import ground_zero.types.unit ground_zero.types.coproduct
open ground_zero.types.unit

hott theory

namespace ground_zero

namespace structures
universes u v

def prop (α : Sort u) :=
Π (a b : α), a = b :> α

def hset (α : Sort u) :=
Π {a b : α} (p q : a = b :> α), p = q :> a = b :> α

structure contr (α : Sort u) :=
(point : α) (intro : Π (a : α), point = a :> α)
--  or we can write `idfun ~ λ _, point`

def LEM := Π (α : Type u), prop α → (α + ¬α)
def law_of_double_negation :=
Π (α : Type u), prop α → (¬¬α → α)

def LEM_inf := Π (α : Type u), α + ¬α
notation `LEM∞` := LEM_inf

inductive homotopy_level
| minus_two
| succ : homotopy_level → homotopy_level

notation `−2` := homotopy_level.minus_two
notation `−1` := homotopy_level.succ −2

instance : has_zero homotopy_level := ⟨homotopy_level.succ −1⟩

def level_to_n : homotopy_level → ℕ
| homotopy_level.minus_two := 0
| (homotopy_level.succ n) := level_to_n n + 1

def n_to_level : ℕ → homotopy_level
| 0 := homotopy_level.minus_two
| (n + 1) := homotopy_level.succ (n_to_level n)

def is_n_type : Sort u → homotopy_level → Sort (max 1 u)
| α homotopy_level.minus_two := contr α
| α (homotopy_level.succ n) := Π (x y : α),
  is_n_type (x = y :> α) n

def n_type (n : homotopy_level) :=
Σ' (α : Sort u), is_n_type α n
notation n `-Type` := n_type n

def contr_impl_prop {α : Sort u} (h : contr α) : prop α :=
λ a b, (h.intro a)⁻¹ ⬝ (h.intro b)

def empty_is_prop : prop empty :=
begin intros x, induction x end

def unit_is_prop : prop types.unit :=
begin intros x y, induction x, induction y, trivial end

def prop_impl_prop {α : Prop} : prop α :=
begin intros x y, trivial end

section
  open types.equiv types.eq
  def prop_is_set {α : Sort u} (r : prop α) : hset α := begin
    intros x y p q, have g := r x,
    transitivity, symmetry, apply rewrite_comp,
    exact (apd g p)⁻¹ ⬝ transport_composition p (g x),
    induction q, apply inv_comp
  end

  -- unsafe postulate, but it computes
  def function_extensionality {α : Sort u} {β : α → Sort v}
    {f g : Π x, β x} (h : f ~ g) : f = g :> Π x, β x :=
  support.inclusion $ funext (λ x, support.truncation (h x))

  def contr_is_prop {α : Sort u} : prop (contr α) := begin
    intros x y, cases x with x u, cases y with y v,
    have p := u y, induction p, apply types.eq.map,
    apply function_extensionality, intro a,
    apply prop_is_set (contr_impl_prop ⟨x, u⟩)
  end

  def prop_is_prop {α : Sort u} : prop (prop α) := begin
    intros f g,
    have p := λ a b, (prop_is_set f) (f a b) (g a b),
    apply function_extensionality, intro a,
    apply function_extensionality, intro b,
    exact p a b
  end
end

inductive squash (α : Sort u) : Prop
| elem : α → squash
def squash.uniq {α : Sort u} (a b : squash α) : a = b :> squash α :=
types.eq.rfl

def K (α : Sort u) :=
Π (a : α) (p : a = a :> α), p = types.eq.refl a :> a = a :> α

theorem K_iff_set (α : Sort u) : K α ↔ hset α := begin
  split,
  { intro h, intros x y p q,
    induction q, apply h },
  { intro h, unfold K,
    intros, apply h }
end

def lem_prop {α : Sort u} (h : α → prop α) : prop α :=
λ a, h a a

def lem_contr {α : Sort u} (h : α → contr α) : prop α :=
λ a, contr_impl_prop (h a) a

def is_contr_fiber {α : Sort u} {β : Sort v} (f : α → β) :=
Π (y : β), contr (types.fib f y)

end structures

-- http://www.cs.bham.ac.uk/~mhe/truncation-and-extensionality/tiny-library.html
-- http://www.cs.bham.ac.uk/~mhe/truncation-and-extensionality/hsetfunext.html
structure {u} singl {α : Sort u} (a : α) :=
(point : α) (intro : a = point :> α)

namespace singl
universe u

def trivial_loop {α : Sort u} (a : α) : singl a :=
⟨a, by reflexivity⟩

def path_from_trivial_loop {α : Sort u} {a b : α}
  (r : a = b :> α) : (trivial_loop a) = ⟨b, r⟩ :> singl a :=
begin induction r, trivial end

def singl.eq {α : Sort u} {a : α} (t : singl a) :
  { point := t.point, intro := t.intro } = t :> singl a :=
begin induction t, simp end

def signl_contr {α : Sort u} (a : α) : structures.contr (singl a) :=
{ point := trivial_loop a,
  intro := λ t, path_from_trivial_loop t.intro ⬝ singl.eq t }

def singl_prop {α : Sort u} (a : α) : structures.prop (singl a) :=
structures.contr_impl_prop (signl_contr a)

end singl

end ground_zero


-- Some simple programming language modeling, using lean4
-- commit 4296e1d83e734b18b4787329e4195569c0518325
-- from Fri Mar 20 18:32:04 2020 -0700
import Init.Data.String

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Data definitions
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

def Var := String

-- Arithmetic unary operations
inductive Ty : Type
| int : Ty
| bool : Ty
--|sum : Ty → Ty → Ty

-- Arithmetic binary operations
inductive Const : Type
| int : Int → Const
| bool : Bool → Const
--|left : Const → Ty → Const
--|right : Ty → Const → Const

instance intToConst : HasCoe Int Const := ⟨Const.int⟩
instance boolToConst : HasCoe Bool Const := ⟨Const.bool⟩

inductive UOp : Type
| inc
| dec
| neg
| zero?
| not

inductive BOp : Type
| add
| sub
| mul

-- Arithmetic expressions
inductive Exp : Type
| var    : Var → Exp
| const  : Const → Exp
| uop    : UOp → Exp → Exp
| bop    : BOp → Exp → Exp → Exp
| cond   : Exp → Exp → Exp → Exp
| letvar : Var → Exp → Exp → Exp
--|left  : Exp → Ty → Exp
--|right : Ty → Exp → Exp
--|elim  : Exp → Ty → Ty → Var

namespace Exp
open UOp BOp Const

private def ci := λ n => const $ int n
private def cb := λ b => const $ bool b

def ex1 : Exp := (ci 42)
def ex2 : Exp := (cb true)
def ex3 : Exp := (uop inc (ci 41))
def ex4 : Exp := (uop dec (const (int 43)))
def ex5 : Exp := (uop neg (bop sub (ci 0) (ci 42)))
def ex6 : Exp := (uop zero? (ci 0))
def ex7 : Exp := (bop add (ci 41) (ci 1))
def ex8 : Exp := (bop sub (ci 43) (ci 1))
def ex9 : Exp := (bop mul (ci 21) (ci 2))
def ex10 : Exp := (uop not (uop zero? (ci 1)))
def ex11 : Exp := (cond (uop not (uop zero? (ci 42))) (ci 42) (ci 0))
def ex12 : Exp := (cond (uop not (uop zero? (ci 0))) (ci 0) (ci 42))
def ex13 : Exp := (letvar "x" (cb true)
                    (cond (var "x") (ci 42) (ci 0)))
def ex14 : Exp := (letvar "x" (uop inc (ci 41))
                    (cond (cb true) (var "x") (ci 0)))
def ex15 : Exp := (letvar "x" (uop inc (ci 39))
                    (letvar "x" (uop inc (var "x"))
                      (uop inc (var "x"))))

end Exp

def Env : Type := Var → Option Const

namespace Env

def empty : Env := λ _ => none
def extend (ρ : Env) (x : Var) (c:Const) : Env :=
  λ y => if x == y then some c else (ρ y)

end Env

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Interpreter
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

namespace UOp

def interp : UOp → Const → Option Const
| inc,   (Const.int n)  => some $ Const.int $ n + 1
| dec,   (Const.int n)  => some $ Const.int $ n - 1
| neg,   (Const.int n)  => some $ Const.int $ 0 - n
| zero?, (Const.int n)  => some $ Const.bool $ n == 0
| not,   (Const.bool b) => some $ Const.bool $ ¬ b
| _,_ => none

end UOp

namespace BOp

def interp : BOp → Const → Const → Option Const
| add, (Const.int x), (Const.int y)  => some $ Const.int $ x + y
| sub, (Const.int x), (Const.int y)  => some $ Const.int $ x - y
| mul, (Const.int x), (Const.int y)  => some $ Const.int $ x * y
| _,_,_ => none

end BOp

namespace Exp

def interp : Env → Exp → Option Const
| ρ, var x => ρ x
| ρ, const c => c
| ρ, uop op e => do
  v ← interp ρ e;
  UOp.interp op v
| ρ, bop op e₁ e₂ => do
  v₁ ← interp ρ e₁;
  v₂ ← interp ρ e₂;
  BOp.interp op v₁ v₂
| ρ, cond e₁ e₂ e₃ =>
  match interp ρ e₁ with
  | some (Const.bool true) => interp ρ e₂
  | some (Const.bool false) => interp ρ e₃
  | _ => none
| ρ, letvar x e₁ e₂ => do
  v₁ ← interp ρ e₁;
  let ρ' := Env.extend ρ x v₁;
  interp ρ' e₂

end Exp

def TyEnv : Type := Var → Option Ty

namespace TyEnv

def empty : TyEnv := λ _ => none
def extend (Γ : TyEnv) (x : Var) (t:Ty) : TyEnv :=
  λ y => if x == y then some t else (Γ y)

end TyEnv

namespace Const

def typeof : Const → Ty
| int _ => Ty.int
| bool _ => Ty.bool

end Const

namespace UOp

def typeof : UOp → (Ty × Ty)
| inc   => (Ty.int, Ty.int)
| dec   => (Ty.int, Ty.int)
| neg   => (Ty.int, Ty.int)
| zero? => (Ty.int, Ty.bool)
| not   => (Ty.bool, Ty.bool)
end UOp

namespace BOp

def typeof : BOp → (Ty × Ty × Ty)
| add   => (Ty.int, Ty.int, Ty.int)
| sub   => (Ty.int, Ty.int, Ty.int)
| mul   => (Ty.int, Ty.int, Ty.int)

end BOp

inductive TypeOf : TyEnv → Exp → Ty → Prop
| var (Γ:TyEnv) x t :
  (Γ x) = (some t)
  → TypeOf Γ (Exp.var x) t
| const Γ c t :
  Const.typeof c = t
  → TypeOf Γ (Exp.const c) t
| uop Γ op e t t' :
  TypeOf Γ e t
  → UOp.typeof op = (t, t')
  → TypeOf Γ (Exp.uop op e) t'
| bop Γ op e₁ e₂ t₁ t₂ t₃ :
  TypeOf Γ e₁ t₁
  → TypeOf Γ e₂ t₂
  → BOp.typeof op = (t₁, t₂, t₃)
  → TypeOf Γ (Exp.bop op e₁ e₂) t₃
| cond Γ e₁ e₂ e₃ t :
  TypeOf Γ e₁ Ty.bool
  → TypeOf Γ e₂ t
  → TypeOf Γ e₃ t
  → TypeOf Γ (Exp.cond e₁ e₂ e₃) t
| letvar Γ x e₁ e₂ t₁ t₂ :
  TypeOf Γ e₁ t₁
  → TypeOf (TyEnv.extend Γ x t₁) e₂ t₂
  → TypeOf Γ (Exp.letvar x e₁ e₂) t₂

-- In the given expression, substitute
-- the constant for the variable.
def subst : Exp → Const → Var → Exp
| Exp.var y, c, x =>
  if x == y then (Exp.const c) else Exp.var y
| Exp.const c, _, _ =>
  Exp.const c
| Exp.uop op e, c, x =>
  Exp.uop op (subst e c x)
| Exp.bop op e₁ e₂, c, x =>
  Exp.bop op (subst e₁ c x) (subst e₂ c x)
| Exp.cond e₁ e₂ e₃, c, x =>
  Exp.cond (subst e₁ c x) (subst e₂ c x) (subst e₃ c x)
| Exp.letvar y e₁ e₂, c, x =>
  let e₁' := (subst e₁ c x);
  if x == y then
    Exp.letvar y e₁' e₂
  else
    Exp.letvar y e₁' (subst e₂ c x)

-- A single reduction step.
inductive Step : Exp → Exp → Prop
| uop_red op c₁ c₂ :
  UOp.interp op c₁ = some c₂
  → Step (Exp.uop op (Exp.const c₁)) (Exp.const c₂)
| bop_red op c₁ c₂ c₃ :
  BOp.interp op c₁ c₂ = some c₃
  → Step (Exp.bop op (Exp.const c₁) (Exp.const c₂)) (Exp.const c₃)
| cond_congr e₁ e₁' e₂ e₃ :
  Step e₁ e₁'
  → Step (Exp.cond e₁ e₂ e₃) (Exp.cond e₁' e₂ e₃)
| cond_red e₁ e₂ :
  Step (Exp.cond (Exp.const true) e₁ e₂) e₁
| letvar_congr x e₁ e₁' e₂ :
  Step e₁ e₁'
  → Step (Exp.letvar x e₁ e₂) (Exp.letvar x e₁' e₂)
| letvar_red x c e :
  Step (Exp.letvar x (Exp.const c) e) (subst e c x)

-- | Zero or more steps of reduction.
inductive Steps : Exp → Exp → Prop
| nil e :
  Steps e e
| cons e₁ e₂ e₃ :
  Step e₁ e₂
  → Steps e₂ e₃
  → Steps e₁ e₃

def env_sat (Γ:TyEnv) (ρ:Env) : Prop := forall x t,
   (Γ x) = some t
   → Exists (λ c => (ρ x) = some c ∧ Const.typeof c = t)

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Theorems (N.B., seems like tactics have to
-- come after `new_frontend`... need to look
-- more into what it entails.)
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

new_frontend

macro try t:tactic : tactic => `($t <|> skip)

syntax "repeat" tactic : tactic
macro_rules
| `(tactic| repeat $t) => `(tactic| try ($t; repeat $t))

-- TODO there's got to be a way to just apply all
-- the known constructors for a type, right?
-- oooh, check out src/Init/Lean/Meta/Tactic
macro constr_TypeOf : tactic =>
`((apply TypeOf.var) <|>
  (apply TypeOf.const) <|>
  (apply TypeOf.uop) <|>
  (apply TypeOf.bop) <|>
  (apply TypeOf.cond) <|>
  (apply TypeOf.letvar))

macro typecheck : tactic =>
 `(repeat (constr_TypeOf <|> (exact rfl)))

open Exp

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Example evaluation tests
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

def test_eval : Exp → Option Const := interp Env.empty

private theorem test_ex1 :
 test_eval ex1 = some (Const.int 42) :=
Eq.refl (some (Const.int 42))

private theorem test_ex2 :
 test_eval ex2 = some (Const.bool true) :=
Eq.refl (some (Const.bool true))

private theorem test_ex3 :
 test_eval ex3 = some (Const.int 42) :=
Eq.refl (some (Const.int 42))

private theorem test_ex4 :
 test_eval ex4 = some (Const.int 42) :=
Eq.refl (some (Const.int 42))

private theorem test_ex5 :
 test_eval ex5 = some (Const.int 42) :=
Eq.refl (some (Const.int 42))

private theorem test_ex6 :
 test_eval ex6 = some (Const.bool true) :=
Eq.refl (some (Const.bool true))

private theorem test_ex7 :
 test_eval ex7 = some (Const.int 42) :=
Eq.refl (some (Const.int 42))

private theorem test_ex8 :
 test_eval ex8 = some (Const.int 42) :=
Eq.refl (some (Const.int 42))

private theorem test_ex8 :
 test_eval ex8 = some (Const.int 42) :=
Eq.refl (some (Const.int 42))

private theorem test_ex9 :
 test_eval ex9 = some (Const.int 42) :=
Eq.refl (some (Const.int 42))

private theorem test_ex10 :
 test_eval ex10 = some (Const.bool true) :=
Eq.refl (some (Const.bool true))

private theorem test_ex11 :
 test_eval ex11 = some (Const.int 42) :=
Eq.refl (some (Const.int 42))

private theorem test_ex12 :
 test_eval ex12 = some (Const.int 42) :=
Eq.refl (some (Const.int 42))

private theorem test_ex13 :
 test_eval ex13 = some (Const.int 42) :=
Eq.refl (some (Const.int 42))

private theorem test_ex14 :
 test_eval ex14 = some (Const.int 42) :=
Eq.refl (some (Const.int 42))

theorem test_ex15 :
 test_eval ex15 = some (Const.int 42) :=
begin
  exact rfl
end

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Example type checking tests
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

namespace Exp
open UOp BOp Const

theorem test_ex1 :
 TypeOf TyEnv.empty ex1 Ty.int :=
begin
  typecheck
end

theorem test_ex2 :
 TypeOf TyEnv.empty ex2 Ty.bool :=
begin
  typecheck
end

theorem test_ex3 :
 TypeOf TyEnv.empty ex3 Ty.int :=
begin
  typecheck
end

theorem test_ex4 :
 TypeOf TyEnv.empty ex4 Ty.int :=
begin
  typecheck
end

theorem test_ex5 :
 TypeOf TyEnv.empty ex5 Ty.int :=
begin
  typecheck
end

theorem test_ex6 :
 TypeOf TyEnv.empty ex6 Ty.bool :=
begin
  typecheck
end

theorem test_ex7 :
 TypeOf TyEnv.empty ex7 Ty.int :=
begin
  typecheck
end

theorem test_ex8 :
 TypeOf TyEnv.empty ex8 Ty.int :=
begin
  typecheck
end

theorem test_ex9 :
 TypeOf TyEnv.empty ex9 Ty.int :=
begin
  typecheck
end

theorem test_ex10 :
 TypeOf TyEnv.empty ex10 Ty.bool :=
begin
  typecheck
end

theorem test_ex11 :
 TypeOf TyEnv.empty ex11 Ty.int :=
begin
  typecheck
end

theorem test_ex12 :
 TypeOf TyEnv.empty ex12 Ty.int :=
begin
  typecheck
end

theorem test_ex13 :
 TypeOf TyEnv.empty ex13 Ty.int :=
begin
  typecheck
end

theorem test_ex14 :
 TypeOf TyEnv.empty ex14 Ty.int :=
begin
  typecheck
end

theorem test_ex15 :
 TypeOf TyEnv.empty ex15 Ty.int :=
begin
  typecheck
end

end Exp

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Type safety theorems
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

namespace UOp
open Const

def interp_safe : forall op t₁ t₂ c,
 typeof op = (t₁, t₂)
 → Const.typeof c = t₁
 → Exists (λ c' => interp op c = some c' ∧ Const.typeof c' = t₂) :=
begin
  intros op t₁ t₂ c Hop Hc;
  cases op; cases c;
  apply (Exists.intro (Const.int $ a + 1));
  apply And.intro;
  exact rfl;
end

end UOp

-- UOp.interp is type safe
-- BOp.interp is type safe
-- BOp.interp is type safe


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

! This file was ported from Lean 3 source module data.qpf.multivariate.constructions.comp
! leanprover-community/mathlib commit 23aa88e32dcc9d2a24cca7bc23268567ed4cd7d6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Pfunctor.Multivariate.Basic
import Mathbin.Data.Qpf.Multivariate.Basic

/-!
# The composition of QPFs is itself a QPF

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

We define composition between one `n`-ary functor and `n` `m`-ary functors
and show that it preserves the QPF structure
-/

universe u

namespace MvQPF

open MvFunctor

variable {n m : ℕ} (F : TypeVec.{u} n → Type _) [fF : MvFunctor F] [q : MvQPF F]
  (G : Fin2 n → TypeVec.{u} m → Type u) [fG : ∀ i, MvFunctor <| G i] [q' : ∀ i, MvQPF <| G i]

#print MvQPF.Comp /-
/-- Composition of an `n`-ary functor with `n` `m`-ary
functors gives us one `m`-ary functor -/
def Comp (v : TypeVec.{u} m) : Type _ :=
  F fun i : Fin2 n => G i v
#align mvqpf.comp MvQPF.Comp
-/

namespace Comp

open MvFunctor MvPFunctor

variable {F G} {α β : TypeVec.{u} m} (f : α ⟹ β)

instance [I : Inhabited (F fun i : Fin2 n => G i α)] : Inhabited (Comp F G α) :=
  I

#print MvQPF.Comp.mk /-
/-- Constructor for functor composition -/
protected def mk (x : F fun i => G i α) : (Comp F G) α :=
  x
#align mvqpf.comp.mk MvQPF.Comp.mk
-/

#print MvQPF.Comp.get /-
/-- Destructor for functor composition -/
protected def get (x : (Comp F G) α) : F fun i => G i α :=
  x
#align mvqpf.comp.get MvQPF.Comp.get
-/

/- warning: mvqpf.comp.mk_get -> MvQPF.Comp.mk_get is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {m : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} {G : (Fin2 n) -> (TypeVec.{u1} m) -> Type.{u1}} {α : TypeVec.{u1} m} (x : MvQPF.Comp.{u1, u2} n m F G α), Eq.{succ u2} (MvQPF.Comp.{u1, u2} n m F G α) (MvQPF.Comp.mk.{u1, u2} n m F G α (MvQPF.Comp.get.{u1, u2} n m F G α x)) x
but is expected to have type
  forall {n : Nat} {m : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} {G : (Fin2 n) -> (TypeVec.{u2} m) -> Type.{u2}} {α : TypeVec.{u2} m} (x : MvQPF.Comp.{u2, u1} n m F G α), Eq.{succ u1} (MvQPF.Comp.{u2, u1} n m F (fun (i : Fin2 n) => G i) α) (MvQPF.Comp.mk.{u2, u1} n m F (fun (i : Fin2 n) => G i) α (MvQPF.Comp.get.{u2, u1} n m F G α x)) x
Case conversion may be inaccurate. Consider using '#align mvqpf.comp.mk_get MvQPF.Comp.mk_getₓ'. -/
@[simp]
protected theorem mk_get (x : (Comp F G) α) : Comp.mk (Comp.get x) = x :=
  rfl
#align mvqpf.comp.mk_get MvQPF.Comp.mk_get

/- warning: mvqpf.comp.get_mk -> MvQPF.Comp.get_mk is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {m : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} {G : (Fin2 n) -> (TypeVec.{u1} m) -> Type.{u1}} {α : TypeVec.{u1} m} (x : F (fun (i : Fin2 n) => G i α)), Eq.{succ u2} (F (fun (i : Fin2 n) => G i α)) (MvQPF.Comp.get.{u1, u2} n m F G α (MvQPF.Comp.mk.{u1, u2} n m F G α x)) x
but is expected to have type
  forall {n : Nat} {m : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} {G : (Fin2 n) -> (TypeVec.{u2} m) -> Type.{u2}} {α : TypeVec.{u2} m} (x : F (fun (i : Fin2 n) => G i α)), Eq.{succ u1} (F (fun (i : Fin2 n) => G i α)) (MvQPF.Comp.get.{u2, u1} n m F (fun (i : Fin2 n) => G i) α (MvQPF.Comp.mk.{u2, u1} n m F (fun (i : Fin2 n) => G i) α x)) x
Case conversion may be inaccurate. Consider using '#align mvqpf.comp.get_mk MvQPF.Comp.get_mkₓ'. -/
@[simp]
protected theorem get_mk (x : F fun i => G i α) : Comp.get (Comp.mk x) = x :=
  rfl
#align mvqpf.comp.get_mk MvQPF.Comp.get_mk

include fG

#print MvQPF.Comp.map' /-
/-- map operation defined on a vector of functors -/
protected def map' : (fun i : Fin2 n => G i α) ⟹ fun i : Fin2 n => G i β := fun i => map f
#align mvqpf.comp.map' MvQPF.Comp.map'
-/

include fF

#print MvQPF.Comp.map /-
/-- The composition of functors is itself functorial -/
protected def map : (Comp F G) α → (Comp F G) β :=
  (map fun i => map f : (F fun i => G i α) → F fun i => G i β)
#align mvqpf.comp.map MvQPF.Comp.map
-/

instance : MvFunctor (Comp F G) where map α β := Comp.map

/- warning: mvqpf.comp.map_mk -> MvQPF.Comp.map_mk is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {m : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [fF : MvFunctor.{u1, u2} n F] {G : (Fin2 n) -> (TypeVec.{u1} m) -> Type.{u1}} [fG : forall (i : Fin2 n), MvFunctor.{u1, u1} m (G i)] {α : TypeVec.{u1} m} {β : TypeVec.{u1} m} (f : TypeVec.Arrow.{u1, u1} m α β) (x : F (fun (i : Fin2 n) => G i α)), Eq.{succ u2} (MvQPF.Comp.{u1, u2} n m F (fun (i : Fin2 n) {α : TypeVec.{u1} m} => G i α) β) (MvFunctor.map.{u1, u2} m (MvQPF.Comp.{u1, u2} n m F (fun (i : Fin2 n) {α : TypeVec.{u1} m} => G i α)) (MvQPF.Comp.mvfunctor.{u1, u2} n m F fF (fun (i : Fin2 n) {α : TypeVec.{u1} m} => G i α) (fun (i : Fin2 n) => fG i)) α β f (MvQPF.Comp.mk.{u1, u2} n m F (fun (i : Fin2 n) {α : TypeVec.{u1} m} => G i α) α x)) (MvQPF.Comp.mk.{u1, u2} n m F (fun (i : Fin2 n) {α : TypeVec.{u1} m} => G i α) β (MvFunctor.map.{u1, u2} n F fF (fun (i : Fin2 n) => G i α) (fun (i : Fin2 n) => G i β) (fun (i : Fin2 n) (x : G i α) => MvFunctor.map.{u1, u1} m (fun {α : TypeVec.{u1} m} => G i α) (fG i) α β f x) x))
but is expected to have type
  forall {n : Nat} {m : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [fF : MvFunctor.{u2, u1} n F] {G : (Fin2 n) -> (TypeVec.{u2} m) -> Type.{u2}} [fG : forall (i : Fin2 n), MvFunctor.{u2, u2} m (G i)] {α : TypeVec.{u2} m} {β : TypeVec.{u2} m} (f : TypeVec.Arrow.{u2, u2} m α β) (x : F (fun (i : Fin2 n) => G i α)), Eq.{succ u1} (MvQPF.Comp.{u2, u1} n m F (fun (i : Fin2 n) => G i) β) (MvFunctor.map.{u2, u1} m (MvQPF.Comp.{u2, u1} n m F (fun (i : Fin2 n) => G i)) (MvQPF.Comp.instMvFunctorComp.{u2, u1} n m F fF (fun (i : Fin2 n) => G i) (fun (i : Fin2 n) => fG i)) α β f (MvQPF.Comp.mk.{u2, u1} n m F (fun (i : Fin2 n) => G i) α x)) (MvQPF.Comp.mk.{u2, u1} n m F (fun (i : Fin2 n) => G i) β (MvFunctor.map.{u2, u1} n F fF (fun (i : Fin2 n) => G i α) (fun (i : Fin2 n) => G i β) (fun (i : Fin2 n) (x : G i α) => MvFunctor.map.{u2, u2} m (G i) (fG i) α β f x) x))
Case conversion may be inaccurate. Consider using '#align mvqpf.comp.map_mk MvQPF.Comp.map_mkₓ'. -/
theorem map_mk (x : F fun i => G i α) :
    f <$$> Comp.mk x = Comp.mk ((fun i (x : G i α) => f <$$> x) <$$> x) :=
  rfl
#align mvqpf.comp.map_mk MvQPF.Comp.map_mk

/- warning: mvqpf.comp.get_map -> MvQPF.Comp.get_map is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {m : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [fF : MvFunctor.{u1, u2} n F] {G : (Fin2 n) -> (TypeVec.{u1} m) -> Type.{u1}} [fG : forall (i : Fin2 n), MvFunctor.{u1, u1} m (G i)] {α : TypeVec.{u1} m} {β : TypeVec.{u1} m} (f : TypeVec.Arrow.{u1, u1} m α β) (x : MvQPF.Comp.{u1, u2} n m F G α), Eq.{succ u2} (F (fun (i : Fin2 n) => G i β)) (MvQPF.Comp.get.{u1, u2} n m F G β (MvFunctor.map.{u1, u2} m (MvQPF.Comp.{u1, u2} n m F G) (MvQPF.Comp.mvfunctor.{u1, u2} n m F fF G (fun (i : Fin2 n) => fG i)) α β f x)) (MvFunctor.map.{u1, u2} n F fF (fun (i : Fin2 n) => G i α) (fun (i : Fin2 n) => G i β) (fun (i : Fin2 n) (x : G i α) => MvFunctor.map.{u1, u1} m (fun {α : TypeVec.{u1} m} => G i α) (fG i) α β f x) (MvQPF.Comp.get.{u1, u2} n m F G α x))
but is expected to have type
  forall {n : Nat} {m : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [fF : MvFunctor.{u2, u1} n F] {G : (Fin2 n) -> (TypeVec.{u2} m) -> Type.{u2}} [fG : forall (i : Fin2 n), MvFunctor.{u2, u2} m (G i)] {α : TypeVec.{u2} m} {β : TypeVec.{u2} m} (f : TypeVec.Arrow.{u2, u2} m α β) (x : MvQPF.Comp.{u2, u1} n m F G α), Eq.{succ u1} (F (fun (i : Fin2 n) => G i β)) (MvQPF.Comp.get.{u2, u1} n m F G β (MvFunctor.map.{u2, u1} m (MvQPF.Comp.{u2, u1} n m F G) (MvQPF.Comp.instMvFunctorComp.{u2, u1} n m F fF G (fun (i : Fin2 n) => fG i)) α β f x)) (MvFunctor.map.{u2, u1} n F fF (fun (i : Fin2 n) => G i α) (fun (i : Fin2 n) => G i β) (fun (i : Fin2 n) (x : G i α) => MvFunctor.map.{u2, u2} m (G i) (fG i) α β f x) (MvQPF.Comp.get.{u2, u1} n m F (fun (i : Fin2 n) => G i) α x))
Case conversion may be inaccurate. Consider using '#align mvqpf.comp.get_map MvQPF.Comp.get_mapₓ'. -/
theorem get_map (x : Comp F G α) :
    Comp.get (f <$$> x) = (fun i (x : G i α) => f <$$> x) <$$> Comp.get x :=
  rfl
#align mvqpf.comp.get_map MvQPF.Comp.get_map

include q q'

instance : MvQPF (Comp F G)
    where
  p := MvPFunctor.comp (p F) fun i => p <| G i
  abs α := Comp.mk ∘ (map fun i => abs) ∘ abs ∘ MvPFunctor.comp.get
  repr α :=
    MvPFunctor.comp.mk ∘
      repr ∘ (map fun i => (repr : G i α → (fun i : Fin2 n => Obj (p (G i)) α) i)) ∘ Comp.get
  abs_repr := by
    intros
    simp [(· ∘ ·), MvFunctor.map_map, (· ⊚ ·), abs_repr]
  abs_map := by
    intros
    simp [(· ∘ ·)]
    rw [← abs_map]
    simp [MvFunctor.id_map, (· ⊚ ·), map_mk, MvPFunctor.comp.get_map, abs_map, MvFunctor.map_map,
      abs_repr]

end Comp

end MvQPF


import EggTactic

inductive EQ {α : Type} (a : α) : α → Type where
  | refl : EQ a a

def EQ.trans (h₁ : EQ a b) (h₂ : EQ b c) : EQ a c := by
  cases h₁; cases h₂; constructor

instance : Trans (@EQ α) (@EQ α) (@EQ α) where
  trans := EQ.trans

infix:50 " ≋ " => EQ

example (h₁ : EQ a b) (h₂ : b = c) (h₃ : EQ c d) : EQ a d := by
  calc a ≋ b := h₁
       _ = c := h₂
       _ ≋ d := h₃

example (h₁ : EQ a b) (h₂ : b = c) (h₃ : EQ c d) : EQ a d := by
  eggxplosion [h₁, h₂, h₃]


import algebra.module.submodule.basic
import algebra.group_power.basic
import .holomorphic_functions
import analysis.complex.upper_half_plane.basic
import linear_algebra.general_linear_group
import linear_algebra.special_linear_group
import algebra.direct_sum.ring
import number_theory.modular
import geometry.manifold.mfderiv
import .upper_half_plane_manifold
import .hol_bdd
import number_theory.modular_forms.slash_actions
import number_theory.modular_forms.slash_invariant_forms
import linear_algebra.general_linear_group

open complex

open_locale topological_space manifold

noncomputable theory

open modular_form

open_locale upper_half_plane

local notation `ℍ'`:=(⟨upper_half_space , upper_half_plane_is_open⟩: open_subs)

local notation `ℍ`:=upper_half_plane

instance : charted_space ℂ ℂ := infer_instance

instance : charted_space ℂ ℍ' := infer_instance

local prefix `↑ₘ`:1024 := @coe _ (matrix (fin 2) (fin 2) _) _

local notation `GL(` n `, ` R `)`⁺:= matrix.GL_pos (fin n) R

local notation `SL(` n `, ` R `)`:= matrix.special_linear_group (fin n) R

variable (M : GL(2, ℝ)⁺)

lemma auxmf2 (a b c : ℂ) : b⁻¹*c⁻¹*a=(b*c)⁻¹*a:=
begin
field_simp,
end

lemma aux1 (a b c d e: ℂ) (k : ℤ) : (e^k)⁻¹*a^(k-1) * (b^k)⁻¹ * c^(k -1) * d =
( (b * e)^ k)⁻¹ * (c * a)^(k-1) * d:=
begin
have : (b^k)⁻¹ * ((e)^ k)⁻¹ * (c)^(k-1) * (a)^(k-1) * d = ( (b * e)^ k)⁻¹ * (c * a)^(k-1) * d ,
by  {ring_exp, rw ← mul_assoc,
 have:  (b * e)^ k = b^k * e^k, by {exact mul_zpow b e k,},
simp_rw [mul_zpow],
simp_rw [mul_inv],ring,},
rw ←this,
ring,
end

open modular_form
open complex matrix matrix.special_linear_group upper_half_plane
open_locale upper_half_plane complex_conjugate

variables (Γ : subgroup SL(2,ℤ)) (C : GL(2, ℝ)⁺) (k: ℤ) (f : (ℍ → ℂ))

localized "notation  f  ` ∣[`:100 k `]`:0 γ :100 := slash k γ f" in modular_form

--Definition of modular forms:
def weakly_modular_weight_k (k : ℤ) (f : ℍ' → ℂ) :=
    ∀ (γ : SL(2,ℤ)),  (f ∣[k] (γ : GL(2, ℝ)⁺)) = f

lemma zero_weakly_modular (k : ℤ) : weakly_modular_weight_k k (0 : ℍ' → ℂ) :=
begin
intro γ,
simp,
sorry,
end

def one_periodicity (f : ℍ' → ℂ) := ∀ (z : ℍ'), extend_by_zero f (z + 1) = extend_by_zero f (z)

def weakly_modular_submodule_weight_k (k : ℤ) : submodule ℂ (ℍ' → ℂ) := {
  carrier := weakly_modular_weight_k k,
  zero_mem' := by {exact zero_weakly_modular k},
  add_mem' := by {
    intros f g hf hg,
    intro γ,
    have hff:= hf γ,
    have hgg:= hg γ,
    rw slash_add k γ f g,
    rw [hff, hgg],
  },
  smul_mem' := by {
    intros c f hf,
    intro γ,
    have hff:= hf γ,
    have : (c • f)  ∣[k] γ = c • (f  ∣[k] γ ),
    by {apply smul_slash},
    rw hff at this,
    apply this,
  },
}

class modular_form_weight_k (k : ℤ) (f : ℍ' → ℂ) : Prop :=
  (hol : f ∈ Holℍ)
  (weak : weakly_modular_weight_k k f)

def space_of_modular_forms_weight_k (k : ℤ) : submodule ℂ (ℍ' → ℂ) := {
  carrier := modular_form_weight_k k,
  add_mem' := λ f g hf hg, ⟨Holℍ.add_mem' hf.hol hg.hol, (weakly_modular_submodule_weight_k k).add_mem' hf.weak hg.weak⟩,
  zero_mem' := ⟨Holℍ.zero_mem', zero_weakly_modular k⟩,
  smul_mem' := λ c f hf, ⟨⟨smul_hol _ _ hf.hol.diff, bounded_at_im_infty.smul _ hf.hol.bdd_at_infty⟩,
    (weakly_modular_submodule_weight_k k).smul_mem' c hf.weak⟩,
  }

-- Definition of modular forms for congruence subgroups:

def weakly_modular_weight_k_subgroup (k : ℤ) (Γ : subgroup SL(2,ℤ)) (f : ℍ' → ℂ) :=
  ∀ (γ : Γ),  (f ∣[k] (γ : GL(2, ℝ)⁺)) = f

lemma zero_weakly_modular_subgroup (k : ℤ) (Γ : subgroup SL(2,ℤ)) : weakly_modular_weight_k_subgroup k Γ (0 : ℍ' → ℂ) :=
begin
intro γ,
simp,
sorry,
end

def weakly_modular_submodule_weight_k_subgroup (k : ℤ) (Γ : subgroup SL(2,ℤ)) : submodule ℂ (ℍ' → ℂ) := {
  carrier := weakly_modular_weight_k_subgroup k Γ,
  zero_mem' := by {exact zero_weakly_modular_subgroup k Γ},
  add_mem' := by {
    intros f g hf hg,
    intro γ,
    have hff:= hf γ,
    have hgg:= hg γ,
    rw slash_add k γ f g,
    rw [hff, hgg],
  },
  smul_mem' := by {
    intros c f hf,
    intro γ,
    have hff:= hf γ,
    have : (c • f)  ∣[k] γ = c • (f  ∣[k] γ ),
    by {apply smul_slash},
    rw hff at this,
    apply this,
  },
}

--instance : has_mem (ℍ' → ℂ) (submodule ℂ (ℍ' → ℂ)) := ⟨λ f V, f ∈ V⟩

--Space of modular forms for congruence subgroups:
class modular_form_weight_k_subgroup (k : ℤ) (Γ : subgroup SL(2,ℤ)) (f : ℍ' → ℂ) : Prop :=
  (hol : f ∈ Holℍ)
  (weak : weakly_modular_weight_k_subgroup k Γ f)

def space_of_modular_forms_weight_k_subgroup (k : ℤ) (Γ : subgroup SL(2,ℤ)) : submodule ℂ (ℍ' → ℂ) := {
  carrier := modular_form_weight_k_subgroup k Γ,
  add_mem' := λ f g hf hg, ⟨Holℍ.add_mem' hf.hol hg.hol, (weakly_modular_submodule_weight_k_subgroup k Γ).add_mem' hf.weak hg.weak⟩,
  zero_mem' := ⟨Holℍ.zero_mem', zero_weakly_modular_subgroup k Γ⟩,
  smul_mem' := λ c f hf, ⟨⟨smul_hol _ _ hf.hol.diff, bounded_at_im_infty.smul _ hf.hol.bdd_at_infty⟩,
    (weakly_modular_submodule_weight_k_subgroup k Γ).smul_mem' c hf.weak⟩,
  }

-- Definition of meromorphic modular forms:
def slash_mer_left (k : ℤ) (γ : SL(2,ℤ)) (f g : ℍ → ℂ) (z : ℍ) : ℂ :=
  f(γ • z) * g(z) * (upper_half_plane.denom γ z)^(-k)

lemma power_of_diff (k1 k2 : ℤ) (a : ℂ) : a^(k1-k2) = a^k1 * a^(-k2) :=
begin

  sorry,
end

lemma sep_slash_mer_left (k1 k2 : ℕ) (k : ℤ) (hk : k = k1-k2) (γ : SL(2,ℤ)) (f g : ℍ → ℂ) (z : ℍ) :
  f(γ • z) * g(z) * (upper_half_plane.denom γ z)^(-k) = f(γ • z) * (upper_half_plane.denom γ z)^(-k1 : ℤ) * g(z) * (upper_half_plane.denom γ z)^(k2) :=
  begin
  rw hk,
  simp only [neg_sub, pow_add],
  have : (denom γ z)^((k2 : ℤ)-(k1:ℤ)) = (denom γ z)^(k2:ℤ) * (denom γ z)^(-k1 : ℤ),
  {
    simp,
    sorry,
  },
  rw this,
  simp only [of_real_int_cast, zpow_coe_nat, zpow_neg],
  sorry,
  end

def slash_mer_right (k : ℤ) (γ : SL(2,ℤ)) (f g : ℍ → ℂ) (z : ℍ) : ℂ :=
  f(z) * g(γ • z)

def weakly_meromorphic_modular_weight_k (k : ℤ) (F : Merℍ) :=
  ∀ (γ : SL(2,ℤ)), slash_mer_left k γ F.numerator.val F.denominator.val.val = slash_mer_right k γ F.numerator.val F.denominator.val.val

instance mem_mer : has_mem Merℍ (submodule ℂ (ℍ' → ℂ)) := ⟨λ F V, F.map ∈ V⟩

--Meromorphic modular form subtype

def Merℍwm (k : ℤ) :=
{F : Merℍ | weakly_meromorphic_modular_weight_k k F}

lemma Merℍwm_mem (k : ℤ) (F : Merℍ) :
  F ∈ (Merℍwm k) ↔  ∀ (γ : SL(2,ℤ)), slash_mer_left k γ F.numerator.val F.denominator.val.val = slash_mer_right k γ F.numerator.val F.denominator.val.val :=
  iff.rfl

lemma Merℍ_ap (k : ℤ) (Γ : subgroup SL(2,ℤ)) (f : Holℍ) (g : non_zero_divisors Holℍ) : Merℍ :=
begin
exact Merℍ.mk f g,
end

lemma modular_forms_of_Merℍwm (k1 k2 : ℤ) (hk : k = k1-k2)
(f : Holℍ) (g : non_zero_divisors Holℍ) (hf : modular_form_weight_k k1 f) (hg : modular_form_weight_k k2 g)
: Merℍ.mk f g ∈ Merℍwm (k) :=
begin
rw Merℍwm_mem,
intro γ,

sorry,
end

/- def space_of_meromorphic_modular_forms_weight_k (k : ℤ) (Γ : subgroup SL(2,ℤ)) : submodule ℂ (ℍ' → ℂ) := {
  carrier := Merℍ.map '' set.univ,
  add_mem' := sorry,
  zero_mem' := sorry,
  smul_mem' := sorry,
  }

 -/

/- ---------
lemma wmodular_mem (k : ℤ) (Γ : subgroup SL(2,ℤ)) (f : ℍ' → ℂ) :
  f ∈ (weakly_modular_submodule_weight_k k Γ) ↔  ∀ (γ : Γ), (f ∣[k] (γ : GL(2, ℝ)⁺)) = f := iff.rfl

/--A function `f:ℍ → ℂ` is modular, of level `Γ` and weight `k ∈ ℤ`, if for every matrix in
 `γ ∈  Γ` we have `f(γ  • z)= (c*z+d)^k f(z)` where `γ= ![![a, b], ![c, d]]`,
 and it acts on `ℍ` via Moebius trainsformations. -/
@[simp] lemma wmodular_mem' (k : ℤ) (Γ : subgroup SL(2,ℤ)) (f : ℍ' → ℂ) :
  f ∈ (weakly_modular_submodule_weight_k k Γ) ↔  ∀ γ : Γ, ∀ z : ℍ,
  f ((γ : matrix.GL_pos (fin 2) ℝ) • z) = ((↑ₘγ 1 0 : ℝ) * z +(↑ₘγ 1 1 : ℝ))^k * f z :=
begin
  simp only [wmodular_mem],
  split,
  intros h1 γ z,
  have h2:= h1 γ,
  have h3: (f ∣[k] γ) z = f z , by {simp_rw h2},
  rw ← h3,
  simp_rw slash,
  rw mul_comm,
  have h5:= upper_half_plane.denom_ne_zero (γ : GL(2, ℝ)⁺) z,
  simp only [coe_fn_coe_base, ne.def, matrix.general_linear_group.coe_fn_eq_coe, coe_coe] at h5,
  have pown := zpow_ne_zero k h5,
  have h55:= inv_mul_cancel pown,
  simp_rw upper_half_plane.denom at *,
  simp only [coe_coe, matrix.special_linear_group.coe_GL_pos_coe_GL_coe_matrix,
  matrix.special_linear_group.coe_matrix_coe, int.coe_cast_ring_hom,
  matrix.map_apply, of_real_int_cast],
  simp [matrix.special_linear_group.coe_GL_pos_coe_GL_coe_matrix] at h55,
  rw mul_assoc,
  simp_rw [h55],
  simp,
  simp_rw [←int.coe_cast_ring_hom],
  simp_rw ←matrix.special_linear_group.coe_matrix_coe,
  have := matrix.special_linear_group.det_coe ((γ : SL(2, ℤ) ) : SL(2, ℝ)),
  rw this,
  simp,
  sorry,
  intros hf γ,
  simp_rw slash,
  ext1,
  have hff:= hf γ x,
  rw hff,
  rw mul_comm,
  have h5:= upper_half_plane.denom_ne_zero (γ : GL(2, ℝ)⁺) x,
  simp only [coe_fn_coe_base, ne.def, matrix.general_linear_group.coe_fn_eq_coe, coe_coe] at h5,
  have pown := zpow_ne_zero k h5,
  have h55:= inv_mul_cancel pown,
  simp_rw upper_half_plane.denom at *,
  simp [matrix.special_linear_group.coe_GL_pos_coe_GL_coe_matrix] at h55,
  simp only [coe_coe, matrix.special_linear_group.coe_GL_pos_coe_GL_coe_matrix,
  matrix.map_apply, of_real_int_cast],
  have := matrix.special_linear_group.det_coe ((γ : SL(2, ℤ) ) : SL(2, ℝ)),
  rw this,
  simp,
  rw ← mul_assoc,
  simp_rw h55,
  simp,
end

lemma mul_modular  (k_1 k_2 : ℤ) (Γ : subgroup SL(2,ℤ)) (f g : ℍ' → ℂ)
  (hf : f ∈ weakly_modular_submodule_weight_k k_1 Γ)  (hg : g ∈ weakly_modular_submodule_weight_k k_2 Γ) :
  f * g  ∈ weakly_modular_submodule_weight_k (k_1+k_2) Γ :=
begin
  simp only [wmodular_mem', pi.mul_apply, coe_coe] at *,
  intros γ z,
  have hff:= hf γ z,
  have hgg:= hg γ z,
  rw [hff,hgg],
  have h5:= upper_half_plane.denom_ne_zero (γ : GL(2, ℝ)⁺) z,
  simp_rw upper_half_plane.denom at h5,
  simp only [coe_fn_coe_base, ne.def, matrix.general_linear_group.coe_fn_eq_coe, coe_coe] at h5,
  have pown := zpow_add₀ h5 k_1 k_2,
  rw pown,
  ring,
end

/--The extension of a function from `ℍ` to `ℍ'`-/
def hol_extn (f : ℍ → ℂ) : ℍ' → ℂ := λ (z : ℍ'), (f (z : ℍ) )

-/


import data.optree
import data.vect
import data.finord

universes u v

-- Structure for algebraic theories
structure theory :=
  mk :: (op : ℕ → Type) (rel : ℕ → Type)
        (rel_lhs : ∀ {n : ℕ}, rel n → optree op (finord n))
        (rel_rhs : ∀ {n : ℕ}, rel n → optree op (finord n))

-- Pre-model of a theory; i.e. sets with structure maps which not necessarily satisfy the axioms.
class premodel (th : theory) (α : Type u) : Type u :=
  mk :: (act : Π {n : ℕ}, th.op n → vect α n → α)

-- Model of a theory
class model (th : theory) (α : Type u) extends premodel th α : Type u:=
  mk :: (haxiom : ∀ {n : ℕ} (r : th.rel n) (var : finord n → α), (th.rel_lhs r).elim @act var = (th.rel_rhs r).elim @act var)

instance model_is_premodel(th : theory) (α : Type _) [ha : model th α] : premodel th α := ha.to_premodel

namespace premodel

definition action (th : theory) (α : Type _) [premodel th α] : Π {n : ℕ}, th.op n → vect α n → α := @premodel.act th α _

end premodel

namespace model

definition axiom_eq (th : theory) (α : Type _) [model th α] : ∀ {n : ℕ} (r : th.rel n) (var : finord n → α), (th.rel_lhs r).elim (@premodel.act th α _) var = (th.rel_rhs r).elim (@premodel.act th α _) var := @model.haxiom th α _

--- Trivial model; `unit` is always a model of any algebraic theory.
instance triv (th : theory) : model th unit :=
{
  act := λ _ _ _, (),
  haxiom :=
    begin
      intros,
      dsimp [premodel.act],
      have : ∀ {x y: unit}, x=y,
        by intros  x y; cases x; cases y; refl,
      exact this
    end
}

#print axioms model.triv

end model

/-*****************************
 - Morphisms of pre-models
 -*****************************-/

@[reducible]
definition is_morphism (th : theory) {α : Type u} {β : Type v} [premodel th α] [premodel th β] (f : α → β) : Prop := ∀ {n : ℕ} (μ : th.op n) (as : vect α n), f (@premodel.act th α _ _ μ as) = (@premodel.act th β _ _ μ (as.map f))

definition morphism (th : theory) (α : Type _) (β : Type _) [premodel th α] [premodel th β] := {f : α → β // is_morphism th f}

namespace morphism

protected
definition coe_to_fun {th : theory} (α : Type _) (β : Type _) [premodel th α] [premodel th β] : has_coe_to_fun (morphism th α β)  :=
  {
    F := λ_, α → β,
    coe := subtype.val
  }

attribute [instance] morphism.coe_to_fun

-- the identity morphism
definition id {th : theory} {α : Type _} [premodel th α] : morphism th α α :=
  ⟨id, by intros n u as; rw [vect.map_id]; refl⟩

-- the composition of morphisms
definition comp {th : theory} {α β γ : Type _} [premodel th α] [premodel th β] [premodel th γ] : morphism th β γ → morphism th α β → morphism th α γ :=
  λ g f, ⟨g.val ∘ f.val, by intros n k cs; unfold function.comp; rw [vect.map_comp,f.property,g.property]⟩

#print axioms morphism.comp

-- Two morphisms equal to each other as soon as their underlying maps do
theorem morphism_eq {th : theory} {α β : Type _} [premodel th α] [premodel th β] {f g : morphism th α β} : f.val = g.val → f = g := subtype.eq

#print axioms morphism_eq

-- The image of every morphism is closed under operations
theorem image_act {th : theory} {α β : Type _} [premodel th α] [premodel th β] (f : morphism th α β) : ∀ {n : ℕ} {k : th.op n} {ys : vect {b // ∃ a, f.val a = b} n}, ∃ a, f.val a = (@premodel.act th β _ _ k) (vect.map subtype.val ys) :=
  begin
    intros,
    apply exists.elim (vect.image ys),
    intros as has,
    existsi (@premodel.act th α _ _ k) as,
    rw [f.property, has]
  end

#print axioms image_act

-- The image of a morphism forms a premodel
definition image_premodel {th : theory} {α β : Type _} [premodel th α] [premodel th β] (f : morphism th α β) : premodel th {b // ∃ a, f.val a = b} :=
  {
    act :=
      λ n k xs, ⟨@premodel.act th β _ _ k (vect.map subtype.val xs), image_act f⟩
  }

-- The image of a morphism in a model forms a model
definition image_model {th : theory} {α β : Type _} [premodel th α] [model th β] (f : morphism th α β) : model th {b // ∃ a, f.val a = b} :=
  {
    to_premodel := image_premodel f,
    haxiom :=
      begin
        intros,
        dsimp [image_premodel] at *,
        apply subtype.eq,
        rw [optree.elim_subtype,optree.elim_subtype],
        rw [model.axiom_eq]
      end
  }

#print axioms image_model

end morphism


import algebra.category.Group.biproducts
import algebra.category.Group.abelian
import algebra.direct_sum.basic
import category_theory.preadditive.yoneda
import for_mathlib.AddCommGroup.epi

open category_theory
open category_theory.limits

def dfinsupp.add_equiv_pi_on_fintype {α : Type*} [fintype α] (X : α → Type*)
  [∀ i, add_comm_group (X i)] :
  (Π₀ i, X i) ≃+ (Π i, X i) :=
{ map_add' := λ x y, by { ext, simp, },
  ..dfinsupp.equiv_fun_on_fintype }

namespace AddCommGroup

universes v u

def pi_π {α : Type v} (X : α → AddCommGroup.{max v u}) (i) :
  AddCommGroup.of (Π i, X i) ⟶ X i :=
pi.eval_add_monoid_hom _ _

def pi_fan {α : Type v} (X : α → AddCommGroup.{max v u}) : fan X :=
fan.mk (AddCommGroup.of $ Π i, X i)
(λ b, pi_π _ _)

def pi_lift {α : Type v} {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f : Π a, Y ⟶ X a) : Y ⟶ AddCommGroup.of (Π i, X i) :=
{ to_fun := λ y i, f _ y,
  map_zero' := by { ext, simp },
  map_add' := λ x y, by { ext, simp } }

@[simp, reassoc]
lemma pi_lift_π {α : Type v} {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f : Π a, Y ⟶ X a) (i) :
  pi_lift X f ≫ pi_π _ i = f _ := by { ext, refl }

lemma pi_hom_ext {α : Type v} {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f g : Y ⟶ AddCommGroup.of (Π i, X i))
  (h : ∀ i, f ≫ pi_π _ i = g ≫ pi_π _ i) : f = g :=
by { ext y a, specialize h a, apply_fun (λ e, e y) at h, exact h }

def is_limit_pi_fan {α : Type v} (X : α → AddCommGroup.{max v u}) :
  is_limit (pi_fan X) :=
{ lift := λ S, pi_lift _ $ λ a, S.π.app ⟨_⟩,
  fac' := begin
    rintros S ⟨j⟩,
    apply pi_lift_π,
  end,
  uniq' := begin
    intros S m hm,
    apply pi_hom_ext,
    intros i,
    erw [hm ⟨i⟩, pi_lift_π],
  end }

noncomputable
def hom_product_comparison
  {α : Type v}
  (A : AddCommGroup.{max v u})
  (X : α → AddCommGroup.{max v u}) :
  AddCommGroup.of (A ⟶ ∏ X) ⟶ ∏ (λ i, AddCommGroup.of (A ⟶ (X i))) :=
limits.pi.lift $ λ a, (preadditive_yoneda.flip.obj (opposite.op A)).map (limits.pi.π _ _)

instance is_iso_hom_product_comparison
  {α : Type v}
  (A : AddCommGroup.{max v u})
  (X : α → AddCommGroup.{max v u}) :
  is_iso (hom_product_comparison A X) :=
begin
  --haveI : balanced Ab.{max v u} := AddcommGroup.abelian
  let t : (∏ λ (i : α), AddCommGroup.of (A ⟶ X i)) ≅ AddCommGroup.of
    (Π i, AddCommGroup.of (A ⟶ X i)) :=
    (limits.limit.is_limit _).cone_point_unique_up_to_iso
    (is_limit_pi_fan (λ i, of (A ⟶ X i))),
  suffices : is_iso (A.hom_product_comparison X ≫ t.hom),
  { apply is_iso.of_is_iso_comp_right _ t.hom, exact this },
  have ht : A.hom_product_comparison X ≫ t.hom =
    (is_limit_pi_fan (λ i, of (A ⟶ X i))).lift
    ⟨_, discrete.nat_trans $ λ i, (preadditive_yoneda.flip.obj (opposite.op A)).map
      (limits.pi.π _ _)⟩,
  { apply (is_limit_pi_fan _).hom_ext, intros j,
    simp [hom_product_comparison] },
  rw ht, clear ht,
  apply_with is_iso_of_mono_of_epi { instances := ff },
  apply_instance,
  { rw mono_iff_injective,
    intros f g h,
    ext1 ⟨j⟩,
    apply_fun (λ e, e j) at h,
    exact h },
  { rw epi_iff_surjective,
    intros f,
    use limits.pi.lift (λ i, f i),
    dsimp [is_limit_pi_fan, pi_lift],
    simp [pi_lift_π] }
end

def direct_sum_π {α : Type v} (X : α → AddCommGroup.{max v u}) (i) :
  AddCommGroup.of (direct_sum α (λ i, X i)) ⟶ X i :=
{ to_fun := λ f, let e : Π₀ (i : α), (X i) := f in e i,
  map_zero' := by simp,
  map_add' := λ x y, by { dsimp, simp } }

def direct_sum_fan {α : Type v} (X : α → AddCommGroup.{max v u}) : fan X :=
fan.mk (AddCommGroup.of (direct_sum α (λ i, X i)))
(λ b, direct_sum_π _ _)

open_locale classical

def direct_sum_lift {α : Type v} [fintype α]
  {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f : Π a, Y ⟶ X a) :
  Y ⟶ AddCommGroup.of (direct_sum α (λ i, X i)) :=
{ to_fun := λ y, (dfinsupp.add_equiv_pi_on_fintype _).symm $ λ i, f i y,
  map_zero' := begin
    simp_rw map_zero,
    change ((dfinsupp.add_equiv_pi_on_fintype (λ (i : α), ↥(X i))).symm) 0 = _,
    simp,
  end,
  map_add' := begin
    intros x y,
    simp_rw map_add,
    change ((dfinsupp.add_equiv_pi_on_fintype (λ (i : α), ↥(X i))).symm)
      ((λ (i : α), (f i) x) + (λ (i : α), (f i) y)) = _,
    simp,
  end }

@[simp, reassoc]
lemma direct_sum_lift_π {α : Type v} [fintype α]
  {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f : Π a, Y ⟶ X a) (i) :
  direct_sum_lift X f ≫ direct_sum_π _ i = f i :=
by { ext, refl }

lemma direct_sum_hom_ext {α : Type v} [fintype α]
  {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f g : Y ⟶ AddCommGroup.of (direct_sum α (λ i, X i)))
  (h : ∀ i, f ≫ direct_sum_π _ i = g ≫ direct_sum_π _ i) :
  f = g :=
begin
  ext,
  specialize h i,
  apply_fun (λ e, e x) at h, exact h
end

def is_limit_direct_sum_fan {α : Type v} [fintype α]
  (X : α → AddCommGroup.{max v u}) : is_limit (direct_sum_fan X) :=
{ lift := λ S, direct_sum_lift _ $ λ a, S.π.app ⟨a⟩, -- S.π.app,
  fac' := begin
    rintros S ⟨j⟩,
    apply direct_sum_lift_π,
  end,
  uniq' := begin
    intros S m hm,
    apply direct_sum_hom_ext,
    intros i,
    specialize hm ⟨i⟩,
    erw [hm, direct_sum_lift_π],
  end }

noncomputable theory

def to_direct_sum {α : Type v} (X : α → AddCommGroup.{max v u})
  (i : α) : X i ⟶ AddCommGroup.of (direct_sum α (λ i, X i)) :=
direct_sum.of (λ i, X i) i

def direct_sum_punit_iso (A : AddCommGroup.{max v u}) :
  AddCommGroup.of (direct_sum _ (λ i : punit.{v+1}, A)) ≅ A :=
{ hom := direct_sum_π _ punit.star,
  inv := to_direct_sum (λ i, A) punit.star,
  hom_inv_id' := begin
    ext ⟨⟩ ⟨⟩,
    ext t ⟨⟩, -- WAT?
    dsimp [direct_sum_π, to_direct_sum],
    simp,
  end,
  inv_hom_id' := begin
    ext a,
    dsimp [direct_sum_π, to_direct_sum],
    simp,
  end }

def direct_sum_ι {α : Type v} (X : α → AddCommGroup.{max v u})
  (i : α) : X i ⟶ AddCommGroup.of (direct_sum α (λ i, X i)) :=
direct_sum.of _ i

def direct_sum_desc {α : Type v} {Y : AddCommGroup.{max v u}} (X : α → AddCommGroup.{max v u})
  (f : Π i, X i ⟶ Y) :
  AddCommGroup.of (direct_sum α (λ i, X i)) ⟶ Y :=
direct_sum.to_add_monoid f

@[simp, reassoc]
lemma direct_sum_ι_desc {α : Type v} {Y : AddCommGroup.{max v u}}
  (X : α → AddCommGroup.{max v u})
  (f : Π i, X i ⟶ Y) (i) :
  direct_sum_ι X i ≫ direct_sum_desc X f = f _ :=
by { ext, dsimp [direct_sum_ι, direct_sum_desc], simp }

lemma direct_sum_hom_ext' {α : Type v} {Y : AddCommGroup.{max v u}}
  (X : α → AddCommGroup.{max v u})
  (f g : AddCommGroup.of (direct_sum α (λ i, X i)) ⟶ Y)
  (h : ∀ i, direct_sum_ι X i ≫ f = direct_sum_ι X i ≫ g) :
  f = g :=
begin
  have hf : f = direct_sum_desc X (λ i, direct_sum_ι X i ≫ f),
  { ext t, apply direct_sum.to_add_monoid.unique },
  have hg : g = direct_sum_desc X (λ i, direct_sum_ι X i ≫ g),
  { ext t, apply direct_sum.to_add_monoid.unique },
  rw [hf, hg],
  congr' 1, ext i, rw h,
end

def direct_sum_cofan {α : Type v}
  (X : α → AddCommGroup.{max v u}) : cofan X :=
cofan.mk _ (direct_sum_ι _)

def is_colimit_direct_sum_cofan {α : Type v}
  (X : α → AddCommGroup.{max v u}) : is_colimit (direct_sum_cofan X) :=
{ desc := λ S, direct_sum_desc X (λ a, S.ι.app ⟨a⟩), -- S.ι.app,
  fac' := begin
    rintros X ⟨j⟩,
    apply direct_sum_ι_desc,
  end,
  uniq' := begin
    intros S m hm,
    apply direct_sum_hom_ext',
    intros i,
    specialize hm ⟨i⟩,
    erw hm, rw direct_sum_ι_desc,
  end }

lemma direct_sum_ι_π {α : Type v} (X : α → AddCommGroup.{max v u}) (i : α) :
  direct_sum_ι.{v u} X i ≫ direct_sum_π.{v u} X i = 𝟙 _ :=
begin
  ext,
  dsimp [direct_sum_ι, direct_sum_π, direct_sum.of],
  simp only [comp_apply, dfinsupp.single_add_hom_apply, add_monoid_hom.coe_mk,
    dfinsupp.single_apply],
  split_ifs, refl, refl,
end

lemma direct_sum_ι_π_of_ne {α : Type v} (X : α → AddCommGroup.{max v u}) (i j : α) (h : i ≠ j):
  direct_sum_ι.{v u} X i ≫ direct_sum_π.{v u} X j = 0 :=
begin
  ext,
  dsimp [direct_sum_ι, direct_sum_π, direct_sum.of],
  simp only [comp_apply, dfinsupp.single_add_hom_apply, add_monoid_hom.coe_mk,
    dfinsupp.single_apply],
  split_ifs, contradiction, refl,
end

-- `bicone` is not sufficiently universe polymorphic.
def direct_sum_bicone {α : Type u} [fintype α]
  (X : α → AddCommGroup.{u}) : bicone X :=
{ X := AddCommGroup.of (direct_sum α (λ i, X i)),
  π := direct_sum_π.{u u} _,
  ι := direct_sum_ι.{u u} _,
  ι_π := λ i j, begin
    ext t,
    dsimp [direct_sum_ι, direct_sum_π, direct_sum.of],
    simp only [comp_apply, dfinsupp.single_add_hom_apply, add_monoid_hom.coe_mk,
      dfinsupp.single_apply],
    split_ifs, subst h, refl, refl,
  end }

def is_bilimit_direct_sum_bicone {α : Type u} [fintype α]
  (X : α → AddCommGroup.{u}) :
  bicone.is_bilimit (direct_sum_bicone X) :=
{ is_limit := is_limit_direct_sum_fan.{u u} X,
  is_colimit := is_colimit_direct_sum_cofan.{u u} X }

end AddCommGroup


variables (f : ℕ → ℕ) (k : ℕ)

example (h₁ : f 0 = 0) (h₂ : k = 0) : f k = 0 :=
  by rw [h₂, h₁]


import data.int.parity data.int.modeq ring_theory.coprime.lemmas

/-! # IMO 2015 N1 -/

namespace IMOSL
namespace IMO2015N1

open function

def f (n : ℤ) := n * (n / 2)

/-- Final solution -/
theorem final_solution (n : ℤ) : (∃ k : ℕ, even (f^[k] n)) ↔ n ≠ 3 :=
begin
  ---- Go for the contrapositive and prove the easy direction
  rw [← not_iff_not, not_not, not_exists, iff.comm]; split,
  rintros rfl,
  suffices : ∀ x : ℕ, f^[x] 3 = 3,
    intros x; rw this; norm_num,
  intros x; induction x with x x_ih,
  rw [iterate_zero, id.def],
  rw [iterate_succ', comp_app, x_ih]; refl,

  ---- Reduce to a more general result
  revert n; suffices : ∀ {n c : ℤ},
    c ≠ 0 → n ≡ 3 [ZMOD 2 * c] → f n ≡ 3 [ZMOD 2 * c] → n ≡ 3 [ZMOD 2 * (2 * c)],
  { intros n h,
    suffices : ∀ x k : ℕ, (f^[k] n) ≡ 3 [ZMOD 2 ^ x],
    { obtain ⟨x, h0⟩ : ∃ x : ℕ, (n - 3).nat_abs < x :=
        ⟨(n - 3).nat_abs.succ, nat.lt_succ_self _⟩,
      replace this := (this x 0).symm,
      rw [iterate_zero, id.def, int.modeq_iff_dvd] at this,
      replace h0 := lt_trans h0 (nat.lt_two_pow x),
      rw [← int.coe_nat_lt, nat.cast_pow, nat.cast_two, ← int.abs_eq_nat_abs] at h0,
      rw ← sub_eq_zero; exact int.eq_zero_of_abs_lt_dvd this h0 },
    intros x; cases x with _ x,
    intros k; rw pow_zero; exact int.modeq_one,
    induction x with x h0; intros k,
    rw [pow_one, int.modeq_iff_dvd, ← even_iff_two_dvd, int.even_sub'],
    norm_num; exact h k,
    refine this (pow_ne_zero _ two_ne_zero) (h0 k) _,
    convert h0 k.succ; rw iterate_succ' },

  ---- Prove the general result
  intros n c hc h h0,
  replace h := h.symm,
  rw int.modeq_iff_dvd at h; cases h with d h,
  rw sub_eq_iff_eq_add at h; subst h,
  symmetry; rw [int.modeq_iff_dvd, add_sub_cancel, mul_comm],
  refine mul_dvd_mul_left (2 * c) _,
  unfold f at h0,
  replace h0 : 3 ≡ 3 * ((2 * c * d + 3) / 2) [ZMOD 2 * c] :=
    h0.symm.trans (int.modeq.mul_right _ (by rw [int.modeq_iff_dvd, add_sub_cancel]; use d)).symm,
  rw [int.modeq_iff_dvd, mul_assoc, add_comm, int.add_mul_div_left _ _ two_ne_zero] at h0,
  norm_num at h0,
  rwa [← mul_sub_one, add_sub_cancel', mul_comm c, ← mul_assoc, bit1,
       mul_dvd_mul_iff_right hc, add_one_mul, dvd_add_right ⟨d, rfl⟩] at h0
end

end IMO2015N1
end IMOSL


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import algebra.punit_instances
import linear_algebra.finsupp
import ring_theory.nilpotent
import ring_theory.localization.away
import ring_theory.ideal.prod
import ring_theory.ideal.over
import topology.sets.opens
import topology.sober

/-!
# Prime spectrum of a commutative ring

The prime spectrum of a commutative ring is the type of all prime ideals.
It is naturally endowed with a topology: the Zariski topology.

(It is also naturally endowed with a sheaf of rings,
which is constructed in `algebraic_geometry.structure_sheaf`.)

## Main definitions

* `prime_spectrum R`: The prime spectrum of a commutative ring `R`,
  i.e., the set of all prime ideals of `R`.
* `zero_locus s`: The zero locus of a subset `s` of `R`
  is the subset of `prime_spectrum R` consisting of all prime ideals that contain `s`.
* `vanishing_ideal t`: The vanishing ideal of a subset `t` of `prime_spectrum R`
  is the intersection of points in `t` (viewed as prime ideals).

## Conventions

We denote subsets of rings with `s`, `s'`, etc...
whereas we denote subsets of prime spectra with `t`, `t'`, etc...

## Inspiration/contributors

The contents of this file draw inspiration from
<https://github.com/ramonfmir/lean-scheme>
which has contributions from Ramon Fernandez Mir, Kevin Buzzard, Kenny Lau,
and Chris Hughes (on an earlier repository).

-/

noncomputable theory
open_locale classical

universes u v

variables (R : Type u) [comm_ring R]

/-- The prime spectrum of a commutative ring `R`
is the type of all prime ideals of `R`.

It is naturally endowed with a topology (the Zariski topology),
and a sheaf of commutative rings (see `algebraic_geometry.structure_sheaf`).
It is a fundamental building block in algebraic geometry. -/
@[nolint has_inhabited_instance]
def prime_spectrum := {I : ideal R // I.is_prime}

variable {R}

namespace prime_spectrum

/-- A method to view a point in the prime spectrum of a commutative ring
as an ideal of that ring. -/
abbreviation as_ideal (x : prime_spectrum R) : ideal R := x.val

instance is_prime (x : prime_spectrum R) :
  x.as_ideal.is_prime := x.2

/--
The prime spectrum of the zero ring is empty.
-/
lemma punit (x : prime_spectrum punit) : false :=
x.1.ne_top_iff_one.1 x.2.1 $ subsingleton.elim (0 : punit) 1 ▸ x.1.zero_mem

section
variables (R) (S : Type v) [comm_ring S]

/-- The prime spectrum of `R × S` is in bijection with the disjoint unions of the prime spectrum of
    `R` and the prime spectrum of `S`. -/
noncomputable def prime_spectrum_prod :
  prime_spectrum (R × S) ≃ prime_spectrum R ⊕ prime_spectrum S :=
ideal.prime_ideals_equiv R S

variables {R S}

@[simp] lemma prime_spectrum_prod_symm_inl_as_ideal (x : prime_spectrum R) :
  ((prime_spectrum_prod R S).symm (sum.inl x)).as_ideal = ideal.prod x.as_ideal ⊤ :=
by { cases x, refl }
@[simp] lemma prime_spectrum_prod_symm_inr_as_ideal (x : prime_spectrum S) :
  ((prime_spectrum_prod R S).symm (sum.inr x)).as_ideal = ideal.prod ⊤ x.as_ideal :=
by { cases x, refl }

end

@[ext] lemma ext {x y : prime_spectrum R} :
  x = y ↔ x.as_ideal = y.as_ideal :=
subtype.ext_iff_val

/-- The zero locus of a set `s` of elements of a commutative ring `R`
is the set of all prime ideals of the ring that contain the set `s`.

An element `f` of `R` can be thought of as a dependent function
on the prime spectrum of `R`.
At a point `x` (a prime ideal)
the function (i.e., element) `f` takes values in the quotient ring `R` modulo the prime ideal `x`.
In this manner, `zero_locus s` is exactly the subset of `prime_spectrum R`
where all "functions" in `s` vanish simultaneously.
-/
def zero_locus (s : set R) : set (prime_spectrum R) :=
{x | s ⊆ x.as_ideal}

@[simp] lemma mem_zero_locus (x : prime_spectrum R) (s : set R) :
  x ∈ zero_locus s ↔ s ⊆ x.as_ideal := iff.rfl

@[simp] lemma zero_locus_span (s : set R) :
  zero_locus (ideal.span s : set R) = zero_locus s :=
by { ext x, exact (submodule.gi R R).gc s x.as_ideal }

/-- The vanishing ideal of a set `t` of points
of the prime spectrum of a commutative ring `R`
is the intersection of all the prime ideals in the set `t`.

An element `f` of `R` can be thought of as a dependent function
on the prime spectrum of `R`.
At a point `x` (a prime ideal)
the function (i.e., element) `f` takes values in the quotient ring `R` modulo the prime ideal `x`.
In this manner, `vanishing_ideal t` is exactly the ideal of `R`
consisting of all "functions" that vanish on all of `t`.
-/
def vanishing_ideal (t : set (prime_spectrum R)) : ideal R :=
⨅ (x : prime_spectrum R) (h : x ∈ t), x.as_ideal

lemma coe_vanishing_ideal (t : set (prime_spectrum R)) :
  (vanishing_ideal t : set R) = {f : R | ∀ x : prime_spectrum R, x ∈ t → f ∈ x.as_ideal} :=
begin
  ext f,
  rw [vanishing_ideal, set_like.mem_coe, submodule.mem_infi],
  apply forall_congr, intro x,
  rw [submodule.mem_infi],
end

lemma mem_vanishing_ideal (t : set (prime_spectrum R)) (f : R) :
  f ∈ vanishing_ideal t ↔ ∀ x : prime_spectrum R, x ∈ t → f ∈ x.as_ideal :=
by rw [← set_like.mem_coe, coe_vanishing_ideal, set.mem_set_of_eq]

@[simp] lemma vanishing_ideal_singleton (x : prime_spectrum R) :
  vanishing_ideal ({x} : set (prime_spectrum R)) = x.as_ideal :=
by simp [vanishing_ideal]

lemma subset_zero_locus_iff_le_vanishing_ideal (t : set (prime_spectrum R)) (I : ideal R) :
  t ⊆ zero_locus I ↔ I ≤ vanishing_ideal t :=
⟨λ h f k, (mem_vanishing_ideal _ _).mpr (λ x j, (mem_zero_locus _ _).mpr (h j) k), λ h,
  λ x j, (mem_zero_locus _ _).mpr (le_trans h (λ f h, ((mem_vanishing_ideal _ _).mp h) x j))⟩

section gc
variable (R)

/-- `zero_locus` and `vanishing_ideal` form a galois connection. -/
lemma gc : @galois_connection
  (ideal R) (order_dual (set (prime_spectrum R))) _ _
  (λ I, zero_locus I) (λ t, vanishing_ideal t) :=
λ I t, subset_zero_locus_iff_le_vanishing_ideal t I

/-- `zero_locus` and `vanishing_ideal` form a galois connection. -/
lemma gc_set : @galois_connection
  (set R) (order_dual (set (prime_spectrum R))) _ _
  (λ s, zero_locus s) (λ t, vanishing_ideal t) :=
have ideal_gc : galois_connection (ideal.span) coe := (submodule.gi R R).gc,
by simpa [zero_locus_span, function.comp] using ideal_gc.compose (gc R)

lemma subset_zero_locus_iff_subset_vanishing_ideal (t : set (prime_spectrum R)) (s : set R) :
  t ⊆ zero_locus s ↔ s ⊆ vanishing_ideal t :=
(gc_set R) s t

end gc

lemma subset_vanishing_ideal_zero_locus (s : set R) :
  s ⊆ vanishing_ideal (zero_locus s) :=
(gc_set R).le_u_l s

lemma le_vanishing_ideal_zero_locus (I : ideal R) :
  I ≤ vanishing_ideal (zero_locus I) :=
(gc R).le_u_l I

@[simp] lemma vanishing_ideal_zero_locus_eq_radical (I : ideal R) :
  vanishing_ideal (zero_locus (I : set R)) = I.radical := ideal.ext $ λ f,
begin
  rw [mem_vanishing_ideal, ideal.radical_eq_Inf, submodule.mem_Inf],
  exact ⟨(λ h x hx, h ⟨x, hx.2⟩ hx.1), (λ h x hx, h x.1 ⟨hx, x.2⟩)⟩
end

@[simp] lemma zero_locus_radical (I : ideal R) : zero_locus (I.radical : set R) = zero_locus I :=
vanishing_ideal_zero_locus_eq_radical I ▸ (gc R).l_u_l_eq_l I

lemma subset_zero_locus_vanishing_ideal (t : set (prime_spectrum R)) :
  t ⊆ zero_locus (vanishing_ideal t) :=
(gc R).l_u_le t

lemma zero_locus_anti_mono {s t : set R} (h : s ⊆ t) : zero_locus t ⊆ zero_locus s :=
(gc_set R).monotone_l h

lemma zero_locus_anti_mono_ideal {s t : ideal R} (h : s ≤ t) :
  zero_locus (t : set R) ⊆ zero_locus (s : set R) :=
(gc R).monotone_l h

lemma vanishing_ideal_anti_mono {s t : set (prime_spectrum R)} (h : s ⊆ t) :
  vanishing_ideal t ≤ vanishing_ideal s :=
(gc R).monotone_u h

lemma zero_locus_subset_zero_locus_iff (I J : ideal R) :
  zero_locus (I : set R) ⊆ zero_locus (J : set R) ↔ J ≤ I.radical :=
⟨λ h, ideal.radical_le_radical_iff.mp (vanishing_ideal_zero_locus_eq_radical I ▸
  vanishing_ideal_zero_locus_eq_radical J ▸ vanishing_ideal_anti_mono h),
λ h, zero_locus_radical I ▸ zero_locus_anti_mono_ideal h⟩

lemma zero_locus_subset_zero_locus_singleton_iff (f g : R) :
  zero_locus ({f} : set R) ⊆ zero_locus {g} ↔ g ∈ (ideal.span ({f} : set R)).radical :=
by rw [← zero_locus_span {f}, ← zero_locus_span {g}, zero_locus_subset_zero_locus_iff,
    ideal.span_le, set.singleton_subset_iff, set_like.mem_coe]

lemma zero_locus_bot :
  zero_locus ((⊥ : ideal R) : set R) = set.univ :=
(gc R).l_bot

@[simp] lemma zero_locus_singleton_zero :
  zero_locus ({0} : set R) = set.univ :=
zero_locus_bot

@[simp] lemma zero_locus_empty :
  zero_locus (∅ : set R) = set.univ :=
(gc_set R).l_bot

@[simp] lemma vanishing_ideal_univ :
  vanishing_ideal (∅ : set (prime_spectrum R)) = ⊤ :=
by simpa using (gc R).u_top

lemma zero_locus_empty_of_one_mem {s : set R} (h : (1:R) ∈ s) :
  zero_locus s = ∅ :=
begin
  rw set.eq_empty_iff_forall_not_mem,
  intros x hx,
  rw mem_zero_locus at hx,
  have x_prime : x.as_ideal.is_prime := by apply_instance,
  have eq_top : x.as_ideal = ⊤, { rw ideal.eq_top_iff_one, exact hx h },
  apply x_prime.ne_top eq_top,
end

@[simp] lemma zero_locus_singleton_one :
  zero_locus ({1} : set R) = ∅ :=
zero_locus_empty_of_one_mem (set.mem_singleton (1 : R))

lemma zero_locus_empty_iff_eq_top {I : ideal R} :
  zero_locus (I : set R) = ∅ ↔ I = ⊤ :=
begin
  split,
  { contrapose!,
    intro h,
    apply set.ne_empty_iff_nonempty.mpr,
    rcases ideal.exists_le_maximal I h with ⟨M, hM, hIM⟩,
    exact ⟨⟨M, hM.is_prime⟩, hIM⟩ },
  { rintro rfl, apply zero_locus_empty_of_one_mem, trivial }
end

@[simp] lemma zero_locus_univ :
  zero_locus (set.univ : set R) = ∅ :=
zero_locus_empty_of_one_mem (set.mem_univ 1)

lemma zero_locus_sup (I J : ideal R) :
  zero_locus ((I ⊔ J : ideal R) : set R) = zero_locus I ∩ zero_locus J :=
(gc R).l_sup

lemma zero_locus_union (s s' : set R) :
  zero_locus (s ∪ s') = zero_locus s ∩ zero_locus s' :=
(gc_set R).l_sup

lemma vanishing_ideal_union (t t' : set (prime_spectrum R)) :
  vanishing_ideal (t ∪ t') = vanishing_ideal t ⊓ vanishing_ideal t' :=
(gc R).u_inf

lemma zero_locus_supr {ι : Sort*} (I : ι → ideal R) :
  zero_locus ((⨆ i, I i : ideal R) : set R) = (⋂ i, zero_locus (I i)) :=
(gc R).l_supr

lemma zero_locus_Union {ι : Sort*} (s : ι → set R) :
  zero_locus (⋃ i, s i) = (⋂ i, zero_locus (s i)) :=
(gc_set R).l_supr

lemma zero_locus_bUnion (s : set (set R)) :
  zero_locus (⋃ s' ∈ s, s' : set R) = ⋂ s' ∈ s, zero_locus s' :=
by simp only [zero_locus_Union]

lemma vanishing_ideal_Union {ι : Sort*} (t : ι → set (prime_spectrum R)) :
  vanishing_ideal (⋃ i, t i) = (⨅ i, vanishing_ideal (t i)) :=
(gc R).u_infi

lemma zero_locus_inf (I J : ideal R) :
  zero_locus ((I ⊓ J : ideal R) : set R) = zero_locus I ∪ zero_locus J :=
set.ext $ λ x, by simpa using x.2.inf_le

lemma union_zero_locus (s s' : set R) :
  zero_locus s ∪ zero_locus s' = zero_locus ((ideal.span s) ⊓ (ideal.span s') : ideal R) :=
by { rw zero_locus_inf, simp }

lemma zero_locus_mul (I J : ideal R) :
  zero_locus ((I * J : ideal R) : set R) = zero_locus I ∪ zero_locus J :=
set.ext $ λ x, by simpa using x.2.mul_le

lemma zero_locus_singleton_mul (f g : R) :
  zero_locus ({f * g} : set R) = zero_locus {f} ∪ zero_locus {g} :=
set.ext $ λ x, by simpa using x.2.mul_mem_iff_mem_or_mem

@[simp] lemma zero_locus_pow (I : ideal R) {n : ℕ} (hn : 0 < n) :
  zero_locus ((I ^ n : ideal R) : set R) = zero_locus I :=
zero_locus_radical (I ^ n) ▸ (I.radical_pow n hn).symm ▸ zero_locus_radical I

@[simp] lemma zero_locus_singleton_pow (f : R) (n : ℕ) (hn : 0 < n) :
  zero_locus ({f ^ n} : set R) = zero_locus {f} :=
set.ext $ λ x, by simpa using x.2.pow_mem_iff_mem n hn

lemma sup_vanishing_ideal_le (t t' : set (prime_spectrum R)) :
  vanishing_ideal t ⊔ vanishing_ideal t' ≤ vanishing_ideal (t ∩ t') :=
begin
  intros r,
  rw [submodule.mem_sup, mem_vanishing_ideal],
  rintro ⟨f, hf, g, hg, rfl⟩ x ⟨hxt, hxt'⟩,
  rw mem_vanishing_ideal at hf hg,
  apply submodule.add_mem; solve_by_elim
end

lemma mem_compl_zero_locus_iff_not_mem {f : R} {I : prime_spectrum R} :
  I ∈ (zero_locus {f} : set (prime_spectrum R))ᶜ ↔ f ∉ I.as_ideal :=
by rw [set.mem_compl_eq, mem_zero_locus, set.singleton_subset_iff]; refl

/-- The Zariski topology on the prime spectrum of a commutative ring
is defined via the closed sets of the topology:
they are exactly those sets that are the zero locus of a subset of the ring. -/
instance zariski_topology : topological_space (prime_spectrum R) :=
topological_space.of_closed (set.range prime_spectrum.zero_locus)
  (⟨set.univ, by simp⟩)
  begin
    intros Zs h,
    rw set.sInter_eq_Inter,
    let f : Zs → set R := λ i, classical.some (h i.2),
    have hf : ∀ i : Zs, ↑i = zero_locus (f i) := λ i, (classical.some_spec (h i.2)).symm,
    simp only [hf],
    exact ⟨_, zero_locus_Union _⟩
  end
  (by { rintro _ ⟨s, rfl⟩ _ ⟨t, rfl⟩, exact ⟨_, (union_zero_locus s t).symm⟩ })

lemma is_open_iff (U : set (prime_spectrum R)) :
  is_open U ↔ ∃ s, Uᶜ = zero_locus s :=
by simp only [@eq_comm _ Uᶜ]; refl

lemma is_closed_iff_zero_locus (Z : set (prime_spectrum R)) :
  is_closed Z ↔ ∃ s, Z = zero_locus s :=
by rw [← is_open_compl_iff, is_open_iff, compl_compl]

lemma is_closed_iff_zero_locus_ideal (Z : set (prime_spectrum R)) :
  is_closed Z ↔ ∃ (s : ideal R), Z = zero_locus s :=
(is_closed_iff_zero_locus _).trans
  ⟨λ x, ⟨_, x.some_spec.trans (zero_locus_span _).symm⟩, λ x, ⟨_, x.some_spec⟩⟩

lemma is_closed_iff_zero_locus_radical_ideal (Z : set (prime_spectrum R)) :
  is_closed Z ↔ ∃ (s : ideal R), s.radical = s ∧ Z = zero_locus s :=
(is_closed_iff_zero_locus_ideal _).trans
  ⟨λ x, ⟨_, ideal.radical_idem _, x.some_spec.trans (zero_locus_radical _).symm⟩,
    λ x, ⟨_, x.some_spec.2⟩⟩

lemma is_closed_zero_locus (s : set R) :
  is_closed (zero_locus s) :=
by { rw [is_closed_iff_zero_locus], exact ⟨s, rfl⟩ }

lemma is_closed_singleton_iff_is_maximal (x : prime_spectrum R) :
  is_closed ({x} : set (prime_spectrum R)) ↔ x.as_ideal.is_maximal :=
begin
  refine (is_closed_iff_zero_locus _).trans ⟨λ h, _, λ h, _⟩,
  { obtain ⟨s, hs⟩ := h,
    rw [eq_comm, set.eq_singleton_iff_unique_mem] at hs,
    refine ⟨⟨x.2.1, λ I hI, not_not.1 (mt (ideal.exists_le_maximal I) $
      not_exists.2 (λ J, not_and.2 $ λ hJ hIJ,_))⟩⟩,
    exact ne_of_lt (lt_of_lt_of_le hI hIJ) (symm $ congr_arg prime_spectrum.as_ideal
      (hs.2 ⟨J, hJ.is_prime⟩ (λ r hr, hIJ (le_of_lt hI $ hs.1 hr)))) },
  { refine ⟨x.as_ideal.1, _⟩,
    rw [eq_comm, set.eq_singleton_iff_unique_mem],
    refine ⟨λ _ h, h, λ y hy, prime_spectrum.ext.2 (h.eq_of_le y.2.ne_top hy).symm⟩ }
end

lemma zero_locus_vanishing_ideal_eq_closure (t : set (prime_spectrum R)) :
  zero_locus (vanishing_ideal t : set R) = closure t :=
begin
  apply set.subset.antisymm,
  { rintro x hx t' ⟨ht', ht⟩,
    obtain ⟨fs, rfl⟩ : ∃ s, t' = zero_locus s,
    by rwa [is_closed_iff_zero_locus] at ht',
    rw [subset_zero_locus_iff_subset_vanishing_ideal] at ht,
    exact set.subset.trans ht hx },
  { rw (is_closed_zero_locus _).closure_subset_iff,
    exact subset_zero_locus_vanishing_ideal t }
end

lemma vanishing_ideal_closure (t : set (prime_spectrum R)) :
  vanishing_ideal (closure t) = vanishing_ideal t :=
zero_locus_vanishing_ideal_eq_closure t ▸ (gc R).u_l_u_eq_u t

lemma t1_space_iff_is_field [is_domain R] :
  t1_space (prime_spectrum R) ↔ is_field R :=
begin
  refine ⟨_, λ h, _⟩,
  { introI h,
    have hbot : ideal.is_prime (⊥ : ideal R) := ideal.bot_prime,
    exact not_not.1 (mt (ring.ne_bot_of_is_maximal_of_not_is_field $
      (is_closed_singleton_iff_is_maximal _).1 (t1_space.t1 ⟨⊥, hbot⟩)) (not_not.2 rfl)) },
  { refine ⟨λ x, (is_closed_singleton_iff_is_maximal x).2 _⟩,
    by_cases hx : x.as_ideal = ⊥,
    { exact hx.symm ▸ @ideal.bot_is_maximal R (@field.to_division_ring _ h.to_field) },
    { exact absurd h (ring.not_is_field_iff_exists_prime.2 ⟨x.as_ideal, ⟨hx, x.2⟩⟩) } }
end

local notation `Z(` a `)` := zero_locus (a : set R)

lemma is_irreducible_zero_locus_iff (I : ideal R) :
  is_irreducible (zero_locus (I : set R)) ↔ I.radical.is_prime :=
(zero_locus_radical I) ▸ is_irreducible_zero_locus_iff_of_radical _ I.radical_idem

instance [is_domain R] : irreducible_space (prime_spectrum R) :=
begin
  rw [irreducible_space_def, set.top_eq_univ, ← zero_locus_bot, is_irreducible_zero_locus_iff],
  simpa using ideal.bot_prime
end

instance : quasi_sober (prime_spectrum R) :=
begin
  constructor,
  intros S h₁ h₂,
  rw [← h₂.closure_eq, ← zero_locus_vanishing_ideal_eq_closure,
    is_irreducible_zero_locus_iff] at h₁,
  use ⟨_, h₁⟩,
  obtain ⟨s, hs, rfl⟩ := (is_closed_iff_zero_locus_radical_ideal _).mp h₂,
  rw is_generic_point_iff_forall_closed h₂,
  intros Z hZ hxZ,
  obtain ⟨t, rfl⟩ := (is_closed_iff_zero_locus_ideal _).mp hZ,
  exact zero_locus_anti_mono (by simpa [hs] using hxZ),
  simp [hs]
end

section comap
variables {S : Type v} [comm_ring S] {S' : Type*} [comm_ring S']

lemma preimage_comap_zero_locus_aux (f : R →+* S) (s : set R) :
  (λ y, ⟨ideal.comap f y.as_ideal, infer_instance⟩ :
    prime_spectrum S → prime_spectrum R) ⁻¹' (zero_locus s) = zero_locus (f '' s) :=
begin
  ext x,
  simp only [mem_zero_locus, set.image_subset_iff],
  refl
end

/-- The function between prime spectra of commutative rings induced by a ring homomorphism.
This function is continuous. -/
def comap (f : R →+* S) : C(prime_spectrum S, prime_spectrum R) :=
{ to_fun := λ y, ⟨ideal.comap f y.as_ideal, infer_instance⟩,
  continuous_to_fun :=
    begin
      simp only [continuous_iff_is_closed, is_closed_iff_zero_locus],
      rintro _ ⟨s, rfl⟩,
      exact ⟨_, preimage_comap_zero_locus_aux f s⟩
    end }

variables (f : R →+* S)

@[simp] lemma comap_as_ideal (y : prime_spectrum S) :
  (comap f y).as_ideal = ideal.comap f y.as_ideal :=
rfl

@[simp] lemma comap_id : comap (ring_hom.id R) = continuous_map.id _ := by { ext, refl }

@[simp] lemma comap_comp (f : R →+* S) (g : S →+* S') :
  comap (g.comp f) = (comap f).comp (comap g) :=
rfl

lemma comap_comp_apply (f : R →+* S) (g : S →+* S') (x : prime_spectrum S') :
  prime_spectrum.comap (g.comp f) x = (prime_spectrum.comap f) (prime_spectrum.comap g x) :=
rfl

@[simp] lemma preimage_comap_zero_locus (s : set R) :
  (comap f) ⁻¹' (zero_locus s) = zero_locus (f '' s) :=
preimage_comap_zero_locus_aux f s

lemma comap_injective_of_surjective (f : R →+* S) (hf : function.surjective f) :
  function.injective (comap f) :=
λ x y h, prime_spectrum.ext.2 (ideal.comap_injective_of_surjective f hf
  (congr_arg prime_spectrum.as_ideal h : (comap f x).as_ideal = (comap f y).as_ideal))

lemma comap_singleton_is_closed_of_surjective (f : R →+* S) (hf : function.surjective f)
  (x : prime_spectrum S) (hx : is_closed ({x} : set (prime_spectrum S))) :
  is_closed ({comap f x} : set (prime_spectrum R)) :=
begin
  haveI : x.as_ideal.is_maximal := (is_closed_singleton_iff_is_maximal x).1 hx,
  exact (is_closed_singleton_iff_is_maximal _).2 (ideal.comap_is_maximal_of_surjective f hf)
end

lemma comap_singleton_is_closed_of_is_integral (f : R →+* S) (hf : f.is_integral)
  (x : prime_spectrum S) (hx : is_closed ({x} : set (prime_spectrum S))) :
  is_closed ({comap f x} : set (prime_spectrum R)) :=
(is_closed_singleton_iff_is_maximal _).2 (ideal.is_maximal_comap_of_is_integral_of_is_maximal'
  f hf x.as_ideal $ (is_closed_singleton_iff_is_maximal x).1 hx)

variable S

lemma localization_comap_inducing [algebra R S] (M : submonoid R)
  [is_localization M S] : inducing (comap (algebra_map R S)) :=
begin
  constructor,
  rw topological_space_eq_iff,
  intro U,
  simp_rw ← is_closed_compl_iff,
  generalize : Uᶜ = Z,
  simp_rw [is_closed_induced_iff, is_closed_iff_zero_locus],
  split,
  { rintro ⟨s, rfl⟩,
    refine ⟨_,⟨(algebra_map R S) ⁻¹' (ideal.span s),rfl⟩,_⟩,
    rw [preimage_comap_zero_locus, ← zero_locus_span, ← zero_locus_span s],
    congr' 1,
    exact congr_arg submodule.carrier (is_localization.map_comap M S (ideal.span s)) },
  { rintro ⟨_, ⟨t, rfl⟩, rfl⟩, simp }
end

lemma localization_comap_injective [algebra R S] (M : submonoid R)
  [is_localization M S] : function.injective (comap (algebra_map R S)) :=
begin
  intros p q h,
  replace h := congr_arg (λ (x : prime_spectrum R), ideal.map (algebra_map R S) x.as_ideal) h,
  dsimp only at h,
  erw [is_localization.map_comap M S, is_localization.map_comap M S] at h,
  ext1,
  exact h
end

lemma localization_comap_embedding [algebra R S] (M : submonoid R)
  [is_localization M S] : embedding (comap (algebra_map R S)) :=
⟨localization_comap_inducing S M, localization_comap_injective S M⟩

lemma localization_comap_range [algebra R S] (M : submonoid R)
  [is_localization M S] :
  set.range (comap (algebra_map R S)) = { p | disjoint (M : set R) p.as_ideal } :=
begin
  ext x,
  split,
  { rintro ⟨p, rfl⟩ x ⟨hx₁, hx₂⟩,
    exact (p.2.1 : ¬ _)
      (p.as_ideal.eq_top_of_is_unit_mem hx₂ (is_localization.map_units S ⟨x, hx₁⟩)) },
  { intro h,
    use ⟨x.as_ideal.map (algebra_map R S),
      is_localization.is_prime_of_is_prime_disjoint M S _ x.2 h⟩,
    ext1,
    exact is_localization.comap_map_of_is_prime_disjoint M S _ x.2 h }
end

end comap

section basic_open

/-- `basic_open r` is the open subset containing all prime ideals not containing `r`. -/
def basic_open (r : R) : topological_space.opens (prime_spectrum R) :=
{ val := { x | r ∉ x.as_ideal },
  property := ⟨{r}, set.ext $ λ x, set.singleton_subset_iff.trans $ not_not.symm⟩ }

@[simp] lemma mem_basic_open (f : R) (x : prime_spectrum R) :
  x ∈ basic_open f ↔ f ∉ x.as_ideal := iff.rfl

lemma is_open_basic_open {a : R} : is_open ((basic_open a) : set (prime_spectrum R)) :=
(basic_open a).property

@[simp] lemma basic_open_eq_zero_locus_compl (r : R) :
  (basic_open r : set (prime_spectrum R)) = (zero_locus {r})ᶜ :=
set.ext $ λ x, by simpa only [set.mem_compl_eq, mem_zero_locus, set.singleton_subset_iff]

@[simp] lemma basic_open_one : basic_open (1 : R) = ⊤ :=
topological_space.opens.ext $ by simp

@[simp] lemma basic_open_zero : basic_open (0 : R) = ⊥ :=
topological_space.opens.ext $ by simp

lemma basic_open_le_basic_open_iff (f g : R) :
  basic_open f ≤ basic_open g ↔ f ∈ (ideal.span ({g} : set R)).radical :=
by rw [topological_space.opens.le_def, basic_open_eq_zero_locus_compl,
    basic_open_eq_zero_locus_compl, set.le_eq_subset, set.compl_subset_compl,
    zero_locus_subset_zero_locus_singleton_iff]

lemma basic_open_mul (f g : R) : basic_open (f * g) = basic_open f ⊓ basic_open g :=
topological_space.opens.ext $ by {simp [zero_locus_singleton_mul]}

lemma basic_open_mul_le_left (f g : R) : basic_open (f * g) ≤ basic_open f :=
by { rw basic_open_mul f g, exact inf_le_left }

lemma basic_open_mul_le_right (f g : R) : basic_open (f * g) ≤ basic_open g :=
by { rw basic_open_mul f g, exact inf_le_right }

@[simp] lemma basic_open_pow (f : R) (n : ℕ) (hn : 0 < n) : basic_open (f ^ n) = basic_open f :=
topological_space.opens.ext $ by simpa using zero_locus_singleton_pow f n hn

lemma is_topological_basis_basic_opens : topological_space.is_topological_basis
  (set.range (λ (r : R), (basic_open r : set (prime_spectrum R)))) :=
begin
  apply topological_space.is_topological_basis_of_open_of_nhds,
  { rintros _ ⟨r, rfl⟩,
    exact is_open_basic_open },
  { rintros p U hp ⟨s, hs⟩,
    rw [← compl_compl U, set.mem_compl_eq, ← hs, mem_zero_locus, set.not_subset] at hp,
    obtain ⟨f, hfs, hfp⟩ := hp,
    refine ⟨basic_open f, ⟨f, rfl⟩, hfp, _⟩,
    rw [← set.compl_subset_compl, ← hs, basic_open_eq_zero_locus_compl, compl_compl],
    exact zero_locus_anti_mono (set.singleton_subset_iff.mpr hfs) }
end

lemma is_basis_basic_opens :
  topological_space.opens.is_basis (set.range (@basic_open R _)) :=
begin
  unfold topological_space.opens.is_basis,
  convert is_topological_basis_basic_opens,
  rw ← set.range_comp,
end

lemma is_compact_basic_open (f : R) : is_compact (basic_open f : set (prime_spectrum R)) :=
is_compact_of_finite_subfamily_closed $ λ ι Z hZc hZ,
begin
  let I : ι → ideal R := λ i, vanishing_ideal (Z i),
  have hI : ∀ i, Z i = zero_locus (I i) := λ i,
    by simpa only [zero_locus_vanishing_ideal_eq_closure] using (hZc i).closure_eq.symm,
  rw [basic_open_eq_zero_locus_compl f, set.inter_comm, ← set.diff_eq,
      set.diff_eq_empty, funext hI, ← zero_locus_supr] at hZ,
  obtain ⟨n, hn⟩ : f ∈ (⨆ (i : ι), I i).radical,
  { rw ← vanishing_ideal_zero_locus_eq_radical,
    apply vanishing_ideal_anti_mono hZ,
    exact (subset_vanishing_ideal_zero_locus {f} (set.mem_singleton f)) },
  rcases submodule.exists_finset_of_mem_supr I hn with ⟨s, hs⟩,
  use s,
  -- Using simp_rw here, because `hI` and `zero_locus_supr` need to be applied underneath binders
  simp_rw [basic_open_eq_zero_locus_compl f, set.inter_comm, ← set.diff_eq,
           set.diff_eq_empty, hI, ← zero_locus_supr],
  rw ← zero_locus_radical, -- this one can't be in `simp_rw` because it would loop
  apply zero_locus_anti_mono,
  rw set.singleton_subset_iff,
  exact ⟨n, hs⟩
end

@[simp]
lemma basic_open_eq_bot_iff (f : R) :
  basic_open f = ⊥ ↔ is_nilpotent f :=
begin
  rw [← subtype.coe_injective.eq_iff, basic_open_eq_zero_locus_compl],
  simp only [set.eq_univ_iff_forall, topological_space.opens.empty_eq, set.singleton_subset_iff,
    topological_space.opens.coe_bot, nilpotent_iff_mem_prime, set.compl_empty_iff, mem_zero_locus,
    set_like.mem_coe],
  exact subtype.forall,
end

lemma localization_away_comap_range (S : Type v) [comm_ring S] [algebra R S] (r : R)
  [is_localization.away r S] : set.range (comap (algebra_map R S)) = basic_open r :=
begin
  rw localization_comap_range S (submonoid.powers r),
  ext,
  simp only [mem_zero_locus, basic_open_eq_zero_locus_compl, set_like.mem_coe, set.mem_set_of_eq,
    set.singleton_subset_iff, set.mem_compl_eq],
  split,
  { intros h₁ h₂,
    exact h₁ ⟨submonoid.mem_powers r, h₂⟩ },
  { rintros h₁ _ ⟨⟨n, rfl⟩, h₃⟩,
    exact h₁ (x.2.mem_of_pow_mem _ h₃) },
end

lemma localization_away_open_embedding (S : Type v) [comm_ring S] [algebra R S] (r : R)
  [is_localization.away r S] : open_embedding (comap (algebra_map R S)) :=
{ to_embedding := localization_comap_embedding S (submonoid.powers r),
  open_range := by { rw localization_away_comap_range S r, exact is_open_basic_open } }

end basic_open

/-- The prime spectrum of a commutative ring is a compact topological space. -/
instance : compact_space (prime_spectrum R) :=
{ compact_univ := by { convert is_compact_basic_open (1 : R), rw basic_open_one, refl } }

section order

/-!
## The specialization order

We endow `prime_spectrum R` with a partial order,
where `x ≤ y` if and only if `y ∈ closure {x}`.
-/

instance : partial_order (prime_spectrum R) :=
subtype.partial_order _

@[simp] lemma as_ideal_le_as_ideal (x y : prime_spectrum R) :
  x.as_ideal ≤ y.as_ideal ↔ x ≤ y :=
subtype.coe_le_coe

@[simp] lemma as_ideal_lt_as_ideal (x y : prime_spectrum R) :
  x.as_ideal < y.as_ideal ↔ x < y :=
subtype.coe_lt_coe

lemma le_iff_mem_closure (x y : prime_spectrum R) :
  x ≤ y ↔ y ∈ closure ({x} : set (prime_spectrum R)) :=
by rw [← as_ideal_le_as_ideal, ← zero_locus_vanishing_ideal_eq_closure,
    mem_zero_locus, vanishing_ideal_singleton, set_like.coe_subset_coe]

lemma le_iff_specializes (x y : prime_spectrum R) :
  x ≤ y ↔ x ⤳ y :=
le_iff_mem_closure x y

instance : t0_space (prime_spectrum R) :=
by { simp [t0_space_iff_or_not_mem_closure, ← le_iff_mem_closure,
  ← not_and_distrib, ← le_antisymm_iff, eq_comm] }

end order

/-- If `x` specializes to `y`, then there is a natural map from the localization of `y` to
the localization of `x`. -/
def localization_map_of_specializes {x y : prime_spectrum R} (h : x ⤳ y) :
  localization.at_prime y.as_ideal →+* localization.at_prime x.as_ideal :=
@is_localization.lift _ _ _ _ _ _ _ _
  localization.is_localization (algebra_map R (localization.at_prime x.as_ideal))
  begin
    rintro ⟨a, ha⟩,
    rw [← prime_spectrum.le_iff_specializes, ← as_ideal_le_as_ideal, ← set_like.coe_subset_coe,
      ← set.compl_subset_compl] at h,
    exact (is_localization.map_units _ ⟨a, (show a ∈ x.as_ideal.prime_compl, from h ha)⟩ : _)
  end

end prime_spectrum

namespace local_ring

variables (R) [local_ring R]

/--
The closed point in the prime spectrum of a local ring.
-/
def closed_point : prime_spectrum R :=
⟨maximal_ideal R, (maximal_ideal.is_maximal R).is_prime⟩

variable {R}

lemma is_local_ring_hom_iff_comap_closed_point {S : Type v} [comm_ring S] [local_ring S]
  (f : R →+* S) : is_local_ring_hom f ↔ prime_spectrum.comap f (closed_point S) = closed_point R :=
by { rw [(local_hom_tfae f).out 0 4, subtype.ext_iff], refl }

@[simp] lemma comap_closed_point {S : Type v} [comm_ring S] [local_ring S] (f : R →+* S)
  [is_local_ring_hom f] : prime_spectrum.comap f (closed_point S) = closed_point R :=
(is_local_ring_hom_iff_comap_closed_point f).mp infer_instance

end local_ring