/-
Copyright (c) 2022 Floris van Doorn, Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Heather Macbeth
-/
import geometry.manifold.cont_mdiff

/-! # The groupoid of smooth, fiberwise-linear maps

This file contains preliminaries for the definition of a smooth vector bundle: an associated
`structure_groupoid`, the groupoid of `smooth_fiberwise_linear` functions.
-/

noncomputable theory

open set topological_space
open_locale manifold topology

/-! ### The groupoid of smooth, fiberwise-linear maps -/

variables {𝕜 B F : Type*} [topological_space B]
variables [nontrivially_normed_field 𝕜] [normed_add_comm_group F] [normed_space 𝕜 F]

namespace fiberwise_linear

variables {φ φ' : B → F ≃L[𝕜] F} {U U' : set B}

/-- For `B` a topological space and `F` a `𝕜`-normed space, a map from `U : set B` to `F ≃L[𝕜] F`
determines a local homeomorphism from `B × F` to itself by its action fiberwise. -/
def local_homeomorph (φ : B → F ≃L[𝕜] F) (hU : is_open U)
  (hφ : continuous_on (λ x, φ x : B → F →L[𝕜] F) U)
  (h2φ : continuous_on (λ x, (φ x).symm : B → F →L[𝕜] F) U) :
  local_homeomorph (B × F) (B × F) :=
{ to_fun := λ x, (x.1, φ x.1 x.2),
  inv_fun := λ x, (x.1, (φ x.1).symm x.2),
  source := U ×ˢ univ,
  target := U ×ˢ univ,
  map_source' := λ x hx, mk_mem_prod hx.1 (mem_univ _),
  map_target' := λ x hx, mk_mem_prod hx.1 (mem_univ _),
  left_inv' := λ x _, prod.ext rfl (continuous_linear_equiv.symm_apply_apply _ _),
  right_inv' := λ x _, prod.ext rfl (continuous_linear_equiv.apply_symm_apply _ _),
  open_source := hU.prod is_open_univ,
  open_target := hU.prod is_open_univ,
  continuous_to_fun := begin
    have : continuous_on (λ p : B × F, ((φ p.1 : F →L[𝕜] F), p.2)) (U ×ˢ univ),
    { exact hφ.prod_map continuous_on_id },
    exact continuous_on_fst.prod (is_bounded_bilinear_map_apply.continuous.comp_continuous_on this),
  end,
  continuous_inv_fun := begin
    have : continuous_on (λ p : B × F, (((φ p.1).symm : F →L[𝕜] F), p.2)) (U ×ˢ univ),
    { exact h2φ.prod_map continuous_on_id },
    exact continuous_on_fst.prod (is_bounded_bilinear_map_apply.continuous.comp_continuous_on this),
  end, }

/-- Compute the composition of two local homeomorphisms induced by fiberwise linear
equivalences. -/
lemma trans_local_homeomorph_apply
  (hU : is_open U)
  (hφ : continuous_on (λ x, φ x : B → F →L[𝕜] F) U)
  (h2φ : continuous_on (λ x, (φ x).symm : B → F →L[𝕜] F) U)
  (hU' : is_open U')
  (hφ' : continuous_on (λ x, φ' x : B → F →L[𝕜] F) U')
  (h2φ' : continuous_on (λ x, (φ' x).symm : B → F →L[𝕜] F) U')
  (b : B) (v : F) :
  (fiberwise_linear.local_homeomorph φ hU hφ h2φ ≫ₕ
    fiberwise_linear.local_homeomorph φ' hU' hφ' h2φ') ⟨b, v⟩ = ⟨b, φ' b (φ b v)⟩ :=
rfl

/-- Compute the source of the composition of two local homeomorphisms induced by fiberwise linear
equivalences. -/
lemma source_trans_local_homeomorph
  (hU : is_open U)
  (hφ : continuous_on (λ x, φ x : B → F →L[𝕜] F) U)
  (h2φ : continuous_on (λ x, (φ x).symm : B → F →L[𝕜] F) U)
  (hU' : is_open U')
  (hφ' : continuous_on (λ x, φ' x : B → F →L[𝕜] F) U')
  (h2φ' : continuous_on (λ x, (φ' x).symm : B → F →L[𝕜] F) U') :
  (fiberwise_linear.local_homeomorph φ hU hφ h2φ ≫ₕ
    fiberwise_linear.local_homeomorph φ' hU' hφ' h2φ').source = (U ∩ U') ×ˢ univ :=
by { dsimp only [fiberwise_linear.local_homeomorph], mfld_set_tac }

/-- Compute the target of the composition of two local homeomorphisms induced by fiberwise linear
equivalences. -/
lemma target_trans_local_homeomorph
  (hU : is_open U)
  (hφ : continuous_on (λ x, φ x : B → F →L[𝕜] F) U)
  (h2φ : continuous_on (λ x, (φ x).symm : B → F →L[𝕜] F) U)
  (hU' : is_open U')
  (hφ' : continuous_on (λ x, φ' x : B → F →L[𝕜] F) U')
  (h2φ' : continuous_on (λ x, (φ' x).symm : B → F →L[𝕜] F) U') :
  (fiberwise_linear.local_homeomorph φ hU hφ h2φ ≫ₕ
    fiberwise_linear.local_homeomorph φ' hU' hφ' h2φ').target = (U ∩ U') ×ˢ univ :=
by { dsimp only [fiberwise_linear.local_homeomorph], mfld_set_tac }

end fiberwise_linear

variables {EB : Type*} [normed_add_comm_group EB] [normed_space 𝕜 EB]
  {HB : Type*} [topological_space HB] [charted_space HB B] {IB : model_with_corners 𝕜 EB HB}

/-- Let `e` be a local homeomorphism of `B × F`.  Suppose that at every point `p` in the source of
`e`, there is some neighbourhood `s` of `p` on which `e` is equal to a bi-smooth fiberwise linear
local homeomorphism.
Then the source of `e` is of the form `U ×ˢ univ`, for some set `U` in `B`, and, at any point `x` in
`U`, admits a neighbourhood `u` of `x` such that `e` is equal on `u ×ˢ univ` to some bi-smooth
fiberwise linear local homeomorphism. -/
lemma smooth_fiberwise_linear.locality_aux₁ (e : local_homeomorph (B × F) (B × F))
  (h : ∀ p ∈ e.source, ∃ s : set (B × F), is_open s ∧ p ∈ s ∧
    ∃ (φ : B → (F ≃L[𝕜] F)) (u : set B) (hu : is_open u)
      (hφ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ x, (φ x : F →L[𝕜] F)) u)
      (h2φ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ x, ((φ x).symm : F →L[𝕜] F)) u),
      (e.restr s).eq_on_source
        (fiberwise_linear.local_homeomorph φ hu hφ.continuous_on h2φ.continuous_on)) :
  ∃ (U : set B) (hU : e.source = U ×ˢ univ),
  ∀ x ∈ U, ∃ (φ : B → (F ≃L[𝕜] F)) (u : set B) (hu : is_open u) (huU : u ⊆ U) (hux : x ∈ u)
    (hφ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ x, (φ x : F →L[𝕜] F)) u)
    (h2φ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ x, ((φ x).symm : F →L[𝕜] F)) u),
    (e.restr (u ×ˢ univ)).eq_on_source
      (fiberwise_linear.local_homeomorph φ hu hφ.continuous_on h2φ.continuous_on) :=
begin
  rw [set_coe.forall'] at h,
  -- choose s hs hsp φ u hu hφ h2φ heφ using h,
  -- the following 2 lines should be `choose s hs hsp φ u hu hφ h2φ heφ using h,`
  -- `choose` produces a proof term that takes a long time to type-check by the kernel (it seems)
  -- porting note: todo: try using `choose` again in Lean 4
  simp only [classical.skolem, ← exists_prop] at h,
  rcases h with ⟨s, hs, hsp, φ, u, hu, hφ, h2φ, heφ⟩,
  have hesu : ∀ p : e.source, e.source ∩ s p = u p ×ˢ univ,
  { intros p,
    rw ← e.restr_source' (s _) (hs _),
    exact (heφ p).1 },
  have hu' : ∀ p : e.source, (p : B × F).fst ∈ u p,
  { intros p,
    have : (p : B × F) ∈ e.source ∩ s p := ⟨p.prop, hsp p⟩,
    simpa only [hesu, mem_prod, mem_univ, and_true] using this },
  have heu : ∀ p : e.source, ∀ q : B × F, q.fst ∈ u p → q ∈ e.source,
  { intros p q hq,
    have : q ∈ u p ×ˢ (univ : set F) := ⟨hq, trivial⟩,
    rw ← hesu p at this,
    exact this.1 },
  have he : e.source = (prod.fst '' e.source) ×ˢ (univ : set F),
  { apply has_subset.subset.antisymm,
    { intros p hp,
      exact ⟨⟨p, hp, rfl⟩, trivial⟩ },
    { rintros ⟨x, v⟩ ⟨⟨p, hp, rfl : p.fst = x⟩, -⟩,
      exact heu ⟨p, hp⟩ (p.fst, v) (hu' ⟨p, hp⟩) } },
  refine ⟨prod.fst '' e.source, he, _⟩,
  rintros x ⟨p, hp, rfl⟩,
  refine ⟨φ ⟨p, hp⟩, u ⟨p, hp⟩, hu ⟨p, hp⟩, _, hu' _, hφ ⟨p, hp⟩, h2φ ⟨p, hp⟩, _⟩,
  { intros y hy, refine ⟨(y, 0), heu ⟨p, hp⟩ ⟨_, _⟩ hy, rfl⟩ },
  { rw [← hesu, e.restr_source_inter], exact heφ ⟨p, hp⟩ },
end

/-- Let `e` be a local homeomorphism of `B × F` whose source is `U ×ˢ univ`, for some set `U` in
`B`, and which, at any point `x` in `U`, admits a neighbourhood `u` of `x` such that `e` is equal on
`u ×ˢ univ` to some bi-smooth fiberwise linear local homeomorphism.  Then `e` itself is equal to
some bi-smooth fiberwise linear local homeomorphism.

This is the key mathematical point of the `locality` condition in the construction of the
`structure_groupoid` of bi-smooth fiberwise linear local homeomorphisms.  The proof is by gluing
together the various bi-smooth fiberwise linear local homeomorphism which exist locally.

The `U` in the conclusion is the same `U` as in the hypothesis. We state it like this, because this
is exactly what we need for `smooth_fiberwise_linear`. -/
lemma smooth_fiberwise_linear.locality_aux₂ (e : local_homeomorph (B × F) (B × F))
  (U : set B) (hU : e.source = U ×ˢ univ)
  (h : ∀ x ∈ U, ∃ (φ : B → (F ≃L[𝕜] F)) (u : set B) (hu : is_open u) (hUu : u ⊆ U) (hux : x ∈ u)
    (hφ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ x, (φ x : F →L[𝕜] F)) u)
    (h2φ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ x, ((φ x).symm : F →L[𝕜] F)) u),
    (e.restr (u ×ˢ univ)).eq_on_source
      (fiberwise_linear.local_homeomorph φ hu hφ.continuous_on h2φ.continuous_on)) :
  ∃ (Φ : B → (F ≃L[𝕜] F)) (U : set B) (hU₀ : is_open U)
    (hΦ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ x, (Φ x : F →L[𝕜] F)) U)
    (h2Φ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ x, ((Φ x).symm : F →L[𝕜] F)) U),
    e.eq_on_source (fiberwise_linear.local_homeomorph Φ hU₀ hΦ.continuous_on h2Φ.continuous_on) :=
begin
  classical,
  rw set_coe.forall' at h,
  choose! φ u hu hUu hux hφ h2φ heφ using h,
  have heuφ : ∀ x : U, eq_on e (λ q, (q.1, φ x q.1 q.2)) (u x ×ˢ univ),
  { intros x p hp,
    refine (heφ x).2 _,
    rw (heφ x).1,
    exact hp },
  have huφ : ∀ (x x' : U) (y : B) (hyx : y ∈ u x) (hyx' : y ∈ u x'), φ x y = φ x' y,
  { intros p p' y hyp hyp',
    ext v,
    have h1 : e (y, v) = (y, φ p y v) := heuφ _ ⟨(id hyp : (y, v).fst ∈ u p), trivial⟩,
    have h2 : e (y, v) = (y, φ p' y v) := heuφ _ ⟨(id hyp' : (y, v).fst ∈ u p'), trivial⟩,
    exact congr_arg prod.snd (h1.symm.trans h2) },
  have hUu' : U = ⋃ i, u i,
  { ext x,
    rw mem_Union,
    refine ⟨λ h, ⟨⟨x, h⟩, hux _⟩, _⟩,
    rintros ⟨x, hx⟩,
    exact hUu x hx },
  have hU' : is_open U,
  { rw hUu',
    apply is_open_Union hu },
  let Φ₀ : U → F ≃L[𝕜] F := Union_lift u (λ x, (φ x) ∘ coe) huφ U hUu'.le,
  let Φ : B → F ≃L[𝕜] F := λ y, if hy : y ∈ U then Φ₀ ⟨y, hy⟩ else continuous_linear_equiv.refl 𝕜 F,
  have hΦ : ∀ (y) (hy : y ∈ U), Φ y = Φ₀ ⟨y, hy⟩ := λ y hy, dif_pos hy,
  have hΦφ : ∀ x : U, ∀ y ∈ u x, Φ y = φ x y,
  { intros x y hyu,
    refine (hΦ y (hUu x hyu)).trans _,
    exact Union_lift_mk ⟨y, hyu⟩ _ },
  have hΦ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ y, (Φ y : F →L[𝕜] F)) U,
  { apply cont_mdiff_on_of_locally_cont_mdiff_on,
    intros x hx,
    refine ⟨u ⟨x, hx⟩, hu ⟨x, hx⟩, hux _, _⟩,
    refine (cont_mdiff_on.congr (hφ ⟨x, hx⟩) _).mono (inter_subset_right _ _),
    intros y hy,
    rw hΦφ ⟨x, hx⟩ y hy },
  have h2Φ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ y, ((Φ y).symm : F →L[𝕜] F)) U,
  { apply cont_mdiff_on_of_locally_cont_mdiff_on,
    intros x hx,
    refine ⟨u ⟨x, hx⟩, hu ⟨x, hx⟩, hux _, _⟩,
    refine (cont_mdiff_on.congr (h2φ ⟨x, hx⟩) _).mono (inter_subset_right _ _),
    intros y hy,
    rw hΦφ ⟨x, hx⟩ y hy },
  refine ⟨Φ, U, hU', hΦ, h2Φ, hU, λ p hp, _⟩,
  rw [hU] at hp,
  -- using rw on the next line seems to cause a timeout in kernel type-checking
  refine (heuφ ⟨p.fst, hp.1⟩ ⟨hux _, hp.2⟩).trans _,
  congrm (_, _),
  rw hΦφ,
  apply hux
end

variables (F B IB)
/-- For `B` a manifold and `F` a normed space, the groupoid on `B × F` consisting of local
homeomorphisms which are bi-smooth and fiberwise linear, and induce the identity on `B`.
When a (topological) vector bundle is smooth, then the composition of charts associated
to the vector bundle belong to this groupoid. -/
def smooth_fiberwise_linear : structure_groupoid (B × F) :=
{ members := ⋃ (φ : B → F ≃L[𝕜] F) (U : set B) (hU : is_open U)
  (hφ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ x, φ x : B → F →L[𝕜] F) U)
  (h2φ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ x, (φ x).symm : B → F →L[𝕜] F) U),
  {e | e.eq_on_source (fiberwise_linear.local_homeomorph φ hU hφ.continuous_on h2φ.continuous_on)},
  trans' := begin
    simp_rw [mem_Union],
    rintros e e' ⟨φ, U, hU, hφ, h2φ, heφ⟩ ⟨φ', U', hU', hφ', h2φ', heφ'⟩,
    refine ⟨λ b, (φ b).trans (φ' b), _, hU.inter hU', _, _, setoid.trans (heφ.trans' heφ') ⟨_, _⟩⟩,
    { show smooth_on IB 𝓘(𝕜, F →L[𝕜] F)
        (λ (x : B), (φ' x).to_continuous_linear_map ∘L (φ x).to_continuous_linear_map) (U ∩ U'),
      exact (hφ'.mono $ inter_subset_right _ _).clm_comp (hφ.mono $ inter_subset_left _ _) },
    { show smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ (x : B),
        (φ x).symm.to_continuous_linear_map ∘L (φ' x).symm.to_continuous_linear_map) (U ∩ U'),
      exact (h2φ.mono $ inter_subset_left _ _).clm_comp (h2φ'.mono $ inter_subset_right _ _) },
    { apply fiberwise_linear.source_trans_local_homeomorph },
    { rintros ⟨b, v⟩ hb, apply fiberwise_linear.trans_local_homeomorph_apply }
  end,
  symm' := begin
    simp_rw [mem_Union],
    rintros e ⟨φ, U, hU, hφ, h2φ, heφ⟩,
    refine ⟨λ b, (φ b).symm, U, hU, h2φ, _, heφ.symm'⟩,
    simp_rw continuous_linear_equiv.symm_symm,
    exact hφ
  end,
  id_mem' := begin
    simp_rw [mem_Union],
    refine ⟨λ b, continuous_linear_equiv.refl 𝕜 F, univ, is_open_univ, _, _, ⟨_, λ b hb, _⟩⟩,
    { apply cont_mdiff_on_const },
    { apply cont_mdiff_on_const },
    { simp only [fiberwise_linear.local_homeomorph, local_homeomorph.refl_local_equiv,
        local_equiv.refl_source, univ_prod_univ] },
    { simp only [fiberwise_linear.local_homeomorph, local_homeomorph.refl_apply, prod.mk.eta,
        id.def, continuous_linear_equiv.coe_refl', local_homeomorph.mk_coe, local_equiv.coe_mk] },
  end,
  locality' := begin -- the hard work has been extracted to `locality_aux₁` and `locality_aux₂`
    simp_rw [mem_Union],
    intros e he,
    obtain ⟨U, hU, h⟩ := smooth_fiberwise_linear.locality_aux₁ e he,
    exact smooth_fiberwise_linear.locality_aux₂ e U hU h,
  end,
  eq_on_source' := begin
    simp_rw [mem_Union],
    rintros e e' ⟨φ, U, hU, hφ, h2φ, heφ⟩ hee',
    exact ⟨φ, U, hU, hφ, h2φ, setoid.trans hee' heφ⟩,
  end }

@[simp] lemma mem_smooth_fiberwise_linear_iff (e : local_homeomorph (B × F) (B × F)) :
  e ∈ smooth_fiberwise_linear B F IB ↔
  ∃ (φ : B → F ≃L[𝕜] F) (U : set B) (hU : is_open U)
  (hφ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ x, φ x : B → F →L[𝕜] F) U)
  (h2φ : smooth_on IB 𝓘(𝕜, F →L[𝕜] F) (λ x, (φ x).symm : B → F →L[𝕜] F) U),
  e.eq_on_source (fiberwise_linear.local_homeomorph φ hU hφ.continuous_on h2φ.continuous_on) :=
show e ∈ set.Union _ ↔ _, by { simp only [mem_Union], refl }


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang

! This file was ported from Lean 3 source module algebraic_geometry.morphisms.ring_hom_properties
! leanprover-community/mathlib commit d39590fc8728fbf6743249802486f8c91ffe07bc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.AlgebraicGeometry.Morphisms.Basic
import Mathbin.RingTheory.LocalProperties

/-!

# Properties of morphisms from properties of ring homs.

We provide the basic framework for talking about properties of morphisms that come from properties
of ring homs. For `P` a property of ring homs, we have two ways of defining a property of scheme
morphisms:

Let `f : X ⟶ Y`,
- `target_affine_locally (affine_and P)`: the preimage of an affine open `U = Spec A` is affine
  (`= Spec B`) and `A ⟶ B` satisfies `P`. (TODO)
- `affine_locally P`: For each pair of affine open `U = Spec A ⊆ X` and `V = Spec B ⊆ f ⁻¹' U`,
  the ring hom `A ⟶ B` satisfies `P`.

For these notions to be well defined, we require `P` be a sufficient local property. For the former,
`P` should be local on the source (`ring_hom.respects_iso P`, `ring_hom.localization_preserves P`,
`ring_hom.of_localization_span`), and `target_affine_locally (affine_and P)` will be local on
the target. (TODO)

For the latter `P` should be local on the target (`ring_hom.property_is_local P`), and
`affine_locally P` will be local on both the source and the target.

Further more, these properties are stable under compositions (resp. base change) if `P` is. (TODO)

-/

universe u

open CategoryTheory Opposite TopologicalSpace CategoryTheory.Limits AlgebraicGeometry

variable (P : ∀ {R S : Type u} [CommRing R] [CommRing S] (f : R →+* S), Prop)

namespace RingHom

include P

variable {P}

theorem RespectsIso.basicOpen_iff (hP : RespectsIso @P) {X Y : Scheme} [IsAffine X] [IsAffine Y]
    (f : X ⟶ Y) (r : Y.Presheaf.obj (Opposite.op ⊤)) :
    P (Scheme.Γ.map (f ∣_ Y.basicOpen r).op) ↔
      P
        (@IsLocalization.Away.map (Y.Presheaf.obj (Opposite.op ⊤)) _
          (Y.Presheaf.obj (Opposite.op <| Y.basicOpen r)) _ _ (X.Presheaf.obj (Opposite.op ⊤)) _
          (X.Presheaf.obj (Opposite.op <| X.basicOpen (Scheme.Γ.map f.op r))) _ _
          (Scheme.Γ.map f.op) r _ _) :=
  by
  rw [Γ_map_morphism_restrict, hP.cancel_left_is_iso, hP.cancel_right_is_iso, ←
    hP.cancel_right_is_iso (f.val.c.app (Opposite.op (Y.basic_open r)))
      (X.presheaf.map (eq_to_hom (Scheme.preimage_basic_open f r).symm).op),
    ← eq_iff_iff]
  congr
  delta IsLocalization.Away.map
  refine' IsLocalization.ringHom_ext (Submonoid.powers r) _
  convert(IsLocalization.map_comp _).symm using 1
  change Y.presheaf.map _ ≫ _ = _ ≫ X.presheaf.map _
  rw [f.val.c.naturality_assoc]
  erw [← X.presheaf.map_comp]
  congr
#align ring_hom.respects_iso.basic_open_iff RingHom.RespectsIso.basicOpen_iff

theorem RespectsIso.basicOpen_iff_localization (hP : RespectsIso @P) {X Y : Scheme} [IsAffine X]
    [IsAffine Y] (f : X ⟶ Y) (r : Y.Presheaf.obj (Opposite.op ⊤)) :
    P (Scheme.Γ.map (f ∣_ Y.basicOpen r).op) ↔ P (Localization.awayMap (Scheme.Γ.map f.op) r) :=
  (hP.basicOpen_iff _ _).trans (hP.is_localization_away_iff _ _ _ _).symm
#align ring_hom.respects_iso.basic_open_iff_localization RingHom.RespectsIso.basicOpen_iff_localization

theorem RespectsIso.ofRestrict_morphismRestrict_iff (hP : RingHom.RespectsIso @P) {X Y : Scheme}
    [IsAffine Y] (f : X ⟶ Y) (r : Y.Presheaf.obj (Opposite.op ⊤)) (U : Opens X.carrier)
    (hU : IsAffineOpen U) {V : Opens _}
    (e : V = (Opens.map (X.of_restrict ((Opens.map f.1.base).obj _).OpenEmbedding).1.base).obj U) :
    P
        (Scheme.Γ.map
          ((X.restrict ((Opens.map f.1.base).obj _).OpenEmbedding).of_restrict V.OpenEmbedding ≫
              f ∣_ Y.basicOpen r).op) ↔
      P (Localization.awayMap (Scheme.Γ.map (X.of_restrict U.OpenEmbedding ≫ f).op) r) :=
  by
  subst e
  convert(hP.is_localization_away_iff _ _ _ _).symm
  rotate_left
  · infer_instance
  · apply RingHom.toAlgebra
    refine'
      X.presheaf.map
        (@hom_of_le _ _ ((IsOpenMap.functor _).obj _) ((IsOpenMap.functor _).obj _) _).op
    rw [← SetLike.coe_subset_coe]
    dsimp
    simp only [Set.image_univ, Subtype.range_coe, Set.image_subset_iff]
    rfl
  · exact AlgebraicGeometry.Γ_restrict_is_localization Y r
  · rw [← U.open_embedding_obj_top] at hU
    dsimp [Scheme.Γ_obj_op, Scheme.Γ_map_op, Scheme.restrict]
    apply AlgebraicGeometry.is_localization_of_eq_basicOpen _ hU
    rw [opens.open_embedding_obj_top, opens.functor_obj_map_obj]
    convert(X.basic_open_res (Scheme.Γ.map f.op r) (hom_of_le le_top).op).symm using 1
    rw [opens.open_embedding_obj_top, opens.open_embedding_obj_top, inf_comm, Scheme.Γ_map_op, ←
      Scheme.preimage_basic_open]
  · apply IsLocalization.ringHom_ext (Submonoid.powers r) _
    swap
    · exact AlgebraicGeometry.Γ_restrict_is_localization Y r
    rw [IsLocalization.Away.map, IsLocalization.map_comp, RingHom.algebraMap_toAlgebra,
      RingHom.algebraMap_toAlgebra, op_comp, functor.map_comp, op_comp, functor.map_comp]
    refine' (@category.assoc CommRingCat _ _ _ _ _ _ _ _).symm.trans _
    refine' Eq.trans _ (@category.assoc CommRingCat _ _ _ _ _ _ _ _)
    dsimp only [Scheme.Γ_map, Quiver.Hom.unop_op]
    rw [morphism_restrict_c_app, category.assoc, category.assoc, category.assoc]
    erw [f.1.c.naturality_assoc, ← X.presheaf.map_comp, ← X.presheaf.map_comp, ←
      X.presheaf.map_comp]
    congr
#align ring_hom.respects_iso.of_restrict_morphism_restrict_iff RingHom.RespectsIso.ofRestrict_morphismRestrict_iff

theorem StableUnderBaseChange.ΓPullbackFst (hP : StableUnderBaseChange @P) (hP' : RespectsIso @P)
    {X Y S : Scheme} [IsAffine X] [IsAffine Y] [IsAffine S] (f : X ⟶ S) (g : Y ⟶ S)
    (H : P (Scheme.Γ.map g.op)) : P (Scheme.Γ.map (pullback.fst : pullback f g ⟶ _).op) :=
  by
  rw [←
    preserves_pullback.iso_inv_fst AffineScheme.forget_to_Scheme (AffineScheme.of_hom f)
      (AffineScheme.of_hom g),
    op_comp, functor.map_comp, hP'.cancel_right_is_iso, AffineScheme.forget_to_Scheme_map]
  have :=
    _root_.congr_arg Quiver.Hom.unop
      (preserves_pullback.iso_hom_fst AffineScheme.Γ.right_op (AffineScheme.of_hom f)
        (AffineScheme.of_hom g))
  simp only [Quiver.Hom.unop_op, functor.right_op_map, unop_comp] at this
  delta AffineScheme.Γ at this
  simp only [Quiver.Hom.unop_op, functor.comp_map, AffineScheme.forget_to_Scheme_map,
    functor.op_map] at this
  rw [← this, hP'.cancel_right_is_iso, ←
    pushout_iso_unop_pullback_inl_hom (Quiver.Hom.unop _) (Quiver.Hom.unop _),
    hP'.cancel_right_is_iso]
  exact hP.pushout_inl _ hP' _ _ H
#align ring_hom.stable_under_base_change.Γ_pullback_fst RingHom.StableUnderBaseChange.ΓPullbackFst

end RingHom

namespace AlgebraicGeometry

/-- For `P` a property of ring homomorphisms, `source_affine_locally P` holds for `f : X ⟶ Y`
whenever `P` holds for the restriction of `f` on every affine open subset of `X`. -/
def sourceAffineLocally : AffineTargetMorphismProperty := fun X Y f hY =>
  ∀ U : X.affineOpens, P (Scheme.Γ.map (X.of_restrict U.1.OpenEmbedding ≫ f).op)
#align algebraic_geometry.source_affine_locally AlgebraicGeometry.sourceAffineLocally

/-- For `P` a property of ring homomorphisms, `affine_locally P` holds for `f : X ⟶ Y` if for each
affine open `U = Spec A ⊆ Y` and `V = Spec B ⊆ f ⁻¹' U`, the ring hom `A ⟶ B` satisfies `P`.
Also see `affine_locally_iff_affine_opens_le`. -/
abbrev affineLocally : MorphismProperty Scheme :=
  targetAffineLocally (sourceAffineLocally @P)
#align algebraic_geometry.affine_locally AlgebraicGeometry.affineLocally

variable {P}

theorem sourceAffineLocally_respectsIso (h₁ : RingHom.RespectsIso @P) :
    (sourceAffineLocally @P).toProperty.RespectsIso :=
  by
  apply affine_target_morphism_property.respects_iso_mk
  · introv H U
    rw [← h₁.cancel_right_is_iso _ (Scheme.Γ.map (Scheme.restrict_map_iso e.inv U.1).Hom.op), ←
      functor.map_comp, ← op_comp]
    convert H ⟨_, U.prop.map_is_iso e.inv⟩ using 3
    rw [is_open_immersion.iso_of_range_eq_hom, is_open_immersion.lift_fac_assoc, category.assoc,
      e.inv_hom_id_assoc]
    rfl
  · introv H U
    rw [← category.assoc, op_comp, functor.map_comp, h₁.cancel_left_is_iso]
    exact H U
#align algebraic_geometry.source_affine_locally_respects_iso AlgebraicGeometry.sourceAffineLocally_respectsIso

theorem affineLocally_respectsIso (h : RingHom.RespectsIso @P) : (affineLocally @P).RespectsIso :=
  targetAffineLocally_respectsIso (sourceAffineLocally_respectsIso h)
#align algebraic_geometry.affine_locally_respects_iso AlgebraicGeometry.affineLocally_respectsIso

theorem affineLocally_iff_affineOpens_le (hP : RingHom.RespectsIso @P) {X Y : Scheme} (f : X ⟶ Y) :
    affineLocally (@P) f ↔
      ∀ (U : Y.affineOpens) (V : X.affineOpens) (e : V.1 ≤ (Opens.map f.1.base).obj U.1),
        P (f.appLe e) :=
  by
  apply forall_congr'
  intro U
  delta source_affine_locally
  simp_rw [op_comp, Scheme.Γ.map_comp, Γ_map_morphism_restrict, category.assoc, Scheme.Γ_map_op,
    hP.cancel_left_is_iso]
  constructor
  · intro H V e
    let U' := (opens.map f.val.base).obj U.1
    have e' : U'.open_embedding.is_open_map.functor.obj ((opens.map U'.inclusion).obj V.1) = V.1 :=
      by
      ext1
      refine' set.image_preimage_eq_inter_range.trans (set.inter_eq_left_iff_subset.mpr _)
      convert e
      exact Subtype.range_coe
    have := H ⟨(opens.map (X.of_restrict U'.open_embedding).1.base).obj V.1, _⟩
    erw [← X.presheaf.map_comp] at this
    rw [← hP.cancel_right_is_iso _ (X.presheaf.map (eq_to_hom _)), category.assoc, ←
      X.presheaf.map_comp]
    convert this using 1
    · dsimp only [functor.op, unop_op]
      rw [opens.open_embedding_obj_top]
      congr 1
      exact e'.symm
    · infer_instance
    · apply (is_affine_open_iff_of_is_open_immersion (X.of_restrict _) _).mp
      convert V.2
      infer_instance
  · intro H V
    specialize H ⟨_, V.2.image_isOpenImmersion (X.of_restrict _)⟩ (Subtype.coe_image_subset _ _)
    erw [← X.presheaf.map_comp]
    rw [← hP.cancel_right_is_iso _ (X.presheaf.map (eq_to_hom _)), category.assoc, ←
      X.presheaf.map_comp]
    convert H
    · dsimp only [functor.op, unop_op]
      rw [opens.open_embedding_obj_top]
      rfl
    · infer_instance
#align algebraic_geometry.affine_locally_iff_affine_opens_le AlgebraicGeometry.affineLocally_iff_affineOpens_le

theorem schemeRestrictBasicOpenOfLocalizationPreserves (h₁ : RingHom.RespectsIso @P)
    (h₂ : RingHom.LocalizationPreserves @P) {X Y : Scheme} [IsAffine Y] (f : X ⟶ Y)
    (r : Y.Presheaf.obj (op ⊤)) (H : sourceAffineLocally (@P) f)
    (U : (X.restrict ((Opens.map f.1.base).obj <| Y.basicOpen r).OpenEmbedding).affineOpens) :
    P
      (Scheme.Γ.map
        ((X.restrict ((Opens.map f.1.base).obj <| Y.basicOpen r).OpenEmbedding).of_restrict
              U.1.OpenEmbedding ≫
            f ∣_ Y.basicOpen r).op) :=
  by
  specialize H ⟨_, U.2.image_isOpenImmersion (X.of_restrict _)⟩
  convert(h₁.of_restrict_morphism_restrict_iff _ _ _ _ _).mpr _ using 1
  pick_goal 5
  · exact h₂.away r H
  · infer_instance
  · exact U.2.image_isOpenImmersion _
  · ext1
    exact (Set.preimage_image_eq _ Subtype.coe_injective).symm
#align algebraic_geometry.Scheme_restrict_basic_open_of_localization_preserves AlgebraicGeometry.schemeRestrictBasicOpenOfLocalizationPreserves

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (V «expr = » (opens.map f.val.base).obj (Y.basic_open r.val)) -/
theorem sourceAffineLocallyIsLocal (h₁ : RingHom.RespectsIso @P)
    (h₂ : RingHom.LocalizationPreserves @P) (h₃ : RingHom.OfLocalizationSpan @P) :
    (sourceAffineLocally @P).IsLocal := by
  constructor
  · exact source_affine_locally_respects_iso h₁
  · introv H U
    apply Scheme_restrict_basic_open_of_localization_preserves h₁ h₂ <;> assumption
  · introv hs hs' U
    skip
    apply h₃ _ _ hs
    intro r
    have := hs' r ⟨(opens.map (X.of_restrict _).1.base).obj U.1, _⟩
    rwa [h₁.of_restrict_morphism_restrict_iff] at this
    · exact U.2
    · rfl
    · infer_instance
    · suffices
        ∀ (V) (_ : V = (opens.map f.val.base).obj (Y.basic_open r.val)),
          is_affine_open ((opens.map (X.of_restrict V.OpenEmbedding).1.base).obj U.1)
        by exact this _ rfl
      intro V hV
      rw [Scheme.preimage_basic_open] at hV
      subst hV
      exact U.2.map_restrict_basicOpen (Scheme.Γ.map f.op r.1)
#align algebraic_geometry.source_affine_locally_is_local AlgebraicGeometry.sourceAffineLocallyIsLocal

variable {P} (hP : RingHom.PropertyIsLocal @P)

theorem source_affine_locally_of_source_open_cover_aux (h₁ : RingHom.RespectsIso @P)
    (h₃ : RingHom.OfLocalizationSpanTarget @P) {X Y : Scheme} (f : X ⟶ Y) (U : X.affineOpens)
    (s : Set (X.Presheaf.obj (op U.1))) (hs : Ideal.span s = ⊤)
    (hs' : ∀ r : s, P (Scheme.Γ.map (X.of_restrict (X.basicOpen r.1).OpenEmbedding ≫ f).op)) :
    P (Scheme.Γ.map (X.of_restrict U.1.OpenEmbedding ≫ f).op) :=
  by
  apply_fun Ideal.map (X.presheaf.map (eq_to_hom U.1.openEmbedding_obj_top).op)  at hs
  rw [Ideal.map_span, Ideal.map_top] at hs
  apply h₃ _ _ hs
  rintro ⟨s, r, hr, hs⟩
  have :=
    (@Localization.algEquiv _ _ _ _ _
          (@AlgebraicGeometry.Γ_restrict_is_localization _ U.2 s)).toRingEquiv.toCommRingIso
  refine'
    (h₁.cancel_right_is_iso _
          (@Localization.algEquiv _ _ _ _ _
                  (@AlgebraicGeometry.Γ_restrict_is_localization _ U.2
                    s)).toRingEquiv.toCommRingIso.Hom).mp
      _
  subst hs
  rw [CommRingCat.comp_eq_ring_hom_comp, ← RingHom.comp_assoc]
  erw [IsLocalization.map_comp, RingHom.comp_id]
  rw [RingHom.algebraMap_toAlgebra, op_comp, functor.map_comp, ← CommRingCat.comp_eq_ring_hom_comp,
    Scheme.Γ_map_op, Scheme.Γ_map_op, Scheme.Γ_map_op, category.assoc]
  erw [← X.presheaf.map_comp]
  rw [← h₁.cancel_right_is_iso _ (X.presheaf.map (eq_to_hom _))]
  convert hs' ⟨r, hr⟩ using 1
  · erw [category.assoc]
    rw [← X.presheaf.map_comp, op_comp, Scheme.Γ.map_comp, Scheme.Γ_map_op, Scheme.Γ_map_op]
    congr
  · dsimp [functor.op]
    conv_lhs => rw [opens.open_embedding_obj_top]
    conv_rhs => rw [opens.open_embedding_obj_top]
    erw [Scheme.image_basic_open (X.of_restrict U.1.OpenEmbedding)]
    erw [PresheafedSpace.is_open_immersion.of_restrict_inv_app_apply]
    rw [Scheme.basic_open_res_eq]
  · infer_instance
#align algebraic_geometry.source_affine_locally_of_source_open_cover_aux AlgebraicGeometry.source_affine_locally_of_source_open_cover_aux

theorem isOpenImmersionCompOfSourceAffineLocally (h₁ : RingHom.RespectsIso @P) {X Y Z : Scheme}
    [IsAffine X] [IsAffine Z] (f : X ⟶ Y) [IsOpenImmersion f] (g : Y ⟶ Z)
    (h₂ : sourceAffineLocally (@P) g) : P (Scheme.Γ.map (f ≫ g).op) :=
  by
  rw [←
    h₁.cancel_right_is_iso _
      (Scheme.Γ.map (is_open_immersion.iso_of_range_eq (Y.of_restrict _) f _).Hom.op),
    ← functor.map_comp, ← op_comp]
  convert h₂ ⟨_, range_is_affine_open_of_open_immersion f⟩ using 3
  · rw [is_open_immersion.iso_of_range_eq_hom, is_open_immersion.lift_fac_assoc]
  · infer_instance
  · exact Subtype.range_coe
  · infer_instance
#align algebraic_geometry.is_open_immersion_comp_of_source_affine_locally AlgebraicGeometry.isOpenImmersionCompOfSourceAffineLocally

end AlgebraicGeometry

open AlgebraicGeometry

namespace RingHom.PropertyIsLocal

variable {P} (hP : RingHom.PropertyIsLocal @P)

include hP

theorem sourceAffineLocallyOfSourceOpenCover {X Y : Scheme} (f : X ⟶ Y) [IsAffine Y]
    (𝒰 : X.OpenCover) [∀ i, IsAffine (𝒰.obj i)] (H : ∀ i, P (Scheme.Γ.map (𝒰.map i ≫ f).op)) :
    sourceAffineLocally (@P) f :=
  by
  let S i :=
    (⟨⟨Set.range (𝒰.map i).1.base, (𝒰.is_open i).base_open.open_range⟩,
        range_is_affine_open_of_open_immersion (𝒰.map i)⟩ :
      X.affine_opens)
  intro U
  apply of_affine_open_cover U
  pick_goal 5; · exact Set.range S
  · intro U r H
    convert hP.stable_under_composition _ _ H _ using 1
    swap
    · refine'
        X.presheaf.map
          (@hom_of_le _ _ ((IsOpenMap.functor _).obj _) ((IsOpenMap.functor _).obj _) _).op
      rw [unop_op, unop_op, opens.open_embedding_obj_top, opens.open_embedding_obj_top]
      exact X.basic_open_le _
    · rw [op_comp, op_comp, functor.map_comp, functor.map_comp]
      refine' (Eq.trans _ (category.assoc _ _ _).symm : _)
      congr 1
      refine' Eq.trans _ (X.presheaf.map_comp _ _)
      change X.presheaf.map _ = _
      congr
    convert hP.holds_for_localization_away _
        (X.presheaf.map (eq_to_hom U.1.openEmbedding_obj_top).op r)
    · exact (RingHom.algebraMap_toAlgebra _).symm
    · dsimp [Scheme.Γ]
      have := U.2
      rw [← U.1.openEmbedding_obj_top] at this
      convert is_localization_basic_open this _ using 6 <;> rw [opens.open_embedding_obj_top] <;>
        exact (Scheme.basic_open_res_eq _ _ _).symm
  · introv hs hs'
    exact source_affine_locally_of_source_open_cover_aux hP.respects_iso hP.2 _ _ _ hs hs'
  · rw [Set.eq_univ_iff_forall]
    intro x
    rw [Set.mem_unionᵢ]
    exact ⟨⟨_, 𝒰.f x, rfl⟩, 𝒰.covers x⟩
  · rintro ⟨_, i, rfl⟩
    specialize H i
    rw [←
      hP.respects_iso.cancel_right_is_iso _
        (Scheme.Γ.map
          (is_open_immersion.iso_of_range_eq (𝒰.map i) (X.of_restrict (S i).1.OpenEmbedding)
                subtype.range_coe.symm).inv.op)] at
      H
    rwa [← Scheme.Γ.map_comp, ← op_comp, is_open_immersion.iso_of_range_eq_inv,
      is_open_immersion.lift_fac_assoc] at H
#align ring_hom.property_is_local.source_affine_locally_of_source_open_cover RingHom.PropertyIsLocal.sourceAffineLocallyOfSourceOpenCover

theorem affine_openCover_tFAE {X Y : Scheme.{u}} [IsAffine Y] (f : X ⟶ Y) :
    TFAE
      [sourceAffineLocally (@P) f,
        ∃ (𝒰 : Scheme.OpenCover.{u} X)(_ : ∀ i, IsAffine (𝒰.obj i)),
          ∀ i : 𝒰.J, P (Scheme.Γ.map (𝒰.map i ≫ f).op),
        ∀ (𝒰 : Scheme.OpenCover.{u} X) [∀ i, IsAffine (𝒰.obj i)] (i : 𝒰.J),
          P (Scheme.Γ.map (𝒰.map i ≫ f).op),
        ∀ {U : Scheme} (g : U ⟶ X) [IsAffine U] [IsOpenImmersion g], P (Scheme.Γ.map (g ≫ f).op)] :=
  by
  tfae_have 1 → 4
  · intro H U g _ hg
    skip
    specialize H ⟨⟨_, hg.base_open.open_range⟩, range_is_affine_open_of_open_immersion g⟩
    rw [←
      hP.respects_iso.cancel_right_is_iso _
        (Scheme.Γ.map
          (is_open_immersion.iso_of_range_eq g
                (X.of_restrict (opens.open_embedding ⟨_, hg.base_open.open_range⟩))
                subtype.range_coe.symm).Hom.op),
      ← Scheme.Γ.map_comp, ← op_comp, is_open_immersion.iso_of_range_eq_hom] at H
    erw [is_open_immersion.lift_fac_assoc] at H
    exact H
  tfae_have 4 → 3
  · intro H 𝒰 _ i
    skip
    apply H
  tfae_have 3 → 2
  · intro H
    refine' ⟨X.affine_cover, inferInstance, H _⟩
  tfae_have 2 → 1
  · rintro ⟨𝒰, _, h𝒰⟩
    exact hP.source_affine_locally_of_source_open_cover f 𝒰 h𝒰
  tfae_finish
#align ring_hom.property_is_local.affine_open_cover_tfae RingHom.PropertyIsLocal.affine_openCover_tFAE

theorem openCover_tFAE {X Y : Scheme.{u}} [IsAffine Y] (f : X ⟶ Y) :
    TFAE
      [sourceAffineLocally (@P) f,
        ∃ 𝒰 : Scheme.OpenCover.{u} X, ∀ i : 𝒰.J, sourceAffineLocally (@P) (𝒰.map i ≫ f),
        ∀ (𝒰 : Scheme.OpenCover.{u} X) (i : 𝒰.J), sourceAffineLocally (@P) (𝒰.map i ≫ f),
        ∀ {U : Scheme} (g : U ⟶ X) [IsOpenImmersion g], sourceAffineLocally (@P) (g ≫ f)] :=
  by
  tfae_have 1 → 4
  · intro H U g hg V
    skip
    rw [(hP.affine_open_cover_tfae f).out 0 3] at H
    haveI : is_affine _ := V.2
    rw [← category.assoc]
    apply H
  tfae_have 4 → 3
  · intro H 𝒰 _ i
    skip
    apply H
  tfae_have 3 → 2
  · intro H
    refine' ⟨X.affine_cover, H _⟩
  tfae_have 2 → 1
  · rintro ⟨𝒰, h𝒰⟩
    rw [(hP.affine_open_cover_tfae f).out 0 1]
    refine' ⟨𝒰.bind fun _ => Scheme.affine_cover _, _, _⟩
    · intro i
      dsimp
      infer_instance
    · intro i
      specialize h𝒰 i.1
      rw [(hP.affine_open_cover_tfae (𝒰.map i.fst ≫ f)).out 0 3] at h𝒰
      erw [category.assoc]
      apply @h𝒰 _ (show _ from _)
      dsimp
      infer_instance
  tfae_finish
#align ring_hom.property_is_local.open_cover_tfae RingHom.PropertyIsLocal.openCover_tFAE

theorem sourceAffineLocallyCompOfIsOpenImmersion {X Y Z : Scheme.{u}} [IsAffine Z] (f : X ⟶ Y)
    (g : Y ⟶ Z) [IsOpenImmersion f] (H : sourceAffineLocally (@P) g) :
    sourceAffineLocally (@P) (f ≫ g) := by apply ((hP.open_cover_tfae g).out 0 3).mp H
#align ring_hom.property_is_local.source_affine_locally_comp_of_is_open_immersion RingHom.PropertyIsLocal.sourceAffineLocallyCompOfIsOpenImmersion

theorem source_affine_openCover_iff {X Y : Scheme.{u}} (f : X ⟶ Y) [IsAffine Y]
    (𝒰 : Scheme.OpenCover.{u} X) [∀ i, IsAffine (𝒰.obj i)] :
    sourceAffineLocally (@P) f ↔ ∀ i, P (Scheme.Γ.map (𝒰.map i ≫ f).op) :=
  ⟨fun H =>
    let h := ((hP.affine_openCover_tFAE f).out 0 2).mp H
    h 𝒰,
    fun H =>
    let h := ((hP.affine_openCover_tFAE f).out 1 0).mp
    h ⟨𝒰, inferInstance, H⟩⟩
#align ring_hom.property_is_local.source_affine_open_cover_iff RingHom.PropertyIsLocal.source_affine_openCover_iff

theorem isLocalSourceAffineLocally : (sourceAffineLocally @P).IsLocal :=
  sourceAffineLocallyIsLocal hP.RespectsIso hP.LocalizationPreserves
    (@RingHom.PropertyIsLocal.ofLocalizationSpan _ hP)
#align ring_hom.property_is_local.is_local_source_affine_locally RingHom.PropertyIsLocal.isLocalSourceAffineLocally

theorem isLocalAffineLocally : PropertyIsLocalAtTarget (affineLocally @P) :=
  hP.isLocalSourceAffineLocally.targetAffineLocallyIsLocal
#align ring_hom.property_is_local.is_local_affine_locally RingHom.PropertyIsLocal.isLocalAffineLocally

theorem affine_openCover_iff {X Y : Scheme.{u}} (f : X ⟶ Y) (𝒰 : Scheme.OpenCover.{u} Y)
    [∀ i, IsAffine (𝒰.obj i)] (𝒰' : ∀ i, Scheme.OpenCover.{u} ((𝒰.pullbackCover f).obj i))
    [∀ i j, IsAffine ((𝒰' i).obj j)] :
    affineLocally (@P) f ↔ ∀ i j, P (Scheme.Γ.map ((𝒰' i).map j ≫ pullback.snd).op) :=
  (hP.isLocalSourceAffineLocally.affine_openCover_iff f 𝒰).trans
    (forall_congr' fun i => hP.source_affine_openCover_iff _ (𝒰' i))
#align ring_hom.property_is_local.affine_open_cover_iff RingHom.PropertyIsLocal.affine_openCover_iff

theorem source_openCover_iff {X Y : Scheme.{u}} (f : X ⟶ Y) (𝒰 : Scheme.OpenCover.{u} X) :
    affineLocally (@P) f ↔ ∀ i, affineLocally (@P) (𝒰.map i ≫ f) :=
  by
  constructor
  · intro H i U
    rw [morphism_restrict_comp]
    delta morphism_restrict
    apply hP.source_affine_locally_comp_of_is_open_immersion
    apply H
  · intro H U
    haveI : is_affine _ := U.2
    apply ((hP.open_cover_tfae (f ∣_ U.1)).out 1 0).mp
    use 𝒰.pullback_cover (X.of_restrict _)
    intro i
    specialize H i U
    rw [morphism_restrict_comp] at H
    delta morphism_restrict at H
    have := source_affine_locally_respects_iso hP.respects_iso
    rw [category.assoc, affine_cancel_left_is_iso this, ←
      affine_cancel_left_is_iso this (pullback_symmetry _ _).Hom,
      pullback_symmetry_hom_comp_snd_assoc] at H
    exact H
#align ring_hom.property_is_local.source_open_cover_iff RingHom.PropertyIsLocal.source_openCover_iff

theorem affineLocally_of_isOpenImmersion (hP : RingHom.PropertyIsLocal @P) {X Y : Scheme}
    (f : X ⟶ Y) [hf : IsOpenImmersion f] : affineLocally (@P) f :=
  by
  intro U
  haveI H : is_affine _ := U.2
  rw [← category.comp_id (f ∣_ U)]
  apply hP.source_affine_locally_comp_of_is_open_immersion
  rw [hP.source_affine_open_cover_iff _ (Scheme.open_cover_of_is_iso (𝟙 _))]
  · intro i
    erw [category.id_comp, op_id, Scheme.Γ.map_id]
    convert hP.holds_for_localization_away _ (1 : Scheme.Γ.obj _)
    · exact (RingHom.algebraMap_toAlgebra _).symm
    · infer_instance
    · refine' IsLocalization.away_of_isUnit_of_bijective _ isUnit_one Function.bijective_id
  · intro i
    exact H
#align ring_hom.property_is_local.affine_locally_of_is_open_immersion RingHom.PropertyIsLocal.affineLocally_of_isOpenImmersion

theorem affineLocally_of_comp
    (H :
      ∀ {R S T : Type u} [CommRing R] [CommRing S] [CommRing T],
        ∀ (f : R →+* S) (g : S →+* T), P (g.comp f) → P g)
    {X Y Z : Scheme} {f : X ⟶ Y} {g : Y ⟶ Z} (h : affineLocally (@P) (f ≫ g)) :
    affineLocally (@P) f :=
  by
  let 𝒰 : ∀ i, ((Z.affine_cover.pullback_cover (f ≫ g)).obj i).OpenCover :=
    by
    intro i
    refine' Scheme.open_cover.bind _ fun i => Scheme.affine_cover _
    apply
      Scheme.open_cover.pushforward_iso _
        (pullback_right_pullback_fst_iso g (Z.affine_cover.map i) f).Hom
    apply Scheme.pullback.open_cover_of_right
    exact (pullback g (Z.affine_cover.map i)).affineCover
  have h𝒰 : ∀ i j, is_affine ((𝒰 i).obj j) := by
    dsimp
    infer_instance
  let 𝒰' := (Z.affine_cover.pullback_cover g).bind fun i => Scheme.affine_cover _
  have h𝒰' : ∀ i, is_affine (𝒰'.obj i) := by
    dsimp
    infer_instance
  rw [hP.affine_open_cover_iff f 𝒰' fun i => Scheme.affine_cover _]
  rw [hP.affine_open_cover_iff (f ≫ g) Z.affine_cover 𝒰] at h
  rintro ⟨i, j⟩ k
  dsimp at i j k
  specialize h i ⟨j, k⟩
  dsimp only [Scheme.open_cover.bind_map, Scheme.open_cover.pushforward_iso_obj,
    Scheme.pullback.open_cover_of_right_obj, Scheme.open_cover.pushforward_iso_map,
    Scheme.pullback.open_cover_of_right_map, Scheme.open_cover.bind_obj,
    Scheme.open_cover.pullback_cover_obj, Scheme.open_cover.pullback_cover_map] at h⊢
  rw [category.assoc, category.assoc, pullback_right_pullback_fst_iso_hom_snd,
    pullback.lift_snd_assoc, category.assoc, ← category.assoc, op_comp, functor.map_comp] at h
  exact H _ _ h
#align ring_hom.property_is_local.affine_locally_of_comp RingHom.PropertyIsLocal.affineLocally_of_comp

theorem affineLocally_stableUnderComposition : (affineLocally @P).StableUnderComposition :=
  by
  intro X Y S f g hf hg
  let 𝒰 : ∀ i, ((S.affine_cover.pullback_cover (f ≫ g)).obj i).OpenCover :=
    by
    intro i
    refine' Scheme.open_cover.bind _ fun i => Scheme.affine_cover _
    apply
      Scheme.open_cover.pushforward_iso _
        (pullback_right_pullback_fst_iso g (S.affine_cover.map i) f).Hom
    apply Scheme.pullback.open_cover_of_right
    exact (pullback g (S.affine_cover.map i)).affineCover
  rw [hP.affine_open_cover_iff (f ≫ g) S.affine_cover _]
  rotate_left
  · exact 𝒰
  · intro i j
    dsimp at *
    infer_instance
  · rintro i ⟨j, k⟩
    dsimp at i j k
    dsimp only [Scheme.open_cover.bind_map, Scheme.open_cover.pushforward_iso_obj,
      Scheme.pullback.open_cover_of_right_obj, Scheme.open_cover.pushforward_iso_map,
      Scheme.pullback.open_cover_of_right_map, Scheme.open_cover.bind_obj]
    rw [category.assoc, category.assoc, pullback_right_pullback_fst_iso_hom_snd,
      pullback.lift_snd_assoc, category.assoc, ← category.assoc, op_comp, functor.map_comp]
    apply hP.stable_under_composition
    · exact (hP.affine_open_cover_iff _ _ _).mp hg _ _
    · delta affine_locally at hf
      rw [(hP.is_local_source_affine_locally.affine_open_cover_tfae f).out 0 3] at hf
      specialize hf ((pullback g (S.affine_cover.map i)).affineCover.map j ≫ pullback.fst)
      rw [(hP.affine_open_cover_tfae
              (pullback.snd :
                pullback f ((pullback g (S.affine_cover.map i)).affineCover.map j ≫ pullback.fst) ⟶
                  _)).out
          0 3] at
        hf
      apply hf
#align ring_hom.property_is_local.affine_locally_stable_under_composition RingHom.PropertyIsLocal.affineLocally_stableUnderComposition

end RingHom.PropertyIsLocal


namespace hidden

class inhabited (α : Type _) := (default : α)

#reduce default Prop
#print default

instance Prop_inhabited : inhabited Prop :=
⟨true⟩

instance bool_inhabited : inhabited bool :=
⟨tt⟩

instance nat_inhabited : inhabited nat :=
⟨0⟩

instance unit_inhabited : inhabited unit :=
⟨()⟩

def default (α : Type) [s : inhabited α] : α :=
@inhabited.default α s

instance prod_inhabited
  {α β : Type} [inhabited α] [inhabited β] : inhabited (prod α β) :=
⟨(default α, default β)⟩

#reduce default (nat × bool)

instance inhabited_fun (α : Type) {β : Type} [inhabited β] :
  inhabited (α → β) :=
⟨(λ a : α, default β)⟩

#check default (nat → nat × bool)
#reduce default (nat → nat × bool)

universes u v

instance prod_has_add {α : Type u} {β : Type v}
    [has_add α] [has_add β] :
  has_add (α × β) :=
⟨λ ⟨a₁, b₁⟩ ⟨a₂, b₂⟩, ⟨a₁ + a₂, b₁ + b₂⟩⟩

#check (1, 2) + (3, 4)    -- ℕ × ℕ
#reduce  (1, 2) + (3, 4)  -- (4, 6)

end hidden

universe u

def list.add {α : Type u} [has_add α] :
  list α → list α → list α
| a [] := a
| [] b := b
| (a::as) (b::bs) := (a + b)::(list.add as bs)

instance {α : Type u} [has_add α] : has_add (list α) :=
  ⟨list.add⟩

#reduce [1,2,3] + [4,5,6,7,8]

set_option pp.implicit true

-- set_option trace.class_instances true

def step (a b x : ℕ) : ℕ :=
if x < a ∨ x > b then 0 else 1

#print definition step

def inhabited.set (α : Type*) : inhabited (set α) :=
by unfold set; apply_instance

#print inhabited.set

instance bool_to_Prop : has_coe bool Prop :=
⟨λ b, b = tt⟩

#reduce if tt then 3 else 5
#reduce if ff then 3 else 5

#print notation

def list.to_set {α : Type u} : list α → set α
| []     := ∅
| (h::t) := {h} ∪ list.to_set t

instance list_to_set_coe (α : Type u) :
  has_coe (list α) (set α) :=
⟨list.to_set⟩

def s : set nat  := {1, 2}
def l : list nat := [3, 4]

#check s ∪  l -- set nat

structure Semigroup : Type (u+1) :=
(carrier : Type u)
(mul : carrier → carrier → carrier)
(mul_assoc : ∀ a b c : carrier,
               mul (mul a b) c = mul a (mul b c))

instance Semigroup_has_mul (S : Semigroup) :
  has_mul (S.carrier) :=
⟨S.mul⟩

#check Semigroup.carrier

instance Semigroup_to_sort : has_coe_to_sort Semigroup :=
{S := Type u, coe := λ S, S.carrier}

example (S : Semigroup) (a b c : S) :
  (a * b) * c = a * (b * c) :=
Semigroup.mul_assoc _ a b c

structure morphism (S1 S2 : Semigroup) :=
(mor : S1 → S2)
(resp_mul : ∀ a b : S1, mor (a * b) = (mor a) * (mor b))

#check @morphism.mor

instance morphism_to_fun (S1 S2 : Semigroup) :
  has_coe_to_fun (morphism S1 S2) :=
{ F   := λ _, S1 → S2,
  coe := λ m, m.mor }

lemma resp_mul {S1 S2 : Semigroup}
    (f : morphism S1 S2) (a b : S1) :
  f (a * b) = f a * f b :=
f.resp_mul a b

theorem semi_assoc (S1 S2 : Semigroup) (f : morphism S1 S2) (a : S1) :
  f (a * a * a) = f a * f a * f a :=
calc
  f (a * a * a) = f (a * a) * f a : by rw [resp_mul f]
            ... = f a * f a * f a : by rw [resp_mul f]

#check semi_assoc
set_option pp.coercions false
#check semi_assoc


def p (x : Prop) := x

@[simp] theorem lemma1 (x : Prop) : p x = x :=
 rfl

theorem ex1 (x : Prop) (h : x) : p x := by
  simp
  assumption

#print ex1

theorem ex2 (x : Prop) (q : Prop → Prop) (h₁ : x) (h₂ : q x = x) : q x := by
  simp [h₂]
  assumption

#print ex2


/-
Goal: state and prove the relationship between deletion, contraction, and duality.

Existence of a normal form:
  expressions of the form M/C\D are closed under deletion and contraction,
  and together with M*/C\D they are closed under duality.

Current idea: define restriction and corestriction from U to subalg E
Then deletion and contraction are instances of these maps
And a sequence of deletions and contractions with disjoint arguments can be composed
-/

import boolalg rankfun
open boolalg

----------------------------------------------------------------

-- For this file, we'll define matroids as living inside a common universe U.
def matroid_on {U : boolalg} (E : U) : Type :=
  rankfun (subalg E)

----------------------------------------------------------------

section matroid_heq
variables
  {U : boolalg}
  {E₁ E₂ E₃ : U}
  {M₁ : matroid_on E₁}
  {M₂ : matroid_on E₂}
  {M₃ : matroid_on E₃}

-- Since we have a common universe, we can talk about matroid equality.
def matroid_heq (M₁ : matroid_on E₁) (M₂ : matroid_on E₂) : Prop :=
  (E₁ = E₂) ∧ forall (X : U) (h₁ : X ⊆ E₁) (h₂ : X ⊆ E₂),
  M₁.r ⟨X, h₁⟩ = M₂.r ⟨X, h₂⟩
notation M₁ ` ≅ ` M₂ := matroid_heq M₁ M₂

-- This is an equivalence relation, unsurprisingly: reflexive, symmetric, transitive.
lemma matroid_heq.refl {E : U} (M : matroid_on E) :
  (M ≅ M) :=
⟨rfl, fun _ _ _, rfl⟩

lemma matroid_heq.symm :
  (M₁ ≅ M₂) → (M₂ ≅ M₁) :=
fun ⟨hE, hr⟩, ⟨hE.symm, fun X h₂ h₁, (hr X h₁ h₂).symm⟩

lemma matroid_heq.trans :
  (M₁ ≅ M₂) → (M₂ ≅ M₃) → (M₁ ≅ M₃) :=
fun ⟨hE₁₂, hr₁₂⟩ ⟨hE₂₃, hr₂₃⟩, ⟨hE₁₂.trans hE₂₃, fun X h₁ h₃, let h₂ : X ⊆ E₂ := eq.rec h₁ hE₁₂ in (hr₁₂ X h₁ h₂).trans (hr₂₃ X h₂ h₃)⟩

-- If the ground sets are defeq, we can upgrade matroid_heq to an eq of rankfun.
lemma matroid_heq.to_eq {E : U} {M₁ M₂ : matroid_on E} :
  (M₁ ≅ M₂) → (M₁ = M₂) :=
fun ⟨_, hr⟩, rankfun.ext _ _ (funext (@subtype.rec _ _ (fun X, M₁.r X = M₂.r X) (fun X h, hr X h h)))

end /-section-/ matroid_heq

----------------------------------------------------------------

section dual
variables {U : boolalg}

-- Every matroid has a dual.
def dual :
  rankfun U → rankfun U :=
fun M, {
  r := (fun X, size X + M.r Xᶜ - M.r ⊤),
  R0 := (fun X,
    calc 0 ≤ M.r X  + M.r Xᶜ - M.r (X ∪ Xᶜ) - M.r (X ∩ Xᶜ) : by linarith [M.R3 X Xᶜ]
    ...    = M.r X  + M.r Xᶜ - M.r ⊤        - M.r ⊥        : by rw [union_compl_self X, inter_compl_self X]
    ...    ≤ size X + M.r Xᶜ - M.r ⊤                       : by linarith [M.R1 X, rank_bot M]),
  R1 := (fun X, by linarith [M.R2 _ _ (subset_top Xᶜ)]),
  R2 := (fun X Y h, let
    Z := Xᶜ ∩ Y,
    h₁ :=
      calc Yᶜ ∪ Z = (Xᶜ ∩ Y) ∪ Yᶜ        : by apply union_comm
      ...         = (Xᶜ ∪ Yᶜ) ∩ (Y ∪ Yᶜ) : by apply union_distrib_right
      ...         = (X ∩ Y)ᶜ ∩ ⊤         : by rw [compl_inter X Y, union_compl_self Y]
      ...         = (X ∩ Y)ᶜ             : by apply inter_top
      ...         = Xᶜ                   : by rw [inter_subset h],
    h₂ :=
      calc Yᶜ ∩ Z = (Xᶜ ∩ Y) ∩ Yᶜ : by apply inter_comm
      ...         = Xᶜ ∩ (Y ∩ Yᶜ) : by apply inter_assoc
      ...         = Xᶜ ∩ ⊥        : by rw [inter_compl_self Y]
      ...         = ⊥             : by apply inter_bot,
    h₃ :=
      calc M.r Xᶜ = M.r Xᶜ + M.r ⊥              : by linarith [rank_bot M]
      ...         = M.r (Yᶜ ∪ Z) + M.r (Yᶜ ∩ Z) : by rw [h₁, h₂]
      ...         ≤ M.r Yᶜ + M.r Z              : by apply M.R3
      ...         ≤ M.r Yᶜ + size Z             : by linarith [M.R1 Z]
      ...         = M.r Yᶜ + size (Xᶜ ∩ Y)      : by refl
      ...         = M.r Yᶜ + size Y - size X    : by linarith [compl_inter_size_subset h]
    in by linarith),
  R3 := (fun X Y,
    calc  size (X ∪ Y) + M.r (X ∪ Y)ᶜ  - M.r ⊤ + (size (X ∩ Y) + M.r (X ∩ Y)ᶜ  - M.r ⊤)
        = size (X ∪ Y) + M.r (Xᶜ ∩ Yᶜ) - M.r ⊤ + (size (X ∩ Y) + M.r (Xᶜ ∪ Yᶜ) - M.r ⊤) : by rw [compl_union X Y, compl_inter X Y]
    ... ≤ size X       + M.r Xᶜ        - M.r ⊤ + (size Y       + M.r Yᶜ        - M.r ⊤) : by linarith [size_modular X Y, M.R3 Xᶜ Yᶜ]),
}

-- The double dual of a matroid is itself.
lemma dual_dual (M : rankfun U) :
  dual (dual M) = M :=
begin
  apply rankfun.ext, apply funext, intro X, calc
  (dual (dual M)).r X = size X + (size Xᶜ + M.r Xᶜᶜ - M.r ⊤) - (size (⊤ : U) + M.r ⊤ᶜ - M.r ⊤) : rfl
  ...                 = size X + (size Xᶜ + M.r X   - M.r ⊤) - (size (⊤ : U) + M.r ⊥  - M.r ⊤) : by rw [compl_compl, boolalg.compl_top]
  ...                 = M.r X                                                                  : by linarith [size_compl X, rank_bot M]
end

end /-section-/ dual

----------------------------------------------------------------

section restrict
variables {U : boolalg}

-- The restriction of a rankfun to a subalg is still a rankfun.
-- This is the same as deleting Eᶜ.
def restrict (E : U) :
  rankfun U → matroid_on E :=
fun M, {
  r := (fun X, M.r X.val),
  R0 := (by intro X;      apply M.R0),
  R1 := (by intro X;      apply M.R1),
  R2 := (by intros X Y h; apply M.R2; exact congr_arg subtype.val h),
  R3 := (by intros X Y;   apply M.R3),
}

end /-section-/ restrict

----------------------------------------------------------------

section corestrict
variables {U : boolalg}

-- The corestriction is the same as contracting Eᶜ.
def corestrict (E : U) :
  rankfun U → matroid_on E :=
fun M, {
  r := (fun X, M.r (X.val ∪ Eᶜ) - M.r Eᶜ),
  R0 := (by intro X; linarith [M.R2 _ _ (subset_union_right X.val Eᶜ)]),
  R1 := sorry,
  R2 := (by intros X Y h; linarith [M.R2 _ _ (subset_union_subset_left X.val Y.val Eᶜ (congr_arg subtype.val h))]),
  R3 := sorry,
}

end /-section-/ corestrict

----------------------------------------------------------------

-- Restriction and corestriction (so, deletion and contraction) are duals
lemma dual_restrict {U : boolalg} (E : U) (M : rankfun U) :
  dual (restrict E M) = corestrict E (dual M) :=
begin
  apply rankfun.ext, apply funext, intro X,
  have h₁ : size (X.val ∪ Eᶜ) = size X.val + size Eᶜ := size_union_of_inter_empty (calc
    X.val ∩ Eᶜ = (X.val ∩ {e}) ∩ Eᶜ : by rw [(eq.symm X.prop : X.val ∩ {e} = X.val)]
    ...        = X.val ∩ (E ∩ Eᶜ) : by apply inter_assoc
    ...        = X.val ∩ ⊥        : by rw [inter_compl_self]
    ...        = ⊥                : by apply inter_bot),
  have h₂ : Eᶜᶜ = E := compl_compl E,
  have h₃ := (calc
    (X.val ∪ Eᶜ)ᶜ = X.valᶜ ∩ Eᶜᶜ : by apply compl_union
    ...           = X.valᶜ ∩ {e}   : by rw [compl_compl]
    ...           = E ∩ X.valᶜ   : by apply inter_comm),
  calc
  (dual (restrict E M)).r X = size X.val + M.r (E ∩ X.valᶜ) - M.r E           : rfl
  ...                       = (size (X.val ∪ Eᶜ) + M.r (E ∩ X.valᶜ) - M.r ⊤)
                            - (size          Eᶜ  + M.r  E           - M.r ⊤)  : by linarith [h₁]
  ...                       = (size (X.val ∪ Eᶜ) + M.r (X.val ∪ Eᶜ)ᶜ - M.r ⊤)
                            - (size          Eᶜ  + M.r          Eᶜ ᶜ - M.r ⊤) : by rw [h₂, h₃]
  ...                       = (corestrict E (dual M)).r X                     : rfl
end

lemma restrict_dual {U : boolalg} (E : U) (M : rankfun U) :
  restrict E (dual M) = dual (corestrict E M) :=
begin
  apply rankfun.ext, apply funext, intro X,
  have h₁ : E ∪ Eᶜ = ⊤ := by apply union_compl_self,
  have h₂ := (calc
    (E ∩ X.valᶜ) ∪ Eᶜ = (E ∪ Eᶜ) ∩ (X.valᶜ ∪ Eᶜ) : by apply union_distrib_right
    ...               = X.valᶜ ∪ Eᶜ              : by simp only [union_compl_self, top_inter]
    ...               = (X.val ∩ {e})ᶜ             : by apply eq.symm; apply compl_inter
    ...               = X.valᶜ                   : by rw [(eq.symm X.prop : X.val ∩ {e} = X.val)]),
  calc
  (restrict E (dual M)).r X = size X.val + M.r X.valᶜ - M.r ⊤                 : rfl
  ...                       = size X.val + (M.r X.valᶜ - M.r Eᶜ)
                                         - (M.r ⊤      - M.r Eᶜ)              : by linarith
  ...                       = size X.val + (M.r ((E ∩ X.valᶜ) ∪ Eᶜ) - M.r Eᶜ)
                                         - (M.r ( E           ∪ Eᶜ) - M.r Eᶜ) : by rw [h₁, h₂]
  ...                       = (dual (corestrict E M)).r X                     : rfl

end

----------------------------------------------------------------

def unnest {U : boolalg} {E : U} {F : subalg E} :
  subalg F → subalg (F.val) :=
fun X, ⟨X.val.val, congr_arg subtype.val X.prop⟩

def nest {U : boolalg} {E : U} (F : subalg E) :
  subalg (F.val) → subalg F :=
fun X, ⟨⟨X.val, subset.trans X.prop F.prop⟩, subtype.ext X.prop⟩

-- Deletion and contraction commute.

def delete_then_contract {U : boolalg} (C D : U) (h_disjoint : C ∩ D = ⊥) :
  rankfun U → matroid_on (Cᶜ ∩ Dᶜ) :=
fun M, let
  M_del     : matroid_on Dᶜ := restrict Dᶜ M,
  E         : ↥(subalg Dᶜ)  := ⟨Cᶜ ∩ Dᶜ, by apply inter_subset_right⟩,
  M_del_con : matroid_on E  := corestrict E M_del
in {
  r := (fun X, M_del_con.r (nest E X)),
  R0 := (by intro X; apply M_del_con.R0),
  R1 := (by intro X; apply M_del_con.R1),
  R2 := (begin
    intros X Y h,
    apply M_del_con.R2,
    apply subtype.ext,
    apply subtype.ext,
    show X.val = X.val ∩ Y.val,
    exact congr_arg subtype.val h
  end),
  R3 := (by intros X Y; apply M_del_con.R3),
}

def contract_then_delete {U : boolalg} (C D : U) (h_disjoint : C ∩ D = ⊥) :
  rankfun U → matroid_on (Cᶜ ∩ Dᶜ) :=
fun M, let
  M_con     : matroid_on Cᶜ := corestrict Cᶜ M,
  E         : ↥(subalg Cᶜ)  := ⟨Cᶜ ∩ Dᶜ, by apply inter_subset_left⟩,
  M_con_del : matroid_on E  := restrict E M_con
in {
  r := (fun X, M_con_del.r (nest E X)),
  R0 := (by intro X; apply M_con_del.R0),
  R1 := (by intro X; apply M_con_del.R1),
  R2 := (begin
    intros X Y h,
    apply M_con_del.R2,
    apply subtype.ext,
    apply subtype.ext,
    show X.val = X.val ∩ Y.val,
    exact congr_arg subtype.val h
  end),
  R3 := (by intros X Y; apply M_con_del.R3),
}

lemma same_same {U : boolalg} (C D : U) (h_disjoint : C ∩ D = ⊥) (M : rankfun U) :
  (delete_then_contract C D h_disjoint M) = (contract_then_delete C D h_disjoint M) :=
begin
  apply rankfun.ext, apply funext, intro X,
  unfold delete_then_contract contract_then_delete,
  simp,
  unfold restrict corestrict,
  simp,

end

/-
lemma del_con {U : boolalg} (C D : U) (h_disjoint : C ∩ D = ⊥) (M : rankfun U) :
  let
    E₁ : ↥(subalg Dᶜ) := ⟨Cᶜ ∩ Dᶜ, by apply inter_subset_right⟩,
    E₂ : ↥(subalg Cᶜ) := ⟨Cᶜ ∩ Dᶜ, by apply inter_subset_left⟩
  in
    corestrict E₁ (restrict Dᶜ M) = restrict E₂ (corestrict Cᶜ M) :=
sorry
-/
----------------------------------------------------------------
/-

----------------------------------------------------------------

lemma contract_contract (C₁ C₂ : subalg E) (M : matroid_on E) :
  contract (C₂∖C₁) (contract C₁ M) ≅ contract (C₁ ∪ C₂) M
:= ⟨
  (calc E - C₁.val - (C₂∖C₁).val
      = (E ∩ C₁.valᶜ) ∩ (C₂.val ∩ C₁.valᶜ)ᶜ : rfl
  ... = E ∩ (C₁.val ∪ (C₂.val ∩ C₁.valᶜ))ᶜ  : by simp only [inter_assoc, compl_union]
  ... = E ∩ (C₁.val ∪ C₂.val)ᶜ              : by simp only [union_distrib_left, union_compl_self, inter_top]
  ... = E - (C₁ ∪ C₂).val                   : rfl),
  (fun X h₁ h₂, let
  h₃ := calc (C₂.val ∩ C₁.valᶜ) ∪ C₁.val
           = C₁.val ∪ (C₁.valᶜ ∩ C₂.val)            : by simp only [inter_comm, union_comm]
       ... = (C₁.val ∪ C₁.valᶜ) ∩ (C₁.val ∪ C₂.val) : by apply union_distrib_left
       ... = C₁.val ∪ C₂.val                        : by simp only [union_compl_self, top_inter],
  h₄ := calc X ∪ (C₂.val ∩ C₁.valᶜ) ∪ C₁.val
           = X ∪ ((C₂.val ∩ C₁.valᶜ) ∪ C₁.val) : by apply union_assoc
       ... = X ∪ (C₁.val ∪ C₂.val)             : by rw [h₃],
  h₅ : (C₁.val ∪ C₂.val) ⊆ E := sorry,
  h₆ : X ∪ (C₁.val ∪ C₂.val) ⊆ E := sorry,
  h₇ (a b c : ℤ) : (a - c) - (b - c) = a - b := by linarith
  in calc (contract (C₂∖C₁) (contract C₁ M)).r ⟨X, h₁⟩
        = (contract C₁ M).r (⟨X, _⟩ ∪ (C₂∖C₁)) - (contract C₁ M).r (C₂∖C₁) : rfl
    ... = (M.r ⟨X ∪ (C₂.val ∩ C₁.valᶜ) ∪ C₁.val, _⟩ - M.r C₁)
        - (M.r ⟨    (C₂.val ∩ C₁.valᶜ) ∪ C₁.val, _⟩ - M.r C₁) : rfl
    ... = M.r ⟨X ∪ (C₂.val ∩ C₁.valᶜ) ∪ C₁.val, _⟩ - M.r ⟨(C₂.val ∩ C₁.valᶜ) ∪ C₁.val, _⟩ : h₇ _ _ _
    ... = (contract (C₁ ∪ C₂) M).r ⟨X, h₂⟩ : sorry),
⟩

end /-section-/ contract

----------------------------------------------------------------

/-- subalg Dᶜ .... -/
def delete {U : boolalg} (D E : U) : (D ⊆ E) →
  rankfun (subalg E) → rankfun (subalg (Dᶜ ∩ {e})) :=
fun hDE M, let
  emb : embed (subalg (Dᶜ ∩ {e})) (subalg E) := embed.from_nested_pair (inter_subset_right _ _),
  f := emb.f,
  DE := push E ⟨D, hDE⟩
in {
  r := (fun X, M.r (f X)),
  R0 := λ X, by apply M.R0,
  R1 := λ X, by apply M.R1,
  R2 := λ X Y hXY, by apply M.R2; apply emb.on_subset; exact hXY,
  R3 := λ X Y, by apply M.R3,
}

def contract {U : boolalg} (C E : U) : (C ⊆ E) →
  rankfun (subalg E) → rankfun (subalg (Cᶜ ∩ {e})) :=
fun hCE M, let
  emb : embed (subalg (Cᶜ ∩ {e})) (subalg E) := embed.from_nested_pair (inter_subset_right _ _),
  f := emb.f,
  CE := push E ⟨C, hCE⟩
in {
  r := (fun X, M.r ((f X) ∪ CE) - M.r CE),
  R0 := λ X, by linarith [M.R2 _ _ (by apply subset_union_right : CE ⊆ f X ∪ CE)],
  R1 := λ X, by linarith [emb.on_size X, M.R0 (f X ∩ CE), M.R3 (f X) CE, M.R1 (f X)],
  R2 := λ X Y hXY, by linarith[M.R2 (f X ∪ CE) (f Y ∪ CE) (subset_union_subset_left (f X) (f Y) CE (emb.on_subset hXY ))],
  R3 := λ X Y,
  begin
    have hu : (f X ∪ CE) ∪ (f Y ∪ CE) = f (X ∪ Y) ∪ CE := by rw [←union_distrib_union_left,←emb.on_union],
    have hi : (f X ∪ CE) ∩ (f Y ∪ CE) = f (X ∩ Y) ∪ CE := by rw [←union_distrib_right, ←emb.on_inter],
    have hs := M.R3 (f X ∪ CE) (f Y ∪ CE),
    rw [hu, hi] at hs,
    linarith [hs],
  end,
}
-/


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import analysis.convex.basic
import combinatorics.simplicial_complex.to_move.default
import data.finset.sort
import data.matrix.notation
import linear_algebra.affine_space.independent

open_locale affine big_operators classical
open finset

universes u₁ u₂
variables {E : Type u₁} [add_comm_group E] [module ℝ E]
variables {ι : Type u₂} {s t : set E}

def convex_independent (p : ι → E) : Prop :=
∀ (s : set ι) (x : ι), p x ∈ convex_hull (p '' s) → x ∈ s

lemma convex_independent.mono (hs : convex_independent (λ p, p : s → E)) (hts : t ⊆ s) :
  convex_independent (λ p, p : t → E) :=
begin
  rintro s x hs,
  sorry
end

lemma convex_independent_set_iff (A : set E) :
  convex_independent (λ p, p : A → E) ↔ ∀ s, s ⊆ A → A ∩ convex_hull s ⊆ s :=
begin
  split,
  { rintro h s hs x ⟨hx₁, hx₂⟩,
    have := h.mono hs,
    /-suffices H : x ∈ convex_hull ((λ (p : A), ↑p) '' {x : A | ↑x ∈ s}),
    {
      have := h {x : A | ↑x ∈ s},
      sorry
    },-/
    sorry

    --simpa using h (s.attach.image (λ x, ⟨x.1, hs x.2⟩)) ⟨_, hx₁⟩ _,
    --convert hx₂,
    --ext y,
    --simpa [←and_assoc] using @hs y
    },
  { intros h s x hs,
    simpa using h (s.image coe) (by simp) ⟨x.2, by simpa using hs⟩ }
end

lemma convex_independent_set_iff' (A : set E) :
  convex_independent (λ p, p : A → E) ↔ ∀ x ∈ A, x ∉ convex_hull (A \ {x}) :=
begin
  rw convex_independent_set_iff,
  split,
  { rintro hA x hxA hx,
    exact (hA _ (set.diff_subset _ _) ⟨hxA, hx⟩).2 (set.mem_singleton _) },
  rintro hA s hs x ⟨hxA, hxs⟩,
  by_contra h,
  exact hA _ hxA (convex_hull_mono (set.subset_diff_singleton hs h) hxs),
end

-- TODO (Bhavik): move these two, and use them to prove the old versions
lemma nontrivial_sum_of_affine_independent' {p : ι → E} {X : finset ι}
  (hX : affine_independent ℝ p) (w : ι → ℝ)
  (hw₀ : ∑ i in X, w i = 0) (hw₁ : ∑ i in X, w i • p i = 0) :
∀ i ∈ X, w i = 0 :=
begin
  specialize hX _ _ hw₀ _,
  { rw finset.weighted_vsub_eq_weighted_vsub_of_point_of_sum_eq_zero _ _ _ hw₀ (0 : E),
    rw finset.weighted_vsub_of_point_apply,
    simpa only [vsub_eq_sub, sub_zero, sum_finset_coe (λ i, w i • p i)] },
  intros i hi,
  apply hX _ hi
end

lemma unique_combination' {p : ι → E} (X : finset ι)
  (hX : affine_independent ℝ p)
  (w₁ w₂ : ι → ℝ) (hw₁ : ∑ i in X, w₁ i = 1) (hw₂ : ∑ i in X, w₂ i = 1)
  (same : ∑ i in X, w₁ i • p i = ∑ i in X, w₂ i • p i) :
  ∀ i ∈ X, w₁ i = w₂ i :=
begin
  let w := w₁ - w₂,
  suffices : ∀ i ∈ X, w i = 0,
  { intros i hi,
    apply eq_of_sub_eq_zero (this i hi) },
  apply nontrivial_sum_of_affine_independent' hX,
  { change ∑ i in X, (w₁ i - w₂ i) = _,
    rw [finset.sum_sub_distrib, hw₁, hw₂, sub_self] },
  { change ∑ i in X, (w₁ i - w₂ i) • p i = _,
    simp_rw [sub_smul, finset.sum_sub_distrib, same, sub_self] }
end

lemma affine_independent.convex_independent {p : ι → E} (hp : affine_independent ℝ p) :
  convex_independent p :=
begin
  intros s x hx,
  by_contra,
  sorry
  /-
  rw [finset.convex_hull_eq] at hx,
  rcases hx with ⟨w, hw₀, hw₁, x_eq⟩,
  have : set.inj_on p s := λ x hx y hy h, injective_of_affine_independent hp h,
  rw finset.center_mass_eq_of_sum_1 _ _ hw₁ at x_eq,
  rw finset.sum_image ‹set.inj_on p s› at hw₁,
  rw finset.sum_image ‹set.inj_on p s› at x_eq,
  dsimp at hw₁ x_eq,
  simp only [and_imp, finset.mem_image, forall_apply_eq_imp_iff₂, exists_imp_distrib] at hw₀,
  let w₀ : ι → ℝ := λ i, if i ∈ s then w (p i) else 0,
  let w₁ : ι → ℝ := λ i, if x = i then 1 else 0,
  have thing : _ = _ := unique_combination' (insert x s) hp w₀ w₁ _ _ _ _ (mem_insert_self _ _),
  { change ite _ _ _ = ite _ _ _ at thing,
    simpa [h] using thing },
  { rwa [sum_insert_of_eq_zero_if_not_mem, sum_extend_by_zero s],
    simp [h] },
  { simp [sum_ite_eq] },
  { simpa [sum_insert_of_eq_zero_if_not_mem, h, ite_smul, sum_extend_by_zero s] }-/
end


/-
Copyright (c) 2020 Thomas Browning, Patrick Lutz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning, Patrick Lutz

! This file was ported from Lean 3 source module field_theory.galois
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.FieldTheory.Normal
import Mathbin.FieldTheory.PrimitiveElement
import Mathbin.FieldTheory.Fixed
import Mathbin.GroupTheory.GroupAction.FixingSubgroup

/-!
# Galois Extensions

In this file we define Galois extensions as extensions which are both separable and normal.

## Main definitions

- `is_galois F E` where `E` is an extension of `F`
- `fixed_field H` where `H : subgroup (E ≃ₐ[F] E)`
- `fixing_subgroup K` where `K : intermediate_field F E`
- `galois_correspondence` where `E/F` is finite dimensional and Galois

## Main results

- `intermediate_field.fixing_subgroup_fixed_field` : If `E/F` is finite dimensional (but not
  necessarily Galois) then `fixing_subgroup (fixed_field H) = H`
- `intermediate_field.fixed_field_fixing_subgroup`: If `E/F` is finite dimensional and Galois
  then `fixed_field (fixing_subgroup K) = K`

Together, these two results prove the Galois correspondence.

- `is_galois.tfae` : Equivalent characterizations of a Galois extension of finite degree
-/

open Polynomial

open FiniteDimensional AlgEquiv

section

variable (F : Type _) [Field F] (E : Type _) [Field E] [Algebra F E]

/-- A field extension E/F is galois if it is both separable and normal. Note that in mathlib
a separable extension of fields is by definition algebraic. -/
class IsGalois : Prop where
  [to_isSeparable : IsSeparable F E]
  [to_normal : Normal F E]
#align is_galois IsGalois

variable {F E}

theorem isGalois_iff : IsGalois F E ↔ IsSeparable F E ∧ Normal F E :=
  ⟨fun h => ⟨h.1, h.2⟩, fun h =>
    { to_isSeparable := h.1
      to_normal := h.2 }⟩
#align is_galois_iff isGalois_iff

attribute [instance] IsGalois.to_isSeparable IsGalois.to_normal

-- see Note [lower instance priority]
variable (F E)

namespace IsGalois

instance self : IsGalois F F :=
  ⟨⟩
#align is_galois.self IsGalois.self

variable (F) {E}

theorem integral [IsGalois F E] (x : E) : IsIntegral F x :=
  to_normal.IsIntegral x
#align is_galois.integral IsGalois.integral

theorem separable [IsGalois F E] (x : E) : (minpoly F x).Separable :=
  IsSeparable.separable F x
#align is_galois.separable IsGalois.separable

theorem splits [IsGalois F E] (x : E) : (minpoly F x).Splits (algebraMap F E) :=
  Normal.splits' x
#align is_galois.splits IsGalois.splits

variable (F E)

instance of_fixed_field (G : Type _) [Group G] [Finite G] [MulSemiringAction G E] :
    IsGalois (FixedPoints.subfield G E) E :=
  ⟨⟩
#align is_galois.of_fixed_field IsGalois.of_fixed_field

/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
theorem IntermediateField.AdjoinSimple.card_aut_eq_finrank [FiniteDimensional F E] {α : E}
    (hα : IsIntegral F α) (h_sep : (minpoly F α).Separable)
    (h_splits : (minpoly F α).Splits (algebraMap F F⟮⟯)) :
    Fintype.card (F⟮⟯ ≃ₐ[F] F⟮⟯) = finrank F F⟮⟯ :=
  by
  letI : Fintype (F⟮⟯ →ₐ[F] F⟮⟯) := IntermediateField.fintypeOfAlgHomAdjoinIntegral F hα
  rw [IntermediateField.adjoin.finrank hα]
  rw [← IntermediateField.card_algHom_adjoin_integral F hα h_sep h_splits]
  exact Fintype.card_congr (algEquivEquivAlgHom F F⟮⟯)
#align is_galois.intermediate_field.adjoin_simple.card_aut_eq_finrank IsGalois.IntermediateField.AdjoinSimple.card_aut_eq_finrank

/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
theorem card_aut_eq_finrank [FiniteDimensional F E] [IsGalois F E] :
    Fintype.card (E ≃ₐ[F] E) = finrank F E :=
  by
  cases' Field.exists_primitive_element F E with α hα
  let iso : F⟮⟯ ≃ₐ[F] E :=
    { toFun := fun e => e.val
      invFun := fun e =>
        ⟨e, by
          rw [hα]
          exact IntermediateField.mem_top⟩
      left_inv := fun _ => by
        ext
        rfl
      right_inv := fun _ => rfl
      map_mul' := fun _ _ => rfl
      map_add' := fun _ _ => rfl
      commutes' := fun _ => rfl }
  have H : IsIntegral F α := IsGalois.integral F α
  have h_sep : (minpoly F α).Separable := IsGalois.separable F α
  have h_splits : (minpoly F α).Splits (algebraMap F E) := IsGalois.splits F α
  replace h_splits : Polynomial.Splits (algebraMap F F⟮⟯) (minpoly F α)
  · have p : iso.symm.to_alg_hom.to_ring_hom.comp (algebraMap F E) = algebraMap F ↥F⟮⟯ :=
      by
      ext
      simp
    simpa [p] using
      Polynomial.splits_comp_of_splits (algebraMap F E) iso.symm.to_alg_hom.to_ring_hom h_splits
  rw [← LinearEquiv.finrank_eq iso.to_linear_equiv]
  rw [← intermediate_field.adjoin_simple.card_aut_eq_finrank F E H h_sep h_splits]
  apply Fintype.card_congr
  apply Equiv.mk (fun ϕ => iso.trans (trans ϕ iso.symm)) fun ϕ => iso.symm.trans (trans ϕ iso)
  · intro ϕ
    ext1
    simp only [trans_apply, apply_symm_apply]
  · intro ϕ
    ext1
    simp only [trans_apply, symm_apply_apply]
#align is_galois.card_aut_eq_finrank IsGalois.card_aut_eq_finrank

end IsGalois

end

section IsGaloisTower

variable (F K E : Type _) [Field F] [Field K] [Field E] {E' : Type _} [Field E'] [Algebra F E']

variable [Algebra F K] [Algebra F E] [Algebra K E] [IsScalarTower F K E]

theorem IsGalois.tower_top_of_isGalois [IsGalois F E] : IsGalois K E :=
  { to_isSeparable := isSeparable_tower_top_of_isSeparable F K E
    to_normal := Normal.tower_top_of_normal F K E }
#align is_galois.tower_top_of_is_galois IsGalois.tower_top_of_isGalois

variable {F E}

-- see Note [lower instance priority]
instance (priority := 100) IsGalois.tower_top_intermediateField (K : IntermediateField F E)
    [h : IsGalois F E] : IsGalois K E :=
  IsGalois.tower_top_of_isGalois F K E
#align is_galois.tower_top_intermediate_field IsGalois.tower_top_intermediateField

theorem isGalois_iff_isGalois_bot : IsGalois (⊥ : IntermediateField F E) E ↔ IsGalois F E :=
  by
  constructor
  · intro h
    exact IsGalois.tower_top_of_isGalois (⊥ : IntermediateField F E) F E
  · intro h
    infer_instance
#align is_galois_iff_is_galois_bot isGalois_iff_isGalois_bot

theorem IsGalois.of_algEquiv [h : IsGalois F E] (f : E ≃ₐ[F] E') : IsGalois F E' :=
  { to_isSeparable := IsSeparable.of_algHom F E f.symm
    to_normal := Normal.of_algEquiv f }
#align is_galois.of_alg_equiv IsGalois.of_algEquiv

theorem AlgEquiv.transfer_galois (f : E ≃ₐ[F] E') : IsGalois F E ↔ IsGalois F E' :=
  ⟨fun h => IsGalois.of_algEquiv f, fun h => IsGalois.of_algEquiv f.symm⟩
#align alg_equiv.transfer_galois AlgEquiv.transfer_galois

theorem isGalois_iff_isGalois_top : IsGalois F (⊤ : IntermediateField F E) ↔ IsGalois F E :=
  (IntermediateField.topEquiv : (⊤ : IntermediateField F E) ≃ₐ[F] E).transfer_galois
#align is_galois_iff_is_galois_top isGalois_iff_isGalois_top

instance isGalois_bot : IsGalois F (⊥ : IntermediateField F E) :=
  (IntermediateField.botEquiv F E).transfer_galois.mpr (IsGalois.self F)
#align is_galois_bot isGalois_bot

end IsGaloisTower

section GaloisCorrespondence

variable {F : Type _} [Field F] {E : Type _} [Field E] [Algebra F E]

variable (H : Subgroup (E ≃ₐ[F] E)) (K : IntermediateField F E)

/-- The intermediate field of fixed points fixed by a monoid action that commutes with the
`F`-action on `E`. -/
def FixedPoints.intermediateField (M : Type _) [Monoid M] [MulSemiringAction M E]
    [SMulCommClass M F E] : IntermediateField F E :=
  { FixedPoints.subfield M E with
    carrier := MulAction.fixedPoints M E
    algebraMap_mem' := fun a g => by rw [Algebra.algebraMap_eq_smul_one, smul_comm, smul_one] }
#align fixed_points.intermediate_field FixedPoints.intermediateField

namespace IntermediateField

/-- The intermediate_field fixed by a subgroup -/
def fixedField : IntermediateField F E :=
  FixedPoints.intermediateField H
#align intermediate_field.fixed_field IntermediateField.fixedField

theorem finrank_fixedField_eq_card [FiniteDimensional F E] [DecidablePred (· ∈ H)] :
    finrank (fixedField H) E = Fintype.card H :=
  FixedPoints.finrank_eq_card H E
#align intermediate_field.finrank_fixed_field_eq_card IntermediateField.finrank_fixedField_eq_card

/-- The subgroup fixing an intermediate_field -/
def fixingSubgroup : Subgroup (E ≃ₐ[F] E) :=
  fixingSubgroup (E ≃ₐ[F] E) (K : Set E)
#align intermediate_field.fixing_subgroup IntermediateField.fixingSubgroup

theorem le_iff_le : K ≤ fixedField H ↔ H ≤ fixingSubgroup K :=
  ⟨fun h g hg x => h (Subtype.mem x) ⟨g, hg⟩, fun h x hx g => h (Subtype.mem g) ⟨x, hx⟩⟩
#align intermediate_field.le_iff_le IntermediateField.le_iff_le

/-- The fixing_subgroup of `K : intermediate_field F E` is isomorphic to `E ≃ₐ[K] E` -/
def fixingSubgroupEquiv : fixingSubgroup K ≃* E ≃ₐ[K] E
    where
  toFun ϕ := { AlgEquiv.toRingEquiv ↑ϕ with commutes' := ϕ.Mem }
  invFun ϕ := ⟨ϕ.restrictScalars _, ϕ.commutes⟩
  left_inv _ := by
    ext
    rfl
  right_inv _ := by
    ext
    rfl
  map_mul' _ _ := by
    ext
    rfl
#align intermediate_field.fixing_subgroup_equiv IntermediateField.fixingSubgroupEquiv

theorem fixingSubgroup_fixedField [FiniteDimensional F E] : fixingSubgroup (fixedField H) = H :=
  by
  have H_le : H ≤ fixingSubgroup (fixed_field H) := (le_iff_le _ _).mp le_rfl
  classical
    suffices Fintype.card H = Fintype.card (fixingSubgroup (fixed_field H)) by
      exact
        SetLike.coe_injective
          (Set.eq_of_inclusion_surjective
              ((Fintype.bijective_iff_injective_and_card (Set.inclusion H_le)).mpr
                  ⟨Set.inclusion_injective H_le, this⟩).2).symm
    apply Fintype.card_congr
    refine' (FixedPoints.toAlgHomEquiv H E).trans _
    refine' (algEquivEquivAlgHom (fixed_field H) E).toEquiv.symm.trans _
    exact (fixing_subgroup_equiv (fixed_field H)).toEquiv.symm
#align intermediate_field.fixing_subgroup_fixed_field IntermediateField.fixingSubgroup_fixedField

instance fixedField.algebra : Algebra K (fixedField (fixingSubgroup K))
    where
  smul x y :=
    ⟨x * y, fun ϕ => by
      rw [smul_mul', show ϕ • ↑x = ↑x from Subtype.mem ϕ x, show ϕ • ↑y = ↑y from Subtype.mem y ϕ]⟩
  toFun x := ⟨x, fun ϕ => Subtype.mem ϕ x⟩
  map_zero' := rfl
  map_add' _ _ := rfl
  map_one' := rfl
  map_mul' _ _ := rfl
  commutes' _ _ := mul_comm _ _
  smul_def' _ _ := rfl
#align intermediate_field.fixed_field.algebra IntermediateField.fixedField.algebra

instance fixedField.isScalarTower : IsScalarTower K (fixedField (fixingSubgroup K)) E :=
  ⟨fun _ _ _ => mul_assoc _ _ _⟩
#align intermediate_field.fixed_field.is_scalar_tower IntermediateField.fixedField.isScalarTower

end IntermediateField

namespace IsGalois

theorem fixedField_fixingSubgroup [FiniteDimensional F E] [h : IsGalois F E] :
    IntermediateField.fixedField (IntermediateField.fixingSubgroup K) = K :=
  by
  have K_le : K ≤ IntermediateField.fixedField (IntermediateField.fixingSubgroup K) :=
    (IntermediateField.le_iff_le _ _).mpr le_rfl
  suffices
    finrank K E = finrank (IntermediateField.fixedField (IntermediateField.fixingSubgroup K)) E by
    exact (IntermediateField.eq_of_le_of_finrank_eq' K_le this).symm
  classical
    rw [IntermediateField.finrank_fixedField_eq_card,
      Fintype.card_congr (IntermediateField.fixingSubgroupEquiv K).toEquiv]
    exact (card_aut_eq_finrank K E).symm
#align is_galois.fixed_field_fixing_subgroup IsGalois.fixedField_fixingSubgroup

theorem card_fixingSubgroup_eq_finrank [DecidablePred (· ∈ IntermediateField.fixingSubgroup K)]
    [FiniteDimensional F E] [IsGalois F E] :
    Fintype.card (IntermediateField.fixingSubgroup K) = finrank K E := by
  conv =>
    rhs
    rw [← fixed_field_fixing_subgroup K, IntermediateField.finrank_fixedField_eq_card]
#align is_galois.card_fixing_subgroup_eq_finrank IsGalois.card_fixingSubgroup_eq_finrank

/-- The Galois correspondence from intermediate fields to subgroups -/
def intermediateFieldEquivSubgroup [FiniteDimensional F E] [IsGalois F E] :
    IntermediateField F E ≃o (Subgroup (E ≃ₐ[F] E))ᵒᵈ
    where
  toFun := IntermediateField.fixingSubgroup
  invFun := IntermediateField.fixedField
  left_inv K := fixedField_fixingSubgroup K
  right_inv H := IntermediateField.fixingSubgroup_fixedField H
  map_rel_iff' K L :=
    by
    rw [← fixed_field_fixing_subgroup L, IntermediateField.le_iff_le, fixed_field_fixing_subgroup L]
    rfl
#align is_galois.intermediate_field_equiv_subgroup IsGalois.intermediateFieldEquivSubgroup

/-- The Galois correspondence as a galois_insertion -/
def galoisInsertionIntermediateFieldSubgroup [FiniteDimensional F E] :
    GaloisInsertion
      (OrderDual.toDual ∘
        (IntermediateField.fixingSubgroup : IntermediateField F E → Subgroup (E ≃ₐ[F] E)))
      ((IntermediateField.fixedField : Subgroup (E ≃ₐ[F] E) → IntermediateField F E) ∘
        OrderDual.toDual)
    where
  choice K _ := IntermediateField.fixingSubgroup K
  gc K H := (IntermediateField.le_iff_le H K).symm
  le_l_u H := le_of_eq (IntermediateField.fixingSubgroup_fixedField H).symm
  choice_eq K _ := rfl
#align is_galois.galois_insertion_intermediate_field_subgroup IsGalois.galoisInsertionIntermediateFieldSubgroup

/-- The Galois correspondence as a galois_coinsertion -/
def galoisCoinsertionIntermediateFieldSubgroup [FiniteDimensional F E] [IsGalois F E] :
    GaloisCoinsertion
      (OrderDual.toDual ∘
        (IntermediateField.fixingSubgroup : IntermediateField F E → Subgroup (E ≃ₐ[F] E)))
      ((IntermediateField.fixedField : Subgroup (E ≃ₐ[F] E) → IntermediateField F E) ∘
        OrderDual.toDual)
    where
  choice H _ := IntermediateField.fixedField H
  gc K H := (IntermediateField.le_iff_le H K).symm
  u_l_le K := le_of_eq (fixedField_fixingSubgroup K)
  choice_eq H _ := rfl
#align is_galois.galois_coinsertion_intermediate_field_subgroup IsGalois.galoisCoinsertionIntermediateFieldSubgroup

end IsGalois

end GaloisCorrespondence

section GaloisEquivalentDefinitions

variable (F : Type _) [Field F] (E : Type _) [Field E] [Algebra F E]

namespace IsGalois

theorem is_separable_splitting_field [FiniteDimensional F E] [IsGalois F E] :
    ∃ p : F[X], p.Separable ∧ p.IsSplittingField F E :=
  by
  cases' Field.exists_primitive_element F E with α h1
  use minpoly F α, separable F α, IsGalois.splits F α
  rw [eq_top_iff, ← IntermediateField.top_toSubalgebra, ← h1]
  rw [IntermediateField.adjoin_simple_toSubalgebra_of_integral (integral F α)]
  apply Algebra.adjoin_mono
  rw [Set.singleton_subset_iff, Finset.mem_coe, Multiset.mem_toFinset, Polynomial.mem_roots]
  · dsimp only [Polynomial.IsRoot]
    rw [Polynomial.eval_map, ← Polynomial.aeval_def]
    exact minpoly.aeval _ _
  · exact Polynomial.map_ne_zero (minpoly.ne_zero (integral F α))
#align is_galois.is_separable_splitting_field IsGalois.is_separable_splitting_field

theorem of_fixedField_eq_bot [FiniteDimensional F E]
    (h : IntermediateField.fixedField (⊤ : Subgroup (E ≃ₐ[F] E)) = ⊥) : IsGalois F E :=
  by
  rw [← isGalois_iff_isGalois_bot, ← h]
  classical exact IsGalois.of_fixed_field E (⊤ : Subgroup (E ≃ₐ[F] E))
#align is_galois.of_fixed_field_eq_bot IsGalois.of_fixedField_eq_bot

theorem of_card_aut_eq_finrank [FiniteDimensional F E]
    (h : Fintype.card (E ≃ₐ[F] E) = finrank F E) : IsGalois F E :=
  by
  apply of_fixed_field_eq_bot
  have p : 0 < finrank (IntermediateField.fixedField (⊤ : Subgroup (E ≃ₐ[F] E))) E := finrank_pos
  classical
    rw [← IntermediateField.finrank_eq_one_iff, ← mul_left_inj' (ne_of_lt p).symm,
      finrank_mul_finrank, ← h, one_mul, IntermediateField.finrank_fixedField_eq_card]
    apply Fintype.card_congr
    exact
      { toFun := fun g => ⟨g, Subgroup.mem_top g⟩
        invFun := coe
        left_inv := fun g => rfl
        right_inv := fun _ => by
          ext
          rfl }
#align is_galois.of_card_aut_eq_finrank IsGalois.of_card_aut_eq_finrank

variable {F} {E} {p : F[X]}

/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
theorem of_separable_splitting_field_aux [hFE : FiniteDimensional F E] [sp : p.IsSplittingField F E]
    (hp : p.Separable) (K : Type _) [Field K] [Algebra F K] [Algebra K E] [IsScalarTower F K E]
    {x : E} (hx : x ∈ (p.map (algebraMap F E)).roots)
    -- these are both implied by `hFE`, but as they carry data this makes the lemma more general
    [Fintype (K →ₐ[F] E)]
    [Fintype (K⟮⟯.restrictScalars F →ₐ[F] E)] :
    Fintype.card (K⟮⟯.restrictScalars F →ₐ[F] E) = Fintype.card (K →ₐ[F] E) * finrank K K⟮⟯ :=
  by
  have h : IsIntegral K x :=
    isIntegral_of_isScalarTower (isIntegral_of_noetherian (IsNoetherian.iff_fg.2 hFE) x)
  have h1 : p ≠ 0 := fun hp => by rwa [hp, Polynomial.map_zero, Polynomial.roots_zero] at hx
  have h2 : minpoly K x ∣ p.map (algebraMap F K) :=
    by
    apply minpoly.dvd
    rw [Polynomial.aeval_def, Polynomial.eval₂_map, ← Polynomial.eval_map, ←
      IsScalarTower.algebraMap_eq]
    exact (Polynomial.mem_roots (Polynomial.map_ne_zero h1)).mp hx
  let key_equiv :
    (K⟮⟯.restrictScalars F →ₐ[F] E) ≃
      Σf : K →ₐ[F] E, @AlgHom K K⟮⟯ E _ _ _ _ (RingHom.toAlgebra f) :=
    by
    change (K⟮⟯ →ₐ[F] E) ≃ Σf : K →ₐ[F] E, _
    exact algHomEquivSigma
  haveI : ∀ f : K →ₐ[F] E, Fintype (@AlgHom K K⟮⟯ E _ _ _ _ (RingHom.toAlgebra f)) := fun f =>
    by
    apply Fintype.ofInjective (Sigma.mk f) fun _ _ H => eq_of_hEq (Sigma.mk.inj H).2
    exact Fintype.ofEquiv _ key_equiv
  rw [Fintype.card_congr key_equiv, Fintype.card_sigma, IntermediateField.adjoin.finrank h]
  apply Finset.sum_const_nat
  intro f hf
  rw [← @IntermediateField.card_algHom_adjoin_integral K _ E _ _ x E _ (RingHom.toAlgebra f) h]
  · apply Fintype.card_congr
    rfl
  · exact Polynomial.Separable.of_dvd ((Polynomial.separable_map (algebraMap F K)).mpr hp) h2
  · refine' Polynomial.splits_of_splits_of_dvd _ (Polynomial.map_ne_zero h1) _ h2
    rw [Polynomial.splits_map_iff, ← IsScalarTower.algebraMap_eq]
    exact sp.splits
#align is_galois.of_separable_splitting_field_aux IsGalois.of_separable_splitting_field_aux

theorem of_separable_splitting_field [sp : p.IsSplittingField F E] (hp : p.Separable) :
    IsGalois F E :=
  by
  haveI hFE : FiniteDimensional F E := Polynomial.IsSplittingField.finiteDimensional E p
  letI := Classical.decEq E
  let s := (p.map (algebraMap F E)).roots.toFinset
  have adjoin_root : IntermediateField.adjoin F ↑s = ⊤ :=
    by
    apply IntermediateField.toSubalgebra_injective
    rw [IntermediateField.top_toSubalgebra, ← top_le_iff, ← sp.adjoin_roots]
    apply IntermediateField.algebra_adjoin_le_adjoin
  let P : IntermediateField F E → Prop := fun K => Fintype.card (K →ₐ[F] E) = finrank F K
  suffices P (IntermediateField.adjoin F ↑s)
    by
    rw [AdjoinRoot] at this
    apply of_card_aut_eq_finrank
    rw [← Eq.trans this (LinearEquiv.finrank_eq intermediate_field.top_equiv.to_linear_equiv)]
    exact
      Fintype.card_congr
        ((algEquivEquivAlgHom F E).toEquiv.trans
          (intermediate_field.top_equiv.symm.arrow_congr AlgEquiv.refl))
  apply IntermediateField.induction_on_adjoin_finset s P
  · have key :=
      IntermediateField.card_algHom_adjoin_integral F
        (show IsIntegral F (0 : E) from isIntegral_zero)
    rw [minpoly.zero, Polynomial.natDegree_X] at key
    specialize key Polynomial.separable_x (Polynomial.splits_X (algebraMap F E))
    rw [← @Subalgebra.finrank_bot F E _ _ _, ← IntermediateField.bot_toSubalgebra] at key
    refine' Eq.trans _ key
    apply Fintype.card_congr
    rw [IntermediateField.adjoin_zero]
  intro K x hx hK
  simp only [P] at *
  rw [of_separable_splitting_field_aux hp K (multiset.mem_to_finset.mp hx), hK, finrank_mul_finrank]
  symm
  refine' LinearEquiv.finrank_eq _
  rfl
#align is_galois.of_separable_splitting_field IsGalois.of_separable_splitting_field

/-- Equivalent characterizations of a Galois extension of finite degree-/
theorem tFAE [FiniteDimensional F E] :
    TFAE
      [IsGalois F E, IntermediateField.fixedField (⊤ : Subgroup (E ≃ₐ[F] E)) = ⊥,
        Fintype.card (E ≃ₐ[F] E) = finrank F E, ∃ p : F[X], p.Separable ∧ p.IsSplittingField F E] :=
  by
  tfae_have 1 → 2
  · exact fun h => OrderIso.map_bot (@intermediate_field_equiv_subgroup F _ E _ _ _ h).symm
  tfae_have 1 → 3
  · intro
    exact card_aut_eq_finrank F E
  tfae_have 1 → 4
  · intro
    exact is_separable_splitting_field F E
  tfae_have 2 → 1
  · exact of_fixed_field_eq_bot F E
  tfae_have 3 → 1
  · exact of_card_aut_eq_finrank F E
  tfae_have 4 → 1
  · rintro ⟨h, hp1, _⟩
    exact of_separable_splitting_field hp1
  tfae_finish
#align is_galois.tfae IsGalois.tFAE

end IsGalois

end GaloisEquivalentDefinitions