/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro, Simon Hudon

! This file was ported from Lean 3 source module control.functor.multivariate
! leanprover-community/mathlib commit 4d392a6c9c4539cbeca399b3ee0afea398fbd2eb
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fin.Fin2
import Mathbin.Data.Typevec

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

Functors between the category of tuples of types, and the category Type

Features:

`mvfunctor n` : the type class of multivariate functors
`f <$$> x`    : notation for map

-/

universe u v w

open MvFunctor

#print MvFunctor /-
/-- multivariate functors, i.e. functor between the category of type vectors
and the category of Type -/
class MvFunctor {n : ℕ} (F : TypeVec n → Type _) where
  map : ∀ {α β : TypeVec n}, α ⟹ β → F α → F β
#align mvfunctor MvFunctor
-/

-- mathport name: mvfunctor.map
scoped[MvFunctor] infixr:100 " <$$> " => MvFunctor.map

variable {n : ℕ}

namespace MvFunctor

variable {α β γ : TypeVec.{u} n} {F : TypeVec.{u} n → Type v} [MvFunctor F]

#print MvFunctor.LiftP /-
/-- predicate lifting over multivariate functors -/
def LiftP {α : TypeVec n} (p : ∀ i, α i → Prop) (x : F α) : Prop :=
  ∃ u : F fun i => Subtype (p i), (fun i => @Subtype.val _ (p i)) <$$> u = x
#align mvfunctor.liftp MvFunctor.LiftP
-/

#print MvFunctor.LiftR /-
/-- relational lifting over multivariate functors -/
def LiftR {α : TypeVec n} (r : ∀ {i}, α i → α i → Prop) (x y : F α) : Prop :=
  ∃ u : F fun i => { p : α i × α i // r p.fst p.snd },
    (fun i (t : { p : α i × α i // r p.fst p.snd }) => t.val.fst) <$$> u = x ∧
      (fun i (t : { p : α i × α i // r p.fst p.snd }) => t.val.snd) <$$> u = y
#align mvfunctor.liftr MvFunctor.LiftR
-/

#print MvFunctor.supp /-
/-- given `x : F α` and a projection `i` of type vector `α`, `supp x i` is the set
of `α.i` contained in `x` -/
def supp {α : TypeVec n} (x : F α) (i : Fin2 n) : Set (α i) :=
  { y : α i | ∀ ⦃p⦄, LiftP p x → p i y }
#align mvfunctor.supp MvFunctor.supp
-/

#print MvFunctor.of_mem_supp /-
theorem of_mem_supp {α : TypeVec n} {x : F α} {p : ∀ ⦃i⦄, α i → Prop} (h : LiftP p x) (i : Fin2 n) :
    ∀ y ∈ supp x i, p y := fun y hy => hy h
#align mvfunctor.of_mem_supp MvFunctor.of_mem_supp
-/

end MvFunctor

#print LawfulMvFunctor /-
/-- laws for `mvfunctor` -/
class LawfulMvFunctor {n : ℕ} (F : TypeVec n → Type _) [MvFunctor F] : Prop where
  id_map : ∀ {α : TypeVec n} (x : F α), TypeVec.id <$$> x = x
  comp_map :
    ∀ {α β γ : TypeVec n} (g : α ⟹ β) (h : β ⟹ γ) (x : F α), (h ⊚ g) <$$> x = h <$$> g <$$> x
#align is_lawful_mvfunctor LawfulMvFunctor
-/

open Nat TypeVec

namespace MvFunctor

export LawfulMvFunctor (comp_map)

open LawfulMvFunctor

variable {α β γ : TypeVec.{u} n}

variable {F : TypeVec.{u} n → Type v} [MvFunctor F]

variable (p : α ⟹ repeat n Prop) (r : α ⊗ α ⟹ repeat n Prop)

#print MvFunctor.LiftP' /-
/-- adapt `mvfunctor.liftp` to accept predicates as arrows -/
def LiftP' : F α → Prop :=
  MvFunctor.LiftP fun i x => ofRepeat <| p i x
#align mvfunctor.liftp' MvFunctor.LiftP'
-/

#print MvFunctor.LiftR' /-
/-- adapt `mvfunctor.liftp` to accept relations as arrows -/
def LiftR' : F α → F α → Prop :=
  MvFunctor.LiftR fun i x y => ofRepeat <| r i <| TypeVec.prod.mk _ x y
#align mvfunctor.liftr' MvFunctor.LiftR'
-/

variable [LawfulMvFunctor F]

#print MvFunctor.id_map /-
@[simp]
theorem id_map (x : F α) : TypeVec.id <$$> x = x :=
  id_map x
#align mvfunctor.id_map MvFunctor.id_map
-/

#print MvFunctor.id_map' /-
@[simp]
theorem id_map' (x : F α) : (fun i a => a) <$$> x = x :=
  id_map x
#align mvfunctor.id_map' MvFunctor.id_map'
-/

#print MvFunctor.map_map /-
theorem map_map (g : α ⟹ β) (h : β ⟹ γ) (x : F α) : h <$$> g <$$> x = (h ⊚ g) <$$> x :=
  Eq.symm <| comp_map _ _ _
#align mvfunctor.map_map MvFunctor.map_map
-/

section Liftp'

variable (F)

#print MvFunctor.exists_iff_exists_of_mono /-
theorem exists_iff_exists_of_mono {p : F α → Prop} {q : F β → Prop} (f : α ⟹ β) (g : β ⟹ α)
    (h₀ : f ⊚ g = id) (h₁ : ∀ u : F α, p u ↔ q (f <$$> u)) : (∃ u : F α, p u) ↔ ∃ u : F β, q u :=
  by
  constructor <;> rintro ⟨u, h₂⟩ <;> [use f <$$> u, use g <$$> u]
  · apply (h₁ u).mp h₂
  · apply (h₁ _).mpr _
    simp only [MvFunctor.map_map, h₀, LawfulMvFunctor.id_map, h₂]
#align mvfunctor.exists_iff_exists_of_mono MvFunctor.exists_iff_exists_of_mono
-/

variable {F}

#print MvFunctor.LiftP_def /-
theorem LiftP_def (x : F α) : LiftP' p x ↔ ∃ u : F (Subtype_ p), subtypeVal p <$$> u = x :=
  exists_iff_exists_of_mono F _ _ (toSubtype_of_subtype p) (by simp [MvFunctor.map_map])
#align mvfunctor.liftp_def MvFunctor.LiftP_def
-/

#print MvFunctor.LiftR_def /-
theorem LiftR_def (x y : F α) :
    LiftR' r x y ↔
      ∃ u : F (Subtype_ r),
        (TypeVec.prod.fst ⊚ subtypeVal r) <$$> u = x ∧
          (TypeVec.prod.snd ⊚ subtypeVal r) <$$> u = y :=
  exists_iff_exists_of_mono _ _ _ (toSubtype'_of_subtype' r)
    (by simp only [map_map, comp_assoc, subtype_val_to_subtype'] <;> simp [comp])
#align mvfunctor.liftr_def MvFunctor.LiftR_def
-/

end Liftp'

end MvFunctor

open Nat

namespace MvFunctor

open TypeVec

section LiftpLastPredIff

variable {F : TypeVec.{u} (n + 1) → Type _} [MvFunctor F] [LawfulMvFunctor F] {α : TypeVec.{u} n}

variable (p : α ⟹ repeat n Prop) (r : α ⊗ α ⟹ repeat n Prop)

open MvFunctor

variable {β : Type u}

variable (pp : β → Prop)

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
private def f :
    ∀ n α,
      (fun i : Fin2 (n + 1) => { p_1 // ofRepeat (PredLast' α pp i p_1) }) ⟹ fun i : Fin2 (n + 1) =>
        { p_1 : (α ::: β) i // PredLast α pp p_1 }
  | _, α, Fin2.fs i, x =>
    ⟨x.val, cast (by simp only [pred_last] <;> erw [const_iff_true]) x.property⟩
  | _, α, Fin2.fz, x => ⟨x.val, x.property⟩
#align mvfunctor.f mvfunctor.f

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
private def g :
    ∀ n α,
      (fun i : Fin2 (n + 1) => { p_1 : (α ::: β) i // PredLast α pp p_1 }) ⟹ fun i : Fin2 (n + 1) =>
        { p_1 // ofRepeat (PredLast' α pp i p_1) }
  | _, α, Fin2.fs i, x =>
    ⟨x.val, cast (by simp only [pred_last] <;> erw [const_iff_true]) x.property⟩
  | _, α, Fin2.fz, x => ⟨x.val, x.property⟩
#align mvfunctor.g mvfunctor.g

/- warning: mvfunctor.liftp_last_pred_iff -> MvFunctor.LiftP_PredLast_iff is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) F] [_inst_2 : LawfulMvFunctor.{u1, u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) F _inst_1] {α : TypeVec.{u1} n} {β : Type.{u1}} (p : β -> Prop) (x : F (TypeVec.append1.{u1} n α β)), Iff (MvFunctor.LiftP'.{u1, u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) (TypeVec.append1.{u1} n α β) F _inst_1 (TypeVec.PredLast'.{u1} n α β p) x) (MvFunctor.LiftP.{u1, u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) F _inst_1 (fun (i : Fin2 (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) => TypeVec.append1.{u1} n α β i) (TypeVec.PredLast.{u1} n α β p) x)
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) F] [_inst_2 : LawfulMvFunctor.{u2, u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) F _inst_1] {α : TypeVec.{u2} n} {β : Type.{u2}} (p : β -> Prop) (x : F (TypeVec.append1.{u2} n α β)), Iff (MvFunctor.LiftP'.{u2, u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) (TypeVec.append1.{u2} n α β) F _inst_1 (TypeVec.PredLast'.{u2} n α β p) x) (MvFunctor.LiftP.{u2, u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) F _inst_1 (fun (i : Fin2 (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) => TypeVec.append1.{u2} n α β i) (TypeVec.PredLast.{u2} n α β p) x)
Case conversion may be inaccurate. Consider using '#align mvfunctor.liftp_last_pred_iff MvFunctor.LiftP_PredLast_iffₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem LiftP_PredLast_iff {β} (p : β → Prop) (x : F (α ::: β)) :
    LiftP' (PredLast' _ p) x ↔ LiftP (PredLast _ p) x :=
  by
  dsimp only [liftp, liftp']
  apply exists_iff_exists_of_mono F (f _ n α) (g _ n α)
  · ext (i⟨x, _⟩)
    cases i <;> rfl
  · intros
    rw [MvFunctor.map_map, (· ⊚ ·)]
    congr <;> ext (i⟨x, _⟩) <;> cases i <;> rfl
#align mvfunctor.liftp_last_pred_iff MvFunctor.LiftP_PredLast_iff

open Function

variable (rr : β → β → Prop)

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
private def f :
    ∀ n α,
      (fun i : Fin2 (n + 1) =>
          { p_1 : _ × _ // ofRepeat (RelLast' α rr i (TypeVec.prod.mk _ p_1.fst p_1.snd)) }) ⟹
        fun i : Fin2 (n + 1) => { p_1 : (α ::: β) i × _ // RelLast α rr p_1.fst p_1.snd }
  | _, α, Fin2.fs i, x =>
    ⟨x.val, cast (by simp only [rel_last] <;> erw [repeat_eq_iff_eq]) x.property⟩
  | _, α, Fin2.fz, x => ⟨x.val, x.property⟩
#align mvfunctor.f mvfunctor.f

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
private def g :
    ∀ n α,
      (fun i : Fin2 (n + 1) => { p_1 : (α ::: β) i × _ // RelLast α rr p_1.fst p_1.snd }) ⟹
        fun i : Fin2 (n + 1) =>
        { p_1 : _ × _ // ofRepeat (RelLast' α rr i (TypeVec.prod.mk _ p_1.1 p_1.2)) }
  | _, α, Fin2.fs i, x =>
    ⟨x.val, cast (by simp only [rel_last] <;> erw [repeat_eq_iff_eq]) x.property⟩
  | _, α, Fin2.fz, x => ⟨x.val, x.property⟩
#align mvfunctor.g mvfunctor.g

/- warning: mvfunctor.liftr_last_rel_iff -> MvFunctor.LiftR_RelLast_iff is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) F] [_inst_2 : LawfulMvFunctor.{u1, u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) F _inst_1] {α : TypeVec.{u1} n} {β : Type.{u1}} (rr : β -> β -> Prop) (x : F (TypeVec.append1.{u1} n α β)) (y : F (TypeVec.append1.{u1} n α β)), Iff (MvFunctor.LiftR'.{u1, u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) (TypeVec.append1.{u1} n α β) F _inst_1 (TypeVec.RelLast'.{u1} n α β rr) x y) (MvFunctor.LiftR.{u1, u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) F _inst_1 (fun (i : Fin2 (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) => TypeVec.append1.{u1} n α β i) (TypeVec.RelLast.{u1} n α β β rr) x y)
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) F] [_inst_2 : LawfulMvFunctor.{u2, u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) F _inst_1] {α : TypeVec.{u2} n} {β : Type.{u2}} (rr : β -> β -> Prop) (x : F (TypeVec.append1.{u2} n α β)) (y : F (TypeVec.append1.{u2} n α β)), Iff (MvFunctor.LiftR'.{u2, u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) (TypeVec.append1.{u2} n α β) F _inst_1 (TypeVec.RelLast'.{u2} n α β rr) x y) (MvFunctor.LiftR.{u2, u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) F _inst_1 (fun {i : Fin2 (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))} => TypeVec.append1.{u2} n α β i) (fun {i._@.Mathlib.Control.Functor.Multivariate._hyg.3418 : Fin2 (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))} => TypeVec.RelLast.{u2} n α β β rr i._@.Mathlib.Control.Functor.Multivariate._hyg.3418) x y)
Case conversion may be inaccurate. Consider using '#align mvfunctor.liftr_last_rel_iff MvFunctor.LiftR_RelLast_iffₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem LiftR_RelLast_iff (x y : F (α ::: β)) :
    LiftR' (RelLast' _ rr) x y ↔ LiftR (RelLast _ rr) x y :=
  by
  dsimp only [liftr, liftr']
  apply exists_iff_exists_of_mono F (f rr _ _) (g rr _ _)
  · ext (i⟨x, _⟩) : 2
    cases i <;> rfl
  · intros
    rw [MvFunctor.map_map, MvFunctor.map_map, (· ⊚ ·), (· ⊚ ·)]
    congr <;> ext (i⟨x, _⟩) <;> cases i <;> rfl
#align mvfunctor.liftr_last_rel_iff MvFunctor.LiftR_RelLast_iff

end LiftpLastPredIff

end MvFunctor


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot

Pi instances for algebraic structures.
-/
import order.basic
import algebra.module algebra.group
import data.finset
import tactic.pi_instances

namespace pi
universes u v w
variable {I : Type u}     -- The indexing type
variable {f : I → Type v} -- The family of types already equiped with instances
variables (x y : Π i, f i) (i : I)

instance has_zero [∀ i, has_zero $ f i] : has_zero (Π i : I, f i) := ⟨λ i, 0⟩
@[simp] lemma zero_apply [∀ i, has_zero $ f i] : (0 : Π i, f i) i = 0 := rfl

instance has_one [∀ i, has_one $ f i] : has_one (Π i : I, f i) := ⟨λ i, 1⟩
@[simp] lemma one_apply [∀ i, has_one $ f i] : (1 : Π i, f i) i = 1 := rfl

attribute [to_additive pi.has_zero] pi.has_one
attribute [to_additive pi.zero_apply] pi.one_apply

instance has_add [∀ i, has_add $ f i] : has_add (Π i : I, f i) := ⟨λ x y, λ i, x i + y i⟩
@[simp] lemma add_apply [∀ i, has_add $ f i] : (x + y) i = x i + y i := rfl

instance has_mul [∀ i, has_mul $ f i] : has_mul (Π i : I, f i) := ⟨λ x y, λ i, x i * y i⟩
@[simp] lemma mul_apply [∀ i, has_mul $ f i] : (x * y) i = x i * y i := rfl

attribute [to_additive pi.has_add] pi.has_mul
attribute [to_additive pi.add_apply] pi.mul_apply

instance has_inv [∀ i, has_inv $ f i] : has_inv (Π i : I, f i) := ⟨λ x, λ i, (x i)⁻¹⟩
@[simp] lemma inv_apply [∀ i, has_inv $ f i] : x⁻¹ i = (x i)⁻¹ := rfl

instance has_neg [∀ i, has_neg $ f i] : has_neg (Π i : I, f i) := ⟨λ x, λ i, -(x i)⟩
@[simp] lemma neg_apply [∀ i, has_neg $ f i] : (-x) i = -x i := rfl

attribute [to_additive pi.has_neg] pi.has_inv
attribute [to_additive pi.neg_apply] pi.inv_apply

instance has_scalar {α : Type*} [∀ i, has_scalar α $ f i] : has_scalar α (Π i : I, f i) := ⟨λ s x, λ i, s • (x i)⟩
@[simp] lemma smul_apply {α : Type*} [∀ i, has_scalar α $ f i] (s : α) : (s • x) i = s • x i := rfl

instance semigroup          [∀ i, semigroup          $ f i] : semigroup          (Π i : I, f i) := by pi_instance
instance comm_semigroup     [∀ i, comm_semigroup     $ f i] : comm_semigroup     (Π i : I, f i) := by pi_instance
instance monoid             [∀ i, monoid             $ f i] : monoid             (Π i : I, f i) := by pi_instance
instance comm_monoid        [∀ i, comm_monoid        $ f i] : comm_monoid        (Π i : I, f i) := by pi_instance
instance group              [∀ i, group              $ f i] : group              (Π i : I, f i) := by pi_instance
instance comm_group         [∀ i, comm_group         $ f i] : comm_group         (Π i : I, f i) := by pi_instance
instance add_semigroup      [∀ i, add_semigroup      $ f i] : add_semigroup      (Π i : I, f i) := by pi_instance
instance add_comm_semigroup [∀ i, add_comm_semigroup $ f i] : add_comm_semigroup (Π i : I, f i) := by pi_instance
instance add_monoid         [∀ i, add_monoid         $ f i] : add_monoid         (Π i : I, f i) := by pi_instance
instance add_comm_monoid    [∀ i, add_comm_monoid    $ f i] : add_comm_monoid    (Π i : I, f i) := by pi_instance
instance add_group          [∀ i, add_group          $ f i] : add_group          (Π i : I, f i) := by pi_instance
instance add_comm_group     [∀ i, add_comm_group     $ f i] : add_comm_group     (Π i : I, f i) := by pi_instance
instance ring               [∀ i, ring               $ f i] : ring               (Π i : I, f i) := by pi_instance
instance comm_ring          [∀ i, comm_ring          $ f i] : comm_ring          (Π i : I, f i) := by pi_instance

instance mul_action     (α) {m : monoid α}                                      [∀ i, mul_action α $ f i]     : mul_action α (Π i : I, f i) :=
{ smul := λ c f i, c • f i,
  mul_smul := λ r s f, funext $ λ i, mul_smul _ _ _,
  one_smul := λ f, funext $ λ i, one_smul α _ }

instance distrib_mul_action (α) {m : monoid α}         [∀ i, add_monoid $ f i]      [∀ i, distrib_mul_action α $ f i] : distrib_mul_action α (Π i : I, f i) :=
{ smul_zero := λ c, funext $ λ i, smul_zero _,
  smul_add := λ c f g, funext $ λ i, smul_add _ _ _,
  ..pi.mul_action _ }

variables (I f)

instance semimodule     (α) {r : semiring α}       [∀ i, add_comm_monoid $ f i] [∀ i, semimodule α $ f i]     : semimodule α (Π i : I, f i) :=
{ add_smul := λ c f g, funext $ λ i, add_smul _ _ _,
  zero_smul := λ f, funext $ λ i, zero_smul α _,
  ..pi.distrib_mul_action _ }

variables {I f}

instance module         (α) {r : ring α}           [∀ i, add_comm_group $ f i]  [∀ i, module α $ f i]         : module α (Π i : I, f i)       := {..pi.semimodule I f α}

instance vector_space   (α) {r : discrete_field α} [∀ i, add_comm_group $ f i]  [∀ i, vector_space α $ f i]   : vector_space α (Π i : I, f i) := {..pi.module α}

instance left_cancel_semigroup [∀ i, left_cancel_semigroup $ f i] : left_cancel_semigroup (Π i : I, f i) :=
by pi_instance

instance add_left_cancel_semigroup [∀ i, add_left_cancel_semigroup $ f i] : add_left_cancel_semigroup (Π i : I, f i) :=
by pi_instance

instance right_cancel_semigroup [∀ i, right_cancel_semigroup $ f i] : right_cancel_semigroup (Π i : I, f i) :=
by pi_instance

instance add_right_cancel_semigroup [∀ i, add_right_cancel_semigroup $ f i] : add_right_cancel_semigroup (Π i : I, f i) :=
by pi_instance

instance ordered_cancel_comm_monoid [∀ i, ordered_cancel_comm_monoid $ f i] : ordered_cancel_comm_monoid (Π i : I, f i) :=
by pi_instance

attribute [to_additive pi.add_semigroup]              pi.semigroup
attribute [to_additive pi.add_comm_semigroup]         pi.comm_semigroup
attribute [to_additive pi.add_monoid]                 pi.monoid
attribute [to_additive pi.add_comm_monoid]            pi.comm_monoid
attribute [to_additive pi.add_group]                  pi.group
attribute [to_additive pi.add_comm_group]             pi.comm_group
attribute [to_additive pi.add_left_cancel_semigroup]  pi.left_cancel_semigroup
attribute [to_additive pi.add_right_cancel_semigroup] pi.right_cancel_semigroup

@[to_additive pi.list_sum_apply]
lemma list_prod_apply {α : Type*} {β : α → Type*} [∀a, monoid (β a)] (a : α) :
  ∀ (l : list (Πa, β a)), l.prod a = (l.map (λf:Πa, β a, f a)).prod
| []       := rfl
| (f :: l) := by simp [mul_apply f l.prod a, list_prod_apply l]

@[to_additive pi.multiset_sum_apply]
lemma multiset_prod_apply {α : Type*} {β : α → Type*} [∀a, comm_monoid (β a)] (a : α)
  (s : multiset (Πa, β a)) : s.prod a = (s.map (λf:Πa, β a, f a)).prod :=
quotient.induction_on s $ assume l, begin simp [list_prod_apply a l] end

@[to_additive pi.finset_sum_apply]
lemma finset_prod_apply {α : Type*} {β : α → Type*} {γ} [∀a, comm_monoid (β a)] (a : α)
  (s : finset γ) (g : γ → Πa, β a) : s.prod g a = s.prod (λc, g c a) :=
show (s.val.map g).prod a = (s.val.map (λc, g c a)).prod,
  by rw [multiset_prod_apply, multiset.map_map]

def is_ring_hom_pi
  {α : Type u} {β : α → Type v} [R : Π a : α, ring (β a)]
  {γ : Type w} [ring γ]
  (f : Π a : α, γ → β a) [Rh : Π a : α, is_ring_hom (f a)] :
  is_ring_hom (λ x b, f b x) :=
begin
  dsimp at *,
  split,
  -- It's a pity that these can't be done using `simp` lemmas.
  { ext, rw [is_ring_hom.map_one (f x)], refl, },
  { intros x y, ext1 z, rw [is_ring_hom.map_mul (f z)], refl, },
  { intros x y, ext1 z, rw [is_ring_hom.map_add (f z)], refl, }
end

end pi

namespace prod

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*} {p q : α × β}

instance [has_add α] [has_add β] : has_add (α × β) :=
⟨λp q, (p.1 + q.1, p.2 + q.2)⟩
@[to_additive prod.has_add]
instance [has_mul α] [has_mul β] : has_mul (α × β) :=
⟨λp q, (p.1 * q.1, p.2 * q.2)⟩

@[simp, to_additive prod.fst_add]
lemma fst_mul [has_mul α] [has_mul β] : (p * q).1 = p.1 * q.1 := rfl
@[simp, to_additive prod.snd_add]
lemma snd_mul [has_mul α] [has_mul β] : (p * q).2 = p.2 * q.2 := rfl
@[simp, to_additive prod.mk_add_mk]
lemma mk_mul_mk [has_mul α] [has_mul β] (a₁ a₂ : α) (b₁ b₂ : β) :
  (a₁, b₁) * (a₂, b₂) = (a₁ * a₂, b₁ * b₂) := rfl

instance [has_zero α] [has_zero β] : has_zero (α × β) := ⟨(0, 0)⟩
@[to_additive prod.has_zero]
instance [has_one α] [has_one β] : has_one (α × β) := ⟨(1, 1)⟩

@[simp, to_additive prod.fst_zero]
lemma fst_one [has_one α] [has_one β] : (1 : α × β).1 = 1 := rfl
@[simp, to_additive prod.snd_zero]
lemma snd_one [has_one α] [has_one β] : (1 : α × β).2 = 1 := rfl
@[to_additive prod.zero_eq_mk]
lemma one_eq_mk [has_one α] [has_one β] : (1 : α × β) = (1, 1) := rfl

instance [has_neg α] [has_neg β] : has_neg (α × β) := ⟨λp, (- p.1, - p.2)⟩
@[to_additive prod.has_neg]
instance [has_inv α] [has_inv β] : has_inv (α × β) := ⟨λp, (p.1⁻¹, p.2⁻¹)⟩

@[simp, to_additive prod.fst_neg]
lemma fst_inv [has_inv α] [has_inv β] : (p⁻¹).1 = (p.1)⁻¹ := rfl
@[simp, to_additive prod.snd_neg]
lemma snd_inv [has_inv α] [has_inv β] : (p⁻¹).2 = (p.2)⁻¹ := rfl
@[to_additive prod.neg_mk]
lemma inv_mk [has_inv α] [has_inv β] (a : α) (b : β) : (a, b)⁻¹ = (a⁻¹, b⁻¹) := rfl

instance [add_semigroup α] [add_semigroup β] : add_semigroup (α × β) :=
{ add_assoc := assume a b c, mk.inj_iff.mpr ⟨add_assoc _ _ _, add_assoc _ _ _⟩,
  .. prod.has_add }
@[to_additive prod.add_semigroup]
instance [semigroup α] [semigroup β] : semigroup (α × β) :=
{ mul_assoc := assume a b c, mk.inj_iff.mpr ⟨mul_assoc _ _ _, mul_assoc _ _ _⟩,
  .. prod.has_mul }

instance [add_monoid α] [add_monoid β] : add_monoid (α × β) :=
{ zero_add := assume a, prod.rec_on a $ λa b, mk.inj_iff.mpr ⟨zero_add _, zero_add _⟩,
  add_zero := assume a, prod.rec_on a $ λa b, mk.inj_iff.mpr ⟨add_zero _, add_zero _⟩,
  .. prod.add_semigroup, .. prod.has_zero }
@[to_additive prod.add_monoid]
instance [monoid α] [monoid β] : monoid (α × β) :=
{ one_mul := assume a, prod.rec_on a $ λa b, mk.inj_iff.mpr ⟨one_mul _, one_mul _⟩,
  mul_one := assume a, prod.rec_on a $ λa b, mk.inj_iff.mpr ⟨mul_one _, mul_one _⟩,
  .. prod.semigroup, .. prod.has_one }

instance [add_group α] [add_group β] : add_group (α × β) :=
{ add_left_neg := assume a, mk.inj_iff.mpr ⟨add_left_neg _, add_left_neg _⟩,
  .. prod.add_monoid, .. prod.has_neg }
@[to_additive prod.add_group]
instance [group α] [group β] : group (α × β) :=
{ mul_left_inv := assume a, mk.inj_iff.mpr ⟨mul_left_inv _, mul_left_inv _⟩,
  .. prod.monoid, .. prod.has_inv }

instance [add_comm_semigroup α] [add_comm_semigroup β] : add_comm_semigroup (α × β) :=
{ add_comm := assume a b, mk.inj_iff.mpr ⟨add_comm _ _, add_comm _ _⟩,
  .. prod.add_semigroup }
@[to_additive prod.add_comm_semigroup]
instance [comm_semigroup α] [comm_semigroup β] : comm_semigroup (α × β) :=
{ mul_comm := assume a b, mk.inj_iff.mpr ⟨mul_comm _ _, mul_comm _ _⟩,
  .. prod.semigroup }

instance [add_comm_monoid α] [add_comm_monoid β] : add_comm_monoid (α × β) :=
{ .. prod.add_comm_semigroup, .. prod.add_monoid }
@[to_additive prod.add_comm_monoid]
instance [comm_monoid α] [comm_monoid β] : comm_monoid (α × β) :=
{ .. prod.comm_semigroup, .. prod.monoid }

instance [add_comm_group α] [add_comm_group β] : add_comm_group (α × β) :=
{ .. prod.add_comm_semigroup, .. prod.add_group }
@[to_additive prod.add_comm_group]
instance [comm_group α] [comm_group β] : comm_group (α × β) :=
{ .. prod.comm_semigroup, .. prod.group }

@[to_additive fst.is_add_monoid_hom]
lemma fst.is_monoid_hom [monoid α] [monoid β] : is_monoid_hom (prod.fst : α × β → α) :=
by refine_struct {..}; simp
@[to_additive snd.is_add_monoid_hom]
lemma snd.is_monoid_hom [monoid α] [monoid β] : is_monoid_hom (prod.snd : α × β → β) :=
by refine_struct {..}; simp

@[to_additive fst.is_add_group_hom]
lemma fst.is_group_hom [group α] [group β] : is_group_hom (prod.fst : α × β → α) :=
by refine_struct {..}; simp
@[to_additive snd.is_add_group_hom]
lemma snd.is_group_hom [group α] [group β] : is_group_hom (prod.snd : α × β → β) :=
by refine_struct {..}; simp

attribute [instance] fst.is_monoid_hom fst.is_add_monoid_hom snd.is_monoid_hom snd.is_add_monoid_hom
fst.is_group_hom fst.is_add_group_hom snd.is_group_hom snd.is_add_group_hom

@[to_additive prod.fst_sum]
lemma fst_prod [comm_monoid α] [comm_monoid β] {t : finset γ} {f : γ → α × β} :
  (t.prod f).1 = t.prod (λc, (f c).1) :=
(finset.prod_hom prod.fst).symm

@[to_additive prod.snd_sum]
lemma snd_prod [comm_monoid α] [comm_monoid β] {t : finset γ} {f : γ → α × β} :
  (t.prod f).2 = t.prod (λc, (f c).2) :=
(finset.prod_hom prod.snd).symm

instance [semiring α] [semiring β] : semiring (α × β) :=
{ zero_mul := λ a, mk.inj_iff.mpr ⟨zero_mul _, zero_mul _⟩,
  mul_zero := λ a, mk.inj_iff.mpr ⟨mul_zero _, mul_zero _⟩,
  left_distrib := λ a b c, mk.inj_iff.mpr ⟨left_distrib _ _ _, left_distrib _ _ _⟩,
  right_distrib := λ a b c, mk.inj_iff.mpr ⟨right_distrib _ _ _, right_distrib _ _ _⟩,
  ..prod.add_comm_monoid, ..prod.monoid }

instance [ring α] [ring β] : ring (α × β) :=
{ ..prod.add_comm_group, ..prod.semiring }

instance [comm_ring α] [comm_ring β] : comm_ring (α × β) :=
{ ..prod.ring, ..prod.comm_monoid }

instance [nonzero_comm_ring α] [comm_ring β] : nonzero_comm_ring (α × β) :=
{ zero_ne_one := mt (congr_arg prod.fst) zero_ne_one,
  ..prod.comm_ring }

instance fst.is_semiring_hom [semiring α] [semiring β] : is_semiring_hom (prod.fst : α × β → α) :=
by refine_struct {..}; simp
instance snd.is_semiring_hom [semiring α] [semiring β] : is_semiring_hom (prod.snd : α × β → β) :=
by refine_struct {..}; simp

instance fst.is_ring_hom [ring α] [ring β] : is_ring_hom (prod.fst : α × β → α) :=
by refine_struct {..}; simp
instance snd.is_ring_hom [ring α] [ring β] : is_ring_hom (prod.snd : α × β → β) :=
by refine_struct {..}; simp

/-- Left injection function for the inner product
From a vector space (and also group and module) perspective the product is the same as the sum of
two vector spaces. `inl` and `inr` provide the corresponding injection functions.
-/
def inl [has_zero β] (a : α) : α × β := (a, 0)

/-- Right injection function for the inner product -/
def inr [has_zero α] (b : β) : α × β := (0, b)

lemma injective_inl [has_zero β] : function.injective (inl : α → α × β) :=
assume x y h, (prod.mk.inj_iff.mp h).1

lemma injective_inr [has_zero α] : function.injective (inr : β → α × β) :=
assume x y h, (prod.mk.inj_iff.mp h).2

@[simp] lemma inl_eq_inl [has_zero β] {a₁ a₂ : α} : (inl a₁ : α × β) = inl a₂ ↔ a₁ = a₂ :=
iff.intro (assume h, injective_inl h) (assume h, h ▸ rfl)

@[simp] lemma inr_eq_inr [has_zero α] {b₁ b₂ : β} : (inr b₁ : α × β) = inr b₂ ↔ b₁ = b₂ :=
iff.intro (assume h, injective_inr h) (assume h, h ▸ rfl)

@[simp] lemma inl_eq_inr [has_zero α] [has_zero β] {a : α} {b : β} :
  inl a = inr b ↔ a = 0 ∧ b = 0 :=
by constructor; simp [inl, inr] {contextual := tt}

@[simp] lemma inr_eq_inl [has_zero α] [has_zero β] {a : α} {b : β} :
  inr b = inl a ↔ a = 0 ∧ b = 0 :=
by constructor; simp [inl, inr] {contextual := tt}

@[simp] lemma fst_inl [has_zero β] (a : α) : (inl a : α × β).1 = a := rfl
@[simp] lemma snd_inl [has_zero β] (a : α) : (inl a : α × β).2 = 0 := rfl
@[simp] lemma fst_inr [has_zero α] (b : β) : (inr b : α × β).1 = 0 := rfl
@[simp] lemma snd_inr [has_zero α] (b : β) : (inr b : α × β).2 = b := rfl

instance [has_scalar α β] [has_scalar α γ] : has_scalar α (β × γ) := ⟨λa p, (a • p.1, a • p.2)⟩

@[simp] theorem smul_fst [has_scalar α β] [has_scalar α γ]
  (a : α) (x : β × γ) : (a • x).1 = a • x.1 := rfl
@[simp] theorem smul_snd [has_scalar α β] [has_scalar α γ]
  (a : α) (x : β × γ) : (a • x).2 = a • x.2 := rfl
@[simp] theorem smul_mk [has_scalar α β] [has_scalar α γ]
  (a : α) (b : β) (c : γ) : a • (b, c) = (a • b, a • c) := rfl

instance {r : semiring α} [add_comm_monoid β] [add_comm_monoid γ]
  [semimodule α β] [semimodule α γ] : semimodule α (β × γ) :=
{ smul_add  := assume a p₁ p₂, mk.inj_iff.mpr ⟨smul_add _ _ _, smul_add _ _ _⟩,
  add_smul  := assume a p₁ p₂, mk.inj_iff.mpr ⟨add_smul _ _ _, add_smul _ _ _⟩,
  mul_smul  := assume a₁ a₂ p, mk.inj_iff.mpr ⟨mul_smul _ _ _, mul_smul _ _ _⟩,
  one_smul  := assume ⟨b, c⟩, mk.inj_iff.mpr ⟨one_smul _ _, one_smul _ _⟩,
  zero_smul := assume ⟨b, c⟩, mk.inj_iff.mpr ⟨zero_smul _ _, zero_smul _ _⟩,
  smul_zero := assume a, mk.inj_iff.mpr ⟨smul_zero _, smul_zero _⟩,
  .. prod.has_scalar }

instance {r : ring α} [add_comm_group β] [add_comm_group γ]
  [module α β] [module α γ] : module α (β × γ) := {}

instance {r : discrete_field α} [add_comm_group β] [add_comm_group γ]
  [vector_space α β] [vector_space α γ] : vector_space α (β × γ) := {}

end prod

namespace finset

@[to_additive finset.prod_mk_sum]
lemma prod_mk_prod {α β γ : Type*} [comm_monoid α] [comm_monoid β] (s : finset γ)
  (f : γ → α) (g : γ → β) : (s.prod f, s.prod g) = s.prod (λ x, (f x, g x)) :=
by haveI := classical.dec_eq γ; exact
finset.induction_on s rfl (by simp [prod.ext_iff] {contextual := tt})

end finset


/-
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.big_operators

/-!
# 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, 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 even_iff_two_dvd at hxsuby hxaddy,
    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_right
  (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_rfl
      ... < (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 (λ x, coe (f x)) (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 only [int.cast_pow, int.cast_add, equiv.swap_apply_right, zmod.pow_card] 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 only [int.cast_pow, int.cast_add, zmod.pow_card] 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 ←equiv.sum_comp σ } },
    simpa only [fin.sum_univ_four, add_assoc] using this,
  end⟩

private lemma prime_sum_four_squares (p : ℕ) [hp : 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 only [zero_pow two_pos, one_pow, add_zero] 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 : ne_zero m := ne_zero.of_pos (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 { rintro rfl, rw mul_zero at hk, exact ne_zero.ne m hk },
    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], norm_num })⟩)
  (λ 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 { push_cast, simp_rw sq_abs, },
      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 only [bit0_mul, one_mul, two_smul,
                                                  nat.cast_add, nat.cast_pow, 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 push_cast,
      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 only [add_eq_zero_iff, int.nat_abs_eq_zero, zmod.val_min_abs_eq_zero, and.assoc,
                         pow_eq_zero_iff two_pos, char_p.int_cast_eq_zero_iff _ m _] 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.2 hm0.1)).1 $
              by { rw [← habcd, hma, hmb, hmc, hmd], ring }⟩,
        (hp.1.eq_one_or_self_of_dvd _ 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_rw [sq], push_cast },
      have haxbwczdy : ((m : ℕ) : ℤ) ∣ a * x - b * w - c * z + d * y,
        from (char_p.int_cast_eq_zero_iff (zmod m) m _).1 $ by { push_cast, 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 { push_cast, 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 { push_cast, 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_right
          (by { erw [← hn], repeat {try {refine add_nonneg _ _}, try {exact sq_nonneg _}} })
          (int.coe_nat_pos.2 $ ne_zero.pos m),
      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.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⟩)

/-- **Four squares theorem** -/
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 : 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) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang

! This file was ported from Lean 3 source module algebraic_geometry.AffineScheme
! leanprover-community/mathlib commit d39590fc8728fbf6743249802486f8c91ffe07bc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.AlgebraicGeometry.GammaSpecAdjunction
import Mathbin.AlgebraicGeometry.OpenImmersion
import Mathbin.CategoryTheory.Limits.Opposites
import Mathbin.RingTheory.Localization.InvSubmonoid

/-!
# 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 section

open CategoryTheory CategoryTheory.Limits Opposite TopologicalSpace

universe u

namespace AlgebraicGeometry

open Spec (structureSheaf)

/-- The category of affine schemes -/
@[nolint has_nonempty_instance]
def AffineScheme :=
  Scheme.spec.EssImageSubcategory deriving Category
#align algebraic_geometry.AffineScheme AlgebraicGeometry.AffineScheme

/-- A Scheme is affine if the canonical map `X ⟶ Spec Γ(X)` is an isomorphism. -/
class IsAffine (X : Scheme) : Prop where
  affine : IsIso (ΓSpec.adjunction.Unit.app X)
#align algebraic_geometry.is_affine AlgebraicGeometry.IsAffine

attribute [instance] is_affine.affine

/-- The canonical isomorphism `X ≅ Spec Γ(X)` for an affine scheme. -/
def Scheme.isoSpec (X : Scheme) [IsAffine X] : X ≅ Scheme.spec.obj (op <| Scheme.Γ.obj <| op X) :=
  asIso (ΓSpec.adjunction.Unit.app X)
#align algebraic_geometry.Scheme.iso_Spec AlgebraicGeometry.Scheme.isoSpec

/-- Construct an affine scheme from a scheme and the information that it is affine.
Also see `AffineScheme.of` for a typclass version. -/
@[simps]
def AffineScheme.mk (X : Scheme) (h : IsAffine X) : AffineScheme :=
  ⟨X, @mem_essImage_of_unit_isIso _ _ _ _ h.1⟩
#align algebraic_geometry.AffineScheme.mk AlgebraicGeometry.AffineScheme.mk

/-- Construct an affine scheme from a scheme. Also see `AffineScheme.mk` for a non-typeclass
version. -/
def AffineScheme.of (X : Scheme) [h : IsAffine X] : AffineScheme :=
  AffineScheme.mk X h
#align algebraic_geometry.AffineScheme.of AlgebraicGeometry.AffineScheme.of

/-- Type check a morphism of schemes as a morphism in `AffineScheme`. -/
def AffineScheme.ofHom {X Y : Scheme} [IsAffine X] [IsAffine Y] (f : X ⟶ Y) :
    AffineScheme.of X ⟶ AffineScheme.of Y :=
  f
#align algebraic_geometry.AffineScheme.of_hom AlgebraicGeometry.AffineScheme.ofHom

theorem mem_spec_essImage (X : Scheme) : X ∈ Scheme.spec.essImage ↔ IsAffine X :=
  ⟨fun h => ⟨Functor.essImage.unit_isIso h⟩, fun h => @mem_essImage_of_unit_isIso _ _ _ X h.1⟩
#align algebraic_geometry.mem_Spec_ess_image AlgebraicGeometry.mem_spec_essImage

instance isAffineAffineScheme (X : AffineScheme.{u}) : IsAffine X.obj :=
  ⟨Functor.essImage.unit_isIso X.property⟩
#align algebraic_geometry.is_affine_AffineScheme AlgebraicGeometry.isAffineAffineScheme

instance specIsAffine (R : CommRingCatᵒᵖ) : IsAffine (Scheme.spec.obj R) :=
  AlgebraicGeometry.isAffineAffineScheme ⟨_, Scheme.spec.obj_mem_essImage R⟩
#align algebraic_geometry.Spec_is_affine AlgebraicGeometry.specIsAffine

theorem isAffineOfIso {X Y : Scheme} (f : X ⟶ Y) [IsIso f] [h : IsAffine Y] : IsAffine X :=
  by
  rw [← mem_Spec_ess_image] at h⊢
  exact functor.ess_image.of_iso (as_iso f).symm h
#align algebraic_geometry.is_affine_of_iso AlgebraicGeometry.isAffineOfIso

namespace AffineScheme

/-- The `Spec` functor into the category of affine schemes. -/
def spec : CommRingCatᵒᵖ ⥤ AffineScheme :=
  Scheme.spec.toEssImage deriving Full, Faithful, EssSurj
#align algebraic_geometry.AffineScheme.Spec AlgebraicGeometry.AffineScheme.spec

/-- The forgetful functor `AffineScheme ⥤ Scheme`. -/
@[simps]
def forgetToScheme : AffineScheme ⥤ Scheme :=
  Scheme.spec.essImageInclusion deriving Full, Faithful
#align algebraic_geometry.AffineScheme.forget_to_Scheme AlgebraicGeometry.AffineScheme.forgetToScheme

/-- The global section functor of an affine scheme. -/
def Γ : AffineSchemeᵒᵖ ⥤ CommRingCat :=
  forgetToScheme.op ⋙ Scheme.Γ
#align algebraic_geometry.AffineScheme.Γ AlgebraicGeometry.AffineScheme.Γ

/-- The category of affine schemes is equivalent to the category of commutative rings. -/
def equivCommRing : AffineScheme ≌ CommRingCatᵒᵖ :=
  equivEssImageOfReflective.symm
#align algebraic_geometry.AffineScheme.equiv_CommRing AlgebraicGeometry.AffineScheme.equivCommRing

instance ΓIsEquiv : IsEquivalence Γ.{u} :=
  haveI : is_equivalence Γ.{u}.rightOp.op := is_equivalence.of_equivalence equiv_CommRing.op
  (functor.is_equivalence_trans Γ.{u}.rightOp.op (op_op_equivalence _).Functor : _)
#align algebraic_geometry.AffineScheme.Γ_is_equiv AlgebraicGeometry.AffineScheme.ΓIsEquiv

instance : HasColimits AffineScheme.{u} :=
  haveI := Adjunction.has_limits_of_equivalence.{u} Γ.{u}
  Adjunction.has_colimits_of_equivalence.{u} (op_op_equivalence AffineScheme.{u}).inverse

instance : HasLimits AffineScheme.{u} :=
  by
  haveI := adjunction.has_colimits_of_equivalence Γ.{u}
  haveI : has_limits AffineScheme.{u}ᵒᵖᵒᵖ := limits.has_limits_op_of_has_colimits
  exact adjunction.has_limits_of_equivalence (op_op_equivalence AffineScheme.{u}).inverse

noncomputable instance : PreservesLimits Γ.{u}.rightOp :=
  @Adjunction.isEquivalencePreservesLimits _ _ Γ.rightOp (IsEquivalence.ofEquivalence equivCommRing)

noncomputable instance : PreservesLimits forgetToScheme :=
  by
  apply (config := { instances := false })
    @preserves_limits_of_nat_iso _ _
      (iso_whisker_right equiv_CommRing.unit_iso forget_to_Scheme).symm
  change preserves_limits (equiv_CommRing.functor ⋙ Scheme.Spec)
  infer_instance

end AffineScheme

/-- An open subset of a scheme is affine if the open subscheme is affine. -/
def IsAffineOpen {X : Scheme} (U : Opens X.carrier) : Prop :=
  IsAffine (X.restrict U.OpenEmbedding)
#align algebraic_geometry.is_affine_open AlgebraicGeometry.IsAffineOpen

/-- The set of affine opens as a subset of `opens X.carrier`. -/
def Scheme.affineOpens (X : Scheme) : Set (Opens X.carrier) :=
  { U : Opens X.carrier | IsAffineOpen U }
#align algebraic_geometry.Scheme.affine_opens AlgebraicGeometry.Scheme.affineOpens

theorem range_isAffineOpen_of_open_immersion {X Y : Scheme} [IsAffine X] (f : X ⟶ Y)
    [H : IsOpenImmersion f] : IsAffineOpen f.opensRange :=
  by
  refine' is_affine_of_iso (is_open_immersion.iso_of_range_eq f (Y.of_restrict _) _).inv
  exact subtype.range_coe.symm
  infer_instance
#align algebraic_geometry.range_is_affine_open_of_open_immersion AlgebraicGeometry.range_isAffineOpen_of_open_immersion

theorem top_isAffineOpen (X : Scheme) [IsAffine X] : IsAffineOpen (⊤ : Opens X.carrier) :=
  by
  convert range_is_affine_open_of_open_immersion (𝟙 X)
  ext1
  exact set.range_id.symm
#align algebraic_geometry.top_is_affine_open AlgebraicGeometry.top_isAffineOpen

instance Scheme.affineCoverIsAffine (X : Scheme) (i : X.affineCover.J) :
    IsAffine (X.affineCover.obj i) :=
  AlgebraicGeometry.specIsAffine _
#align algebraic_geometry.Scheme.affine_cover_is_affine AlgebraicGeometry.Scheme.affineCoverIsAffine

instance Scheme.affineBasisCoverIsAffine (X : Scheme) (i : X.affineBasisCover.J) :
    IsAffine (X.affineBasisCover.obj i) :=
  AlgebraicGeometry.specIsAffine _
#align algebraic_geometry.Scheme.affine_basis_cover_is_affine AlgebraicGeometry.Scheme.affineBasisCoverIsAffine

theorem isBasis_affine_open (X : Scheme) : Opens.IsBasis X.affineOpens :=
  by
  rw [opens.is_basis_iff_nbhd]
  rintro 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.is_open
  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 _
#align algebraic_geometry.is_basis_affine_open AlgebraicGeometry.isBasis_affine_open

/-- The open immersion `Spec 𝒪ₓ(U) ⟶ X` for an affine `U`. -/
def IsAffineOpen.fromSpec {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U) :
    Scheme.spec.obj (op <| X.Presheaf.obj <| op U) ⟶ X :=
  by
  haveI : is_affine (X.restrict U.open_embedding) := hU
  have : U.open_embedding.is_open_map.functor.obj ⊤ = U :=
    by
    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).isoSpec.inv ≫ X.of_restrict _
#align algebraic_geometry.is_affine_open.from_Spec AlgebraicGeometry.IsAffineOpen.fromSpec

instance IsAffineOpen.isOpenImmersion_fromSpec {X : Scheme} {U : Opens X.carrier}
    (hU : IsAffineOpen U) : IsOpenImmersion hU.fromSpec :=
  by
  delta is_affine_open.from_Spec
  infer_instance
#align algebraic_geometry.is_affine_open.is_open_immersion_from_Spec AlgebraicGeometry.IsAffineOpen.isOpenImmersion_fromSpec

theorem IsAffineOpen.fromSpec_range {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U) :
    Set.range hU.fromSpec.1.base = (U : Set X.carrier) :=
  by
  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 [← TopCat.epi_iff_surjective]
  infer_instance
#align algebraic_geometry.is_affine_open.from_Spec_range AlgebraicGeometry.IsAffineOpen.fromSpec_range

theorem IsAffineOpen.fromSpec_image_top {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U) :
    hU.isOpenImmersion_fromSpec.base_open.IsOpenMap.Functor.obj ⊤ = U :=
  by
  ext1
  exact set.image_univ.trans hU.from_Spec_range
#align algebraic_geometry.is_affine_open.from_Spec_image_top AlgebraicGeometry.IsAffineOpen.fromSpec_image_top

theorem IsAffineOpen.isCompact {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U) :
    IsCompact (U : Set X.carrier) :=
  by
  convert@IsCompact.image _ _ _ _ Set.univ hU.from_Spec.1.base PrimeSpectrum.compactSpace.1
      (by continuity)
  convert hU.from_Spec_range.symm
  exact Set.image_univ
#align algebraic_geometry.is_affine_open.is_compact AlgebraicGeometry.IsAffineOpen.isCompact

theorem IsAffineOpen.image_isOpenImmersion {X Y : Scheme} {U : Opens X.carrier}
    (hU : IsAffineOpen U) (f : X ⟶ Y) [H : IsOpenImmersion f] :
    IsAffineOpen (f.opensFunctor.obj U) :=
  by
  haveI : is_affine _ := hU
  convert range_is_affine_open_of_open_immersion (X.of_restrict U.open_embedding ≫ f)
  ext1
  exact Set.image_eq_range _ _
#align algebraic_geometry.is_affine_open.image_is_open_immersion AlgebraicGeometry.IsAffineOpen.image_isOpenImmersion

theorem isAffineOpen_iff_of_isOpenImmersion {X Y : Scheme} (f : X ⟶ Y) [H : IsOpenImmersion f]
    (U : Opens X.carrier) : IsAffineOpen (H.openFunctor.obj U) ↔ IsAffineOpen U :=
  by
  refine' ⟨fun hU => @is_affine_of_iso _ _ hU, fun hU => hU.image_isOpenImmersion f⟩
  refine' (is_open_immersion.iso_of_range_eq (X.of_restrict _ ≫ f) (Y.of_restrict _) _).Hom
  · rw [Scheme.comp_val_base, coe_comp, Set.range_comp]
    dsimp [opens.inclusion]
    rw [Subtype.range_coe, Subtype.range_coe]
    rfl
  · infer_instance
#align algebraic_geometry.is_affine_open_iff_of_is_open_immersion AlgebraicGeometry.isAffineOpen_iff_of_isOpenImmersion

instance Scheme.quasi_compact_of_affine (X : Scheme) [IsAffine X] : CompactSpace X.carrier :=
  ⟨(top_isAffineOpen X).IsCompact⟩
#align algebraic_geometry.Scheme.quasi_compact_of_affine AlgebraicGeometry.Scheme.quasi_compact_of_affine

theorem IsAffineOpen.fromSpec_base_preimage {X : Scheme} {U : Opens X.carrier}
    (hU : IsAffineOpen U) : (Opens.map hU.fromSpec.val.base).obj U = ⊤ :=
  by
  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
#align algebraic_geometry.is_affine_open.from_Spec_base_preimage AlgebraicGeometry.IsAffineOpen.fromSpec_base_preimage

theorem Scheme.specMap_presheaf_map_eqToHom {X : Scheme} {U V : Opens X.carrier} (h : U = V) (W) :
    (Scheme.spec.map (X.Presheaf.map (eqToHom h).op).op).val.c.app W =
      eqToHom
        (by
          cases h
          induction W using Opposite.rec
          dsimp
          simp
          rfl) :=
  by
  have : Scheme.Spec.map (X.presheaf.map (𝟙 (op U))).op = 𝟙 _ := by
    rw [X.presheaf.map_id, op_id, Scheme.Spec.map_id]
  cases h
  refine' (Scheme.congr_app this _).trans _
  erw [category.id_comp]
  simpa [eq_to_hom_map]
#align algebraic_geometry.Scheme.Spec_map_presheaf_map_eq_to_hom AlgebraicGeometry.Scheme.specMap_presheaf_map_eqToHom

theorem IsAffineOpen.specΓIdentity_hom_app_fromSpec {X : Scheme} {U : Opens X.carrier}
    (hU : IsAffineOpen U) :
    specΓIdentity.Hom.app (X.Presheaf.obj <| op U) ≫ hU.fromSpec.1.c.app (op U) =
      (Scheme.spec.obj _).Presheaf.map (eqToHom hU.fromSpec_base_preimage).op :=
  by
  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]
#align algebraic_geometry.is_affine_open.Spec_Γ_identity_hom_app_from_Spec AlgebraicGeometry.IsAffineOpen.specΓIdentity_hom_app_fromSpec

@[elementwise]
theorem IsAffineOpen.fromSpec_app_eq {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U) :
    hU.fromSpec.1.c.app (op U) =
      specΓIdentity.inv.app (X.Presheaf.obj <| op U) ≫
        (Scheme.spec.obj _).Presheaf.map (eqToHom hU.fromSpec_base_preimage).op :=
  by rw [← hU.Spec_Γ_identity_hom_app_from_Spec, iso.inv_hom_id_app_assoc]
#align algebraic_geometry.is_affine_open.from_Spec_app_eq AlgebraicGeometry.IsAffineOpen.fromSpec_app_eq

theorem IsAffineOpen.basicOpen_is_affine {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U)
    (f : X.Presheaf.obj (op U)) : IsAffineOpen (X.basicOpen f) :=
  by
  convert range_is_affine_open_of_open_immersion
      (Scheme.Spec.map
          (CommRingCat.ofHom (algebraMap (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) :=
    by
    rw [Set.image_preimage_eq_inter_range, Set.inter_eq_left_iff_subset, hU.from_Spec_range]
    exact Scheme.basic_open_le _ _
  rw [Scheme.hom.opens_range_coe, 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 _ (PrimeSpectrum.localization_away_comap_range (Localization.Away f) f).symm
  congr 1
  have : (opens.map hU.from_Spec.val.base).obj U = ⊤ :=
    by
    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 := fun s => this.symm ▸ top_inf_eq
  refine' Eq.trans _ (lm _)
  refine'
    Eq.trans _
      ((Scheme.Spec.obj <| op <| X.presheaf.obj <| op U).basicOpen_res _ (eq_to_hom this).op)
  rw [← comp_apply]
  congr 2
  rw [iso.eq_inv_comp]
  erw [hU.Spec_Γ_identity_hom_app_from_Spec]
#align algebraic_geometry.is_affine_open.basic_open_is_affine AlgebraicGeometry.IsAffineOpen.basicOpen_is_affine

theorem IsAffineOpen.map_restrict_basicOpen {X : Scheme} (r : X.Presheaf.obj (op ⊤))
    {U : Opens X.carrier} (hU : IsAffineOpen U) :
    IsAffineOpen ((Opens.map (X.of_restrict (X.basicOpen r).OpenEmbedding).1.base).obj U) :=
  by
  apply
    (is_affine_open_iff_of_is_open_immersion (X.of_restrict (X.basic_open r).OpenEmbedding) _).mp
  delta PresheafedSpace.is_open_immersion.open_functor
  dsimp
  erw [opens.functor_obj_map_obj, opens.open_embedding_obj_top, inf_comm, ←
    Scheme.basic_open_res _ _ (hom_of_le le_top).op]
  exact hU.basic_open_is_affine _
#align algebraic_geometry.is_affine_open.map_restrict_basic_open AlgebraicGeometry.IsAffineOpen.map_restrict_basicOpen

theorem Scheme.map_prime_spectrum_basicOpen_of_affine (X : Scheme) [IsAffine X]
    (f : Scheme.Γ.obj (op X)) :
    (Opens.map X.isoSpec.Hom.1.base).obj (PrimeSpectrum.basicOpen f) = X.basicOpen f :=
  by
  rw [← basic_open_eq_of_affine]
  trans
    (opens.map X.iso_Spec.hom.1.base).obj
      ((Scheme.Spec.obj (op (Scheme.Γ.obj (op X)))).basicOpen
        ((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]
    rfl
  · rw [eq_to_hom_map]
    rfl
  · dsimp
    congr
  · refine' (Scheme.preimage_basic_open _ _).trans _
    rw [is_iso.inv_hom_id_apply, Scheme.basic_open_res_eq]
#align algebraic_geometry.Scheme.map_prime_spectrum_basic_open_of_affine AlgebraicGeometry.Scheme.map_prime_spectrum_basicOpen_of_affine

theorem isBasis_basicOpen (X : Scheme) [IsAffine X] :
    Opens.IsBasis (Set.range (X.basicOpen : X.Presheaf.obj (op ⊤) → Opens X.carrier)) :=
  by
  delta opens.is_basis
  convert prime_spectrum.is_basis_basic_opens.inducing
      (TopCat.homeoOfIso (Scheme.forget_to_Top.map_iso X.iso_Spec)).Inducing using
    1
  ext
  simp only [Set.mem_image, exists_exists_eq_and]
  constructor
  · rintro ⟨_, ⟨x, rfl⟩, rfl⟩
    refine' ⟨_, ⟨_, ⟨x, rfl⟩, rfl⟩, _⟩
    exact congr_arg opens.carrier (X.map_prime_spectrum_basic_open_of_affine x)
  · rintro ⟨_, ⟨_, ⟨x, rfl⟩, rfl⟩, rfl⟩
    refine' ⟨_, ⟨x, rfl⟩, _⟩
    exact congr_arg opens.carrier (X.map_prime_spectrum_basic_open_of_affine x).symm
#align algebraic_geometry.is_basis_basic_open AlgebraicGeometry.isBasis_basicOpen

theorem IsAffineOpen.exists_basicOpen_le {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U)
    {V : Opens X.carrier} (x : V) (h : ↑x ∈ U) :
    ∃ f : X.Presheaf.obj (op U), X.basicOpen f ≤ V ∧ ↑x ∈ X.basicOpen f :=
  by
  haveI : is_affine _ := hU
  obtain ⟨_, ⟨_, ⟨r, rfl⟩, rfl⟩, h₁, h₂⟩ :=
    (is_basis_basic_open (X.restrict U.open_embedding)).exists_subset_of_mem_open _
      ((opens.map U.inclusion).obj V).IsOpen
  swap
  exact ⟨x, h⟩
  have :
    U.open_embedding.is_open_map.functor.obj ((X.restrict U.open_embedding).basicOpen r) =
      X.basic_open (X.presheaf.map (eq_to_hom U.open_embedding_obj_top.symm).op r) :=
    by
    refine' (Scheme.image_basic_open (X.of_restrict U.open_embedding) r).trans _
    erw [← Scheme.basic_open_res_eq _ _ (eq_to_hom U.open_embedding_obj_top).op]
    rw [← comp_apply, ← CategoryTheory.Functor.map_comp, ← op_comp, eq_to_hom_trans, eq_to_hom_refl,
      op_id, CategoryTheory.Functor.map_id, Scheme.hom.inv_app]
    erw [PresheafedSpace.is_open_immersion.of_restrict_inv_app]
    congr
  use X.presheaf.map (eq_to_hom U.open_embedding_obj_top.symm).op r
  rw [← this]
  exact ⟨set.image_subset_iff.mpr h₂, Set.mem_image_of_mem _ h₁⟩
  exact x.prop
#align algebraic_geometry.is_affine_open.exists_basic_open_le AlgebraicGeometry.IsAffineOpen.exists_basicOpen_le

instance {X : Scheme} {U : Opens X.carrier} (f : X.Presheaf.obj (op U)) :
    Algebra (X.Presheaf.obj (op U)) (X.Presheaf.obj (op <| X.basicOpen f)) :=
  (X.Presheaf.map (homOfLE <| RingedSpace.basicOpen_le _ f : _ ⟶ U).op).toAlgebra

theorem IsAffineOpen.opens_map_fromSpec_basicOpen {X : Scheme} {U : Opens X.carrier}
    (hU : IsAffineOpen U) (f : X.Presheaf.obj (op U)) :
    (Opens.map hU.fromSpec.val.base).obj (X.basicOpen f) =
      RingedSpace.basicOpen _ (specΓIdentity.inv.app (X.Presheaf.obj <| op U) f) :=
  by
  erw [LocallyRingedSpace.preimage_basic_open]
  refine'
    Eq.trans _
      (RingedSpace.basic_open_res_eq
        (Scheme.Spec.obj <| op <| X.presheaf.obj (op U)).toLocallyRingedSpace.toRingedSpace
        (eq_to_hom hU.from_Spec_base_preimage).op _)
  congr
  rw [← comp_apply]
  congr
  erw [← hU.Spec_Γ_identity_hom_app_from_Spec]
  rw [iso.inv_hom_id_app_assoc]
#align algebraic_geometry.is_affine_open.opens_map_from_Spec_basic_open AlgebraicGeometry.IsAffineOpen.opens_map_fromSpec_basicOpen

/-- The canonical map `Γ(𝒪ₓ, D(f)) ⟶ Γ(Spec 𝒪ₓ(U), D(Spec_Γ_identity.inv f))`
This is an isomorphism, as witnessed by an `is_iso` instance. -/
def basicOpenSectionsToAffine {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U)
    (f : X.Presheaf.obj (op U)) :
    X.Presheaf.obj (op <| X.basicOpen f) ⟶
      (Scheme.spec.obj <| op <| X.Presheaf.obj (op U)).Presheaf.obj
        (op <| Scheme.basicOpen _ <| specΓIdentity.inv.app (X.Presheaf.obj (op U)) f) :=
  hU.fromSpec.1.c.app (op <| X.basicOpen f) ≫
    (Scheme.spec.obj <| op <| X.Presheaf.obj (op U)).Presheaf.map
      (eqToHom <| (hU.opens_map_fromSpec_basicOpen f).symm).op
#align algebraic_geometry.basic_open_sections_to_affine AlgebraicGeometry.basicOpenSectionsToAffine

instance {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U) (f : X.Presheaf.obj (op U)) :
    IsIso (basicOpenSectionsToAffine hU f) :=
  by
  delta basic_open_sections_to_affine
  apply (config := { instances := false }) is_iso.comp_is_iso
  · apply PresheafedSpace.is_open_immersion.is_iso_of_subset
    rw [hU.from_Spec_range]
    exact RingedSpace.basic_open_le _ _
  infer_instance

theorem is_localization_basicOpen {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U)
    (f : X.Presheaf.obj (op U)) : IsLocalization.Away f (X.Presheaf.obj (op <| X.basicOpen f)) :=
  by
  apply
    (IsLocalization.isLocalization_iff_of_ringEquiv (Submonoid.powers f)
        (as_iso <|
            basic_open_sections_to_affine hU f ≫
              (Scheme.Spec.obj _).Presheaf.map
                (eq_to_hom (basic_open_eq_of_affine _).symm).op).commRingIsoToRingEquiv).mpr
  convert structure_sheaf.is_localization.to_basic_open _ f
  change _ ≫ basic_open_sections_to_affine hU f ≫ _ = _
  delta basic_open_sections_to_affine
  erw [RingHom.algebraMap_toAlgebra]
  simp only [Scheme.comp_val_c_app, category.assoc]
  erw [hU.from_Spec.val.c.naturality_assoc]
  rw [hU.from_Spec_app_eq]
  dsimp
  simp only [category.assoc, ← functor.map_comp, ← op_comp]
  apply structure_sheaf.to_open_res
#align algebraic_geometry.is_localization_basic_open AlgebraicGeometry.is_localization_basicOpen

instance {X : Scheme} [IsAffine X] (r : X.Presheaf.obj (op ⊤)) :
    IsLocalization.Away r (X.Presheaf.obj (op <| X.basicOpen r)) :=
  is_localization_basicOpen (top_isAffineOpen X) r

theorem is_localization_of_eq_basicOpen {X : Scheme} {U V : Opens X.carrier} (i : V ⟶ U)
    (hU : IsAffineOpen U) (r : X.Presheaf.obj (op U)) (e : V = X.basicOpen r) :
    @IsLocalization.Away _ r (X.Presheaf.obj (op V)) _ (X.Presheaf.map i.op).toAlgebra :=
  by
  subst e
  convert is_localization_basic_open hU r using 3
#align algebraic_geometry.is_localization_of_eq_basic_open AlgebraicGeometry.is_localization_of_eq_basicOpen

instance ΓRestrictAlgebra {X : Scheme} {Y : TopCat} {f : Y ⟶ X.carrier} (hf : OpenEmbedding f) :
    Algebra (Scheme.Γ.obj (op X)) (Scheme.Γ.obj (op <| X.restrict hf)) :=
  (Scheme.Γ.map (X.of_restrict hf).op).toAlgebra
#align algebraic_geometry.Γ_restrict_algebra AlgebraicGeometry.ΓRestrictAlgebra

instance Γ_restrict_is_localization (X : Scheme.{u}) [IsAffine X] (r : Scheme.Γ.obj (op X)) :
    IsLocalization.Away r (Scheme.Γ.obj (op <| X.restrict (X.basicOpen r).OpenEmbedding)) :=
  is_localization_of_eq_basicOpen _ (top_isAffineOpen X) r (Opens.openEmbedding_obj_top _)
#align algebraic_geometry.Γ_restrict_is_localization AlgebraicGeometry.Γ_restrict_is_localization

theorem basicOpen_basicOpen_is_basicOpen {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U)
    (f : X.Presheaf.obj (op U)) (g : X.Presheaf.obj (op <| X.basicOpen f)) :
    ∃ f' : X.Presheaf.obj (op U), X.basicOpen f' = X.basicOpen g :=
  by
  haveI := is_localization_basic_open hU f
  obtain ⟨x, ⟨_, n, rfl⟩, rfl⟩ := IsLocalization.surj' (Submonoid.powers f) g
  use f * x
  rw [Algebra.smul_def, Scheme.basic_open_mul, Scheme.basic_open_mul]
  erw [Scheme.basic_open_res]
  refine' (inf_eq_left.mpr _).symm
  convert inf_le_left using 1
  apply Scheme.basic_open_of_is_unit
  apply
    Submonoid.leftInv_le_isUnit _
      (IsLocalization.toInvSubmonoid (Submonoid.powers f) (X.presheaf.obj (op <| X.basic_open f))
          _).Prop
#align algebraic_geometry.basic_open_basic_open_is_basic_open AlgebraicGeometry.basicOpen_basicOpen_is_basicOpen

theorem exists_basicOpen_le_affine_inter {X : Scheme} {U V : Opens X.carrier} (hU : IsAffineOpen U)
    (hV : IsAffineOpen V) (x : X.carrier) (hx : x ∈ U ⊓ V) :
    ∃ (f : X.Presheaf.obj <| op U)(g : X.Presheaf.obj <| op V),
      X.basicOpen f = X.basicOpen g ∧ x ∈ X.basicOpen f :=
  by
  obtain ⟨f, hf₁, hf₂⟩ := hU.exists_basic_open_le ⟨x, hx.2⟩ hx.1
  obtain ⟨g, hg₁, hg₂⟩ := hV.exists_basic_open_le ⟨x, hf₂⟩ hx.2
  obtain ⟨f', hf'⟩ :=
    basic_open_basic_open_is_basic_open hU f (X.presheaf.map (hom_of_le hf₁ : _ ⟶ V).op g)
  replace hf' := (hf'.trans (RingedSpace.basic_open_res _ _ _)).trans (inf_eq_right.mpr hg₁)
  exact ⟨f', g, hf', hf'.symm ▸ hg₂⟩
#align algebraic_geometry.exists_basic_open_le_affine_inter AlgebraicGeometry.exists_basicOpen_le_affine_inter

/-- The prime ideal of `𝒪ₓ(U)` corresponding to a point `x : U`. -/
noncomputable def IsAffineOpen.primeIdealOf {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U)
    (x : U) : PrimeSpectrum (X.Presheaf.obj <| op U) :=
  (Scheme.spec.map
          (X.Presheaf.map
              (eqToHom <|
                  show U.OpenEmbedding.IsOpenMap.Functor.obj ⊤ = U from
                    Opens.ext (Set.image_univ.trans Subtype.range_coe)).op).op).1.base
    ((@Scheme.isoSpec (X.restrict U.OpenEmbedding) hU).Hom.1.base x)
#align algebraic_geometry.is_affine_open.prime_ideal_of AlgebraicGeometry.IsAffineOpen.primeIdealOf

theorem IsAffineOpen.fromSpec_primeIdealOf {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U)
    (x : U) : hU.fromSpec.val.base (hU.primeIdealOf x) = x.1 :=
  by
  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, CategoryTheory.Functor.map_id, category.id_comp, iso.hom_inv_id_assoc]
#align algebraic_geometry.is_affine_open.from_Spec_prime_ideal_of AlgebraicGeometry.IsAffineOpen.fromSpec_primeIdealOf

theorem IsAffineOpen.is_localization_stalk_aux {X : Scheme} (U : Opens X.carrier)
    [IsAffine (X.restrict U.OpenEmbedding)] :
    (inv (ΓSpec.adjunction.Unit.app (X.restrict U.OpenEmbedding))).1.c.app
        (op ((Opens.map U.inclusion).obj U)) =
      X.Presheaf.map
          (eqToHom <| by rw [opens.inclusion_map_eq_top] :
              U.OpenEmbedding.IsOpenMap.Functor.obj ⊤ ⟶
                U.OpenEmbedding.IsOpenMap.Functor.obj ((Opens.map U.inclusion).obj U)).op ≫
        toSpecΓ (X.Presheaf.obj <| op (U.OpenEmbedding.IsOpenMap.Functor.obj ⊤)) ≫
          (Scheme.spec.obj <| op <| X.Presheaf.obj <| _).Presheaf.map
            (eqToHom
                  (by
                    rw [opens.inclusion_map_eq_top]
                    rfl) :
                unop _ ⟶ ⊤).op :=
  by
  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]
    rfl
  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, CategoryTheory.Functor.map_id, category.id_comp]
  erw [Spec_Γ_identity.inv_hom_id_app_assoc]
  simp only [eq_to_hom_map, eq_to_hom_trans]
#align algebraic_geometry.is_affine_open.is_localization_stalk_aux AlgebraicGeometry.IsAffineOpen.is_localization_stalk_aux

theorem IsAffineOpen.is_localization_stalk {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U)
    (x : U) : IsLocalization.AtPrime (X.Presheaf.stalk x) (hU.primeIdealOf x).asIdeal :=
  by
  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 IsLocalization y.as_ideal.prime_compl _
  clear_value y
  subst this
  apply
    (IsLocalization.isLocalization_iff_of_ringEquiv _
        (as_iso <| PresheafedSpace.stalk_map hU.from_Spec.1 y).commRingIsoToRingEquiv).mpr
  convert structure_sheaf.is_localization.to_stalk _ _ using 1
  delta structure_sheaf.stalk_algebra
  congr 1
  rw [RingHom.algebraMap_toAlgebra]
  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]
  trans _ ≫ (structure_sheaf (X.presheaf.obj <| op U)).Presheaf.germ ⟨_, _⟩
  · rfl
  convert(structure_sheaf (X.presheaf.obj <| op U)).Presheaf.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]
  trans
    LocallyRingedSpace.Γ.map (Quiver.Hom.op <| Scheme.Spec.map (X.presheaf.map (𝟙 (op U))).op) ≫ _
  · congr
  simp only [CategoryTheory.Functor.map_id, op_id]
  erw [CategoryTheory.Functor.map_id]
  rw [category.id_comp]
  rfl
#align algebraic_geometry.is_affine_open.is_localization_stalk AlgebraicGeometry.IsAffineOpen.is_localization_stalk

/-- The basic open set of a section `f` on an an affine open as an `X.affine_opens`. -/
@[simps]
def Scheme.affineBasicOpen (X : Scheme) {U : X.affineOpens} (f : X.Presheaf.obj <| op U) :
    X.affineOpens :=
  ⟨X.basicOpen f, U.Prop.basicOpen_is_affine f⟩
#align algebraic_geometry.Scheme.affine_basic_open AlgebraicGeometry.Scheme.affineBasicOpen

@[simp]
theorem IsAffineOpen.basicOpen_fromSpec_app {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U)
    (f : X.Presheaf.obj (op U)) :
    @Scheme.basicOpen (Scheme.spec.obj <| op (X.Presheaf.obj <| op U))
        ((Opens.map hU.fromSpec.1.base).obj U) (hU.fromSpec.1.c.app (op U) f) =
      PrimeSpectrum.basicOpen f :=
  by
  rw [← Scheme.basic_open_res_eq _ _ (eq_to_hom hU.from_Spec_base_preimage.symm).op,
    basic_open_eq_of_affine', is_affine_open.from_Spec_app_eq]
  congr
  rw [← comp_apply, ← comp_apply, category.assoc, ← functor.map_comp_assoc, eq_to_hom_op,
    eq_to_hom_op, eq_to_hom_trans, eq_to_hom_refl, CategoryTheory.Functor.map_id, category.id_comp,
    ← iso.app_inv, iso.inv_hom_id]
  rfl
#align algebraic_geometry.is_affine_open.basic_open_from_Spec_app AlgebraicGeometry.IsAffineOpen.basicOpen_fromSpec_app

theorem IsAffineOpen.fromSpec_map_basicOpen {X : Scheme} {U : Opens X.carrier} (hU : IsAffineOpen U)
    (f : X.Presheaf.obj (op U)) :
    (Opens.map hU.fromSpec.val.base).obj (X.basicOpen f) = PrimeSpectrum.basicOpen f := by simp
#align algebraic_geometry.is_affine_open.from_Spec_map_basic_open AlgebraicGeometry.IsAffineOpen.fromSpec_map_basicOpen

theorem IsAffineOpen.basicOpen_union_eq_self_iff {X : Scheme} {U : Opens X.carrier}
    (hU : IsAffineOpen U) (s : Set (X.Presheaf.obj <| op U)) :
    (⨆ f : s, X.basicOpen (f : X.Presheaf.obj <| op U)) = U ↔ Ideal.span s = ⊤ :=
  by
  trans (⋃ i : s, (PrimeSpectrum.basicOpen i.1).1) = Set.univ
  trans
    hU.from_Spec.1.base ⁻¹' (⨆ f : s, X.basic_open (f : X.presheaf.obj <| op U)).1 =
      hU.from_Spec.1.base ⁻¹' U.1
  · refine' ⟨fun h => by rw [h], _⟩
    intro h
    apply_fun Set.image hU.from_Spec.1.base  at h
    rw [Set.image_preimage_eq_inter_range, Set.image_preimage_eq_inter_range, hU.from_Spec_range] at
      h
    simp only [Set.inter_self, opens.carrier_eq_coe, Set.inter_eq_right_iff_subset] at h
    ext1
    refine' Set.Subset.antisymm _ h
    simp only [Set.unionᵢ_subset_iff, SetCoe.forall, opens.coe_supr]
    intro x hx
    exact X.basic_open_le x
  · simp only [opens.supr_def, Subtype.coe_mk, Set.preimage_unionᵢ, Subtype.val_eq_coe]
    congr 3
    · ext1 x
      exact congr_arg opens.carrier (hU.from_Spec_map_basic_open _)
    · exact congr_arg opens.carrier hU.from_Spec_base_preimage
  · simp only [opens.carrier_eq_coe, PrimeSpectrum.basicOpen_eq_zeroLocus_compl]
    rw [← Set.compl_interᵢ, Set.compl_univ_iff, ← PrimeSpectrum.zeroLocus_unionᵢ, ←
      PrimeSpectrum.zeroLocus_empty_iff_eq_top, PrimeSpectrum.zeroLocus_span]
    simp only [Set.unionᵢ_singleton_eq_range, Subtype.range_val_subtype, Set.setOf_mem_eq]
#align algebraic_geometry.is_affine_open.basic_open_union_eq_self_iff AlgebraicGeometry.IsAffineOpen.basicOpen_union_eq_self_iff

theorem IsAffineOpen.self_le_basicOpen_union_iff {X : Scheme} {U : Opens X.carrier}
    (hU : IsAffineOpen U) (s : Set (X.Presheaf.obj <| op U)) :
    (U ≤ ⨆ f : s, X.basicOpen (f : X.Presheaf.obj <| op U)) ↔ Ideal.span s = ⊤ :=
  by
  rw [← hU.basic_open_union_eq_self_iff, @comm _ Eq]
  refine' ⟨fun h => le_antisymm h _, le_of_eq⟩
  simp only [supᵢ_le_iff, SetCoe.forall]
  intro x hx
  exact X.basic_open_le x
#align algebraic_geometry.is_affine_open.self_le_basic_open_union_iff AlgebraicGeometry.IsAffineOpen.self_le_basicOpen_union_iff

/-- Let `P` be a predicate on the affine open sets of `X` satisfying
1. If `P` holds on `U`, then `P` holds on the basic open set of every section on `U`.
2. If `P` holds for a family of basic open sets covering `U`, then `P` holds for `U`.
3. There exists an affine open cover of `X` each satisfying `P`.

Then `P` holds for every affine open of `X`.

This is also known as the **Affine communication lemma** in [*The rising sea*][RisingSea]. -/
@[elab_as_elim]
theorem of_affine_open_cover {X : Scheme} (V : X.affineOpens) (S : Set X.affineOpens)
    {P : X.affineOpens → Prop}
    (hP₁ : ∀ (U : X.affineOpens) (f : X.Presheaf.obj <| op U.1), P U → P (X.affineBasicOpen f))
    (hP₂ :
      ∀ (U : X.affineOpens) (s : Finset (X.Presheaf.obj <| op U))
        (hs : Ideal.span (s : Set (X.Presheaf.obj <| op U)) = ⊤),
        (∀ f : s, P (X.affineBasicOpen f.1)) → P U)
    (hS : (⋃ i : S, i : Set X.carrier) = Set.univ) (hS' : ∀ U : S, P U) : P V := by
  classical
    have :
      ∀ x : V, ∃ f : X.presheaf.obj <| op V.1, ↑x ∈ X.basic_open f ∧ P (X.affine_basic_open f) :=
      by
      intro x
      have : ↑x ∈ (Set.univ : Set X.carrier) := trivial
      rw [← hS] at this
      obtain ⟨W, hW⟩ := set.mem_Union.mp this
      obtain ⟨f, g, e, hf⟩ := exists_basic_open_le_affine_inter V.prop W.1.Prop x ⟨x.prop, hW⟩
      refine' ⟨f, hf, _⟩
      convert hP₁ _ g (hS' W) using 1
      ext1
      exact e
    choose f hf₁ hf₂ using this
    suffices Ideal.span (Set.range f) = ⊤
      by
      obtain ⟨t, ht₁, ht₂⟩ := (Ideal.span_eq_top_iff_finite _).mp this
      apply hP₂ V t ht₂
      rintro ⟨i, hi⟩
      obtain ⟨x, rfl⟩ := ht₁ hi
      exact hf₂ x
    rw [← V.prop.self_le_basic_open_union_iff]
    intro x hx
    rw [supᵢ_range', opens.mem_supr]
    exact ⟨_, hf₁ ⟨x, hx⟩⟩
#align algebraic_geometry.of_affine_open_cover AlgebraicGeometry.of_affine_open_cover

end AlgebraicGeometry


/- The definition of environments, contexts and names within the continuous-π
   calculus.

   Names are represented as de Bruijn indicies for obvious reasons. We use the
   same representation of names as [1], indexing them by the context that they
   exist in. This ensures that names are always well formed, thus avoiding many
   common pitfalls that occur when renaming and shuffling terms.

   We have two kinds of names which, while sharing a context type, do have
   rather different meanings:

    - References to species definitions: The context here acts as a global
      environment `ω', holding the definitions of species. Species invocations
      `D(a̅)' index into this table.

      Each reference within this environment is given an arity, holding the
      arity of its corresponding definition.

      Unlike other contexts, the environment should remain constant across a
      whole series of processes.

   - Names exist on the main π-calculus level, either introduced by the global
     affinity network or locall bound by restrictions.

     Each name also has an arity, representing the arity of the corresponding
     affinity network. Names then index into that affinity network, using finite
     number bounded by the arity.

  [1]: Proof-relevant π-calculus: a constructive account of concurrency and
       causality, Roly Perera, James Cheney
-/
import data.fin data.vector data.vector2

namespace cpi

/-- A context under which terms may be evaluated and names resolved.

    Each level of the context holds the arity of the name defined at that point.
-/
@[derive decidable_eq, nolint has_inhabited_instance]
inductive context : Type
| nil : context
| extend : ℕ → context → context

/-- A reference to a species definition within the global definition context. -/
@[derive decidable_eq, nolint has_inhabited_instance]
inductive reference : ℕ → context → Type
| zero   {ω : context} (n : ℕ) : reference n (context.extend n ω)
| extend {ω : context} {n m : ℕ} : reference n ω → reference n (context.extend m ω)

/-- The set of names within the continuous π-calculus. -/
@[derive decidable_eq, nolint has_inhabited_instance]
inductive name : context → Type
| zero   {Γ} {n : ℕ} : fin n → name (context.extend n Γ)
| extend {Γ} {n : ℕ} : name Γ → name (context.extend n Γ)

/-- The "depth" of a variable.

    This is effectively a name, but without the index into the affinity network.
    It is used to determine if the affinity network appears at all within a
    term.

    Technically this property could be defined as "does any name of this level
    appear" - it may be worth seeing if that simplifies things in the future. -/
@[derive decidable_eq, nolint has_inhabited_instance]
inductive level : context → Type
| zero   {Γ} {n} : level (context.extend n Γ)
| extend {Γ} {n} : level Γ → level (context.extend n Γ)

/-- Get the variable level/depth. This doesn't have much use aside for pretty-printing. -/
protected def reference.level : ∀ {Γ n}, reference Γ n → ℕ
| Γ n (reference.zero _) := 0
| Γ n (reference.extend r) := 1 + reference.level r

instance {Γ n} : has_repr (reference Γ n) := ⟨ λ x, repr (reference.level x) ⟩

namespace name
  /-- Get the variable index. This doesn't have much use aside for pretty-printing. -/
  protected def idx : ∀ {Γ}, name Γ → ℕ
  | ._ (name.zero a) := a
  | ._ (name.extend a) := idx a

  /-- Get the variable level/depth. This doesn't have much use aside for pretty-printing. -/
  protected def level : ∀ {Γ}, name Γ → ℕ
  | ._ (name.zero a) := 0
  | ._ (name.extend a) := 1 + level a

  instance {Γ} : has_repr (name Γ) := ⟨ λ x, repr (name.level x) ++ "." ++ repr (name.idx x) ⟩

  /-- Get the level of this name. -/
  def to_level : ∀ {Γ}, name Γ → level Γ
  | ._ (zero _) := level.zero
  | ._ (extend a) := level.extend (to_level a)

  section free
    /-- Determine if this variable is on a specific level or depth.

        This can be thought of as a determining if a given level is free within
        this variable. -/
    def at_level : ∀ {Γ}, level Γ → name Γ → Prop
    | ._ level.zero (zero _) := true
    | ._ (level.extend l) (extend a) := at_level l a

    | ._ level.zero (extend _) := false
    | ._ (level.extend _) (zero _) := false

    instance {Γ} : has_mem (level Γ) (name Γ) := ⟨ at_level ⟩

    private def at_level_decide :
      ∀ {Γ} (l : level Γ) (a : name Γ), decidable (at_level l a)
    | ._ level.zero (zero _) := decidable.true
    | ._ (level.extend l) (extend a) := at_level_decide l a
    | ._ level.zero (extend _) := decidable.false
    | ._ (level.extend _) (zero _) := decidable.false

    instance at_level.decidable {Γ} {l} {a : name Γ} : decidable (at_level l a)
      := at_level_decide l a

    /-- Any variable is always at the level provided by to_level. -/
    theorem to_level_at : ∀ {Γ} (a : name Γ), name.to_level a ∈ a
    | ._ (zero _) := by unfold to_level
    | ._ (extend n) := to_level_at n
  end free

  /- Renaming applies a function to all variables in the current context,
     mapping them to a new set of variables in a different (or the same)
     context.

     Our renaming code is pretty typical, though with some additional
     complexities. The actual renaming function receives evidence that the
     provided variable is used (typically, that it is free within the term
     begin renamed).

     While this may seem like an obvious fact, it is crucial to allow lowering
     the level of names - if we know `name.zero ∉ A', then we can safely reduce
     all variables by one, as we can show by contradiction that our renaming
     function doesn't receive `name.zero'.

     Any functions suffixed with `_with' use this more complex definition of
     renaming - we also provide simpler ones which provide a simple
     `name Γ → name Δ' interface (and a few additional guarantees). -/
  section rename
    /-- Wrap a renaming function, making it suitable for a nested context. -/
    def ext_with {Γ Δ} {n}
        (P : level (context.extend n Γ) → Prop)
        (ρ : Π (x : name Γ), P (level.extend (name.to_level x)) → name Δ)
      : Π (x : name (context.extend n Γ)), P (name.to_level x) → name (context.extend n Δ)
    | (zero idx) p := zero idx
    | (extend a) p := extend (ρ a p)

    /-- Extending with `id' does nothing. -/
    lemma ext_with_identity :
      ∀ {Γ} {n : ℕ}
        (P : level (context.extend n Γ) → Prop)
        (a : name (context.extend n Γ)) (p : P (name.to_level a))
      , ext_with P (λ x _, x) a p = a
    | Γ n P (zero lt) _ := rfl
    | Γ n P (extend a) _ := rfl

    /-- Extending with `id' is equivalent to the identity function. -/
    lemma ext_with_id {Γ} {n : ℕ} (P : level (context.extend n Γ) → Prop)
      : ext_with P (λ x _, x) = λ x _, x
      := funext $ λ a, funext (ext_with_identity P a)

    /-- Wrap a simple renaming function, making it suitable for a nested
        context. -/
    @[reducible]
    def ext {Γ Δ} {n} (ρ : name Γ → name Δ)
      : name (context.extend n Γ) → name (context.extend n Δ)
    | a := ext_with (λ _, true) (λ x p, ρ x) a true.intro

    /-- Extending with the identity does nothing. -/
    lemma ext_identity {Γ} {n : ℕ} (a : name (context.extend n Γ))
      : ext id a = a
      := ext_with_identity _ a _

    /-- Extending with `id' is equivalent to the identity function. -/
    lemma ext_id : ∀ {Γ} {n : ℕ}, @ext Γ Γ n id = id
    | Γ n := funext ext_identity

    /-- Composing extensions is equivalent extending a composition. -/
    lemma ext_with_compose :
      ∀ {Γ Δ η} {n : ℕ}
        (P : level (context.extend n Γ) → Prop)
        (ρ : Π (x : name Γ), P (level.extend (name.to_level x)) → name Δ)
        (σ : name Δ → name η)
        (a : name (context.extend n Γ)) (p : P (name.to_level a))
      , ext σ (ext_with P ρ a p) = ext_with P (λ a p, σ (ρ a p)) a p
    | Γ Δ η n P ρ σ (zero lt) _ := rfl
    | Γ Δ η n P ρ σ (extend a) _ := rfl

    /-- Composing extensions is equivalent extending a composition. -/
    lemma ext_with_comp {Γ Δ η} {n : ℕ}
        (P : level (context.extend n Γ) → Prop)
        (ρ : Π (x : name Γ), P (level.extend (name.to_level x)) → name Δ)
        (σ : name Δ → name η)
      : (λ a p, ext σ (ext_with P ρ a p)) = ext_with P (λ a p, σ (ρ a p))
      := funext $ λ a, funext (ext_with_compose P ρ σ a)

    /-- Composing simple extensions is equivalent extending a composition. -/
    lemma ext_compose {Γ Δ η} (ρ : name Γ → name Δ) (σ : name Δ → name η) {n : ℕ}
        (a : name (context.extend n Γ))
      : ext σ (ext ρ a) = ext (σ ∘ ρ) a
      := ext_with_compose (λ _, true) (λ x _, ρ x) σ a true.intro

    /-- Composing simple extensions is equivalent extending a composition. -/
    lemma ext_comp {Γ Δ η} (ρ : name Γ → name Δ) (σ : name Δ → name η) {n : ℕ}
      : (ext σ ∘ ext ρ) = @ext _ _ n (σ ∘ ρ)
      := funext (ext_compose ρ σ)

    /-- Extending then renaming with an extended function, is equivalent to
        renaming then extending. -/
    lemma ext_extend {Γ Δ} {n : ℕ} (ρ : name Γ → name Δ)
      : (ext ρ ∘ extend) = (@extend Δ n ∘ ρ) := funext (λ x, rfl)

    lemma ext_zero {Γ Δ} {n : ℕ} (ρ : name Γ → name Δ)
      : (ext ρ ∘ zero) = (@zero Δ n) := funext (λ x, rfl)

    /-- Rewrite one ext_with to another.

        This is largely useful when proving renaming properties in more complex
        types. -/
    lemma ext_with_discard {Γ Δ} {n}
        (P : level (context.extend n Γ) → Prop)
        (ρ : name Γ → name Δ)
      : (ext_with P (λ a _, ρ a))
      = (λ a _, name.ext_with (λ _x, true) (λ x _, ρ x) a true.intro)
      := funext $ λ a, funext $ λ free, by { cases a; from rfl }

    lemma ext.inj {Γ Δ n} {ρ : name Γ → name Δ} (inj : function.injective ρ)
      : function.injective (@ext Γ Δ n ρ)
    | (name.zero i) (name.zero j) eq := by { cases eq, from rfl }
    | (name.zero i) (name.extend b) eq := by contradiction
    | (name.extend i) (name.zero j) eq := by contradiction
    | (name.extend a) (name.extend b) eq := congr_arg extend (inj (extend.inj eq))
  end rename

  section swap
    /-- Swap the two topmost variables. Used for exchange of ν(_) terms. -/
    def swap {Γ} {M N : ℕ}
      : name (context.extend M (context.extend N Γ))
      → name (context.extend N (context.extend M Γ))
    | (zero lt) := extend (zero lt)
    | (extend (zero lt)) := zero lt
    | (extend (extend n)) := extend (extend n)

    /-- A twice-extended renaming function can be applied before or after a
        swap. -/
    lemma swap_ext_ext {Γ Δ} {ρ : name Γ → name Δ} {m n : ℕ}
      : (ext (ext ρ) ∘ swap)
      = (swap ∘ @ext _ _ n (@ext _ _ m ρ))
      := funext $ λ α,
        match α with
        | zero p := rfl
        | extend (zero lt) := rfl
        | extend (extend _) := rfl
        end

    /-- Incrementing names and swapping, is just the same as incrementing
        everything above 0. -/
    lemma swap_comp_extend {Γ} {m n : ℕ}
      : (@name.swap Γ m n ∘ name.extend) = (name.ext name.extend)
      := funext $ λ a, by { cases a; from rfl }

    /-- Incrementing all names above 0 and swapping is the same as just
        incrementing everything. -/
    lemma swap_comp_ext_extend {Γ} {m n : ℕ}
      : (@name.swap Γ m n ∘ name.ext name.extend) = name.extend
      := funext $ λ a, by { cases a; from rfl }

    /-- Swapping twice does nothing. -/
    lemma swap_swap_identity :
      ∀ {Γ} {a b : ℕ} (a : name (context.extend b (context.extend a Γ)))
      , name.swap (name.swap a) = a
      | Γ a b (name.zero _) := rfl
      | Γ a b (name.extend (name.zero _)) := rfl
      | Γ a b (name.extend (name.extend _)) := rfl

    /-- Swapping twice gives the identity. -/
    lemma swap_swap :
      ∀ {Γ} {a b : ℕ}
      , (@name.swap Γ a b) ∘ name.swap = id
      | Γ a b := funext swap_swap_identity
  end swap

  section application
    /-- Given a list of names bs, construct a renaming function which renames
        level-0 names to the corresponding names in bs.  -/
    def mk_apply {Γ} {b} (bs : vector (name Γ) b)
      : name (context.extend b Γ) → name Γ
    | (zero idx) := vector.nth bs idx
    | (extend e) := e

    lemma mk_apply_rename
        {Γ Δ} {b} (ρ : name Γ → name Δ) {bs : vector (name Γ) b}
      : ρ ∘ mk_apply bs = mk_apply (vector.map ρ bs) ∘ name.ext ρ
      := funext $ λ a,
        by { cases a; simp only [mk_apply, ext, ext_with, vector.nth_map, function.comp] }

    lemma mk_apply_ext {Γ} {b} {bs : vector (name Γ) b}
      : mk_apply bs ∘ (@extend Γ b) = id
      := funext $λ α, by { cases α; unfold mk_apply id function.comp }
  end application

  section drop
    /-- Reduce the level of a variable by one, given a proof it's unused.  -/
    def drop_var {Γ} {n}
        (P : level (context.extend n Γ) → Prop) (p : (¬ P level.zero))
      : Π a, P (name.to_level a) → name Γ
    | (name.zero idx) q := by { unfold name.to_level at q, contradiction }
    | (name.extend a) _ := a

    /-- Show a renaming function which drops then extends is the identity. -/
    lemma drop_var_compose {Γ} {n}
      (P : level (context.extend n Γ) → Prop) (p : (¬ P level.zero))
      : (λ a f, name.extend (drop_var P p a f)) = λ a _, a
      := funext $ λ a, funext $ λ q, begin
        cases a,
        case name.zero { unfold name.to_level at q, contradiction },
        case name.extend { from rfl }
      end
  end drop

  /-- Get the index of a name in the singleton context . -/
  def to_idx {n : ℕ} : name (context.extend n context.nil) → fin n
  | (name.zero i) := i
  | (name.extend a) := by cases a
end name

end cpi

#lint-