/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/

import category_theory.monad.types
import category_theory.monad.limits
import category_theory.equivalence
import topology.category.CompHaus.basic
import topology.category.Profinite.basic
import data.set.constructions

/-!

# Compacta and Compact Hausdorff Spaces

Recall that, given a monad `M` on `Type*`, an *algebra* for `M` consists of the following data:
- A type `X : Type*`
- A "structure" map `M X → X`.
This data must also satisfy a distributivity and unit axiom, and algebras for `M` form a category
in an evident way.

See the file `category_theory.monad.algebra` for a general version, as well as the following link.
https://ncatlab.org/nlab/show/monad

This file proves the equivalence between the category of *compact Hausdorff topological spaces*
and the category of algebras for the *ultrafilter monad*.

## Notation:

Here are the main objects introduced in this file.
- `Compactum` is the type of compacta, which we define as algebras for the ultrafilter monad.
- `Compactum_to_CompHaus` is the functor `Compactum ⥤ CompHaus`. Here `CompHaus` is the usual
  category of compact Hausdorff spaces.
- `Compactum_to_CompHaus.is_equivalence` is a term of type `is_equivalence Compactum_to_CompHaus`.

The proof of this equivalence is a bit technical. But the idea is quite simply that the structure
map `ultrafilter X → X` for an algebra `X` of the ultrafilter monad should be considered as the map
sending an ultrafilter to its limit in `X`. The topology on `X` is then defined by mimicking the
characterization of open sets in terms of ultrafilters.

Any `X : Compactum` is endowed with a coercion to `Type*`, as well as the following instances:
- `topological_space X`.
- `compact_space X`.
- `t2_space X`.

Any morphism `f : X ⟶ Y` of is endowed with a coercion to a function `X → Y`, which is shown to
be continuous in `continuous_of_hom`.

The function `Compactum.of_topological_space` can be used to construct a `Compactum` from a
topological space which satisfies `compact_space` and `t2_space`.

We also add wrappers around structures which already exist. Here are the main ones, all in the
`Compactum` namespace:

- `forget : Compactum ⥤ Type*` is the forgetful functor, which induces a `concrete_category`
  instance for `Compactum`.
- `free : Type* ⥤ Compactum` is the left adjoint to `forget`, and the adjunction is in `adj`.
- `str : ultrafilter X → X` is the structure map for `X : Compactum`.
  The notation `X.str` is preferred.
- `join : ultrafilter (ultrafilter X) → ultrafilter X` is the monadic join for `X : Compactum`.
  Again, the notation `X.join` is preferred.
- `incl : X → ultrafilter X` is the unit for `X : Compactum`. The notation `X.incl` is preferred.

## References

- E. Manes, Algebraic Theories, Graduate Texts in Mathematics 26, Springer-Verlag, 1976.
- https://ncatlab.org/nlab/show/ultrafilter

-/

universe u
open category_theory filter ultrafilter topological_space category_theory.limits has_finite_inter
open_locale classical topology

local notation `β` := of_type_monad ultrafilter

/-- The type `Compactum` of Compacta, defined as algebras for the ultrafilter monad. -/
@[derive [category, inhabited]]
def Compactum := monad.algebra β

namespace Compactum

/-- The forgetful functor to Type* -/
@[derive [creates_limits,faithful]]
def forget : Compactum ⥤ Type* := monad.forget _

/-- The "free" Compactum functor. -/
def free : Type* ⥤ Compactum := monad.free _

/-- The adjunction between `free` and `forget`. -/
def adj : free ⊣ forget := monad.adj _

-- Basic instances
instance : concrete_category Compactum := { forget := forget }
instance : has_coe_to_sort Compactum Type* := ⟨forget.obj⟩
instance {X Y : Compactum} : has_coe_to_fun (X ⟶ Y) (λ f, X → Y) := ⟨λ f, f.f⟩
instance : has_limits Compactum := has_limits_of_has_limits_creates_limits forget

/-- The structure map for a compactum, essentially sending an ultrafilter to its limit. -/
def str (X : Compactum) : ultrafilter X → X := X.a

/-- The monadic join. -/
def join (X : Compactum) : ultrafilter (ultrafilter X) → ultrafilter X := β .μ.app _

/-- The inclusion of `X` into `ultrafilter X`. -/
def incl (X : Compactum) : X → ultrafilter X := β .η.app _

@[simp] lemma str_incl (X : Compactum) (x : X) : X.str (X.incl x) = x :=
begin
  change (β .η.app _ ≫ X.a) _ = _,
  rw monad.algebra.unit,
  refl,
end

@[simp] lemma str_hom_commute (X Y : Compactum) (f : X ⟶ Y) (xs : ultrafilter X) :
  f (X.str xs) = Y.str (map f xs) :=
begin
  change (X.a ≫ f.f) _ = _,
  rw ←f.h,
  refl,
end

@[simp] lemma join_distrib (X : Compactum) (uux : ultrafilter (ultrafilter X)) :
  X.str (X.join uux) = X.str (map X.str uux) :=
begin
  change (β .μ.app _ ≫ X.a) _ = _,
  rw monad.algebra.assoc,
  refl,
end

instance {X : Compactum} : topological_space X :=
{ is_open := λ U, ∀ (F : ultrafilter X), X.str F ∈ U → U ∈ F,
  is_open_univ := λ _ _, filter.univ_sets _,
  is_open_inter := λ S T h3 h4 h5 h6,
    filter.inter_sets _ (h3 _ h6.1) (h4 _ h6.2),
  is_open_sUnion := λ S h1 F ⟨T,hT,h2⟩,
    mem_of_superset (h1 T hT _ h2) (set.subset_sUnion_of_mem hT) }

theorem is_closed_iff {X : Compactum} (S : set X) : is_closed S ↔
  (∀ F : ultrafilter X, S ∈ F → X.str F ∈ S) :=
begin
  rw ← is_open_compl_iff,
  split,
  { intros cond F h,
    by_contradiction c,
    specialize cond F c,
    rw compl_mem_iff_not_mem at cond,
    contradiction },
  { intros h1 F h2,
    specialize h1 F,
    cases F.mem_or_compl_mem S, exacts [absurd (h1 h) h2, h] }
end

instance {X : Compactum} : compact_space X :=
begin
  constructor,
  rw is_compact_iff_ultrafilter_le_nhds,
  intros F h,
  refine ⟨X.str F, by tauto, _⟩,
  rw le_nhds_iff,
  intros S h1 h2,
  exact h2 F h1
end

/-- A local definition used only in the proofs. -/
private def basic {X : Compactum} (A : set X) : set (ultrafilter X) := {F | A ∈ F}
/-- A local definition used only in the proofs. -/
private def cl {X : Compactum} (A : set X) : set X := X.str '' (basic A)

private lemma basic_inter {X : Compactum} (A B : set X) : basic (A ∩ B) = basic A ∩ basic B :=
begin
  ext G,
  split,
  { intro hG,
    split; filter_upwards [hG] with _,
    exacts [and.left, and.right] },
  { rintros ⟨h1, h2⟩,
    exact inter_mem h1 h2 }
end

private lemma subset_cl {X : Compactum} (A : set X) : A ⊆ cl A := λ a ha, ⟨X.incl a, ha,by simp⟩

private theorem cl_cl {X : Compactum} (A : set X) : cl (cl A) ⊆ cl A :=
begin
  rintros _ ⟨F,hF,rfl⟩,
  -- Notation to be used in this proof.
  let fsu := finset (set (ultrafilter X)),
  let ssu := set (set (ultrafilter X)),
  let ι : fsu → ssu := coe,
  let C0 : ssu := {Z | ∃ B ∈ F, X.str ⁻¹' B = Z},
  let AA := {G : ultrafilter X | A ∈ G},
  let C1 := insert AA C0,
  let C2 := finite_inter_closure C1,
  -- C0 is closed under intersections.
  have claim1 : ∀ B C ∈ C0, B ∩ C ∈ C0,
  { rintros B ⟨Q,hQ,rfl⟩ C ⟨R,hR,rfl⟩,
    use Q ∩ R,
    simp only [and_true, eq_self_iff_true, set.preimage_inter, subtype.val_eq_coe],
    exact inter_sets _ hQ hR },
  -- All sets in C0 are nonempty.
  have claim2 : ∀ B ∈ C0, set.nonempty B,
  { rintros B ⟨Q,hQ,rfl⟩,
    obtain ⟨q⟩ := filter.nonempty_of_mem hQ,
    use X.incl q,
    simpa, },
  -- The intersection of AA with every set in C0 is nonempty.
  have claim3 : ∀ B ∈ C0, (AA ∩ B).nonempty,
  { rintros B ⟨Q,hQ,rfl⟩,
    have : (Q ∩ cl A).nonempty :=
      filter.nonempty_of_mem (inter_mem hQ hF),
    rcases this with ⟨q,hq1,P,hq2,hq3⟩,
    refine ⟨P,hq2,_⟩,
    rw ←hq3 at hq1,
    simpa },
  -- Suffices to show that the intersection of any finite subcollection of C1 is nonempty.
  suffices : ∀ (T : fsu), ι T ⊆ C1 → (⋂₀ ι T).nonempty,
  { obtain ⟨G, h1⟩ := exists_ultrafilter_of_finite_inter_nonempty _ this,
    use X.join G,
    have : G.map X.str = F :=
      ultrafilter.coe_le_coe.1 (λ S hS, h1 (or.inr ⟨S, hS, rfl⟩)),
    rw [join_distrib, this],
    exact ⟨h1 (or.inl rfl), rfl⟩ },
  -- C2 is closed under finite intersections (by construction!).
  have claim4 := finite_inter_closure_has_finite_inter C1,
  -- C0 is closed under finite intersections by claim1.
  have claim5 : has_finite_inter C0 :=
    ⟨⟨_, univ_mem, set.preimage_univ⟩, claim1⟩,
  -- Every element of C2 is nonempty.
  have claim6 : ∀ P ∈ C2, (P : set (ultrafilter X)).nonempty,
  { suffices : ∀ P ∈ C2, P ∈ C0 ∨ ∃ Q ∈ C0, P = AA ∩ Q,
    { intros P hP,
      cases this P hP,
      { exact claim2 _ h },
      { rcases h with ⟨Q, hQ, rfl⟩,
        exact claim3 _ hQ } },
    intros P hP,
    exact claim5.finite_inter_closure_insert _ hP },
  intros T hT,
  -- Suffices to show that the intersection of the T's is contained in C2.
  suffices : ⋂₀ ι T ∈ C2, by exact claim6 _ this,
  -- Finish
  apply claim4.finite_inter_mem,
  intros t ht,
  exact finite_inter_closure.basic (@hT t ht),
end

lemma is_closed_cl {X : Compactum} (A : set X) : is_closed (cl A) :=
begin
  rw is_closed_iff,
  intros F hF,
  exact cl_cl _ ⟨F, hF, rfl⟩,
end

lemma str_eq_of_le_nhds {X : Compactum} (F : ultrafilter X) (x : X) :
  ↑F ≤ 𝓝 x → X.str F = x :=
begin
  -- Notation to be used in this proof.
  let fsu := finset (set (ultrafilter X)),
  let ssu := set (set (ultrafilter X)),
  let ι : fsu → ssu := coe,
  let T0 : ssu := { S | ∃ A ∈ F, S = basic A },
  let AA := (X.str ⁻¹' {x}),
  let T1 := insert AA T0,
  let T2 := finite_inter_closure T1,
  intro cond,
  -- If F contains a closed set A, then x is contained in A.
  have claim1 : ∀ (A : set X), is_closed A → A ∈ F → x ∈ A,
  { intros A hA h,
    by_contradiction H,
    rw le_nhds_iff at cond,
    specialize cond Aᶜ H hA.is_open_compl,
    rw [ultrafilter.mem_coe, ultrafilter.compl_mem_iff_not_mem] at cond,
    contradiction },
  -- If A ∈ F, then x ∈ cl A.
  have claim2 : ∀ (A : set X), A ∈ F → x ∈ cl A,
  { intros A hA,
    exact claim1 (cl A) (is_closed_cl A) (mem_of_superset hA (subset_cl A)) },
  -- T0 is closed under intersections.
  have claim3 : ∀ (S1 S2 ∈ T0), S1 ∩ S2 ∈ T0,
  { rintros S1 ⟨S1, hS1, rfl⟩ S2 ⟨S2, hS2, rfl⟩,
    exact ⟨S1 ∩ S2, inter_mem hS1 hS2, by simp [basic_inter]⟩ },
  -- For every S ∈ T0, the intersection AA ∩ S is nonempty.
  have claim4 : ∀ (S ∈ T0), (AA ∩ S).nonempty,
  { rintros S ⟨S, hS, rfl⟩,
    rcases claim2 _ hS with ⟨G, hG, hG2⟩,
    exact ⟨G, hG2, hG⟩ },
  -- Every element of T0 is nonempty.
  have claim5 : ∀ (S ∈ T0), set.nonempty S,
  { rintros S ⟨S, hS, rfl⟩,
    exact ⟨F, hS⟩ },
  -- Every element of T2 is nonempty.
  have claim6 : ∀ (S ∈ T2), set.nonempty S,
  { suffices : ∀ S ∈ T2, S ∈ T0 ∨ ∃ Q ∈ T0, S = AA ∩ Q,
    { intros S hS,
      cases this _ hS with h h,
      { exact claim5 S h },
      { rcases h with ⟨Q, hQ, rfl⟩,
        exact claim4 Q hQ } },
    intros S hS,
    apply finite_inter_closure_insert,
    { split,
      { use set.univ,
        refine ⟨filter.univ_sets _, _⟩,
        ext,
        refine ⟨_, by tauto⟩,
        { intro,
          apply filter.univ_sets, } },
      { exact claim3 } },
    { exact hS} },
  -- It suffices to show that the intersection of any finite subset of T1 is nonempty.
  suffices : ∀ (F : fsu), ↑F ⊆ T1 → (⋂₀ ι F).nonempty,
  { obtain ⟨G,h1⟩ := ultrafilter.exists_ultrafilter_of_finite_inter_nonempty _ this,
    have c1 : X.join G = F := ultrafilter.coe_le_coe.1 (λ P hP, h1 (or.inr ⟨P, hP, rfl⟩)),
    have c2 : G.map X.str = X.incl x,
    { refine ultrafilter.coe_le_coe.1 (λ P hP, _),
      apply mem_of_superset (h1 (or.inl rfl)),
      rintros x ⟨rfl⟩,
      exact hP },
    simp [←c1, c2] },
  -- Finish...
  intros T hT,
  refine claim6 _ (finite_inter_mem (finite_inter_closure_has_finite_inter _) _ _),
  intros t ht,
  exact finite_inter_closure.basic (@hT t ht)
end

lemma le_nhds_of_str_eq {X : Compactum} (F : ultrafilter X) (x : X) :
  X.str F = x → ↑F ≤ 𝓝 x := λ h, le_nhds_iff.mpr (λ s hx hs, hs _ $ by rwa h)

-- All the hard work above boils down to this t2_space instance.
instance {X : Compactum} : t2_space X :=
begin
  rw t2_iff_ultrafilter,
  intros _ _ F hx hy,
  rw [← str_eq_of_le_nhds _ _ hx, ← str_eq_of_le_nhds _ _ hy]
end

/-- The structure map of a compactum actually computes limits. -/
lemma Lim_eq_str {X : Compactum} (F : ultrafilter X) : F.Lim = X.str F :=
begin
  rw [ultrafilter.Lim_eq_iff_le_nhds, le_nhds_iff],
  tauto,
end

lemma cl_eq_closure {X : Compactum} (A : set X) : cl A = closure A :=
begin
  ext,
  rw mem_closure_iff_ultrafilter,
  split,
  { rintro ⟨F, h1, h2⟩,
    exact ⟨F, h1, le_nhds_of_str_eq _ _ h2⟩ },
  { rintro ⟨F, h1, h2⟩,
    exact ⟨F, h1, str_eq_of_le_nhds _ _ h2⟩ }
end

/-- Any morphism of compacta is continuous. -/
lemma continuous_of_hom {X Y : Compactum} (f : X ⟶ Y) : continuous f :=
begin
  rw continuous_iff_ultrafilter,
  intros x _ h,
  rw [tendsto, ← coe_map],
  apply le_nhds_of_str_eq,
  rw [← str_hom_commute, str_eq_of_le_nhds _ x h]
end

/-- Given any compact Hausdorff space, we construct a Compactum. -/
noncomputable def of_topological_space (X : Type*) [topological_space X]
  [compact_space X] [t2_space X] : Compactum :=
{ A := X,
  a := ultrafilter.Lim,
  unit' := by {ext x, exact Lim_eq (pure_le_nhds _) },
  assoc' := begin
    ext FF,
    change ultrafilter (ultrafilter X) at FF,
    set x := (ultrafilter.map ultrafilter.Lim FF).Lim with c1,
    have c2 : ∀ (U : set X) (F : ultrafilter X), F.Lim ∈ U → is_open U → U ∈ F,
    { intros U F h1 hU,
      exact c1 ▸ is_open_iff_ultrafilter.mp hU _ h1 _ (ultrafilter.le_nhds_Lim _) },
    have c3 : ↑(ultrafilter.map ultrafilter.Lim FF) ≤ 𝓝 x,
    { rw le_nhds_iff,
      intros U hx hU,
      exact mem_coe.2 (c2 _ _ (by rwa ← c1) hU) },
    have c4 : ∀ (U : set X), x ∈ U → is_open U → { G : ultrafilter X | U ∈ G } ∈ FF,
    { intros U hx hU,
      suffices : ultrafilter.Lim ⁻¹' U ∈ FF,
      { apply mem_of_superset this,
        intros P hP,
        exact c2 U P hP hU },
      exact @c3 U (is_open.mem_nhds hU hx) },
    apply Lim_eq,
    rw le_nhds_iff,
    exact c4,
  end }

/-- Any continuous map between Compacta is a morphism of compacta. -/
def hom_of_continuous {X Y : Compactum} (f : X → Y) (cont : continuous f) : X ⟶ Y :=
{ f := f,
  h' := begin
    rw continuous_iff_ultrafilter at cont,
    ext (F : ultrafilter X),
    specialize cont (X.str F) F (le_nhds_of_str_eq F (X.str F) rfl),
    have := str_eq_of_le_nhds (ultrafilter.map f F) _ cont,
    simpa only [←this, types_comp_apply, of_type_functor_map],
  end }

end Compactum

/-- The functor functor from Compactum to CompHaus. -/
def Compactum_to_CompHaus : Compactum ⥤ CompHaus :=
{ obj := λ X, { to_Top := { α := X } },
  map := λ X Y f,
  { to_fun := f,
    continuous_to_fun := Compactum.continuous_of_hom _ }}

namespace Compactum_to_CompHaus

/-- The functor Compactum_to_CompHaus is full. -/
def full : full Compactum_to_CompHaus.{u} :=
{ preimage := λ X Y f, Compactum.hom_of_continuous f.1 f.2 }

/-- The functor Compactum_to_CompHaus is faithful. -/
lemma faithful : faithful Compactum_to_CompHaus := {}

/-- This definition is used to prove essential surjectivity of Compactum_to_CompHaus. -/
def iso_of_topological_space {D : CompHaus} :
  Compactum_to_CompHaus.obj (Compactum.of_topological_space D) ≅ D :=
{ hom :=
  { to_fun := id,
    continuous_to_fun := continuous_def.2 $ λ _ h, by {rw is_open_iff_ultrafilter' at h, exact h} },
  inv :=
  { to_fun := id,
    continuous_to_fun := continuous_def.2 $
      λ _ h1, by {rw is_open_iff_ultrafilter', intros _ h2, exact h1 _ h2} } }

/-- The functor Compactum_to_CompHaus is essentially surjective. -/
lemma ess_surj : ess_surj Compactum_to_CompHaus :=
{ mem_ess_image := λ X, ⟨Compactum.of_topological_space X, ⟨iso_of_topological_space⟩⟩ }

/-- The functor Compactum_to_CompHaus is an equivalence of categories. -/
noncomputable instance is_equivalence : is_equivalence Compactum_to_CompHaus :=
begin
  apply equivalence.of_fully_faithfully_ess_surj _,
  exact Compactum_to_CompHaus.full,
  exact Compactum_to_CompHaus.faithful,
  exact Compactum_to_CompHaus.ess_surj,
end

end Compactum_to_CompHaus

/-- The forgetful functors of `Compactum` and `CompHaus` are compatible via
`Compactum_to_CompHaus`. -/
def Compactum_to_CompHaus_comp_forget :
  Compactum_to_CompHaus ⋙ category_theory.forget CompHaus ≅ Compactum.forget :=
nat_iso.of_components (λ X, eq_to_iso rfl) $
by { intros X Y f, dsimp, simpa }

/-
TODO: `forget CompHaus` is monadic, as it is isomorphic to the composition
of an equivalence with the monadic functor `forget Compactum`.
Once we have the API to transfer monadicity of functors along such isomorphisms,
the instance `creates_limits (forget CompHaus)` can be deduced from this
monadicity.
-/

noncomputable
instance CompHaus.forget_creates_limits : creates_limits (forget CompHaus) :=
begin
  let e : forget CompHaus ≅ Compactum_to_CompHaus.inv ⋙ Compactum.forget :=
    _ ≪≫ iso_whisker_left _ Compactum_to_CompHaus_comp_forget,
  swap,
  refine _ ≪≫ functor.associator _ _ _,
  refine (functor.left_unitor _).symm ≪≫ _,
  refine iso_whisker_right _ _,
  exact Compactum_to_CompHaus.as_equivalence.symm.unit_iso,
  exact creates_limits_of_nat_iso e.symm,
end

noncomputable
instance Profinite.forget_creates_limits : creates_limits (forget Profinite) :=
begin
  change creates_limits (Profinite_to_CompHaus ⋙ forget _),
  apply_instance,
end


/-
Copyright (c) 2022 George Peter Banyard, Yaël Dillies, Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: George Peter Banyard, Yaël Dillies, Kyle Miller

! This file was ported from Lean 3 source module combinatorics.simple_graph.prod
! leanprover-community/mathlib commit f47581155c818e6361af4e4fda60d27d020c226b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Combinatorics.SimpleGraph.Connectivity

/-!
# Graph products

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file defines the box product of graphs and other product constructions. The box product of `G`
and `H` is the graph on the product of the vertices such that `x` and `y` are related iff they agree
on one component and the other one is related via either `G` or `H`. For example, the box product of
two edges is a square.

## Main declarations

* `simple_graph.box_prod`: The box product.

## Notation

* `G □ H`: The box product of `G` and `H`.

## TODO

Define all other graph products!
-/

variable {α β γ : Type _}

namespace SimpleGraph

variable {G : SimpleGraph α} {H : SimpleGraph β} {I : SimpleGraph γ} {a a₁ a₂ : α} {b b₁ b₂ : β}
  {x y : α × β}

#print SimpleGraph.boxProd /-
/-- Box product of simple graphs. It relates `(a₁, b)` and `(a₂, b)` if `G` relates `a₁` and `a₂`,
and `(a, b₁)` and `(a, b₂)` if `H` relates `b₁` and `b₂`. -/
def boxProd (G : SimpleGraph α) (H : SimpleGraph β) : SimpleGraph (α × β)
    where
  Adj x y := G.Adj x.1 y.1 ∧ x.2 = y.2 ∨ H.Adj x.2 y.2 ∧ x.1 = y.1
  symm x y := by simp [and_comm', or_comm', eq_comm, adj_comm]
  loopless x := by simp
#align simple_graph.box_prod SimpleGraph.boxProd
-/

-- mathport name: «expr □ »
infixl:70 " □ " => boxProd

/- warning: simple_graph.box_prod_adj -> SimpleGraph.boxProd_adj is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {G : SimpleGraph.{u1} α} {H : SimpleGraph.{u2} β} {x : Prod.{u1, u2} α β} {y : Prod.{u1, u2} α β}, Iff (SimpleGraph.Adj.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H) x y) (Or (And (SimpleGraph.Adj.{u1} α G (Prod.fst.{u1, u2} α β x) (Prod.fst.{u1, u2} α β y)) (Eq.{succ u2} β (Prod.snd.{u1, u2} α β x) (Prod.snd.{u1, u2} α β y))) (And (SimpleGraph.Adj.{u2} β H (Prod.snd.{u1, u2} α β x) (Prod.snd.{u1, u2} α β y)) (Eq.{succ u1} α (Prod.fst.{u1, u2} α β x) (Prod.fst.{u1, u2} α β y))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {G : SimpleGraph.{u2} α} {H : SimpleGraph.{u1} β} {x : Prod.{u2, u1} α β} {y : Prod.{u2, u1} α β}, Iff (SimpleGraph.Adj.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H) x y) (Or (And (SimpleGraph.Adj.{u2} α G (Prod.fst.{u2, u1} α β x) (Prod.fst.{u2, u1} α β y)) (Eq.{succ u1} β (Prod.snd.{u2, u1} α β x) (Prod.snd.{u2, u1} α β y))) (And (SimpleGraph.Adj.{u1} β H (Prod.snd.{u2, u1} α β x) (Prod.snd.{u2, u1} α β y)) (Eq.{succ u2} α (Prod.fst.{u2, u1} α β x) (Prod.fst.{u2, u1} α β y))))
Case conversion may be inaccurate. Consider using '#align simple_graph.box_prod_adj SimpleGraph.boxProd_adjₓ'. -/
@[simp]
theorem boxProd_adj : (G □ H).Adj x y ↔ G.Adj x.1 y.1 ∧ x.2 = y.2 ∨ H.Adj x.2 y.2 ∧ x.1 = y.1 :=
  Iff.rfl
#align simple_graph.box_prod_adj SimpleGraph.boxProd_adj

/- warning: simple_graph.box_prod_adj_left -> SimpleGraph.boxProd_adj_left is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {G : SimpleGraph.{u1} α} {H : SimpleGraph.{u2} β} {a₁ : α} {a₂ : α} {b : β}, Iff (SimpleGraph.Adj.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H) (Prod.mk.{u1, u2} α β a₁ b) (Prod.mk.{u1, u2} α β a₂ b)) (SimpleGraph.Adj.{u1} α G a₁ a₂)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {G : SimpleGraph.{u2} α} {H : SimpleGraph.{u1} β} {a₁ : α} {a₂ : β} {b : α}, Iff (SimpleGraph.Adj.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H) (Prod.mk.{u2, u1} α β a₁ a₂) (Prod.mk.{u2, u1} α β b a₂)) (SimpleGraph.Adj.{u2} α G a₁ b)
Case conversion may be inaccurate. Consider using '#align simple_graph.box_prod_adj_left SimpleGraph.boxProd_adj_leftₓ'. -/
@[simp]
theorem boxProd_adj_left : (G □ H).Adj (a₁, b) (a₂, b) ↔ G.Adj a₁ a₂ := by
  rw [box_prod_adj, and_iff_left rfl, or_iff_left fun h : H.adj b b ∧ _ => h.1.Ne rfl]
#align simple_graph.box_prod_adj_left SimpleGraph.boxProd_adj_left

/- warning: simple_graph.box_prod_adj_right -> SimpleGraph.boxProd_adj_right is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {G : SimpleGraph.{u1} α} {H : SimpleGraph.{u2} β} {a : α} {b₁ : β} {b₂ : β}, Iff (SimpleGraph.Adj.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H) (Prod.mk.{u1, u2} α β a b₁) (Prod.mk.{u1, u2} α β a b₂)) (SimpleGraph.Adj.{u2} β H b₁ b₂)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {G : SimpleGraph.{u2} α} {H : SimpleGraph.{u1} β} {a : α} {b₁ : β} {b₂ : β}, Iff (SimpleGraph.Adj.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H) (Prod.mk.{u2, u1} α β a b₁) (Prod.mk.{u2, u1} α β a b₂)) (SimpleGraph.Adj.{u1} β H b₁ b₂)
Case conversion may be inaccurate. Consider using '#align simple_graph.box_prod_adj_right SimpleGraph.boxProd_adj_rightₓ'. -/
@[simp]
theorem boxProd_adj_right : (G □ H).Adj (a, b₁) (a, b₂) ↔ H.Adj b₁ b₂ := by
  rw [box_prod_adj, and_iff_left rfl, or_iff_right fun h : G.adj a a ∧ _ => h.1.Ne rfl]
#align simple_graph.box_prod_adj_right SimpleGraph.boxProd_adj_right

/- warning: simple_graph.box_prod_neighbor_set -> SimpleGraph.boxProd_neighborSet is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {G : SimpleGraph.{u1} α} {H : SimpleGraph.{u2} β} (x : Prod.{u1, u2} α β), Eq.{succ (max u1 u2)} (Set.{max u1 u2} (Prod.{u1, u2} α β)) (SimpleGraph.neighborSet.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H) x) (Union.union.{max u1 u2} (Set.{max u1 u2} (Prod.{u1, u2} α β)) (Set.hasUnion.{max u1 u2} (Prod.{u1, u2} α β)) (Set.prod.{u1, u2} α β (SimpleGraph.neighborSet.{u1} α G (Prod.fst.{u1, u2} α β x)) (Singleton.singleton.{u2, u2} β (Set.{u2} β) (Set.hasSingleton.{u2} β) (Prod.snd.{u1, u2} α β x))) (Set.prod.{u1, u2} α β (Singleton.singleton.{u1, u1} α (Set.{u1} α) (Set.hasSingleton.{u1} α) (Prod.fst.{u1, u2} α β x)) (SimpleGraph.neighborSet.{u2} β H (Prod.snd.{u1, u2} α β x))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {G : SimpleGraph.{u2} α} {H : SimpleGraph.{u1} β} (x : Prod.{u2, u1} α β), Eq.{max (succ u2) (succ u1)} (Set.{max u2 u1} (Prod.{u2, u1} α β)) (SimpleGraph.neighborSet.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H) x) (Union.union.{max u1 u2} (Set.{max u1 u2} (Prod.{u2, u1} α β)) (Set.instUnionSet.{max u2 u1} (Prod.{u2, u1} α β)) (Set.prod.{u2, u1} α β (SimpleGraph.neighborSet.{u2} α G (Prod.fst.{u2, u1} α β x)) (Singleton.singleton.{u1, u1} β (Set.{u1} β) (Set.instSingletonSet.{u1} β) (Prod.snd.{u2, u1} α β x))) (Set.prod.{u2, u1} α β (Singleton.singleton.{u2, u2} α (Set.{u2} α) (Set.instSingletonSet.{u2} α) (Prod.fst.{u2, u1} α β x)) (SimpleGraph.neighborSet.{u1} β H (Prod.snd.{u2, u1} α β x))))
Case conversion may be inaccurate. Consider using '#align simple_graph.box_prod_neighbor_set SimpleGraph.boxProd_neighborSetₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem boxProd_neighborSet (x : α × β) :
    (G □ H).neighborSet x = G.neighborSet x.1 ×ˢ {x.2} ∪ {x.1} ×ˢ H.neighborSet x.2 :=
  by
  ext ⟨a', b'⟩
  simp only [mem_neighbor_set, Set.mem_union, box_prod_adj, Set.mem_prod, Set.mem_singleton_iff]
  simp only [eq_comm, and_comm']
#align simple_graph.box_prod_neighbor_set SimpleGraph.boxProd_neighborSet

variable (G H I)

#print SimpleGraph.boxProdComm /-
/-- The box product is commutative up to isomorphism. `equiv.prod_comm` as a graph isomorphism. -/
@[simps]
def boxProdComm : G □ H ≃g H □ G :=
  ⟨Equiv.prodComm _ _, fun x y => or_comm' _ _⟩
#align simple_graph.box_prod_comm SimpleGraph.boxProdComm
-/

#print SimpleGraph.boxProdAssoc /-
/-- The box product is associative up to isomorphism. `equiv.prod_assoc` as a graph isomorphism. -/
@[simps]
def boxProdAssoc : G □ H □ I ≃g G □ (H □ I) :=
  ⟨Equiv.prodAssoc _ _ _, fun x y => by
    simp only [box_prod_adj, Equiv.prodAssoc_apply, or_and_right, or_assoc', Prod.ext_iff,
      and_assoc', @and_comm (x.1.1 = _)]⟩
#align simple_graph.box_prod_assoc SimpleGraph.boxProdAssoc
-/

#print SimpleGraph.boxProdLeft /-
/-- The embedding of `G` into `G □ H` given by `b`. -/
@[simps]
def boxProdLeft (b : β) : G ↪g G □ H where
  toFun a := (a, b)
  inj' a₁ a₂ := congr_arg Prod.fst
  map_rel_iff' a₁ a₂ := boxProd_adj_left
#align simple_graph.box_prod_left SimpleGraph.boxProdLeft
-/

#print SimpleGraph.boxProdRight /-
/-- The embedding of `H` into `G □ H` given by `a`. -/
@[simps]
def boxProdRight (a : α) : H ↪g G □ H
    where
  toFun := Prod.mk a
  inj' b₁ b₂ := congr_arg Prod.snd
  map_rel_iff' b₁ b₂ := boxProd_adj_right
#align simple_graph.box_prod_right SimpleGraph.boxProdRight
-/

namespace Walk

variable {G}

#print SimpleGraph.Walk.boxProdLeft /-
/-- Turn a walk on `G` into a walk on `G □ H`. -/
protected def boxProdLeft (b : β) : G.Walk a₁ a₂ → (G □ H).Walk (a₁, b) (a₂, b) :=
  Walk.map (G.boxProdLeft H b).toHom
#align simple_graph.walk.box_prod_left SimpleGraph.Walk.boxProdLeft
-/

variable (G) {H}

#print SimpleGraph.Walk.boxProdRight /-
/-- Turn a walk on `H` into a walk on `G □ H`. -/
protected def boxProdRight (a : α) : H.Walk b₁ b₂ → (G □ H).Walk (a, b₁) (a, b₂) :=
  Walk.map (G.boxProdRight H a).toHom
#align simple_graph.walk.box_prod_right SimpleGraph.Walk.boxProdRight
-/

variable {G}

#print SimpleGraph.Walk.ofBoxProdLeft /-
/-- Project a walk on `G □ H` to a walk on `G` by discarding the moves in the direction of `H`. -/
def ofBoxProdLeft [DecidableEq β] [DecidableRel G.Adj] :
    ∀ {x y : α × β}, (G □ H).Walk x y → G.Walk x.1 y.1
  | _, _, nil => nil
  | x, z, cons h w =>
    Or.by_cases h (fun hG => w.ofBoxProdLeft.cons hG.1) fun hH =>
      show G.Walk x.1 z.1 by rw [hH.2] <;> exact w.of_box_prod_left
#align simple_graph.walk.of_box_prod_left SimpleGraph.Walk.ofBoxProdLeft
-/

#print SimpleGraph.Walk.ofBoxProdRight /-
/-- Project a walk on `G □ H` to a walk on `H` by discarding the moves in the direction of `G`. -/
def ofBoxProdRight [DecidableEq α] [DecidableRel H.Adj] :
    ∀ {x y : α × β}, (G □ H).Walk x y → H.Walk x.2 y.2
  | _, _, nil => nil
  | x, z, cons h w =>
    (Or.symm h).byCases (fun hH => w.ofBoxProdRight.cons hH.1) fun hG =>
      show H.Walk x.2 z.2 by rw [hG.2] <;> exact w.of_box_prod_right
#align simple_graph.walk.of_box_prod_right SimpleGraph.Walk.ofBoxProdRight
-/

#print SimpleGraph.Walk.ofBoxProdLeft_boxProdLeft /-
@[simp]
theorem ofBoxProdLeft_boxProdLeft [DecidableEq β] [DecidableRel G.Adj] :
    ∀ {a₁ a₂ : α} (w : G.Walk a₁ a₂), (w.boxProdLeft H b).ofBoxProdLeft = w
  | _, _, nil => rfl
  | _, _, cons' x y z h w =>
    by
    rw [walk.box_prod_left, map_cons, of_box_prod_left, Or.by_cases, dif_pos, ← walk.box_prod_left,
      of_box_prod_left_box_prod_left]
    exacts[rfl, ⟨h, rfl⟩]
#align simple_graph.walk.of_box_prod_left_box_prod_left SimpleGraph.Walk.ofBoxProdLeft_boxProdLeft
-/

#print SimpleGraph.Walk.ofBoxProdLeft_boxProdRight /-
@[simp]
theorem ofBoxProdLeft_boxProdRight [DecidableEq α] [DecidableRel G.Adj] :
    ∀ {b₁ b₂ : α} (w : G.Walk b₁ b₂), (w.boxProdRight G a).ofBoxProdRight = w
  | _, _, nil => rfl
  | _, _, cons' x y z h w =>
    by
    rw [walk.box_prod_right, map_cons, of_box_prod_right, Or.by_cases, dif_pos, ←
      walk.box_prod_right, of_box_prod_left_box_prod_right]
    exacts[rfl, ⟨h, rfl⟩]
#align simple_graph.walk.of_box_prod_left_box_prod_right SimpleGraph.Walk.ofBoxProdLeft_boxProdRight
-/

end Walk

variable {G H}

/- warning: simple_graph.preconnected.box_prod -> SimpleGraph.Preconnected.boxProd is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {G : SimpleGraph.{u1} α} {H : SimpleGraph.{u2} β}, (SimpleGraph.Preconnected.{u1} α G) -> (SimpleGraph.Preconnected.{u2} β H) -> (SimpleGraph.Preconnected.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {G : SimpleGraph.{u2} α} {H : SimpleGraph.{u1} β}, (SimpleGraph.Preconnected.{u2} α G) -> (SimpleGraph.Preconnected.{u1} β H) -> (SimpleGraph.Preconnected.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H))
Case conversion may be inaccurate. Consider using '#align simple_graph.preconnected.box_prod SimpleGraph.Preconnected.boxProdₓ'. -/
protected theorem Preconnected.boxProd (hG : G.Preconnected) (hH : H.Preconnected) :
    (G □ H).Preconnected := by
  rintro x y
  obtain ⟨w₁⟩ := hG x.1 y.1
  obtain ⟨w₂⟩ := hH x.2 y.2
  rw [← @Prod.mk.eta _ _ x, ← @Prod.mk.eta _ _ y]
  exact ⟨(w₁.box_prod_left _ _).append (w₂.box_prod_right _ _)⟩
#align simple_graph.preconnected.box_prod SimpleGraph.Preconnected.boxProd

#print SimpleGraph.Preconnected.ofBoxProdLeft /-
protected theorem Preconnected.ofBoxProdLeft [Nonempty β] (h : (G □ H).Preconnected) :
    G.Preconnected := by
  classical
    rintro a₁ a₂
    obtain ⟨w⟩ := h (a₁, Classical.arbitrary _) (a₂, Classical.arbitrary _)
    exact ⟨w.of_box_prod_left⟩
#align simple_graph.preconnected.of_box_prod_left SimpleGraph.Preconnected.ofBoxProdLeft
-/

/- warning: simple_graph.preconnected.of_box_prod_right -> SimpleGraph.Preconnected.ofBoxProdRight is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {G : SimpleGraph.{u1} α} {H : SimpleGraph.{u2} β} [_inst_1 : Nonempty.{succ u1} α], (SimpleGraph.Preconnected.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H)) -> (SimpleGraph.Preconnected.{u2} β H)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {G : SimpleGraph.{u2} α} {H : SimpleGraph.{u1} β} [_inst_1 : Nonempty.{succ u2} α], (SimpleGraph.Preconnected.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H)) -> (SimpleGraph.Preconnected.{u1} β H)
Case conversion may be inaccurate. Consider using '#align simple_graph.preconnected.of_box_prod_right SimpleGraph.Preconnected.ofBoxProdRightₓ'. -/
protected theorem Preconnected.ofBoxProdRight [Nonempty α] (h : (G □ H).Preconnected) :
    H.Preconnected := by
  classical
    rintro b₁ b₂
    obtain ⟨w⟩ := h (Classical.arbitrary _, b₁) (Classical.arbitrary _, b₂)
    exact ⟨w.of_box_prod_right⟩
#align simple_graph.preconnected.of_box_prod_right SimpleGraph.Preconnected.ofBoxProdRight

/- warning: simple_graph.connected.box_prod -> SimpleGraph.Connected.boxProd is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {G : SimpleGraph.{u1} α} {H : SimpleGraph.{u2} β}, (SimpleGraph.Connected.{u1} α G) -> (SimpleGraph.Connected.{u2} β H) -> (SimpleGraph.Connected.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {G : SimpleGraph.{u2} α} {H : SimpleGraph.{u1} β}, (SimpleGraph.Connected.{u2} α G) -> (SimpleGraph.Connected.{u1} β H) -> (SimpleGraph.Connected.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H))
Case conversion may be inaccurate. Consider using '#align simple_graph.connected.box_prod SimpleGraph.Connected.boxProdₓ'. -/
protected theorem Connected.boxProd (hG : G.Connected) (hH : H.Connected) : (G □ H).Connected :=
  by
  haveI := hG.nonempty
  haveI := hH.nonempty
  exact ⟨hG.preconnected.box_prod hH.preconnected⟩
#align simple_graph.connected.box_prod SimpleGraph.Connected.boxProd

/- warning: simple_graph.connected.of_box_prod_left -> SimpleGraph.Connected.ofBoxProdLeft is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {G : SimpleGraph.{u1} α} {H : SimpleGraph.{u2} β}, (SimpleGraph.Connected.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H)) -> (SimpleGraph.Connected.{u1} α G)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {G : SimpleGraph.{u2} α} {H : SimpleGraph.{u1} β}, (SimpleGraph.Connected.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H)) -> (SimpleGraph.Connected.{u2} α G)
Case conversion may be inaccurate. Consider using '#align simple_graph.connected.of_box_prod_left SimpleGraph.Connected.ofBoxProdLeftₓ'. -/
protected theorem Connected.ofBoxProdLeft (h : (G □ H).Connected) : G.Connected :=
  by
  haveI := (nonempty_prod.1 h.nonempty).1
  haveI := (nonempty_prod.1 h.nonempty).2
  exact ⟨h.preconnected.of_box_prod_left⟩
#align simple_graph.connected.of_box_prod_left SimpleGraph.Connected.ofBoxProdLeft

/- warning: simple_graph.connected.of_box_prod_right -> SimpleGraph.Connected.ofBoxProdRight is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {G : SimpleGraph.{u1} α} {H : SimpleGraph.{u2} β}, (SimpleGraph.Connected.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H)) -> (SimpleGraph.Connected.{u2} β H)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {G : SimpleGraph.{u2} α} {H : SimpleGraph.{u1} β}, (SimpleGraph.Connected.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H)) -> (SimpleGraph.Connected.{u1} β H)
Case conversion may be inaccurate. Consider using '#align simple_graph.connected.of_box_prod_right SimpleGraph.Connected.ofBoxProdRightₓ'. -/
protected theorem Connected.ofBoxProdRight (h : (G □ H).Connected) : H.Connected :=
  by
  haveI := (nonempty_prod.1 h.nonempty).1
  haveI := (nonempty_prod.1 h.nonempty).2
  exact ⟨h.preconnected.of_box_prod_right⟩
#align simple_graph.connected.of_box_prod_right SimpleGraph.Connected.ofBoxProdRight

/- warning: simple_graph.box_prod_connected -> SimpleGraph.boxProd_connected is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {G : SimpleGraph.{u1} α} {H : SimpleGraph.{u2} β}, Iff (SimpleGraph.Connected.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H)) (And (SimpleGraph.Connected.{u1} α G) (SimpleGraph.Connected.{u2} β H))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {G : SimpleGraph.{u2} α} {H : SimpleGraph.{u1} β}, Iff (SimpleGraph.Connected.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H)) (And (SimpleGraph.Connected.{u2} α G) (SimpleGraph.Connected.{u1} β H))
Case conversion may be inaccurate. Consider using '#align simple_graph.box_prod_connected SimpleGraph.boxProd_connectedₓ'. -/
@[simp]
theorem boxProd_connected : (G □ H).Connected ↔ G.Connected ∧ H.Connected :=
  ⟨fun h => ⟨h.ofBoxProdLeft, h.ofBoxProdRight⟩, fun h => h.1.boxProd h.2⟩
#align simple_graph.box_prod_connected SimpleGraph.boxProd_connected

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
#print SimpleGraph.boxProdFintypeNeighborSet /-
instance boxProdFintypeNeighborSet (x : α × β) [Fintype (G.neighborSet x.1)]
    [Fintype (H.neighborSet x.2)] : Fintype ((G □ H).neighborSet x) :=
  Fintype.ofEquiv
    ((G.neighborFinset x.1 ×ˢ {x.2}).disjUnion ({x.1} ×ˢ H.neighborFinset x.2) <|
      Finset.disjoint_product.mpr <| Or.inl <| neighborFinset_disjoint_singleton _ _)
    ((Equiv.refl _).subtypeEquiv fun y =>
      by
      simp_rw [Finset.mem_disjUnion, Finset.mem_product, Finset.mem_singleton, mem_neighbor_finset,
        mem_neighbor_set, Equiv.refl_apply, box_prod_adj]
      simp only [eq_comm, and_comm'])
#align simple_graph.box_prod_fintype_neighbor_set SimpleGraph.boxProdFintypeNeighborSet
-/

/- warning: simple_graph.box_prod_neighbor_finset -> SimpleGraph.boxProd_neighborFinset is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {G : SimpleGraph.{u1} α} {H : SimpleGraph.{u2} β} (x : Prod.{u1, u2} α β) [_inst_1 : Fintype.{u1} (coeSort.{succ u1, succ (succ u1)} (Set.{u1} α) Type.{u1} (Set.hasCoeToSort.{u1} α) (SimpleGraph.neighborSet.{u1} α G (Prod.fst.{u1, u2} α β x)))] [_inst_2 : Fintype.{u2} (coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) (SimpleGraph.neighborSet.{u2} β H (Prod.snd.{u1, u2} α β x)))] [_inst_3 : Fintype.{max u1 u2} (coeSort.{succ (max u1 u2), succ (succ (max u1 u2))} (Set.{max u1 u2} (Prod.{u1, u2} α β)) Type.{max u1 u2} (Set.hasCoeToSort.{max u1 u2} (Prod.{u1, u2} α β)) (SimpleGraph.neighborSet.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H) x))], Eq.{succ (max u1 u2)} (Finset.{max u1 u2} (Prod.{u1, u2} α β)) (SimpleGraph.neighborFinset.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H) x _inst_3) (Finset.disjUnion.{max u1 u2} (Prod.{u1, u2} α β) (Finset.product.{u1, u2} α β (SimpleGraph.neighborFinset.{u1} α G (Prod.fst.{u1, u2} α β x) _inst_1) (Singleton.singleton.{u2, u2} β (Finset.{u2} β) (Finset.hasSingleton.{u2} β) (Prod.snd.{u1, u2} α β x))) (Finset.product.{u1, u2} α β (Singleton.singleton.{u1, u1} α (Finset.{u1} α) (Finset.hasSingleton.{u1} α) (Prod.fst.{u1, u2} α β x)) (SimpleGraph.neighborFinset.{u2} β H (Prod.snd.{u1, u2} α β x) _inst_2)) (Iff.mpr (Disjoint.{max u1 u2} (Finset.{max u1 u2} (Prod.{u1, u2} α β)) (Finset.partialOrder.{max u1 u2} (Prod.{u1, u2} α β)) (Finset.orderBot.{max u1 u2} (Prod.{u1, u2} α β)) (Finset.product.{u1, u2} α β (SimpleGraph.neighborFinset.{u1} α G (Prod.fst.{u1, u2} α β x) _inst_1) (Singleton.singleton.{u2, u2} β (Finset.{u2} β) (Finset.hasSingleton.{u2} β) (Prod.snd.{u1, u2} α β x))) (Finset.product.{u1, u2} α β (Singleton.singleton.{u1, u1} α (Finset.{u1} α) (Finset.hasSingleton.{u1} α) (Prod.fst.{u1, u2} α β x)) (SimpleGraph.neighborFinset.{u2} β H (Prod.snd.{u1, u2} α β x) _inst_2))) (Or (Disjoint.{u1} (Finset.{u1} α) (Finset.partialOrder.{u1} α) (Finset.orderBot.{u1} α) (SimpleGraph.neighborFinset.{u1} α G (Prod.fst.{u1, u2} α β x) _inst_1) (Singleton.singleton.{u1, u1} α (Finset.{u1} α) (Finset.hasSingleton.{u1} α) (Prod.fst.{u1, u2} α β x))) (Disjoint.{u2} (Finset.{u2} β) (Finset.partialOrder.{u2} β) (Finset.orderBot.{u2} β) (Singleton.singleton.{u2, u2} β (Finset.{u2} β) (Finset.hasSingleton.{u2} β) (Prod.snd.{u1, u2} α β x)) (SimpleGraph.neighborFinset.{u2} β H (Prod.snd.{u1, u2} α β x) _inst_2))) (Finset.disjoint_product.{u1, u2} α β (SimpleGraph.neighborFinset.{u1} α G (Prod.fst.{u1, u2} α β x) _inst_1) (Singleton.singleton.{u1, u1} α (Finset.{u1} α) (Finset.hasSingleton.{u1} α) (Prod.fst.{u1, u2} α β x)) (Singleton.singleton.{u2, u2} β (Finset.{u2} β) (Finset.hasSingleton.{u2} β) (Prod.snd.{u1, u2} α β x)) (SimpleGraph.neighborFinset.{u2} β H (Prod.snd.{u1, u2} α β x) _inst_2)) (Or.inl (Disjoint.{u1} (Finset.{u1} α) (Finset.partialOrder.{u1} α) (Finset.orderBot.{u1} α) (SimpleGraph.neighborFinset.{u1} α G (Prod.fst.{u1, u2} α β x) _inst_1) (Singleton.singleton.{u1, u1} α (Finset.{u1} α) (Finset.hasSingleton.{u1} α) (Prod.fst.{u1, u2} α β x))) (Disjoint.{u2} (Finset.{u2} β) (Finset.partialOrder.{u2} β) (Finset.orderBot.{u2} β) (Singleton.singleton.{u2, u2} β (Finset.{u2} β) (Finset.hasSingleton.{u2} β) (Prod.snd.{u1, u2} α β x)) (SimpleGraph.neighborFinset.{u2} β H (Prod.snd.{u1, u2} α β x) _inst_2)) (SimpleGraph.neighborFinset_disjoint_singleton.{u1} α G (Prod.fst.{u1, u2} α β x) _inst_1))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {G : SimpleGraph.{u2} α} {H : SimpleGraph.{u1} β} (x : Prod.{u2, u1} α β) [_inst_1 : Fintype.{u2} (Set.Elem.{u2} α (SimpleGraph.neighborSet.{u2} α G (Prod.fst.{u2, u1} α β x)))] [_inst_2 : Fintype.{u1} (Set.Elem.{u1} β (SimpleGraph.neighborSet.{u1} β H (Prod.snd.{u2, u1} α β x)))] [_inst_3 : Fintype.{max u2 u1} (Set.Elem.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.neighborSet.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H) x))], Eq.{max (succ u2) (succ u1)} (Finset.{max u2 u1} (Prod.{u2, u1} α β)) (SimpleGraph.neighborFinset.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H) x _inst_3) (Finset.disjUnion.{max u2 u1} (Prod.{u2, u1} α β) (Finset.product.{u2, u1} α β (SimpleGraph.neighborFinset.{u2} α G (Prod.fst.{u2, u1} α β x) _inst_1) (Singleton.singleton.{u1, u1} β (Finset.{u1} β) (Finset.instSingletonFinset.{u1} β) (Prod.snd.{u2, u1} α β x))) (Finset.product.{u2, u1} α β (Singleton.singleton.{u2, u2} α (Finset.{u2} α) (Finset.instSingletonFinset.{u2} α) (Prod.fst.{u2, u1} α β x)) (SimpleGraph.neighborFinset.{u1} β H (Prod.snd.{u2, u1} α β x) _inst_2)) (Iff.mpr (Disjoint.{max u1 u2} (Finset.{max u1 u2} (Prod.{u2, u1} α β)) (Finset.partialOrder.{max u2 u1} (Prod.{u2, u1} α β)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{max u2 u1} (Prod.{u2, u1} α β)) (Finset.product.{u2, u1} α β (SimpleGraph.neighborFinset.{u2} α G (Prod.fst.{u2, u1} α β x) _inst_1) (Singleton.singleton.{u1, u1} β (Finset.{u1} β) (Finset.instSingletonFinset.{u1} β) (Prod.snd.{u2, u1} α β x))) (Finset.product.{u2, u1} α β (Singleton.singleton.{u2, u2} α (Finset.{u2} α) (Finset.instSingletonFinset.{u2} α) (Prod.fst.{u2, u1} α β x)) (SimpleGraph.neighborFinset.{u1} β H (Prod.snd.{u2, u1} α β x) _inst_2))) (Or (Disjoint.{u2} (Finset.{u2} α) (Finset.partialOrder.{u2} α) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u2} α) (SimpleGraph.neighborFinset.{u2} α G (Prod.fst.{u2, u1} α β x) _inst_1) (Singleton.singleton.{u2, u2} α (Finset.{u2} α) (Finset.instSingletonFinset.{u2} α) (Prod.fst.{u2, u1} α β x))) (Disjoint.{u1} (Finset.{u1} β) (Finset.partialOrder.{u1} β) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} β) (Singleton.singleton.{u1, u1} β (Finset.{u1} β) (Finset.instSingletonFinset.{u1} β) (Prod.snd.{u2, u1} α β x)) (SimpleGraph.neighborFinset.{u1} β H (Prod.snd.{u2, u1} α β x) _inst_2))) (Finset.disjoint_product.{u2, u1} α β (SimpleGraph.neighborFinset.{u2} α G (Prod.fst.{u2, u1} α β x) _inst_1) (Singleton.singleton.{u2, u2} α (Finset.{u2} α) (Finset.instSingletonFinset.{u2} α) (Prod.fst.{u2, u1} α β x)) (Singleton.singleton.{u1, u1} β (Finset.{u1} β) (Finset.instSingletonFinset.{u1} β) (Prod.snd.{u2, u1} α β x)) (SimpleGraph.neighborFinset.{u1} β H (Prod.snd.{u2, u1} α β x) _inst_2)) (Or.inl (Disjoint.{u2} (Finset.{u2} α) (Finset.partialOrder.{u2} α) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u2} α) (SimpleGraph.neighborFinset.{u2} α G (Prod.fst.{u2, u1} α β x) _inst_1) (Singleton.singleton.{u2, u2} α (Finset.{u2} α) (Finset.instSingletonFinset.{u2} α) (Prod.fst.{u2, u1} α β x))) (Disjoint.{u1} (Finset.{u1} β) (Finset.partialOrder.{u1} β) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} β) (Singleton.singleton.{u1, u1} β (Finset.{u1} β) (Finset.instSingletonFinset.{u1} β) (Prod.snd.{u2, u1} α β x)) (SimpleGraph.neighborFinset.{u1} β H (Prod.snd.{u2, u1} α β x) _inst_2)) (SimpleGraph.neighborFinset_disjoint_singleton.{u2} α G (Prod.fst.{u2, u1} α β x) _inst_1))))
Case conversion may be inaccurate. Consider using '#align simple_graph.box_prod_neighbor_finset SimpleGraph.boxProd_neighborFinsetₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem boxProd_neighborFinset (x : α × β) [Fintype (G.neighborSet x.1)]
    [Fintype (H.neighborSet x.2)] [Fintype ((G □ H).neighborSet x)] :
    (G □ H).neighborFinset x =
      (G.neighborFinset x.1 ×ˢ {x.2}).disjUnion ({x.1} ×ˢ H.neighborFinset x.2)
        (Finset.disjoint_product.mpr <| Or.inl <| neighborFinset_disjoint_singleton _ _) :=
  by
  -- swap out the fintype instance for the canonical one
  letI : Fintype ((G □ H).neighborSet x) := SimpleGraph.boxProdFintypeNeighborSet _
  refine' Eq.trans _ Finset.attach_map_val
  convert Finset.map_map _ (Function.Embedding.subtype _) Finset.univ
#align simple_graph.box_prod_neighbor_finset SimpleGraph.boxProd_neighborFinset

/- warning: simple_graph.box_prod_degree -> SimpleGraph.boxProd_degree is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {G : SimpleGraph.{u1} α} {H : SimpleGraph.{u2} β} (x : Prod.{u1, u2} α β) [_inst_1 : Fintype.{u1} (coeSort.{succ u1, succ (succ u1)} (Set.{u1} α) Type.{u1} (Set.hasCoeToSort.{u1} α) (SimpleGraph.neighborSet.{u1} α G (Prod.fst.{u1, u2} α β x)))] [_inst_2 : Fintype.{u2} (coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) (SimpleGraph.neighborSet.{u2} β H (Prod.snd.{u1, u2} α β x)))] [_inst_3 : Fintype.{max u1 u2} (coeSort.{succ (max u1 u2), succ (succ (max u1 u2))} (Set.{max u1 u2} (Prod.{u1, u2} α β)) Type.{max u1 u2} (Set.hasCoeToSort.{max u1 u2} (Prod.{u1, u2} α β)) (SimpleGraph.neighborSet.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H) x))], Eq.{1} Nat (SimpleGraph.degree.{max u1 u2} (Prod.{u1, u2} α β) (SimpleGraph.boxProd.{u1, u2} α β G H) x _inst_3) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (SimpleGraph.degree.{u1} α G (Prod.fst.{u1, u2} α β x) _inst_1) (SimpleGraph.degree.{u2} β H (Prod.snd.{u1, u2} α β x) _inst_2))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {G : SimpleGraph.{u2} α} {H : SimpleGraph.{u1} β} (x : Prod.{u2, u1} α β) [_inst_1 : Fintype.{u2} (Set.Elem.{u2} α (SimpleGraph.neighborSet.{u2} α G (Prod.fst.{u2, u1} α β x)))] [_inst_2 : Fintype.{u1} (Set.Elem.{u1} β (SimpleGraph.neighborSet.{u1} β H (Prod.snd.{u2, u1} α β x)))] [_inst_3 : Fintype.{max u2 u1} (Set.Elem.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.neighborSet.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H) x))], Eq.{1} Nat (SimpleGraph.degree.{max u2 u1} (Prod.{u2, u1} α β) (SimpleGraph.boxProd.{u2, u1} α β G H) x _inst_3) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (SimpleGraph.degree.{u2} α G (Prod.fst.{u2, u1} α β x) _inst_1) (SimpleGraph.degree.{u1} β H (Prod.snd.{u2, u1} α β x) _inst_2))
Case conversion may be inaccurate. Consider using '#align simple_graph.box_prod_degree SimpleGraph.boxProd_degreeₓ'. -/
theorem boxProd_degree (x : α × β) [Fintype (G.neighborSet x.1)] [Fintype (H.neighborSet x.2)]
    [Fintype ((G □ H).neighborSet x)] : (G □ H).degree x = G.degree x.1 + H.degree x.2 :=
  by
  rw [degree, degree, degree, box_prod_neighbor_finset, Finset.card_disjUnion]
  simp_rw [Finset.card_product, Finset.card_singleton, mul_one, one_mul]
#align simple_graph.box_prod_degree SimpleGraph.boxProd_degree

end SimpleGraph


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.group.opposite
import group_theory.group_action.defs

/-!
# Scalar actions on and by `Mᵐᵒᵖ`

This file defines the actions on the opposite type `has_scalar R Mᵐᵒᵖ`, and actions by the opposite
type, `has_scalar Rᵐᵒᵖ M`.

Note that `mul_opposite.has_scalar` is provided in an earlier file as it is needed to provide the
`add_monoid.nsmul` and `add_comm_group.gsmul` fields.
-/

variables (α : Type*)

/-! ### Actions _on_ the opposite type

Actions on the opposite type just act on the underlying type.
-/

namespace mul_opposite

@[to_additive] instance (R : Type*) [monoid R] [mul_action R α] : mul_action R αᵐᵒᵖ :=
{ one_smul := λ x, unop_injective $ one_smul R (unop x),
  mul_smul := λ r₁ r₂ x, unop_injective $ mul_smul r₁ r₂ (unop x),
  .. mul_opposite.has_scalar α R }

instance (R : Type*) [monoid R] [add_monoid α] [distrib_mul_action R α] :
  distrib_mul_action R αᵐᵒᵖ :=
{ smul_add := λ r x₁ x₂, unop_injective $ smul_add r (unop x₁) (unop x₂),
  smul_zero := λ r, unop_injective $ smul_zero r,
  .. mul_opposite.mul_action α R }

instance (R : Type*) [monoid R] [monoid α] [mul_distrib_mul_action R α] :
  mul_distrib_mul_action R αᵐᵒᵖ :=
{ smul_mul := λ r x₁ x₂, unop_injective $ smul_mul' r (unop x₂) (unop x₁),
  smul_one := λ r, unop_injective $ smul_one r,
  .. mul_opposite.mul_action α R }

instance {M N} [has_scalar M N] [has_scalar M α] [has_scalar N α] [is_scalar_tower M N α] :
  is_scalar_tower M N αᵐᵒᵖ :=
⟨λ x y z, unop_injective $ smul_assoc _ _ _⟩

@[to_additive] instance {M N} [has_scalar M α] [has_scalar N α] [smul_comm_class M N α] :
  smul_comm_class M N αᵐᵒᵖ :=
⟨λ x y z, unop_injective $ smul_comm _ _ _⟩

instance (R : Type*) [has_scalar R α] [has_scalar Rᵐᵒᵖ α] [is_central_scalar R α] :
  is_central_scalar R αᵐᵒᵖ :=
⟨λ r m, unop_injective $ op_smul_eq_smul _ _⟩

lemma op_smul_eq_op_smul_op {R : Type*} [has_scalar R α] [has_scalar Rᵐᵒᵖ α] [is_central_scalar R α]
  (r : R) (a : α) : op (r • a) = op r • op a :=
(op_smul_eq_smul r (op a)).symm

lemma unop_smul_eq_unop_smul_unop {R : Type*} [has_scalar R α] [has_scalar Rᵐᵒᵖ α]
  [is_central_scalar R α] (r : Rᵐᵒᵖ) (a : αᵐᵒᵖ) : unop (r • a) = unop r • unop a :=
(unop_smul_eq_smul r (unop a)).symm

end mul_opposite

/-! ### Actions _by_ the opposite type (right actions)

In `has_mul.to_has_scalar` in another file, we define the left action `a₁ • a₂ = a₁ * a₂`. For the
multiplicative opposite, we define `mul_opposite.op a₁ • a₂ = a₂ * a₁`, with the multiplication
reversed.
-/

open mul_opposite

/-- Like `has_mul.to_has_scalar`, but multiplies on the right.

See also `monoid.to_opposite_mul_action` and `monoid_with_zero.to_opposite_mul_action_with_zero`. -/
@[to_additive] instance has_mul.to_has_opposite_scalar [has_mul α] : has_scalar αᵐᵒᵖ α :=
{ smul := λ c x, x * c.unop }

@[simp, to_additive] lemma op_smul_eq_mul [has_mul α] {a a' : α} : op a • a' = a' * a := rfl

/-- The right regular action of a group on itself is transitive. -/
@[to_additive] instance mul_action.opposite_regular.is_pretransitive {G : Type*} [group G] :
  mul_action.is_pretransitive Gᵐᵒᵖ G :=
⟨λ x y, ⟨op (x⁻¹ * y), mul_inv_cancel_left _ _⟩⟩

@[to_additive] instance semigroup.opposite_smul_comm_class [semigroup α] :
  smul_comm_class αᵐᵒᵖ α α :=
{ smul_comm := λ x y z, (mul_assoc _ _ _) }

@[to_additive] instance semigroup.opposite_smul_comm_class' [semigroup α] :
  smul_comm_class α αᵐᵒᵖ α :=
smul_comm_class.symm _ _ _

instance comm_semigroup.is_central_scalar [comm_semigroup α] : is_central_scalar α α :=
⟨λ r m, mul_comm _ _⟩

/-- Like `monoid.to_mul_action`, but multiplies on the right. -/
@[to_additive] instance monoid.to_opposite_mul_action [monoid α] : mul_action αᵐᵒᵖ α :=
{ smul := (•),
  one_smul := mul_one,
  mul_smul := λ x y r, (mul_assoc _ _ _).symm }

instance is_scalar_tower.opposite_mid {M N} [monoid N] [has_scalar M N]
  [smul_comm_class M N N] :
  is_scalar_tower M Nᵐᵒᵖ N :=
⟨λ x y z, mul_smul_comm _ _ _⟩

instance smul_comm_class.opposite_mid {M N} [monoid N] [has_scalar M N]
  [is_scalar_tower M N N] :
  smul_comm_class M Nᵐᵒᵖ N :=
⟨λ x y z, by { induction y using mul_opposite.rec, simp [smul_mul_assoc] }⟩

-- The above instance does not create an unwanted diamond, the two paths to
-- `mul_action αᵐᵒᵖ αᵐᵒᵖ` are defeq.
example [monoid α] : monoid.to_mul_action αᵐᵒᵖ = mul_opposite.mul_action α αᵐᵒᵖ := rfl

/-- `monoid.to_opposite_mul_action` is faithful on cancellative monoids. -/
@[to_additive] instance left_cancel_monoid.to_has_faithful_opposite_scalar [left_cancel_monoid α] :
  has_faithful_scalar αᵐᵒᵖ α :=
⟨λ x y h, unop_injective $ mul_left_cancel (h 1)⟩

/-- `monoid.to_opposite_mul_action` is faithful on nontrivial cancellative monoids with zero. -/
instance cancel_monoid_with_zero.to_has_faithful_opposite_scalar
  [cancel_monoid_with_zero α] [nontrivial α] : has_faithful_scalar αᵐᵒᵖ α :=
⟨λ x y h, unop_injective $ mul_left_cancel₀ one_ne_zero (h 1)⟩


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison

! This file was ported from Lean 3 source module algebraic_geometry.stalks
! 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.PresheafedSpace
import Mathbin.CategoryTheory.Limits.Final
import Mathbin.Topology.Sheaves.Stalks

/-!
# Stalks for presheaved spaces

This file lifts constructions of stalks and pushforwards of stalks to work with
the category of presheafed spaces. Additionally, we prove that restriction of
presheafed spaces does not change the stalks.
-/

noncomputable section

universe v u v' u'

open CategoryTheory

open CategoryTheory.Limits CategoryTheory.Category CategoryTheory.Functor

open AlgebraicGeometry

open TopologicalSpace

open Opposite

variable {C : Type u} [Category.{v} C] [HasColimits C]

attribute [local tidy] tactic.op_induction' tactic.auto_cases_opens

open TopCat.Presheaf

namespace AlgebraicGeometry.PresheafedSpace

/-- The stalk at `x` of a `PresheafedSpace`.
-/
abbrev stalk (X : PresheafedSpace C) (x : X) : C :=
  X.Presheaf.stalk x
#align algebraic_geometry.PresheafedSpace.stalk AlgebraicGeometry.PresheafedSpace.stalk

/-- A morphism of presheafed spaces induces a morphism of stalks.
-/
def stalkMap {X Y : PresheafedSpace.{v} C} (α : X ⟶ Y) (x : X) : Y.stalk (α.base x) ⟶ X.stalk x :=
  (stalkFunctor C (α.base x)).map α.c ≫ X.Presheaf.stalkPushforward C α.base x
#align algebraic_geometry.PresheafedSpace.stalk_map AlgebraicGeometry.PresheafedSpace.stalkMap

@[simp, elementwise, reassoc.1]
theorem stalkMap_germ {X Y : PresheafedSpace.{v} C} (α : X ⟶ Y) (U : Opens Y.carrier)
    (x : (Opens.map α.base).obj U) :
    Y.Presheaf.germ ⟨α.base x, x.2⟩ ≫ stalkMap α ↑x = α.c.app (op U) ≫ X.Presheaf.germ x := by
  rw [stalk_map, stalk_functor_map_germ_assoc, stalk_pushforward_germ]
#align algebraic_geometry.PresheafedSpace.stalk_map_germ AlgebraicGeometry.PresheafedSpace.stalkMap_germ

section Restrict

/-- For an open embedding `f : U ⟶ X` and a point `x : U`, we get an isomorphism between the stalk
of `X` at `f x` and the stalk of the restriction of `X` along `f` at t `x`.
-/
def restrictStalkIso {U : TopCat} (X : PresheafedSpace.{v} C) {f : U ⟶ (X : TopCat.{v})}
    (h : OpenEmbedding f) (x : U) : (X.restrict h).stalk x ≅ X.stalk (f x) :=
  haveI-- As a left adjoint, the functor `h.is_open_map.functor_nhds x` is initial.
   := initial_of_adjunction (h.is_open_map.adjunction_nhds x)
  -- Typeclass resolution knows that the opposite of an initial functor is final. The result
    -- follows from the general fact that postcomposing with a final functor doesn't change colimits.
    final.colimit_iso
    (h.is_open_map.functor_nhds x).op ((open_nhds.inclusion (f x)).op ⋙ X.presheaf)
#align algebraic_geometry.PresheafedSpace.restrict_stalk_iso AlgebraicGeometry.PresheafedSpace.restrictStalkIso

@[simp, elementwise, reassoc.1]
theorem restrictStalkIso_hom_eq_germ {U : TopCat} (X : PresheafedSpace.{v} C)
    {f : U ⟶ (X : TopCat.{v})} (h : OpenEmbedding f) (V : Opens U) (x : U) (hx : x ∈ V) :
    (X.restrict h).Presheaf.germ ⟨x, hx⟩ ≫ (restrictStalkIso X h x).Hom =
      X.Presheaf.germ ⟨f x, show f x ∈ h.IsOpenMap.Functor.obj V from ⟨x, hx, rfl⟩⟩ :=
  colimit.ι_pre ((OpenNhds.inclusion (f x)).op ⋙ X.Presheaf) (h.IsOpenMap.functorNhds x).op
    (op ⟨V, hx⟩)
#align algebraic_geometry.PresheafedSpace.restrict_stalk_iso_hom_eq_germ AlgebraicGeometry.PresheafedSpace.restrictStalkIso_hom_eq_germ

@[simp, elementwise, reassoc.1]
theorem restrictStalkIso_inv_eq_germ {U : TopCat} (X : PresheafedSpace.{v} C)
    {f : U ⟶ (X : TopCat.{v})} (h : OpenEmbedding f) (V : Opens U) (x : U) (hx : x ∈ V) :
    X.Presheaf.germ ⟨f x, show f x ∈ h.IsOpenMap.Functor.obj V from ⟨x, hx, rfl⟩⟩ ≫
        (restrictStalkIso X h x).inv =
      (X.restrict h).Presheaf.germ ⟨x, hx⟩ :=
  by rw [← restrict_stalk_iso_hom_eq_germ, category.assoc, iso.hom_inv_id, category.comp_id]
#align algebraic_geometry.PresheafedSpace.restrict_stalk_iso_inv_eq_germ AlgebraicGeometry.PresheafedSpace.restrictStalkIso_inv_eq_germ

theorem restrictStalkIso_inv_eq_ofRestrict {U : TopCat} (X : PresheafedSpace.{v} C)
    {f : U ⟶ (X : TopCat.{v})} (h : OpenEmbedding f) (x : U) :
    (X.restrictStalkIso h x).inv = stalkMap (X.of_restrict h) x :=
  by
  ext V
  induction V using Opposite.rec
  let i : (h.is_open_map.functor_nhds x).obj ((open_nhds.map f x).obj V) ⟶ V :=
    hom_of_le (Set.image_preimage_subset f _)
  erw [iso.comp_inv_eq, colimit.ι_map_assoc, colimit.ι_map_assoc, colimit.ι_pre]
  simp_rw [category.assoc]
  erw [colimit.ι_pre ((open_nhds.inclusion (f x)).op ⋙ X.presheaf)
      (h.is_open_map.functor_nhds x).op]
  erw [← X.presheaf.map_comp_assoc]
  exact (colimit.w ((open_nhds.inclusion (f x)).op ⋙ X.presheaf) i.op).symm
#align algebraic_geometry.PresheafedSpace.restrict_stalk_iso_inv_eq_of_restrict AlgebraicGeometry.PresheafedSpace.restrictStalkIso_inv_eq_ofRestrict

instance ofRestrict_stalkMap_isIso {U : TopCat} (X : PresheafedSpace.{v} C)
    {f : U ⟶ (X : TopCat.{v})} (h : OpenEmbedding f) (x : U) :
    IsIso (stalkMap (X.of_restrict h) x) :=
  by
  rw [← restrict_stalk_iso_inv_eq_of_restrict]
  infer_instance
#align algebraic_geometry.PresheafedSpace.of_restrict_stalk_map_is_iso AlgebraicGeometry.PresheafedSpace.ofRestrict_stalkMap_isIso

end Restrict

namespace StalkMap

@[simp]
theorem id (X : PresheafedSpace.{v} C) (x : X) : stalkMap (𝟙 X) x = 𝟙 (X.stalk x) :=
  by
  dsimp [stalk_map]
  simp only [stalk_pushforward.id]
  rw [← map_comp]
  convert(stalk_functor C x).map_id X.presheaf
  tidy
#align algebraic_geometry.PresheafedSpace.stalk_map.id AlgebraicGeometry.PresheafedSpace.stalkMap.id

-- TODO understand why this proof is still gross (i.e. requires using `erw`)
@[simp]
theorem comp {X Y Z : PresheafedSpace.{v} C} (α : X ⟶ Y) (β : Y ⟶ Z) (x : X) :
    stalkMap (α ≫ β) x =
      (stalkMap β (α.base x) : Z.stalk (β.base (α.base x)) ⟶ Y.stalk (α.base x)) ≫
        (stalkMap α x : Y.stalk (α.base x) ⟶ X.stalk x) :=
  by
  dsimp [stalk_map, stalk_functor, stalk_pushforward]
  ext U
  induction U using Opposite.rec
  cases U
  simp only [colimit.ι_map_assoc, colimit.ι_pre_assoc, colimit.ι_pre, whisker_left_app,
    whisker_right_app, assoc, id_comp, map_id, map_comp]
  dsimp
  simp only [map_id, assoc, pushforward.comp_inv_app]
  -- FIXME Why doesn't simp do this:
  erw [CategoryTheory.Functor.map_id]
  erw [CategoryTheory.Functor.map_id]
  erw [id_comp, id_comp]
#align algebraic_geometry.PresheafedSpace.stalk_map.comp AlgebraicGeometry.PresheafedSpace.stalkMap.comp

/-- If `α = β` and `x = x'`, we would like to say that `stalk_map α x = stalk_map β x'`.
Unfortunately, this equality is not well-formed, as their types are not _definitionally_ the same.
To get a proper congruence lemma, we therefore have to introduce these `eq_to_hom` arrows on
either side of the equality.
-/
theorem congr {X Y : PresheafedSpace.{v} C} (α β : X ⟶ Y) (h₁ : α = β) (x x' : X) (h₂ : x = x') :
    stalkMap α x ≫ eqToHom (show X.stalk x = X.stalk x' by rw [h₂]) =
      eqToHom (show Y.stalk (α.base x) = Y.stalk (β.base x') by rw [h₁, h₂]) ≫ stalkMap β x' :=
  stalk_hom_ext _ fun U hx => by
    subst h₁
    subst h₂
    simp
#align algebraic_geometry.PresheafedSpace.stalk_map.congr AlgebraicGeometry.PresheafedSpace.stalkMap.congr

theorem congr_hom {X Y : PresheafedSpace.{v} C} (α β : X ⟶ Y) (h : α = β) (x : X) :
    stalkMap α x =
      eqToHom (show Y.stalk (α.base x) = Y.stalk (β.base x) by rw [h]) ≫ stalkMap β x :=
  by rw [← stalk_map.congr α β h x x rfl, eq_to_hom_refl, category.comp_id]
#align algebraic_geometry.PresheafedSpace.stalk_map.congr_hom AlgebraicGeometry.PresheafedSpace.stalkMap.congr_hom

theorem congr_point {X Y : PresheafedSpace.{v} C} (α : X ⟶ Y) (x x' : X) (h : x = x') :
    stalkMap α x ≫ eqToHom (show X.stalk x = X.stalk x' by rw [h]) =
      eqToHom (show Y.stalk (α.base x) = Y.stalk (α.base x') by rw [h]) ≫ stalkMap α x' :=
  by rw [stalk_map.congr α α rfl x x' h]
#align algebraic_geometry.PresheafedSpace.stalk_map.congr_point AlgebraicGeometry.PresheafedSpace.stalkMap.congr_point

instance isIso {X Y : PresheafedSpace.{v} C} (α : X ⟶ Y) [IsIso α] (x : X) : IsIso (stalkMap α x)
    where out := by
    let β : Y ⟶ X := CategoryTheory.inv α
    have h_eq : (α ≫ β).base x = x := by rw [is_iso.hom_inv_id α, id_base, TopCat.id_app]
    -- Intuitively, the inverse of the stalk map of `α` at `x` should just be the stalk map of `β`
    -- at `α x`. Unfortunately, we have a problem with dependent type theory here: Because `x`
    -- is not *definitionally* equal to `β (α x)`, the map `stalk_map β (α x)` has not the correct
    -- type for an inverse.
    -- To get a proper inverse, we need to compose with the `eq_to_hom` arrow
    -- `X.stalk x ⟶ X.stalk ((α ≫ β).base x)`.
    refine'
      ⟨eq_to_hom (show X.stalk x = X.stalk ((α ≫ β).base x) by rw [h_eq]) ≫
          (stalk_map β (α.base x) : _),
        _, _⟩
    · rw [← category.assoc, congr_point α x ((α ≫ β).base x) h_eq.symm, category.assoc]
      erw [← stalk_map.comp β α (α.base x)]
      rw [congr_hom _ _ (is_iso.inv_hom_id α), stalk_map.id, eq_to_hom_trans_assoc, eq_to_hom_refl,
        category.id_comp]
    ·
      rw [category.assoc, ← stalk_map.comp, congr_hom _ _ (is_iso.hom_inv_id α), stalk_map.id,
        eq_to_hom_trans_assoc, eq_to_hom_refl, category.id_comp]
#align algebraic_geometry.PresheafedSpace.stalk_map.is_iso AlgebraicGeometry.PresheafedSpace.stalkMap.isIso

/-- An isomorphism between presheafed spaces induces an isomorphism of stalks.
-/
def stalkIso {X Y : PresheafedSpace.{v} C} (α : X ≅ Y) (x : X) :
    Y.stalk (α.Hom.base x) ≅ X.stalk x :=
  asIso (stalkMap α.Hom x)
#align algebraic_geometry.PresheafedSpace.stalk_map.stalk_iso AlgebraicGeometry.PresheafedSpace.stalkMap.stalkIso

@[simp, reassoc.1, elementwise]
theorem stalkSpecializes_stalkMap {X Y : PresheafedSpace.{v} C} (f : X ⟶ Y) {x y : X} (h : x ⤳ y) :
    Y.Presheaf.stalkSpecializes (f.base.map_specializes h) ≫ stalkMap f x =
      stalkMap f y ≫ X.Presheaf.stalkSpecializes h :=
  by
  delta PresheafedSpace.stalk_map
  simp [stalk_map]
#align algebraic_geometry.PresheafedSpace.stalk_map.stalk_specializes_stalk_map AlgebraicGeometry.PresheafedSpace.stalkMap.stalkSpecializes_stalkMap

end StalkMap

end AlgebraicGeometry.PresheafedSpace


/-
Copyright (c) 2021 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import data.set.pointwise
import order.antichain
import order.order_iso_nat
import order.well_founded

/-!
# Well-founded sets

A well-founded subset of an ordered type is one on which the relation `<` is well-founded.

## Main Definitions
 * `set.well_founded_on s r` indicates that the relation `r` is
  well-founded when restricted to the set `s`.
 * `set.is_wf s` indicates that `<` is well-founded when restricted to `s`.
 * `set.partially_well_ordered_on s r` indicates that the relation `r` is
  partially well-ordered (also known as well quasi-ordered) when restricted to the set `s`.
 * `set.is_pwo s` indicates that any infinite sequence of elements in `s`
  contains an infinite monotone subsequence. Note that

### Definitions for Hahn Series
 * `set.add_antidiagonal s t a` and `set.mul_antidiagonal s t a` are the sets of pairs of elements
  from `s` and `t` that add/multiply to `a`.
 * `finset.add_antidiagonal` and `finset.mul_antidiagonal` are finite versions of
  `set.add_antidiagonal` and `set.mul_antidiagonal` defined when `s` and `t` are well-founded.

## Main Results
 * Higman's Lemma, `set.partially_well_ordered_on.partially_well_ordered_on_sublist_forall₂`,
  shows that if `r` is partially well-ordered on `s`, then `list.sublist_forall₂` is partially
  well-ordered on the set of lists of elements of `s`. The result was originally published by
  Higman, but this proof more closely follows Nash-Williams.
 * `set.well_founded_on_iff` relates `well_founded_on` to the well-foundedness of a relation on the
 original type, to avoid dealing with subtypes.
 * `set.is_wf.mono` shows that a subset of a well-founded subset is well-founded.
 * `set.is_wf.union` shows that the union of two well-founded subsets is well-founded.
 * `finset.is_wf` shows that all `finset`s are well-founded.

## TODO

Prove that `s` is partial well ordered iff it has no infinite descending chain or antichain.

## References
 * [Higman, *Ordering by Divisibility in Abstract Algebras*][Higman52]
 * [Nash-Williams, *On Well-Quasi-Ordering Finite Trees*][Nash-Williams63]
-/

open_locale pointwise

variables {α : Type*}

namespace set

/-- `s.well_founded_on r` indicates that the relation `r` is well-founded when restricted to `s`. -/
def well_founded_on (s : set α) (r : α → α → Prop) : Prop :=
well_founded (λ (a : s) (b : s), r a b)

lemma well_founded_on_iff {s : set α} {r : α → α → Prop} :
  s.well_founded_on r ↔ well_founded (λ (a b : α), r a b ∧ a ∈ s ∧ b ∈ s) :=
begin
  have f : rel_embedding (λ (a : s) (b : s), r a b) (λ (a b : α), r a b ∧ a ∈ s ∧ b ∈ s) :=
    ⟨⟨coe, subtype.coe_injective⟩, λ a b, by simp⟩,
  refine ⟨λ h, _, f.well_founded⟩,
  rw well_founded.well_founded_iff_has_min,
  intros t ht,
  by_cases hst : (s ∩ t).nonempty,
  { rw ← subtype.preimage_coe_nonempty at hst,
    rcases well_founded.well_founded_iff_has_min.1 h (coe ⁻¹' t) hst with ⟨⟨m, ms⟩, mt, hm⟩,
    exact ⟨m, mt, λ x xt ⟨xm, xs, ms⟩, hm ⟨x, xs⟩ xt xm⟩ },
  { rcases ht with ⟨m, mt⟩,
    exact ⟨m, mt, λ x xt ⟨xm, xs, ms⟩, hst ⟨m, ⟨ms, mt⟩⟩⟩ }
end

lemma well_founded_on.induction {s : set α} {r : α → α → Prop} (hs : s.well_founded_on r) {x : α}
  (hx : x ∈ s) {P : α → Prop} (hP : ∀ (y ∈ s), (∀ (z ∈ s), r z y → P z) → P y) :
  P x :=
begin
  let Q : s → Prop := λ y, P y,
  change Q ⟨x, hx⟩,
  refine well_founded.induction hs ⟨x, hx⟩ _,
  rintros ⟨y, ys⟩ ih,
  exact hP _ ys (λ z zs zy, ih ⟨z, zs⟩ zy),
end

instance is_strict_order.subset {s : set α} {r : α → α → Prop} [is_strict_order α r] :
  is_strict_order α (λ (a b : α), r a b ∧ a ∈ s ∧ b ∈ s) :=
{ to_is_irrefl := ⟨λ a con, irrefl_of r a con.1 ⟩,
  to_is_trans := ⟨λ a b c ab bc, ⟨trans_of r ab.1 bc.1, ab.2.1, bc.2.2⟩ ⟩ }

theorem well_founded_on_iff_no_descending_seq {s : set α} {r : α → α → Prop} [is_strict_order α r] :
  s.well_founded_on r ↔ ∀ (f : ((>) : ℕ → ℕ → Prop) ↪r r), ¬ (range f) ⊆ s :=
begin
  rw [well_founded_on_iff, rel_embedding.well_founded_iff_no_descending_seq],
  refine ⟨λ h f con, begin
      refine h.elim' ⟨⟨f, f.injective⟩, λ a b, _⟩,
       simp only [con (mem_range_self a), con (mem_range_self b), and_true, gt_iff_lt,
        function.embedding.coe_fn_mk, f.map_rel_iff]
    end, λ h, ⟨λ con, _⟩⟩,
  rcases con with ⟨f, hf⟩,
  have hfs' : ∀ n : ℕ, f n ∈ s := λ n, (hf.2 n.lt_succ_self).2.2,
  refine h ⟨f, λ a b, _⟩ (λ n hn, _),
  { rw ← hf,
    exact ⟨λ h, ⟨h, hfs' _, hfs' _⟩, λ h, h.1⟩ },
  { rcases set.mem_range.1 hn with ⟨m, hm⟩,
    rw ← hm,
    apply hfs' }
end

section has_lt
variables [has_lt α]

/-- `s.is_wf` indicates that `<` is well-founded when restricted to `s`. -/
def is_wf (s : set α) : Prop := well_founded_on s (<)

lemma is_wf_univ_iff : is_wf (univ : set α) ↔ well_founded ((<) : α → α → Prop) :=
by simp [is_wf, well_founded_on_iff]

variables {s t : set α}

theorem is_wf.mono (h : is_wf t) (st : s ⊆ t) : is_wf s :=
begin
  rw [is_wf, well_founded_on_iff] at *,
  refine subrelation.wf (λ x y xy, _) h,
  exact ⟨xy.1, st xy.2.1, st xy.2.2⟩,
end
end has_lt

section partial_order
variables [partial_order α] {s t : set α} {a : α}

theorem is_wf_iff_no_descending_seq :
  is_wf s ↔ ∀ (f : (order_dual ℕ) ↪o α), ¬ (range f) ⊆ s :=
begin
  haveI : is_strict_order α (λ (a b : α), a < b ∧ a ∈ s ∧ b ∈ s) :=
  { to_is_irrefl := ⟨λ x con, lt_irrefl x con.1⟩,
    to_is_trans := ⟨λ a b c ab bc, ⟨lt_trans ab.1 bc.1, ab.2.1, bc.2.2⟩⟩, },
  rw [is_wf, well_founded_on_iff_no_descending_seq],
  exact ⟨λ h f, h f.lt_embedding, λ h f, h (order_embedding.of_strict_mono
    f (λ _ _, f.map_rel_iff.2))⟩,
end

theorem is_wf.union (hs : is_wf s) (ht : is_wf t) : is_wf (s ∪ t) :=
begin
  classical,
  rw [is_wf_iff_no_descending_seq] at *,
  rintros f fst,
  have h : infinite (f ⁻¹' s) ∨ infinite (f ⁻¹' t),
  { have h : infinite (univ : set ℕ) := infinite_univ,
    have hpre : f ⁻¹' (s ∪ t) = set.univ,
    { rw [← image_univ, image_subset_iff, univ_subset_iff] at fst,
      exact fst },
    rw preimage_union at hpre,
    rw ← hpre at h,
    rw [infinite, infinite],
    rw infinite at h,
    contrapose! h,
    exact finite.union h.1 h.2, },
  rw [← infinite_coe_iff, ← infinite_coe_iff] at h,
  cases h with inf inf; haveI := inf,
  { apply hs ((nat.order_embedding_of_set (f ⁻¹' s)).dual.trans f),
    change range (function.comp f (nat.order_embedding_of_set (f ⁻¹' s))) ⊆ s,
    rw [range_comp, image_subset_iff],
      simp },
  { apply ht ((nat.order_embedding_of_set (f ⁻¹' t)).dual.trans f),
    change range (function.comp f (nat.order_embedding_of_set (f ⁻¹' t))) ⊆ t,
    rw [range_comp, image_subset_iff],
      simp }
end
end partial_order

end set

namespace set

/-- A subset is partially well-ordered by a relation `r` when any infinite sequence contains
  two elements where the first is related to the second by `r`. -/
def partially_well_ordered_on (s) (r : α → α → Prop) : Prop :=
  ∀ (f : ℕ → α), range f ⊆ s → ∃ (m n : ℕ), m < n ∧ r (f m) (f n)

/-- A subset of a preorder is partially well-ordered when any infinite sequence contains
  a monotone subsequence of length 2 (or equivalently, an infinite monotone subsequence). -/
def is_pwo [preorder α] (s) : Prop :=
partially_well_ordered_on s ((≤) : α → α → Prop)

theorem partially_well_ordered_on.mono {s t : set α} {r : α → α → Prop}
  (ht : t.partially_well_ordered_on r) (hsub : s ⊆ t) :
  s.partially_well_ordered_on r :=
λ f hf, ht f (set.subset.trans hf hsub)

theorem is_pwo.mono [preorder α] {s t : set α}
  (ht : t.is_pwo) (hsub : s ⊆ t) :
  s.is_pwo :=
partially_well_ordered_on.mono ht hsub

theorem partially_well_ordered_on.image_of_monotone_on {s : set α}
  {r : α → α → Prop} {β : Type*} {r' : β → β → Prop}
  (hs : s.partially_well_ordered_on r) {f : α → β}
  (hf : ∀ a1 a2 : α, a1 ∈ s → a2 ∈ s → r a1 a2 → r' (f a1) (f a2)) :
  (f '' s).partially_well_ordered_on r' :=
λ g hg, begin
  have h := λ (n : ℕ), ((mem_image _ _ _).1 (hg (mem_range_self n))),
  obtain ⟨m, n, hlt, hmn⟩ := hs (λ n, classical.some (h n)) _,
  { refine ⟨m, n, hlt, _⟩,
    rw [← (classical.some_spec (h m)).2,
      ← (classical.some_spec (h n)).2],
    exact hf _ _ (classical.some_spec (h m)).1 (classical.some_spec (h n)).1 hmn },
  { rintros _ ⟨n, rfl⟩,
    exact (classical.some_spec (h n)).1 }
end

lemma _root_.is_antichain.finite_of_partially_well_ordered_on {s : set α} {r : α → α → Prop}
  (ha : is_antichain r s) (hp : s.partially_well_ordered_on r) :
  s.finite :=
begin
  refine finite_or_infinite.resolve_right (λ hi, _),
  obtain ⟨m, n, hmn, h⟩ := hp (λ n, hi.nat_embedding _ n) (range_subset_iff.2 $
    λ n, (hi.nat_embedding _ n).2),
  exact hmn.ne ((hi.nat_embedding _).injective $ subtype.val_injective $
    ha.eq (hi.nat_embedding _ m).2 (hi.nat_embedding _ n).2 h),
end

lemma finite.partially_well_ordered_on {s : set α} {r : α → α → Prop} [is_refl α r]
  (hs : s.finite) :
  s.partially_well_ordered_on r :=
begin
  intros f hf,
  obtain ⟨m, n, hmn, h⟩ := hs.exists_lt_map_eq_of_range_subset hf,
  exact ⟨m, n, hmn, h.subst $ refl (f m)⟩,
end

lemma _root_.is_antichain.partially_well_ordered_on_iff {s : set α} {r : α → α → Prop} [is_refl α r]
  (hs : is_antichain r s) :
  s.partially_well_ordered_on r ↔ s.finite :=
⟨hs.finite_of_partially_well_ordered_on, finite.partially_well_ordered_on⟩

lemma partially_well_ordered_on_iff_finite_antichains {s : set α} {r : α → α → Prop} [is_refl α r]
  [is_symm α r] :
  s.partially_well_ordered_on r ↔ ∀ t ⊆ s, is_antichain r t → t.finite :=
begin
  refine ⟨λ h t ht hrt, hrt.finite_of_partially_well_ordered_on (h.mono ht), _⟩,
  rintro hs f hf,
  by_contra' H,
  refine set.infinite_range_of_injective (λ m n hmn, _) (hs _ hf _),
  { obtain h | h | h := lt_trichotomy m n,
    { refine (H _ _ h _).elim,
      rw hmn,
      exact refl _ },
    { exact h },
    { refine (H _ _ h _).elim,
      rw hmn,
      exact refl _ } },
  rintro _ ⟨m, hm, rfl⟩ _ ⟨n, hn, rfl⟩ hmn,
  obtain h | h  := (ne_of_apply_ne _ hmn).lt_or_lt,
  { exact H _ _ h },
  { exact mt symm (H _ _ h) }
end

section partial_order
variables {s : set α} {t : set α} {r : α → α → Prop}

theorem partially_well_ordered_on.exists_monotone_subseq [is_refl α r] [is_trans α r]
  (h : s.partially_well_ordered_on r) (f : ℕ → α) (hf : range f ⊆ s) :
  ∃ (g : ℕ ↪o ℕ), ∀ m n : ℕ, m ≤ n → r (f (g m)) (f (g n)) :=
begin
  obtain ⟨g, h1 | h2⟩ := exists_increasing_or_nonincreasing_subseq r f,
  { refine ⟨g, λ m n hle, _⟩,
    obtain hlt | heq := lt_or_eq_of_le hle,
    { exact h1 m n hlt, },
    { rw [heq],
      apply refl_of r } },
  { exfalso,
    obtain ⟨m, n, hlt, hle⟩ := h (f ∘ g) (subset.trans (range_comp_subset_range _ _) hf),
    exact h2 m n hlt hle }
end

theorem partially_well_ordered_on_iff_exists_monotone_subseq [is_refl α r] [is_trans α r] :
  s.partially_well_ordered_on r ↔
    ∀ f : ℕ → α, range f ⊆ s → ∃ (g : ℕ ↪o ℕ), ∀ m n : ℕ, m ≤ n → r (f (g m)) (f (g n)) :=
begin
  classical,
  split; intros h f hf,
  { exact h.exists_monotone_subseq f hf },
  { obtain ⟨g, gmon⟩ := h f hf,
    refine ⟨g 0, g 1, g.lt_iff_lt.2 zero_lt_one, gmon _ _ zero_le_one⟩, }
end

lemma partially_well_ordered_on.well_founded_on [is_partial_order α r]
  (h : s.partially_well_ordered_on r) :
  s.well_founded_on (λ a b, r a b ∧ a ≠ b) :=
begin
  haveI : is_strict_order α (λ a b, r a b ∧ a ≠ b) :=
  { to_is_irrefl := ⟨λ a con, con.2 rfl⟩,
    to_is_trans := ⟨λ a b c ab bc, ⟨trans ab.1 bc.1,
      λ ac, ab.2 (antisymm ab.1 (ac.symm ▸ bc.1))⟩⟩ },
  rw well_founded_on_iff_no_descending_seq,
  intros f con,
  obtain ⟨m, n, hlt, hle⟩ := h f con,
  exact (f.map_rel_iff.2 hlt).2 (antisymm hle (f.map_rel_iff.2 hlt).1).symm,
end

variables [partial_order α]

lemma is_pwo.is_wf (h : s.is_pwo) :
  s.is_wf :=
begin
  rw [is_wf],
  convert h.well_founded_on,
  ext x y,
  rw lt_iff_le_and_ne,
end

theorem is_pwo.exists_monotone_subseq
  (h : s.is_pwo) (f : ℕ → α) (hf : range f ⊆ s) :
  ∃ (g : ℕ ↪o ℕ), monotone (f ∘ g) :=
h.exists_monotone_subseq f hf

theorem is_pwo_iff_exists_monotone_subseq :
  s.is_pwo ↔
    ∀ f : ℕ → α, range f ⊆ s → ∃ (g : ℕ ↪o ℕ), monotone (f ∘ g) :=
partially_well_ordered_on_iff_exists_monotone_subseq

lemma is_pwo.prod (hs : s.is_pwo)
  (ht : t.is_pwo) :
  (s ×ˢ t : set _).is_pwo :=
begin
  classical,
  rw is_pwo_iff_exists_monotone_subseq at *,
  intros f hf,
  obtain ⟨g1, h1⟩ := hs (prod.fst ∘ f) _,
  swap,
  { rw [range_comp, image_subset_iff],
    refine subset.trans hf _,
    rintros ⟨x1, x2⟩ hx,
    simp only [mem_preimage, hx.1] },
  obtain ⟨g2, h2⟩ := ht (prod.snd ∘ f ∘ g1) _,
  refine ⟨g2.trans g1, λ m n mn, _⟩,
  swap,
  { rw [range_comp, image_subset_iff],
    refine subset.trans (range_comp_subset_range _ _) (subset.trans hf _),
    rintros ⟨x1, x2⟩ hx,
    simp only [mem_preimage, hx.2] },
  simp only [rel_embedding.coe_trans, function.comp_app],
  exact ⟨h1 (g2.le_iff_le.2 mn), h2 mn⟩,
end

theorem is_pwo.image_of_monotone {β : Type*} [partial_order β]
  (hs : s.is_pwo) {f : α → β} (hf : monotone f) :
  is_pwo (f '' s) :=
hs.image_of_monotone_on (λ _ _ _ _ ab, hf ab)

theorem is_pwo.union (hs : is_pwo s) (ht : is_pwo t) : is_pwo (s ∪ t) :=
begin
  classical,
  rw [is_pwo_iff_exists_monotone_subseq] at *,
  rintros f fst,
  have h : infinite (f ⁻¹' s) ∨ infinite (f ⁻¹' t),
  { have h : infinite (univ : set ℕ) := infinite_univ,
    have hpre : f ⁻¹' (s ∪ t) = set.univ,
    { rw [← image_univ, image_subset_iff, univ_subset_iff] at fst,
      exact fst },
    rw preimage_union at hpre,
    rw ← hpre at h,
    rw [infinite, infinite],
    rw infinite at h,
    contrapose! h,
    exact finite.union h.1 h.2, },
  rw [← infinite_coe_iff, ← infinite_coe_iff] at h,
  cases h with inf inf; haveI := inf,
  { obtain ⟨g, hg⟩ := hs (f ∘ (nat.order_embedding_of_set (f ⁻¹' s))) _,
    { rw [function.comp.assoc, ← rel_embedding.coe_trans] at hg,
      exact ⟨_, hg⟩ },
    rw [range_comp, image_subset_iff],
    simp },
  { obtain ⟨g, hg⟩ := ht (f ∘ (nat.order_embedding_of_set (f ⁻¹' t))) _,
    { rw [function.comp.assoc, ← rel_embedding.coe_trans] at hg,
      exact ⟨_, hg⟩ },
    rw [range_comp, image_subset_iff],
    simp }
end

end partial_order

theorem is_wf.is_pwo [linear_order α] {s : set α}
  (hs : s.is_wf) : s.is_pwo :=
λ f hf, begin
  rw [is_wf, well_founded_on_iff] at hs,
  have hrange : (range f).nonempty := ⟨f 0, mem_range_self 0⟩,
  let a := hs.min (range f) hrange,
  obtain ⟨m, hm⟩ := hs.min_mem (range f) hrange,
  refine ⟨m, m.succ, m.lt_succ_self, le_of_not_lt (λ con, _)⟩,
  rw hm at con,
  apply hs.not_lt_min (range f) hrange (mem_range_self m.succ)
    ⟨con, hf (mem_range_self m.succ), hf _⟩,
  rw ← hm,
  apply mem_range_self,
end

theorem is_wf_iff_is_pwo [linear_order α] {s : set α} :
  s.is_wf ↔ s.is_pwo :=
⟨is_wf.is_pwo, is_pwo.is_wf⟩

end set

namespace finset

@[simp] lemma partially_well_ordered_on {r : α → α → Prop} [is_refl α r] (s : finset α) :
  (s : set α).partially_well_ordered_on r :=
s.finite_to_set.partially_well_ordered_on

@[simp]
theorem is_pwo [partial_order α] (f : finset α) :
  set.is_pwo (↑f : set α) :=
f.partially_well_ordered_on

@[simp]
theorem well_founded_on {r : α → α → Prop} [is_strict_order α r] (f : finset α) :
  set.well_founded_on (↑f : set α) r :=
begin
  rw [set.well_founded_on_iff_no_descending_seq],
  intros g con,
  apply set.infinite_of_injective_forall_mem g.injective (set.range_subset_iff.1 con),
  exact f.finite_to_set,
end

@[simp]
theorem is_wf [partial_order α] (f : finset α) : set.is_wf (↑f : set α) :=
f.is_pwo.is_wf

end finset

namespace set
variables [partial_order α] {s : set α} {a : α}

theorem finite.is_pwo (h : s.finite) : s.is_pwo :=
begin
  rw ← h.coe_to_finset,
  exact h.to_finset.is_pwo,
end

@[simp]
theorem fintype.is_pwo [fintype α] : s.is_pwo := (finite.of_fintype s).is_pwo

@[simp]
theorem is_pwo_empty : is_pwo (∅ : set α) :=
finite_empty.is_pwo

@[simp]
theorem is_pwo_singleton (a) : is_pwo ({a} : set α) :=
(finite_singleton a).is_pwo

theorem is_pwo.insert (a) (hs : is_pwo s) : is_pwo (insert a s) :=
by { rw ← union_singleton, exact hs.union (is_pwo_singleton a) }

/-- `is_wf.min` returns a minimal element of a nonempty well-founded set. -/
noncomputable def is_wf.min (hs : is_wf s) (hn : s.nonempty) : α :=
hs.min univ (nonempty_iff_univ_nonempty.1 hn.to_subtype)

lemma is_wf.min_mem (hs : is_wf s) (hn : s.nonempty) : hs.min hn ∈ s :=
(well_founded.min hs univ (nonempty_iff_univ_nonempty.1 hn.to_subtype)).2

lemma is_wf.not_lt_min (hs : is_wf s) (hn : s.nonempty) (ha : a ∈ s) : ¬ a < hs.min hn :=
hs.not_lt_min univ (nonempty_iff_univ_nonempty.1 hn.to_subtype) (mem_univ (⟨a, ha⟩ : s))

@[simp]
lemma is_wf_min_singleton (a) {hs : is_wf ({a} : set α)} {hn : ({a} : set α).nonempty} :
  hs.min hn = a :=
eq_of_mem_singleton (is_wf.min_mem hs hn)

end set

theorem finset.is_wf_sup {ι : Type*} [partial_order α] (f : finset ι) (g : ι → set α)
  (hf : ∀ i : ι, i ∈ f → (g i).is_wf) : (f.sup g).is_wf :=
finset.sup_induction set.is_pwo_empty.is_wf (λ a ha b hb, ha.union hb) hf

theorem finset.is_pwo_sup {ι : Type*} [partial_order α] (f : finset ι) (g : ι → set α)
  (hf : ∀ i : ι, i ∈ f → (g i).is_pwo) : (f.sup g).is_pwo :=
finset.sup_induction set.is_pwo_empty (λ a ha b hb, ha.union hb) hf

namespace set
variables [linear_order α] {s t : set α} {a : α}

lemma is_wf.min_le
  (hs : s.is_wf) (hn : s.nonempty) (ha : a ∈ s) : hs.min hn ≤ a :=
le_of_not_lt (hs.not_lt_min hn ha)

lemma is_wf.le_min_iff
  (hs : s.is_wf) (hn : s.nonempty) :
  a ≤ hs.min hn ↔ ∀ b, b ∈ s → a ≤ b :=
⟨λ ha b hb, le_trans ha (hs.min_le hn hb), λ h, h _ (hs.min_mem _)⟩

lemma is_wf.min_le_min_of_subset
  {hs : s.is_wf} {hsn : s.nonempty} {ht : t.is_wf} {htn : t.nonempty} (hst : s ⊆ t) :
  ht.min htn ≤ hs.min hsn :=
(is_wf.le_min_iff _ _).2 (λ b hb, ht.min_le htn (hst hb))

lemma is_wf.min_union (hs : s.is_wf) (hsn : s.nonempty) (ht : t.is_wf) (htn : t.nonempty) :
  (hs.union ht).min (union_nonempty.2 (or.intro_left _ hsn)) = min (hs.min hsn) (ht.min htn) :=
begin
  refine le_antisymm (le_min (is_wf.min_le_min_of_subset (subset_union_left _ _))
      (is_wf.min_le_min_of_subset (subset_union_right _ _))) _,
  rw min_le_iff,
  exact ((mem_union _ _ _).1 ((hs.union ht).min_mem
    (union_nonempty.2 (or.intro_left _ hsn)))).imp (hs.min_le _) (ht.min_le _),
end

end set

namespace set

variables {s : set α} {t : set α}

@[to_additive]
theorem is_pwo.mul [ordered_cancel_comm_monoid α] (hs : s.is_pwo) (ht : t.is_pwo) :
  is_pwo (s * t) :=
begin
  rw ← image_mul_prod,
  exact (is_pwo.prod hs ht).image_of_monotone (λ _ _ h, mul_le_mul' h.1 h.2),
end

variable [linear_ordered_cancel_comm_monoid α]

@[to_additive]
theorem is_wf.mul (hs : s.is_wf) (ht : t.is_wf) : is_wf (s * t) :=
(hs.is_pwo.mul ht.is_pwo).is_wf

@[to_additive]
theorem is_wf.min_mul (hs : s.is_wf) (ht : t.is_wf) (hsn : s.nonempty) (htn : t.nonempty) :
  (hs.mul ht).min (hsn.mul htn) = hs.min hsn * ht.min htn :=
begin
  refine le_antisymm (is_wf.min_le _ _ (mem_mul.2 ⟨_, _, hs.min_mem _, ht.min_mem _, rfl⟩)) _,
  rw is_wf.le_min_iff,
  rintros _ ⟨x, y, hx, hy, rfl⟩,
  exact mul_le_mul' (hs.min_le _ hx) (ht.min_le _ hy),
end

end set

namespace set
namespace partially_well_ordered_on

/-- In the context of partial well-orderings, a bad sequence is a nonincreasing sequence
  whose range is contained in a particular set `s`. One exists if and only if `s` is not
  partially well-ordered. -/
def is_bad_seq (r : α → α → Prop) (s : set α) (f : ℕ → α) : Prop :=
set.range f ⊆ s ∧ ∀ (m n : ℕ), m < n → ¬ r (f m) (f n)

lemma iff_forall_not_is_bad_seq (r : α → α → Prop) (s : set α) :
  s.partially_well_ordered_on r ↔
    ∀ f, ¬ is_bad_seq r s f :=
begin
  rw [set.partially_well_ordered_on],
  apply forall_congr (λ f, _),
  simp [is_bad_seq]
end

/-- This indicates that every bad sequence `g` that agrees with `f` on the first `n`
  terms has `rk (f n) ≤ rk (g n)`. -/
def is_min_bad_seq (r : α → α → Prop) (rk : α → ℕ) (s : set α) (n : ℕ) (f : ℕ → α) : Prop :=
  ∀ g : ℕ → α, (∀ (m : ℕ), m < n → f m = g m) → rk (g n) < rk (f n) → ¬ is_bad_seq r s g

/-- Given a bad sequence `f`, this constructs a bad sequence that agrees with `f` on the first `n`
  terms and is minimal at `n`.
-/
noncomputable def min_bad_seq_of_bad_seq (r : α → α → Prop) (rk : α → ℕ) (s : set α)
  (n : ℕ) (f : ℕ → α) (hf : is_bad_seq r s f) :
  { g : ℕ → α // (∀ (m : ℕ), m < n → f m = g m) ∧ is_bad_seq r s g ∧ is_min_bad_seq r rk s n g } :=
begin
  classical,
  have h : ∃ (k : ℕ) (g : ℕ → α), (∀ m, m < n → f m = g m) ∧ is_bad_seq r s g
        ∧ rk (g n) = k :=
  ⟨_, f, λ _ _, rfl, hf, rfl⟩,
  obtain ⟨h1, h2, h3⟩ := classical.some_spec (nat.find_spec h),
  refine ⟨classical.some (nat.find_spec h), h1, by convert h2, λ g hg1 hg2 con, _⟩,
  refine nat.find_min h _ ⟨g, λ m mn, (h1 m mn).trans (hg1 m mn), by convert con, rfl⟩,
  rwa ← h3,
end

lemma exists_min_bad_of_exists_bad (r : α → α → Prop) (rk : α → ℕ) (s : set α) :
  (∃ f, is_bad_seq r s f) → ∃ f, is_bad_seq r s f ∧ ∀ n, is_min_bad_seq r rk s n f :=
begin
  rintro ⟨f0, (hf0 : is_bad_seq r s f0)⟩,
  let fs : Π (n : ℕ), { f :  ℕ → α // is_bad_seq r s f ∧ is_min_bad_seq r rk s n f },
  { refine nat.rec _ _,
    { exact ⟨(min_bad_seq_of_bad_seq r rk s 0 f0 hf0).1,
        (min_bad_seq_of_bad_seq r rk s 0 f0 hf0).2.2⟩, },
    { exact λ n fn, ⟨(min_bad_seq_of_bad_seq r rk s (n + 1) fn.1 fn.2.1).1,
        (min_bad_seq_of_bad_seq r rk s (n + 1) fn.1 fn.2.1).2.2⟩ } },
  have h : ∀ m n, m ≤ n → (fs m).1 m = (fs n).1 m,
  { intros m n mn,
    obtain ⟨k, rfl⟩ := exists_add_of_le mn,
    clear mn,
    induction k with k ih,
    { refl },
    rw [ih, ((min_bad_seq_of_bad_seq r rk s (m + k).succ (fs (m + k)).1 (fs (m + k)).2.1).2.1 m
        (nat.lt_succ_iff.2 (nat.add_le_add_left k.zero_le m)))],
    refl },
  refine ⟨λ n, (fs n).1 n, ⟨set.range_subset_iff.2 (λ n, ((fs n).2).1.1 (mem_range_self n)),
    λ m n mn, _⟩, λ n g hg1 hg2, _⟩,
  { dsimp,
    rw [← subtype.val_eq_coe, h m n (le_of_lt mn)],
    convert (fs n).2.1.2 m n mn },
  { convert (fs n).2.2 g (λ m mn, eq.trans _ (hg1 m mn)) (lt_of_lt_of_le hg2 le_rfl),
    rw ← h m n (le_of_lt mn) },
end

lemma iff_not_exists_is_min_bad_seq {r : α → α → Prop} (rk : α → ℕ) {s : set α} :
  s.partially_well_ordered_on r ↔ ¬ ∃ f, is_bad_seq r s f ∧ ∀ n, is_min_bad_seq r rk s n f :=
begin
  rw [iff_forall_not_is_bad_seq, ← not_exists, not_congr],
  split,
  { apply exists_min_bad_of_exists_bad },
  rintro ⟨f, hf1, hf2⟩,
  exact ⟨f, hf1⟩,
end

/-- Higman's Lemma, which states that for any reflexive, transitive relation `r` which is
  partially well-ordered on a set `s`, the relation `list.sublist_forall₂ r` is partially
  well-ordered on the set of lists of elements of `s`. That relation is defined so that
  `list.sublist_forall₂ r l₁ l₂` whenever `l₁` related pointwise by `r` to a sublist of `l₂`.  -/
lemma partially_well_ordered_on_sublist_forall₂ (r : α → α → Prop) [is_refl α r] [is_trans α r]
  {s : set α} (h : s.partially_well_ordered_on r) :
  { l : list α | ∀ x, x ∈ l → x ∈ s }.partially_well_ordered_on (list.sublist_forall₂ r) :=
begin
  rcases s.eq_empty_or_nonempty with rfl | ⟨as, has⟩,
  { apply partially_well_ordered_on.mono (finset.partially_well_ordered_on {list.nil}),
    { intros l hl,
      rw [finset.mem_coe, finset.mem_singleton, list.eq_nil_iff_forall_not_mem],
      exact hl, },
    apply_instance },
  haveI : inhabited α := ⟨as⟩,
  rw [iff_not_exists_is_min_bad_seq (list.length)],
  rintro ⟨f, hf1, hf2⟩,
  have hnil : ∀ n, f n ≠ list.nil :=
    λ n con, (hf1).2 n n.succ n.lt_succ_self (con.symm ▸ list.sublist_forall₂.nil),
  obtain ⟨g, hg⟩ := h.exists_monotone_subseq (list.head ∘ f) _,
  swap, { simp only [set.range_subset_iff, function.comp_apply],
    exact λ n, hf1.1 (set.mem_range_self n) _ (list.head_mem_self (hnil n)) },
  have hf' := hf2 (g 0) (λ n, if n < g 0 then f n else list.tail (f (g (n - g 0))))
    (λ m hm, (if_pos hm).symm) _,
  swap, { simp only [if_neg (lt_irrefl (g 0)), tsub_self],
    rw [list.length_tail, ← nat.pred_eq_sub_one],
    exact nat.pred_lt (λ con, hnil _ (list.length_eq_zero.1 con)) },
  rw [is_bad_seq] at hf',
  push_neg at hf',
  obtain ⟨m, n, mn, hmn⟩ := hf' _,
  swap, { rw set.range_subset_iff,
    rintro n x hx,
    split_ifs at hx with hn hn,
    { exact hf1.1 (set.mem_range_self _) _ hx },
    { refine hf1.1 (set.mem_range_self _) _ (list.tail_subset _ hx), } },
  by_cases hn : n < g 0,
  { apply hf1.2 m n mn,
    rwa [if_pos hn, if_pos (mn.trans hn)] at hmn },
  { obtain ⟨n', rfl⟩ := le_iff_exists_add.1 (not_lt.1 hn),
    rw [if_neg hn, add_comm (g 0) n', add_tsub_cancel_right] at hmn,
    split_ifs at hmn with hm hm,
    { apply hf1.2 m (g n') (lt_of_lt_of_le hm (g.monotone n'.zero_le)),
      exact trans hmn (list.tail_sublist_forall₂_self _) },
    { rw [← (tsub_lt_iff_left (le_of_not_lt hm))] at mn,
      apply hf1.2 _ _ (g.lt_iff_lt.2 mn),
      rw [← list.cons_head_tail (hnil (g (m - g 0))), ← list.cons_head_tail (hnil (g n'))],
      exact list.sublist_forall₂.cons (hg _ _ (le_of_lt mn)) hmn, } }
end

end partially_well_ordered_on

namespace is_pwo

@[to_additive]
lemma submonoid_closure [ordered_cancel_comm_monoid α] {s : set α} (hpos : ∀ x : α, x ∈ s → 1 ≤ x)
  (h : s.is_pwo) : is_pwo ((submonoid.closure s) : set α) :=
begin
  have hl : ((submonoid.closure s) : set α) ⊆ list.prod '' { l : list α | ∀ x, x ∈ l → x ∈ s },
  { intros x hx,
    rw set_like.mem_coe at hx,
    refine submonoid.closure_induction hx (λ x hx, ⟨_, λ y hy, _, list.prod_singleton⟩)
      ⟨_, λ y hy, (list.not_mem_nil _ hy).elim, list.prod_nil⟩ _,
    { rwa list.mem_singleton.1 hy },
    rintros _ _ ⟨l, hl, rfl⟩ ⟨l', hl', rfl⟩,
    refine ⟨_, λ y hy, _, list.prod_append⟩,
    cases list.mem_append.1 hy with hy hy,
    { exact hl _ hy },
    { exact hl' _ hy } },
  apply ((h.partially_well_ordered_on_sublist_forall₂ (≤)).image_of_monotone_on _).mono hl,
  intros l1 l2 hl1 hl2 h12,
  obtain ⟨l, hll1, hll2⟩ := list.sublist_forall₂_iff.1 h12,
  refine le_trans (list.rel_prod (le_refl 1) (λ a b ab c d cd, mul_le_mul' ab cd) hll1) _,
  obtain ⟨l', hl'⟩ := hll2.exists_perm_append,
  rw [hl'.prod_eq, list.prod_append, ← mul_one l.prod, mul_assoc, one_mul],
  apply mul_le_mul_left',
  have hl's := λ x hx, hl2 x (list.subset.trans (l.subset_append_right _) hl'.symm.subset hx),
  clear hl',
  induction l' with x1 x2 x3 x4 x5,
  { refl },
  rw [list.prod_cons, ← one_mul (1 : α)],
  exact mul_le_mul' (hpos x1 (hl's x1 (list.mem_cons_self x1 x2)))
    (x3 (λ x hx, hl's x (list.mem_cons_of_mem _ hx)))
end

end is_pwo

/-- `set.mul_antidiagonal s t a` is the set of all pairs of an element in `s` and an element in `t`
  that multiply to `a`. -/
@[to_additive "`set.add_antidiagonal s t a` is the set of all pairs of an element in `s`
  and an element in `t` that add to `a`."]
def mul_antidiagonal [monoid α] (s t : set α) (a : α) : set (α × α) :=
{ x | x.1 * x.2 = a ∧ x.1 ∈ s ∧ x.2 ∈ t }

namespace mul_antidiagonal

@[simp, to_additive]
lemma mem_mul_antidiagonal [monoid α] {s t : set α} {a : α} {x : α × α} :
  x ∈ mul_antidiagonal s t a ↔ x.1 * x.2 = a ∧ x.1 ∈ s ∧ x.2 ∈ t := iff.refl _

section cancel_comm_monoid
variables [cancel_comm_monoid α] {s t : set α} {a : α}

@[to_additive]
lemma fst_eq_fst_iff_snd_eq_snd {x y : (mul_antidiagonal s t a)} :
  (x : α × α).fst = (y : α × α).fst ↔ (x : α × α).snd = (y : α × α).snd :=
⟨λ h, begin
  have hx := x.2.1,
  rw [subtype.val_eq_coe, h] at hx,
  apply mul_left_cancel (hx.trans y.2.1.symm),
end, λ h, begin
  have hx := x.2.1,
  rw [subtype.val_eq_coe, h] at hx,
  apply mul_right_cancel (hx.trans y.2.1.symm),
end⟩

@[to_additive]
lemma eq_of_fst_eq_fst {x y : (mul_antidiagonal s t a)}
  (h : (x : α × α).fst = (y : α × α).fst) : x = y :=
subtype.ext (prod.ext h (mul_antidiagonal.fst_eq_fst_iff_snd_eq_snd.1 h))

@[to_additive]
lemma eq_of_snd_eq_snd {x y : (mul_antidiagonal s t a)}
  (h : (x : α × α).snd = (y : α × α).snd) : x = y :=
subtype.ext (prod.ext (mul_antidiagonal.fst_eq_fst_iff_snd_eq_snd.2 h) h)

end cancel_comm_monoid

section ordered_cancel_comm_monoid
variables [ordered_cancel_comm_monoid α] (s t : set α) (a : α)

@[to_additive]
lemma eq_of_fst_le_fst_of_snd_le_snd {x y : (mul_antidiagonal s t a)}
  (h1 : (x : α × α).fst ≤ (y : α × α).fst) (h2 : (x : α × α).snd ≤ (y : α × α).snd ) :
  x = y :=
begin
  apply eq_of_fst_eq_fst,
  cases eq_or_lt_of_le h1 with heq hlt,
  { exact heq },
  exfalso,
  exact ne_of_lt (mul_lt_mul_of_lt_of_le hlt h2)
    ((mem_mul_antidiagonal.1 x.2).1.trans (mem_mul_antidiagonal.1 y.2).1.symm)
end

variables {s} {t}

@[to_additive]
theorem finite_of_is_pwo (hs : s.is_pwo) (ht : t.is_pwo) (a) :
  (mul_antidiagonal s t a).finite :=
begin
  by_contra h,
  rw [← set.infinite] at h,
  have h1 : (mul_antidiagonal s t a).partially_well_ordered_on (prod.fst ⁻¹'o (≤)),
  { intros f hf,
    refine hs (prod.fst ∘ f) _,
    rw range_comp,
    rintros _ ⟨⟨x, y⟩, hxy, rfl⟩,
    exact (mem_mul_antidiagonal.1 (hf hxy)).2.1 },
  have h2 : (mul_antidiagonal s t a).partially_well_ordered_on (prod.snd ⁻¹'o (≤)),
  { intros f hf,
    refine ht (prod.snd ∘ f) _,
    rw range_comp,
    rintros _ ⟨⟨x, y⟩, hxy, rfl⟩,
    exact (mem_mul_antidiagonal.1 (hf hxy)).2.2 },
  obtain ⟨g, hg⟩ := h1.exists_monotone_subseq (λ x, h.nat_embedding _ x) _,
  swap, { rintro _ ⟨k, rfl⟩,
    exact ((infinite.nat_embedding (s.mul_antidiagonal t a) h) _).2 },
  obtain ⟨m, n, mn, h2'⟩ := h2 (λ x, (h.nat_embedding _) (g x)) _,
  swap, { rintro _ ⟨k, rfl⟩,
    exact ((infinite.nat_embedding (s.mul_antidiagonal t a) h) _).2, },
  apply ne_of_lt mn (g.injective ((h.nat_embedding _).injective _)),
  exact eq_of_fst_le_fst_of_snd_le_snd _ _ _ (hg _ _ (le_of_lt mn)) h2',
end

end ordered_cancel_comm_monoid

@[to_additive]
theorem finite_of_is_wf [linear_ordered_cancel_comm_monoid α] {s t : set α}
  (hs : s.is_wf) (ht : t.is_wf) (a) :
  (mul_antidiagonal s t a).finite :=
finite_of_is_pwo hs.is_pwo ht.is_pwo a

end mul_antidiagonal
end set

namespace finset

variables [ordered_cancel_comm_monoid α]
variables {s t : set α} (hs : s.is_pwo) (ht : t.is_pwo) (a : α)

/-- `finset.mul_antidiagonal_of_is_wf hs ht a` is the set of all pairs of an element in
  `s` and an element in `t` that multiply to `a`, but its construction requires proofs
  `hs` and `ht` that `s` and `t` are well-ordered. -/
@[to_additive "`finset.add_antidiagonal_of_is_wf hs ht a` is the set of all pairs of an element in
  `s` and an element in `t` that add to `a`, but its construction requires proofs
  `hs` and `ht` that `s` and `t` are well-ordered."]
noncomputable def mul_antidiagonal : finset (α × α) :=
(set.mul_antidiagonal.finite_of_is_pwo hs ht a).to_finset

variables {hs} {ht} {u : set α} {hu : u.is_pwo} {a} {x : α × α}

@[simp, to_additive]
lemma mem_mul_antidiagonal :
  x ∈ mul_antidiagonal hs ht a ↔ x.1 * x.2 = a ∧ x.1 ∈ s ∧ x.2 ∈ t :=
by simp [mul_antidiagonal]

@[to_additive]
lemma mul_antidiagonal_mono_left (hus : u ⊆ s) :
  (finset.mul_antidiagonal hu ht a) ⊆ (finset.mul_antidiagonal hs ht a) :=
λ x hx, begin
  rw mem_mul_antidiagonal at *,
  exact ⟨hx.1, hus hx.2.1, hx.2.2⟩,
end

@[to_additive]
lemma mul_antidiagonal_mono_right (hut : u ⊆ t) :
  (finset.mul_antidiagonal hs hu a) ⊆ (finset.mul_antidiagonal hs ht a) :=
λ x hx, begin
  rw mem_mul_antidiagonal at *,
  exact ⟨hx.1, hx.2.1, hut hx.2.2⟩,
end

@[to_additive]
lemma support_mul_antidiagonal_subset_mul :
  { a : α | (mul_antidiagonal hs ht a).nonempty } ⊆ s * t :=
(λ x ⟨⟨a1, a2⟩, ha⟩, begin
  obtain ⟨hmul, h1, h2⟩ := mem_mul_antidiagonal.1 ha,
  exact ⟨a1, a2, h1, h2, hmul⟩,
end)

@[to_additive]
theorem is_pwo_support_mul_antidiagonal :
  { a : α | (mul_antidiagonal hs ht a).nonempty }.is_pwo :=
(hs.mul ht).mono support_mul_antidiagonal_subset_mul

@[to_additive]
theorem mul_antidiagonal_min_mul_min {α} [linear_ordered_cancel_comm_monoid α] {s t : set α}
  (hs : s.is_wf) (ht : t.is_wf)
  (hns : s.nonempty) (hnt : t.nonempty) :
  mul_antidiagonal hs.is_pwo ht.is_pwo ((hs.min hns) * (ht.min hnt)) =
    {(hs.min hns, ht.min hnt)} :=
begin
  ext ⟨a1, a2⟩,
  rw [mem_mul_antidiagonal, finset.mem_singleton, prod.ext_iff],
  split,
  { rintro ⟨hast, has, hat⟩,
    cases eq_or_lt_of_le (hs.min_le hns has) with heq hlt,
    { refine ⟨heq.symm, _⟩,
      rw heq at hast,
      exact mul_left_cancel hast },
    { contrapose hast,
      exact ne_of_gt (mul_lt_mul_of_lt_of_le hlt (ht.min_le hnt hat)) } },
  { rintro ⟨ha1, ha2⟩,
    rw [ha1, ha2],
    exact ⟨rfl, hs.min_mem _, ht.min_mem _⟩ }
end

end finset

lemma well_founded.is_wf [has_lt α] (h : well_founded ((<) : α → α → Prop)) (s : set α) :
  s.is_wf :=
(set.is_wf_univ_iff.2 h).mono (set.subset_univ s)

/-- A version of **Dickson's lemma** any subset of functions `Π s : σ, α s` is partially well
ordered, when `σ` is a `fintype` and each `α s` is a linear well order.
This includes the classical case of Dickson's lemma that `ℕ ^ n` is a well partial order.
Some generalizations would be possible based on this proof, to include cases where the target
is partially well ordered, and also to consider the case of `partially_well_ordered_on` instead of
`is_pwo`. -/
lemma pi.is_pwo {σ : Type*} {α : σ → Type*} [∀ s, linear_order (α s)] [∀ s, is_well_order (α s) (<)]
  [fintype σ] (S : set (Π s : σ, α s)) : S.is_pwo :=
begin
  classical,
  refine set.is_pwo.mono _ (set.subset_univ _),
  rw set.is_pwo_iff_exists_monotone_subseq,
  simp_rw [monotone, pi.le_def],
  suffices : ∀ s : finset σ, ∀ (f : ℕ → (Π s, α s)), set.range f ⊆ set.univ → ∃ (g : ℕ ↪o ℕ),
    ∀ ⦃a b : ℕ⦄, a ≤ b → ∀ (x : σ) (hs : x ∈ s), (f ∘ g) a x ≤ (f ∘ g) b x,
  { simpa only [forall_true_left, finset.mem_univ] using this finset.univ, },
  apply' finset.induction,
  { intros f hf, existsi rel_embedding.refl (≤),
    simp only [forall_false_left, implies_true_iff, forall_const, finset.not_mem_empty], },
  { intros x s hx ih f hf,
    obtain ⟨g, hg⟩ := (is_well_order.wf.is_wf (set.univ : set _)).is_pwo.exists_monotone_subseq
      ((λ mo : Π s : σ, α s, mo x) ∘ f) (set.subset_univ _),
    obtain ⟨g', hg'⟩ := ih (f ∘ g) (set.subset_univ _),
    refine ⟨g'.trans g, λ a b hab, _⟩,
    simp only [finset.mem_insert, rel_embedding.coe_trans, function.comp_app, forall_eq_or_imp],
    exact ⟨hg (order_hom_class.mono g' hab), hg' hab⟩, },
end