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

! This file was ported from Lean 3 source module data.prod.lex
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.BoundedOrder

/-!
# Lexicographic order

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

This file defines the lexicographic relation for pairs of orders, partial orders and linear orders.

## Main declarations

* `prod.lex.<pre/partial_/linear_>order`: Instances lifting the orders on `α` and `β` to `α ×ₗ β`.

## Notation

* `α ×ₗ β`: `α × β` equipped with the lexicographic order

## See also

Related files are:
* `data.finset.colex`: Colexicographic order on finite sets.
* `data.list.lex`: Lexicographic order on lists.
* `data.pi.lex`: Lexicographic order on `Πₗ i, α i`.
* `data.psigma.order`: Lexicographic order on `Σ' i, α i`.
* `data.sigma.order`: Lexicographic order on `Σ i, α i`.
-/

variable {α β γ : Type _}

namespace Prod.Lex

-- mathport name: «expr ×ₗ »
notation:35 α " ×ₗ " β:34 => Lex (Prod α β)

unsafe instance [has_to_format α] [has_to_format β] : has_to_format (α ×ₗ β) :=
  prod.has_to_format

#print Prod.Lex.decidableEq /-
instance decidableEq (α β : Type _) [DecidableEq α] [DecidableEq β] : DecidableEq (α ×ₗ β) :=
  Prod.decidableEq
#align prod.lex.decidable_eq Prod.Lex.decidableEq
-/

#print Prod.Lex.inhabited /-
instance inhabited (α β : Type _) [Inhabited α] [Inhabited β] : Inhabited (α ×ₗ β) :=
  Prod.inhabited
#align prod.lex.inhabited Prod.Lex.inhabited
-/

#print Prod.Lex.instLE /-
/-- Dictionary / lexicographic ordering on pairs.  -/
instance instLE (α β : Type _) [LT α] [LE β] : LE (α ×ₗ β) where le := Prod.Lex (· < ·) (· ≤ ·)
#align prod.lex.has_le Prod.Lex.instLE
-/

#print Prod.Lex.instLT /-
instance instLT (α β : Type _) [LT α] [LT β] : LT (α ×ₗ β) where lt := Prod.Lex (· < ·) (· < ·)
#align prod.lex.has_lt Prod.Lex.instLT
-/

/- warning: prod.lex.le_iff -> Prod.Lex.le_iff is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : LT.{u1} α] [_inst_2 : LE.{u2} β] (a : Prod.{u1, u2} α β) (b : Prod.{u1, u2} α β), Iff (LE.le.{max u1 u2} (Lex.{max u1 u2} (Prod.{u1, u2} α β)) (Prod.Lex.instLE.{u1, u2} α β _inst_1 _inst_2) (coeFn.{succ (max u1 u2), succ (max u1 u2)} (Equiv.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (fun (_x : Equiv.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) => (Prod.{u1, u2} α β) -> (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (Equiv.hasCoeToFun.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (toLex.{max u1 u2} (Prod.{u1, u2} α β)) a) (coeFn.{succ (max u1 u2), succ (max u1 u2)} (Equiv.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (fun (_x : Equiv.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) => (Prod.{u1, u2} α β) -> (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (Equiv.hasCoeToFun.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (toLex.{max u1 u2} (Prod.{u1, u2} α β)) b)) (Or (LT.lt.{u1} α _inst_1 (Prod.fst.{u1, u2} α β a) (Prod.fst.{u1, u2} α β b)) (And (Eq.{succ u1} α (Prod.fst.{u1, u2} α β a) (Prod.fst.{u1, u2} α β b)) (LE.le.{u2} β _inst_2 (Prod.snd.{u1, u2} α β a) (Prod.snd.{u1, u2} α β b))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : LT.{u2} α] [_inst_2 : LE.{u1} β] (a : Prod.{u2, u1} α β) (b : Prod.{u2, u1} α β), Iff (LE.le.{max u2 u1} ((fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : Prod.{u2, u1} α β) => Lex.{max u2 u1} (Prod.{u2, u1} α β)) a) (Prod.Lex.instLE.{u2, u1} α β _inst_1 _inst_2) (FunLike.coe.{succ (max u2 u1), succ (max u2 u1), succ (max u2 u1)} (Equiv.{succ (max u2 u1), succ (max u2 u1)} (Prod.{u2, u1} α β) (Lex.{max u2 u1} (Prod.{u2, u1} α β))) (Prod.{u2, u1} α β) (fun (_x : Prod.{u2, u1} α β) => (fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : Prod.{u2, u1} α β) => Lex.{max u2 u1} (Prod.{u2, u1} α β)) _x) (Equiv.instFunLikeEquiv.{succ (max u2 u1), succ (max u2 u1)} (Prod.{u2, u1} α β) (Lex.{max u2 u1} (Prod.{u2, u1} α β))) (toLex.{max u2 u1} (Prod.{u2, u1} α β)) a) (FunLike.coe.{succ (max u2 u1), succ (max u2 u1), succ (max u2 u1)} (Equiv.{succ (max u2 u1), succ (max u2 u1)} (Prod.{u2, u1} α β) (Lex.{max u2 u1} (Prod.{u2, u1} α β))) (Prod.{u2, u1} α β) (fun (_x : Prod.{u2, u1} α β) => (fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : Prod.{u2, u1} α β) => Lex.{max u2 u1} (Prod.{u2, u1} α β)) _x) (Equiv.instFunLikeEquiv.{succ (max u2 u1), succ (max u2 u1)} (Prod.{u2, u1} α β) (Lex.{max u2 u1} (Prod.{u2, u1} α β))) (toLex.{max u2 u1} (Prod.{u2, u1} α β)) b)) (Or (LT.lt.{u2} α _inst_1 (Prod.fst.{u2, u1} α β a) (Prod.fst.{u2, u1} α β b)) (And (Eq.{succ u2} α (Prod.fst.{u2, u1} α β a) (Prod.fst.{u2, u1} α β b)) (LE.le.{u1} β _inst_2 (Prod.snd.{u2, u1} α β a) (Prod.snd.{u2, u1} α β b))))
Case conversion may be inaccurate. Consider using '#align prod.lex.le_iff Prod.Lex.le_iffₓ'. -/
theorem le_iff [LT α] [LE β] (a b : α × β) :
    toLex a ≤ toLex b ↔ a.1 < b.1 ∨ a.1 = b.1 ∧ a.2 ≤ b.2 :=
  Prod.lex_def (· < ·) (· ≤ ·)
#align prod.lex.le_iff Prod.Lex.le_iff

/- warning: prod.lex.lt_iff -> Prod.Lex.lt_iff is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : LT.{u1} α] [_inst_2 : LT.{u2} β] (a : Prod.{u1, u2} α β) (b : Prod.{u1, u2} α β), Iff (LT.lt.{max u1 u2} (Lex.{max u1 u2} (Prod.{u1, u2} α β)) (Prod.Lex.instLT.{u1, u2} α β _inst_1 _inst_2) (coeFn.{succ (max u1 u2), succ (max u1 u2)} (Equiv.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (fun (_x : Equiv.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) => (Prod.{u1, u2} α β) -> (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (Equiv.hasCoeToFun.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (toLex.{max u1 u2} (Prod.{u1, u2} α β)) a) (coeFn.{succ (max u1 u2), succ (max u1 u2)} (Equiv.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (fun (_x : Equiv.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) => (Prod.{u1, u2} α β) -> (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (Equiv.hasCoeToFun.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (toLex.{max u1 u2} (Prod.{u1, u2} α β)) b)) (Or (LT.lt.{u1} α _inst_1 (Prod.fst.{u1, u2} α β a) (Prod.fst.{u1, u2} α β b)) (And (Eq.{succ u1} α (Prod.fst.{u1, u2} α β a) (Prod.fst.{u1, u2} α β b)) (LT.lt.{u2} β _inst_2 (Prod.snd.{u1, u2} α β a) (Prod.snd.{u1, u2} α β b))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : LT.{u2} α] [_inst_2 : LT.{u1} β] (a : Prod.{u2, u1} α β) (b : Prod.{u2, u1} α β), Iff (LT.lt.{max u2 u1} ((fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : Prod.{u2, u1} α β) => Lex.{max u2 u1} (Prod.{u2, u1} α β)) a) (Prod.Lex.instLT.{u2, u1} α β _inst_1 _inst_2) (FunLike.coe.{succ (max u2 u1), succ (max u2 u1), succ (max u2 u1)} (Equiv.{succ (max u2 u1), succ (max u2 u1)} (Prod.{u2, u1} α β) (Lex.{max u2 u1} (Prod.{u2, u1} α β))) (Prod.{u2, u1} α β) (fun (_x : Prod.{u2, u1} α β) => (fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : Prod.{u2, u1} α β) => Lex.{max u2 u1} (Prod.{u2, u1} α β)) _x) (Equiv.instFunLikeEquiv.{succ (max u2 u1), succ (max u2 u1)} (Prod.{u2, u1} α β) (Lex.{max u2 u1} (Prod.{u2, u1} α β))) (toLex.{max u2 u1} (Prod.{u2, u1} α β)) a) (FunLike.coe.{succ (max u2 u1), succ (max u2 u1), succ (max u2 u1)} (Equiv.{succ (max u2 u1), succ (max u2 u1)} (Prod.{u2, u1} α β) (Lex.{max u2 u1} (Prod.{u2, u1} α β))) (Prod.{u2, u1} α β) (fun (_x : Prod.{u2, u1} α β) => (fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : Prod.{u2, u1} α β) => Lex.{max u2 u1} (Prod.{u2, u1} α β)) _x) (Equiv.instFunLikeEquiv.{succ (max u2 u1), succ (max u2 u1)} (Prod.{u2, u1} α β) (Lex.{max u2 u1} (Prod.{u2, u1} α β))) (toLex.{max u2 u1} (Prod.{u2, u1} α β)) b)) (Or (LT.lt.{u2} α _inst_1 (Prod.fst.{u2, u1} α β a) (Prod.fst.{u2, u1} α β b)) (And (Eq.{succ u2} α (Prod.fst.{u2, u1} α β a) (Prod.fst.{u2, u1} α β b)) (LT.lt.{u1} β _inst_2 (Prod.snd.{u2, u1} α β a) (Prod.snd.{u2, u1} α β b))))
Case conversion may be inaccurate. Consider using '#align prod.lex.lt_iff Prod.Lex.lt_iffₓ'. -/
theorem lt_iff [LT α] [LT β] (a b : α × β) :
    toLex a < toLex b ↔ a.1 < b.1 ∨ a.1 = b.1 ∧ a.2 < b.2 :=
  Prod.lex_def (· < ·) (· < ·)
#align prod.lex.lt_iff Prod.Lex.lt_iff

#print Prod.Lex.preorder /-
/-- Dictionary / lexicographic preorder for pairs. -/
instance preorder (α β : Type _) [Preorder α] [Preorder β] : Preorder (α ×ₗ β) :=
  { Prod.Lex.instLE α β,
    Prod.Lex.instLT α β with
    le_refl := refl_of <| Prod.Lex _ _
    le_trans := fun _ _ _ => trans_of <| Prod.Lex _ _
    lt_iff_le_not_le := fun x₁ x₂ =>
      match x₁, x₂ with
      | toLex (a₁, b₁), toLex (a₂, b₂) => by
        constructor
        · rintro (⟨_, _, hlt⟩ | ⟨_, hlt⟩)
          · constructor
            · left
              assumption
            · rintro ⟨⟩
              · apply lt_asymm hlt
                assumption
              · apply lt_irrefl _ hlt
          · constructor
            · right
              rw [lt_iff_le_not_le] at hlt
              exact hlt.1
            · rintro ⟨⟩
              · apply lt_irrefl a₁
                assumption
              · rw [lt_iff_le_not_le] at hlt
                apply hlt.2
                assumption
        · rintro ⟨⟨⟩, h₂r⟩
          · left
            assumption
          · right
            rw [lt_iff_le_not_le]
            constructor
            · assumption
            · intro h
              apply h₂r
              right
              exact h }
#align prod.lex.preorder Prod.Lex.preorder
-/

section Preorder

variable [PartialOrder α] [Preorder β]

/- warning: prod.lex.to_lex_mono -> Prod.Lex.toLex_mono is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : PartialOrder.{u1} α] [_inst_2 : Preorder.{u2} β], Monotone.{max u1 u2, max u1 u2} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β)) (Prod.preorder.{u1, u2} α β (PartialOrder.toPreorder.{u1} α _inst_1) _inst_2) (Prod.Lex.preorder.{u1, u2} α β (PartialOrder.toPreorder.{u1} α _inst_1) _inst_2) (coeFn.{succ (max u1 u2), succ (max u1 u2)} (Equiv.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (fun (_x : Equiv.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) => (Prod.{u1, u2} α β) -> (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (Equiv.hasCoeToFun.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (toLex.{max u1 u2} (Prod.{u1, u2} α β)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : PartialOrder.{u2} α] [_inst_2 : Preorder.{u1} β], Monotone.{max u2 u1, max u2 u1} (Prod.{u2, u1} α β) (Lex.{max u1 u2} (Prod.{u2, u1} α β)) (Prod.instPreorderProd.{u2, u1} α β (PartialOrder.toPreorder.{u2} α _inst_1) _inst_2) (Prod.Lex.preorder.{u2, u1} α β (PartialOrder.toPreorder.{u2} α _inst_1) _inst_2) (FunLike.coe.{succ (max u2 u1), succ (max u2 u1), succ (max u2 u1)} (Equiv.{succ (max u2 u1), succ (max u2 u1)} (Prod.{u2, u1} α β) (Lex.{max u2 u1} (Prod.{u2, u1} α β))) (Prod.{u2, u1} α β) (fun (_x : Prod.{u2, u1} α β) => (fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : Prod.{u2, u1} α β) => Lex.{max u2 u1} (Prod.{u2, u1} α β)) _x) (Equiv.instFunLikeEquiv.{succ (max u2 u1), succ (max u2 u1)} (Prod.{u2, u1} α β) (Lex.{max u2 u1} (Prod.{u2, u1} α β))) (toLex.{max u2 u1} (Prod.{u2, u1} α β)))
Case conversion may be inaccurate. Consider using '#align prod.lex.to_lex_mono Prod.Lex.toLex_monoₓ'. -/
theorem toLex_mono : Monotone (toLex : α × β → α ×ₗ β) :=
  by
  rintro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ ⟨ha, hb⟩
  obtain rfl | ha : a₁ = a₂ ∨ _ := ha.eq_or_lt
  · exact right _ hb
  · exact left _ _ ha
#align prod.lex.to_lex_mono Prod.Lex.toLex_mono

/- warning: prod.lex.to_lex_strict_mono -> Prod.Lex.toLex_strictMono is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : PartialOrder.{u1} α] [_inst_2 : Preorder.{u2} β], StrictMono.{max u1 u2, max u1 u2} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β)) (Prod.preorder.{u1, u2} α β (PartialOrder.toPreorder.{u1} α _inst_1) _inst_2) (Prod.Lex.preorder.{u1, u2} α β (PartialOrder.toPreorder.{u1} α _inst_1) _inst_2) (coeFn.{succ (max u1 u2), succ (max u1 u2)} (Equiv.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (fun (_x : Equiv.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) => (Prod.{u1, u2} α β) -> (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (Equiv.hasCoeToFun.{succ (max u1 u2), succ (max u1 u2)} (Prod.{u1, u2} α β) (Lex.{max u1 u2} (Prod.{u1, u2} α β))) (toLex.{max u1 u2} (Prod.{u1, u2} α β)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : PartialOrder.{u2} α] [_inst_2 : Preorder.{u1} β], StrictMono.{max u2 u1, max u2 u1} (Prod.{u2, u1} α β) (Lex.{max u1 u2} (Prod.{u2, u1} α β)) (Prod.instPreorderProd.{u2, u1} α β (PartialOrder.toPreorder.{u2} α _inst_1) _inst_2) (Prod.Lex.preorder.{u2, u1} α β (PartialOrder.toPreorder.{u2} α _inst_1) _inst_2) (FunLike.coe.{succ (max u2 u1), succ (max u2 u1), succ (max u2 u1)} (Equiv.{succ (max u2 u1), succ (max u2 u1)} (Prod.{u2, u1} α β) (Lex.{max u2 u1} (Prod.{u2, u1} α β))) (Prod.{u2, u1} α β) (fun (_x : Prod.{u2, u1} α β) => (fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : Prod.{u2, u1} α β) => Lex.{max u2 u1} (Prod.{u2, u1} α β)) _x) (Equiv.instFunLikeEquiv.{succ (max u2 u1), succ (max u2 u1)} (Prod.{u2, u1} α β) (Lex.{max u2 u1} (Prod.{u2, u1} α β))) (toLex.{max u2 u1} (Prod.{u2, u1} α β)))
Case conversion may be inaccurate. Consider using '#align prod.lex.to_lex_strict_mono Prod.Lex.toLex_strictMonoₓ'. -/
theorem toLex_strictMono : StrictMono (toLex : α × β → α ×ₗ β) :=
  by
  rintro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h
  obtain rfl | ha : a₁ = a₂ ∨ _ := h.le.1.eq_or_lt
  · exact right _ (Prod.mk_lt_mk_iff_right.1 h)
  · exact left _ _ ha
#align prod.lex.to_lex_strict_mono Prod.Lex.toLex_strictMono

end Preorder

#print Prod.Lex.partialOrder /-
/-- Dictionary / lexicographic partial_order for pairs. -/
instance partialOrder (α β : Type _) [PartialOrder α] [PartialOrder β] : PartialOrder (α ×ₗ β) :=
  { Prod.Lex.preorder α β with
    le_antisymm :=
      by
      haveI : IsStrictOrder α (· < ·) :=
        { irrefl := lt_irrefl
          trans := fun _ _ _ => lt_trans }
      haveI : IsAntisymm β (· ≤ ·) := ⟨fun _ _ => le_antisymm⟩
      exact @antisymm _ (Prod.Lex _ _) _ }
#align prod.lex.partial_order Prod.Lex.partialOrder
-/

#print Prod.Lex.linearOrder /-
/-- Dictionary / lexicographic linear_order for pairs. -/
instance linearOrder (α β : Type _) [LinearOrder α] [LinearOrder β] : LinearOrder (α ×ₗ β) :=
  { Prod.Lex.partialOrder α β with
    le_total := total_of (Prod.Lex _ _)
    decidableLe := Prod.Lex.decidable _ _
    decidableLt := Prod.Lex.decidable _ _
    DecidableEq := Lex.decidableEq _ _ }
#align prod.lex.linear_order Prod.Lex.linearOrder
-/

#print Prod.Lex.orderBot /-
instance orderBot [PartialOrder α] [Preorder β] [OrderBot α] [OrderBot β] : OrderBot (α ×ₗ β)
    where
  bot := toLex ⊥
  bot_le a := toLex_mono bot_le
#align prod.lex.order_bot Prod.Lex.orderBot
-/

#print Prod.Lex.orderTop /-
instance orderTop [PartialOrder α] [Preorder β] [OrderTop α] [OrderTop β] : OrderTop (α ×ₗ β)
    where
  top := toLex ⊤
  le_top a := toLex_mono le_top
#align prod.lex.order_top Prod.Lex.orderTop
-/

#print Prod.Lex.boundedOrder /-
instance boundedOrder [PartialOrder α] [Preorder β] [BoundedOrder α] [BoundedOrder β] :
    BoundedOrder (α ×ₗ β) :=
  { Lex.orderBot, Lex.orderTop with }
#align prod.lex.bounded_order Prod.Lex.boundedOrder
-/

instance [Preorder α] [Preorder β] [DenselyOrdered α] [DenselyOrdered β] :
    DenselyOrdered (α ×ₗ β) :=
  ⟨by
    rintro _ _ (@⟨a₁, b₁, a₂, b₂, h⟩ | @⟨a, b₁, b₂, h⟩)
    · obtain ⟨c, h₁, h₂⟩ := exists_between h
      exact ⟨(c, b₁), left _ _ h₁, left _ _ h₂⟩
    · obtain ⟨c, h₁, h₂⟩ := exists_between h
      exact ⟨(a, c), right _ h₁, right _ h₂⟩⟩

#print Prod.Lex.noMaxOrder_of_left /-
instance noMaxOrder_of_left [Preorder α] [Preorder β] [NoMaxOrder α] : NoMaxOrder (α ×ₗ β) :=
  ⟨by
    rintro ⟨a, b⟩
    obtain ⟨c, h⟩ := exists_gt a
    exact ⟨⟨c, b⟩, left _ _ h⟩⟩
#align prod.lex.no_max_order_of_left Prod.Lex.noMaxOrder_of_left
-/

#print Prod.Lex.noMinOrder_of_left /-
instance noMinOrder_of_left [Preorder α] [Preorder β] [NoMinOrder α] : NoMinOrder (α ×ₗ β) :=
  ⟨by
    rintro ⟨a, b⟩
    obtain ⟨c, h⟩ := exists_lt a
    exact ⟨⟨c, b⟩, left _ _ h⟩⟩
#align prod.lex.no_min_order_of_left Prod.Lex.noMinOrder_of_left
-/

#print Prod.Lex.noMaxOrder_of_right /-
instance noMaxOrder_of_right [Preorder α] [Preorder β] [NoMaxOrder β] : NoMaxOrder (α ×ₗ β) :=
  ⟨by
    rintro ⟨a, b⟩
    obtain ⟨c, h⟩ := exists_gt b
    exact ⟨⟨a, c⟩, right _ h⟩⟩
#align prod.lex.no_max_order_of_right Prod.Lex.noMaxOrder_of_right
-/

#print Prod.Lex.noMinOrder_of_right /-
instance noMinOrder_of_right [Preorder α] [Preorder β] [NoMinOrder β] : NoMinOrder (α ×ₗ β) :=
  ⟨by
    rintro ⟨a, b⟩
    obtain ⟨c, h⟩ := exists_lt b
    exact ⟨⟨a, c⟩, right _ h⟩⟩
#align prod.lex.no_min_order_of_right Prod.Lex.noMinOrder_of_right
-/

end Prod.Lex


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.Gamma_Spec_adjunction
import algebraic_geometry.open_immersion
import category_theory.limits.opposites

/-!
# Affine schemes

We define the category of `AffineScheme`s as the essential image of `Spec`.
We also define predicates about affine schemes and affine open sets.

## Main definitions

* `algebraic_geometry.AffineScheme`: The category of affine schemes.
* `algebraic_geometry.is_affine`: A scheme is affine if the canonical map `X ⟶ Spec Γ(X)` is an
  isomorphism.
* `algebraic_geometry.Scheme.iso_Spec`: The canonical isomorphism `X ≅ Spec Γ(X)` for an affine
  scheme.
* `algebraic_geometry.AffineScheme.equiv_CommRing`: The equivalence of categories
  `AffineScheme ≌ CommRingᵒᵖ` given by `AffineScheme.Spec : CommRingᵒᵖ ⥤ AffineScheme` and
  `AffineScheme.Γ : AffineSchemeᵒᵖ ⥤ CommRing`.
* `algebraic_geometry.is_affine_open`: An open subset of a scheme is affine if the open subscheme is
  affine.
* `algebraic_geometry.is_affine_open.from_Spec`: The immersion `Spec 𝒪ₓ(U) ⟶ X` for an affine `U`.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

namespace algebraic_geometry

/-- The category of affine schemes -/
def AffineScheme := Scheme.Spec.ess_image

/-- A Scheme is affine if the canonical map `X ⟶ Spec Γ(X)` is an isomorphism. -/
class is_affine (X : Scheme) : Prop :=
(affine : is_iso (Γ_Spec.adjunction.unit.app X))

attribute [instance] is_affine.affine

/-- The canonical isomorphism `X ≅ Spec Γ(X)` for an affine scheme. -/
def Scheme.iso_Spec (X : Scheme) [is_affine X] :
  X ≅ Scheme.Spec.obj (op $ Scheme.Γ.obj $ op X) :=
as_iso (Γ_Spec.adjunction.unit.app X)

lemma mem_AffineScheme (X : Scheme) : X ∈ AffineScheme ↔ is_affine X :=
⟨λ h, ⟨functor.ess_image.unit_is_iso h⟩, λ h, @@mem_ess_image_of_unit_is_iso _ _ _ X h.1⟩

instance is_affine_AffineScheme (X : AffineScheme.{u}) : is_affine (X : Scheme.{u}) :=
(mem_AffineScheme _).mp X.prop

instance Spec_is_affine (R : CommRingᵒᵖ) : is_affine (Scheme.Spec.obj R) :=
(mem_AffineScheme _).mp (Scheme.Spec.obj_mem_ess_image R)

lemma is_affine_of_iso {X Y : Scheme} (f : X ⟶ Y) [is_iso f] [h : is_affine Y] :
  is_affine X :=
by { rw [← mem_AffineScheme] at h ⊢, exact functor.ess_image.of_iso (as_iso f).symm h }

namespace AffineScheme

/-- The `Spec` functor into the category of affine schemes. -/
@[derive [full, faithful, ess_surj], simps]
def Spec : CommRingᵒᵖ ⥤ AffineScheme := Scheme.Spec.to_ess_image

/-- The forgetful functor `AffineScheme ⥤ Scheme`. -/
@[derive [full, faithful], simps]
def forget_to_Scheme : AffineScheme ⥤ Scheme := Scheme.Spec.ess_image_inclusion

/-- The global section functor of an affine scheme. -/
def Γ : AffineSchemeᵒᵖ ⥤ CommRing := forget_to_Scheme.op ⋙ Scheme.Γ

/-- The category of affine schemes is equivalent to the category of commutative rings. -/
def equiv_CommRing : AffineScheme ≌ CommRingᵒᵖ :=
equiv_ess_image_of_reflective.symm

instance Γ_is_equiv : is_equivalence Γ.{u} :=
begin
  haveI : is_equivalence Γ.{u}.right_op.op := is_equivalence.of_equivalence equiv_CommRing.op,
  exact (functor.is_equivalence_trans Γ.{u}.right_op.op (op_op_equivalence _).functor : _),
end

instance : has_colimits AffineScheme.{u} :=
begin
  haveI := adjunction.has_limits_of_equivalence.{u} Γ.{u},
  haveI : has_colimits AffineScheme.{u} ᵒᵖᵒᵖ := has_colimits_op_of_has_limits,
  exactI adjunction.has_colimits_of_equivalence.{u} (op_op_equivalence AffineScheme.{u}).inverse
end

instance : has_limits AffineScheme.{u} :=
begin
  haveI := adjunction.has_colimits_of_equivalence Γ.{u},
  haveI : has_limits AffineScheme.{u} ᵒᵖᵒᵖ := limits.has_limits_op_of_has_colimits,
  exactI adjunction.has_limits_of_equivalence (op_op_equivalence AffineScheme.{u}).inverse
end

end AffineScheme

/-- An open subset of a scheme is affine if the open subscheme is affine. -/
def is_affine_open {X : Scheme} (U : opens X.carrier) : Prop :=
is_affine (X.restrict U.open_embedding)

lemma range_is_affine_open_of_open_immersion {X Y : Scheme} [is_affine X] (f : X ⟶ Y)
  [H : is_open_immersion f] : is_affine_open ⟨set.range f.1.base, H.base_open.open_range⟩ :=
begin
  refine is_affine_of_iso (is_open_immersion.iso_of_range_eq f (Y.of_restrict _) _).inv,
  exact subtype.range_coe.symm,
  apply_instance
end

lemma top_is_affine_open (X : Scheme) [is_affine X] : is_affine_open (⊤ : opens X.carrier) :=
begin
  convert range_is_affine_open_of_open_immersion (𝟙 X),
  ext1,
  exact set.range_id.symm
end

instance Scheme.affine_basis_cover_is_affine (X : Scheme) (i : X.affine_basis_cover.J) :
  is_affine (X.affine_basis_cover.obj i) :=
algebraic_geometry.Spec_is_affine _

lemma is_basis_affine_open (X : Scheme) :
  opens.is_basis { U : opens X.carrier | is_affine_open U } :=
begin
  rw opens.is_basis_iff_nbhd,
  rintros U x (hU : x ∈ (U : set X.carrier)),
  obtain ⟨S, hS, hxS, hSU⟩ := X.affine_basis_cover_is_basis.exists_subset_of_mem_open hU U.prop,
  refine ⟨⟨S, X.affine_basis_cover_is_basis.is_open hS⟩, _, hxS, hSU⟩,
  rcases hS with ⟨i, rfl⟩,
  exact range_is_affine_open_of_open_immersion _,
end

/-- The open immersion `Spec 𝒪ₓ(U) ⟶ X` for an affine `U`. -/
def is_affine_open.from_Spec {X : Scheme} {U : opens X.carrier} (hU : is_affine_open U) :
  Scheme.Spec.obj (op $ X.presheaf.obj $ op U) ⟶ X :=
begin
  haveI : is_affine (X.restrict U.open_embedding) := hU,
  have : U.open_embedding.is_open_map.functor.obj ⊤ = U,
  { ext1, exact set.image_univ.trans subtype.range_coe },
  exact Scheme.Spec.map (X.presheaf.map (eq_to_hom this.symm).op).op ≫
    (X.restrict U.open_embedding).iso_Spec.inv ≫ X.of_restrict _
end

instance is_affine_open.is_open_immersion_from_Spec {X : Scheme} {U : opens X.carrier}
  (hU : is_affine_open U) :
  is_open_immersion hU.from_Spec :=
by { delta is_affine_open.from_Spec, apply_instance }

lemma is_affine_open.from_Spec_range {X : Scheme} {U : opens X.carrier} (hU : is_affine_open U) :
  set.range hU.from_Spec.1.base = (U : set X.carrier) :=
begin
  delta is_affine_open.from_Spec,
  erw [← category.assoc, Scheme.comp_val_base],
  rw [coe_comp, set.range_comp, set.range_iff_surjective.mpr, set.image_univ],
  exact subtype.range_coe,
  rw ← Top.epi_iff_surjective,
  apply_instance
end

lemma is_affine_open.from_Spec_image_top {X : Scheme} {U : opens X.carrier}
  (hU : is_affine_open U) :
  hU.is_open_immersion_from_Spec.base_open.is_open_map.functor.obj ⊤ = U :=
by { ext1, exact set.image_univ.trans hU.from_Spec_range }

lemma is_affine_open.is_compact {X : Scheme} {U : opens X.carrier} (hU : is_affine_open U) :
  is_compact (U : set X.carrier) :=
begin
  convert @is_compact.image _ _ _ _ set.univ hU.from_Spec.1.base
    prime_spectrum.compact_space.1 (by continuity),
  convert hU.from_Spec_range.symm,
  exact set.image_univ
end

instance Scheme.quasi_compact_of_affine (X : Scheme) [is_affine X] : compact_space X.carrier :=
⟨(top_is_affine_open X).is_compact⟩

lemma is_affine_open.from_Spec_base_preimage
  {X : Scheme} {U : opens X.carrier} (hU : is_affine_open U) :
    (opens.map hU.from_Spec.val.base).obj U = ⊤ :=
begin
  ext1,
  change hU.from_Spec.1.base ⁻¹' (U : set X.carrier) = set.univ,
  rw [← hU.from_Spec_range, ← set.image_univ],
  exact set.preimage_image_eq _ PresheafedSpace.is_open_immersion.base_open.inj
end

lemma Scheme.Spec_map_presheaf_map_eq_to_hom {X : Scheme} {U V : opens X.carrier} (h : U = V) (W) :
  (Scheme.Spec.map (X.presheaf.map (eq_to_hom h).op).op).val.c.app W =
    eq_to_hom (by { cases h, dsimp, induction W using opposite.rec, congr, ext1, simpa }) :=
begin
  have : Scheme.Spec.map (X.presheaf.map (𝟙 (op U))).op = 𝟙 _,
  { rw [X.presheaf.map_id, op_id, Scheme.Spec.map_id]  },
  cases h,
  refine (Scheme.congr_app this _).trans _,
  erw category.id_comp,
  simpa
end

lemma is_affine_open.Spec_Γ_identity_hom_app_from_Spec {X : Scheme} {U : opens X.carrier}
  (hU : is_affine_open U) :
  (Spec_Γ_identity.hom.app (X.presheaf.obj $ op U)) ≫ hU.from_Spec.1.c.app (op U) =
    (Scheme.Spec.obj _).presheaf.map (eq_to_hom hU.from_Spec_base_preimage).op :=
begin
  haveI : is_affine _ := hU,
  have e₁ :=
    Spec_Γ_identity.hom.naturality (X.presheaf.map (eq_to_hom U.open_embedding_obj_top).op),
  rw ← is_iso.comp_inv_eq at e₁,
  have e₂ := Γ_Spec.adjunction_unit_app_app_top (X.restrict U.open_embedding),
  erw ← e₂ at e₁,
  simp only [functor.id_map, quiver.hom.unop_op, functor.comp_map, ← functor.map_inv, ← op_inv,
    LocallyRingedSpace.Γ_map, category.assoc, functor.right_op_map, inv_eq_to_hom] at e₁,
  delta is_affine_open.from_Spec Scheme.iso_Spec,
  rw [Scheme.comp_val_c_app, Scheme.comp_val_c_app, ← e₁],
  simp_rw category.assoc,
  erw ← X.presheaf.map_comp_assoc,
  rw ← op_comp,
  have e₃ : U.open_embedding.is_open_map.adjunction.counit.app U ≫
    eq_to_hom U.open_embedding_obj_top.symm =
    U.open_embedding.is_open_map.functor.map (eq_to_hom U.inclusion_map_eq_top) :=
    subsingleton.elim _ _,
  have e₄ : X.presheaf.map _ ≫ _ = _ :=
    (as_iso (Γ_Spec.adjunction.unit.app (X.restrict U.open_embedding)))
    .inv.1.c.naturality_assoc (eq_to_hom U.inclusion_map_eq_top).op _,
  erw [e₃, e₄, ← Scheme.comp_val_c_app_assoc, iso.inv_hom_id],
  simp only [eq_to_hom_map, eq_to_hom_op, Scheme.Spec_map_presheaf_map_eq_to_hom],
  erw [Scheme.Spec_map_presheaf_map_eq_to_hom, category.id_comp],
  simpa only [eq_to_hom_trans]
end

@[elementwise]
lemma is_affine_open.from_Spec_app_eq {X : Scheme} {U : opens X.carrier}
  (hU : is_affine_open U) :
  hU.from_Spec.1.c.app (op U) = Spec_Γ_identity.inv.app (X.presheaf.obj $ op U) ≫
    (Scheme.Spec.obj _).presheaf.map (eq_to_hom hU.from_Spec_base_preimage).op :=
by rw [← hU.Spec_Γ_identity_hom_app_from_Spec, iso.inv_hom_id_app_assoc]

lemma is_affine_open.basic_open_is_affine {X : Scheme} {U : opens X.carrier}
  (hU : is_affine_open U) (f : X.presheaf.obj (op U)) : is_affine_open (X.basic_open f) :=
begin
  convert range_is_affine_open_of_open_immersion (Scheme.Spec.map (CommRing.of_hom
    (algebra_map (X.presheaf.obj (op U)) (localization.away f))).op ≫ hU.from_Spec),
  ext1,
  have : hU.from_Spec.val.base '' (hU.from_Spec.val.base ⁻¹' (X.basic_open f : set X.carrier)) =
    (X.basic_open f : set X.carrier),
  { rw [set.image_preimage_eq_inter_range, set.inter_eq_left_iff_subset, hU.from_Spec_range],
    exact Scheme.basic_open_subset _ _ },
  rw [subtype.coe_mk, Scheme.comp_val_base, ← this, coe_comp, set.range_comp],
  congr' 1,
  refine (congr_arg coe $ Scheme.preimage_basic_open hU.from_Spec f).trans _,
  refine eq.trans _ (prime_spectrum.localization_away_comap_range (localization.away f) f).symm,
  congr' 1,
  have : (opens.map hU.from_Spec.val.base).obj U = ⊤,
  { ext1,
    change hU.from_Spec.1.base ⁻¹' (U : set X.carrier) = set.univ,
    rw [← hU.from_Spec_range, ← set.image_univ],
    exact set.preimage_image_eq _ PresheafedSpace.is_open_immersion.base_open.inj },
  refine eq.trans _ (basic_open_eq_of_affine f),
  have lm : ∀ s, (opens.map hU.from_Spec.val.base).obj U ⊓ s = s := λ s, this.symm ▸ top_inf_eq,
  refine eq.trans _ (lm _),
  refine eq.trans _
    ((Scheme.Spec.obj $ op $ X.presheaf.obj $ op U).basic_open_res _ (eq_to_hom this).op),
  rw ← comp_apply,
  congr' 2,
  rw iso.eq_inv_comp,
  erw hU.Spec_Γ_identity_hom_app_from_Spec,
end

lemma Scheme.map_prime_spectrum_basic_open_of_affine (X : Scheme) [is_affine X]
  (f : Scheme.Γ.obj (op X)) :
  (opens.map X.iso_Spec.hom.1.base).obj (prime_spectrum.basic_open f) = X.basic_open f :=
begin
  rw ← basic_open_eq_of_affine,
  transitivity (opens.map X.iso_Spec.hom.1.base).obj ((Scheme.Spec.obj
    (op (Scheme.Γ.obj (op X)))).basic_open ((inv (X.iso_Spec.hom.1.c.app
      (op ((opens.map (inv X.iso_Spec.hom).val.base).obj ⊤)))) ((X.presheaf.map (eq_to_hom _)) f))),
  congr,
  { rw [← is_iso.inv_eq_inv, is_iso.inv_inv, is_iso.iso.inv_inv, nat_iso.app_hom],
    erw ← Γ_Spec.adjunction_unit_app_app_top,
    refl },
  { rw eq_to_hom_map, refl },
  { dsimp, congr },
  { refine (Scheme.preimage_basic_open _ _).trans _,
    rw [is_iso.inv_hom_id_apply, Scheme.basic_open_res_eq] }
end

lemma is_basis_basic_open (X : Scheme) [is_affine X] :
  opens.is_basis (set.range (X.basic_open : X.presheaf.obj (op ⊤) → opens X.carrier)) :=
begin
  delta opens.is_basis,
  convert prime_spectrum.is_basis_basic_opens.inducing
    (Top.homeo_of_iso (Scheme.forget_to_Top.map_iso X.iso_Spec)).inducing using 1,
  ext,
  simp only [set.mem_image, exists_exists_eq_and],
  split,
  { rintro ⟨_, ⟨x, rfl⟩, rfl⟩,
    refine ⟨_, ⟨_, ⟨x, rfl⟩, rfl⟩, _⟩,
    exact congr_arg subtype.val (X.map_prime_spectrum_basic_open_of_affine x) },
  { rintro ⟨_, ⟨_, ⟨x, rfl⟩, rfl⟩, rfl⟩,
    refine ⟨_, ⟨x, rfl⟩, _⟩,
    exact congr_arg subtype.val (X.map_prime_spectrum_basic_open_of_affine x).symm }
end

/-- The prime ideal of `𝒪ₓ(U)` corresponding to a point `x : U`. -/
noncomputable
def is_affine_open.prime_ideal_of {X : Scheme} {U : opens X.carrier}
  (hU : is_affine_open U) (x : U) :
  prime_spectrum (X.presheaf.obj $ op U) :=
((Scheme.Spec.map (X.presheaf.map (eq_to_hom $
  show U.open_embedding.is_open_map.functor.obj ⊤ = U, from
    opens.ext (set.image_univ.trans subtype.range_coe)).op).op).1.base
  ((@@Scheme.iso_Spec (X.restrict U.open_embedding) hU).hom.1.base x))

lemma is_affine_open.from_Spec_prime_ideal_of {X : Scheme} {U : opens X.carrier}
  (hU : is_affine_open U) (x : U) :
  hU.from_Spec.val.base (hU.prime_ideal_of x) = x.1 :=
begin
  dsimp only [is_affine_open.from_Spec, subtype.coe_mk],
  erw [← Scheme.comp_val_base_apply, ← Scheme.comp_val_base_apply],
  simpa only [← functor.map_comp_assoc, ← functor.map_comp, ← op_comp, eq_to_hom_trans, op_id,
    eq_to_hom_refl, category_theory.functor.map_id, category.id_comp, iso.hom_inv_id_assoc]
end

lemma is_affine_open.is_localization_stalk_aux {X : Scheme} (U : opens X.carrier)
  [is_affine (X.restrict U.open_embedding)] :
  (inv (Γ_Spec.adjunction.unit.app (X.restrict U.open_embedding))).1.c.app
    (op ((opens.map U.inclusion).obj U)) =
      X.presheaf.map (eq_to_hom $ by rw opens.inclusion_map_eq_top :
        U.open_embedding.is_open_map.functor.obj ⊤ ⟶
          (U.open_embedding.is_open_map.functor.obj ((opens.map U.inclusion).obj U))).op ≫
      to_Spec_Γ (X.presheaf.obj $ op (U.open_embedding.is_open_map.functor.obj ⊤)) ≫
      (Scheme.Spec.obj $ op $ X.presheaf.obj $ _).presheaf.map
        (eq_to_hom (by { rw [opens.inclusion_map_eq_top], refl }) : unop _ ⟶ ⊤).op :=
begin
  have e : (opens.map (inv (Γ_Spec.adjunction.unit.app (X.restrict U.open_embedding))).1.base).obj
    ((opens.map U.inclusion).obj U) = ⊤,
  by { rw [opens.inclusion_map_eq_top], refl },
  rw [Scheme.inv_val_c_app, is_iso.comp_inv_eq, Scheme.app_eq _ e,
    Γ_Spec.adjunction_unit_app_app_top],
  simp only [category.assoc, eq_to_hom_op],
  erw ← functor.map_comp_assoc,
  rw [eq_to_hom_trans, eq_to_hom_refl, category_theory.functor.map_id,
    category.id_comp],
  erw Spec_Γ_identity.inv_hom_id_app_assoc,
  simp only [eq_to_hom_map, eq_to_hom_trans],
end

lemma is_affine_open.is_localization_stalk {X : Scheme} {U : opens X.carrier}
  (hU : is_affine_open U) (x : U) :
  is_localization.at_prime (X.presheaf.stalk x) (hU.prime_ideal_of x).as_ideal :=
begin
  haveI : is_affine _ := hU,
  haveI : nonempty U := ⟨x⟩,
  rcases x with ⟨x, hx⟩,
  let y := hU.prime_ideal_of ⟨x, hx⟩,
  have : hU.from_Spec.val.base y = x := hU.from_Spec_prime_ideal_of ⟨x, hx⟩,
  change is_localization y.as_ideal.prime_compl _,
  clear_value y,
  subst this,
  apply (is_localization.is_localization_iff_of_ring_equiv _
    (as_iso $ PresheafedSpace.stalk_map hU.from_Spec.1 y).CommRing_iso_to_ring_equiv).mpr,
  convert structure_sheaf.is_localization.to_stalk _ _ using 1,
  delta structure_sheaf.stalk_algebra,
  congr' 1,
  rw ring_hom.algebra_map_to_algebra,
  refine (PresheafedSpace.stalk_map_germ hU.from_Spec.1 _ ⟨_, _⟩).trans _,
  delta is_affine_open.from_Spec Scheme.iso_Spec structure_sheaf.to_stalk,
  simp only [Scheme.comp_val_c_app, category.assoc],
  dsimp only [functor.op, as_iso_inv, unop_op],
  erw is_affine_open.is_localization_stalk_aux,
  simp only [category.assoc],
  conv_lhs { rw ← category.assoc },
  erw [← X.presheaf.map_comp, Spec_Γ_naturality_assoc],
  congr' 1,
  simp only [← category.assoc],
  transitivity _ ≫ (structure_sheaf (X.presheaf.obj $ op U)).1.germ ⟨_, _⟩,
  { refl },
  convert ((structure_sheaf (X.presheaf.obj $ op U)).1.germ_res (hom_of_le le_top) ⟨_, _⟩) using 2,
  rw category.assoc,
  erw nat_trans.naturality,
  rw [← LocallyRingedSpace.Γ_map_op, ← LocallyRingedSpace.Γ.map_comp_assoc, ← op_comp],
  erw ← Scheme.Spec.map_comp,
  rw [← op_comp, ← X.presheaf.map_comp],
  transitivity LocallyRingedSpace.Γ.map (quiver.hom.op $ Scheme.Spec.map
    (X.presheaf.map (𝟙 (op U))).op) ≫ _,
  { congr },
  simp only [category_theory.functor.map_id, op_id],
  erw category_theory.functor.map_id,
  rw category.id_comp,
  refl
end

end algebraic_geometry


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

import algebra.group_power.identities
import data.zmod.basic
import field_theory.finite.basic
import data.int.parity
import data.fintype.card

/-!
# Lagrange's four square theorem

The main result in this file is `sum_four_squares`,
a proof that every natural number is the sum of four square numbers.

## Implementation Notes

The proof used is close to Lagrange's original proof.
-/

open finset polynomial finite_field equiv
open_locale big_operators

namespace int

lemma sq_add_sq_of_two_mul_sq_add_sq {m x y : ℤ} (h : 2 * m = x^2 + y^2) :
  m = ((x - y) / 2) ^ 2 + ((x + y) / 2) ^ 2 :=
have even (x^2 + y^2), by simp [h.symm, even_mul],
have hxaddy : even (x + y), by simpa [sq] with parity_simps,
have hxsuby : even (x - y), by simpa [sq] with parity_simps,
(mul_right_inj' (show (2*2 : ℤ) ≠ 0, from dec_trivial)).1 $
calc 2 * 2 * m = (x - y)^2 + (x + y)^2 : by rw [mul_assoc, h]; ring
... = (2 * ((x - y) / 2))^2 + (2 * ((x + y) / 2))^2 :
  by rw [int.mul_div_cancel' hxsuby, int.mul_div_cancel' hxaddy]
... = 2 * 2 * (((x - y) / 2) ^ 2 + ((x + y) / 2) ^ 2) :
  by simp [mul_add, pow_succ, mul_comm, mul_assoc, mul_left_comm]

lemma exists_sq_add_sq_add_one_eq_k (p : ℕ) [hp : fact p.prime] :
  ∃ (a b : ℤ) (k : ℕ), a^2 + b^2 + 1 = k * p ∧ k < p :=
hp.1.eq_two_or_odd.elim (λ hp2, hp2.symm ▸ ⟨1, 0, 1, rfl, dec_trivial⟩) $ λ hp1,
let ⟨a, b, hab⟩ := zmod.sq_add_sq p (-1) in
have hab' : (p : ℤ) ∣ a.val_min_abs ^ 2 + b.val_min_abs ^ 2 + 1,
  from (char_p.int_cast_eq_zero_iff (zmod p) p _).1 $ by simpa [eq_neg_iff_add_eq_zero] using hab,
let ⟨k, hk⟩ := hab' in
have hk0 : 0 ≤ k, from nonneg_of_mul_nonneg_left
  (by rw ← hk; exact (add_nonneg (add_nonneg (sq_nonneg _) (sq_nonneg _)) zero_le_one))
  (int.coe_nat_pos.2 hp.1.pos),
⟨a.val_min_abs, b.val_min_abs, k.nat_abs,
    by rw [hk, int.nat_abs_of_nonneg hk0, mul_comm],
  lt_of_mul_lt_mul_left
    (calc p * k.nat_abs = a.val_min_abs.nat_abs ^ 2 + b.val_min_abs.nat_abs ^ 2 + 1 :
        by rw [← int.coe_nat_inj', int.coe_nat_add, int.coe_nat_add, int.coe_nat_pow,
          int.coe_nat_pow, int.nat_abs_sq, int.nat_abs_sq,
          int.coe_nat_one, hk, int.coe_nat_mul, int.nat_abs_of_nonneg hk0]
      ... ≤ (p / 2) ^ 2 + (p / 2)^2 + 1 :
        add_le_add
          (add_le_add
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _)
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _))
          (le_refl _)
      ... < (p / 2) ^ 2 + (p / 2)^ 2 + (p % 2)^2 + ((2 * (p / 2)^2 + (4 * (p / 2) * (p % 2)))) :
        by rw [hp1, one_pow, mul_one];
          exact (lt_add_iff_pos_right _).2
            (add_pos_of_nonneg_of_pos (nat.zero_le _) (mul_pos dec_trivial
              (nat.div_pos hp.1.two_le dec_trivial)))
      ... = p * p : by { conv_rhs { rw [← nat.mod_add_div p 2] }, ring })
    (show 0 ≤ p, from nat.zero_le _)⟩

end int

namespace nat

open int

open_locale classical

private lemma sum_four_squares_of_two_mul_sum_four_squares {m a b c d : ℤ}
  (h : a^2 + b^2 + c^2 + d^2 = 2 * m) : ∃ w x y z : ℤ, w^2 + x^2 + y^2 + z^2 = m :=
have ∀ f : fin 4 → zmod 2, (f 0)^2 + (f 1)^2 + (f 2)^2 + (f 3)^2 = 0 →
    ∃ i : (fin 4), (f i)^2 + f (swap i 0 1)^2 = 0 ∧ f (swap i 0 2)^2 + f (swap i 0 3)^2 = 0,
  from dec_trivial,
let f : fin 4 → ℤ :=
  vector.nth (a ::ᵥ b ::ᵥ c ::ᵥ d ::ᵥ vector.nil) in
let ⟨i, hσ⟩ := this (coe ∘ f) (by rw [← @zero_mul (zmod 2) _ m,
  ← show ((2 : ℤ) : zmod 2) = 0, from rfl,
  ← int.cast_mul, ← h]; simp only [int.cast_add, int.cast_pow]; refl) in
let σ := swap i 0 in
have h01 : 2 ∣ f (σ 0) ^ 2 + f (σ 1) ^ 2,
  from (char_p.int_cast_eq_zero_iff (zmod 2) 2 _).1 $ by simpa [σ] using hσ.1,
have h23 : 2 ∣ f (σ 2) ^ 2 + f (σ 3) ^ 2,
  from (char_p.int_cast_eq_zero_iff (zmod 2) 2 _).1 $ by simpa using hσ.2,
let ⟨x, hx⟩ := h01 in let ⟨y, hy⟩ := h23 in
⟨(f (σ 0) - f (σ 1)) / 2, (f (σ 0) + f (σ 1)) / 2, (f (σ 2) - f (σ 3)) / 2, (f (σ 2) + f (σ 3)) / 2,
  begin
    rw [← int.sq_add_sq_of_two_mul_sq_add_sq hx.symm, add_assoc,
      ← int.sq_add_sq_of_two_mul_sq_add_sq hy.symm,
      ← mul_right_inj' (show (2 : ℤ) ≠ 0, from dec_trivial), ← h, mul_add, ← hx, ← hy],
    have : ∑ x, f (σ x)^2 = ∑ x, f x^2,
    { conv_rhs { rw ← σ.sum_comp } },
    have fin4univ : (univ : finset (fin 4)).1 = 0 ::ₘ 1 ::ₘ 2 ::ₘ 3 ::ₘ 0, from dec_trivial,
    simpa [finset.sum_eq_multiset_sum, fin4univ, multiset.sum_cons, f, add_assoc]
  end⟩

private lemma prime_sum_four_squares (p : ℕ) [hp : _root_.fact p.prime] :
  ∃ a b c d : ℤ, a^2 + b^2 + c^2 + d^2 = p :=
have hm : ∃ m < p, 0 < m ∧ ∃ a b c d : ℤ, a^2 + b^2 + c^2 + d^2 = m * p,
  from let ⟨a, b, k, hk⟩ := exists_sq_add_sq_add_one_eq_k p in
  ⟨k, hk.2, nat.pos_of_ne_zero $
    (λ hk0, by { rw [hk0, int.coe_nat_zero, zero_mul] at hk,
      exact ne_of_gt (show a^2 + b^2 + 1 > 0, from add_pos_of_nonneg_of_pos
        (add_nonneg (sq_nonneg _) (sq_nonneg _)) zero_lt_one) hk.1 }),
    a, b, 1, 0, by simpa [sq] using hk.1⟩,
let m := nat.find hm in
let ⟨a, b, c, d, (habcd : a^2 + b^2 + c^2 + d^2 = m * p)⟩ := (nat.find_spec hm).snd.2 in
by haveI hm0 : _root_.fact (0 < m) := ⟨(nat.find_spec hm).snd.1⟩; exact
have hmp : m < p, from (nat.find_spec hm).fst,
m.mod_two_eq_zero_or_one.elim
  (λ hm2 : m % 2 = 0,
    let ⟨k, hk⟩ := (nat.dvd_iff_mod_eq_zero _ _).2 hm2 in
    have hk0 : 0 < k, from nat.pos_of_ne_zero $ λ _, by { simp [*, lt_irrefl] at * },
    have hkm : k < m, { rw [hk, two_mul], exact (lt_add_iff_pos_left _).2 hk0 },
    false.elim $ nat.find_min hm hkm ⟨lt_trans hkm hmp, hk0,
      sum_four_squares_of_two_mul_sum_four_squares
        (show a^2 + b^2 + c^2 + d^2 = 2 * (k * p),
          by { rw [habcd, hk, int.coe_nat_mul, mul_assoc], simp })⟩)
  (λ hm2 : m % 2 = 1,
    if hm1 : m = 1 then ⟨a, b, c, d, by simp only [hm1, habcd, int.coe_nat_one, one_mul]⟩
    else
      let w := (a : zmod m).val_min_abs, x := (b : zmod m).val_min_abs,
          y := (c : zmod m).val_min_abs, z := (d : zmod m).val_min_abs in
      have hnat_abs : w^2 + x^2 + y^2 + z^2 =
          (w.nat_abs^2 + x.nat_abs^2 + y.nat_abs ^2 + z.nat_abs ^ 2 : ℕ),
        by simp [sq],
      have hwxyzlt : w^2 + x^2 + y^2 + z^2 < m^2,
        from calc w^2 + x^2 + y^2 + z^2
            = (w.nat_abs^2 + x.nat_abs^2 + y.nat_abs ^2 + z.nat_abs ^ 2 : ℕ) : hnat_abs
        ... ≤ ((m / 2) ^ 2 + (m / 2) ^ 2 + (m / 2) ^ 2 + (m / 2) ^ 2 : ℕ) :
          int.coe_nat_le.2 $ add_le_add (add_le_add (add_le_add
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _)
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _))
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _))
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _)
        ... = 4 * (m / 2 : ℕ) ^ 2 : by simp [sq, bit0, bit1, mul_add, add_mul, add_assoc]
        ... < 4 * (m / 2 : ℕ) ^ 2 + ((4 * (m / 2) : ℕ) * (m % 2 : ℕ) + (m % 2 : ℕ)^2) :
          (lt_add_iff_pos_right _).2 (by { rw [hm2, int.coe_nat_one, one_pow, mul_one],
            exact add_pos_of_nonneg_of_pos (int.coe_nat_nonneg _) zero_lt_one })
        ... = m ^ 2 : by { conv_rhs {rw [← nat.mod_add_div m 2]},
          simp [-nat.mod_add_div, mul_add, add_mul, bit0, bit1, mul_comm, mul_assoc, mul_left_comm,
            pow_add, add_comm, add_left_comm] },
      have hwxyzabcd : ((w^2 + x^2 + y^2 + z^2 : ℤ) : zmod m) =
          ((a^2 + b^2 + c^2 + d^2 : ℤ) : zmod m),
        by simp [w, x, y, z, sq],
      have hwxyz0 : ((w^2 + x^2 + y^2 + z^2 : ℤ) : zmod m) = 0,
        by rw [hwxyzabcd, habcd, int.cast_mul, cast_coe_nat, zmod.nat_cast_self, zero_mul],
      let ⟨n, hn⟩ := ((char_p.int_cast_eq_zero_iff _ m _).1 hwxyz0) in
      have hn0 : 0 < n.nat_abs, from int.nat_abs_pos_of_ne_zero (λ hn0,
        have hwxyz0 : (w.nat_abs^2 + x.nat_abs^2 + y.nat_abs^2 + z.nat_abs^2 : ℕ) = 0,
          by { rw [← int.coe_nat_eq_zero, ← hnat_abs], rwa [hn0, mul_zero] at hn },
        have habcd0 : (m : ℤ) ∣ a ∧ (m : ℤ) ∣ b ∧ (m : ℤ) ∣ c ∧ (m : ℤ) ∣ d,
          by simpa [@add_eq_zero_iff_eq_zero_of_nonneg ℤ _ _ _ (sq_nonneg _)
              (sq_nonneg _),
            sq, w, x, y, z, (char_p.int_cast_eq_zero_iff _ m _), and.assoc] using hwxyz0,
        let ⟨ma, hma⟩ := habcd0.1,     ⟨mb, hmb⟩ := habcd0.2.1,
            ⟨mc, hmc⟩ := habcd0.2.2.1, ⟨md, hmd⟩ := habcd0.2.2.2 in
        have hmdvdp : m ∣ p,
          from int.coe_nat_dvd.1 ⟨ma^2 + mb^2 + mc^2 + md^2,
            (mul_right_inj' (show (m : ℤ) ≠ 0, from int.coe_nat_ne_zero_iff_pos.2 hm0.1)).1 $
              by { rw [← habcd, hma, hmb, hmc, hmd], ring }⟩,
        (hp.1.2 _ hmdvdp).elim hm1 (λ hmeqp, by simpa [lt_irrefl, hmeqp] using hmp)),
      have hawbxcydz : ((m : ℕ) : ℤ) ∣ a * w + b * x + c * y + d * z,
        from (char_p.int_cast_eq_zero_iff (zmod m) m _).1 $ by { rw [← hwxyz0], simp, ring },
      have haxbwczdy : ((m : ℕ) : ℤ) ∣ a * x - b * w - c * z + d * y,
        from (char_p.int_cast_eq_zero_iff (zmod m) m _).1 $ by { simp [sub_eq_add_neg], ring },
      have haybzcwdx : ((m : ℕ) : ℤ) ∣ a * y + b * z - c * w - d * x,
        from (char_p.int_cast_eq_zero_iff (zmod m) m _).1 $ by { simp [sub_eq_add_neg], ring },
      have hazbycxdw : ((m : ℕ) : ℤ) ∣ a * z - b * y + c * x - d * w,
        from (char_p.int_cast_eq_zero_iff (zmod m) m _).1 $ by { simp [sub_eq_add_neg], ring },
      let ⟨s, hs⟩ := hawbxcydz, ⟨t, ht⟩ := haxbwczdy, ⟨u, hu⟩ := haybzcwdx, ⟨v, hv⟩ := hazbycxdw in
      have hn_nonneg : 0 ≤ n,
        from nonneg_of_mul_nonneg_left
          (by { erw [← hn], repeat {try {refine add_nonneg _ _}, try {exact sq_nonneg _}} })
          (int.coe_nat_pos.2 hm0.1),
      have hnm : n.nat_abs < m,
        from int.coe_nat_lt.1 (lt_of_mul_lt_mul_left
          (by { rw [int.nat_abs_of_nonneg hn_nonneg, ← hn, ← sq], exact hwxyzlt })
          (int.coe_nat_nonneg m)),
      have hstuv : s^2 + t^2 + u^2 + v^2 = n.nat_abs * p,
        from (mul_right_inj' (show (m^2 : ℤ) ≠ 0, from pow_ne_zero 2
            (int.coe_nat_ne_zero_iff_pos.2 hm0.1))).1 $
          calc (m : ℤ)^2 * (s^2 + t^2 + u^2 + v^2) = ((m : ℕ) * s)^2 + ((m : ℕ) * t)^2 +
              ((m : ℕ) * u)^2 + ((m : ℕ) * v)^2 :
            by { simp [mul_pow], ring }
          ... = (w^2 + x^2 + y^2 + z^2) * (a^2 + b^2 + c^2 + d^2) :
            by { simp only [hs.symm, ht.symm, hu.symm, hv.symm], ring }
          ... = _ : by { rw [hn, habcd, int.nat_abs_of_nonneg hn_nonneg], dsimp [m], ring },
      false.elim $ nat.find_min hm hnm ⟨lt_trans hnm hmp, hn0, s, t, u, v, hstuv⟩)

lemma sum_four_squares : ∀ n : ℕ, ∃ a b c d : ℕ, a^2 + b^2 + c^2 + d^2 = n
| 0 := ⟨0, 0, 0, 0, rfl⟩
| 1 := ⟨1, 0, 0, 0, rfl⟩
| n@(k+2) :=
have hm : _root_.fact (min_fac (k+2)).prime := ⟨min_fac_prime dec_trivial⟩,
have n / min_fac n < n := factors_lemma,
let ⟨a, b, c, d, h₁⟩ := show ∃ a b c d : ℤ, a^2 + b^2 + c^2 + d^2 = min_fac n,
  by exactI prime_sum_four_squares (min_fac (k+2)) in
let ⟨w, x, y, z, h₂⟩ := sum_four_squares (n / min_fac n) in
⟨(a * w - b * x - c * y - d * z).nat_abs,
 (a * x + b * w + c * z - d * y).nat_abs,
 (a * y - b * z + c * w + d * x).nat_abs,
 (a * z + b * y - c * x + d * w).nat_abs,
  begin
    rw [← int.coe_nat_inj', ← nat.mul_div_cancel' (min_fac_dvd (k+2)), int.coe_nat_mul, ← h₁, ← h₂],
    simp [sum_four_sq_mul_sum_four_sq],
  end⟩

end nat


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison, Floris van Doorn
-/
import category_theory.fully_faithful
import category_theory.full_subcategory
import category_theory.whiskering
import category_theory.essential_image
import tactic.slice

/-!
# Equivalence of categories

An equivalence of categories `C` and `D` is a pair of functors `F : C ⥤ D` and `G : D ⥤ C` such
that `η : 𝟭 C ≅ F ⋙ G` and `ε : G ⋙ F ≅ 𝟭 D`. In many situations, equivalences are a better
notion of "sameness" of categories than the stricter isomorphims of categories.

Recall that one way to express that two functors `F : C ⥤ D` and `G : D ⥤ C` are adjoint is using
two natural transformations `η : 𝟭 C ⟶ F ⋙ G` and `ε : G ⋙ F ⟶ 𝟭 D`, called the unit and the
counit, such that the compositions `F ⟶ FGF ⟶ F` and `G ⟶ GFG ⟶ G` are the identity. Unfortunately,
it is not the case that the natural isomorphisms `η` and `ε` in the definition of an equivalence
automatically give an adjunction. However, it is true that
* if one of the two compositions is the identity, then so is the other, and
* given an equivalence of categories, it is always possible to refine `η` in such a way that the
  identities are satisfied.

For this reason, in mathlib we define an equivalence to be a "half-adjoint equivalence", which is
a tuple `(F, G, η, ε)` as in the first paragraph such that the composite `F ⟶ FGF ⟶ F` is the
identity. By the remark above, this already implies that the tuple is an "adjoint equivalence",
i.e., that the composite `G ⟶ GFG ⟶ G` is also the identity.

We also define essentially surjective functors and show that a functor is an equivalence if and only
if it is full, faithful and essentially surjective.

## Main definitions

* `equivalence`: bundled (half-)adjoint equivalences of categories
* `is_equivalence`: type class on a functor `F` containing the data of the inverse `G` as well as
  the natural isomorphisms `η` and `ε`.
* `ess_surj`: type class on a functor `F` containing the data of the preimages and the isomorphisms
  `F.obj (preimage d) ≅ d`.

## Main results

* `equivalence.mk`: upgrade an equivalence to a (half-)adjoint equivalence
* `equivalence_of_fully_faithfully_ess_surj`: a fully faithful essentially surjective functor is an
  equivalence.

## Notations

We write `C ≌ D` (`\backcong`, not to be confused with `≅`/`\cong`) for a bundled equivalence.

-/

namespace category_theory
open category_theory.functor nat_iso category
-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ u₁ u₂ u₃

/-- We define an equivalence as a (half)-adjoint equivalence, a pair of functors with
  a unit and counit which are natural isomorphisms and the triangle law `Fη ≫ εF = 1`, or in other
  words the composite `F ⟶ FGF ⟶ F` is the identity.

  In `unit_inverse_comp`, we show that this is actually an adjoint equivalence, i.e., that the
  composite `G ⟶ GFG ⟶ G` is also the identity.

  The triangle equation is written as a family of equalities between morphisms, it is more
  complicated if we write it as an equality of natural transformations, because then we would have
  to insert natural transformations like `F ⟶ F1`.

See https://stacks.math.columbia.edu/tag/001J
-/
structure equivalence (C : Type u₁) [category.{v₁} C] (D : Type u₂) [category.{v₂} D] :=
mk' ::
(functor : C ⥤ D)
(inverse : D ⥤ C)
(unit_iso   : 𝟭 C ≅ functor ⋙ inverse)
(counit_iso : inverse ⋙ functor ≅ 𝟭 D)
(functor_unit_iso_comp' : ∀(X : C), functor.map ((unit_iso.hom : 𝟭 C ⟶ functor ⋙ inverse).app X) ≫
  counit_iso.hom.app (functor.obj X) = 𝟙 (functor.obj X) . obviously)

restate_axiom equivalence.functor_unit_iso_comp'

infixr ` ≌ `:10  := equivalence

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]

namespace equivalence

/-- The unit of an equivalence of categories. -/
abbreviation unit (e : C ≌ D) : 𝟭 C ⟶ e.functor ⋙ e.inverse := e.unit_iso.hom
/-- The counit of an equivalence of categories. -/
abbreviation counit (e : C ≌ D) : e.inverse ⋙ e.functor ⟶ 𝟭 D := e.counit_iso.hom
/-- The inverse of the unit of an equivalence of categories. -/
abbreviation unit_inv (e : C ≌ D) : e.functor ⋙ e.inverse ⟶ 𝟭 C := e.unit_iso.inv
/-- The inverse of the counit of an equivalence of categories. -/
abbreviation counit_inv (e : C ≌ D) : 𝟭 D ⟶ e.inverse ⋙ e.functor := e.counit_iso.inv

/- While these abbreviations are convenient, they also cause some trouble,
preventing structure projections from unfolding. -/
@[simp] lemma equivalence_mk'_unit (functor inverse unit_iso counit_iso f) :
  (⟨functor, inverse, unit_iso, counit_iso, f⟩ : C ≌ D).unit = unit_iso.hom := rfl
@[simp] lemma equivalence_mk'_counit (functor inverse unit_iso counit_iso f) :
  (⟨functor, inverse, unit_iso, counit_iso, f⟩ : C ≌ D).counit = counit_iso.hom := rfl
@[simp] lemma equivalence_mk'_unit_inv (functor inverse unit_iso counit_iso f) :
  (⟨functor, inverse, unit_iso, counit_iso, f⟩ : C ≌ D).unit_inv = unit_iso.inv := rfl
@[simp] lemma equivalence_mk'_counit_inv (functor inverse unit_iso counit_iso f) :
  (⟨functor, inverse, unit_iso, counit_iso, f⟩ : C ≌ D).counit_inv = counit_iso.inv := rfl

@[simp] lemma functor_unit_comp (e : C ≌ D) (X : C) :
  e.functor.map (e.unit.app X) ≫ e.counit.app (e.functor.obj X) = 𝟙 (e.functor.obj X) :=
e.functor_unit_iso_comp X

@[simp] lemma counit_inv_functor_comp (e : C ≌ D) (X : C) :
  e.counit_inv.app (e.functor.obj X) ≫ e.functor.map (e.unit_inv.app X) = 𝟙 (e.functor.obj X) :=
begin
  erw [iso.inv_eq_inv
    (e.functor.map_iso (e.unit_iso.app X) ≪≫ e.counit_iso.app (e.functor.obj X)) (iso.refl _)],
  exact e.functor_unit_comp X
end

lemma counit_inv_app_functor (e : C ≌ D) (X : C) :
  e.counit_inv.app (e.functor.obj X) = e.functor.map (e.unit.app X) :=
by { symmetry, erw [←iso.comp_hom_eq_id (e.counit_iso.app _), functor_unit_comp], refl }

lemma counit_app_functor (e : C ≌ D) (X : C) :
  e.counit.app (e.functor.obj X) = e.functor.map (e.unit_inv.app X) :=
by { erw [←iso.hom_comp_eq_id (e.functor.map_iso (e.unit_iso.app X)), functor_unit_comp], refl }

/-- The other triangle equality. The proof follows the following proof in Globular:
  http://globular.science/1905.001 -/
@[simp] lemma unit_inverse_comp (e : C ≌ D) (Y : D) :
  e.unit.app (e.inverse.obj Y) ≫ e.inverse.map (e.counit.app Y) = 𝟙 (e.inverse.obj Y) :=
begin
  rw [←id_comp (e.inverse.map _), ←map_id e.inverse, ←counit_inv_functor_comp, map_comp,
      ←iso.hom_inv_id_assoc (e.unit_iso.app _) (e.inverse.map (e.functor.map _)),
      app_hom, app_inv],
  slice_lhs 2 3 { erw [e.unit.naturality] },
  slice_lhs 1 2 { erw [e.unit.naturality] },
  slice_lhs 4 4
  { rw [←iso.hom_inv_id_assoc (e.inverse.map_iso (e.counit_iso.app _)) (e.unit_inv.app _)] },
  slice_lhs 3 4 { erw [←map_comp e.inverse, e.counit.naturality],
    erw [(e.counit_iso.app _).hom_inv_id, map_id] }, erw [id_comp],
  slice_lhs 2 3 { erw [←map_comp e.inverse, e.counit_iso.inv.naturality, map_comp] },
  slice_lhs 3 4 { erw [e.unit_inv.naturality] },
  slice_lhs 4 5 { erw [←map_comp (e.functor ⋙ e.inverse), (e.unit_iso.app _).hom_inv_id, map_id] },
  erw [id_comp],
  slice_lhs 3 4 { erw [←e.unit_inv.naturality] },
  slice_lhs 2 3 { erw [←map_comp e.inverse, ←e.counit_iso.inv.naturality,
    (e.counit_iso.app _).hom_inv_id, map_id] }, erw [id_comp, (e.unit_iso.app _).hom_inv_id], refl
end

@[simp] lemma inverse_counit_inv_comp (e : C ≌ D) (Y : D) :
  e.inverse.map (e.counit_inv.app Y) ≫ e.unit_inv.app (e.inverse.obj Y) = 𝟙 (e.inverse.obj Y) :=
begin
  erw [iso.inv_eq_inv
    (e.unit_iso.app (e.inverse.obj Y) ≪≫ e.inverse.map_iso (e.counit_iso.app Y)) (iso.refl _)],
  exact e.unit_inverse_comp Y
end

lemma unit_app_inverse (e : C ≌ D) (Y : D) :
  e.unit.app (e.inverse.obj Y) = e.inverse.map (e.counit_inv.app Y) :=
by { erw [←iso.comp_hom_eq_id (e.inverse.map_iso (e.counit_iso.app Y)), unit_inverse_comp], refl }

lemma unit_inv_app_inverse (e : C ≌ D) (Y : D) :
  e.unit_inv.app (e.inverse.obj Y) = e.inverse.map (e.counit.app Y) :=
by { symmetry, erw [←iso.hom_comp_eq_id (e.unit_iso.app _), unit_inverse_comp], refl }

@[simp] lemma fun_inv_map (e : C ≌ D) (X Y : D) (f : X ⟶ Y) :
  e.functor.map (e.inverse.map f) = e.counit.app X ≫ f ≫ e.counit_inv.app Y :=
(nat_iso.naturality_2 (e.counit_iso) f).symm

@[simp] lemma inv_fun_map (e : C ≌ D) (X Y : C) (f : X ⟶ Y) :
  e.inverse.map (e.functor.map f) = e.unit_inv.app X ≫ f ≫ e.unit.app Y :=
(nat_iso.naturality_1 (e.unit_iso) f).symm

section
-- In this section we convert an arbitrary equivalence to a half-adjoint equivalence.
variables {F : C ⥤ D} {G : D ⥤ C} (η : 𝟭 C ≅ F ⋙ G) (ε : G ⋙ F ≅ 𝟭 D)

/-- If `η : 𝟭 C ≅ F ⋙ G` is part of a (not necessarily half-adjoint) equivalence, we can upgrade it
to a refined natural isomorphism `adjointify_η η : 𝟭 C ≅ F ⋙ G` which exhibits the properties
required for a half-adjoint equivalence. See `equivalence.mk`. -/
def adjointify_η : 𝟭 C ≅ F ⋙ G :=
calc
  𝟭 C ≅ F ⋙ G               : η
  ... ≅ F ⋙ (𝟭 D ⋙ G)      : iso_whisker_left F (left_unitor G).symm
  ... ≅ F ⋙ ((G ⋙ F) ⋙ G) : iso_whisker_left F (iso_whisker_right ε.symm G)
  ... ≅ F ⋙ (G ⋙ (F ⋙ G)) : iso_whisker_left F (associator G F G)
  ... ≅ (F ⋙ G) ⋙ (F ⋙ G) : (associator F G (F ⋙ G)).symm
  ... ≅ 𝟭 C ⋙ (F ⋙ G)      : iso_whisker_right η.symm (F ⋙ G)
  ... ≅ F ⋙ G               : left_unitor (F ⋙ G)

lemma adjointify_η_ε (X : C) :
  F.map ((adjointify_η η ε).hom.app X) ≫ ε.hom.app (F.obj X) = 𝟙 (F.obj X) :=
begin
  dsimp [adjointify_η], simp,
  have := ε.hom.naturality (F.map (η.inv.app X)), dsimp at this, rw [this], clear this,
  rw [←assoc _ _ (F.map _)],
  have := ε.hom.naturality (ε.inv.app $ F.obj X), dsimp at this, rw [this], clear this,
  have := (ε.app $ F.obj X).hom_inv_id, dsimp at this, rw [this], clear this,
  rw [id_comp], have := (F.map_iso $ η.app X).hom_inv_id, dsimp at this, rw [this]
end

end

/-- Every equivalence of categories consisting of functors `F` and `G` such that `F ⋙ G` and
    `G ⋙ F` are naturally isomorphic to identity functors can be transformed into a half-adjoint
    equivalence without changing `F` or `G`. -/
protected definition mk (F : C ⥤ D) (G : D ⥤ C)
  (η : 𝟭 C ≅ F ⋙ G) (ε : G ⋙ F ≅ 𝟭 D) : C ≌ D :=
⟨F, G, adjointify_η η ε, ε, adjointify_η_ε η ε⟩

/-- Equivalence of categories is reflexive. -/
@[refl, simps] def refl : C ≌ C :=
⟨𝟭 C, 𝟭 C, iso.refl _, iso.refl _, λ X, category.id_comp _⟩

instance : inhabited (C ≌ C) :=
⟨refl⟩

/-- Equivalence of categories is symmetric. -/
@[symm, simps] def symm (e : C ≌ D) : D ≌ C :=
⟨e.inverse, e.functor, e.counit_iso.symm, e.unit_iso.symm, e.inverse_counit_inv_comp⟩

variables {E : Type u₃} [category.{v₃} E]

/-- Equivalence of categories is transitive. -/
@[trans, simps] def trans (e : C ≌ D) (f : D ≌ E) : C ≌ E :=
{ functor := e.functor ⋙ f.functor,
  inverse := f.inverse ⋙ e.inverse,
  unit_iso :=
  begin
    refine iso.trans e.unit_iso _,
    exact iso_whisker_left e.functor (iso_whisker_right f.unit_iso e.inverse) ,
  end,
  counit_iso :=
  begin
    refine iso.trans _ f.counit_iso,
    exact iso_whisker_left f.inverse (iso_whisker_right e.counit_iso f.functor)
  end,
  -- We wouldn't have needed to give this proof if we'd used `equivalence.mk`,
  -- but we choose to avoid using that here, for the sake of good structure projection `simp`
  -- lemmas.
  functor_unit_iso_comp' := λ X,
  begin
    dsimp,
    rw [← f.functor.map_comp_assoc, e.functor.map_comp, ←counit_inv_app_functor, fun_inv_map,
        iso.inv_hom_id_app_assoc, assoc, iso.inv_hom_id_app, counit_app_functor,
        ← functor.map_comp],
    erw [comp_id, iso.hom_inv_id_app, functor.map_id],
  end }

/-- Composing a functor with both functors of an equivalence yields a naturally isomorphic
functor. -/
def fun_inv_id_assoc (e : C ≌ D) (F : C ⥤ E) : e.functor ⋙ e.inverse ⋙ F ≅ F :=
(functor.associator _ _ _).symm ≪≫ iso_whisker_right e.unit_iso.symm F ≪≫ F.left_unitor

@[simp] lemma fun_inv_id_assoc_hom_app (e : C ≌ D) (F : C ⥤ E) (X : C) :
  (fun_inv_id_assoc e F).hom.app X = F.map (e.unit_inv.app X) :=
by { dsimp [fun_inv_id_assoc], tidy }

@[simp] lemma fun_inv_id_assoc_inv_app (e : C ≌ D) (F : C ⥤ E) (X : C) :
  (fun_inv_id_assoc e F).inv.app X = F.map (e.unit.app X) :=
by { dsimp [fun_inv_id_assoc], tidy }

/-- Composing a functor with both functors of an equivalence yields a naturally isomorphic
functor. -/
def inv_fun_id_assoc (e : C ≌ D) (F : D ⥤ E) : e.inverse ⋙ e.functor ⋙ F ≅ F :=
(functor.associator _ _ _).symm ≪≫ iso_whisker_right e.counit_iso F ≪≫ F.left_unitor

@[simp] lemma inv_fun_id_assoc_hom_app (e : C ≌ D) (F : D ⥤ E) (X : D) :
  (inv_fun_id_assoc e F).hom.app X = F.map (e.counit.app X) :=
by { dsimp [inv_fun_id_assoc], tidy }

@[simp] lemma inv_fun_id_assoc_inv_app (e : C ≌ D) (F : D ⥤ E) (X : D) :
  (inv_fun_id_assoc e F).inv.app X = F.map (e.counit_inv.app X) :=
by { dsimp [inv_fun_id_assoc], tidy }

/-- If `C` is equivalent to `D`, then `C ⥤ E` is equivalent to `D ⥤ E`. -/
@[simps functor inverse unit_iso counit_iso]
def congr_left (e : C ≌ D) : (C ⥤ E) ≌ (D ⥤ E) :=
equivalence.mk
  ((whiskering_left _ _ _).obj e.inverse)
  ((whiskering_left _ _ _).obj e.functor)
  (nat_iso.of_components (λ F, (e.fun_inv_id_assoc F).symm) (by tidy))
  (nat_iso.of_components (λ F, e.inv_fun_id_assoc F) (by tidy))

/-- If `C` is equivalent to `D`, then `E ⥤ C` is equivalent to `E ⥤ D`. -/
@[simps functor inverse unit_iso counit_iso]
def congr_right (e : C ≌ D) : (E ⥤ C) ≌ (E ⥤ D) :=
equivalence.mk
  ((whiskering_right _ _ _).obj e.functor)
  ((whiskering_right _ _ _).obj e.inverse)
  (nat_iso.of_components
    (λ F, F.right_unitor.symm ≪≫ iso_whisker_left F e.unit_iso ≪≫ functor.associator _ _ _)
    (by tidy))
  (nat_iso.of_components
    (λ F, functor.associator _ _ _ ≪≫ iso_whisker_left F e.counit_iso ≪≫ F.right_unitor)
    (by tidy))

section cancellation_lemmas
variables (e : C ≌ D)

/- We need special forms of `cancel_nat_iso_hom_right(_assoc)` and
`cancel_nat_iso_inv_right(_assoc)` for units and counits, because neither `simp` or `rw` will apply
those lemmas in this setting without providing `e.unit_iso` (or similar) as an explicit argument.
We also provide the lemmas for length four compositions, since they're occasionally useful.
(e.g. in proving that equivalences take monos to monos) -/

@[simp] lemma cancel_unit_right {X Y : C}
  (f f' : X ⟶ Y) :
  f ≫ e.unit.app Y = f' ≫ e.unit.app Y ↔ f = f' :=
by simp only [cancel_mono]

@[simp] lemma cancel_unit_inv_right {X Y : C}
  (f f' : X ⟶ e.inverse.obj (e.functor.obj Y))   :
  f ≫ e.unit_inv.app Y = f' ≫ e.unit_inv.app Y ↔ f = f' :=
by simp only [cancel_mono]

@[simp] lemma cancel_counit_right {X Y : D}
  (f f' : X ⟶ e.functor.obj (e.inverse.obj Y))   :
  f ≫ e.counit.app Y = f' ≫ e.counit.app Y ↔ f = f' :=
by simp only [cancel_mono]

@[simp] lemma cancel_counit_inv_right {X Y : D}
  (f f' : X ⟶ Y) :
  f ≫ e.counit_inv.app Y = f' ≫ e.counit_inv.app Y ↔ f = f' :=
by simp only [cancel_mono]

@[simp] lemma cancel_unit_right_assoc {W X X' Y : C}
  (f : W ⟶ X) (g : X ⟶ Y) (f' : W ⟶ X') (g' : X' ⟶ Y) :
  f ≫ g ≫ e.unit.app Y = f' ≫ g' ≫ e.unit.app Y ↔ f ≫ g = f' ≫ g' :=
by simp only [←category.assoc, cancel_mono]

@[simp] lemma cancel_counit_inv_right_assoc {W X X' Y : D}
  (f : W ⟶ X) (g : X ⟶ Y) (f' : W ⟶ X') (g' : X' ⟶ Y) :
  f ≫ g ≫ e.counit_inv.app Y = f' ≫ g' ≫ e.counit_inv.app Y ↔ f ≫ g = f' ≫ g' :=
by simp only [←category.assoc, cancel_mono]

@[simp] lemma cancel_unit_right_assoc' {W X X' Y Y' Z : C}
  (f : W ⟶ X) (g : X ⟶ Y) (h : Y ⟶ Z) (f' : W ⟶ X') (g' : X' ⟶ Y') (h' : Y' ⟶ Z) :
  f ≫ g ≫ h ≫ e.unit.app Z = f' ≫ g' ≫ h' ≫ e.unit.app Z ↔ f ≫ g ≫ h = f' ≫ g' ≫ h' :=
by simp only [←category.assoc, cancel_mono]

@[simp]

end cancellation_lemmas

section

-- There's of course a monoid structure on `C ≌ C`,
-- but let's not encourage using it.
-- The power structure is nevertheless useful.

/-- Natural number powers of an auto-equivalence.  Use `(^)` instead. -/
def pow_nat (e : C ≌ C) : ℕ → (C ≌ C)
| 0 := equivalence.refl
| 1 := e
| (n+2) := e.trans (pow_nat (n+1))

/-- Powers of an auto-equivalence.  Use `(^)` instead. -/
def pow (e : C ≌ C) : ℤ → (C ≌ C)
| (int.of_nat n) := e.pow_nat n
| (int.neg_succ_of_nat n) := e.symm.pow_nat (n+1)

instance : has_pow (C ≌ C) ℤ := ⟨pow⟩

@[simp] lemma pow_zero (e : C ≌ C) : e^(0 : ℤ) = equivalence.refl := rfl
@[simp] lemma pow_one (e : C ≌ C) : e^(1 : ℤ) = e := rfl
@[simp] lemma pow_neg_one (e : C ≌ C) : e^(-1 : ℤ) = e.symm := rfl

-- TODO as necessary, add the natural isomorphisms `(e^a).trans e^b ≅ e^(a+b)`.
-- At this point, we haven't even defined the category of equivalences.

end

end equivalence

/-- A functor that is part of a (half) adjoint equivalence -/
class is_equivalence (F : C ⥤ D) :=
mk' ::
(inverse    : D ⥤ C)
(unit_iso   : 𝟭 C ≅ F ⋙ inverse)
(counit_iso : inverse ⋙ F ≅ 𝟭 D)
(functor_unit_iso_comp' : ∀ (X : C), F.map ((unit_iso.hom : 𝟭 C ⟶ F ⋙ inverse).app X) ≫
  counit_iso.hom.app (F.obj X) = 𝟙 (F.obj X) . obviously)

restate_axiom is_equivalence.functor_unit_iso_comp'

namespace is_equivalence

instance of_equivalence (F : C ≌ D) : is_equivalence F.functor :=
{ ..F }

instance of_equivalence_inverse (F : C ≌ D) : is_equivalence F.inverse :=
is_equivalence.of_equivalence F.symm

open equivalence
/-- To see that a functor is an equivalence, it suffices to provide an inverse functor `G` such that
    `F ⋙ G` and `G ⋙ F` are naturally isomorphic to identity functors. -/
protected definition mk {F : C ⥤ D} (G : D ⥤ C)
  (η : 𝟭 C ≅ F ⋙ G) (ε : G ⋙ F ≅ 𝟭 D) : is_equivalence F :=
⟨G, adjointify_η η ε, ε, adjointify_η_ε η ε⟩

end is_equivalence

namespace functor

/-- Interpret a functor that is an equivalence as an equivalence. -/
def as_equivalence (F : C ⥤ D) [is_equivalence F] : C ≌ D :=
⟨F, is_equivalence.inverse F, is_equivalence.unit_iso, is_equivalence.counit_iso,
  is_equivalence.functor_unit_iso_comp⟩

instance is_equivalence_refl : is_equivalence (𝟭 C) :=
is_equivalence.of_equivalence equivalence.refl

/-- The inverse functor of a functor that is an equivalence. -/
def inv (F : C ⥤ D) [is_equivalence F] : D ⥤ C :=
is_equivalence.inverse F

instance is_equivalence_inv (F : C ⥤ D) [is_equivalence F] : is_equivalence F.inv :=
is_equivalence.of_equivalence F.as_equivalence.symm

@[simp] lemma as_equivalence_functor (F : C ⥤ D) [is_equivalence F] :
  F.as_equivalence.functor = F := rfl

@[simp] lemma as_equivalence_inverse (F : C ⥤ D) [is_equivalence F] :
  F.as_equivalence.inverse = inv F := rfl

@[simp] lemma inv_inv (F : C ⥤ D) [is_equivalence F] :
  inv (inv F) = F := rfl

variables {E : Type u₃} [category.{v₃} E]

instance is_equivalence_trans (F : C ⥤ D) (G : D ⥤ E) [is_equivalence F] [is_equivalence G] :
  is_equivalence (F ⋙ G) :=
is_equivalence.of_equivalence (equivalence.trans (as_equivalence F) (as_equivalence G))

end functor

namespace equivalence

@[simp]
lemma functor_inv (E : C ≌ D) : E.functor.inv = E.inverse := rfl

@[simp]
lemma inverse_inv (E : C ≌ D) : E.inverse.inv = E.functor := rfl

@[simp]
lemma functor_as_equivalence (E : C ≌ D) : E.functor.as_equivalence = E :=
by { cases E, congr, }

@[simp]
lemma inverse_as_equivalence (E : C ≌ D) : E.inverse.as_equivalence = E.symm :=
by { cases E, congr, }

end equivalence

namespace is_equivalence

@[simp] lemma fun_inv_map (F : C ⥤ D) [is_equivalence F] (X Y : D) (f : X ⟶ Y) :
  F.map (F.inv.map f) = F.as_equivalence.counit.app X ≫ f ≫ F.as_equivalence.counit_inv.app Y :=
begin
  erw [nat_iso.naturality_2],
  refl
end
@[simp] lemma inv_fun_map (F : C ⥤ D) [is_equivalence F] (X Y : C) (f : X ⟶ Y) :
  F.inv.map (F.map f) = F.as_equivalence.unit_inv.app X ≫ f ≫ F.as_equivalence.unit.app Y :=
begin
  erw [nat_iso.naturality_1],
  refl
end

end is_equivalence

namespace equivalence

/--
An equivalence is essentially surjective.

See https://stacks.math.columbia.edu/tag/02C3.
-/
lemma ess_surj_of_equivalence (F : C ⥤ D) [is_equivalence F] : ess_surj F :=
⟨λ Y, ⟨F.inv.obj Y, ⟨F.as_equivalence.counit_iso.app Y⟩⟩⟩

/--
An equivalence is faithful.

See https://stacks.math.columbia.edu/tag/02C3.
-/
@[priority 100] -- see Note [lower instance priority]
instance faithful_of_equivalence (F : C ⥤ D) [is_equivalence F] : faithful F :=
{ map_injective' := λ X Y f g w,
  begin
    have p := congr_arg (@category_theory.functor.map _ _ _ _ F.inv _ _) w,
    simpa only [cancel_epi, cancel_mono, is_equivalence.inv_fun_map] using p
  end }.

/--
An equivalence is full.

See https://stacks.math.columbia.edu/tag/02C3.
-/
@[priority 100] -- see Note [lower instance priority]
instance full_of_equivalence (F : C ⥤ D) [is_equivalence F] : full F :=
{ preimage := λ X Y f, F.as_equivalence.unit.app X ≫ F.inv.map f ≫ F.as_equivalence.unit_inv.app Y,
  witness' := λ X Y f, F.inv.map_injective $
  by simpa only [is_equivalence.inv_fun_map, assoc, iso.inv_hom_id_app_assoc, iso.inv_hom_id_app]
    using comp_id _ }

@[simps] private noncomputable def equivalence_inverse (F : C ⥤ D) [full F] [faithful F]
  [ess_surj F] : D ⥤ C :=
{ obj  := λ X, F.obj_preimage X,
  map := λ X Y f, F.preimage ((F.obj_obj_preimage_iso X).hom ≫ f ≫ (F.obj_obj_preimage_iso Y).inv),
  map_id' := λ X, begin apply F.map_injective, tidy end,
  map_comp' := λ X Y Z f g, by apply F.map_injective; simp }

/--
A functor which is full, faithful, and essentially surjective is an equivalence.

See https://stacks.math.columbia.edu/tag/02C3.
-/
noncomputable def equivalence_of_fully_faithfully_ess_surj
  (F : C ⥤ D) [full F] [faithful F] [ess_surj F] : is_equivalence F :=
is_equivalence.mk (equivalence_inverse F)
  (nat_iso.of_components
    (λ X, (preimage_iso $ F.obj_obj_preimage_iso $ F.obj X).symm)
    (λ X Y f, by { apply F.map_injective, obviously }))
  (nat_iso.of_components F.obj_obj_preimage_iso (by tidy))

@[simp] lemma functor_map_inj_iff (e : C ≌ D) {X Y : C} (f g : X ⟶ Y) :
  e.functor.map f = e.functor.map g ↔ f = g :=
⟨λ h, e.functor.map_injective h, λ h, h ▸ rfl⟩

@[simp] lemma inverse_map_inj_iff (e : C ≌ D) {X Y : D} (f g : X ⟶ Y) :
  e.inverse.map f = e.inverse.map g ↔ f = g :=
functor_map_inj_iff e.symm f g

instance ess_surj_induced_functor {C' : Type*} (e : C' ≃ D) : ess_surj (induced_functor e) :=
{ mem_ess_image := λ Y, ⟨e.symm Y, by simp⟩, }

noncomputable
instance induced_functor_of_equiv {C' : Type*} (e : C' ≃ D) : is_equivalence (induced_functor e) :=
equivalence_of_fully_faithfully_ess_surj _

end equivalence

section partial_order
variables {α β : Type*} [partial_order α] [partial_order β]

/--
A categorical equivalence between partial orders is just an order isomorphism.
-/
def equivalence.to_order_iso (e : α ≌ β) : α ≃o β :=
{ to_fun := e.functor.obj,
  inv_fun := e.inverse.obj,
  left_inv := λ a, (e.unit_iso.app a).to_eq.symm,
  right_inv := λ b, (e.counit_iso.app b).to_eq,
  map_rel_iff' := λ a a',
    ⟨λ h, le_of_hom
      ((equivalence.unit e).app a ≫ e.inverse.map (hom_of_le h) ≫ (equivalence.unit_inv e).app a'),
     λ (h : a ≤ a'), le_of_hom (e.functor.map (hom_of_le h))⟩, }

-- `@[simps]` on `equivalence.to_order_iso` produces lemmas that fail the `simp_nf` linter,
-- so we provide them by hand:
@[simp]
lemma equivalence.to_order_iso_apply (e : α ≌ β) (a : α) :
  e.to_order_iso a = e.functor.obj a := rfl

@[simp]
lemma equivalence.to_order_iso_symm_apply (e : α ≌ β) (b : β) :
  e.to_order_iso.symm b = e.inverse.obj b := rfl

end partial_order

end category_theory


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.algebra.basic
import Mathlib.algebra.star.basic
import Mathlib.PostPort

universes u v l

namespace Mathlib

/-!
# Star algebras

Introduces the notion of a star algebra over a star ring.
-/

/--
A star algebra `A` over a star ring `R` is an algebra which is a star ring,
and the two star structures are compatible in the sense
`star (r • a) = star r • star a`.
-/
-- Note that we take `star_ring A` as a typeclass argument, rather than extending it,

-- to avoid having multiple definitions of the star operation.

class star_algebra (R : Type u) (A : Type v) [comm_semiring R] [star_ring R] [semiring A]
    [star_ring A] [algebra R A]
    where
  star_smul : ∀ (r : R) (a : A), star (r • a) = has_star.star r • star a

@[simp] theorem star_smul (R : Type u) (A : Type v) [comm_semiring R] [star_ring R] [semiring A]
    [star_ring A] [algebra R A] [star_algebra R A] (r : R) (a : A) :
    star (r • a) = star r • star a :=
  star_algebra.star_smul r a

end Mathlib


/- ACL and MIdFF, Lean 2022 meeting at Icerm -/
import divided_powers.basic
import basic_lemmas

open subtype

-- We should PR this lemma
lemma submodule.supr_eq_span' {R M : Type*} [semiring R] [add_comm_monoid M] [module R M]
  {ι : Sort*} (p : ι → submodule R M) (h : ι → Prop) :
  (⨆ (i : ι) (hi : h i), p i) = submodule.span R (⋃ (i : ι) (hi : h i), ↑(p i)) :=
by simp_rw [← submodule.supr_span, submodule.span_eq]

namespace subideal

variables {A : Type*} [comm_ring A] {I : ideal A}

def galois_coinsertion : galois_coinsertion (λ J : {J : ideal A // J ≤ I}, (J : ideal A))
  (λ J : ideal A, ⟨J ⊓ I, by exact inf_le_right⟩) :=
galois_coinsertion.monotone_intro (λ J J' h, mk_le_mk.mpr (inf_le_inf_right I h))
  (λ J J' h, h) (λ J, inf_le_left) (λ ⟨J, hJ⟩, by simp only [coe_mk]; exact inf_eq_left.mpr hJ)

instance : complete_lattice {J : ideal A // J ≤ I} :=
galois_coinsertion.lift_complete_lattice (galois_coinsertion)

lemma top_def : (⟨I, le_refl I⟩ : {J : ideal A // J ≤ I}) = ⊤ :=
eq_top_iff.mpr (⊤ : {J : ideal A // J ≤ I}).property

lemma bot_def : (⟨⊥, bot_le⟩ : {J : ideal A // J ≤ I}) = ⊥ := by rw mk_bot

lemma inf_def (J J' : {J : ideal A // J ≤ I}) :
  (J ⊓ J' : {J : ideal A // J ≤ I} ) = ⟨(J : ideal A) ⊓ (J' : ideal A), inf_le_of_left_le J.2⟩ :=
by { ext x, exact ⟨λ ⟨h, h'⟩, h, λ h, ⟨h, J.property h.left⟩⟩ }

lemma  Inf_def (S : set {J : ideal A // J ≤ I}) :
  (Inf S : {J : ideal A // J ≤ I} ) = ⟨(Inf ((coe : _ → ideal A) '' S)) ⊓ I, inf_le_right⟩ :=
by { ext x, refl }

lemma sup_def (J J' : {J : ideal A // J ≤ I}) :
  (J ⊔ J' : {J : ideal A // J ≤ I} ) =
    ⟨Inf {B | (J : ideal A) ≤ B ∧ (J' : ideal A) ≤ B}, Inf_le_of_le ⟨J.2, J'.2⟩ (le_refl I)⟩ :=
begin
  ext x,
  refine ⟨λ ⟨h, h'⟩, h, λ h, ⟨h, _⟩⟩,
  rw [coe_mk, submodule.mem_Inf] at h,
  exact h I ⟨J.2, J'.2⟩
end

lemma Sup_def (S : set {J : ideal A // J ≤ I}) :
  (Sup S : {J : ideal A // J ≤ I} ) = ⟨(Sup ((coe : _ → ideal A) '' S)) ⊓ I, inf_le_right⟩ :=
by { ext x, refl }

end subideal

namespace divided_powers

/-- The structure of a sub-pd-ideal of a pd-ideal -/
structure is_sub_pd_ideal {A : Type*} [comm_ring A] {I : ideal A} (hI : divided_powers I)
  (J : ideal A) : Prop :=
(is_sub_ideal : J ≤ I)
(dpow_mem_ideal : ∀ (n : ℕ) (hn : n ≠ 0) (j ∈ J), hI.dpow n j ∈ J )

section is_sub_pd_ideal

variables {A : Type*} [comm_ring A] {I : ideal A} (hI : divided_powers I)

/-- The ideal J ⊓ I is a sub-pd-ideal of I, if and only if (on I) the divided powers have some
  compatiblity mod J. (The necessity was proved as a sanity check.) -/
lemma is_sub_pd_ideal_inf_iff (J : ideal A) :
  (is_sub_pd_ideal hI (J ⊓ I)) ↔ (∀ (n : ℕ) (a b : A) (ha : a ∈ I) (hb : b ∈ I) (hab : (a - b) ∈ J),
    hI.dpow n a - hI.dpow n b ∈ J) :=
begin
  refine ⟨λ hIJ n a b ha hb hab, _, λ hIJ, _⟩,
  { have hab' : a - b ∈ I := I.sub_mem ha hb,
    rw [← add_sub_cancel'_right b a, hI.dpow_add n hb hab', finset.range_succ,
      finset.sum_insert (finset.not_mem_range_self), tsub_self, hI.dpow_zero hab', mul_one,
      add_sub_cancel'],
    apply ideal.sum_mem,
    intros i hi,
    apply semilattice_inf.inf_le_left J I,
    exact (J ⊓ I).smul_mem _ (hIJ.dpow_mem_ideal (n - i)
      (ne_of_gt (nat.sub_pos_of_lt (finset.mem_range.mp hi))) _ ⟨hab, hab'⟩) },
  { refine ⟨semilattice_inf.inf_le_right J I, λ n hn a ha,  ⟨_, hI.dpow_mem hn ha.right⟩⟩,
    rw [← sub_zero (hI.dpow n a), ← hI.dpow_eval_zero hn],
    exact hIJ n a 0 ha.right (I.zero_mem) (J.sub_mem ha.left J.zero_mem) },
end

/-- Lemma 3.6 of [BO] (Antoine) -/
lemma span_is_sub_pd_ideal_iff (S : set A) (hS : S ⊆ I) :
  is_sub_pd_ideal hI (ideal.span S) ↔
  ∀ (n : ℕ) (hn : n ≠ 0) (s ∈ S), hI.dpow n s ∈ ideal.span S :=
begin
  split,
  { -- trivial direction
    intros hhI h hn s hs,
    apply hhI.dpow_mem_ideal h hn s (ideal.subset_span hs), },
  { -- interesting direction,
    intro hhI,
    have hSI := ideal.span_le.mpr hS,
    apply is_sub_pd_ideal.mk (hSI),
    intros n hn z hz, revert n,
    refine submodule.span_induction' _ _ _ _ hz,
    { -- case of elements of S
      intros s hs n hn, exact hhI n hn s hs, },
    { -- case of 0
      intros n hn, rw hI.dpow_eval_zero hn, apply ideal.zero_mem _, },
    { -- case of sum
      rintros x hxI y hyI hx hy n hn,
      rw hI.dpow_add n (hSI hxI) (hSI hyI),
      apply submodule.sum_mem (ideal.span S),
      intros m hm,
      by_cases hm0 : m = 0,
      { rw hm0,
        exact ideal.mul_mem_left (ideal.span S) _ (hy n hn), },
      { exact ideal.mul_mem_right _ (ideal.span S) (hx m hm0), } },
    { -- case : product,
      intros a x hxI hx n hn,
      simp only [algebra.id.smul_eq_mul],
      rw hI.dpow_smul n (hSI hxI),
      exact ideal.mul_mem_left (ideal.span S) (a ^ n) (hx n hn), }, },
end

lemma generated_dpow_is_sub_ideal {S : set A} (hS : S ⊆ I) :
  ideal.span { y : A | ∃ (n : ℕ) (hn : n ≠ 0) (x : A) (hx : x ∈ S), y = hI.dpow n x } ≤ I :=
begin
  rw ideal.span_le,
  rintros y ⟨n, hn, x, hx, hxy⟩,
  rw hxy,
  exact hI.dpow_mem hn (hS hx)
end

end is_sub_pd_ideal

/-- A `sub-pd-ideal` of `I` is a sub-ideal `J` of `I` such that for all `n ∈ ℕ ≥ 0` and all
  `j ∈ J`, `hI.dpow n j ∈ J`. -/
@[ext] structure sub_pd_ideal {A : Type*} [comm_ring A] {I : ideal A} (hI : divided_powers I) :=
(carrier : ideal A)
(is_sub_ideal : carrier ≤ I)
(dpow_mem_ideal : ∀ (n : ℕ) (hn : n ≠ 0) (j ∈ carrier), hI.dpow n j ∈ carrier)

namespace sub_pd_ideal

variables {A : Type*} [comm_ring A] {I : ideal A} (hI : divided_powers I)

def mk' (J : ideal A) (hJ : is_sub_pd_ideal hI J) : sub_pd_ideal hI := ⟨J, hJ.1, hJ.2⟩

instance : set_like (sub_pd_ideal hI) A :=
{ coe := λ s, s.carrier,
  coe_injective' := λ p q h, by rw [set_like.coe_set_eq] at h; cases p; cases q; congr'  }

instance : has_coe (sub_pd_ideal hI) (ideal A) := ⟨λ J, J.carrier⟩

lemma coe_def (J : sub_pd_ideal hI) : (J : ideal A) = J.carrier := rfl

@[simp] lemma mem_carrier {s : sub_pd_ideal hI} {x : A} : x ∈ s.carrier ↔ x ∈ s := iff.rfl

/-- If there is a pd-structure on I(A/J) such that the quotient map is
   a pd-morphism, then J ⊓ I is a sub-pd-ideal of I -/
def inter_quot (J : ideal A) (hJ : divided_powers (I.map (ideal.quotient.mk J)))
  (φ : pd_morphism hI hJ) (hφ:  φ.to_ring_hom = ideal.quotient.mk J) :
  sub_pd_ideal hI :=
{ carrier        := J ⊓ I,
  is_sub_ideal   := set.inter_subset_right J I,
  dpow_mem_ideal := λ n hn a ⟨haJ, haI⟩,
  begin
    refine ⟨_, hI.dpow_mem hn haI⟩,
    rw [set_like.mem_coe,← ideal.quotient.eq_zero_iff_mem, ← hφ, ← φ.dpow_comp n a haI],
    suffices ha0 : (φ.to_ring_hom) a = 0,
    { rw ha0,
      exact hJ.dpow_eval_zero hn },
    rw [hφ, ideal.quotient.eq_zero_iff_mem],
    exact haJ,
  end }

/-- If J is an ideal of A, then J ⬝ I is a sub-pd-ideal of I. (Berthelot, 1.6.1 (i)) -/
def prod (J : ideal A) : sub_pd_ideal hI  :=
{ carrier        := I • J,
  is_sub_ideal   := ideal.mul_le_right,
  dpow_mem_ideal := λ n hn x hx,
  begin
    revert n,
    apply submodule.smul_induction_on' hx,
    { -- mul
      intros a ha b hb n hn,
      rw [algebra.id.smul_eq_mul, mul_comm a b, hI.dpow_smul n ha, mul_comm],
      exact submodule.mul_mem_mul (hI.dpow_mem hn ha)
        (J.pow_mem_of_mem hb n (zero_lt_iff.mpr hn)) },
    { -- add
      intros x hx y hy hx' hy' n hn,
      rw hI.dpow_add n (ideal.mul_le_right hx) (ideal.mul_le_right hy),
      apply submodule.sum_mem (I • J),
      intros k hk,
      by_cases hk0 : k = 0,
      { rw hk0, apply ideal.mul_mem_left (I • J), exact hy' _ hn, },
      { apply ideal.mul_mem_right _ (I • J), exact hx' k hk0, }, }
  end }

section complete_lattice

instance : has_coe (sub_pd_ideal hI) {J : ideal A // J ≤ I} :=  ⟨λ J, ⟨J.carrier, J.is_sub_ideal⟩⟩

instance : has_le (sub_pd_ideal hI) := ⟨λ J J', J.carrier ≤ J'.carrier⟩

lemma le_iff {J J' : sub_pd_ideal hI} : J ≤ J' ↔ J.carrier ≤ J'.carrier := iff.rfl

instance : has_lt (sub_pd_ideal hI) := ⟨λ J J', J.carrier < J'.carrier⟩

lemma lt_iff {J J' : sub_pd_ideal hI} : J < J' ↔ J.carrier < J'.carrier := iff.rfl

/-- I is a sub-pd-ideal ot itself. -/
instance : has_top (sub_pd_ideal hI) :=
⟨{ carrier       := I,
  is_sub_ideal   := le_refl _,
  dpow_mem_ideal := λ n hn x hx, hI.dpow_mem hn hx }⟩

instance inhabited : inhabited hI.sub_pd_ideal := ⟨⊤⟩

/-- (0) is a sub-pd-ideal ot the pd-ideal I. -/
instance : has_bot (sub_pd_ideal hI) :=
⟨{ carrier       := ⊥,
  is_sub_ideal   := bot_le,
  dpow_mem_ideal := λ n hn x hx,
  by rw [ideal.mem_bot.mp hx, hI.dpow_eval_zero hn, ideal.mem_bot]}⟩

--Section 1.8 of [B]
/- The intersection of two sub-PD ideals is a sub-PD ideal. -/
instance : has_inf (sub_pd_ideal hI) := ⟨λ J J',
{ carrier := J.carrier ⊓ J'.carrier,
  is_sub_ideal := λ x hx, J.is_sub_ideal hx.1,
  dpow_mem_ideal :=  λ n hn x hx, ⟨J.dpow_mem_ideal n hn x hx.1, J'.dpow_mem_ideal n hn x hx.2⟩ }⟩

lemma inf_carrier_def (J J' : sub_pd_ideal hI) :
  (J ⊓ J').carrier = J.carrier ⊓ J'.carrier := rfl

instance : has_Inf (sub_pd_ideal hI) := ⟨λ S,
{ carrier := ⨅ s ∈ (has_insert.insert ⊤ S), (s : hI.sub_pd_ideal).carrier,
  is_sub_ideal := λ x hx,
  begin
    simp only [ideal.mem_infi] at hx,
    exact hx ⊤ (set.mem_insert ⊤ S),
  end,
  dpow_mem_ideal := λ n hn x hx,
  begin
    simp only [ideal.mem_infi] at hx ⊢,
    intros s hs,
    refine (s : hI.sub_pd_ideal).dpow_mem_ideal n hn x (hx s hs),
  end }⟩

lemma Inf_carrier_def (S : set (sub_pd_ideal hI)) :
  (Inf S).carrier = ⨅ s ∈ (has_insert.insert ⊤ S), (s : hI.sub_pd_ideal).carrier := rfl

instance : has_sup (sub_pd_ideal hI) :=
⟨λ J J', sub_pd_ideal.mk' hI ((J : ideal A) ⊔ J')  $ begin
  have hJJ' : (J : ideal A) ⊔ (J' : ideal A) = ideal.span(J ∪ J'),
  { simp only [ideal.span_union, coe_coe, ideal.span_eq] },
  rw [hJJ', span_is_sub_pd_ideal_iff hI (J ∪ J') (set.union_subset J.is_sub_ideal J'.is_sub_ideal)],
  rintros n hn x (hx | hx),
  { exact ideal.subset_span (set.mem_union_left _ (J.dpow_mem_ideal n hn x hx)) },
  { exact ideal.subset_span (set.mem_union_right _ (J'.dpow_mem_ideal n hn x hx)) }
end⟩

lemma sup_carrier_def (J J' : sub_pd_ideal hI) : (J ⊔ J').carrier = J ⊔ J' := rfl

instance : has_Sup (sub_pd_ideal hI) :=
⟨λ S, sub_pd_ideal.mk' hI (Sup ((coe : sub_pd_ideal hI → ideal A) '' S)) $
  begin
    have h : (⋃ (i : ideal A) (hi : i ∈ coe '' S), ↑i) ⊆ (I : set A),
    { rintros a ⟨-, ⟨J, rfl⟩, haJ⟩,
      rw [set.mem_Union, set_like.mem_coe, exists_prop] at haJ,
      obtain ⟨J', hJ'⟩ := (set.mem_image _ _ _).mp haJ.1,
      rw [← hJ'.2, coe_def] at haJ,
      exact J'.is_sub_ideal haJ.2, },
    rw [Sup_eq_supr, submodule.supr_eq_span', ideal.submodule_span_eq,
      span_is_sub_pd_ideal_iff hI _ h],
    rintros n hn x ⟨T, hT, hTx⟩,
    obtain ⟨J, hJ⟩ := hT,
    rw ← hJ at hTx,
    obtain ⟨J', ⟨⟨hJ', rfl⟩, h'⟩⟩ := hTx,
    apply ideal.subset_span,
    apply set.mem_bUnion hJ',
    obtain ⟨K, hKS, rfl⟩ := hJ',
    exact K.dpow_mem_ideal n hn x h',
end⟩

lemma Sup_carrier_def (S : set (sub_pd_ideal hI)) :
  (Sup S).carrier = Sup ((coe : sub_pd_ideal hI → ideal A) '' S) := rfl

instance : complete_lattice (sub_pd_ideal hI) :=
begin
  refine function.injective.complete_lattice (λ J : sub_pd_ideal hI, (J : {J : ideal A // J ≤ I}))
    (λ J J' h, (ext_iff _ _).mpr (subtype.ext_iff.mp h)) (λ J J', by rw subideal.sup_def; refl)
    (λ J J', by rw subideal.inf_def; refl) _ _ (by rw ← subideal.top_def; refl)
    (by rw ← subideal.bot_def; refl),
  { intro S,
    conv_rhs { rw supr },
    rw [subideal.Sup_def, subtype.ext_iff,← coe_coe, coe_def, Sup_carrier_def, coe_mk,
      Sup_image, Sup_image, supr_range],
    have : ∀ (J : hI.sub_pd_ideal),
      ((⨆ (H : J ∈ S), (J : {B : ideal A // B ≤ I}) : {B : ideal A // B ≤ I} ) : ideal A) =
      (⨆ (H : J ∈ S), (J : ideal A)),
    { intro J,
      by_cases hJ : J ∈ S,
      { rw [csupr_pos hJ, csupr_pos hJ], refl },
      { simp only [hJ, supr_false, coe_eq_bot_iff, bot_le] }},
    simp_rw this,
    ext a,
    refine ⟨λ ha, ⟨ha, _⟩, λ ha, ha.1⟩,
    apply (submodule.mem_supr _).mp ha I,
    intro J,
    by_cases hJ : J ∈ S,
    { rw csupr_pos hJ, exact J.is_sub_ideal, },
    { simp only [hJ, supr_false, bot_le] }},
  { intro S,
    conv_rhs { rw infi },
    rw [subideal.Inf_def, subtype.ext_iff, ← coe_coe, coe_def, Inf_carrier_def, coe_mk,
      Inf_image, infi_range, infi_inf, infi_insert, inf_infi],
    apply infi_congr,
    intro J,
    by_cases hJ : J ∈ S,
    { rw [cinfi_pos hJ, cinfi_pos hJ, inf_comm], refl, },
    { simp only [hJ, infi_false, inf_top_eq, ← subideal.top_def, coe_mk, inf_idem], refl }}
end

end complete_lattice

section generated

/-- The sub-pd-ideal of I generated by a family of elements of A. -/
def generated (S : set A) : sub_pd_ideal hI :=
Inf { J : sub_pd_ideal hI | S ⊆ J.carrier }

/-- The sub-pd-ideal of I generated by the family `hI.dpow n x`, where `n ∈ ℕ ≥ 0` and `x ∈ S`. -/
def generated_dpow {S : set A} (hS : S ⊆ I) :
  sub_pd_ideal hI :=
{ carrier := ideal.span { y : A | ∃ (n : ℕ) (hn : n ≠ 0) (x : A) (hx : x ∈ S), y = hI.dpow n x },
  is_sub_ideal := generated_dpow_is_sub_ideal hI hS,
  dpow_mem_ideal := λ n hn z hz,
  begin
    have hSI := generated_dpow_is_sub_ideal hI hS,
    revert n,
    refine submodule.span_induction' _ _ _ _ hz,
    { -- Elements of S
      rintros y ⟨m, hm, x, hxS, hxy⟩ n hn,
      rw [hxy, hI.dpow_comp n hm (hS hxS)],
      exact ideal.mul_mem_left _ _ (ideal.subset_span ⟨n*m, mul_ne_zero hn hm, x, hxS, rfl⟩) },
    { -- Zero
      intros n hn,
      rw hI.dpow_eval_zero hn, exact ideal.zero_mem _ },
    { intros x hx y hy hx_pow hy_pow n hn,
      rw hI.dpow_add n (hSI hx) (hSI hy),
      apply submodule.sum_mem (ideal.span _),
      intros m hm,
      by_cases hm0 : m = 0,
      { rw hm0, exact ideal.mul_mem_left (ideal.span _) _ (hy_pow n hn), },
      { exact ideal.mul_mem_right _ (ideal.span _) (hx_pow m hm0), }, },
    { intros a x hx hx_pow n hn,
      rw [smul_eq_mul, hI.dpow_smul n (hSI hx)],
      exact ideal.mul_mem_left (ideal.span _) (a ^ n) (hx_pow n hn) }
  end }

lemma generated_dpow_carrier {S : set A} (hS : S ⊆ I) :
  (generated_dpow hI hS).carrier =
  ideal.span { y : A | ∃ (n : ℕ) (hn : n ≠ 0) (x : A) (hx : x ∈ S), y = hI.dpow n x } := rfl

lemma le_generated_dpow {S : set A} (hS : S ⊆ I) :
  S ⊆ (generated_dpow hI hS).carrier :=
λ x hx, ideal.subset_span ⟨1, one_ne_zero, x, hx, by rw hI.dpow_one (hS hx)⟩

lemma generated_dpow_le (S : set A) (J : sub_pd_ideal hI)
  (hSJ : S ⊆ J.carrier) :
  ideal.span { y : A | ∃ (n : ℕ) (hn : n ≠ 0) (x : A) (hx : x ∈ S), y = hI.dpow n x } ≤ J.carrier :=
begin
  rw ideal.span_le,
  rintros y ⟨n, hn, x, hx, hxy⟩,
  rw hxy,
  exact J.dpow_mem_ideal n hn x (hSJ hx),
end

lemma generated_carrier_eq {S : set A} (hS : S ⊆ I) :
  (generated hI S).carrier =
    ideal.span { y : A | ∃ (n : ℕ) (hn : n ≠ 0) (x : A) (hx : x ∈ S), y = hI.dpow n x } :=
begin
  simp only [generated, Inf_carrier_def],
  apply le_antisymm,
  { have h : generated_dpow hI hS ∈ insert ⊤ {J : hI.sub_pd_ideal | S ⊆ ↑(J.carrier)},
  { apply set.mem_insert_of_mem,
    simp only [set.mem_set_of_eq, generated_dpow_carrier],
    exact le_generated_dpow hI hS },
    refine Inf_le_of_le ⟨generated_dpow hI hS, _⟩ (le_refl _),
    simp only [h, cinfi_pos],
    refl },
  { rw le_infi₂_iff,
    rintros J hJ,
    refine generated_dpow_le hI S J _,
    cases set.mem_insert_iff.mp hJ with hJI hJS,
    { rw hJI, exact hS },
    { exact hJS }}
end

end generated

end sub_pd_ideal

namespace quot

variables {A : Type*} [comm_ring A] {I : ideal A} (hI : divided_powers I)

/- Tagged as noncomputable because it makes use of function.extend,
but under is_sub_pd_ideal hI (J ⊓ I), dpow_quot_eq proves that no choices are involved -/
/-- The definition of divided powers on A ⧸ J -/
noncomputable def dpow (J : ideal A) : ℕ → (A ⧸ J) → (A ⧸ J) :=
λ n, function.extend (λ a, ideal.quotient.mk J ↑a : I → A ⧸ J)
  (λ a, (ideal.quotient.mk J) (hI.dpow n a) : I → A ⧸ J) 0

variables {J : ideal A} (hIJ : is_sub_pd_ideal hI (J ⊓ I))

include hIJ

open_locale classical

/-- Divided powers on the quotient are compatible with quotient map -/
lemma dpow_eq {n : ℕ} {a : A} (ha : a ∈ I) :
  dpow hI J n (ideal.quotient.mk J a) = (ideal.quotient.mk J) (hI.dpow n a) :=
begin
  have ha' : ∃ (a' : ↥I), (ideal.quotient.mk J) ↑a' = (ideal.quotient.mk J) a := ⟨⟨a, ha⟩, rfl⟩,
  simp only [dpow],
  rw [ function.extend_def, dif_pos ha', ideal.quotient.eq],
  apply (is_sub_pd_ideal_inf_iff hI J).mp hIJ n _ _ (set_like.coe_mem _) ha,
  rw [← ideal.quotient.eq, classical.some_spec ha'],
end

-- We wish for a better API to denote I.map (ideal.quotient.mk J) as I ⧸ J
/-- When `I ⊓ J` is a `sub_pd_ideal` of `I`, the dpow map for the ideal `I(A⧸J)` of the quotient -/
noncomputable def divided_powers : divided_powers (I.map (ideal.quotient.mk J)) :=
{ dpow := dpow hI J,
  dpow_null := λ n x hx,
  begin
    simp only [dpow, function.extend_def],
    have ha' : ¬ ∃ (a' : ↥I), (ideal.quotient.mk J) ↑a' = x,
    { rintro ⟨a, rfl⟩,
      exact hx (ideal.apply_coe_mem_map (ideal.quotient.mk J) I a), },
    rw [dif_neg ha', pi.zero_apply],
  end,
  dpow_zero := λ x hx,
  begin
    obtain ⟨a, ha, hax⟩ :=
    (ideal.mem_map_iff_of_surjective _ (ideal.quotient.mk J).is_surjective).mp hx,
    rw [← hax, dpow_eq hI hIJ ha, hI.dpow_zero ha, map_one],
  end,
  dpow_one := λ x hx,
  begin
    obtain ⟨a, ha, hax⟩ :=
    (ideal.mem_map_iff_of_surjective _ (ideal.quotient.mk J).is_surjective).mp hx,
    rw [← hax, dpow_eq hI hIJ ha, hI.dpow_one ha],
  end,
  dpow_mem := λ n hn x hx,
  begin
    simp only [dpow], rw function.extend_def,
    split_ifs with ha,
    { rw [ideal.mem_quotient_iff_mem_sup],
      exact ideal.mem_sup_left (hI.dpow_mem hn (set_like.coe_mem _)) },
    { exact ideal.zero_mem _ }
  end,
  dpow_add := λ n x y hx hy,
  begin
    obtain ⟨a, ha, hax⟩ :=
    (ideal.mem_map_iff_of_surjective _ (ideal.quotient.mk J).is_surjective).mp hx,
    obtain ⟨b, hb, hby⟩ :=
    (ideal.mem_map_iff_of_surjective _ (ideal.quotient.mk J).is_surjective).mp hy,
    rw [← hax, ← hby, ← map_add, dpow_eq hI hIJ (I.add_mem ha hb), hI.dpow_add n ha hb,
      map_sum,
 finset.sum_congr rfl],
    { intros k hk,
      rw [dpow_eq hI hIJ ha, dpow_eq hI hIJ hb, ← map_mul] },
  end,
  dpow_smul := λ n x y hy,
  begin
    obtain ⟨a, rfl⟩ := ideal.quotient.mk_surjective x,
    obtain ⟨b, hb, hby⟩ :=
    (ideal.mem_map_iff_of_surjective _ (ideal.quotient.mk J).is_surjective).mp hy,
    rw [← hby, dpow_eq hI hIJ hb, ← map_mul, ← map_pow, dpow_eq hI hIJ (ideal.mul_mem_left I a hb),
      hI.dpow_smul n hb, map_mul],
    end,
  dpow_mul := λ m n x hx,
  begin
    obtain ⟨a, ha, hax⟩ :=
    (ideal.mem_map_iff_of_surjective _ (ideal.quotient.mk J).is_surjective).mp hx,
    simp only [← hax, dpow_eq hI hIJ ha],
    rw [← map_mul, hI.dpow_mul m n ha, map_mul, map_nat_cast],
  end,
  dpow_comp := λ m n hn x hx,
  begin
    obtain ⟨a, ha, hax⟩ :=
    (ideal.mem_map_iff_of_surjective _ (ideal.quotient.mk J).is_surjective).mp hx,
    simp only [← hax, dpow_eq hI hIJ, ha, hI.dpow_mem hn ha],
    rw [hI.dpow_comp m hn ha, map_mul, map_nat_cast],
  end }

lemma divided_powers_dpow_quot_apply {n : ℕ} {x : A ⧸ J} :
  (divided_powers hI hIJ).dpow n x = dpow hI J n x :=
rfl

lemma divided_powers_quot_unique (hquot : _root_.divided_powers (I.map (ideal.quotient.mk J)))
  (hm : is_pd_morphism hI hquot (ideal.quotient.mk J)) :
  hquot = divided_powers hI hIJ := eq_of_eq_on_ideal _ _ $ λ n x hx,
begin
  obtain ⟨a, ha, hax⟩ :=
  (ideal.mem_map_iff_of_surjective _ (ideal.quotient.mk J).is_surjective).mp hx,
  rw [← hax, hm.dpow_comp n a ha, divided_powers_dpow_quot_apply, dpow_eq hI hIJ ha],
end

end quot

end divided_powers