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

! This file was ported from Lean 3 source module category_theory.abelian.right_derived
! leanprover-community/mathlib commit 024a4231815538ac739f52d08dd20a55da0d6b23
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Abelian.InjectiveResolution
import Mathbin.Algebra.Homology.Additive
import Mathbin.CategoryTheory.Limits.Constructions.EpiMono
import Mathbin.CategoryTheory.Abelian.Homology
import Mathbin.CategoryTheory.Abelian.Exact

/-!
# Right-derived functors

We define the right-derived functors `F.right_derived n : C ⥤ D` for any additive functor `F`
out of a category with injective resolutions.

The definition is
```
injective_resolutions C ⋙ F.map_homotopy_category _ ⋙ homotopy_category.homology_functor D _ n
```
that is, we pick an injective resolution (thought of as an object of the homotopy category),
we apply `F` objectwise, and compute `n`-th homology.

We show that these right-derived functors can be calculated
on objects using any choice of injective resolution,
and on morphisms by any choice of lift to a cochain map between chosen injective resolutions.

Similarly we define natural transformations between right-derived functors coming from
natural transformations between the original additive functors,
and show how to compute the components.

## Main results
* `category_theory.functor.right_derived_obj_injective_zero`: the `0`-th derived functor of `F` on
  an injective object `X` is isomorphic to `F.obj X`.
* `category_theory.functor.right_derived_obj_injective_succ`: injective objects have no higher
  right derived functor.
* `category_theory.nat_trans.right_derived`: the natural isomorphism between right derived functors
  induced by natural transformation.

Now, we assume `preserves_finite_limits F`, then
* `category_theory.abelian.functor.preserves_exact_of_preserves_finite_limits_of_mono`: if `f` is
  mono and `exact f g`, then `exact (F.map f) (F.map g)`.
* `category_theory.abelian.functor.right_derived_zero_iso_self`: if there are enough injectives,
  then there is a natural isomorphism `(F.right_derived 0) ≅ F`.
-/

noncomputable section

open CategoryTheory

open CategoryTheory.Limits

namespace CategoryTheory

universe v u

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

variable [Abelian C] [HasInjectiveResolutions C] [Abelian D]

/-- The right derived functors of an additive functor. -/
def Functor.rightDerived (F : C ⥤ D) [F.Additive] (n : ℕ) : C ⥤ D :=
  injectiveResolutions C ⋙ F.mapHomotopyCategory _ ⋙ HomotopyCategory.homologyFunctor D _ n
#align category_theory.functor.right_derived CategoryTheory.Functor.rightDerived

/-- We can compute a right derived functor using a chosen injective resolution. -/
@[simps]
def Functor.rightDerivedObjIso (F : C ⥤ D) [F.Additive] (n : ℕ) {X : C}
    (P : InjectiveResolution X) :
    (F.rightDerived n).obj X ≅
      (homologyFunctor D _ n).obj ((F.mapHomologicalComplex _).obj P.cocomplex) :=
  (HomotopyCategory.homologyFunctor D _ n).mapIso
      (HomotopyCategory.isoOfHomotopyEquiv
        (F.mapHomotopyEquiv (InjectiveResolution.homotopyEquiv _ P))) ≪≫
    (HomotopyCategory.homologyFactors D _ n).app _
#align category_theory.functor.right_derived_obj_iso CategoryTheory.Functor.rightDerivedObjIso

/-- The 0-th derived functor of `F` on an injective object `X` is just `F.obj X`. -/
@[simps]
def Functor.rightDerivedObjInjectiveZero (F : C ⥤ D) [F.Additive] (X : C) [Injective X] :
    (F.rightDerived 0).obj X ≅ F.obj X :=
  F.rightDerivedObjIso 0 (InjectiveResolution.self X) ≪≫
    (homologyFunctor _ _ _).mapIso ((CochainComplex.single₀MapHomologicalComplex F).app X) ≪≫
      (CochainComplex.homologyFunctor0Single₀ D).app (F.obj X)
#align category_theory.functor.right_derived_obj_injective_zero CategoryTheory.Functor.rightDerivedObjInjectiveZero

open ZeroObject

/-- The higher derived functors vanish on injective objects. -/
@[simps inv]
def Functor.rightDerivedObjInjectiveSucc (F : C ⥤ D) [F.Additive] (n : ℕ) (X : C) [Injective X] :
    (F.rightDerived (n + 1)).obj X ≅ 0 :=
  F.rightDerivedObjIso (n + 1) (InjectiveResolution.self X) ≪≫
    (homologyFunctor _ _ _).mapIso ((CochainComplex.single₀MapHomologicalComplex F).app X) ≪≫
      (CochainComplex.homologyFunctorSuccSingle₀ D n).app (F.obj X) ≪≫ (Functor.zero_obj _).isoZero
#align category_theory.functor.right_derived_obj_injective_succ CategoryTheory.Functor.rightDerivedObjInjectiveSucc

/-- We can compute a right derived functor on a morphism using a descent of that morphism
to a cochain map between chosen injective resolutions.
-/
theorem Functor.rightDerived_map_eq (F : C ⥤ D) [F.Additive] (n : ℕ) {X Y : C} (f : Y ⟶ X)
    {P : InjectiveResolution X} {Q : InjectiveResolution Y} (g : Q.cocomplex ⟶ P.cocomplex)
    (w : Q.ι ≫ g = (CochainComplex.single₀ C).map f ≫ P.ι) :
    (F.rightDerived n).map f =
      (F.rightDerivedObjIso n Q).Hom ≫
        (homologyFunctor D _ n).map ((F.mapHomologicalComplex _).map g) ≫
          (F.rightDerivedObjIso n P).inv :=
  by
  dsimp only [functor.right_derived, functor.right_derived_obj_iso]
  dsimp; simp only [category.comp_id, category.id_comp]
  rw [← homologyFunctor_map, HomotopyCategory.homologyFunctor_map_factors]
  simp only [← functor.map_comp]
  congr 1
  apply HomotopyCategory.eq_of_homotopy
  apply functor.map_homotopy
  apply Homotopy.trans
  exact HomotopyCategory.homotopyOutMap _
  apply InjectiveResolution.desc_homotopy f
  · simp
  · simp only [InjectiveResolution.homotopy_equiv_hom_ι_assoc]
    rw [← category.assoc, w, category.assoc]
    simp only [InjectiveResolution.homotopy_equiv_inv_ι]
#align category_theory.functor.right_derived_map_eq CategoryTheory.Functor.rightDerived_map_eq

/-- The natural transformation between right-derived functors induced by a natural transformation.-/
@[simps]
def NatTrans.rightDerived {F G : C ⥤ D} [F.Additive] [G.Additive] (α : F ⟶ G) (n : ℕ) :
    F.rightDerived n ⟶ G.rightDerived n :=
  whiskerLeft (injectiveResolutions C)
    (whiskerRight (NatTrans.mapHomotopyCategory α _) (HomotopyCategory.homologyFunctor D _ n))
#align category_theory.nat_trans.right_derived CategoryTheory.NatTrans.rightDerived

@[simp]
theorem NatTrans.rightDerived_id (F : C ⥤ D) [F.Additive] (n : ℕ) :
    NatTrans.rightDerived (𝟙 F) n = 𝟙 (F.rightDerived n) :=
  by
  simp [nat_trans.right_derived]
  rfl
#align category_theory.nat_trans.right_derived_id CategoryTheory.NatTrans.rightDerived_id

@[simp, nolint simp_nf]
theorem NatTrans.rightDerived_comp {F G H : C ⥤ D} [F.Additive] [G.Additive] [H.Additive]
    (α : F ⟶ G) (β : G ⟶ H) (n : ℕ) :
    NatTrans.rightDerived (α ≫ β) n = NatTrans.rightDerived α n ≫ NatTrans.rightDerived β n := by
  simp [nat_trans.right_derived]
#align category_theory.nat_trans.right_derived_comp CategoryTheory.NatTrans.rightDerived_comp

/-- A component of the natural transformation between right-derived functors can be computed
using a chosen injective resolution.
-/
theorem NatTrans.rightDerived_eq {F G : C ⥤ D} [F.Additive] [G.Additive] (α : F ⟶ G) (n : ℕ) {X : C}
    (P : InjectiveResolution X) :
    (NatTrans.rightDerived α n).app X =
      (F.rightDerivedObjIso n P).Hom ≫
        (homologyFunctor D _ n).map ((NatTrans.mapHomologicalComplex α _).app P.cocomplex) ≫
          (G.rightDerivedObjIso n P).inv :=
  by
  symm
  dsimp [nat_trans.right_derived, functor.right_derived_obj_iso]
  simp only [category.comp_id, category.id_comp]
  rw [← homologyFunctor_map, HomotopyCategory.homologyFunctor_map_factors]
  simp only [← functor.map_comp]
  congr 1
  apply HomotopyCategory.eq_of_homotopy
  simp only [nat_trans.map_homological_complex_naturality_assoc, ← functor.map_comp]
  apply Homotopy.compLeftId
  rw [← Functor.map_id]
  apply functor.map_homotopy
  apply HomotopyEquiv.homotopyHomInvId
#align category_theory.nat_trans.right_derived_eq CategoryTheory.NatTrans.rightDerived_eq

end CategoryTheory

section

universe w v u

open CategoryTheory.Limits CategoryTheory CategoryTheory.Functor

variable {C : Type u} [Category.{w} C] {D : Type u} [Category.{w} D]

variable (F : C ⥤ D) {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z}

namespace CategoryTheory.Abelian.Functor

open CategoryTheory.Preadditive

variable [Abelian C] [Abelian D] [Additive F]

/-- If `preserves_finite_limits F` and `mono f`, then `exact (F.map f) (F.map g)` if
`exact f g`. -/
theorem preserves_exact_of_preservesFiniteLimits_of_mono [PreservesFiniteLimits F] [Mono f]
    (ex : Exact f g) : Exact (F.map f) (F.map g) :=
  Abelian.exact_of_is_kernel _ _ (by simp [← functor.map_comp, ex.w]) <|
    Limits.isLimitForkMapOfIsLimit' _ ex.w (Abelian.isLimitOfExactOfMono _ _ ex)
#align category_theory.abelian.functor.preserves_exact_of_preserves_finite_limits_of_mono CategoryTheory.Abelian.Functor.preserves_exact_of_preservesFiniteLimits_of_mono

theorem exact_of_map_injective_resolution (P : InjectiveResolution X) [PreservesFiniteLimits F] :
    Exact (F.map (P.ι.f 0))
      (((F.mapHomologicalComplex (ComplexShape.up ℕ)).obj P.cocomplex).dFrom 0) :=
  Preadditive.exact_of_iso_of_exact' (F.map (P.ι.f 0)) (F.map (P.cocomplex.d 0 1)) _ _ (Iso.refl _)
    (Iso.refl _)
    (HomologicalComplex.xNextIso ((F.mapHomologicalComplex _).obj P.cocomplex) rfl).symm (by simp)
    (by rw [iso.refl_hom, category.id_comp, iso.symm_hom, HomologicalComplex.dFrom_eq] <;> congr )
    (preserves_exact_of_preserves_finite_limits_of_mono _ P.exact₀)
#align category_theory.abelian.functor.exact_of_map_injective_resolution CategoryTheory.Abelian.Functor.exact_of_map_injective_resolution

/-- Given `P : InjectiveResolution X`, a morphism `(F.right_derived 0).obj X ⟶ F.obj X` given
`preserves_finite_limits F`. -/
def rightDerivedZeroToSelfApp [EnoughInjectives C] [PreservesFiniteLimits F] {X : C}
    (P : InjectiveResolution X) : (F.rightDerived 0).obj X ⟶ F.obj X :=
  (rightDerivedObjIso F 0 P).Hom ≫
    (homologyIsoKernelDesc _ _ _).Hom ≫
      kernel.map _ _ (cokernel.desc _ (𝟙 _) (by simp)) (𝟙 _)
          (by
            ext
            simp) ≫
        (asIso (kernel.lift _ _ (exact_of_map_injective_resolution F P).w)).inv
#align category_theory.abelian.functor.right_derived_zero_to_self_app CategoryTheory.Abelian.Functor.rightDerivedZeroToSelfApp

/-- Given `P : InjectiveResolution X`, a morphism `F.obj X ⟶ (F.right_derived 0).obj X`. -/
def rightDerivedZeroToSelfAppInv [EnoughInjectives C] {X : C} (P : InjectiveResolution X) :
    F.obj X ⟶ (F.rightDerived 0).obj X :=
  homology.lift _ _ _ (F.map (P.ι.f 0) ≫ cokernel.π _)
      (by
        have : (ComplexShape.up ℕ).Rel 0 1 := rfl
        rw [category.assoc, cokernel.π_desc, HomologicalComplex.dFrom_eq _ this,
          map_homological_complex_obj_d, ← category.assoc, ← functor.map_comp]
        simp only [InjectiveResolution.ι_f_zero_comp_complex_d, functor.map_zero, zero_comp]) ≫
    (rightDerivedObjIso F 0 P).inv
#align category_theory.abelian.functor.right_derived_zero_to_self_app_inv CategoryTheory.Abelian.Functor.rightDerivedZeroToSelfAppInv

theorem rightDerivedZeroToSelfApp_comp_inv [EnoughInjectives C] [PreservesFiniteLimits F] {X : C}
    (P : InjectiveResolution X) :
    right_derived_zero_to_self_app F P ≫ right_derived_zero_to_self_app_inv F P = 𝟙 _ :=
  by
  dsimp [right_derived_zero_to_self_app, right_derived_zero_to_self_app_inv]
  rw [← category.assoc, iso.comp_inv_eq, category.id_comp, category.assoc, category.assoc, ←
    iso.eq_inv_comp, iso.inv_hom_id]
  ext
  rw [category.assoc, category.assoc, homology.lift_ι, category.id_comp, homology.π'_ι,
    category.assoc, ← category.assoc _ _ (cokernel.π _), abelian.kernel.lift.inv, ← category.assoc,
    ← category.assoc _ (kernel.ι _), limits.kernel.lift_ι, category.assoc, category.assoc, ←
    category.assoc (homologyIsoKernelDesc _ _ _).Hom _ _, ← homology.ι, ← category.assoc,
    homology.π'_ι, category.assoc, ← category.assoc (cokernel.π _), cokernel.π_desc, whisker_eq]
  convert category.id_comp (cokernel.π _)
#align category_theory.abelian.functor.right_derived_zero_to_self_app_comp_inv CategoryTheory.Abelian.Functor.rightDerivedZeroToSelfApp_comp_inv

theorem rightDerivedZeroToSelfAppInv_comp [EnoughInjectives C] [PreservesFiniteLimits F] {X : C}
    (P : InjectiveResolution X) :
    right_derived_zero_to_self_app_inv F P ≫ right_derived_zero_to_self_app F P = 𝟙 _ :=
  by
  dsimp [right_derived_zero_to_self_app, right_derived_zero_to_self_app_inv]
  rw [← category.assoc _ (F.right_derived_obj_iso 0 P).Hom,
    category.assoc _ _ (F.right_derived_obj_iso 0 P).Hom, iso.inv_hom_id, category.comp_id, ←
    category.assoc, ← category.assoc, is_iso.comp_inv_eq, category.id_comp]
  ext
  simp only [limits.kernel.lift_ι_assoc, category.assoc, limits.kernel.lift_ι, homology.lift]
  rw [← category.assoc, ← category.assoc, category.assoc _ _ (homologyIsoKernelDesc _ _ _).Hom]
  simp
#align category_theory.abelian.functor.right_derived_zero_to_self_app_inv_comp CategoryTheory.Abelian.Functor.rightDerivedZeroToSelfAppInv_comp

/-- Given `P : InjectiveResolution X`, the isomorphism `(F.right_derived 0).obj X ≅ F.obj X` if
`preserves_finite_limits F`. -/
def rightDerivedZeroToSelfAppIso [EnoughInjectives C] [PreservesFiniteLimits F] {X : C}
    (P : InjectiveResolution X) : (F.rightDerived 0).obj X ≅ F.obj X
    where
  Hom := right_derived_zero_to_self_app _ P
  inv := right_derived_zero_to_self_app_inv _ P
  hom_inv_id' := right_derived_zero_to_self_app_comp_inv _ P
  inv_hom_id' := right_derived_zero_to_self_app_inv_comp _ P
#align category_theory.abelian.functor.right_derived_zero_to_self_app_iso CategoryTheory.Abelian.Functor.rightDerivedZeroToSelfAppIso

/-- Given `P : InjectiveResolution X` and `Q : InjectiveResolution Y` and a morphism `f : X ⟶ Y`,
naturality of the square given by `right_derived_zero_to_self_natural`. -/
theorem rightDerived_zero_to_self_natural [EnoughInjectives C] {X : C} {Y : C} (f : X ⟶ Y)
    (P : InjectiveResolution X) (Q : InjectiveResolution Y) :
    F.map f ≫ right_derived_zero_to_self_app_inv F Q =
      right_derived_zero_to_self_app_inv F P ≫ (F.rightDerived 0).map f :=
  by
  dsimp [right_derived_zero_to_self_app_inv]
  simp only [CategoryTheory.Functor.map_id, category.id_comp, ← category.assoc]
  rw [iso.comp_inv_eq, right_derived_map_eq F 0 f (InjectiveResolution.desc f Q P) (by simp),
    category.assoc, category.assoc, category.assoc, category.assoc, iso.inv_hom_id,
    category.comp_id, ← category.assoc (F.right_derived_obj_iso 0 P).inv, iso.inv_hom_id,
    category.id_comp]
  dsimp only [homologyFunctor_map]
  ext
  rw [category.assoc, homology.lift_ι, category.assoc, homology.map_ι, ←
    category.assoc (homology.lift _ _ _ _ _) _ _, homology.lift_ι, category.assoc, cokernel.π_desc,
    ← category.assoc, ← functor.map_comp, ← category.assoc, HomologicalComplex.Hom.sqFrom_left,
    map_homological_complex_map_f, ← functor.map_comp,
    show f ≫ Q.ι.f 0 = P.ι.f 0 ≫ (InjectiveResolution.desc f Q P).f 0 from
      HomologicalComplex.congr_hom (InjectiveResolution.desc_commutes f Q P).symm 0]
#align category_theory.abelian.functor.right_derived_zero_to_self_natural CategoryTheory.Abelian.Functor.rightDerived_zero_to_self_natural

/-- Given `preserves_finite_limits F`, the natural isomorphism `(F.right_derived 0) ≅ F`. -/
def rightDerivedZeroIsoSelf [EnoughInjectives C] [PreservesFiniteLimits F] : F.rightDerived 0 ≅ F :=
  Iso.symm <|
    NatIso.ofComponents
      (fun X => (right_derived_zero_to_self_app_iso _ (InjectiveResolution.of X)).symm) fun X Y f =>
      right_derived_zero_to_self_natural _ _ _ _
#align category_theory.abelian.functor.right_derived_zero_iso_self CategoryTheory.Abelian.Functor.rightDerivedZeroIsoSelf

end CategoryTheory.Abelian.Functor

end


/-
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.module.linear_map
import algebra.opposites

/-!
# Module operations on `Mᵒᵖ`

This file contains definitions that could not be placed into `algebra.opposites` due to import
cycles.
-/

namespace opposite
universes u v

variables (R : Type u) {M : Type v} [semiring R] [add_comm_monoid M] [module R M]

/-- `opposite.distrib_mul_action` extends to a `module` -/
instance : module R (opposite M) :=
{ add_smul := λ r₁ r₂ x, unop_injective $ add_smul r₁ r₂ (unop x),
  zero_smul := λ x, unop_injective $ zero_smul _ (unop x),
  ..opposite.distrib_mul_action M R }

/-- The function `op` is a linear equivalence. -/
def op_linear_equiv : M ≃ₗ[R] Mᵒᵖ :=
{ map_smul' := opposite.op_smul, .. op_add_equiv }

@[simp] lemma coe_op_linear_equiv :
  (op_linear_equiv R : M → Mᵒᵖ) = op := rfl
@[simp] lemma coe_op_linear_equiv_symm :
  ((op_linear_equiv R).symm : Mᵒᵖ → M) = unop := rfl

@[simp]

@[simp] lemma op_linear_equiv_to_add_equiv :
  (op_linear_equiv R : M ≃ₗ[R] Mᵒᵖ).to_add_equiv = op_add_equiv := rfl
@[simp] lemma op_linear_equiv_symm_to_add_equiv :
  (op_linear_equiv R : M ≃ₗ[R] Mᵒᵖ).symm.to_add_equiv = op_add_equiv.symm := rfl

end opposite


import tactic --hide

-- Level name : absorpsion laws pt 2

/-
This level proves the second absorption law.
-/

/-Lemma
If $P,Q$ are logical statements then $P ∨ (P ∧ Q)$ is true if and only if $P$ is true.
-/
lemma absorption_two (P Q : Prop) : P ∨ (P ∧ Q) ↔ P :=
begin
  split,
  intro h,
  cases h,
  exact h,
  cases h,
  exact h_left,
  intro h,
  left,
  exact h,
end


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.bounds
import Mathlib.PostPort

universes u_6 l u_1 u_2 u_4 u_5 u_3

namespace Mathlib

/-!
# Theory of complete lattices

## Main definitions

* `Sup` and `Inf` are the supremum and the infimum of a set;
* `supr (f : ι → α)` and `infi (f : ι → α)` are indexed supremum and infimum of a function,
  defined as `Sup` and `Inf` of the range of this function;
* `class complete_lattice`: a bounded lattice such that `Sup s` is always the least upper boundary
  of `s` and `Inf s` is always the greatest lower boundary of `s`;
* `class complete_linear_order`: a linear ordered complete lattice.

## Naming conventions

We use `Sup`/`Inf`/`supr`/`infi` for the corresponding functions in the statement. Sometimes we
also use `bsupr`/`binfi` for "bounded` supremum or infimum, i.e. one of `⨆ i ∈ s, f i`,
`⨆ i (hi : p i), f i`, or more generally `⨆ i (hi : p i), f i hi`.

## Notation

* `⨆ i, f i` : `supr f`, the supremum of the range of `f`;
* `⨅ i, f i` : `infi f`, the infimum of the range of `f`.
-/

/-- class for the `Sup` operator -/
/-- class for the `Inf` operator -/
class has_Sup (α : Type u_6)
where
  Sup : set α → α

class has_Inf (α : Type u_6)
where
  Inf : set α → α

/-- Supremum of a set -/
/-- Infimum of a set -/
/-- Indexed supremum -/
/-- Indexed infimum -/
def supr {α : Type u_1} [has_Sup α] {ι : Sort u_2} (s : ι → α) : α :=
  Sup (set.range s)

def infi {α : Type u_1} [has_Inf α] {ι : Sort u_2} (s : ι → α) : α :=
  Inf (set.range s)

protected instance has_Inf_to_nonempty (α : Type u_1) [has_Inf α] : Nonempty α :=
  Nonempty.intro (Inf ∅)

protected instance has_Sup_to_nonempty (α : Type u_1) [has_Sup α] : Nonempty α :=
  Nonempty.intro (Sup ∅)

protected instance order_dual.has_Sup (α : Type u_1) [has_Inf α] : has_Sup (order_dual α) :=
  has_Sup.mk Inf

protected instance order_dual.has_Inf (α : Type u_1) [has_Sup α] : has_Inf (order_dual α) :=
  has_Inf.mk Sup

/-- A complete lattice is a bounded lattice which
  has suprema and infima for every subset. -/
class complete_lattice (α : Type u_6)
extends bounded_lattice α, has_Sup α, has_Inf α
where
  le_Sup : ∀ (s : set α) (a : α), a ∈ s → a ≤ Sup s
  Sup_le : ∀ (s : set α) (a : α), (∀ (b : α), b ∈ s → b ≤ a) → Sup s ≤ a
  Inf_le : ∀ (s : set α) (a : α), a ∈ s → Inf s ≤ a
  le_Inf : ∀ (s : set α) (a : α), (∀ (b : α), b ∈ s → a ≤ b) → a ≤ Inf s

/-- Create a `complete_lattice` from a `partial_order` and `Inf` function
that returns the greatest lower bound of a set. Usually this constructor provides
poor definitional equalities.  If other fields are known explicitly, they should be
provided; for example, if `inf` is known explicitly, construct the `complete_lattice`
instance as
```
instance : complete_lattice my_T :=
{ inf := better_inf,
  le_inf := ...,
  inf_le_right := ...,
  inf_le_left := ...
  -- don't care to fix sup, Sup, bot, top
  ..complete_lattice_of_Inf my_T _ }
```
-/
def complete_lattice_of_Inf (α : Type u_1) [H1 : partial_order α] [H2 : has_Inf α] (is_glb_Inf : ∀ (s : set α), is_glb s (Inf s)) : complete_lattice α :=
  complete_lattice.mk (fun (a b : α) => Inf (set_of fun (x : α) => a ≤ x ∧ b ≤ x)) partial_order.le partial_order.lt
    partial_order.le_refl partial_order.le_trans partial_order.le_antisymm sorry sorry sorry
    (fun (a b : α) => Inf (insert a (singleton b))) sorry sorry sorry (Inf ∅) sorry (Inf set.univ) sorry
    (fun (s : set α) => Inf (upper_bounds s)) Inf sorry sorry sorry sorry

/-- Create a `complete_lattice` from a `partial_order` and `Sup` function
that returns the least upper bound of a set. Usually this constructor provides
poor definitional equalities.  If other fields are known explicitly, they should be
provided; for example, if `inf` is known explicitly, construct the `complete_lattice`
instance as
```
instance : complete_lattice my_T :=
{ inf := better_inf,
  le_inf := ...,
  inf_le_right := ...,
  inf_le_left := ...
  -- don't care to fix sup, Inf, bot, top
  ..complete_lattice_of_Sup my_T _ }
```
-/
def complete_lattice_of_Sup (α : Type u_1) [H1 : partial_order α] [H2 : has_Sup α] (is_lub_Sup : ∀ (s : set α), is_lub s (Sup s)) : complete_lattice α :=
  complete_lattice.mk (fun (a b : α) => Sup (insert a (singleton b))) partial_order.le partial_order.lt
    partial_order.le_refl partial_order.le_trans partial_order.le_antisymm sorry sorry sorry
    (fun (a b : α) => Sup (set_of fun (x : α) => x ≤ a ∧ x ≤ b)) sorry sorry sorry (Sup set.univ) sorry (Sup ∅) sorry Sup
    (fun (s : set α) => Sup (lower_bounds s)) sorry sorry sorry sorry

/-- A complete linear order is a linear order whose lattice structure is complete. -/
class complete_linear_order (α : Type u_6)
extends linear_order α, complete_lattice α
where

namespace order_dual

protected instance complete_lattice (α : Type u_1) [complete_lattice α] : complete_lattice (order_dual α) :=
  complete_lattice.mk bounded_lattice.sup bounded_lattice.le bounded_lattice.lt sorry sorry sorry sorry sorry sorry
    bounded_lattice.inf sorry sorry sorry bounded_lattice.top sorry bounded_lattice.bot sorry Sup Inf
    complete_lattice.Inf_le complete_lattice.le_Inf complete_lattice.le_Sup complete_lattice.Sup_le

protected instance complete_linear_order (α : Type u_1) [complete_linear_order α] : complete_linear_order (order_dual α) :=
  complete_linear_order.mk complete_lattice.sup complete_lattice.le complete_lattice.lt sorry sorry sorry sorry sorry
    sorry complete_lattice.inf sorry sorry sorry complete_lattice.top sorry complete_lattice.bot sorry
    complete_lattice.Sup complete_lattice.Inf sorry sorry sorry sorry sorry linear_order.decidable_le
    linear_order.decidable_eq linear_order.decidable_lt

end order_dual

theorem le_Sup {α : Type u_1} [complete_lattice α] {s : set α} {a : α} : a ∈ s → a ≤ Sup s :=
  complete_lattice.le_Sup s a

theorem Sup_le {α : Type u_1} [complete_lattice α] {s : set α} {a : α} : (∀ (b : α), b ∈ s → b ≤ a) → Sup s ≤ a :=
  complete_lattice.Sup_le s a

theorem Inf_le {α : Type u_1} [complete_lattice α] {s : set α} {a : α} : a ∈ s → Inf s ≤ a :=
  complete_lattice.Inf_le s a

theorem le_Inf {α : Type u_1} [complete_lattice α] {s : set α} {a : α} : (∀ (b : α), b ∈ s → a ≤ b) → a ≤ Inf s :=
  complete_lattice.le_Inf s a

theorem is_lub_Sup {α : Type u_1} [complete_lattice α] (s : set α) : is_lub s (Sup s) :=
  { left := fun (x : α) => le_Sup, right := fun (x : α) => Sup_le }

theorem is_lub.Sup_eq {α : Type u_1} [complete_lattice α] {s : set α} {a : α} (h : is_lub s a) : Sup s = a :=
  is_lub.unique (is_lub_Sup s) h

theorem is_glb_Inf {α : Type u_1} [complete_lattice α] (s : set α) : is_glb s (Inf s) :=
  { left := fun (a : α) => Inf_le, right := fun (a : α) => le_Inf }

theorem is_glb.Inf_eq {α : Type u_1} [complete_lattice α] {s : set α} {a : α} (h : is_glb s a) : Inf s = a :=
  is_glb.unique (is_glb_Inf s) h

theorem le_Sup_of_le {α : Type u_1} [complete_lattice α] {s : set α} {a : α} {b : α} (hb : b ∈ s) (h : a ≤ b) : a ≤ Sup s :=
  le_trans h (le_Sup hb)

theorem Inf_le_of_le {α : Type u_1} [complete_lattice α] {s : set α} {a : α} {b : α} (hb : b ∈ s) (h : b ≤ a) : Inf s ≤ a :=
  le_trans (Inf_le hb) h

theorem Sup_le_Sup {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} (h : s ⊆ t) : Sup s ≤ Sup t :=
  is_lub.mono (is_lub_Sup s) (is_lub_Sup t) h

theorem Inf_le_Inf {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} (h : s ⊆ t) : Inf t ≤ Inf s :=
  is_glb.mono (is_glb_Inf s) (is_glb_Inf t) h

@[simp] theorem Sup_le_iff {α : Type u_1} [complete_lattice α] {s : set α} {a : α} : Sup s ≤ a ↔ ∀ (b : α), b ∈ s → b ≤ a :=
  is_lub_le_iff (is_lub_Sup s)

@[simp] theorem le_Inf_iff {α : Type u_1} [complete_lattice α] {s : set α} {a : α} : a ≤ Inf s ↔ ∀ (b : α), b ∈ s → a ≤ b :=
  le_is_glb_iff (is_glb_Inf s)

theorem Sup_le_Sup_of_forall_exists_le {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} (h : ∀ (x : α) (H : x ∈ s), ∃ (y : α), ∃ (H : y ∈ t), x ≤ y) : Sup s ≤ Sup t := sorry

theorem Inf_le_Inf_of_forall_exists_le {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} (h : ∀ (x : α) (H : x ∈ s), ∃ (y : α), ∃ (H : y ∈ t), y ≤ x) : Inf t ≤ Inf s := sorry

theorem Inf_le_Sup {α : Type u_1} [complete_lattice α] {s : set α} (hs : set.nonempty s) : Inf s ≤ Sup s :=
  is_glb_le_is_lub (is_glb_Inf s) (is_lub_Sup s) hs

-- TODO: it is weird that we have to add union_def

theorem Sup_union {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} : Sup (s ∪ t) = Sup s ⊔ Sup t :=
  is_lub.Sup_eq (is_lub.union (is_lub_Sup s) (is_lub_Sup t))

theorem Sup_inter_le {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} : Sup (s ∩ t) ≤ Sup s ⊓ Sup t := sorry

/-
  Sup_le (assume a ⟨a_s, a_t⟩, le_inf (le_Sup a_s) (le_Sup a_t))
-/

theorem Inf_union {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} : Inf (s ∪ t) = Inf s ⊓ Inf t :=
  is_glb.Inf_eq (is_glb.union (is_glb_Inf s) (is_glb_Inf t))

theorem le_Inf_inter {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} : Inf s ⊔ Inf t ≤ Inf (s ∩ t) :=
  Sup_inter_le

@[simp] theorem Sup_empty {α : Type u_1} [complete_lattice α] : Sup ∅ = ⊥ :=
  is_lub.Sup_eq is_lub_empty

@[simp] theorem Inf_empty {α : Type u_1} [complete_lattice α] : Inf ∅ = ⊤ :=
  is_glb.Inf_eq is_glb_empty

@[simp] theorem Sup_univ {α : Type u_1} [complete_lattice α] : Sup set.univ = ⊤ :=
  is_lub.Sup_eq is_lub_univ

@[simp] theorem Inf_univ {α : Type u_1} [complete_lattice α] : Inf set.univ = ⊥ :=
  is_glb.Inf_eq is_glb_univ

-- TODO(Jeremy): get this automatically

@[simp] theorem Sup_insert {α : Type u_1} [complete_lattice α] {a : α} {s : set α} : Sup (insert a s) = a ⊔ Sup s :=
  is_lub.Sup_eq (is_lub.insert a (is_lub_Sup s))

@[simp] theorem Inf_insert {α : Type u_1} [complete_lattice α] {a : α} {s : set α} : Inf (insert a s) = a ⊓ Inf s :=
  is_glb.Inf_eq (is_glb.insert a (is_glb_Inf s))

theorem Sup_le_Sup_of_subset_instert_bot {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} (h : s ⊆ insert ⊥ t) : Sup s ≤ Sup t :=
  le_trans (Sup_le_Sup h) (le_of_eq (trans Sup_insert bot_sup_eq))

theorem Inf_le_Inf_of_subset_insert_top {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} (h : s ⊆ insert ⊤ t) : Inf t ≤ Inf s :=
  le_trans (le_of_eq (trans (Eq.symm top_inf_eq) (Eq.symm Inf_insert))) (Inf_le_Inf h)

-- We will generalize this to conditionally complete lattices in `cSup_singleton`.

theorem Sup_singleton {α : Type u_1} [complete_lattice α] {a : α} : Sup (singleton a) = a :=
  is_lub.Sup_eq is_lub_singleton

-- We will generalize this to conditionally complete lattices in `cInf_singleton`.

theorem Inf_singleton {α : Type u_1} [complete_lattice α] {a : α} : Inf (singleton a) = a :=
  is_glb.Inf_eq is_glb_singleton

theorem Sup_pair {α : Type u_1} [complete_lattice α] {a : α} {b : α} : Sup (insert a (singleton b)) = a ⊔ b :=
  is_lub.Sup_eq is_lub_pair

theorem Inf_pair {α : Type u_1} [complete_lattice α] {a : α} {b : α} : Inf (insert a (singleton b)) = a ⊓ b :=
  is_glb.Inf_eq is_glb_pair

@[simp] theorem Inf_eq_top {α : Type u_1} [complete_lattice α] {s : set α} : Inf s = ⊤ ↔ ∀ (a : α), a ∈ s → a = ⊤ :=
  { mp := fun (h : Inf s = ⊤) (a : α) (ha : a ∈ s) => top_unique (h ▸ Inf_le ha),
    mpr :=
      fun (h : ∀ (a : α), a ∈ s → a = ⊤) => top_unique (le_Inf fun (a : α) (ha : a ∈ s) => iff.mpr top_le_iff (h a ha)) }

theorem eq_singleton_top_of_Inf_eq_top_of_nonempty {α : Type u_1} [complete_lattice α] {s : set α} (h_inf : Inf s = ⊤) (hne : set.nonempty s) : s = singleton ⊤ :=
  eq.mpr (id (Eq._oldrec (Eq.refl (s = singleton ⊤)) (propext set.eq_singleton_iff_nonempty_unique_mem)))
    { left := hne, right := eq.mp (Eq._oldrec (Eq.refl (Inf s = ⊤)) (propext Inf_eq_top)) h_inf }

@[simp] theorem Sup_eq_bot {α : Type u_1} [complete_lattice α] {s : set α} : Sup s = ⊥ ↔ ∀ (a : α), a ∈ s → a = ⊥ :=
  Inf_eq_top

theorem eq_singleton_bot_of_Sup_eq_bot_of_nonempty {α : Type u_1} [complete_lattice α] {s : set α} (h_sup : Sup s = ⊥) (hne : set.nonempty s) : s = singleton ⊥ :=
  eq.mpr (id (Eq._oldrec (Eq.refl (s = singleton ⊥)) (propext set.eq_singleton_iff_nonempty_unique_mem)))
    { left := hne, right := eq.mp (Eq._oldrec (Eq.refl (Sup s = ⊥)) (propext Sup_eq_bot)) h_sup }

theorem Inf_lt_iff {α : Type u_1} [complete_linear_order α] {s : set α} {b : α} : Inf s < b ↔ ∃ (a : α), ∃ (H : a ∈ s), a < b :=
  is_glb_lt_iff (is_glb_Inf s)

theorem lt_Sup_iff {α : Type u_1} [complete_linear_order α] {s : set α} {b : α} : b < Sup s ↔ ∃ (a : α), ∃ (H : a ∈ s), b < a :=
  lt_is_lub_iff (is_lub_Sup s)

theorem Sup_eq_top {α : Type u_1} [complete_linear_order α] {s : set α} : Sup s = ⊤ ↔ ∀ (b : α) (H : b < ⊤), ∃ (a : α), ∃ (H : a ∈ s), b < a := sorry

theorem Inf_eq_bot {α : Type u_1} [complete_linear_order α] {s : set α} : Inf s = ⊥ ↔ ∀ (b : α) (H : b > ⊥), ∃ (a : α), ∃ (H : a ∈ s), a < b :=
  Sup_eq_top

theorem lt_supr_iff {α : Type u_1} {ι : Sort u_4} [complete_linear_order α] {a : α} {f : ι → α} : a < supr f ↔ ∃ (i : ι), a < f i :=
  iff.trans lt_Sup_iff set.exists_range_iff

theorem infi_lt_iff {α : Type u_1} {ι : Sort u_4} [complete_linear_order α] {a : α} {f : ι → α} : infi f < a ↔ ∃ (i : ι), f i < a :=
  iff.trans Inf_lt_iff set.exists_range_iff

/-
### supr & infi
-/

-- TODO: this declaration gives error when starting smt state

--@[ematch]

theorem le_supr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (s : ι → α) (i : ι) : s i ≤ supr s :=
  le_Sup (Exists.intro i rfl)

theorem le_supr' {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (s : ι → α) (i : ι) : s i ≤ supr s :=
  le_Sup (Exists.intro i rfl)

/- TODO: this version would be more powerful, but, alas, the pattern matcher
   doesn't accept it.
@[ematch] theorem le_supr' (s : ι → α) (i : ι) : (: s i :) ≤ (: supr s :) :=
le_Sup ⟨i, rfl⟩
-/

theorem is_lub_supr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} : is_lub (set.range s) (supr fun (j : ι) => s j) :=
  is_lub_Sup (set.range s)

theorem is_lub.supr_eq {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} (h : is_lub (set.range s) a) : (supr fun (j : ι) => s j) = a :=
  is_lub.Sup_eq h

theorem is_glb_infi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} : is_glb (set.range s) (infi fun (j : ι) => s j) :=
  is_glb_Inf (set.range s)

theorem is_glb.infi_eq {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} (h : is_glb (set.range s) a) : (infi fun (j : ι) => s j) = a :=
  is_glb.Inf_eq h

theorem le_supr_of_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} (i : ι) (h : a ≤ s i) : a ≤ supr s :=
  le_trans h (le_supr s i)

theorem le_bsupr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop} {f : (i : ι) → p i → α} (i : ι) (hi : p i) : f i hi ≤ supr fun (i : ι) => supr fun (hi : p i) => f i hi :=
  le_supr_of_le i (le_supr (f i) hi)

theorem le_bsupr_of_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {a : α} {p : ι → Prop} {f : (i : ι) → p i → α} (i : ι) (hi : p i) (h : a ≤ f i hi) : a ≤ supr fun (i : ι) => supr fun (hi : p i) => f i hi :=
  le_trans h (le_bsupr i hi)

theorem supr_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} (h : ∀ (i : ι), s i ≤ a) : supr s ≤ a := sorry

theorem bsupr_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {a : α} {p : ι → Prop} {f : (i : ι) → p i → α} (h : ∀ (i : ι) (hi : p i), f i hi ≤ a) : (supr fun (i : ι) => supr fun (hi : p i) => f i hi) ≤ a :=
  supr_le fun (i : ι) => supr_le (h i)

theorem bsupr_le_supr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (p : ι → Prop) (f : ι → α) : (supr fun (i : ι) => supr fun (H : p i) => f i) ≤ supr fun (i : ι) => f i :=
  bsupr_le fun (i : ι) (hi : p i) => le_supr f i

theorem supr_le_supr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {t : ι → α} (h : ∀ (i : ι), s i ≤ t i) : supr s ≤ supr t :=
  supr_le fun (i : ι) => le_supr_of_le i (h i)

theorem supr_le_supr2 {α : Type u_1} {ι : Sort u_4} {ι₂ : Sort u_5} [complete_lattice α] {s : ι → α} {t : ι₂ → α} (h : ∀ (i : ι), ∃ (j : ι₂), s i ≤ t j) : supr s ≤ supr t :=
  supr_le fun (j : ι) => exists.elim (h j) le_supr_of_le

theorem bsupr_le_bsupr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop} {f : (i : ι) → p i → α} {g : (i : ι) → p i → α} (h : ∀ (i : ι) (hi : p i), f i hi ≤ g i hi) : (supr fun (i : ι) => supr fun (hi : p i) => f i hi) ≤ supr fun (i : ι) => supr fun (hi : p i) => g i hi :=
  bsupr_le fun (i : ι) (hi : p i) => le_trans (h i hi) (le_bsupr i hi)

theorem supr_le_supr_const {α : Type u_1} {ι : Sort u_4} {ι₂ : Sort u_5} [complete_lattice α] {a : α} (h : ι → ι₂) : (supr fun (i : ι) => a) ≤ supr fun (j : ι₂) => a :=
  supr_le ((le_supr fun (j : ι₂) => a) ∘ h)

@[simp] theorem supr_le_iff {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} : supr s ≤ a ↔ ∀ (i : ι), s i ≤ a :=
  iff.trans (is_lub_le_iff is_lub_supr) set.forall_range_iff

theorem supr_lt_iff {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} : supr s < a ↔ ∃ (b : α), ∃ (H : b < a), ∀ (i : ι), s i ≤ b := sorry

theorem Sup_eq_supr {α : Type u_1} [complete_lattice α] {s : set α} : Sup s = supr fun (a : α) => supr fun (H : a ∈ s) => a :=
  le_antisymm (Sup_le fun (b : α) (h : b ∈ s) => le_supr_of_le b (le_supr (fun (h : b ∈ s) => b) h))
    (supr_le fun (b : α) => supr_le fun (h : b ∈ s) => le_Sup h)

theorem le_supr_iff {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} : a ≤ supr s ↔ ∀ (b : α), (∀ (i : ι), s i ≤ b) → a ≤ b :=
  { mp := fun (h : a ≤ supr s) (b : α) (hb : ∀ (i : ι), s i ≤ b) => le_trans h (supr_le hb),
    mpr := fun (h : ∀ (b : α), (∀ (i : ι), s i ≤ b) → a ≤ b) => h (supr s) fun (i : ι) => le_supr s i }

theorem monotone.le_map_supr {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α] {s : ι → α} [complete_lattice β] {f : α → β} (hf : monotone f) : (supr fun (i : ι) => f (s i)) ≤ f (supr s) :=
  supr_le fun (i : ι) => hf (le_supr s i)

theorem monotone.le_map_supr2 {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α] [complete_lattice β] {f : α → β} (hf : monotone f) {ι' : ι → Sort u_3} (s : (i : ι) → ι' i → α) : (supr fun (i : ι) => supr fun (h : ι' i) => f (s i h)) ≤ f (supr fun (i : ι) => supr fun (h : ι' i) => s i h) :=
  le_trans (supr_le_supr fun (i : ι) => monotone.le_map_supr hf) (monotone.le_map_supr hf)

theorem monotone.le_map_Sup {α : Type u_1} {β : Type u_2} [complete_lattice α] [complete_lattice β] {s : set α} {f : α → β} (hf : monotone f) : (supr fun (a : α) => supr fun (H : a ∈ s) => f a) ≤ f (Sup s) :=
  eq.mpr (id (Eq._oldrec (Eq.refl ((supr fun (a : α) => supr fun (H : a ∈ s) => f a) ≤ f (Sup s))) Sup_eq_supr))
    (monotone.le_map_supr2 hf fun (a : α) (H : a ∈ s) => a)

theorem supr_comp_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {ι' : Sort u_2} (f : ι' → α) (g : ι → ι') : (supr fun (x : ι) => f (g x)) ≤ supr fun (y : ι') => f y :=
  supr_le_supr2 fun (x : ι) => Exists.intro (g x) (le_refl (f (g x)))

theorem monotone.supr_comp_eq {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α] [preorder β] {f : β → α} (hf : monotone f) {s : ι → β} (hs : ∀ (x : β), ∃ (i : ι), x ≤ s i) : (supr fun (x : ι) => f (s x)) = supr fun (y : β) => f y :=
  le_antisymm (supr_comp_le f fun (x : ι) => s x)
    (supr_le_supr2 fun (x : β) => Exists.imp (fun (i : ι) (hi : x ≤ s i) => hf hi) (hs x))

theorem function.surjective.supr_comp {ι : Sort u_4} {ι₂ : Sort u_5} {α : Type u_1} [has_Sup α] {f : ι → ι₂} (hf : function.surjective f) (g : ι₂ → α) : (supr fun (x : ι) => g (f x)) = supr fun (y : ι₂) => g y := sorry

theorem supr_congr {ι : Sort u_4} {ι₂ : Sort u_5} {α : Type u_1} [has_Sup α] {f : ι → α} {g : ι₂ → α} (h : ι → ι₂) (h1 : function.surjective h) (h2 : ∀ (x : ι), g (h x) = f x) : (supr fun (x : ι) => f x) = supr fun (y : ι₂) => g y := sorry

-- TODO: finish doesn't do well here.

theorem supr_congr_Prop {α : Type u_1} [has_Sup α] {p : Prop} {q : Prop} {f₁ : p → α} {f₂ : q → α} (pq : p ↔ q) (f : ∀ (x : q), f₁ (iff.mpr pq x) = f₂ x) : supr f₁ = supr f₂ :=
  eq.mpr (id (Eq._oldrec (Eq.refl (supr f₁ = supr f₂)) (Eq.symm (funext f))))
    (Eq.symm
      (function.surjective.supr_comp (fun (h : p) => Exists.intro (iff.mp pq h) (Eq.refl (iff.mpr pq (iff.mp pq h)))) f₁))

theorem infi_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (s : ι → α) (i : ι) : infi s ≤ s i :=
  Inf_le (Exists.intro i rfl)

theorem infi_le' {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (s : ι → α) (i : ι) : infi s ≤ s i :=
  Inf_le (Exists.intro i rfl)

theorem infi_le_of_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} (i : ι) (h : s i ≤ a) : infi s ≤ a :=
  le_trans (infi_le s i) h

theorem binfi_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop} {f : (i : ι) → p i → α} (i : ι) (hi : p i) : (infi fun (i : ι) => infi fun (hi : p i) => f i hi) ≤ f i hi :=
  infi_le_of_le i (infi_le (f i) hi)

theorem binfi_le_of_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {a : α} {p : ι → Prop} {f : (i : ι) → p i → α} (i : ι) (hi : p i) (h : f i hi ≤ a) : (infi fun (i : ι) => infi fun (hi : p i) => f i hi) ≤ a :=
  le_trans (binfi_le i hi) h

theorem le_infi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} (h : ∀ (i : ι), a ≤ s i) : a ≤ infi s := sorry

theorem le_binfi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {a : α} {p : ι → Prop} {f : (i : ι) → p i → α} (h : ∀ (i : ι) (hi : p i), a ≤ f i hi) : a ≤ infi fun (i : ι) => infi fun (hi : p i) => f i hi :=
  le_infi fun (i : ι) => le_infi (h i)

theorem infi_le_binfi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (p : ι → Prop) (f : ι → α) : (infi fun (i : ι) => f i) ≤ infi fun (i : ι) => infi fun (H : p i) => f i :=
  le_binfi fun (i : ι) (hi : p i) => infi_le f i

theorem infi_le_infi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {t : ι → α} (h : ∀ (i : ι), s i ≤ t i) : infi s ≤ infi t :=
  le_infi fun (i : ι) => infi_le_of_le i (h i)

theorem infi_le_infi2 {α : Type u_1} {ι : Sort u_4} {ι₂ : Sort u_5} [complete_lattice α] {s : ι → α} {t : ι₂ → α} (h : ∀ (j : ι₂), ∃ (i : ι), s i ≤ t j) : infi s ≤ infi t :=
  le_infi fun (j : ι₂) => exists.elim (h j) infi_le_of_le

theorem binfi_le_binfi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop} {f : (i : ι) → p i → α} {g : (i : ι) → p i → α} (h : ∀ (i : ι) (hi : p i), f i hi ≤ g i hi) : (infi fun (i : ι) => infi fun (hi : p i) => f i hi) ≤ infi fun (i : ι) => infi fun (hi : p i) => g i hi :=
  le_binfi fun (i : ι) (hi : p i) => le_trans (binfi_le i hi) (h i hi)

theorem infi_le_infi_const {α : Type u_1} {ι : Sort u_4} {ι₂ : Sort u_5} [complete_lattice α] {a : α} (h : ι₂ → ι) : (infi fun (i : ι) => a) ≤ infi fun (j : ι₂) => a :=
  le_infi ((infi_le fun (i : ι) => a) ∘ h)

@[simp] theorem le_infi_iff {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} : a ≤ infi s ↔ ∀ (i : ι), a ≤ s i :=
  { mp := fun (this : a ≤ infi s) (i : ι) => le_trans this (infi_le s i), mpr := le_infi }

theorem Inf_eq_infi {α : Type u_1} [complete_lattice α] {s : set α} : Inf s = infi fun (a : α) => infi fun (H : a ∈ s) => a :=
  Sup_eq_supr

theorem monotone.map_infi_le {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α] {s : ι → α} [complete_lattice β] {f : α → β} (hf : monotone f) : f (infi s) ≤ infi fun (i : ι) => f (s i) :=
  le_infi fun (i : ι) => hf (infi_le s i)

theorem monotone.map_infi2_le {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α] [complete_lattice β] {f : α → β} (hf : monotone f) {ι' : ι → Sort u_3} (s : (i : ι) → ι' i → α) : f (infi fun (i : ι) => infi fun (h : ι' i) => s i h) ≤ infi fun (i : ι) => infi fun (h : ι' i) => f (s i h) :=
  monotone.le_map_supr2 (monotone.order_dual hf) fun (i : ι) (h : ι' i) => s i h

theorem monotone.map_Inf_le {α : Type u_1} {β : Type u_2} [complete_lattice α] [complete_lattice β] {s : set α} {f : α → β} (hf : monotone f) : f (Inf s) ≤ infi fun (a : α) => infi fun (H : a ∈ s) => f a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f (Inf s) ≤ infi fun (a : α) => infi fun (H : a ∈ s) => f a)) Inf_eq_infi))
    (monotone.map_infi2_le hf fun (a : α) (H : a ∈ s) => a)

theorem le_infi_comp {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {ι' : Sort u_2} (f : ι' → α) (g : ι → ι') : (infi fun (y : ι') => f y) ≤ infi fun (x : ι) => f (g x) :=
  infi_le_infi2 fun (x : ι) => Exists.intro (g x) (le_refl (f (g x)))

theorem monotone.infi_comp_eq {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α] [preorder β] {f : β → α} (hf : monotone f) {s : ι → β} (hs : ∀ (x : β), ∃ (i : ι), s i ≤ x) : (infi fun (x : ι) => f (s x)) = infi fun (y : β) => f y :=
  le_antisymm (infi_le_infi2 fun (x : β) => Exists.imp (fun (i : ι) (hi : s i ≤ x) => hf hi) (hs x))
    (le_infi_comp (fun (y : β) => f y) fun (x : ι) => s x)

theorem function.surjective.infi_comp {ι : Sort u_4} {ι₂ : Sort u_5} {α : Type u_1} [has_Inf α] {f : ι → ι₂} (hf : function.surjective f) (g : ι₂ → α) : (infi fun (x : ι) => g (f x)) = infi fun (y : ι₂) => g y :=
  function.surjective.supr_comp hf g

theorem infi_congr {ι : Sort u_4} {ι₂ : Sort u_5} {α : Type u_1} [has_Inf α] {f : ι → α} {g : ι₂ → α} (h : ι → ι₂) (h1 : function.surjective h) (h2 : ∀ (x : ι), g (h x) = f x) : (infi fun (x : ι) => f x) = infi fun (y : ι₂) => g y :=
  supr_congr h h1 h2

theorem infi_congr_Prop {α : Type u_1} [has_Inf α] {p : Prop} {q : Prop} {f₁ : p → α} {f₂ : q → α} (pq : p ↔ q) (f : ∀ (x : q), f₁ (iff.mpr pq x) = f₂ x) : infi f₁ = infi f₂ :=
  supr_congr_Prop pq f

theorem supr_const_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {x : α} : (supr fun (h : ι) => x) ≤ x :=
  supr_le fun (_x : ι) => le_rfl

theorem le_infi_const {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {x : α} : x ≤ infi fun (h : ι) => x :=
  le_infi fun (_x : ι) => le_rfl

-- We will generalize this to conditionally complete lattices in `cinfi_const`.

theorem infi_const {α : Type u_1} {ι : Sort u_4} [complete_lattice α] [Nonempty ι] {a : α} : (infi fun (b : ι) => a) = a :=
  eq.mpr (id (Eq._oldrec (Eq.refl ((infi fun (b : ι) => a) = a)) (infi.equations._eqn_1 fun (b : ι) => a)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (Inf (set.range fun (b : ι) => a) = a)) set.range_const))
      (eq.mpr (id (Eq._oldrec (Eq.refl (Inf (singleton a) = a)) Inf_singleton)) (Eq.refl a)))

-- We will generalize this to conditionally complete lattices in `csupr_const`.

theorem supr_const {α : Type u_1} {ι : Sort u_4} [complete_lattice α] [Nonempty ι] {a : α} : (supr fun (b : ι) => a) = a :=
  infi_const

@[simp] theorem infi_top {α : Type u_1} {ι : Sort u_4} [complete_lattice α] : (infi fun (i : ι) => ⊤) = ⊤ :=
  top_unique (le_infi fun (i : ι) => le_refl ⊤)

@[simp] theorem supr_bot {α : Type u_1} {ι : Sort u_4} [complete_lattice α] : (supr fun (i : ι) => ⊥) = ⊥ :=
  infi_top

@[simp] theorem infi_eq_top {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} : infi s = ⊤ ↔ ∀ (i : ι), s i = ⊤ :=
  iff.trans Inf_eq_top set.forall_range_iff

@[simp] theorem supr_eq_bot {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} : supr s = ⊥ ↔ ∀ (i : ι), s i = ⊥ :=
  iff.trans Sup_eq_bot set.forall_range_iff

@[simp] theorem infi_pos {α : Type u_1} [complete_lattice α] {p : Prop} {f : p → α} (hp : p) : (infi fun (h : p) => f h) = f hp :=
  le_antisymm (infi_le (fun (h : p) => f h) hp) (le_infi fun (h : p) => le_refl (f hp))

@[simp] theorem infi_neg {α : Type u_1} [complete_lattice α] {p : Prop} {f : p → α} (hp : ¬p) : (infi fun (h : p) => f h) = ⊤ :=
  le_antisymm le_top (le_infi fun (h : p) => false.elim (hp h))

@[simp] theorem supr_pos {α : Type u_1} [complete_lattice α] {p : Prop} {f : p → α} (hp : p) : (supr fun (h : p) => f h) = f hp :=
  le_antisymm (supr_le fun (h : p) => le_refl (f h)) (le_supr f hp)

@[simp] theorem supr_neg {α : Type u_1} [complete_lattice α] {p : Prop} {f : p → α} (hp : ¬p) : (supr fun (h : p) => f h) = ⊥ :=
  le_antisymm (supr_le fun (h : p) => false.elim (hp h)) bot_le

theorem supr_eq_dif {α : Type u_1} [complete_lattice α] {p : Prop} [Decidable p] (a : p → α) : (supr fun (h : p) => a h) = dite p (fun (h : p) => a h) fun (h : ¬p) => ⊥ := sorry

theorem supr_eq_if {α : Type u_1} [complete_lattice α] {p : Prop} [Decidable p] (a : α) : (supr fun (h : p) => a) = ite p a ⊥ :=
  supr_eq_dif fun (_x : p) => a

theorem infi_eq_dif {α : Type u_1} [complete_lattice α] {p : Prop} [Decidable p] (a : p → α) : (infi fun (h : p) => a h) = dite p (fun (h : p) => a h) fun (h : ¬p) => ⊤ :=
  supr_eq_dif fun (h : p) => a h

theorem infi_eq_if {α : Type u_1} [complete_lattice α] {p : Prop} [Decidable p] (a : α) : (infi fun (h : p) => a) = ite p a ⊤ :=
  infi_eq_dif fun (_x : p) => a

-- TODO: should this be @[simp]?

theorem infi_comm {α : Type u_1} {ι : Sort u_4} {ι₂ : Sort u_5} [complete_lattice α] {f : ι → ι₂ → α} : (infi fun (i : ι) => infi fun (j : ι₂) => f i j) = infi fun (j : ι₂) => infi fun (i : ι) => f i j :=
  le_antisymm (le_infi fun (i : ι₂) => le_infi fun (j : ι) => infi_le_of_le j (infi_le (fun (j_1 : ι₂) => f j j_1) i))
    (le_infi fun (j : ι) => le_infi fun (i : ι₂) => infi_le_of_le i (infi_le (fun (i_1 : ι) => f i_1 i) j))

/- TODO: this is strange. In the proof below, we get exactly the desired
   among the equalities, but close does not get it.
begin
  apply @le_antisymm,
    simp, intros,
    begin [smt]
      ematch, ematch, ematch, trace_state, have := le_refl (f i_1 i),
      trace_state, close
    end
end
-/

-- TODO: should this be @[simp]?

theorem supr_comm {α : Type u_1} {ι : Sort u_4} {ι₂ : Sort u_5} [complete_lattice α] {f : ι → ι₂ → α} : (supr fun (i : ι) => supr fun (j : ι₂) => f i j) = supr fun (j : ι₂) => supr fun (i : ι) => f i j :=
  infi_comm

@[simp] theorem infi_infi_eq_left {α : Type u_1} {β : Type u_2} [complete_lattice α] {b : β} {f : (x : β) → x = b → α} : (infi fun (x : β) => infi fun (h : x = b) => f x h) = f b rfl := sorry

@[simp] theorem infi_infi_eq_right {α : Type u_1} {β : Type u_2} [complete_lattice α] {b : β} {f : (x : β) → b = x → α} : (infi fun (x : β) => infi fun (h : b = x) => f x h) = f b rfl := sorry

@[simp] theorem supr_supr_eq_left {α : Type u_1} {β : Type u_2} [complete_lattice α] {b : β} {f : (x : β) → x = b → α} : (supr fun (x : β) => supr fun (h : x = b) => f x h) = f b rfl :=
  infi_infi_eq_left

@[simp] theorem supr_supr_eq_right {α : Type u_1} {β : Type u_2} [complete_lattice α] {b : β} {f : (x : β) → b = x → α} : (supr fun (x : β) => supr fun (h : b = x) => f x h) = f b rfl :=
  infi_infi_eq_right

theorem infi_subtype {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop} {f : Subtype p → α} : (infi fun (x : Subtype p) => f x) = infi fun (i : ι) => infi fun (h : p i) => f { val := i, property := h } := sorry

theorem infi_subtype' {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop} {f : (i : ι) → p i → α} : (infi fun (i : ι) => infi fun (h : p i) => f i h) = infi fun (x : Subtype p) => f (↑x) (subtype.property x) :=
  Eq.symm infi_subtype

theorem infi_subtype'' {α : Type u_1} [complete_lattice α] {ι : Type u_2} (s : set ι) (f : ι → α) : (infi fun (i : ↥s) => f ↑i) = infi fun (t : ι) => infi fun (H : t ∈ s) => f t :=
  infi_subtype

theorem infi_inf_eq {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {f : ι → α} {g : ι → α} : (infi fun (x : ι) => f x ⊓ g x) = (infi fun (x : ι) => f x) ⊓ infi fun (x : ι) => g x := sorry

/- TODO: here is another example where more flexible pattern matching
   might help.

begin
  apply @le_antisymm,
  safe, pose h := f a ⊓ g a, begin [smt] ematch, ematch  end
end
-/

theorem infi_inf {α : Type u_1} {ι : Sort u_4} [complete_lattice α] [h : Nonempty ι] {f : ι → α} {a : α} : (infi fun (x : ι) => f x) ⊓ a = infi fun (x : ι) => f x ⊓ a := sorry

theorem inf_infi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] [Nonempty ι] {f : ι → α} {a : α} : (a ⊓ infi fun (x : ι) => f x) = infi fun (x : ι) => a ⊓ f x := sorry

theorem binfi_inf {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop} {f : (i : ι) → p i → α} {a : α} (h : ∃ (i : ι), p i) : (infi fun (i : ι) => infi fun (h : p i) => f i h) ⊓ a = infi fun (i : ι) => infi fun (h : p i) => f i h ⊓ a := sorry

theorem inf_binfi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop} {f : (i : ι) → p i → α} {a : α} (h : ∃ (i : ι), p i) : (a ⊓ infi fun (i : ι) => infi fun (h : p i) => f i h) = infi fun (i : ι) => infi fun (h : p i) => a ⊓ f i h := sorry

theorem supr_sup_eq {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {g : β → α} : (supr fun (x : β) => f x ⊔ g x) = (supr fun (x : β) => f x) ⊔ supr fun (x : β) => g x :=
  infi_inf_eq

theorem supr_sup {α : Type u_1} {ι : Sort u_4} [complete_lattice α] [h : Nonempty ι] {f : ι → α} {a : α} : (supr fun (x : ι) => f x) ⊔ a = supr fun (x : ι) => f x ⊔ a :=
  infi_inf

theorem sup_supr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] [Nonempty ι] {f : ι → α} {a : α} : (a ⊔ supr fun (x : ι) => f x) = supr fun (x : ι) => a ⊔ f x :=
  inf_infi

/- supr and infi under Prop -/

@[simp] theorem infi_false {α : Type u_1} [complete_lattice α] {s : False → α} : infi s = ⊤ :=
  le_antisymm le_top (le_infi fun (i : False) => false.elim i)

@[simp] theorem supr_false {α : Type u_1} [complete_lattice α] {s : False → α} : supr s = ⊥ :=
  le_antisymm (supr_le fun (i : False) => false.elim i) bot_le

@[simp] theorem infi_true {α : Type u_1} [complete_lattice α] {s : True → α} : infi s = s trivial :=
  le_antisymm (infi_le s trivial)
    (le_infi
      fun (_x : True) => (fun (_a : True) => true.dcases_on _a (idRhs (s trivial ≤ s trivial) (le_refl (s trivial)))) _x)

@[simp] theorem supr_true {α : Type u_1} [complete_lattice α] {s : True → α} : supr s = s trivial := sorry

@[simp] theorem infi_exists {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop} {f : Exists p → α} : (infi fun (x : Exists p) => f x) = infi fun (i : ι) => infi fun (h : p i) => f (Exists.intro i h) := sorry

@[simp] theorem supr_exists {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop} {f : Exists p → α} : (supr fun (x : Exists p) => f x) = supr fun (i : ι) => supr fun (h : p i) => f (Exists.intro i h) :=
  infi_exists

theorem infi_and {α : Type u_1} [complete_lattice α] {p : Prop} {q : Prop} {s : p ∧ q → α} : infi s = infi fun (h₁ : p) => infi fun (h₂ : q) => s { left := h₁, right := h₂ } := sorry

/-- The symmetric case of `infi_and`, useful for rewriting into a infimum over a conjunction -/
theorem infi_and' {α : Type u_1} [complete_lattice α] {p : Prop} {q : Prop} {s : p → q → α} : (infi fun (h₁ : p) => infi fun (h₂ : q) => s h₁ h₂) = infi fun (h : p ∧ q) => s (and.left h) (and.right h) :=
  Eq.symm infi_and

theorem supr_and {α : Type u_1} [complete_lattice α] {p : Prop} {q : Prop} {s : p ∧ q → α} : supr s = supr fun (h₁ : p) => supr fun (h₂ : q) => s { left := h₁, right := h₂ } :=
  infi_and

/-- The symmetric case of `supr_and`, useful for rewriting into a supremum over a conjunction -/
theorem supr_and' {α : Type u_1} [complete_lattice α] {p : Prop} {q : Prop} {s : p → q → α} : (supr fun (h₁ : p) => supr fun (h₂ : q) => s h₁ h₂) = supr fun (h : p ∧ q) => s (and.left h) (and.right h) :=
  Eq.symm supr_and

theorem infi_or {α : Type u_1} [complete_lattice α] {p : Prop} {q : Prop} {s : p ∨ q → α} : infi s = (infi fun (h : p) => s (Or.inl h)) ⊓ infi fun (h : q) => s (Or.inr h) := sorry

theorem supr_or {α : Type u_1} [complete_lattice α] {p : Prop} {q : Prop} {s : p ∨ q → α} : (supr fun (x : p ∨ q) => s x) = (supr fun (i : p) => s (Or.inl i)) ⊔ supr fun (j : q) => s (Or.inr j) :=
  infi_or

theorem Sup_range {ι : Sort u_4} {α : Type u_1} [has_Sup α] {f : ι → α} : Sup (set.range f) = supr f :=
  rfl

theorem Inf_range {ι : Sort u_4} {α : Type u_1} [has_Inf α] {f : ι → α} : Inf (set.range f) = infi f :=
  rfl

theorem supr_range {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α] {g : β → α} {f : ι → β} : (supr fun (b : β) => supr fun (H : b ∈ set.range f) => g b) = supr fun (i : ι) => g (f i) := sorry

theorem infi_range {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α] {g : β → α} {f : ι → β} : (infi fun (b : β) => infi fun (H : b ∈ set.range f) => g b) = infi fun (i : ι) => g (f i) :=
  supr_range

theorem Inf_image {α : Type u_1} {β : Type u_2} [complete_lattice α] {s : set β} {f : β → α} : Inf (f '' s) = infi fun (a : β) => infi fun (H : a ∈ s) => f a := sorry

theorem Sup_image {α : Type u_1} {β : Type u_2} [complete_lattice α] {s : set β} {f : β → α} : Sup (f '' s) = supr fun (a : β) => supr fun (H : a ∈ s) => f a :=
  Inf_image

/-
### supr and infi under set constructions
-/

theorem infi_emptyset {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} : (infi fun (x : β) => infi fun (H : x ∈ ∅) => f x) = ⊤ := sorry

theorem supr_emptyset {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} : (supr fun (x : β) => supr fun (H : x ∈ ∅) => f x) = ⊥ := sorry

theorem infi_univ {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} : (infi fun (x : β) => infi fun (H : x ∈ set.univ) => f x) = infi fun (x : β) => f x := sorry

theorem supr_univ {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} : (supr fun (x : β) => supr fun (H : x ∈ set.univ) => f x) = supr fun (x : β) => f x := sorry

theorem infi_union {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {s : set β} {t : set β} : (infi fun (x : β) => infi fun (H : x ∈ s ∪ t) => f x) =
  (infi fun (x : β) => infi fun (H : x ∈ s) => f x) ⊓ infi fun (x : β) => infi fun (H : x ∈ t) => f x := sorry

theorem infi_split {α : Type u_1} {β : Type u_2} [complete_lattice α] (f : β → α) (p : β → Prop) : (infi fun (i : β) => f i) =
  (infi fun (i : β) => infi fun (h : p i) => f i) ⊓ infi fun (i : β) => infi fun (h : ¬p i) => f i := sorry

theorem infi_split_single {α : Type u_1} {β : Type u_2} [complete_lattice α] (f : β → α) (i₀ : β) : (infi fun (i : β) => f i) = f i₀ ⊓ infi fun (i : β) => infi fun (h : i ≠ i₀) => f i := sorry

theorem infi_le_infi_of_subset {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {s : set β} {t : set β} (h : s ⊆ t) : (infi fun (x : β) => infi fun (H : x ∈ t) => f x) ≤ infi fun (x : β) => infi fun (H : x ∈ s) => f x := sorry

theorem supr_union {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {s : set β} {t : set β} : (supr fun (x : β) => supr fun (H : x ∈ s ∪ t) => f x) =
  (supr fun (x : β) => supr fun (H : x ∈ s) => f x) ⊔ supr fun (x : β) => supr fun (H : x ∈ t) => f x :=
  infi_union

theorem supr_split {α : Type u_1} {β : Type u_2} [complete_lattice α] (f : β → α) (p : β → Prop) : (supr fun (i : β) => f i) =
  (supr fun (i : β) => supr fun (h : p i) => f i) ⊔ supr fun (i : β) => supr fun (h : ¬p i) => f i :=
  infi_split (fun (i : β) => f i) fun (i : β) => p i

theorem supr_split_single {α : Type u_1} {β : Type u_2} [complete_lattice α] (f : β → α) (i₀ : β) : (supr fun (i : β) => f i) = f i₀ ⊔ supr fun (i : β) => supr fun (h : i ≠ i₀) => f i :=
  infi_split_single (fun (i : β) => f i) i₀

theorem supr_le_supr_of_subset {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {s : set β} {t : set β} (h : s ⊆ t) : (supr fun (x : β) => supr fun (H : x ∈ s) => f x) ≤ supr fun (x : β) => supr fun (H : x ∈ t) => f x :=
  infi_le_infi_of_subset h

theorem infi_insert {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {s : set β} {b : β} : (infi fun (x : β) => infi fun (H : x ∈ insert b s) => f x) = f b ⊓ infi fun (x : β) => infi fun (H : x ∈ s) => f x :=
  Eq.trans infi_union (congr_arg (fun (x : α) => x ⊓ infi fun (x : β) => infi fun (H : x ∈ s) => f x) infi_infi_eq_left)

theorem supr_insert {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {s : set β} {b : β} : (supr fun (x : β) => supr fun (H : x ∈ insert b s) => f x) = f b ⊔ supr fun (x : β) => supr fun (H : x ∈ s) => f x :=
  Eq.trans supr_union (congr_arg (fun (x : α) => x ⊔ supr fun (x : β) => supr fun (H : x ∈ s) => f x) supr_supr_eq_left)

theorem infi_singleton {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {b : β} : (infi fun (x : β) => infi fun (H : x ∈ singleton b) => f x) = f b := sorry

theorem infi_pair {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {a : β} {b : β} : (infi fun (x : β) => infi fun (H : x ∈ insert a (singleton b)) => f x) = f a ⊓ f b := sorry

theorem supr_singleton {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {b : β} : (supr fun (x : β) => supr fun (H : x ∈ singleton b) => f x) = f b :=
  infi_singleton

theorem supr_pair {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {a : β} {b : β} : (supr fun (x : β) => supr fun (H : x ∈ insert a (singleton b)) => f x) = f a ⊔ f b := sorry

theorem infi_image {α : Type u_1} {β : Type u_2} [complete_lattice α] {γ : Type u_3} {f : β → γ} {g : γ → α} {t : set β} : (infi fun (c : γ) => infi fun (H : c ∈ f '' t) => g c) = infi fun (b : β) => infi fun (H : b ∈ t) => g (f b) := sorry

theorem supr_image {α : Type u_1} {β : Type u_2} [complete_lattice α] {γ : Type u_3} {f : β → γ} {g : γ → α} {t : set β} : (supr fun (c : γ) => supr fun (H : c ∈ f '' t) => g c) = supr fun (b : β) => supr fun (H : b ∈ t) => g (f b) :=
  infi_image

/-!
### `supr` and `infi` under `Type`
-/

theorem infi_of_empty' {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (h : ι → False) {s : ι → α} : infi s = ⊤ :=
  top_unique (le_infi fun (i : ι) => false.elim (h i))

theorem supr_of_empty' {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (h : ι → False) {s : ι → α} : supr s = ⊥ :=
  bot_unique (supr_le fun (i : ι) => false.elim (h i))

theorem infi_of_empty {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (h : ¬Nonempty ι) {s : ι → α} : infi s = ⊤ :=
  infi_of_empty' fun (i : ι) => h (Nonempty.intro i)

theorem supr_of_empty {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (h : ¬Nonempty ι) {s : ι → α} : supr s = ⊥ :=
  supr_of_empty' fun (i : ι) => h (Nonempty.intro i)

@[simp] theorem infi_empty {α : Type u_1} [complete_lattice α] {s : empty → α} : infi s = ⊤ :=
  infi_of_empty nonempty_empty

@[simp] theorem supr_empty {α : Type u_1} [complete_lattice α] {s : empty → α} : supr s = ⊥ :=
  supr_of_empty nonempty_empty

theorem supr_bool_eq {α : Type u_1} [complete_lattice α] {f : Bool → α} : (supr fun (b : Bool) => f b) = f tt ⊔ f false := sorry

theorem infi_bool_eq {α : Type u_1} [complete_lattice α] {f : Bool → α} : (infi fun (b : Bool) => f b) = f tt ⊓ f false :=
  supr_bool_eq

theorem is_glb_binfi {α : Type u_1} {β : Type u_2} [complete_lattice α] {s : set β} {f : β → α} : is_glb (f '' s) (infi fun (x : β) => infi fun (H : x ∈ s) => f x) := sorry

theorem supr_subtype {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop} {f : Subtype p → α} : (supr fun (x : Subtype p) => f x) = supr fun (i : ι) => supr fun (h : p i) => f { val := i, property := h } :=
  infi_subtype

theorem supr_subtype' {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop} {f : (i : ι) → p i → α} : (supr fun (i : ι) => supr fun (h : p i) => f i h) = supr fun (x : Subtype p) => f (↑x) (subtype.property x) :=
  Eq.symm supr_subtype

theorem Sup_eq_supr' {α : Type u_1} [complete_lattice α] {s : set α} : Sup s = supr fun (x : ↥s) => ↑x := sorry

theorem is_lub_bsupr {α : Type u_1} {β : Type u_2} [complete_lattice α] {s : set β} {f : β → α} : is_lub (f '' s) (supr fun (x : β) => supr fun (H : x ∈ s) => f x) := sorry

theorem infi_sigma {α : Type u_1} {β : Type u_2} [complete_lattice α] {p : β → Type u_3} {f : sigma p → α} : (infi fun (x : sigma p) => f x) = infi fun (i : β) => infi fun (h : p i) => f (sigma.mk i h) := sorry

theorem supr_sigma {α : Type u_1} {β : Type u_2} [complete_lattice α] {p : β → Type u_3} {f : sigma p → α} : (supr fun (x : sigma p) => f x) = supr fun (i : β) => supr fun (h : p i) => f (sigma.mk i h) :=
  infi_sigma

theorem infi_prod {α : Type u_1} {β : Type u_2} [complete_lattice α] {γ : Type u_3} {f : β × γ → α} : (infi fun (x : β × γ) => f x) = infi fun (i : β) => infi fun (j : γ) => f (i, j) := sorry

theorem supr_prod {α : Type u_1} {β : Type u_2} [complete_lattice α] {γ : Type u_3} {f : β × γ → α} : (supr fun (x : β × γ) => f x) = supr fun (i : β) => supr fun (j : γ) => f (i, j) :=
  infi_prod

theorem infi_sum {α : Type u_1} {β : Type u_2} [complete_lattice α] {γ : Type u_3} {f : β ⊕ γ → α} : (infi fun (x : β ⊕ γ) => f x) = (infi fun (i : β) => f (sum.inl i)) ⊓ infi fun (j : γ) => f (sum.inr j) := sorry

theorem supr_sum {α : Type u_1} {β : Type u_2} [complete_lattice α] {γ : Type u_3} {f : β ⊕ γ → α} : (supr fun (x : β ⊕ γ) => f x) = (supr fun (i : β) => f (sum.inl i)) ⊔ supr fun (j : γ) => f (sum.inr j) :=
  infi_sum

/-!
### `supr` and `infi` under `ℕ`
-/

theorem supr_ge_eq_supr_nat_add {α : Type u_1} [complete_lattice α] {u : ℕ → α} (n : ℕ) : (supr fun (i : ℕ) => supr fun (H : i ≥ n) => u i) = supr fun (i : ℕ) => u (i + n) := sorry

theorem infi_ge_eq_infi_nat_add {α : Type u_1} [complete_lattice α] {u : ℕ → α} (n : ℕ) : (infi fun (i : ℕ) => infi fun (H : i ≥ n) => u i) = infi fun (i : ℕ) => u (i + n) :=
  supr_ge_eq_supr_nat_add n

theorem supr_eq_top {α : Type u_1} {ι : Sort u_4} [complete_linear_order α] (f : ι → α) : supr f = ⊤ ↔ ∀ (b : α), b < ⊤ → ∃ (i : ι), b < f i := sorry

theorem infi_eq_bot {α : Type u_1} {ι : Sort u_4} [complete_linear_order α] (f : ι → α) : infi f = ⊥ ↔ ∀ (b : α), b > ⊥ → ∃ (i : ι), f i < b := sorry

/-!
### Instances
-/

protected instance complete_lattice_Prop : complete_lattice Prop :=
  complete_lattice.mk bounded_distrib_lattice.sup bounded_distrib_lattice.le bounded_distrib_lattice.lt sorry sorry sorry
    sorry sorry sorry bounded_distrib_lattice.inf sorry sorry sorry bounded_distrib_lattice.top sorry
    bounded_distrib_lattice.bot sorry (fun (s : set Prop) => ∃ (a : Prop), ∃ (H : a ∈ s), a)
    (fun (s : set Prop) => ∀ (a : Prop), a ∈ s → a) sorry sorry sorry sorry

theorem Inf_Prop_eq {s : set Prop} : Inf s = ∀ (p : Prop), p ∈ s → p :=
  rfl

theorem Sup_Prop_eq {s : set Prop} : Sup s = ∃ (p : Prop), ∃ (H : p ∈ s), p :=
  rfl

theorem infi_Prop_eq {ι : Sort u_1} {p : ι → Prop} : (infi fun (i : ι) => p i) = ∀ (i : ι), p i := sorry

theorem supr_Prop_eq {ι : Sort u_1} {p : ι → Prop} : (supr fun (i : ι) => p i) = ∃ (i : ι), p i := sorry

protected instance pi.has_Sup {α : Type u_1} {β : α → Type u_2} [(i : α) → has_Sup (β i)] : has_Sup ((i : α) → β i) :=
  has_Sup.mk fun (s : set ((i : α) → β i)) (i : α) => supr fun (f : ↥s) => coe f i

protected instance pi.has_Inf {α : Type u_1} {β : α → Type u_2} [(i : α) → has_Inf (β i)] : has_Inf ((i : α) → β i) :=
  has_Inf.mk fun (s : set ((i : α) → β i)) (i : α) => infi fun (f : ↥s) => coe f i

protected instance pi.complete_lattice {α : Type u_1} {β : α → Type u_2} [(i : α) → complete_lattice (β i)] : complete_lattice ((i : α) → β i) :=
  complete_lattice.mk bounded_lattice.sup bounded_lattice.le bounded_lattice.lt sorry sorry sorry sorry sorry sorry
    bounded_lattice.inf sorry sorry sorry bounded_lattice.top sorry bounded_lattice.bot sorry Sup Inf sorry sorry sorry
    sorry

theorem Inf_apply {α : Type u_1} {β : α → Type u_2} [(i : α) → has_Inf (β i)] {s : set ((a : α) → β a)} {a : α} : Inf s a = infi fun (f : ↥s) => coe f a :=
  rfl

theorem infi_apply {α : Type u_1} {β : α → Type u_2} {ι : Sort u_3} [(i : α) → has_Inf (β i)] {f : ι → (a : α) → β a} {a : α} : infi (fun (i : ι) => f i) a = infi fun (i : ι) => f i a := sorry

theorem Sup_apply {α : Type u_1} {β : α → Type u_2} [(i : α) → has_Sup (β i)] {s : set ((a : α) → β a)} {a : α} : Sup s a = supr fun (f : ↥s) => coe f a :=
  rfl

theorem supr_apply {α : Type u_1} {β : α → Type u_2} {ι : Sort u_3} [(i : α) → has_Sup (β i)] {f : ι → (a : α) → β a} {a : α} : supr (fun (i : ι) => f i) a = supr fun (i : ι) => f i a :=
  infi_apply

theorem monotone_Sup_of_monotone {α : Type u_1} {β : Type u_2} [preorder α] [complete_lattice β] {s : set (α → β)} (m_s : ∀ (f : α → β), f ∈ s → monotone f) : monotone (Sup s) :=
  fun (x y : α) (h : x ≤ y) => supr_le fun (f : ↥s) => le_supr_of_le f (m_s (↑f) (subtype.property f) h)

theorem monotone_Inf_of_monotone {α : Type u_1} {β : Type u_2} [preorder α] [complete_lattice β] {s : set (α → β)} (m_s : ∀ (f : α → β), f ∈ s → monotone f) : monotone (Inf s) :=
  fun (x y : α) (h : x ≤ y) => le_infi fun (f : ↥s) => infi_le_of_le f (m_s (↑f) (subtype.property f) h)

namespace prod

protected instance has_Inf (α : Type u_1) (β : Type u_2) [has_Inf α] [has_Inf β] : has_Inf (α × β) :=
  has_Inf.mk fun (s : set (α × β)) => (Inf (fst '' s), Inf (snd '' s))

protected instance has_Sup (α : Type u_1) (β : Type u_2) [has_Sup α] [has_Sup β] : has_Sup (α × β) :=
  has_Sup.mk fun (s : set (α × β)) => (Sup (fst '' s), Sup (snd '' s))

protected instance complete_lattice (α : Type u_1) (β : Type u_2) [complete_lattice α] [complete_lattice β] : complete_lattice (α × β) :=
  complete_lattice.mk bounded_lattice.sup bounded_lattice.le bounded_lattice.lt sorry sorry sorry sorry sorry sorry
    bounded_lattice.inf sorry sorry sorry bounded_lattice.top sorry bounded_lattice.bot sorry Sup Inf sorry sorry sorry
    sorry


import .wf

open list

def remove_neg : atom → atom
| (atom.le i ks) := atom.le (1 - i) (map_neg ks)
| (atom.dvd d i ks)  := atom.ndvd d i ks
| (atom.ndvd d i ks) := atom.dvd d i ks

meta def neg_prsv_normal_aux :=
  `[unfold remove_neg at hb,
    rewrite (eq_of_mem_singleton hb), trivial]

lemma wf_remove_neg : ∀ {a : atom}, a.wf → (remove_neg a).wf
| (atom.le i ks)     h := begin simp [remove_neg] end
| (atom.dvd d i ks)  h := begin simp [remove_neg], apply h end
| (atom.ndvd d i ks) h := begin simp [remove_neg], apply h end

lemma eval_remove_neg :
  ∀ (a : atom) (xs : list znum),
    (remove_neg a).eval xs ↔ (¬ (a.eval xs))
| (atom.le i ks) xs :=
  begin
    simp only [remove_neg, atom.eval],
    apply calc
          (1 - i ≤ znum.dot_prod (map_neg ks) xs)
        ↔ (-(znum.dot_prod (map_neg ks) xs) ≤ -(1 - i)) :
          begin apply iff.intro, apply (@neg_le_neg znum _), apply (@le_of_neg_le_neg znum _) end
    ... ↔ (znum.dot_prod ks xs ≤ -(1 - i)) :
          begin rw [znum.map_neg_dot_prod], simp, end
    ... ↔ (znum.dot_prod ks xs ≤ i - 1) :
           by rewrite neg_sub
    ... ↔ (znum.dot_prod ks xs < i) :
          begin
            apply iff.intro,
            apply znum.lt_of_le_sub_one,
            apply znum.le_sub_one_of_lt
          end
    ... ↔ ¬i ≤ znum.dot_prod ks xs :
          begin
            apply iff.intro,
            apply not_le_of_gt,
            apply lt_of_not_ge
          end
  end
| (atom.dvd d i ks)  xs := by refl
| (atom.ndvd d i ks) xs := by apply not_not_iff.symm


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Johan Commelin, Mario Carneiro
-/

import data.mv_polynomial.rename
import data.polynomial.algebra_map
import logic.equiv.fin

/-!
# Equivalences between polynomial rings

This file establishes a number of equivalences between polynomial rings,
based on equivalences between the underlying types.

## Notation

As in other polynomial files, we typically use the notation:

+ `σ : Type*` (indexing the variables)

+ `R : Type*` `[comm_semiring R]` (the coefficients)

+ `s : σ →₀ ℕ`, a function from `σ` to `ℕ` which is zero away from a finite set.
This will give rise to a monomial in `mv_polynomial σ R` which mathematicians might call `X^s`

+ `a : R`

+ `i : σ`, with corresponding monomial `X i`, often denoted `X_i` by mathematicians

+ `p : mv_polynomial σ R`

## Tags

equivalence, isomorphism, morphism, ring hom, hom

-/

noncomputable theory

open_locale classical big_operators polynomial

open set function finsupp add_monoid_algebra

universes u v w x
variables {R : Type u} {S₁ : Type v} {S₂ : Type w} {S₃ : Type x}

namespace mv_polynomial
variables {σ : Type*} {a a' a₁ a₂ : R} {e : ℕ} {n m : σ} {s : σ →₀ ℕ}

section equiv

variables (R) [comm_semiring R]

/--
The ring isomorphism between multivariable polynomials in a single variable and
polynomials over the ground ring.
-/
@[simps]
def punit_alg_equiv : mv_polynomial punit R ≃ₐ[R] R[X] :=
{ to_fun    := eval₂ polynomial.C (λu:punit, polynomial.X),
  inv_fun   := polynomial.eval₂ mv_polynomial.C (X punit.star),
  left_inv  :=
    begin
      let f : R[X] →+* mv_polynomial punit R :=
        (polynomial.eval₂_ring_hom mv_polynomial.C (X punit.star)),
      let g : mv_polynomial punit R →+* R[X] :=
        (eval₂_hom polynomial.C (λu:punit, polynomial.X)),
      show ∀ p, f.comp g p = p,
      apply is_id,
      { ext a, dsimp, rw [eval₂_C, polynomial.eval₂_C] },
      { rintros ⟨⟩, dsimp, rw [eval₂_X, polynomial.eval₂_X] }
    end,
  right_inv := assume p, polynomial.induction_on p
    (assume a, by rw [polynomial.eval₂_C, mv_polynomial.eval₂_C])
    (assume p q hp hq, by rw [polynomial.eval₂_add, mv_polynomial.eval₂_add, hp, hq])
    (assume p n hp,
      by rw [polynomial.eval₂_mul, polynomial.eval₂_pow, polynomial.eval₂_X, polynomial.eval₂_C,
        eval₂_mul, eval₂_C, eval₂_pow, eval₂_X]),
  map_mul'  := λ _ _, eval₂_mul _ _,
  map_add'  := λ _ _, eval₂_add _ _,
  commutes' := λ _, eval₂_C _ _ _}

section map
variables {R} (σ)

/-- If `e : A ≃+* B` is an isomorphism of rings, then so is `map e`. -/
@[simps apply]
def map_equiv [comm_semiring S₁] [comm_semiring S₂] (e : S₁ ≃+* S₂) :
  mv_polynomial σ S₁ ≃+* mv_polynomial σ S₂ :=
{ to_fun    := map (e : S₁ →+* S₂),
  inv_fun   := map (e.symm : S₂ →+* S₁),
  left_inv  := map_left_inverse e.left_inv,
  right_inv := map_right_inverse e.right_inv,
  ..map (e : S₁ →+* S₂) }

@[simp] lemma map_equiv_refl :
  map_equiv σ (ring_equiv.refl R) = ring_equiv.refl _ :=
ring_equiv.ext map_id

@[simp] lemma map_equiv_symm [comm_semiring S₁] [comm_semiring S₂] (e : S₁ ≃+* S₂) :
  (map_equiv σ e).symm = map_equiv σ e.symm := rfl

@[simp] lemma map_equiv_trans [comm_semiring S₁] [comm_semiring S₂] [comm_semiring S₃]
  (e : S₁ ≃+* S₂) (f : S₂ ≃+* S₃) :
  (map_equiv σ e).trans (map_equiv σ f) = map_equiv σ (e.trans f) :=
ring_equiv.ext (map_map e f)

variables {A₁ A₂ A₃ : Type*} [comm_semiring A₁] [comm_semiring A₂] [comm_semiring A₃]
variables [algebra R A₁] [algebra R A₂] [algebra R A₃]

/-- If `e : A ≃ₐ[R] B` is an isomorphism of `R`-algebras, then so is `map e`. -/
@[simps apply]
def map_alg_equiv (e : A₁ ≃ₐ[R] A₂) :
  mv_polynomial σ A₁ ≃ₐ[R] mv_polynomial σ A₂ :=
{ to_fun := map (e : A₁ →+* A₂),
  ..map_alg_hom (e : A₁ →ₐ[R] A₂),
  ..map_equiv σ (e : A₁ ≃+* A₂) }

@[simp] lemma map_alg_equiv_refl :
  map_alg_equiv σ (alg_equiv.refl : A₁ ≃ₐ[R] A₁) = alg_equiv.refl :=
alg_equiv.ext map_id

@[simp] lemma map_alg_equiv_symm (e : A₁ ≃ₐ[R] A₂) :
  (map_alg_equiv σ e).symm = map_alg_equiv σ e.symm := rfl

@[simp] lemma map_alg_equiv_trans (e : A₁ ≃ₐ[R] A₂) (f : A₂ ≃ₐ[R] A₃) :
  (map_alg_equiv σ e).trans (map_alg_equiv σ f) = map_alg_equiv σ (e.trans f) :=
alg_equiv.ext (map_map e f)

end map

section
variables (S₁ S₂ S₃)

/--
The function from multivariable polynomials in a sum of two types,
to multivariable polynomials in one of the types,
with coefficents in multivariable polynomials in the other type.

See `sum_ring_equiv` for the ring isomorphism.
-/
def sum_to_iter : mv_polynomial (S₁ ⊕ S₂) R →+* mv_polynomial S₁ (mv_polynomial S₂ R) :=
eval₂_hom (C.comp C) (λbc, sum.rec_on bc X (C ∘ X))

@[simp]
lemma sum_to_iter_C (a : R) : sum_to_iter R S₁ S₂ (C a) = C (C a) :=
eval₂_C _ _ a

@[simp]
lemma sum_to_iter_Xl (b : S₁) : sum_to_iter R S₁ S₂ (X (sum.inl b)) = X b :=
eval₂_X _ _ (sum.inl b)

@[simp]
lemma sum_to_iter_Xr (c : S₂) : sum_to_iter R S₁ S₂ (X (sum.inr c)) = C (X c) :=
eval₂_X _ _ (sum.inr c)

/--
The function from multivariable polynomials in one type,
with coefficents in multivariable polynomials in another type,
to multivariable polynomials in the sum of the two types.

See `sum_ring_equiv` for the ring isomorphism.
-/
def iter_to_sum : mv_polynomial S₁ (mv_polynomial S₂ R) →+* mv_polynomial (S₁ ⊕ S₂) R :=
eval₂_hom (eval₂_hom C (X ∘ sum.inr)) (X ∘ sum.inl)

lemma iter_to_sum_C_C (a : R) : iter_to_sum R S₁ S₂ (C (C a)) = C a :=
eq.trans (eval₂_C _ _ (C a)) (eval₂_C _ _ _)

lemma iter_to_sum_X (b : S₁) : iter_to_sum R S₁ S₂ (X b) = X (sum.inl b) :=
eval₂_X _ _ _

lemma iter_to_sum_C_X (c : S₂) : iter_to_sum R S₁ S₂ (C (X c)) = X (sum.inr c) :=
eq.trans (eval₂_C _ _ (X c)) (eval₂_X _ _ _)

variable (σ)

/-- The algebra isomorphism between multivariable polynomials in no variables
and the ground ring. -/
@[simps] def is_empty_alg_equiv [he : is_empty σ] : mv_polynomial σ R ≃ₐ[R] R :=
alg_equiv.of_alg_hom
  (aeval (is_empty.elim he))
  (algebra.of_id _ _)
  (by { ext, simp [algebra.of_id_apply, algebra_map_eq] })
  (by { ext i m, exact is_empty.elim' he i })

/-- The ring isomorphism between multivariable polynomials in no variables
and the ground ring. -/
@[simps] def is_empty_ring_equiv [he : is_empty σ] : mv_polynomial σ R ≃+* R :=
(is_empty_alg_equiv R σ).to_ring_equiv

variable {σ}

/-- A helper function for `sum_ring_equiv`. -/
@[simps]
def mv_polynomial_equiv_mv_polynomial [comm_semiring S₃]
  (f : mv_polynomial S₁ R →+* mv_polynomial S₂ S₃)
  (g : mv_polynomial S₂ S₃ →+* mv_polynomial S₁ R)
  (hfgC : (f.comp g).comp C = C)
  (hfgX : ∀n, f (g (X n)) = X n)
  (hgfC : (g.comp f).comp C = C)
  (hgfX : ∀n, g (f (X n)) = X n) :
  mv_polynomial S₁ R ≃+* mv_polynomial S₂ S₃ :=
{ to_fun    := f, inv_fun := g,
  left_inv  := is_id (ring_hom.comp _ _) hgfC hgfX,
  right_inv := is_id (ring_hom.comp _ _) hfgC hfgX,
  map_mul'  := f.map_mul,
  map_add'  := f.map_add }

/--
The ring isomorphism between multivariable polynomials in a sum of two types,
and multivariable polynomials in one of the types,
with coefficents in multivariable polynomials in the other type.
-/
def sum_ring_equiv : mv_polynomial (S₁ ⊕ S₂) R ≃+* mv_polynomial S₁ (mv_polynomial S₂ R) :=
begin
  apply @mv_polynomial_equiv_mv_polynomial R (S₁ ⊕ S₂) _ _ _ _
    (sum_to_iter R S₁ S₂) (iter_to_sum R S₁ S₂),
  { refine ring_hom.ext (λ p, _),
    rw [ring_hom.comp_apply],
    convert hom_eq_hom ((sum_to_iter R S₁ S₂).comp ((iter_to_sum R S₁ S₂).comp C)) C _ _ p,
    { ext1 a, dsimp, rw [iter_to_sum_C_C R S₁ S₂, sum_to_iter_C R S₁ S₂] },
    { assume c, dsimp, rw [iter_to_sum_C_X R S₁ S₂, sum_to_iter_Xr R S₁ S₂] } },
  { assume b, rw [iter_to_sum_X R S₁ S₂, sum_to_iter_Xl R S₁ S₂] },
  { ext1 a, rw [ring_hom.comp_apply, ring_hom.comp_apply,
      sum_to_iter_C R S₁ S₂, iter_to_sum_C_C R S₁ S₂] },
  { assume n, cases n with b c,
    { rw [sum_to_iter_Xl, iter_to_sum_X] },
    { rw [sum_to_iter_Xr, iter_to_sum_C_X] } },
end

/--
The algebra isomorphism between multivariable polynomials in a sum of two types,
and multivariable polynomials in one of the types,
with coefficents in multivariable polynomials in the other type.
-/
def sum_alg_equiv : mv_polynomial (S₁ ⊕ S₂) R ≃ₐ[R]
  mv_polynomial S₁ (mv_polynomial S₂ R) :=
{ commutes' := begin
    intro r,
    have A : algebra_map R (mv_polynomial S₁ (mv_polynomial S₂ R)) r = (C (C r) : _), by refl,
    have B : algebra_map R (mv_polynomial (S₁ ⊕ S₂) R) r = C r, by refl,
    simp only [sum_ring_equiv, sum_to_iter_C, mv_polynomial_equiv_mv_polynomial_apply,
      ring_equiv.to_fun_eq_coe, A, B],
  end,
  ..sum_ring_equiv R S₁ S₂ }

section

-- this speeds up typeclass search in the lemma below
local attribute [instance, priority 2000] is_scalar_tower.right

/--
The algebra isomorphism between multivariable polynomials in `option S₁` and
polynomials with coefficients in `mv_polynomial S₁ R`.
-/
@[simps] def option_equiv_left :
  mv_polynomial (option S₁) R ≃ₐ[R] polynomial (mv_polynomial S₁ R) :=
alg_equiv.of_alg_hom
  (mv_polynomial.aeval (λ o, o.elim polynomial.X (λ s, polynomial.C (X s))))
  (polynomial.aeval_tower (mv_polynomial.rename some) (X none))
  (by ext : 2; simp [← polynomial.C_eq_algebra_map])
  (by ext i : 2; cases i; simp)

end

/--
The algebra isomorphism between multivariable polynomials in `option S₁` and
multivariable polynomials with coefficients in polynomials.
-/
def option_equiv_right : mv_polynomial (option S₁) R ≃ₐ[R] mv_polynomial S₁ R[X] :=
alg_equiv.of_alg_hom
  (mv_polynomial.aeval (λ o, o.elim (C polynomial.X) X))
  (mv_polynomial.aeval_tower (polynomial.aeval (X none)) (λ i, X (option.some i)))
  (by ext : 2; simp [mv_polynomial.algebra_map_eq])
  (by ext i : 2; cases i; simp)

/--
The algebra isomorphism between multivariable polynomials in `fin (n + 1)` and
polynomials over multivariable polynomials in `fin n`.
-/
def fin_succ_equiv (n : ℕ) :
  mv_polynomial (fin (n + 1)) R ≃ₐ[R] polynomial (mv_polynomial (fin n) R) :=
(rename_equiv R (fin_succ_equiv n)).trans
  (option_equiv_left R (fin n))

lemma fin_succ_equiv_eq (n : ℕ) :
  (fin_succ_equiv R n : mv_polynomial (fin (n + 1)) R →+* polynomial (mv_polynomial (fin n) R)) =
  eval₂_hom (polynomial.C.comp (C : R →+* mv_polynomial (fin n) R))
    (λ i : fin (n+1), fin.cases polynomial.X (λ k, polynomial.C (X k)) i) :=
begin
  ext : 2,
  { simp only [fin_succ_equiv, option_equiv_left_apply, aeval_C, alg_equiv.coe_trans,
      ring_hom.coe_coe, coe_eval₂_hom, comp_app, rename_equiv_apply, eval₂_C, ring_hom.coe_comp,
      rename_C],
    refl },
  { intro i,
    refine fin.cases _ _ i;
    simp [fin_succ_equiv] }
end

@[simp] lemma fin_succ_equiv_apply (n : ℕ) (p : mv_polynomial (fin (n + 1)) R) :
  fin_succ_equiv R n p =
  eval₂_hom (polynomial.C.comp (C : R →+* mv_polynomial (fin n) R))
    (λ i : fin (n+1), fin.cases polynomial.X (λ k, polynomial.C (X k)) i) p :=
by { rw ← fin_succ_equiv_eq, refl }

lemma fin_succ_equiv_comp_C_eq_C {R : Type u} [comm_semiring R] (n : ℕ) :
  (↑(mv_polynomial.fin_succ_equiv R n).symm : polynomial (mv_polynomial (fin n) R) →+* _).comp
    ((polynomial.C).comp (mv_polynomial.C))
    = (mv_polynomial.C : R →+* mv_polynomial (fin n.succ) R) :=
begin
  refine ring_hom.ext (λ x, _),
  rw ring_hom.comp_apply,
  refine (mv_polynomial.fin_succ_equiv R n).injective
    (trans ((mv_polynomial.fin_succ_equiv R n).apply_symm_apply _) _),
  simp only [mv_polynomial.fin_succ_equiv_apply, mv_polynomial.eval₂_hom_C],
end

end

end equiv

end mv_polynomial


import tactic
import .lesson6

noncomputable theory
open_locale classical

open PreHilbertPlane
open Triangle
open HilbertPlane

variables {Ω : Type*} [HilbertPlane Ω]
variables {A B C D E F : Ω}

namespace Segment

def is_congruent (S T : Segment Ω) : Prop := S ≅ T

@[simp] theorem congruence_is_equiv : equivalence (@is_congruent Ω _) :=
begin
    fconstructor,
    {
        intro A,
        change A ≅ A,
        exact C22 A,
    },
    split,
    {
        intros A B hAB,
        apply C21 A B _ hAB (C22 A),
    },
    {
        intros A B C hAB hAC,
        apply C21 B _ _ _ hAC,
        {
            apply C21 A B _ hAB (C22 A),
        },
    },
end

end Segment


theorem fermats_last_theorem
  (n : ℕ)
  (n_gt_2 : n > 2)
  :
  ¬ (∃ x y z : ℕ, (x^n + y^n = z^n) ∧ (x ≠ 0) ∧ (y ≠ 0) ∧ (z ≠ 0))
:=
begin
  sorry,
end