/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau

Free abelian groups as abelianization of free groups.

-- TODO: rewrite in terms of finsupp
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.group.pi
import Mathlib.group_theory.free_group
import Mathlib.group_theory.abelianization
import Mathlib.PostPort

universes u v u_1 u_2 u_3

namespace Mathlib

def free_abelian_group (α : Type u) := additive (abelianization (free_group α))

protected instance free_abelian_group.add_comm_group (α : Type u) :
    add_comm_group (free_abelian_group α) :=
  additive.add_comm_group

protected instance free_abelian_group.inhabited (α : Type u) : Inhabited (free_abelian_group α) :=
  { default := 0 }

namespace free_abelian_group

def of {α : Type u} (x : α) : free_abelian_group α := coe_fn abelianization.of (free_group.of x)

def lift {α : Type u} {β : Type v} [add_comm_group β] (f : α → β) : free_abelian_group α →+ β :=
  coe_fn monoid_hom.to_additive (abelianization.lift (monoid_hom.of ⇑(free_group.to_group f)))

namespace lift

@[simp] protected theorem add {α : Type u} {β : Type v} [add_comm_group β] (f : α → β)
    (x : free_abelian_group α) (y : free_abelian_group α) :
    coe_fn (lift f) (x + y) = coe_fn (lift f) x + coe_fn (lift f) y :=
  is_add_hom.map_add (⇑(lift f)) x y

@[simp] protected theorem neg {α : Type u} {β : Type v} [add_comm_group β] (f : α → β)
    (x : free_abelian_group α) : coe_fn (lift f) (-x) = -coe_fn (lift f) x :=
  is_add_group_hom.map_neg (⇑(lift f)) x

@[simp] protected theorem sub {α : Type u} {β : Type v} [add_comm_group β] (f : α → β)
    (x : free_abelian_group α) (y : free_abelian_group α) :
    coe_fn (lift f) (x - y) = coe_fn (lift f) x - coe_fn (lift f) y :=
  sorry

@[simp] protected theorem zero {α : Type u} {β : Type v} [add_comm_group β] (f : α → β) :
    coe_fn (lift f) 0 = 0 :=
  is_add_group_hom.map_zero ⇑(lift f)

@[simp] protected theorem of {α : Type u} {β : Type v} [add_comm_group β] (f : α → β) (x : α) :
    coe_fn (lift f) (of x) = f x :=
  sorry

protected theorem unique {α : Type u} {β : Type v} [add_comm_group β] (f : α → β)
    (g : free_abelian_group α →+ β) (hg : ∀ (x : α), coe_fn g (of x) = f x)
    {x : free_abelian_group α} : coe_fn g x = coe_fn (lift f) x :=
  abelianization.lift.unique (monoid_hom.of ⇑(free_group.to_group f))
    (coe_fn add_monoid_hom.to_multiplicative g)
    fun (x : free_group α) =>
      free_group.to_group.unique
        (monoid_hom.comp (coe_fn add_monoid_hom.to_multiplicative' g) abelianization.of) hg

/-- See note [partially-applied ext lemmas]. -/
protected theorem ext {α : Type u} {β : Type v} [add_comm_group β] (g : free_abelian_group α →+ β)
    (h : free_abelian_group α →+ β) (H : ∀ (x : α), coe_fn g (of x) = coe_fn h (of x)) : g = h :=
  sorry

theorem map_hom {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group β] [add_comm_group γ]
    (a : free_abelian_group α) (f : α → β) (g : β →+ γ) :
    coe_fn g (coe_fn (lift f) a) = coe_fn (lift (⇑g ∘ f)) a :=
  sorry

end lift

theorem of_injective {α : Type u} : function.injective of := sorry

/-- The bijection underlying the free-forgetful adjunction for abelian groups.-/
def hom_equiv (X : Type u_1) (G : Type u_2) [add_comm_group G] :
    (free_abelian_group X →+ G) ≃ (X → G) :=
  equiv.mk (fun (f : free_abelian_group X →+ G) => add_monoid_hom.to_fun f ∘ of)
    (fun (f : X → G) => add_monoid_hom.of ⇑(lift f)) sorry sorry

@[simp] theorem hom_equiv_apply (X : Type u_1) (G : Type u_2) [add_comm_group G]
    (f : free_abelian_group X →+ G) (x : X) : coe_fn (hom_equiv X G) f x = coe_fn f (of x) :=
  rfl

@[simp] theorem hom_equiv_symm_apply (X : Type u_1) (G : Type u_2) [add_comm_group G] (f : X → G)
    (x : free_abelian_group X) :
    coe_fn (coe_fn (equiv.symm (hom_equiv X G)) f) x = coe_fn (lift f) x :=
  rfl

protected theorem induction_on {α : Type u} {C : free_abelian_group α → Prop}
    (z : free_abelian_group α) (C0 : C 0) (C1 : ∀ (x : α), C (of x))
    (Cn : ∀ (x : α), C (of x) → C (-of x))
    (Cp : ∀ (x y : free_abelian_group α), C x → C y → C (x + y)) : C z :=
  sorry

theorem lift.add' {α : Type u_1} {β : Type u_2} [add_comm_group β] (a : free_abelian_group α)
    (f : α → β) (g : α → β) : coe_fn (lift (f + g)) a = coe_fn (lift f) a + coe_fn (lift g) a :=
  sorry

protected instance is_add_group_hom_lift' {α : Type u_1} (β : Type u_2) [add_comm_group β]
    (a : free_abelian_group α) : is_add_group_hom fun (f : α → β) => coe_fn (lift f) a :=
  is_add_group_hom.mk

protected instance monad : Monad free_abelian_group := sorry

protected theorem induction_on' {α : Type u} {C : free_abelian_group α → Prop}
    (z : free_abelian_group α) (C0 : C 0) (C1 : ∀ (x : α), C (pure x))
    (Cn : ∀ (x : α), C (pure x) → C (-pure x))
    (Cp : ∀ (x y : free_abelian_group α), C x → C y → C (x + y)) : C z :=
  free_abelian_group.induction_on z C0 C1 Cn Cp

@[simp] theorem map_pure {α : Type u} {β : Type u} (f : α → β) (x : α) :
    f <$> pure x = pure (f x) :=
  lift.of (of ∘ f) x

@[simp] theorem map_zero {α : Type u} {β : Type u} (f : α → β) : f <$> 0 = 0 := lift.zero (of ∘ f)

@[simp] theorem map_add {α : Type u} {β : Type u} (f : α → β) (x : free_abelian_group α)
    (y : free_abelian_group α) : f <$> (x + y) = f <$> x + f <$> y :=
  lift.add (of ∘ f) x y

@[simp] theorem map_neg {α : Type u} {β : Type u} (f : α → β) (x : free_abelian_group α) :
    f <$> (-x) = -f <$> x :=
  lift.neg (of ∘ f) x

@[simp] theorem map_sub {α : Type u} {β : Type u} (f : α → β) (x : free_abelian_group α)
    (y : free_abelian_group α) : f <$> (x - y) = f <$> x - f <$> y :=
  lift.sub (of ∘ f) x y

@[simp] theorem map_of {α : Type u} {β : Type u} (f : α → β) (y : α) : f <$> of y = of (f y) := rfl

/-- The additive group homomorphism `free_abelian_group α →+ free_abelian_group β` induced from a
  map `α → β` -/
def map {α : Type u} {β : Type u} (f : α → β) : free_abelian_group α →+ free_abelian_group β :=
  add_monoid_hom.mk' (fun (x : free_abelian_group α) => f <$> x) (map_add f)

theorem lift_comp {α : Type u_1} {β : Type u_1} {γ : Type u_2} [add_comm_group γ] (f : α → β)
    (g : β → γ) (x : free_abelian_group α) : coe_fn (lift (g ∘ f)) x = coe_fn (lift g) (f <$> x) :=
  sorry

@[simp] theorem pure_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β) (x : α) :
    pure x >>= f = f x :=
  lift.of f x

@[simp] theorem zero_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β) : 0 >>= f = 0 :=
  lift.zero f

@[simp] theorem add_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β)
    (x : free_abelian_group α) (y : free_abelian_group α) : x + y >>= f = (x >>= f) + (y >>= f) :=
  lift.add f x y

@[simp] theorem neg_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β)
    (x : free_abelian_group α) : -x >>= f = -(x >>= f) :=
  lift.neg f x

@[simp] theorem sub_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β)
    (x : free_abelian_group α) (y : free_abelian_group α) : x - y >>= f = (x >>= f) - (y >>= f) :=
  lift.sub f x y

@[simp] theorem pure_seq {α : Type u} {β : Type u} (f : α → β) (x : free_abelian_group α) :
    pure f <*> x = f <$> x :=
  pure_bind
    (fun (_x : α → β) =>
      (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x
        x)
    f

@[simp] theorem zero_seq {α : Type u} {β : Type u} (x : free_abelian_group α) : 0 <*> x = 0 :=
  zero_bind
    fun (_x : α → β) =>
      (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x
        x

@[simp] theorem add_seq {α : Type u} {β : Type u} (f : free_abelian_group (α → β))
    (g : free_abelian_group (α → β)) (x : free_abelian_group α) :
    f + g <*> x = (f <*> x) + (g <*> x) :=
  add_bind
    (fun (_x : α → β) =>
      (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x
        x)
    f g

@[simp] theorem neg_seq {α : Type u} {β : Type u} (f : free_abelian_group (α → β))
    (x : free_abelian_group α) : -f <*> x = -(f <*> x) :=
  neg_bind
    (fun (_x : α → β) =>
      (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x
        x)
    f

@[simp] theorem sub_seq {α : Type u} {β : Type u} (f : free_abelian_group (α → β))
    (g : free_abelian_group (α → β)) (x : free_abelian_group α) :
    f - g <*> x = (f <*> x) - (g <*> x) :=
  sub_bind
    (fun (_x : α → β) =>
      (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x
        x)
    f g

protected instance is_add_group_hom_seq {α : Type u} {β : Type u} (f : free_abelian_group (α → β)) :
    is_add_group_hom (Seq.seq f) :=
  is_add_group_hom.mk

@[simp] theorem seq_zero {α : Type u} {β : Type u} (f : free_abelian_group (α → β)) : f <*> 0 = 0 :=
  is_add_group_hom.map_zero (Seq.seq f)

@[simp] theorem seq_add {α : Type u} {β : Type u} (f : free_abelian_group (α → β))
    (x : free_abelian_group α) (y : free_abelian_group α) : f <*> x + y = (f <*> x) + (f <*> y) :=
  is_add_hom.map_add (Seq.seq f) x y

@[simp] theorem seq_neg {α : Type u} {β : Type u} (f : free_abelian_group (α → β))
    (x : free_abelian_group α) : f <*> -x = -(f <*> x) :=
  is_add_group_hom.map_neg (Seq.seq f) x

@[simp] theorem seq_sub {α : Type u} {β : Type u} (f : free_abelian_group (α → β))
    (x : free_abelian_group α) (y : free_abelian_group α) : f <*> x - y = (f <*> x) - (f <*> y) :=
  is_add_group_hom.map_sub (Seq.seq f) x y

protected instance is_lawful_monad : is_lawful_monad free_abelian_group := sorry

protected instance is_comm_applicative : is_comm_applicative free_abelian_group := sorry

protected instance semigroup (α : Type u) [monoid α] : semigroup (free_abelian_group α) :=
  semigroup.mk
    (fun (x : free_abelian_group α) =>
      ⇑(lift fun (x₂ : α) => coe_fn (lift fun (x₁ : α) => of (x₁ * x₂)) x))
    sorry

theorem mul_def (α : Type u) [monoid α] (x : free_abelian_group α) (y : free_abelian_group α) :
    x * y = coe_fn (lift fun (x₂ : α) => coe_fn (lift fun (x₁ : α) => of (x₁ * x₂)) x) y :=
  rfl

theorem of_mul_of (α : Type u) [monoid α] (x : α) (y : α) : of x * of y = of (x * y) := rfl

theorem of_mul (α : Type u) [monoid α] (x : α) (y : α) : of (x * y) = of x * of y := rfl

protected instance ring (α : Type u) [monoid α] : ring (free_abelian_group α) :=
  ring.mk add_comm_group.add sorry add_comm_group.zero sorry sorry add_comm_group.neg
    add_comm_group.sub sorry sorry semigroup.mul sorry (of 1) sorry sorry sorry sorry

theorem one_def (α : Type u) [monoid α] : 1 = of 1 := rfl

theorem of_one (α : Type u) [monoid α] : of 1 = 1 := rfl

protected instance comm_ring (α : Type u) [comm_monoid α] : comm_ring (free_abelian_group α) :=
  comm_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry
    ring.one sorry sorry sorry sorry sorry

end Mathlib


--
-- The Falso HyperProver in Lean. Why bother with another axiom system?
-- (c) Copyright 2018 Michael Jendrusch
--
-- For details about the copyright, see the file
-- LICENSE, included in this distribution.
--

import falso.hyperprover

-- As a small example of the immense reasoning power of
-- the Falso (TM) system, we shall prove Fermat's theorem.
def fermat_true (n : ℕ) : Prop :=
n > 2 → ¬(
    ∃ x y z : ℕ,
    x > 0 ∧
    y > 0 ∧
    z > 0 ∧
    x^n + y^n = z^n
)

-- And that's it for the proof.
theorem Fermat (n : ℕ) : fermat_true n :=
by falso.hyperprove
-- Equivalent:
-- falso.prove (fermat_true n)

-- QED.


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.semiquot
import data.rat.floor
/-!
# Implementation of floating-point numbers (experimental).

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

def int.shift2 (a b : ℕ) : ℤ → ℕ × ℕ
| (int.of_nat e) := (a.shiftl e, b)
| -[1+ e] := (a, b.shiftl e.succ)

namespace fp

@[derive inhabited]
inductive rmode
| NE -- round to nearest even

class float_cfg :=
(prec emax : ℕ)
(prec_pos : 0 < prec)
(prec_max : prec ≤ emax)

variable [C : float_cfg]
include C

def prec := C.prec
def emax := C.emax
def emin : ℤ := 1 - C.emax

def valid_finite (e : ℤ) (m : ℕ) : Prop :=
emin ≤ e + prec - 1 ∧ e + prec - 1 ≤ emax ∧ e = max (e + m.size - prec) emin

instance dec_valid_finite (e m) : decidable (valid_finite e m) :=
by unfold valid_finite; apply_instance

inductive float
| inf : bool → float
| nan : float
| finite : bool → Π e m, valid_finite e m → float

def float.is_finite : float → bool
| (float.finite s e m f) := tt
| _ := ff

def to_rat : Π (f : float), f.is_finite → ℚ
| (float.finite s e m f) _ :=
  let (n, d) := int.shift2 m 1 e,
      r := rat.mk_nat n d in
  if s then -r else r

theorem float.zero.valid : valid_finite emin 0 :=
⟨begin
  rw add_sub_assoc,
  apply le_add_of_nonneg_right,
  apply sub_nonneg_of_le,
  apply int.coe_nat_le_coe_nat_of_le,
  exact C.prec_pos
end,
suffices prec ≤ 2 * emax,
begin
  rw ← int.coe_nat_le at this,
  rw ← sub_nonneg at *,
  simp only [emin, emax] at *,
  ring_nf,
  assumption
end, le_trans C.prec_max (nat.le_mul_of_pos_left dec_trivial),
by rw max_eq_right; simp [sub_eq_add_neg]⟩

def float.zero (s : bool) : float :=
float.finite s emin 0 float.zero.valid

instance : inhabited float := ⟨float.zero tt⟩

protected def float.sign' : float → semiquot bool
| (float.inf s) := pure s
| float.nan := ⊤
| (float.finite s e m f) := pure s

protected def float.sign : float → bool
| (float.inf s) := s
| float.nan := ff
| (float.finite s e m f) := s

protected def float.is_zero : float → bool
| (float.finite s e 0 f) := tt
| _ := ff

protected def float.neg : float → float
| (float.inf s) := float.inf (bnot s)
| float.nan := float.nan
| (float.finite s e m f) := float.finite (bnot s) e m f

def div_nat_lt_two_pow (n d : ℕ) : ℤ → bool
| (int.of_nat e) := n < d.shiftl e
| -[1+ e] := n.shiftl e.succ < d

-- TODO(Mario): Prove these and drop 'meta'
meta def of_pos_rat_dn (n : ℕ+) (d : ℕ+) : float × bool :=
begin
  let e₁ : ℤ := n.1.size - d.1.size - prec,
  cases h₁ : int.shift2 d.1 n.1 (e₁ + prec) with d₁ n₁,
  let e₂ := if n₁ < d₁ then e₁ - 1 else e₁,
  let e₃ := max e₂ emin,
  cases h₂ : int.shift2 d.1 n.1 (e₃ + prec) with d₂ n₂,
  let r := rat.mk_nat n₂ d₂,
  let m := r.floor,
  refine (float.finite ff e₃ (int.to_nat m) _, r.denom = 1),
  { exact undefined }
end

meta def next_up_pos (e m) (v : valid_finite e m) : float :=
let m' := m.succ in
if ss : m'.size = m.size then
  float.finite ff e m' (by unfold valid_finite at *; rw ss; exact v)
else if h : e = emax then
  float.inf ff
else
  float.finite ff e.succ (nat.div2 m') undefined

meta def next_dn_pos (e m) (v : valid_finite e m) : float :=
match m with
| 0 := next_up_pos _ _ float.zero.valid
| nat.succ m' :=
  if ss : m'.size = m.size then
    float.finite ff e m' (by unfold valid_finite at *; rw ss; exact v)
  else if h : e = emin then
    float.finite ff emin m' undefined
  else
    float.finite ff e.pred (bit1 m') undefined
end

meta def next_up : float → float
| (float.finite ff e m f) := next_up_pos e m f
| (float.finite tt e m f) := float.neg $ next_dn_pos e m f
| f := f

meta def next_dn : float → float
| (float.finite ff e m f) := next_dn_pos e m f
| (float.finite tt e m f) := float.neg $ next_up_pos e m f
| f := f

meta def of_rat_up : ℚ → float
| ⟨0, _, _, _⟩          := float.zero ff
| ⟨nat.succ n, d, h, _⟩ :=
  let (f, exact) := of_pos_rat_dn n.succ_pnat ⟨d, h⟩ in
  if exact then f else next_up f
| ⟨-[1+n], d, h, _⟩     := float.neg (of_pos_rat_dn n.succ_pnat ⟨d, h⟩).1

meta def of_rat_dn (r : ℚ) : float :=
float.neg $ of_rat_up (-r)

meta def of_rat : rmode → ℚ → float
| rmode.NE r :=
  let low := of_rat_dn r, high := of_rat_up r in
  if hf : high.is_finite then
    if r = to_rat _ hf then high else
    if lf : low.is_finite then
      if r - to_rat _ lf > to_rat _ hf - r then high else
      if r - to_rat _ lf < to_rat _ hf - r then low else
      match low, lf with float.finite s e m f, _ :=
        if 2 ∣ m then low else high
      end
    else float.inf tt
  else float.inf ff

namespace float

instance : has_neg float := ⟨float.neg⟩

meta def add (mode : rmode) : float → float → float
| nan      _        := nan
| _        nan      := nan
| (inf tt) (inf ff) := nan
| (inf ff) (inf tt) := nan
| (inf s₁) _        := inf s₁
| _        (inf s₂) := inf s₂
| (finite s₁ e₁ m₁ v₁) (finite s₂ e₂ m₂ v₂) :=
  let f₁ := finite s₁ e₁ m₁ v₁, f₂ := finite s₂ e₂ m₂ v₂ in
  of_rat mode (to_rat f₁ rfl + to_rat f₂ rfl)

meta instance : has_add float := ⟨float.add rmode.NE⟩

meta def sub (mode : rmode) (f1 f2 : float) : float :=
add mode f1 (-f2)

meta instance : has_sub float := ⟨float.sub rmode.NE⟩

meta def mul (mode : rmode) : float → float → float
| nan      _        := nan
| _        nan      := nan
| (inf s₁) f₂       := if f₂.is_zero then nan else inf (bxor s₁ f₂.sign)
| f₁       (inf s₂) := if f₁.is_zero then nan else inf (bxor f₁.sign s₂)
| (finite s₁ e₁ m₁ v₁) (finite s₂ e₂ m₂ v₂) :=
  let f₁ := finite s₁ e₁ m₁ v₁, f₂ := finite s₂ e₂ m₂ v₂ in
  of_rat mode (to_rat f₁ rfl * to_rat f₂ rfl)

meta def div (mode : rmode) : float → float → float
| nan      _        := nan
| _        nan      := nan
| (inf s₁) (inf s₂) := nan
| (inf s₁) f₂       := inf (bxor s₁ f₂.sign)
| f₁       (inf s₂) := zero (bxor f₁.sign s₂)
| (finite s₁ e₁ m₁ v₁) (finite s₂ e₂ m₂ v₂) :=
  let f₁ := finite s₁ e₁ m₁ v₁, f₂ := finite s₂ e₂ m₂ v₂ in
  if f₂.is_zero then inf (bxor s₁ s₂) else
  of_rat mode (to_rat f₁ rfl / to_rat f₂ rfl)

end float

end fp


import algebraic_geometry.pullbacks
import algebraic_geometry.AffineScheme
import linear_algebra.tensor_product_basis
import algebraic_geometry.misc

open opposite topological_space category_theory category_theory.limits

open local_ring (closed_point)

namespace algebraic_geometry

universe u

noncomputable theory

section local_ring_to_Scheme

variables {R : CommRing.{u}} [local_ring R] (X : Scheme.{u}) (f : Scheme.Spec.obj (op R) ⟶ X)

lemma CommRing.of_eq (R : CommRing) : CommRing.of R = R :=
by { cases R, refl }

lemma is_localization.at_prime.comap_maximal_ideal {R : Type*} (S : Type*) [comm_ring R] [comm_ring S]
  (I : ideal R) [I.is_prime] [algebra R S] [is_localization.at_prime S I] [local_ring S] :
  (local_ring.maximal_ideal S).comap (algebra_map R S) = I :=
ideal.ext $ λ x, by
simpa only [ideal.mem_comap] using is_localization.at_prime.to_map_mem_maximal_iff _ I x

lemma local_ring.specializes_closed_point {R : Type*} [comm_ring R] [local_ring R]
  (x : prime_spectrum R) :
  x ⤳ closed_point R :=
begin
  rw ← prime_spectrum.le_iff_specializes,
  exact local_ring.le_maximal_ideal x.2.1,
end

lemma local_ring.closed_point_mem_iff {R : Type*} [comm_ring R] [local_ring R]
  (U : opens $ prime_spectrum R) :
  closed_point R ∈ U ↔ U = ⊤ :=
begin
  split,
  { rw eq_top_iff, exact λ h x _, (local_ring.specializes_closed_point x).mem_open U.2 h },
  { rintro rfl, trivial }
end

lemma _root_.ring.is_field_iff_forall_ideal_eq {R : Type*} [comm_ring R] [nontrivial R] :
  is_field R ↔ ∀ I : ideal R, I = ⊥ ∨ I = ⊤ :=
begin
  rw [← not_iff_not, ring.not_is_field_iff_exists_ideal_bot_lt_and_lt_top],
  push_neg,
  simp_rw [lt_top_iff_ne_top, bot_lt_iff_ne_bot],
end

lemma field.ideal_eq {R : Type*} [field R] (I : ideal R) :
  I = ⊥ ∨ I = ⊤ :=
ring.is_field_iff_forall_ideal_eq.mp (field.to_is_field R) I

lemma _root_.local_ring.is_field_iff_maximal_ideal_eq {R : Type*} [comm_ring R] [local_ring R] :
  is_field R ↔ local_ring.maximal_ideal R = ⊥ :=
begin
  simp_rw [ring.is_field_iff_forall_ideal_eq, or_iff_not_imp_right],
  exact ⟨λ H, H (local_ring.maximal_ideal R) (ideal.is_prime.ne_top infer_instance),
    λ e I hI, eq_bot_iff.mpr (e ▸ local_ring.le_maximal_ideal hI)⟩,
end

instance {R : Type*} [comm_ring R] [is_domain R] : order_bot (prime_spectrum R) :=
{ bot := ⟨⊥, ideal.bot_prime⟩, bot_le := λ I, @bot_le _ _ _ I.as_ideal }

instance {R : Type*} [field R] : unique (prime_spectrum R) :=
{ default := ⊥,
  uniq := λ x, subtype.ext
    ((field.ideal_eq x.as_ideal).resolve_right (ideal.is_prime.ne_top infer_instance)) }

lemma _root_.prime_spectrum.comap_residue {R : Type*} [comm_ring R] [local_ring R]
  (I : prime_spectrum (local_ring.residue_field R)) :
  prime_spectrum.comap (local_ring.residue R) I = local_ring.closed_point R :=
begin
  have : I = ⊥ := subsingleton.elim _ _,
  subst this,
  ext1,
  exact ideal.mk_ker,
end

lemma local_ring.maximal_ideal_eq_bot {R : Type*} [field R] : local_ring.maximal_ideal R = ⊥ :=
local_ring.is_field_iff_maximal_ideal_eq.mp (field.to_is_field R)

def local_ring.lift_residue_field {R S : Type*} [comm_ring R] [local_ring R] [field S]
  (f : R →+* S) [is_local_ring_hom f] : local_ring.residue_field R →+* S :=
ideal.quotient.lift _ f (λ a ha,
  classical.by_contradiction (λ h, ha (is_unit_of_map_unit f a (is_unit_iff_ne_zero.mpr h))))

lemma local_ring.lift_residue_field_comp {R S : Type*} [comm_ring R] [local_ring R] [field S]
  (f : R →+* S) [is_local_ring_hom f] : local_ring.residue_field R →+* S :=
ideal.quotient.lift _ f (λ a ha,
  classical.by_contradiction (λ h, ha (is_unit_of_map_unit f a (is_unit_iff_ne_zero.mpr h))))

instance {R S : Type*} [field R] [comm_ring S] [nontrivial S] (f : R →+* S) :
  is_local_ring_hom f :=
⟨λ a ha, is_unit_iff_ne_zero.mpr (λ e, @not_is_unit_zero S _ _ $ by rwa [← map_zero f, ← e])⟩

instance {R : Type*} [comm_ring R] [local_ring R] :
  is_local_ring_hom (local_ring.residue R) :=
⟨λ a ha, not_not.mp (ideal.quotient.eq_zero_iff_mem.not.mp (is_unit_iff_ne_zero.mp ha))⟩

open topological_space

variables {X}

lemma is_affine_open.map_from_Spec {U V : opens X.carrier} (h : op U ⟶ op V)
  (hU : is_affine_open U) (hV : is_affine_open V) :
  Scheme.Spec.map (X.presheaf.map h).op ≫ hU.from_Spec = hV.from_Spec :=
begin
  delta is_affine_open.from_Spec Scheme.iso_Spec,
  rw ← is_iso.inv_comp_eq,
  rw iso.eq_inv_comp,
  simp only [← functor.map_inv, ← op_inv, eq_to_hom_op, inv_eq_to_hom,
    ← functor.map_comp_assoc, ← op_comp, ← functor.map_comp],
  rw [as_iso_hom, as_iso_inv, ← category.assoc],
  have e := (Γ_Spec.adjunction.unit.naturality (X.restrict_functor.map h.unop).1),
  rw [functor.id_map, category_theory.functor.comp_map, functor.right_op_map,
    Scheme.Γ_map_op, X.restrict_functor_map_app] at e,
  dsimp only [Scheme.restrict_functor, unop_op, over.mk, costructured_arrow.mk] at e,
  erw ← e,
  rw [category.assoc, is_iso.hom_inv_id_assoc, over.hom_mk_left, is_open_immersion.lift_fac],
end

def is_affine_open.from_Spec_stalk {U : opens X.carrier} (hU : is_affine_open U) {x : X.carrier}
  (hxU : x ∈ U) :
  Scheme.Spec.obj (op $ X.presheaf.stalk x) ⟶ X :=
Scheme.Spec.map (X.presheaf.germ ⟨x, hxU⟩).op ≫ hU.from_Spec

lemma from_Spec_stalk_eq (x : X.carrier) {U V : opens X.carrier}
  (hU : is_affine_open U) (hV : is_affine_open V) (hxU : x ∈ U) (hxV : x ∈ V) :
    hU.from_Spec_stalk hxU = hV.from_Spec_stalk hxV :=
begin
  obtain ⟨U', h₁, h₂, h₃ : U' ≤ U ⊓ V⟩ :=
    opens.is_basis_iff_nbhd.mp (is_basis_affine_open X) (show x ∈ U ⊓ V, from ⟨hxU, hxV⟩),
  transitivity h₁.from_Spec_stalk h₂; delta is_affine_open.from_Spec_stalk,
  { rw [← hU.map_from_Spec (hom_of_le $ h₃.trans inf_le_left).op h₁, ← functor.map_comp_assoc,
      ← op_comp, Top.presheaf.germ_res], refl },
  { rw [← hV.map_from_Spec (hom_of_le $ h₃.trans inf_le_right).op h₁, ← functor.map_comp_assoc,
      ← op_comp, Top.presheaf.germ_res], refl },
end

def Scheme.from_Spec_stalk (X : Scheme) (x : X.carrier) :
  Scheme.Spec.obj (op $ X.presheaf.stalk x) ⟶ X :=
(range_is_affine_open_of_open_immersion $ X.affine_cover.map x).from_Spec_stalk
  (X.affine_cover.covers x)

lemma is_affine_open.from_Spec_stalk_eq {X : Scheme} {U : opens X.carrier} (hU : is_affine_open U)
  (x ∈ U) :
  hU.from_Spec_stalk H = X.from_Spec_stalk x :=
from_Spec_stalk_eq _ _ _ _ _

@[instance]
lemma Scheme.mono_from_Spec_stalk {X : Scheme} (x : X.carrier) : mono (X.from_Spec_stalk x) :=
begin
  apply_with mono_comp { instances := ff },
  swap, { apply_instance },
  apply_with functor.map_mono { instances := ff },
  { apply_instance },
  apply_with category_theory.op_mono_of_epi { instances := ff },
  have := (range_is_affine_open_of_open_immersion (X.affine_cover.map x)).is_localization_stalk
      ⟨x, X.affine_cover.covers x⟩,
  convert @is_localization.epi _ _ _ _ _ _ this,
  { exact (CommRing.of_eq _).symm },
  { exact (CommRing.of_eq _).symm }
end

lemma is_affine_open.from_Spec_stalk_closed_point {U : opens X.carrier} (hU : is_affine_open U)
  {x : X.carrier} (hxU : x ∈ U) :
  (hU.from_Spec_stalk hxU).1.base (closed_point (X.presheaf.stalk x) : _) = x :=
begin
  letI : is_affine _ := hU,
  rw [is_affine_open.from_Spec_stalk, is_affine_open.from_Spec, ← functor.map_comp_assoc,
    ← op_comp, Top.presheaf.germ_res],
  simp only [Top.comp_app, Scheme.of_restrict_val_base,
    quiver.hom.unop_op, Scheme.comp_coe_base, Scheme.Spec_map_2,
    eq_to_hom_op, opens.inclusion_apply],
  refine eq.trans _ (subtype.coe_mk x hxU),
  congr' 1,
  have : function.injective (X.restrict U.open_embedding).iso_Spec.hom.val.base,
  { rw ← Top.mono_iff_injective, apply_instance },
  apply this,
  convert_to ((X.restrict _).iso_Spec.inv ≫ (X.restrict _).iso_Spec.hom).val.base _ = _,
  rw [iso.inv_hom_id, Scheme.id_val_base, id_apply, Scheme.iso_Spec,
    as_iso_hom, Γ_Spec.adjunction_unit_app_base_apply, LocallyRingedSpace.Γ_to_stalk],
  erw [← PresheafedSpace.restrict_stalk_iso_inv_eq_germ, prime_spectrum.comap_comp],
  rw [continuous_map.comp_apply, local_ring.comap_closed_point],
  refl
end

lemma Scheme.from_Spec_stalk_closed_point (x : X.carrier) :
  (X.from_Spec_stalk x).1.base (closed_point (X.presheaf.stalk x) : _) = x :=
is_affine_open.from_Spec_stalk_closed_point _ _

lemma Scheme.range_from_Spec_stalk (X : Scheme) (x : X.carrier) :
  set.range (X.from_Spec_stalk x).1.base = { y | y ⤳ x } :=
begin
  apply le_antisymm,
  { rintros _ ⟨y, rfl⟩,
    dsimp at y,
    change _ ⤳ x,
    convert (local_ring.specializes_closed_point y).map (X.from_Spec_stalk x).1.base.2,
    exact (Scheme.from_Spec_stalk_closed_point x).symm },
  { rintros y (h : y ⤳ x),
    have h' := h,
    conv_rhs at h { rw ← Scheme.from_Spec_stalk_closed_point x },
    rw [Scheme.from_Spec_stalk, is_affine_open.from_Spec_stalk, Scheme.comp_val_base] at h ⊢,
    generalize_proofs _ _ hx hU,
    change x ∈ (X.affine_cover.map x).opens_range at hx,
    have hyU : y ∈ ((X.affine_cover.map x).opens_range : set X.carrier) :=
      h'.mem_open ((X.affine_cover.map x).opens_range.2) (X.affine_cover.covers x),
    rw [← hU.from_Spec_range] at hyU,
    obtain ⟨y', rfl⟩ := hyU,
    rw [coe_comp, set.range_comp],
    apply set.mem_image_of_mem,
    replace h := PresheafedSpace.is_open_immersion.base_open.to_inducing.specializes_iff.mp h,
    rw ← prime_spectrum.le_iff_specializes at h,
    haveI H := hU.is_localization_stalk ⟨x, hx⟩,
    erw @@prime_spectrum.localization_comap_range _ _ _ _ _ H,
    dsimp,
    apply set.subset_compl_iff_disjoint_left.mp,
    erw compl_compl,
    change y'.as_ideal ≤ (hU.prime_ideal_of ⟨x, hx⟩).as_ideal,
    convert h,
    ext1,
    exact (@@is_localization.at_prime.comap_maximal_ideal _ _ _ _ _ _ H _).symm }
end

def stalk_closed_point_to (R : CommRing) [local_ring R]
  (f : Scheme.Spec.obj (op R) ⟶ X) :
  X.presheaf.stalk (f.1.base (closed_point R : _)) ⟶ R :=
PresheafedSpace.stalk_map f.1 (closed_point R : _) ≫
  structure_sheaf.stalk_to_fiber_ring_hom R _ ≫
begin
  refine (@ring_equiv.to_CommRing_iso R
    (localization.at_prime (closed_point R).as_ideal) _ _ _).inv,
  refine (is_localization.at_units _
    (closed_point R).as_ideal.prime_compl _ _).to_ring_equiv,
  exact λ x, not_not.mp x.2,
end

instance (R : CommRing) [local_ring R]
  (f : Scheme.Spec.obj (op R) ⟶ X) : is_local_ring_hom (stalk_closed_point_to R f) :=
is_local_ring_hom_comp _ _

lemma structure_sheaf.is_iso_to_open_of_closed_point_mem (R : CommRing) [local_ring R]
  (f : Scheme.Spec.obj (op R) ⟶ X)
  (U : opens X.carrier) (hU : f.1.base (closed_point R : _) ∈ U) :
  is_iso (structure_sheaf.to_open R ((opens.map f.val.base).obj U)) :=
begin
  have : (opens.map f.val.base).obj U = ⊤ := (@local_ring.closed_point_mem_iff R _ _ _).mp hU,
  rw this,
  apply_instance,
end

@[reassoc]
lemma germ_stalk_closed_point_to (R : CommRing) [local_ring R]
  (f : Scheme.Spec.obj (op R) ⟶ X)
  (U : opens X.carrier) (hU : f.1.base (closed_point R : _) ∈ U) :
  X.presheaf.germ ⟨_, hU⟩ ≫ stalk_closed_point_to R f = f.1.c.app (op U)
    ≫ @@inv _ _ (structure_sheaf.is_iso_to_open_of_closed_point_mem R f U hU) :=
begin
  haveI H := structure_sheaf.is_iso_to_open_of_closed_point_mem R f U hU,
  rw stalk_closed_point_to,
  erw [PresheafedSpace.stalk_map_germ_assoc _ _ ⟨_, _⟩],
  slice_lhs 2 3 { erw structure_sheaf.germ_comp_stalk_to_fiber_ring_hom _ _ ⟨_, _⟩ },
  congr' 1,
  apply @@is_iso.eq_inv_of_hom_inv_id _ H,
  erw [← category.assoc, iso.comp_inv_eq_id],
  ext,
  refl,
end

@[reassoc]
lemma germ_stalk_closed_point_to_to_open (R : CommRing) [local_ring R]
  (f : Scheme.Spec.obj (op R) ⟶ X)
  (U : opens X.carrier) (hU : f.1.base (local_ring.closed_point R : _) ∈ U) :
  X.presheaf.germ ⟨_, hU⟩ ≫ stalk_closed_point_to R f
    ≫ structure_sheaf.to_open R ((opens.map f.val.base).obj U) = f.1.c.app (op U) :=
begin
  haveI H := structure_sheaf.is_iso_to_open_of_closed_point_mem R f U hU,
  rw germ_stalk_closed_point_to_assoc,
  erw @@is_iso.inv_hom_id _ _ H,
  exact category.comp_id _
end

instance {X Y : Scheme} (f : X ⟶ Y)
  [H : is_open_immersion f] (U) : is_iso (f.inv_app U) :=
by { delta Scheme.hom.inv_app, apply_instance }

@[reassoc]
lemma Spec_map_stalk_closed_point_to_from_stalk (R : CommRing) [local_ring R]
  (f : Scheme.Spec.obj (op R) ⟶ X) :
  Scheme.Spec.map (stalk_closed_point_to R f).op ≫ X.from_Spec_stalk _ = f :=
begin
  rw [Scheme.from_Spec_stalk, is_affine_open.from_Spec_stalk, ← functor.map_comp_assoc,
    ← op_comp],
  convert is_open_immersion.lift_fac _ _ _,
  rotate, { apply_instance },
  { rw [is_affine_open.from_Spec_range, ← set.image_univ,
      set.image_subset_iff, ← opens.map_coe],
    convert (@opens.coe_top (prime_spectrum R) _).symm.subset using 2,
    rw ← @local_ring.closed_point_mem_iff R,
    exact X.affine_cover.covers _ },
  { refine eq.trans _ (Scheme.Spec.image_preimage _),
    rw ← quiver.hom.op_unop (Scheme.Spec.preimage _),
    congr' 2,
    rw [germ_stalk_closed_point_to],
    erw @@is_iso.comp_inv_eq _ _ (structure_sheaf.is_iso_to_open_of_closed_point_mem R f _ _),
    rw ← structure_sheaf.to_open_res _ _ _ (hom_of_le le_top),
    swap, { apply_instance },
    erw [Spec_Γ_naturality'_assoc, Scheme.Spec.image_preimage],
    let U := (X.affine_cover.map (f.1.base (closed_point R : _))).opens_range,
    have hU : is_affine_open U := range_is_affine_open_of_open_immersion _,
    have : hU.from_Spec.opens_functor.obj ⊤ = U :=
      opens.ext (set.image_univ.trans hU.from_Spec_range),
    convert_to f.1.c.app (op U) = to_Spec_Γ (X.presheaf.obj $ op U) ≫ _,
    rw [Scheme.Γ_map, quiver.hom.unop_op, is_open_immersion.lift_app, category.assoc,
      category.assoc, ← category.assoc,
      (is_iso.eq_inv_comp _).mpr (f.1.c.naturality (eq_to_hom this.symm).op)],
    erw ← functor.map_comp,
    congr' 2,
    rw [Scheme.hom.inv_app, ← is_iso.comp_inv_eq, ← functor.map_inv, ← op_inv, inv_eq_to_hom,
      PresheafedSpace.is_open_immersion.inv_inv_app,
      nat_trans.naturality_assoc, is_affine_open.from_Spec_app_eq],
    simp only [eq_to_hom_op, eq_to_hom_map, eq_to_hom_trans, category.assoc,
      eq_to_hom_refl, category.comp_id],
    refl }
end

-- lemma Spec_map_comp_from_Spec_app {R : Type*} [comm_ring R] {X : Scheme} {U : opens X.carrier}
--   (hU : is_affine_open U) (f : X.presheaf.obj (op U) ⟶ CommRing.of R) :
--   (Scheme.Spec.map f.op ≫ hU.from_Spec).1.c.app (op U) = f ≫
--     structure_sheaf.to_open R ((opens.map (Scheme.Spec.map f.op ≫ hU.from_Spec).1.base).obj U) :=
-- begin
--   rw [Scheme.comp_val_c_app, is_affine_open.from_Spec_app_eq, category.assoc,
--     nat_trans.naturality, ← category.assoc],
--   convert_to (Γ_Spec.adjunction.counit.app (op (CommRing.of R)) ≫ f.op).unop ≫ _ = _,
--   { congr' 1, rw ← Γ_Spec.adjunction.counit_naturality f.op, refl },
--   convert_to (f ≫ to_Spec_Γ (CommRing.of R)) ≫ _ = _,
--   rw category.assoc,
--   congr' 1
-- end

lemma Spec_to_equiv_of_local_ring_eq_iff {R : CommRing} [local_ring R] {X : Scheme}
  {f₁ f₂ : Σ (x : X.carrier), { f : X.presheaf.stalk x ⟶ R // is_local_ring_hom f }} :
  f₁ = f₂ ↔ ∃ h₁ : f₁.1 = f₂.1, f₁.2.1 =
    X.presheaf.stalk_specializes (specializes_of_eq h₁.symm) ≫ f₂.2.1 :=
begin
  split,
  { rintro rfl, refine ⟨rfl, by simp⟩ },
  { rcases ⟨f₁, f₂⟩ with ⟨⟨_, ⟨⟩⟩, _, ⟨⟩⟩, dsimp, rintro ⟨rfl, rfl⟩, congr' 2,
    apply Top.presheaf.stalk_hom_ext, intros U hU, simp },
end

@[reassoc]
lemma Scheme.stalk_specializes_from_Spec_stalk {X : Scheme} {x y : X.carrier} (h : x ⤳ y) :
  Scheme.Spec.map (X.presheaf.stalk_specializes h).op ≫ X.from_Spec_stalk y =
    X.from_Spec_stalk x :=
begin
  rw Scheme.from_Spec_stalk,
  generalize_proofs _ _ h₁ h₂,
  rw ← h₁.from_Spec_stalk_eq _ (h.mem_open (X.affine_cover.map y).opens_range.2 h₂),
  delta is_affine_open.from_Spec_stalk,
  rw [← Scheme.Spec.map_comp_assoc, ← op_comp, Top.presheaf.germ_stalk_specializes'],
  refl
end

def Spec_to_equiv_of_local_ring (R : CommRing) [local_ring R] (X : Scheme) :
  (Scheme.Spec.obj (op R) ⟶ X) ≃
    Σ (x : X.carrier), { f : X.presheaf.stalk x ⟶ R // is_local_ring_hom f } :=
{ to_fun := λ f, ⟨f.1.base (closed_point R : _), stalk_closed_point_to R f, infer_instance⟩,
  inv_fun := λ xf, Scheme.Spec.map xf.2.1.op ≫ X.from_Spec_stalk xf.1,
  left_inv := Spec_map_stalk_closed_point_to_from_stalk R,
  right_inv := begin
    rintros ⟨x, f, hf⟩,
    resetI,
    have : (Scheme.Spec.map f.op ≫ X.from_Spec_stalk x).1.base (closed_point R : _) = x,
    { convert_to (X.from_Spec_stalk x).val.base (prime_spectrum.comap f $ closed_point R) = x,
      rw [local_ring.comap_closed_point, Scheme.from_Spec_stalk_closed_point] },
    refine Spec_to_equiv_of_local_ring_eq_iff.mpr ⟨_, _⟩,
    { dsimp only, exact this },
    { dsimp only,
      apply quiver.hom.op_inj,
      apply Scheme.Spec.map_injective,
      rw [← cancel_mono (X.from_Spec_stalk _), Spec_map_stalk_closed_point_to_from_stalk, op_comp,
        functor.map_comp_assoc, Scheme.stalk_specializes_from_Spec_stalk],
      apply_instance }
  end }
.

lemma stalk_closed_point_to_from_Spec_stalk {X : Scheme} (x : X.carrier) :
  stalk_closed_point_to (X.presheaf.stalk x) (X.from_Spec_stalk x) =
  X.presheaf.stalk_specializes (specializes_of_eq (Scheme.from_Spec_stalk_closed_point x).symm) :=
begin
  obtain ⟨e₁, e₂⟩ := Spec_to_equiv_of_local_ring_eq_iff.mp
    ((Spec_to_equiv_of_local_ring _ X).apply_symm_apply ⟨x, 𝟙 _, infer_instance⟩),
  dsimp [Spec_to_equiv_of_local_ring, - Scheme.Spec_map_2] at e₂,
  rw category.comp_id at e₂,
  convert e₂ using 2,
  rw Scheme.Spec.map_id,
  exact (category.id_comp _).symm,
end

lemma is_affine_open.from_Spec_stalk_app (X : Scheme)
  {x : X.carrier} {U : opens X.carrier} (h : x ∈ U) :
  (X.from_Spec_stalk x).1.c.app (op U) = X.presheaf.germ ⟨x, h⟩ ≫
    structure_sheaf.to_open (X.presheaf.stalk x)
      ((opens.map (X.from_Spec_stalk x).1.base).obj U) :=
begin
  have : (X.from_Spec_stalk x).1.base (local_ring.closed_point $ X.presheaf.stalk x : _) ∈ U,
  { rwa Scheme.from_Spec_stalk_closed_point },
  haveI H := structure_sheaf.is_iso_to_open_of_closed_point_mem
    (X.presheaf.stalk x) (X.from_Spec_stalk x) U this,
  have : X.presheaf.germ ⟨_, this⟩ ≫
    stalk_closed_point_to (X.presheaf.stalk x) (X.from_Spec_stalk x) =
     X.presheaf.germ ⟨x, h⟩,
  { rw [stalk_closed_point_to_from_Spec_stalk, Top.presheaf.germ_stalk_specializes'], refl },
  rw [germ_stalk_closed_point_to] at this,
  exact (@@is_iso.comp_inv_eq _ _ H).mp this,
end

lemma stalk_map_from_Spec_stalk
  {X Y : Scheme} (f : X ⟶ Y) (x : X.carrier) :
    Scheme.Spec.map (PresheafedSpace.stalk_map f.1 x).op ≫ Y.from_Spec_stalk _ =
      X.from_Spec_stalk x ≫ f :=
begin
  apply (@equiv.apply_eq_iff_eq_symm_apply _ _ (Spec_to_equiv_of_local_ring _ Y).symm
    ⟨f.1.base x, PresheafedSpace.stalk_map f.1 x, infer_instance⟩ _).mpr _,
  refine Spec_to_equiv_of_local_ring_eq_iff.mpr ⟨_, _⟩,
  { dsimp [Spec_to_equiv_of_local_ring], rw Scheme.from_Spec_stalk_closed_point },
  { apply Scheme.stalk_hom_affine_ext,
    intros U hU hxU,
    dsimp [Spec_to_equiv_of_local_ring],
    rw Top.presheaf.germ_stalk_specializes'_assoc,
    erw PresheafedSpace.stalk_map_germ f.1 U ⟨x, hxU⟩,
    convert (germ_stalk_closed_point_to _ (X.from_Spec_stalk x ≫ f) _ _).symm using 1,
    erw @@is_iso.eq_comp_inv _ _ (structure_sheaf.is_iso_to_open_of_closed_point_mem _ _ _ _),
    rw Scheme.comp_val_c_app,
    dsimp only [functor.op],
    rw is_affine_open.from_Spec_stalk_app, swap, { exact hxU },
    exact category.assoc _ _ _ }
end

end local_ring_to_Scheme

section residue_field

variables {X Y Z : Scheme.{u}} (f : X ⟶ Z) (g : Y ⟶ Z)

def Scheme.residue_field (X : Scheme) (x : X.carrier) : CommRing :=
CommRing.of $ local_ring.residue_field (X.presheaf.stalk x)

instance {x : X.carrier} : field (X.residue_field x) :=
show field (local_ring.residue_field _), by apply_instance

def Scheme.to_residue_field (X : Scheme) (x) : X.stalk x ⟶ X.residue_field x :=
local_ring.residue _

def Scheme.desc_residue_field {K : Type*} [field K] (X : Scheme) {x}
  (f : X.stalk x ⟶ CommRing.of K) [is_local_ring_hom f] : X.residue_field x ⟶ CommRing.of K :=
local_ring.lift_residue_field f

@[simp, reassoc]
lemma Scheme.to_desc_residue_field {K : Type*} [field K] (X : Scheme) {x}
  (f : X.stalk x ⟶ CommRing.of K) [is_local_ring_hom f] :
  X.to_residue_field x ≫ X.desc_residue_field f = f :=
ring_hom.ext (λ _, rfl)

instance (x) : epi (X.to_residue_field x) :=
begin
  refine (forget _).epi_of_epi_map _,
  exact (epi_iff_surjective _).mpr ideal.quotient.mk_surjective
end

instance (x) : is_local_ring_hom (X.to_residue_field x) := local_ring.is_local_ring_hom_residue

def Scheme.residue_field_of_eq (X : Scheme) {x y : X.carrier} (h : x = y) :
  X.residue_field y ⟶ X.residue_field x :=
X.desc_residue_field
  (X.presheaf.stalk_specializes (specializes_of_eq h) ≫ X.to_residue_field x)

@[simp, reassoc]
lemma Scheme.to_residue_field_of_eq (x y) (e : x = y) :
  X.to_residue_field _ ≫ X.residue_field_of_eq e =
    (X.presheaf.stalk_congr $ inseparable.of_eq e.symm).hom ≫ X.to_residue_field _ :=
rfl

@[simp, reassoc]
lemma Scheme.residue_field_of_eq_trans (X : Scheme) {x y z : X.carrier} (h : x = y) (h' : y = z) :
  X.residue_field_of_eq h' ≫ X.residue_field_of_eq h = X.residue_field_of_eq (h.trans h') :=
by { rw ← cancel_epi (X.to_residue_field z), simpa }

@[simp]
lemma Scheme.residue_field_of_eq_refl (X : Scheme) {x : X.carrier} :
  X.residue_field_of_eq (refl x) = 𝟙 _ :=
begin
  rw [← cancel_epi (X.to_residue_field x), Scheme.to_residue_field_of_eq,
    Top.presheaf.stalk_congr_hom],
  erw [X.presheaf.stalk_specializes_refl x, category.id_comp],
end

def Scheme.hom.map_residue_field {X Y : Scheme} (f : X ⟶ Y) (x : X.carrier) :
  Y.residue_field (f.1.base x) ⟶ X.residue_field x :=
Y.desc_residue_field (PresheafedSpace.stalk_map f.1 x ≫ X.to_residue_field x)

@[simp, reassoc]
lemma Scheme.to_residue_field_map_residue_field {X Y : Scheme} (f : X ⟶ Y) (x : X.carrier) :
  Y.to_residue_field (f.1.base x) ≫ f.map_residue_field x =
    PresheafedSpace.stalk_map f.1 x ≫ X.to_residue_field x :=
Y.to_desc_residue_field (PresheafedSpace.stalk_map f.1 x ≫ X.to_residue_field x)

def Scheme.from_Spec_residue_field (X : Scheme) (x : X.carrier) :
  Scheme.Spec.obj (op $ X.residue_field x) ⟶ X :=
Scheme.Spec.map (CommRing.of_hom $ local_ring.residue _).op ≫ X.from_Spec_stalk x

@[instance]
lemma Scheme.mono_from_Spec_residue_field {X : Scheme} (x : X.carrier) :
  mono (X.from_Spec_residue_field x) :=
begin
  rw Scheme.from_Spec_residue_field,
  apply_with mono_comp { instances := ff },
  swap, { apply_instance },
  apply_with functor.map_mono { instances := ff },
  { apply_instance },
  apply_with category_theory.op_mono_of_epi { instances := ff },
  apply concrete_category.epi_of_surjective,
  exact ideal.quotient.mk_surjective,
end

@[simp, reassoc]
lemma Scheme.residue_field_of_eq_from_Spec (X : Scheme) {x y : X.carrier} (h : x = y) :
  Scheme.Spec.map (X.residue_field_of_eq h).op ≫ X.from_Spec_residue_field y =
    X.from_Spec_residue_field x :=
begin
  subst h,
  rw [Scheme.residue_field_of_eq_refl, op_id, category_theory.functor.map_id, category.id_comp],
end

lemma Scheme.hom.map_residue_field_from_Spec_residue_field
  {X Y : Scheme} (f : X ⟶ Y) (x : X.carrier) :
    Scheme.Spec.map (f.map_residue_field x).op ≫ Y.from_Spec_residue_field _ =
      X.from_Spec_residue_field x ≫ f :=
begin
  rw [Scheme.from_Spec_residue_field, Scheme.from_Spec_residue_field, category.assoc,
    ← stalk_map_from_Spec_stalk, ← functor.map_comp_assoc, ← op_comp],
  convert eq.trans _ (Scheme.Spec.map_comp_assoc _ _ _),
  all_goals { delta PresheafedSpace.stalk, cases X.presheaf.stalk x, refl },
end

lemma Scheme.hom.map_residue_field_comp {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z)
  (x : X.carrier) :
  (f ≫ g).map_residue_field x = g.map_residue_field (f.1.base x) ≫ f.map_residue_field x :=
begin
  apply ideal.quotient.ring_hom_ext,
  transitivity (local_ring.residue (X.presheaf.stalk x)).comp
    (PresheafedSpace.stalk_map (f ≫ g).1 x),
  { refl },
  { erw PresheafedSpace.stalk_map.comp, ext, refl }
end
.
lemma Scheme.hom.map_residue_field_congr {X Y : Scheme} {f g : X ⟶ Y} (e : f = g)
  (x : X.carrier) :
  f.map_residue_field x = Y.residue_field_of_eq (by rw e) ≫ g.map_residue_field x :=
begin
  subst e,
  rw [Scheme.residue_field_of_eq_refl, category.id_comp],
end

lemma Scheme.hom.map_residue_field_eq {X Y : Scheme} (f : X ⟶ Y) (x) :
  f.map_residue_field x = local_ring.residue_field.map (PresheafedSpace.stalk_map f.1 x) :=
begin
  ext, refl,
end

instance {X Y : Scheme} (f : X ⟶ Y) [is_open_immersion f] (x) :
  is_iso (f.map_residue_field x) :=
begin
  rw [CommRing.is_iso_iff_bijective, Scheme.hom.map_residue_field_eq],
  exact (local_ring.residue_field.map_equiv
    (as_iso $ PresheafedSpace.stalk_map f.1 x).CommRing_iso_to_ring_equiv).bijective
end

lemma Scheme.from_Spec_residue_field_base (x : X.carrier) (s) :
  (X.from_Spec_residue_field x).1.base s = x :=
begin
  rw [Scheme.from_Spec_residue_field, Scheme.comp_val_base, comp_apply],
  convert Scheme.from_Spec_stalk_closed_point x,
  convert prime_spectrum.comap_residue _,
end

lemma Scheme.range_from_Spec_residue_field  (x : X.carrier) :
  set.range (X.from_Spec_residue_field x).1.base = {x} :=
begin
  ext y,
  simp only [set.mem_range, set.mem_singleton_iff, Scheme.from_Spec_residue_field_base],
  exact ⟨λ ⟨a, b⟩, b.symm, λ e, ⟨(⊥ : prime_spectrum (X.residue_field x)), e.symm⟩⟩,
end
.
lemma Spec_map_desc_residue_field_from_Spec_residue_field (K : Type*) [field K] (X : Scheme)
  (f : Scheme.Spec.obj (op $ CommRing.of K) ⟶ X) :
  Scheme.Spec.map (X.desc_residue_field (stalk_closed_point_to _ f)).op
    ≫ X.from_Spec_residue_field (f.1.base (local_ring.closed_point K)) = f :=
begin
  dsimp only [Scheme.from_Spec_residue_field],
  rw [← Scheme.Spec.map_comp_assoc, ← op_comp],
  exact Spec_map_stalk_closed_point_to_from_stalk _ f
end

lemma Spec_to_equiv_of_field_eq_iff {K : Type*} [field K] {X : Scheme}
  {f₁ f₂ : Σ x : X.carrier, X.residue_field x ⟶ CommRing.of K} :
  f₁ = f₂ ↔ ∃ e : f₁.1 = f₂.1,f₁.2 = X.residue_field_of_eq e.symm ≫ f₂.2 :=
by { split, { rintro rfl, exact ⟨rfl, by simp⟩ },
  { cases f₁, cases f₂, dsimp, rintro ⟨rfl, rfl⟩, congr, simp  } }

lemma Spec_to_equiv_of_field_right_inv {K : Type*} [field K] {X : Scheme}
  (xf : Σ x : X.carrier, X.residue_field x ⟶ CommRing.of K) :
  (sigma.mk _ (X.desc_residue_field (stalk_closed_point_to _ $
    Scheme.Spec.map xf.2.op ≫ X.from_Spec_residue_field xf.1)) :
      Σ x : X.carrier, X.residue_field x ⟶ CommRing.of K) = xf :=
begin
  haveI : nontrivial (CommRing.of K) := show nontrivial K, by apply_instance,
  refine Spec_to_equiv_of_field_eq_iff.mpr ⟨_, _⟩,
  { exact Scheme.from_Spec_residue_field_base _ _ },
  apply ideal.quotient.ring_hom_ext,
  dsimp,
  convert_to stalk_closed_point_to (CommRing.of K)
    (Scheme.Spec_map xf.snd ≫ X.from_Spec_residue_field xf.fst) = _,
  have := is_local_ring_hom_comp xf.2 (local_ring.residue $ X.presheaf.stalk xf.1),
  obtain ⟨_, e₂⟩ := Spec_to_equiv_of_local_ring_eq_iff.mp ((Spec_to_equiv_of_local_ring _ X)
    .right_inv ⟨xf.1, CommRing.of_hom (local_ring.residue _) ≫ xf.2, this⟩),
  dsimp only [Spec_to_equiv_of_local_ring] at e₂,
  convert e₂ using 1,
  congr' 1,
  rw [op_comp, Scheme.Spec.map_comp_assoc],
  refl
end
.

@[simps]
def Spec_to_equiv_of_field (K : Type*) [field K] (X : Scheme) :
  (Scheme.Spec.obj (op $ CommRing.of $ K) ⟶ X) ≃
    Σ x : X.carrier, X.residue_field x ⟶ CommRing.of K :=
{ to_fun := λ f, ⟨_, X.desc_residue_field (stalk_closed_point_to _ f)⟩,
  inv_fun := λ xf, Scheme.Spec.map xf.2.op ≫ X.from_Spec_residue_field xf.1,
  left_inv := Spec_map_desc_residue_field_from_Spec_residue_field K X,
  right_inv := Spec_to_equiv_of_field_right_inv }

end residue_field

end algebraic_geometry


import SciLean.Core
-- import SciLean.Core.IsSmooth

open SciLean

variable {α β γ : Type}
variable {X Y Z W : Type} [Vec X] [Vec Y] [Vec Z] [Vec W]

namespace maintests

  variable {α β γ : Type}

  variable (f : Y → Z) (g : X → Y) [IsSmoothT f] [IsSmoothT g] (h : X → X) [IsSmoothT h] (h' : Y → Y) [IsSmoothT h']
  variable (a : α) (b : β)
  variable (F : Y → α → X) [IsSmoothT F]
  variable (G : X → α → β → Y) [IsSmoothT G]
  variable (G' : X → Z → W → Y) (z : Z) (w : W) [IsSmoothT G']
  variable (H : α → X → β → Y) [IsSmoothT (H a)]
  variable (H': α → β → X → Y) [IsSmoothT (H' a b)]

  example : IsSmoothT (λ x => g x) := by infer_instance
  example : IsSmoothT (λ x => f (g x)) := by infer_instance
  example : IsSmoothT (λ x => f (g (h (h x)))) := by infer_instance
  example : IsSmoothT (λ (g' : X → Y) => f ∘ g') := by unfold Function.comp; infer_instance
  example : IsSmoothT (λ (x : X) => F (g (h x)) a) := by infer_instance
  example : IsSmoothT (f ∘ g) := by unfold Function.comp; infer_instance
  example : IsSmoothT (λ (f : Y → Z) (x : X) => (f (g x))) := by infer_instance
  example : IsSmoothT (λ (h'' : X → X) (x : X) => h (h (h (h'' ((h ∘ h) (h x)))))) := by infer_instance
  example : IsSmoothT (λ (x : X) => G (h x) a b) := by infer_instance
  example : IsSmoothT (λ (x : X) => H a (h x) b) := by infer_instance
  example : IsSmoothT (λ (x : X) => H' a b (h x)) := by infer_instance
  example (f : β → Y → Z) [∀ b, IsSmoothT (f b)] : IsSmoothT (λ (g : α → Y) (b : β) (a : α) => f b (g a)) := by infer_instance
  example (f : X → X → Y) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y]: IsSmoothT (λ x => f x x) := by infer_instance
  example (f : X → X → Y) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y] : IsSmoothT (λ x => f (h x) x) := by infer_instance
  example (f : X → X → Y) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y] : IsSmoothT (λ x => f x (h x)) := by infer_instance
  example : IsSmoothT (λ (h : X → X) (x : X) => H' a b (h x)) := by infer_instance
  example (f : Y → Z) (g : X → Y) [IsSmoothT f] [IsSmoothT g] : IsSmoothT (f ∘ g) := by unfold Function.comp; infer_instance
  example (g : α → β) : IsSmoothT (λ (f : β → Z) (a : α) => (f (g a))) := by infer_instance
  example (f : Y → β → Z) (g : X → Y) (b : β) [IsSmoothT f] [IsSmoothT g] : IsSmoothT (λ x => f (g x) d) := by infer_instance
  example (f : Y → β → Z) (g : X → Y) (h : X → X) (b : β) [IsSmoothT f] [IsSmoothT g] [IsSmoothT h] : IsSmoothT (λ x => f (g (h (h x))) d) := by infer_instance
  example (f : α → Y → Z) [∀ a, IsSmoothT (f a)] : IsSmoothT (λ y a => f a y) := by infer_instance
  example (f : α → β → X → Y) [∀ a b, IsSmoothT (f a b)] : IsSmoothT (λ x b a => f a b x) := by infer_instance
  example (f : α → β → X → Y) [∀ a b, IsSmoothT (f a b)] : IsSmoothT (λ x a b => f a b x) := by infer_instance
  example (f : α → β → γ → X → Y) [∀ a b c, IsSmoothT (f a b c)] : IsSmoothT (λ x a b c => f a b c x) := by infer_instance
  example (f : X → X) [IsSmoothT f] : IsSmoothT (λ (g : X → X) x => f (f (g x))) := by infer_instance
  example (f : X → X → β → Y) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y] : IsSmoothT (λ x b => f x x b) := by infer_instance
  example : IsSmoothT (λ (g : X → Y) (x : X) => F (g (h x)) a) := by infer_instance
  example : IsSmoothT (λ (x : X) => G' (h x) z w) := by infer_instance
  example (f : X → X → β → Y) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y]  (b) : IsSmoothT (λ x => f x x b) := by infer_instance
  -- example (f : X → X → β → Y) (b) [IsSmoothNT 2 (λ x y => f x y b)] : IsSmoothT (λ x => f x x b) := by infer_instance
  example : IsSmoothT (λ (h : X → X) (x : X) => G (h x)) := by infer_instance

  example : IsSmoothT (λ (h : X → X) (x : X) => G (h x) a b) := by infer_instance
  example : IsSmoothT (λ (h : X → X) (x : X) => H a (h x) b) := by infer_instance
  example : IsSmoothT (λ (x : X) => h (F (h' ((h' ∘ g) (h x))) a)) := by unfold Function.comp; infer_instance
  example : IsSmoothT (λ (h'' : X → X) (x : X) => (h ∘ h ∘ h) (h (h'' (h ((h ∘ h) x))))) := by unfold Function.comp; infer_instance

end maintests

namespace foldtest

variable {α β γ : Type}
variable {X : Type} {Y : Type} {Z : Type} [Vec X] [Vec Y] [Vec Z]

variable (f : X → X) [IsSmoothT f]

example : IsSmoothT (λ x => f x) := by infer_instance
example : IsSmoothT (λ x => f (f x)) := by infer_instance
example : IsSmoothT (λ (g : X → X) x => f (g x)) := by infer_instance
example : IsSmoothT (λ (g : X → X) x => g (f x)) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => g (g x)) := by infer_instance
example : IsSmoothT (λ (g : X → X) x => f (f (g x))) := by infer_instance
example : IsSmoothT (λ (g : X → X) x => f (g (f x))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => f (g (g x))) := by infer_instance
example : IsSmoothT (λ (g : X → X)  x => g (f (f x))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => g (f (g x))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => g (g (f x))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => g (g (g x))) := by infer_instance
example : IsSmoothT (λ (g : X → X)  x => f (f (f (g x)))) := by infer_instance
example : IsSmoothT (λ (g : X → X)  x => f (f (g (f x)))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => f (f (g (g x)))) := by infer_instance
example : IsSmoothT (λ (g : X → X)  x => f (g (f (f x)))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => f (g (f (g x)))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => f (g (g (f x)))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => f (g (g (g x)))) := by infer_instance
example : IsSmoothT (λ (g : X → X)  x => g (f (f (f x)))) := by infer_instance

end foldtest

namespace forktest

variable {α β γ : Type}
variable {X : Type} {Y : Type} {Z : Type} [Vec X] [Vec Y] [Vec Z]

variable (f : X → X → X) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y]

example : IsSmoothT (λ x => f x x) := by infer_instance
example : IsSmoothT (λ x => f (f x x) x) := by infer_instance
example : IsSmoothT (λ x => f x (f x x)) := by infer_instance
example : IsSmoothT (λ x => f (f x x) (f x x)) := by infer_instance
example : IsSmoothT (λ x => f (f (f x x) x) x) := by infer_instance
example : IsSmoothT (λ x => f (f x (f x x)) x) := by infer_instance
example : IsSmoothT (λ x => f x (f (f x x) x)) := by infer_instance
example : IsSmoothT (λ x => f x (f x (f x x))) := by infer_instance

example : IsSmoothT (λ (g : X → X) x => f (g x) x) := by infer_instance
example : IsSmoothT (λ (g : X → X) x => f x (g x)) := by infer_instance
example : IsSmoothT (λ (g : X → X) x => f x (g x)) := by infer_instance

end forktest

namespace combtests
  variable {α β γ : Type}
  variable {X : Type} {Y : Type} {Z : Type} [Vec X] [Vec Y] [Vec Z]

  example (f : X → X) [IsSmoothT f] : IsSmoothT ((f ∘ f) ∘ (f ∘ (f ∘ f))) := by unfold Function.comp; infer_instance
  example (f : β → X → Y) (g : α → β) (a : α) [IsSmoothT (f (g a))] : IsSmoothT ((f ∘ g) a) := by simp; infer_instance
  example (y : X) (A : X → X) (B : X → X) [IsSmoothT A] [IsSmoothT B] : IsSmoothT λ x => (B∘A) x + B (A (B x) + B x) := by unfold Function.comp; infer_instance
  example (y : X) (A : X → X) (B : X → X) [IsSmoothT A] [IsSmoothT B] : IsSmoothT (λ x : X => x + x) := by infer_instance
end combtests

section highorderfunctions

variable {X Y : Type} [Hilbert X] [Hilbert Y]

example : IsSmoothT fun (g : X⟿Y) => λ x ⟿ (c:ℝ) * g x := by infer_instance
example : IsSmoothT fun (g : ℝ⟿Y) => λ x ⟿ x * g x := by infer_instance
example : IsSmoothT fun (g : ℝ⟿ℝ) => λ x ⟿ g x * x := by apply IsSmoothT_rule_S₂ (λ (x y : ℝ) => y * x)
example  (f : X⟿Y) : IsSmoothT fun (g : X⟿Y) => λ x ⟿ ⟪f x, g x⟫ := by infer_instance
example  (f : X⟿Y) : IsSmoothT fun (g : X⟿Y) => λ x ⟿ ⟪g x, f x⟫ := by apply IsSmoothT_rule_S₂ (λ x y => ⟪y, f x⟫)
example  (f : X⟿Y) (A B : Y → Y) [IsSmoothT A] [IsSmooth B] : IsSmoothT fun (g : X⟿Y) => λ x ⟿ ⟪A (g x), B (f x)⟫ := by apply IsSmoothT_rule_S₂ (λ x y => ⟪A y, B (f x)⟫)
example : IsSmoothT fun (g : ℝ⟿Y) => λ x ⟿ x * g x := by infer_instance

end highorderfunctions

section argument_shuffling

-- Test in forgeting smoothenss in various components

--IsSmoothN 2 to IsSmooth
example (f : X → Y → Z) [IsSmoothN 2 f]
  : IsSmoothT f := by infer_instance

example (f : X → Y → Z) [IsSmoothN 2 f] (x : X)
  : IsSmoothT (f x) := by infer_instance

example (f : X → Y → Z) [IsSmoothN 2 f] (y : Y)
  : IsSmoothT (λ y => f x y) := by infer_instance

-- IsSmoothN 3 to IsSmooth
example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ x y z => f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (x : X)
  : IsSmoothT (f x) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (x : X) (y : Y)
  : IsSmoothT (f x y) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (x : X) (z : Z)
  : IsSmoothT (λ y => f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (y : Y) (z : Z)
  : IsSmoothT (λ x => f x y z) := by infer_instance

-- IsSmoothN 3 to effectively IsSmoothN 2
example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ λ z => f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ z ⟿ λ y => f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ y => λ x ⟿ λ z => f x y z) := by infer_instance
set_option synthInstance.maxSize 300 in
example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ y => λ z ⟿ λ x => f x y z) := by infer_instance
set_option synthInstance.maxSize 300 in
example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ z => λ x ⟿ λ y => f x y z) := by infer_instance
set_option synthInstance.maxSize 500 in
example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ z => λ y ⟿ λ x => f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (z : Z)
  : IsSmoothT (λ x => λ y ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (y : Y)
  : IsSmoothT (λ x => λ z ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (x : X)
  : IsSmoothT (λ y => λ z ⟿ f x y z) := by infer_instance

-- Duplicating arguments
example (f : X → X → Z) [IsSmoothN 2 f]
  : IsSmoothT (λ x => f x x) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f x x y) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f x x y) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f x y x) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f y x x) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f x y y) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f y x y) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f x y y) := by infer_instance

-- Permuting arguments
example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ z y ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ z ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ x y => λ z ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ y => λ x z ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ z => λ x y ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ y => λ x z ⟿ f x y z) := by infer_instance

end argument_shuffling


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Robert Y. Lewis, Gabriel Ebner
-/
import data.bool.basic
import meta.rb_map
import tactic.lint.basic

/-!
# Linters about type classes

This file defines several linters checking the correct usage of type classes
and the appropriate definition of instances:

 * `instance_priority` ensures that blanket instances have low priority.
 * `has_inhabited_instances` checks that every type has an `inhabited` instance.
 * `impossible_instance` checks that there are no instances which can never apply.
 * `incorrect_type_class_argument` checks that only type classes are used in
   instance-implicit arguments.
 * `dangerous_instance` checks for instances that generate subproblems with metavariables.
 * `fails_quickly` checks that type class resolution finishes quickly.
 * `class_structure` checks that every `class` is a structure, i.e. `@[class] def` is forbidden.
 * `has_coe_variable` checks that there is no instance of type `has_coe α t`.
 * `inhabited_nonempty` checks whether `[inhabited α]` arguments could be generalized
   to `[nonempty α]`.
 * `decidable_classical` checks propositions for `[decidable_... p]` hypotheses that are not used
   in the statement, and could thus be removed by using `classical` in the proof.
 * `linter.has_coe_to_fun` checks whether necessary `has_coe_to_fun` instances are declared.
 * `linter.check_reducibility` checks whether non-instances with a class as type are reducible.
-/

open tactic

/-- Pretty prints a list of arguments of a declaration. Assumes `l` is a list of argument positions
and binders (or any other element that can be pretty printed).
`l` can be obtained e.g. by applying `list.indexes_values` to a list obtained by
`get_pi_binders`. -/
meta def print_arguments {α} [has_to_tactic_format α] (l : list (ℕ × α)) : tactic string := do
  fs ← l.mmap (λ ⟨n, b⟩, (λ s, to_fmt "argument " ++ to_fmt (n+1) ++ ": " ++ s) <$> pp b),
  return $ fs.to_string_aux tt

/-- checks whether an instance that always applies has priority ≥ 1000. -/
private meta def instance_priority (d : declaration) : tactic (option string) := do
  let nm := d.to_name,
  b ← is_instance nm,
  /- return `none` if `d` is not an instance -/
  if ¬ b then return none else do
  (is_persistent, prio) ← has_attribute `instance nm,
  /- return `none` if `d` is has low priority -/
  if prio < 1000 then return none else do
  (_, tp) ← open_pis d.type,
  tp ← whnf tp transparency.none,
  let (fn, args) := tp.get_app_fn_args,
  cls ← get_decl fn.const_name,
  let (pi_args, _) := cls.type.pi_binders,
  guard (args.length = pi_args.length),
  /- List all the arguments of the class that block type-class inference from firing
    (if they are metavariables). These are all the arguments except instance-arguments and
    out-params. -/
  let relevant_args := (args.zip pi_args).filter_map $ λ⟨e, ⟨_, info, tp⟩⟩,
    if info = binder_info.inst_implicit ∨ tp.get_app_fn.is_constant_of `out_param
    then none else some e,
  let always_applies := relevant_args.all expr.is_local_constant ∧ relevant_args.nodup,
  if always_applies then return $ some "set priority below 1000" else return none

/--
There are places where typeclass arguments are specified with implicit `{}` brackets instead of
the usual `[]` brackets. This is done when the instances can be inferred because they are implicit
arguments to the type of one of the other arguments. When they can be inferred from these other
arguments,  it is faster to use this method than to use type class inference.

For example, when writing lemmas about `(f : α →+* β)`, it is faster to specify the fact that `α`
and `β` are `semiring`s as `{rα : semiring α} {rβ : semiring β}` rather than the usual
`[semiring α] [semiring β]`.
-/
library_note "implicit instance arguments"

/--
Certain instances always apply during type-class resolution. For example, the instance
`add_comm_group.to_add_group {α} [add_comm_group α] : add_group α` applies to all type-class
resolution problems of the form `add_group _`, and type-class inference will then do an
exhaustive search to find a commutative group. These instances take a long time to fail.
Other instances will only apply if the goal has a certain shape. For example
`int.add_group : add_group ℤ` or
`add_group.prod {α β} [add_group α] [add_group β] : add_group (α × β)`. Usually these instances
will fail quickly, and when they apply, they are almost the desired instance.
For this reason, we want the instances of the second type (that only apply in specific cases) to
always have higher priority than the instances of the first type (that always apply).
See also #1561.

Therefore, if we create an instance that always applies, we set the priority of these instances to
100 (or something similar, which is below the default value of 1000).
-/
library_note "lower instance priority"

/-- A linter object for checking instance priorities of instances that always apply.
This is in the default linter set. -/
@[linter] meta def linter.instance_priority : linter :=
{ test := instance_priority,
  no_errors_found := "All instance priorities are good.",
  errors_found := "DANGEROUS INSTANCE PRIORITIES.
The following instances always apply, and therefore should have a priority < 1000.
If you don't know what priority to choose, use priority 100.
See note [lower instance priority] for instructions to change the priority.",
  auto_decls := tt }

/-- Reports declarations of types that do not have an associated `inhabited` instance. -/
private meta def has_inhabited_instance (d : declaration) : tactic (option string) := do
tt ← pure d.is_trusted | pure none,
ff ← has_attribute' `reducible d.to_name | pure none,
ff ← has_attribute' `class d.to_name | pure none,
(_, ty) ← open_pis d.type,
ty ← whnf ty,
if ty = `(Prop) then pure none else do
`(Sort _) ← whnf ty | pure none,
insts ← attribute.get_instances `instance,
insts_tys ← insts.mmap $ λ i, expr.pi_codomain <$> declaration.type <$> get_decl i,
let inhabited_insts := insts_tys.filter (λ i,
  i.app_fn.const_name = ``inhabited ∨ i.app_fn.const_name = `unique),
let inhabited_tys := inhabited_insts.map (λ i, i.app_arg.get_app_fn.const_name),
if d.to_name ∈ inhabited_tys then
  pure none
else
  pure "inhabited instance missing"

/-- A linter for missing `inhabited` instances. -/
@[linter]
meta def linter.has_inhabited_instance : linter :=
{ test := has_inhabited_instance,
  auto_decls := ff,
  no_errors_found := "No types have missing inhabited instances.",
  errors_found := "TYPES ARE MISSING INHABITED INSTANCES:",
  is_fast := ff }

attribute [nolint has_inhabited_instance] pempty

/-- Checks whether an instance can never be applied. -/
private meta def impossible_instance (d : declaration) : tactic (option string) := do
  tt ← is_instance d.to_name | return none,
  (binders, _) ← get_pi_binders_nondep d.type,
  let bad_arguments := binders.filter $ λ nb, nb.2.info ≠ binder_info.inst_implicit,
  _ :: _ ← return bad_arguments | return none,
  (λ s, some $ "Impossible to infer " ++ s) <$> print_arguments bad_arguments

/-- A linter object for `impossible_instance`. -/
@[linter] meta def linter.impossible_instance : linter :=
{ test := impossible_instance,
  auto_decls := tt,
  no_errors_found := "All instances are applicable.",
  errors_found := "IMPOSSIBLE INSTANCES FOUND.
These instances have an argument that cannot be found during type-class resolution, and " ++
"therefore can never succeed. Either mark the arguments with square brackets (if it is a " ++
"class), or don't make it an instance." }

/-- Checks whether an instance can never be applied. -/
private meta def incorrect_type_class_argument (d : declaration) : tactic (option string) := do
  (binders, _) ← get_pi_binders d.type,
  let instance_arguments := binders.indexes_values $
    λ b : binder, b.info = binder_info.inst_implicit,
  /- the head of the type should either unfold to a class, or be a local constant.
  A local constant is allowed, because that could be a class when applied to the
  proper arguments. -/
  bad_arguments ← instance_arguments.mfilter (λ ⟨_, b⟩, do
    (_, head) ← open_pis b.type,
    if head.get_app_fn.is_local_constant then return ff else do
    bnot <$> is_class head),
  _ :: _ ← return bad_arguments | return none,
  (λ s, some $ "These are not classes. " ++ s) <$> print_arguments bad_arguments

/-- A linter object for `incorrect_type_class_argument`. -/
@[linter] meta def linter.incorrect_type_class_argument : linter :=
{ test := incorrect_type_class_argument,
  auto_decls := tt,
  no_errors_found := "All declarations have correct type-class arguments.",
  errors_found := "INCORRECT TYPE-CLASS ARGUMENTS.
Some declarations have non-classes between [square brackets]:" }

/-- Checks whether an instance is dangerous: it creates a new type-class problem with metavariable
arguments. -/
private meta def dangerous_instance (d : declaration) : tactic (option string) := do
  tt ← is_instance d.to_name | return none,
  (local_constants, target) ← open_pis d.type,
  let instance_arguments := local_constants.indexes_values $
    λ e : expr, e.local_binding_info = binder_info.inst_implicit,
  let bad_arguments := local_constants.indexes_values $ λ x,
      !target.has_local_constant x &&
      (x.local_binding_info ≠ binder_info.inst_implicit) &&
      instance_arguments.any (λ nb, nb.2.local_type.has_local_constant x),
  let bad_arguments : list (ℕ × binder) := bad_arguments.map $ λ ⟨n, e⟩, ⟨n, e.to_binder⟩,
  _ :: _ ← return bad_arguments | return none,
  (λ s, some $ "The following arguments become metavariables. " ++ s) <$>
    print_arguments bad_arguments

/-- A linter object for `dangerous_instance`. -/
@[linter] meta def linter.dangerous_instance : linter :=
{ test := dangerous_instance,
  no_errors_found := "No dangerous instances.",
  errors_found := "DANGEROUS INSTANCES FOUND.\nThese instances are recursive, and create a new " ++
"type-class problem which will have metavariables.
Possible solution: remove the instance attribute or make it a local instance instead.

Currently this linter does not check whether the metavariables only occur in arguments marked " ++
"with `out_param`, in which case this linter gives a false positive.",
  auto_decls := tt }

/-- Auxilliary definition for `find_nondep` -/
meta def find_nondep_aux : list expr → expr_set → tactic expr_set
| []      r := return r
| (h::hs) r :=
  do type ← infer_type h,
    find_nondep_aux hs $ r.union type.list_local_consts'

/-- Finds all hypotheses that don't occur in the target or other hypotheses. -/
meta def find_nondep : tactic (list expr) := do
  ctx ← local_context,
  tgt ← target,
  lconsts ← find_nondep_aux ctx tgt.list_local_consts',
  return $ ctx.filter $ λ e, !lconsts.contains e

/--
Tests whether type-class inference search will end quickly on certain unsolvable
type-class problems. This is to detect loops or very slow searches, which are problematic
(recall that normal type-class search often creates unsolvable subproblems, which have to fail
quickly for type-class inference to perform well.
We create these type-class problems by taking an instance, and removing the last hypothesis that
doesn't appear in the goal (or a later hypothesis). Note: this argument is necessarily an
instance-implicit argument if it passes the `linter.incorrect_type_class_argument`.
This tactic succeeds if `mk_instance` succeeds quickly or fails quickly with the error
message that it cannot find an instance. It fails if the tactic takes too long, or if any other
error message is raised (usually a maximum depth in the search).
-/
meta def fails_quickly (max_steps : ℕ) (d : declaration) : tactic (option string) := retrieve $ do
  tt ← is_instance d.to_name | return none,
  let e := d.type,
  g ← mk_meta_var e,
  set_goals [g],
  intros,
  l@(_::_) ← find_nondep | return none, -- if all arguments occur in the goal, this instance is ok
  clear l.ilast,
  reset_instance_cache,
  state ← read,
  let state_msg := "\nState:\n" ++ to_string state,
  tgt ← target >>= instantiate_mvars,
  sum.inr msg ← retrieve_or_report_error $ tactic.try_for max_steps $ mk_instance tgt |
    return none, /- it's ok if type-class inference can find an instance with fewer hypotheses.
    This happens a lot for `has_sizeof` and `has_well_founded`, but can also happen if there is a
    noncomputable instance with fewer assumptions. -/
  return $ if "tactic.mk_instance failed to generate instance for".is_prefix_of msg then none else
    some $ (++ state_msg) $
      if msg = "try_for tactic failed, timeout" then "type-class inference timed out" else msg

/--
A linter object for `fails_quickly`.
We currently set the number of steps in the type-class search pretty high.
Some instances take quite some time to fail, and we seem to run against the caching issue in
https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/odd.20repeated.20type.20class.20search
-/
@[linter] meta def linter.fails_quickly : linter :=
{ test := fails_quickly 15000,
  auto_decls := tt,
  no_errors_found := "No type-class searches timed out.",
  errors_found := "TYPE CLASS SEARCHES TIMED OUT.
The following instances are part of a loop, or an excessively long search.
It is common that the loop occurs in a different class than the one flagged below,
but usually an instance that is part of the loop is also flagged.
To debug:
(1) run `scripts/mk_all.sh` and create a file with `import all` and
`set_option trace.class_instances true`
(2) Recreate the state shown in the error message. You can do this easily by copying the type of
the instance (the output of `#check @my_instance`), turning this into an example and removing the
last argument in square brackets. Prove the example using `by apply_instance`.
For example, if `additive.topological_add_group` raises an error, run
```
example {G : Type*} [topological_space G] [group G] : topological_add_group (additive G) :=
by apply_instance
```
(3) What error do you get?
(3a) If the error is \"tactic.mk_instance failed to generate instance\",
there might be nothing wrong. But it might take unreasonably long for the type-class inference to
fail. Check the trace to see if type-class inference takes any unnecessary long unexpected turns.
If not, feel free to increase the value in the definition of the linter `fails_quickly`.
(3b) If the error is \"maximum class-instance resolution depth has been reached\" there is almost
certainly a loop in the type-class inference. Find which instance causes the type-class inference to
go astray, and fix that instance.",
  is_fast := ff }

/-- Checks that all uses of the `@[class]` attribute apply to structures or inductive types.
  This is future-proofing for lean 4, which no longer supports `@[class] def`. -/
private meta def class_structure (n : name) : tactic (option string) := do
  is_class ← has_attribute' `class n,
  if is_class then do
    env ← get_env,
    pure $ if env.is_inductive n then none else
      "is a non-structure or inductive type marked @[class]"
  else pure none

/-- A linter object for `class_structure`. -/
@[linter] meta def linter.class_structure : linter :=
{ test := λ d, class_structure d.to_name,
  auto_decls := tt,
  no_errors_found := "All classes are structures.",
  errors_found := "USE OF @[class] def IS DISALLOWED:" }

/--
Tests whether there is no instance of type `has_coe α t` where `α` is a variable,
or `has_coe t α` where `α` does not occur in `t`.
See note [use has_coe_t].
-/
private meta def has_coe_variable (d : declaration) : tactic (option string) := do
tt ← is_instance d.to_name | return none,
`(has_coe %%a %%b) ← return d.type.pi_codomain | return none,
if a.is_var then
  return $ some $ "illegal instance, first argument is variable"
else if b.is_var ∧ ¬ b.occurs a then
  return $ some $ "illegal instance, second argument is variable not occurring in first argument"
else
  return none

/-- A linter object for `has_coe_variable`. -/
@[linter] meta def linter.has_coe_variable : linter :=
{ test := has_coe_variable,
  auto_decls := tt,
  no_errors_found := "No invalid `has_coe` instances.",
  errors_found := "INVALID `has_coe` INSTANCES.
Make the following declarations instances of the class `has_coe_t` instead of `has_coe`." }

/-- Checks whether a declaration is prop-valued and takes an `inhabited _` argument that is unused
elsewhere in the type. In this case, that argument can be replaced with `nonempty _`. -/
private meta def inhabited_nonempty (d : declaration) : tactic (option string) :=
do tt ← is_prop d.type | return none,
   (binders, _) ← get_pi_binders_nondep d.type,
   let inhd_binders := binders.filter $ λ pr, pr.2.type.is_app_of `inhabited,
   if inhd_binders.length = 0 then return none
   else (λ s, some $ "The following `inhabited` instances should be `nonempty`. " ++ s) <$>
      print_arguments inhd_binders

/-- A linter object for `inhabited_nonempty`. -/
@[linter] meta def linter.inhabited_nonempty : linter :=
{ test := inhabited_nonempty,
  auto_decls := ff,
  no_errors_found := "No uses of `inhabited` arguments should be replaced with `nonempty`.",
  errors_found := "USES OF `inhabited` SHOULD BE REPLACED WITH `nonempty`." }

/-- Checks whether a declaration is `Prop`-valued and takes a `decidable* _`
hypothesis that is unused lsewhere in the type.
In this case, that hypothesis can be replaced with `classical` in the proof.
Theorems in the `decidable` namespace are exempt from the check. -/
private meta def decidable_classical (d : declaration) : tactic (option string) :=
do tt ← is_prop d.type | return none,
   ff ← pure $ (`decidable).is_prefix_of d.to_name | return none,
   (binders, _) ← get_pi_binders_nondep d.type,
   let deceq_binders := binders.filter $ λ pr, pr.2.type.is_app_of `decidable_eq
     ∨ pr.2.type.is_app_of `decidable_pred ∨ pr.2.type.is_app_of `decidable_rel
     ∨ pr.2.type.is_app_of `decidable,
   if deceq_binders.length = 0 then return none
   else (λ s, some $ "The following `decidable` hypotheses should be replaced with
                      `classical` in the proof. " ++ s) <$>
      print_arguments deceq_binders

/-- A linter object for `decidable_classical`. -/
@[linter] meta def linter.decidable_classical : linter :=
{ test := decidable_classical,
  auto_decls := ff,
  no_errors_found := "No uses of `decidable` arguments should be replaced with `classical`.",
  errors_found := "USES OF `decidable` SHOULD BE REPLACED WITH `classical` IN THE PROOF." }

/- The file `logic/basic.lean` emphasizes the differences between what holds under classical
and non-classical logic. It makes little sense to make all these lemmas classical, so we add them
to the list of lemmas which are not checked by the linter `decidable_classical`. -/
attribute [nolint decidable_classical] dec_em dec_em' not.decidable_imp_symm

private meta def has_coe_to_fun_linter (d : declaration) : tactic (option string) :=
retrieve $ do
tt ← return d.is_trusted | pure none,
mk_meta_var d.type >>= set_goals ∘ pure,
args ← unfreezing intros,
expr.sort _ ← target | pure none,
let ty : expr := (expr.const d.to_name d.univ_levels).mk_app args,
some coe_fn_inst ←
  try_core $ to_expr ``(_root_.has_coe_to_fun %%ty _) >>= mk_instance | pure none,
set_bool_option `pp.all true,
some trans_inst@(expr.app (expr.app _ trans_inst_1) trans_inst_2) ←
  try_core $ to_expr ``(@_root_.coe_fn_trans %%ty _ _ _ _) | pure none,
tt ← succeeds $ unify trans_inst coe_fn_inst transparency.reducible | pure none,
set_bool_option `pp.all true,
trans_inst_1 ← pp trans_inst_1,
trans_inst_2 ← pp trans_inst_2,
pure $ format.to_string $
  "`has_coe_to_fun` instance is definitionally equal to a transitive instance composed of: " ++
  trans_inst_1.group.indent 2 ++
  format.line ++ "and" ++
  trans_inst_2.group.indent 2

/-- Linter that checks whether `has_coe_to_fun` instances comply with Note [function coercion]. -/
@[linter] meta def linter.has_coe_to_fun : linter :=
{ test := has_coe_to_fun_linter,
  auto_decls := tt,
  no_errors_found := "has_coe_to_fun is used correctly",
  errors_found := "INVALID/MISSING `has_coe_to_fun` instances.
You should add a `has_coe_to_fun` instance for the following types.
See Note [function coercion]." }

/--
Checks whether an instance contains a semireducible non-instance with a class as
type in its value. We add some restrictions to get not too many false positives:
* We only consider classes with an `add` or `mul` field, since those classes are most likely to
  occur as a field to another class, and be an extension of another class.
* We only consider instances of type-valued classes and non-instances that are definitions.
* We currently ignore declarations `foo` that have a `foo._main` declaration. We could look inside,
or at the generated equation lemmas, but it's unlikely that there are many problematic instances
defined using the equation compiler.
-/
meta def check_reducible_non_instances (d : declaration) : tactic (option string) := do
  tt ← is_instance d.to_name | return none,
  ff ← is_prop d.type | return none,
  env ← get_env,
  -- We only check if the class of the instance contains an `add` or a `mul` field.
  let cls := d.type.pi_codomain.get_app_fn.const_name,
  some constrs ← return $ env.structure_fields cls | return none,
  tt ← return $ constrs.mem `add || constrs.mem `mul | return none,
  l ← d.value.list_constant.mfilter $ λ nm, do
  { d ← env.get nm,
    ff ← is_instance nm | return ff,
    tt ← is_class d.type | return ff,
    tt ← return d.is_definition | return ff,
    -- We only check if the class of the non-instance contains an `add` or a `mul` field.
    let cls := d.type.pi_codomain.get_app_fn.const_name,
    some constrs ← return $ env.structure_fields cls | return ff,
    tt ← return $ constrs.mem `add || constrs.mem `mul | return ff,
    ff ← has_attribute' `reducible nm | return ff,
    return tt },
  if l.empty then return none else
  -- we currently ignore declarations that have a `foo._main` declaration.
  if l.to_list = [d.to_name ++ `_main] then return none else
    return $ some $ "This instance contains the declarations " ++ to_string l.to_list ++
      ", which are semireducible non-instances."

/-- A linter that checks whether an instance contains a semireducible non-instance. -/
@[linter]
meta def linter.check_reducibility : linter :=
{ test := check_reducible_non_instances,
  auto_decls := ff,
  no_errors_found :=
    "All non-instances are reducible.",
  errors_found := "THE FOLLOWING INSTANCES MIGHT NOT REDUCE.
These instances contain one or more declarations that are not instances and are also not marked
`@[reducible]`. This means that type-class inference cannot unfold these declarations, " ++
"which might mean that type-class inference cannot infer that two instances are definitionally " ++
"equal. This can cause unexpected errors when this class occurs " ++
"as an *argument* to a type-class problem. See note [reducible non-instances].",
  is_fast := tt }