/-
Copyright (c) 2022 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/

-- Ported from mathlib3, file src/data/list/basic.lean,
-- commit a945b3769cb82bc238ee004b4327201a6864e7e0

import Aesop

set_option aesop.check.script true

-- We use this constant to 'prove' theorems which Aesop can't solve. We don't
-- use `sorry` because it generates lots of warnings.
axiom ADMIT : ∀ {α : Sort _}, α

@[aesop safe cases]
class IsEmpty (α : Sort _) where
  false : α → False

@[aesop safe forward]
def IsEmpty.false' (h : IsEmpty α) (a : α) : False :=
  h.false a

@[aesop safe constructors]
structure Unique (α : Sort _) extends Inhabited α where
  uniq : ∀ a : α, a = toInhabited.default

class IsLeftId (α : Type _) (op : α → α → α) (o : outParam α) : Prop where
  leftId : ∀ a, op o a = a

def Injective (f : α → β) : Prop :=
  ∀ x y, f x = f y → x = y

@[aesop safe forward]
theorem injective_elim (h₁ : Injective f) (h₂ : f a = f b) : a = b :=
  h₁ _ _ h₂

@[aesop 99%]
theorem injective_intro (h : ∀ a b, f a = f b → a = b) : Injective f :=
  h

def Surjective (f : α → β) : Prop :=
  ∀ b, ∃ a, f a = b

@[aesop norm (forward (immediate := [h]))]
theorem surjective_elim (h : Surjective f) : ∀ b, ∃ a, f a = b :=
  h

@[aesop 99%]
theorem surjective_intro (h : ∀ b, ∃ a, f a = b) : Surjective f :=
  h

@[aesop norm unfold]
def Bijective (f : α → β) : Prop :=
  Injective f ∧ Surjective f

def Involutive (f : α → α) : Prop :=
  ∀ x, f (f x) = x

@[aesop norm forward]
theorem involutive_elim {f : α → α} (h : Involutive f) (a : α) : f (f a) = a :=
  h a

@[aesop 99%]
theorem involutive_intro (h : ∀ a, f (f a) = a) : Involutive f :=
  h

@[aesop 25%]
theorem Involutive.injective : Involutive f → Injective f :=
  λ h x y hxy => by rw [← h x, ← h y, hxy]

@[aesop 25%]
theorem Involutive.surjective : Involutive f → Surjective f :=
  λ h x => ⟨f x, h x⟩

theorem Involutive.bijective (h : Involutive f) : Bijective f :=
  ⟨h.injective, h.surjective⟩

namespace Option

@[aesop safe [constructors, cases]]
inductive Mem (a : α) : Option α → Prop
  | some : Mem a (some a)

instance : Membership α (Option α) :=
  ⟨Option.Mem⟩

@[simp]
theorem mem_spec {o : Option α} : a ∈ o ↔ o = some a := by
  aesop (add norm simp Membership.mem)

@[simp]
theorem mem_none : a ∈ none ↔ False := by
  aesop

@[simp]
theorem mem_some : a ∈ some b ↔ a = b := by
  aesop

@[simp]
def iget [Inhabited α] : Option α → α
  | none => default
  | some a => a

end Option

namespace List

attribute [simp] map List.bind

instance : Pure List where
  pure x := [x]

def init : List α → List α
  | [] => []
  | [_] => []
  | a :: as => a :: init as

@[simp]
def last : (l : List α) → l ≠ [] → α
  | [], h => nomatch h
  | [a], _ => a
  | _ :: a :: as, _ => last (a :: as) (by aesop)

-- The unnecessarily complicated case split in this definition is inherited from
-- Lean 3.
@[simp]
def ilast [Inhabited α] : List α → α
  | [] => default
  | [a] => a
  | [_, b] => b
  | _ :: _ :: l => ilast l

@[simp]
def head' : List α → Option α
  | [] => none
  | a :: _ => some a

@[simp]
def ihead [Inhabited α] : List α → α
  | [] => default
  | a :: _ => a

@[simp]
def nth_le : ∀ (l : List α) (n), n < l.length → α
  | [],       n,     h => absurd h n.not_lt_zero
  | (a :: _), 0,     _ => a
  | (_ :: l), (n+1), h => nth_le l n (by simp_all_arith)

@[simp]
def modify_head (f : α → α) : List α → List α
  | [] => []
  | (a :: as) => f a :: as

@[simp]
def Empty : List α → Prop
  | [] => True
  | _ :: _ => False

@[simp] theorem mem_eq_mem : Mem x xs ↔ x ∈ xs := Iff.rfl

theorem subset_trans {l₁ l₂ l₃ : List α} : l₁ ⊆ l₂ → l₂ ⊆ l₃ → l₁ ⊆ l₃ := by
  intro h₁ h₂ a ha
  cases l₁ with
  | nil =>
    cases ha
  | cons x xs =>
    cases ha with
    | head =>
      apply h₂
      apply h₁
      constructor
    | tail _ hxs =>
      apply h₂
      apply h₁
      constructor
      assumption

-- END PRELUDE

instance unique_of_is_empty [IsEmpty α] : Unique (List α) := by
  aesop (add 1% cases List)

-- instance : is_left_id (list α) has_append.append [] :=
-- ⟨ nil_append ⟩

-- instance : is_right_id (list α) has_append.append [] :=
-- ⟨ append_nil ⟩

-- instance : is_associative (list α) has_append.append :=
-- ⟨ append_assoc ⟩

-- attribute [-simp] cons_ne_nil
theorem X.cons_ne_nil (a : α) (l : List α) : a::l ≠ [] := by
  aesop

-- attribute [-simp] cons_ne_self
theorem X.cons_ne_self (a : α) (l : List α) : a::l ≠ l := by
  aesop (add 1% cases Eq)

-- attribute [-simp] head_eq_of_cons_eq
theorem X.head_eq_of_cons_eq {h₁ h₂ : α} {t₁ t₂ : List α} :
      (h₁::t₁) = (h₂::t₂) → h₁ = h₂ := by
  aesop

-- attribute [-simp] tail_eq_of_cons_eq
theorem X.tail_eq_of_cons_eq {h₁ h₂ : α} {t₁ t₂ : List α} :
      (h₁::t₁) = (h₂::t₂) → t₁ = t₂ := by
  aesop

@[simp] theorem cons_injective {a : α} : Injective (cons a) := by
  aesop

-- attribute [-simp] cons_inj
theorem X.cons_inj (a : α) {l l' : List α} : a::l = a::l' ↔ l = l' := by
  aesop

-- attribute [-simp] exists_cons_of_ne_nil
theorem X.exists_cons_of_ne_nil : l ≠ nil → ∃ b L, l = b :: L := by
  aesop (add 1% cases List)

-- theorem set_of_mem_cons (l : list α) (a : α) : {x | x ∈ a :: l} = insert a {x | x ∈ l} := rfl

/-! ### mem -/

attribute [aesop safe constructors] List.Mem
attribute [aesop safe (cases (patterns := [List.Mem _ [], List.Mem _ (_ :: _)]))] List.Mem

-- attribute [-simp] mem_singleton_self
@[simp]
theorem X.mem_singleton_self (a : α) : a ∈ [a] := by
  aesop

attribute [-simp] mem_singleton
-- attribute [-simp] eq_of_mem_singleton
theorem X.eq_of_mem_singleton {a b : α} : a ∈ [b] → a = b := by
  aesop

@[simp]
theorem X.mem_singleton {a b : α} : a ∈ [b] ↔ a = b := by
  aesop

-- attribute [-simp] mem_of_mem_cons_of_mem
theorem X.mem_of_mem_cons_of_mem {a b : α} {l : List α} : a ∈ b::l → b ∈ l → a ∈ l := by
  aesop

set_option linter.unusedVariables false in
theorem _root_.decidable.list.eq_or_ne_mem_of_mem [deq : DecidableEq α]
  {a b : α} {l : List α} (h : a ∈ b :: l) : a = b ∨ (a ≠ b ∧ a ∈ l) :=
  ADMIT
  -- cases deq a b <;> aesop

-- attribute [-simp] eq_or_ne_mem_of_mem
theorem X.eq_or_ne_mem_of_mem {a b : α} {l : List α} : a ∈ b :: l → a = b ∨ (a ≠ b ∧ a ∈ l) := by
  open Classical in
  aesop (add safe [decidable.list.eq_or_ne_mem_of_mem])

theorem not_mem_append {a : α} {s t : List α} (h₁ : a ∉ s) (h₂ : a ∉ t) : a ∉ s ++ t := by
  induction s <;> aesop

-- attribute [-simp] ne_nil_of_mem
theorem X.ne_nil_of_mem {a : α} {l : List α} (h : a ∈ l) : l ≠ [] := by
  aesop

set_option linter.unusedVariables false in
theorem mem_split {a : α} {l : List α} (h : a ∈ l) : ∃ s t : List α, l = s ++ a :: t :=
  ADMIT -- Nontrivial existential.

theorem mem_of_ne_of_mem {a y : α} {l : List α} (h₁ : a ≠ y) (h₂ : a ∈ y :: l) : a ∈ l := by
  aesop

theorem ne_of_not_mem_cons {a b : α} {l : List α} : a ∉ b::l → a ≠ b := by
  aesop

theorem not_mem_of_not_mem_cons {a b : α} {l : List α} : a ∉ b::l → a ∉ l := by
  aesop

theorem not_mem_cons_of_ne_of_not_mem {a y : α} {l : List α} : a ≠ y → a ∉ l → a ∉ y::l := by
  aesop

theorem ne_and_not_mem_of_not_mem_cons {a y : α} {l : List α} : a ∉ y::l → a ≠ y ∧ a ∉ l := by
  aesop

-- attribute [-simp] mem_map
@[simp] theorem X.mem_map {f : α → β} {b : β} {l : List α} : b ∈ map f l ↔ ∃ a, a ∈ l ∧ f a = b := by
  induction l <;> aesop

-- attribute [-simp] mem_map_of_mem
@[aesop safe]
theorem X.mem_map_of_mem (f : α → β) {a : α} {l : List α} (h : a ∈ l) : f a ∈ map f l := by
  aesop

theorem mem_map_of_injective {f : α → β} (H : Injective f) {a : α} {l : List α} :
  f a ∈ map f l ↔ a ∈ l := by
  aesop

@[simp] theorem _root_.function.involutive.exists_mem_and_apply_eq_iff {f : α → α}
  (hf : Involutive f) (x : α) (l : List α) :
  (∃ (y : α), y ∈ l ∧ f y = x) ↔ f x ∈ l := by
  aesop

theorem mem_map_of_involutive {f : α → α} (hf : Involutive f) {a : α} {l : List α} :
  a ∈ map f l ↔ f a ∈ l := by
  aesop

-- attribute [-simp] forall_mem_map_iff
theorem X.forall_mem_map_iff {f : α → β} {l : List α} {P : β → Prop} :
  (∀ i, i ∈ l.map f → P i) ↔ ∀ j, j ∈ l → P (f j) := by
  aesop

attribute [-simp] map_eq_nil
@[simp] theorem X.map_eq_nil {f : α → β} {l : List α} : map f l = [] ↔ l = [] := by
  aesop (add 1% cases List)

-- attribute [-simp] mem_join
@[simp] theorem X.mem_join {a : α} : ∀ {L : List (List α)}, a ∈ join L ↔ ∃ l, l ∈ L ∧ a ∈ l := by
  intro L; induction L <;> aesop

-- attribute [-simp] exists_of_mem_join
theorem X.exists_of_mem_join {a : α} {L : List (List α)} : a ∈ join L → ∃ l, l ∈ L ∧ a ∈ l := by
  aesop

-- attribute [-simp] mem_join_of_mem
theorem X.mem_join_of_mem {a : α} {L : List (List α)} {l} (lL : l ∈ L) (al : a ∈ l) : a ∈ join L := by
  aesop

-- attribute [-simp] mem_bind
@[simp] theorem X.mem_bind {b : β} {l : List α} {f : α → List β} : b ∈ l.bind f ↔ ∃ a, a ∈ l ∧ b ∈ f a := by
  induction l <;> aesop

-- attribute [-simp] exists_of_mem_bind
theorem X.exists_of_mem_bind {l : List α} :
    b ∈ l.bind f → ∃ a, a ∈ l ∧ b ∈ f a := by
  aesop

-- attribute [-simp] mem_bind_of_mem
theorem X.mem_bind_of_mem {l : List α} :
    (∃ a, a ∈ l ∧ b ∈ f a) → b ∈ l.bind f := by
  induction l <;> aesop

-- attribute [-simp] bind_map
theorem X.bind_map {g : α → List β} {f : β → γ} :
  ∀ l : List α, map f (l.bind g) = l.bind (λa => (g a).map f) := by
  intro l; induction l <;> aesop

theorem map_bind (g : β → List γ) (f : α → β) :
  ∀ l : List α, (map f l).bind g = l.bind (λ a => g (f a)) := by
  intro l; induction l <;> aesop

-- theorem range_map (f : α → β) : set.range (map f) = {l | ∀ x ∈ l, x ∈ set.range f} :=

-- theorem range_map_coe (s : set α) : set.range (map (coe : s → α)) = {l | ∀ x ∈ l, x ∈ s} :=

-- instance [h : can_lift α β] : can_lift (list α) (list β) :=

/-! ### length -/

-- attribute [-simp] length_eq_zero
theorem X.length_eq_zero {l : List α} : length l = 0 ↔ l = [] := by
  aesop (add 1% cases List)

attribute [-simp] length_singleton
@[simp] theorem X.length_singleton (a : α) : length [a] = 1 := rfl

-- attribute [-simp] length_pos_of_mem
theorem X.length_pos_of_mem {a : α} : ∀ {l : List α}, a ∈ l → 0 < length l := by
  aesop (add 1% cases List) (simp_options := { arith := true })

-- attribute [-simp] exists_mem_of_length_pos
theorem X.exists_mem_of_length_pos : ∀ {l : List α}, 0 < length l → ∃ a, a ∈ l := by
  aesop (add 1% cases List)

-- attribute [-simp] length_pos_iff_exists_mem
theorem X.length_pos_iff_exists_mem {l : List α} : 0 < length l ↔ ∃ a, a ∈ l := by
  aesop (add unsafe [length_pos_of_mem, exists_mem_of_length_pos])

theorem ne_nil_of_length_pos {l : List α} : 0 < length l → l ≠ [] := by
  aesop (add 1% cases List)

theorem length_pos_of_ne_nil {l : List α} : l ≠ [] → 0 < length l := by
  aesop (add 1% cases List) (simp_options := { arith := true })

theorem length_pos_iff_ne_nil {l : List α} : 0 < length l ↔ l ≠ [] := by
  aesop (add unsafe [ne_nil_of_length_pos, length_pos_of_ne_nil])

-- attribute [-simp] exists_mem_of_ne_nil
theorem X.exists_mem_of_ne_nil (l : List α) (h : l ≠ []) : ∃ x, x ∈ l := by
  aesop (add 1% cases List)

-- attribute [-simp] length_eq_one
theorem X.length_eq_one : length l = 1 ↔ ∃ a, l = [a] := by
  aesop (add 1% cases List)

theorem exists_of_length_succ {n} :
  ∀ l : List α, l.length = n + 1 → ∃ h t, l = h :: t := by
  intro l; induction l <;> aesop (simp_options := { arith := true })

@[simp] theorem length_injective_iff : Injective (length : List α → Nat) ↔ Subsingleton α :=
  ADMIT -- Requires induction after case split.

@[simp] theorem length_injective [Subsingleton α] : Injective (length : List α → Nat) := by
  aesop

theorem length_eq_two {l : List α} : l.length = 2 ↔ ∃ a b, l = [a, b] := by
  aesop (add 50% cases List)

theorem length_eq_three {l : List α} : l.length = 3 ↔ ∃ a b c, l = [a, b, c] := by
  aesop (add 50% cases List)

/-! ### set-theoretic notation of lists -/

attribute [-simp] empty_eq
theorem X.empty_eq : (∅ : List α) = [] := rfl

-- theorem singleton_eq (x : α) : ({x} : List α) = [x]

-- theorem insert_neg [DecidableEq α] {x : α} {l : List α} (h : x ∉ l) :
--   has_insert.insert x l = x :: l

-- theorem insert_pos [DecidableEq α] {x : α} {l : List α} (h : x ∈ l) :
--   has_insert.insert x l = l

-- theorem doubleton_eq [DecidableEq α] {x y : α} (h : x ≠ y) : ({x, y} : List α) = [x, y]

/-! ### bounded quantifiers over lists -/

-- The notation used in Lean 3 (`∀ x ∈ xs, P x` and `∃ x ∈ xs, P x`) does not
-- exist in Lean 4. We've expanded it manually.

-- attribute [-simp] forall_mem_nil
theorem X.forall_mem_nil (p : α → Prop) : ∀ x, x ∈ @nil α → p x := by
  aesop

-- attribute [-simp] forall_mem_cons
theorem X.forall_mem_cons : ∀ {p : α → Prop} {a : α} {l : List α},
    (∀ x, x ∈ a :: l → p x) ↔ p a ∧ ∀ x, x ∈ l → p x := by
  aesop

theorem forall_mem_of_forall_mem_cons {p : α → Prop} {a : α} {l : List α}
    (h : ∀ x, x ∈ a :: l → p x) :
  ∀ x, x ∈ l → p x := by
  aesop

-- attribute [-simp] forall_mem_singleton
theorem X.forall_mem_singleton {p : α → Prop} {a : α} : (∀ x, x ∈ [a] → p x) ↔ p a := by
  aesop

-- attribute [-simp] forall_mem_append
theorem X.forall_mem_append {p : α → Prop} {l₁ l₂ : List α} :
    (∀ x, x ∈ l₁ ++ l₂ → p x) ↔ (∀ x, x ∈ l₁ → p x) ∧ (∀ x, x ∈ l₂ → p x) := by
  aesop

theorem not_exists_mem_nil (p : α → Prop) : ¬ ∃ x, x ∈ @nil α ∧ p x := by
  aesop

theorem exists_mem_cons_of {p : α → Prop} {a : α} (l : List α) (h : p a) :
    ∃ x, x ∈ a :: l ∧ p x := by
  aesop

theorem exists_mem_cons_of_exists {p : α → Prop} {a : α} {l : List α} (h : ∃ x, x ∈ l ∧ p x) :
  ∃ x, x ∈ a :: l ∧ p x := by
  aesop

theorem or_exists_of_exists_mem_cons {p : α → Prop} {a : α} {l : List α} (h : ∃ x, x ∈ a :: l ∧ p x) :
  p a ∨ ∃ x, x ∈ l ∧ p x := by
  aesop

theorem exists_mem_cons_iff (p : α → Prop) (a : α) (l : List α) :
  (∃ x, x ∈ a :: l ∧ p x) ↔ p a ∨ ∃ x, x ∈ l ∧ p x := by
  aesop

/-! ### list subset -/

-- attribute [-simp] subset_def
theorem X.subset_def {l₁ l₂ : List α} : l₁ ⊆ l₂ ↔ ∀ ⦃a : α⦄, a ∈ l₁ → a ∈ l₂ := by
  aesop

-- attribute [-simp] subset_append_of_subset_left
theorem X.subset_append_of_subset_left (l l₁ l₂ : List α) : l ⊆ l₁ → l ⊆ l₁++l₂ := by
  aesop (add 1% subset_trans)

-- attribute [-simp] subset_append_of_subset_right
theorem X.subset_append_of_subset_right (l l₁ l₂ : List α) : l ⊆ l₂ → l ⊆ l₁ ++ l₂ := by
  aesop (add 1% subset_trans)

attribute [-simp] cons_subset
@[simp] theorem X.cons_subset {a : α} {l m : List α} :
  a::l ⊆ m ↔ a ∈ m ∧ l ⊆ m := by
  set_option aesop.check.script false in -- TODO
  aesop (add norm simp [HasSubset.Subset, List.Subset])

theorem cons_subset_of_subset_of_mem {a : α} {l m : List α}
    (ainm : a ∈ m) (lsubm : l ⊆ m) : a::l ⊆ m := by
  aesop

theorem append_subset_of_subset_of_subset {l₁ l₂ l : List α} (l₁subl : l₁ ⊆ l) (l₂subl : l₂ ⊆ l) :
  l₁ ++ l₂ ⊆ l := by
  set_option aesop.check.script false in -- TODO
  aesop (add norm simp [HasSubset.Subset, List.Subset])

@[simp] theorem append_subset_iff {l₁ l₂ l : List α} :
    l₁ ++ l₂ ⊆ l ↔ l₁ ⊆ l ∧ l₂ ⊆ l := by
  set_option aesop.check.script false in -- TODO
  aesop (add norm simp [HasSubset.Subset, List.Subset])

@[aesop safe destruct]
theorem eq_nil_of_subset_nil {l : List α} : l ⊆ [] → l = [] := by
  aesop (add 1% cases List)

-- attribute [-simp] eq_nil_iff_forall_not_mem
theorem X.eq_nil_iff_forall_not_mem {l : List α} : l = [] ↔ ∀ a, a ∉ l := by
  aesop (add 1% cases List)

-- attribute [-simp] map_subset
theorem X.map_subset {l₁ l₂ : List α} (f : α → β) (H : l₁ ⊆ l₂) : map f l₁ ⊆ map f l₂ := by
  set_option aesop.check.script false in -- TODO
  aesop (add norm simp [HasSubset.Subset, List.Subset])

theorem map_subset_iff {l₁ l₂ : List α} (f : α → β) (h : Injective f) :
    map f l₁ ⊆ map f l₂ ↔ l₁ ⊆ l₂ := by
  induction l₁ <;> induction l₂ <;> aesop

/-! ### append -/

theorem append_eq_has_append {L₁ L₂ : List α} : List.append L₁ L₂ = L₁ ++ L₂ := rfl

attribute [-simp] singleton_append
@[simp] theorem X.singleton_append {x : α} {l : List α} : [x] ++ l = x :: l := rfl

-- attribute [-simp] append_ne_nil_of_ne_nil_left
theorem X.append_ne_nil_of_ne_nil_left (s t : List α) : s ≠ [] → s ++ t ≠ [] := by
  induction s <;> aesop

-- attribute [-simp] append_ne_nil_of_ne_nil_right
theorem X.append_ne_nil_of_ne_nil_right (s t : List α) : t ≠ [] → s ++ t ≠ [] := by
  induction s <;> aesop

attribute [-simp] append_eq_nil
@[simp] theorem X.append_eq_nil {p q : List α} : (p ++ q) = [] ↔ p = [] ∧ q = [] := by
  aesop (add 1% cases List)

@[simp] theorem nil_eq_append_iff {a b : List α} : [] = a ++ b ↔ a = [] ∧ b = [] := by
  induction a <;> aesop

theorem append_eq_cons_iff {a b c : List α} {x : α} :
  a ++ b = x :: c ↔ (a = [] ∧ b = x :: c) ∨ (∃a', a = x :: a' ∧ c = a' ++ b) := by
  aesop (add 1% cases List)

theorem cons_eq_append_iff {a b c : List α} {x : α} :
    (x :: c : List α) = a ++ b ↔ (a = [] ∧ b = x :: c) ∨ (∃a', a = x :: a' ∧ c = a' ++ b) := by
  aesop (add norm simp [append_eq_cons_iff, eq_comm])

-- attribute [-simp] append_eq_append_iff
theorem X.append_eq_append_iff {a b c d : List α} :
    a ++ b = c ++ d ↔ (∃a', c = a ++ a' ∧ b = a' ++ d) ∨ (∃c', a = c ++ c' ∧ d = c' ++ b) :=
  ADMIT -- Nontrivial existential.

attribute [-simp] take_append_drop
@[simp] theorem X.take_append_drop : ∀ (n : Nat) (l : List α), take n l ++ drop n l = l
  | 0        , a         => by aesop
  | (.succ _), []        => by aesop
  | (.succ n), (_ :: xs) => by
    have ih := take_append_drop n xs
    aesop

-- attribute [-simp] append_inj
@[aesop safe forward]
theorem X.append_inj :
  ∀ {s₁ s₂ t₁ t₂ : List α}, s₁ ++ t₁ = s₂ ++ t₂ → length s₁ = length s₂ → s₁ = s₂ ∧ t₁ = t₂
  | []     , []     , t₁, t₂, h, _  => by aesop
  | (a::s₁), []     , t₁, t₂, _, hl => by aesop
  | []     , (b::s₂), t₁, t₂, _, hl => by aesop
  | (a::s₁), (b::s₂), t₁, t₂, h, hl => by
    have ih := @append_inj _ s₁ s₂ t₁ t₂
    aesop

-- attribute [-simp] append_inj_right
theorem X.append_inj_right {s₁ s₂ t₁ t₂ : List α} (h : s₁ ++ t₁ = s₂ ++ t₂)
    (hl : length s₁ = length s₂) : t₁ = t₂ := by
  aesop

-- attribute [-simp] append_inj_left
theorem X.append_inj_left {s₁ s₂ t₁ t₂ : List α} (h : s₁ ++ t₁ = s₂ ++ t₂)
    (hl : length s₁ = length s₂) : s₁ = s₂ := by
  aesop

-- attribute [-simp] append_inj'
set_option linter.unusedVariables false in
@[aesop safe forward]
theorem X.append_inj' {s₁ s₂ t₁ t₂ : List α} (h : s₁ ++ t₁ = s₂ ++ t₂) (hl : length t₁ = length t₂) :
  s₁ = s₂ ∧ t₁ = t₂ := by
  induction s₁ generalizing s₂ <;> induction s₂ <;>
    aesop (simp_options := { arith := true })

-- attribute [-simp] append_inj_right'
theorem X.append_inj_right' {s₁ s₂ t₁ t₂ : List α} (h : s₁ ++ t₁ = s₂ ++ t₂)
    (hl : length t₁ = length t₂) : t₁ = t₂ := by
  aesop

-- attribute [-simp] append_inj_left'
theorem X.append_inj_left' {s₁ s₂ t₁ t₂ : List α} (h : s₁ ++ t₁ = s₂ ++ t₂)
    (hl : length t₁ = length t₂) : s₁ = s₂ := by
  aesop

theorem append_left_cancel {s t₁ t₂ : List α} (h : s ++ t₁ = s ++ t₂) : t₁ = t₂ := by
  aesop

theorem append_right_cancel {s₁ s₂ t : List α} (h : s₁ ++ t = s₂ ++ t) : s₁ = s₂ := by
  aesop

theorem append_right_injective (s : List α) : Injective (λ t => s ++ t) := by
  aesop

-- attribute [-simp] append_right_inj
theorem X.append_right_inj {t₁ t₂ : List α} (s) : s ++ t₁ = s ++ t₂ ↔ t₁ = t₂ := by
  aesop

theorem append_left_injective (t : List α) : Injective (λ s => s ++ t) := by
  aesop

-- attribute [-simp] append_left_inj
theorem X.append_left_inj {s₁ s₂ : List α} (t) : s₁ ++ t = s₂ ++ t ↔ s₁ = s₂ := by
  aesop

-- attribute [-simp] map_eq_append_split
set_option linter.unusedVariables false in
theorem X.map_eq_append_split {f : α → β} {l : List α} {s₁ s₂ : List β}
    (h : map f l = s₁ ++ s₂) : ∃ l₁ l₂, l = l₁ ++ l₂ ∧ map f l₁ = s₁ ∧ map f l₂ = s₂ :=
  ADMIT -- Nontrivial existential.

/-! ### replicate/repeat -/

-- Note: `replicate` is called `repeat` in Lean 3 and has flipped arguments.

-- attribute [-simp] replicate_succ
@[simp] theorem X.replicate_succ (a : α) (n) : replicate (n + 1) a = a :: replicate n a := rfl

-- attribute [-simp] mem_replicate
@[simp] theorem X.mem_replicate {a b : α} {n} : b ∈ replicate n a ↔ n ≠ 0 ∧ b = a := by
  induction n <;> aesop

-- attribute [-simp] eq_of_mem_replicate
@[aesop safe destruct]
theorem X.eq_of_mem_replicate {a b : α} {n} (h : b ∈ replicate n a) : b = a := by
  aesop

theorem eq_replicate_of_mem {a : α} {l : List α} : (∀ b, b ∈ l → b = a) → l = replicate l.length a := by
  induction l <;> aesop (simp_options := { useHyps := false })

theorem eq_replicate' {a : α} {l : List α} : l = replicate l.length a ↔ ∀ b, b ∈ l → b = a := by
  induction l <;> aesop

theorem eq_replicate {a : α} {n} {l : List α} : l = replicate n a ↔ length l = n ∧ ∀ b, b ∈ l → b = a := by
  set_option aesop.check.script false in -- TODO
  aesop (add norm simp eq_replicate')

theorem replicate_add (a : α) (m n) : replicate (m + n) a = replicate m a ++ replicate n a :=
  ADMIT -- Need to apply associativity of addition to let `replicate` reduce.

theorem replicate_subset_singleton (a : α) (n) : replicate n a ⊆ [a] := by
  set_option aesop.check.script false in -- TODO
  aesop (add norm simp [HasSubset.Subset, List.Subset])

theorem subset_singleton_iff {a : α} {L : List α} : L ⊆ [a] ↔ ∃ n, L = replicate n a :=
  ADMIT -- Nontrivial existential.

@[simp] theorem map_const (l : List α) (b : β) : map (λ _ => b) l = replicate l.length b := by
  induction l <;> aesop

theorem eq_of_mem_map_const {b₁ b₂ : β} {l : List α} (h : b₁ ∈ map (λ _ => b₂) l) :
  b₁ = b₂ := by
  aesop

@[simp] theorem map_replicate (f : α → β) (a : α) (n) : map f (replicate n a) = replicate n (f a) := by
  induction n <;> aesop

@[simp] theorem tail_replicate (a : α) (n) : tail (replicate n a) = replicate n.pred a := by
  aesop (add 1% cases Nat)

@[simp] theorem join_replicate_nil (n : Nat) : join (replicate n []) = @nil α := by
  induction n <;> aesop

theorem replicate_left_injective {n : Nat} (hn : n ≠ 0) :
    Injective (λ a : α => replicate n a) := by
  induction n <;> aesop

@[simp] theorem replicate_left_inj' {a b : α} :
  ∀ {n}, replicate n a = replicate n b ↔ n = 0 ∨ a = b := by
  intro n; induction n <;> aesop

theorem replicate_right_injective (a : α) : Injective (λ n => replicate n a) := by
  unfold Injective; intro x y
  induction x generalizing y <;> induction y <;>
    aesop (simp_options := { useHyps := false })

@[simp] theorem replicate_right_inj {a : α} {n m : Nat} :
    replicate n a = replicate m a ↔ n = m := by
  induction n generalizing m <;> aesop (add 1% cases Nat)

/-! ### pure -/

@[simp]
theorem mem_pure {α} (x y : α) :
    x ∈ (pure y : List α) ↔ x = y := by
  set_option aesop.check.script false in -- TODO
  aesop (add norm simp pure)

/-! ### bind -/

instance : Bind List where
  bind l f := List.bind l f

@[simp] theorem bind_eq_bind {α β} (f : α → List β) (l : List α) :
    l >>= f = l.bind f := rfl

theorem bind_append (f : α → List β) (l₁ l₂ : List α) :
  (l₁ ++ l₂).bind f = l₁.bind f ++ l₂.bind f := by
  induction l₁ <;> aesop

@[simp] theorem bind_singleton (f : α → List β) (x : α) : [x].bind f = f x := by
  aesop

@[simp] theorem bind_singleton' (l : List α) : l.bind (λ x => [x]) = l := by
  induction l <;> aesop

theorem map_eq_bind {α β} (f : α → β) (l : List α) : map f l = l.bind (λ x => [f x]) := by
  induction l <;> aesop

theorem bind_assoc {α β γ : Type u} (l : List α) (f : α → List β) (g : β → List γ) :
    (l.bind f).bind g = l.bind (λ x => (f x).bind g) :=
  ADMIT
  -- have aux {δ : Type u} (xs ys : List (List δ)) : join (xs ++ ys) = join xs ++ join ys := by
  --   induction xs <;> aesop
  -- induction l <;> aesop (add norm [simp [bind_append], unfold [bind]])

/-! ### concat -/

@[simp] theorem concat_nil (a : α) : concat [] a = [a] := rfl

@[simp] theorem concat_cons (a b : α) (l : List α) : concat (a :: l) b = a :: concat l b := rfl

attribute [-simp] concat_eq_append
@[simp] theorem X.concat_eq_append (a : α) (l : List α) : concat l a = l ++ [a] := by
  induction l <;> aesop

theorem init_eq_of_concat_eq {a : α} {l₁ l₂ : List α} : concat l₁ a = concat l₂ a → l₁ = l₂ := by
  aesop

theorem last_eq_of_concat_eq {a b : α} {l : List α} : concat l a = concat l b → a = b := by
  aesop

theorem concat_ne_nil (a : α) (l : List α) : concat l a ≠ [] := by
  aesop

attribute [simp] append_assoc

theorem concat_append (a : α) (l₁ l₂ : List α) : concat l₁ a ++ l₂ = l₁ ++ a :: l₂ := by
  aesop

attribute [-simp] length_concat
theorem X.length_concat (a : α) (l : List α) : length (concat l a) = .succ (length l) := by
  aesop

theorem append_concat (a : α) (l₁ l₂ : List α) : l₁ ++ concat l₂ a = concat (l₁ ++ l₂) a := by
  aesop

/-! ### reverse -/

attribute [-simp] reverse_nil
@[simp] theorem X.reverse_nil : reverse (@nil α) = [] := rfl

attribute [-simp] reverse_cons
@[simp] theorem X.reverse_cons (a : α) (l : List α) : reverse (a::l) = reverse l ++ [a] :=
  ADMIT
  -- have aux : ∀ l₁ l₂, reverseAux l₁ l₂ ++ [a] = reverseAux l₁ (l₂ ++ [a]) := by
  --   intro l₁; induction l₁ <;> aesop (add norm unfold reverseAux)
  -- aesop (add norm unfold reverse)

-- Note: reverse_core is called reverseAux in Lean 4.
-- attribute [-simp] reverseAux_eq
@[simp]
theorem reverse_core_eq (l₁ l₂ : List α) : reverseAux l₁ l₂ = reverse l₁ ++ l₂ := by
  induction l₁ generalizing l₂ <;> aesop

theorem reverse_cons' (a : α) (l : List α) : reverse (a::l) = concat (reverse l) a := by
  aesop

@[simp] theorem reverse_singleton (a : α) : reverse [a] = [a] := rfl

attribute [-simp] reverse_append
@[simp] theorem X.reverse_append (s t : List α) : reverse (s ++ t) = (reverse t) ++ (reverse s) := by
  induction s <;> aesop

-- attribute [-simp] reverse_concat
theorem X.reverse_concat (l : List α) (a : α) : reverse (concat l a) = a :: reverse l := by
  aesop

attribute [-simp] reverse_reverse
@[simp] theorem X.reverse_reverse (l : List α) : reverse (reverse l) = l := by
  induction l <;> aesop

@[simp] theorem reverse_involutive : Involutive (@reverse α) := by
  aesop

@[simp] theorem reverse_injective {α : Type u} : Injective (@reverse α) := by
  aesop

@[simp] theorem reverse_surjective {α : Type u} : Surjective (@reverse α) := by
  aesop

@[simp] theorem reverse_bijective : Bijective (@reverse α) := by
  aesop

@[simp] theorem reverse_inj {l₁ l₂ : List α} : reverse l₁ = reverse l₂ ↔ l₁ = l₂ := by
  aesop (add safe forward reverse_injective)

theorem reverse_eq_iff {l l' : List α} :
  l.reverse = l' ↔ l = l'.reverse := by
  aesop

@[simp] theorem reverse_eq_nil {l : List α} : reverse l = [] ↔ l = [] := by
  aesop (add norm simp reverse_eq_iff)

theorem concat_eq_reverse_cons (a : α) (l : List α) : concat l a = reverse (a :: reverse l) := by
  induction l <;> aesop

attribute [-simp] length_reverse
@[simp] theorem X.length_reverse (l : List α) : length (reverse l) = length l := by
  induction l <;> aesop

theorem map_reverse (f : α → β) (l : List α) : map f (reverse l) = reverse (map f l) := by
  induction l <;> aesop

-- attribute [-simp] map_reverseAux
theorem map_reverse_core (f : α → β) (l₁ l₂ : List α) :
  map f (reverseAux l₁ l₂) = reverseAux (map f l₁) (map f l₂) := by
  aesop (add norm simp reverse_map)

attribute [-simp] mem_reverse
@[simp] theorem X.mem_reverse {a : α} {l : List α} : a ∈ reverse l ↔ a ∈ l := by
  induction l <;> aesop

@[simp] theorem reverse_replicate (a : α) (n) : reverse (replicate n a) = replicate n a :=
  ADMIT -- Several missing lemmas.

/-! ### empty -/

theorem empty_iff_eq_nil {l : List α} : Empty l ↔ l = [] := by
  aesop

/-! ### init -/

@[simp] theorem length_init : ∀ (l : List α), length (init l) = length l - 1
  | [] => by aesop
  | [_] => by aesop
  | (_ :: y :: zs) => by
    have ih := length_init (y :: zs)
    aesop (add norm simp [init, Nat.add_sub_cancel])

/-! ### last -/

@[simp] theorem last_cons {a : α} {l : List α} :
  ∀ (h : l ≠ nil), last (a :: l) (cons_ne_nil a l) = last l h := by
  aesop (add 1% cases List)

@[simp] theorem last_append_singleton {a : α} (l : List α) :
  last (l ++ [a]) (append_ne_nil_of_ne_nil_right l _ (cons_ne_nil a _)) = a := by
  induction l <;> aesop

theorem last_append (l₁ l₂ : List α) (h : l₂ ≠ []) :
  last (l₁ ++ l₂) (append_ne_nil_of_ne_nil_right l₁ l₂ h) = last l₂ h := by
  induction l₁ <;> aesop

theorem last_concat {a : α} (l : List α) : last (concat l a) (concat_ne_nil a l) = a := by
  aesop

@[simp] theorem last_singleton (a : α) : last [a] (cons_ne_nil a []) = a := rfl

@[simp] theorem last_cons_cons (a₁ a₂ : α) (l : List α) :
  last (a₁::a₂::l) (cons_ne_nil _ _) = last (a₂::l) (cons_ne_nil a₂ l) := rfl

theorem init_append_last : ∀ {l : List α} (h : l ≠ []), init l ++ [last l h] = l
  | [] => by aesop
  | [_] => by aesop
  | x :: y :: zs => by
    have ih := init_append_last (l := y :: zs)
    aesop (add norm simp [init, last])

theorem last_congr {l₁ l₂ : List α} (h₁ : l₁ ≠ []) (h₂ : l₂ ≠ []) (h₃ : l₁ = l₂) :
  last l₁ h₁ = last l₂ h₂ := by
  aesop

theorem last_mem : ∀ {l : List α} (h : l ≠ []), last l h ∈ l := by
  intro l; induction l <;> aesop (add norm simp last, 1% cases List)

theorem last_replicate_succ (a m : Nat) :
  (replicate m.succ a).last
    (ne_nil_of_length_eq_succ
      (show (replicate m.succ a).length = m.succ by rw [length_replicate])) =
  a := by
  induction m <;> aesop

/-! ### last' -/

@[simp] theorem last'_is_none :
  ∀ {l : List α}, (last' l).isNone ↔ l = []
  | [] => by aesop
  | [a] => by aesop
  | a :: a' :: as => by
    have ih := last'_is_none (l := a' :: as)
    aesop

@[simp] theorem last'_is_some : ∀ {l : List α}, l.last'.isSome ↔ l ≠ []
  | [] => by aesop
  | [a] => by aesop
  | a :: a' :: as => by
    have ih := last'_is_some (l := a' :: as)
    aesop

theorem mem_last'_eq_last : ∀ {l : List α} {x : α}, x ∈ l.last' → ∃ h, x = last l h
  | [], _, h => by aesop
  | [_], _, h => by aesop
  | a :: a' :: as, x, h => by
    have ih := mem_last'_eq_last (l := a' :: as) (x := x)
    aesop (add norm simp last')

theorem last'_eq_last_of_ne_nil : ∀ {l : List α} (h : l ≠ []), l.last' = some (l.last h)
  | [], h => by aesop
  | [a], _ => by aesop
  | _ :: b :: l, _ => by
    have ih := last'_eq_last_of_ne_nil (l := b :: l)
    aesop

theorem mem_last'_cons {x y : α} : ∀ {l : List α} (_ : x ∈ l.last'), x ∈ (y :: l).last' := by
  intro l; induction l <;> aesop

theorem mem_of_mem_last' {l : List α} {a : α} (ha : a ∈ l.last') : a ∈ l := by
  match l with
  | [] => aesop
  | [_] => aesop
  | x :: y :: zs =>
    have ih := mem_of_mem_last' (l := y :: zs) (a := a)
    aesop

theorem init_append_last' : ∀ {l : List α} {a}, a ∈ l.last' → init l ++ [a] = l
  | [], _ => by aesop
  | [_], _ => by aesop
  | x :: y :: zs, a => by
    have ih := init_append_last' (l := y :: zs) (a := a)
    aesop (add norm simp init)

theorem ilast_eq_last' [Inhabited α] : ∀ l : List α, l.ilast = l.last'.iget
  | [] => by aesop
  | [a] => by aesop
  | [_, _] => by aesop
  | [_, _, _] => by aesop
  | (_ :: _ :: c :: l) => by
    have ih := ilast_eq_last' (c :: l)
    aesop

@[simp] theorem last'_append_cons : ∀ (l₁ : List α) (a : α) (l₂ : List α),
  last' (l₁ ++ a :: l₂) = last' (a :: l₂)
  | [], a, l₂ => by aesop
  | [_], a, l₂ => by aesop
  | _ :: c :: l₁, a, l₂ =>
    have ih := last'_append_cons (c :: l₁) a
    by aesop

@[simp] theorem last'_cons_cons (x y : α) (l : List α) :
  last' (x :: y :: l) = last' (y :: l) := rfl

theorem last'_append_of_ne_nil (l₁ : List α) : ∀ {l₂ : List α} (_ : l₂ ≠ []),
  last' (l₁ ++ l₂) = last' l₂
  | [], hl₂ => by aesop
  | b :: l₂, _ => by aesop

theorem last'_append {l₁ l₂ : List α} {x : α} (h : x ∈ l₂.last') :
  x ∈ (l₁ ++ l₂).last' := by
  aesop (add 1% cases List)

/-! ### head(') and tail -/

-- Note: Lean 3 head is Lean 4 ihead.

-- attribute [-simp] ihead_eq_head'
theorem head_eq_head' [Inhabited α] (l : List α) : ihead l = (head' l).iget := by
  aesop (add 1% cases List)

theorem mem_of_mem_head' {x : α} : ∀ {l : List α}, x ∈ l.head' → x ∈ l := by
  intro l; induction l <;> aesop

-- attribute [-simp] head'_cons
@[simp] theorem X.head'_cons [Inhabited α] (a : α) (l : List α) : head' (a::l) = a := rfl

attribute [-simp] tail_nil
@[simp] theorem X.tail_nil : tail (@nil α) = [] := rfl

attribute [-simp] tail_cons
@[simp] theorem X.tail_cons (a : α) (l : List α) : tail (a::l) = l := rfl

-- attribute [-simp] ihead_append
@[simp] theorem head_append [Inhabited α] (t : List α) {s : List α} (h : s ≠ []) :
  ihead (s ++ t) = ihead s := by
  aesop (add 1% cases List)

theorem head'_append {s t : List α} {x : α} (h : x ∈ s.head') :
  x ∈ (s ++ t).head' := by
  aesop (add 1% cases List)

theorem head'_append_of_ne_nil : ∀ (l₁ : List α) {l₂ : List α} (_ : l₁ ≠ []),
  head' (l₁ ++ l₂) = head' l₁ := by
  aesop (add 1% cases List)

theorem tail_append_singleton_of_ne_nil {a : α} {l : List α} (h : l ≠ nil) :
  tail (l ++ [a]) = tail l ++ [a] := by
  induction l <;> aesop

theorem cons_head'_tail : ∀ {l : List α} {a : α} (_ : a ∈ head' l), a :: tail l = l := by
  aesop

-- attribute [-simp] ihead_mem_head'
theorem head_mem_head' [Inhabited α] : ∀ {l : List α} (_ : l ≠ []), ihead l ∈ head' l := by
  aesop

-- attribute [-simp] cons_ihead_tail
theorem cons_head_tail [Inhabited α] {l : List α} (h : l ≠ []) : (ihead l)::(tail l) = l := by
  aesop

end List


/-
Copyright (c) 2021 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import tactic cnf

universes u v

variables {α : Type u} [decidable_eq α]

namespace list

variables {β : Type v} [add_monoid β] [partial_order β]
variables [contravariant_class β β (+) (<)]
variables [covariant_class β β (+) (<)]
variables [covariant_class β β (function.swap (+)) (≤)]
variables [covariant_class β β (function.swap (+)) (<)]
variables [covariant_class β β (+) (≤)]
variables [@decidable_rel β (≤)]

lemma sum_map_le_sum_map {l : list α} {f g : α → β} (hfg : ∀ x ∈ l, f x ≤ g x) : (l.map f).sum ≤ (l.map g).sum :=
begin
  induction l with x l ih,
  { refl },
  { simp only [sum_cons, map],
    exact add_le_add (hfg _ (mem_cons_self _ _)) (ih (λ x hx, hfg _ (mem_cons_of_mem _ hx))) }
end

lemma sum_map_lt_sum_map (l : list α) (f g : α → β) (hfg : ∀ x ∈ l, f x ≤ g x) :
  (l.map f).sum < (l.map g).sum ↔ ∃ x ∈ l, f x < g x :=
begin
  refine ⟨_, _⟩,
  { induction l with a as ih,
    { simp only [lt_self_iff_false, forall_false_left, map_nil] },
    { by_cases h : f a < g a,
      { exact λ _, ⟨a, ⟨mem_cons_self _ _, h⟩⟩ },
      { have hfa : f a = g a := decidable.eq_iff_le_not_lt.2 ⟨hfg _ (mem_cons_self _ _), h⟩,
        simp only [list.map_cons, list.sum_cons, hfa, add_lt_add_iff_left],
        intro h',
        obtain ⟨x, ⟨hx, hx'⟩⟩ := ih (λ x hx, hfg _ (mem_cons_of_mem _ hx)) h',
        exact ⟨x, ⟨mem_cons_of_mem _ hx, hx'⟩⟩ } } },
  { rintro ⟨x, ⟨hx, hx'⟩⟩,
    obtain ⟨s, t, rfl⟩ := list.mem_split hx,
    simp only [sum_cons, map, sum_append, map_append],
    refine add_lt_add_of_le_of_lt (sum_map_le_sum_map (λ x hx, hfg _ (mem_append_left _ hx))) _,
    exact add_lt_add_of_lt_of_le hx' (sum_map_le_sum_map (λ x hx, hfg _ (mem_append_right _ (mem_cons_of_mem _ hx)))) }
end

end list

namespace literal

end literal

namespace clause

def unit_propagate (l : literal α) (c : clause α) : clause α :=
c.filter $ (≠) l.inverse

def unit_propagate' (l : literal α) (c : clause α) : option (clause α) :=
if l ∈ c then none else some (unit_propagate l c)

lemma unit_propagate'_of_mem {l : literal α} {c : clause α} (h : l ∈ c) : unit_propagate' l c = none :=
by simp only [unit_propagate', h, if_true]

lemma unit_propagate'_of_not_mem {l : literal α} {c : clause α} (h : l ∉ c) :
  unit_propagate' l c = some (unit_propagate l c) :=
by simp only [unit_propagate', h, if_false]

lemma unit_propagate'_eq_some (l : literal α) (c d : clause α) :
  unit_propagate' l c = some d ↔ l ∉ c ∧ unit_propagate l c = d :=
by by_cases h : l ∈ c; simp [unit_propagate', h]

@[simp]
def satisfied' (ι : interpretation α) : option (clause α) → Prop
| none := tt
| (some c) := satisfied ι c

@[simp]
def length' : option (clause α) → ℕ
| none := 0
| (some c) := c.length

lemma length'_comp_some : (length' : option (clause α) → ℕ) ∘ some = list.length :=
rfl

lemma length_unit_propagate {l : literal α} {c : clause α} (hl : l.inverse ∈ c) :
  (unit_propagate l c).length < c.length :=
(list.length_filter_lt_length_iff_exists _ _).2 ⟨_, hl, λ h, h rfl⟩

lemma length'_unit_propagate'_of_mem {l : literal α} {c : clause α} (hl : l ∈ c) : length' (unit_propagate' l c) < c.length :=
by simpa only [unit_propagate'_of_mem hl, length'] using list.length_pos_of_mem hl

lemma length'_unit_propagate' {l : literal α} {c : clause α} (hl : l.inverse ∈ c) : length' (unit_propagate' l c) < c.length :=
begin
  by_cases h : l ∈ c,
  { exact length'_unit_propagate'_of_mem h },
  { rw [unit_propagate'_of_not_mem h, length'],
    exact length_unit_propagate hl }
end

lemma length_unit_propagate_le (l : literal α) (c : clause α) : (unit_propagate l c).length ≤ c.length :=
list.length_le_of_sublist $ list.filter_sublist c

lemma length'_unit_propagate'_le (l : literal α) (c : clause α) : length' (unit_propagate' l c) ≤ c.length :=
begin
  by_cases h : l ∈ c,
  { rw unit_propagate'_of_mem h,
    exact zero_le _ },
  { rw unit_propagate'_of_not_mem h,
    exact length_unit_propagate_le l c }
end

lemma mem_unit_propagate {l : literal α} {c : clause α} {m : literal α} :
  m ∈ unit_propagate l c ↔ m ∈ c ∧ l.inverse ≠ m :=
by rw [unit_propagate, list.mem_filter]

lemma satisfied_unit_propagate (l : literal α) (c : clause α) (ι : interpretation α)
  (hl : literal.satisfied ι l) : satisfied ι (unit_propagate l c) ↔ satisfied ι c :=
begin
  simp only [satisfied],
  refine ⟨_, _⟩,
  { rintro ⟨m, ⟨hmem, hm⟩⟩,
    rw [mem_unit_propagate] at hmem,
    exact ⟨m, ⟨hmem.1, hm⟩⟩ },
  { rintro ⟨m, ⟨hmem, hm⟩⟩,
    refine ⟨m, ⟨_, hm⟩⟩,
    { rw mem_unit_propagate,
      refine ⟨hmem, _⟩,
      symmetry,
      apply literal.not_satisfied_and_satisfied_inverse _ _ _ hm hl } }
end

lemma satisfied'_unit_propagate' (l : literal α) (c : clause α) (ι : interpretation α)
  (hl : literal.satisfied ι l) : satisfied' ι (unit_propagate' l c) ↔ satisfied ι c :=
begin
  by_cases h : l ∈ c,
  { rw [unit_propagate'_of_mem h, satisfied', satisfied, coe_sort_tt, true_iff],
    exact ⟨_, h, hl⟩ },
  { rw [unit_propagate'_of_not_mem h, satisfied', satisfied_unit_propagate],
    exact hl }
end

end clause

namespace cnf

def unit_propagate (l : literal α) (c : cnf α) : cnf α :=
c.filter_map $ clause.unit_propagate' l

lemma unit_propagate_cons (l : literal α) (γ : clause α) (c : cnf α) :
  unit_propagate l (γ :: c) = if l ∈ γ then unit_propagate l c else (clause.unit_propagate l γ) :: unit_propagate l c :=
begin
  by_cases h : l ∈ γ,
  { simp only [h, unit_propagate, clause.unit_propagate'_of_mem h, list.filter_map_cons_none, if_true] },
  { simp only [h, unit_propagate, list.filter_map_cons_some _ _ _ (clause.unit_propagate'_of_not_mem h),
      eq_self_iff_true, if_false, and_self] }
end

lemma sizeof_unit_propagate (l : literal α) (c : cnf α) :
  sizeof (unit_propagate l c) = (c.map (clause.length' ∘ clause.unit_propagate' l)).sum :=
begin
  induction c with γ c ih,
  { refl },
  { simp only [sizeof_eq_size, size, unit_propagate_cons, list.sum_cons, function.comp_app, list.map],
    by_cases h : l ∈ γ,
    { simp only [h, clause.unit_propagate'_of_mem h, ←ih, sizeof_eq_size, size, if_true, clause.length', zero_add] },
    { simp only [h, clause.unit_propagate'_of_not_mem h, ←ih, sizeof_eq_size, size, list.sum_cons, clause.length',
      if_false, list.map] } }
end

lemma sizeof_cnf (c : cnf α) : sizeof c = (c.map (clause.length' ∘ some)).sum :=
by rw [clause.length'_comp_some, sizeof_eq_size, size]

lemma sizeof_unit_propagate_of_mem {l : literal α} {γ : clause α} {c : cnf α} (hlγ : l ∈ γ ∨ l.inverse ∈ γ) (hγc: γ ∈ c) :
  sizeof (unit_propagate l c) < sizeof c :=
begin
  rw [sizeof_unit_propagate, sizeof_cnf, list.sum_map_lt_sum_map],
  { cases hlγ,
    { exact ⟨γ, hγc, clause.length'_unit_propagate'_of_mem hlγ⟩ },
    { exact ⟨γ, hγc, clause.length'_unit_propagate' hlγ⟩ } },
  { exact λ _ _, clause.length'_unit_propagate'_le _ _ }
end

lemma mem_unit_propagate (l : literal α) (c : cnf α) (γ : clause α) :
  γ ∈ unit_propagate l c ↔ ∃ δ, (δ ∈ c ∧ l ∉ δ) ∧ clause.unit_propagate l δ = γ :=
by simp only [unit_propagate, clause.unit_propagate'_eq_some, and.assoc, list.mem_filter_map]

lemma non_mem_unit_propagate {l : literal α} {c : cnf α} {γ : clause α} (hγ : γ ∈ unit_propagate l c) : l ∉ γ :=
begin
  obtain ⟨δ, ⟨⟨hδc, hlδ⟩, rfl⟩⟩ := (mem_unit_propagate l c γ).1 hγ,
  exact λ hl, hlδ (clause.mem_unit_propagate.1 hl).1
end

lemma inverse_non_mem_unit_propagate {l : literal α} {c : cnf α} {γ : clause α} (hγ : γ ∈ unit_propagate l c) :
  l.inverse ∉ γ :=
begin
  obtain ⟨δ, ⟨⟨hδc, hlδ⟩, rfl⟩⟩ := (mem_unit_propagate l c γ).1 hγ,
  exact λ hl, (clause.mem_unit_propagate.1 hl).2 rfl
end

lemma satisfied_unit_propagate (l : literal α) {c : cnf α} {ι : interpretation α}
  (hl : literal.satisfied ι l) : satisfied ι (unit_propagate l c) ↔ satisfied ι c :=
begin
  simp only [satisfied],
  refine ⟨λ h γ hγ, _, λ h γ hγ, _⟩,
  { by_cases hlγ : l ∈ γ,
    { rw clause.satisfied,
      exact ⟨l, hlγ, hl⟩ },
    { rw ←clause.satisfied_unit_propagate l _ _ hl,
      apply h,
      rw mem_unit_propagate,
      exact ⟨γ, ⟨hγ, hlγ⟩, rfl⟩ } },
  { rw mem_unit_propagate at hγ,
    rcases hγ with ⟨δ, ⟨hδ, -⟩, rfl⟩,
    rw clause.satisfied_unit_propagate _ _ _ hl,
    exact h _ hδ }
end

lemma satisfiable_of_satisfiable_unit_propagate {l : literal α} {c : cnf α} (h : satisfiable (unit_propagate l c)) :
  satisfiable c :=
begin
  rcases h with ⟨ι, hι⟩,
  by_cases h : literal.satisfied ι l,
  { exact ⟨ι, (satisfied_unit_propagate _ h).1 hι⟩ },
  { refine ⟨ι.flip l, (satisfied_unit_propagate l _).1 ((satisfied_iff _ ι (λ γ hγ m hm, _)).2 hι)⟩,
    { simpa only [interpretation.satisfied_flip_eq] using h },
    { apply interpretation.satisfied_flip_neq;
      rintro rfl,
      exacts [non_mem_unit_propagate hγ hm, inverse_non_mem_unit_propagate hγ hm] } }
end

def any_literal : Π (c : clause α) (hc : c ≠ []), literal α
| [] hc := false.elim (hc rfl)
| (l::lc) hc := l

lemma any_literal_mem : ∀ {c : clause α} (hc : c ≠ []), any_literal c hc ∈ c
| [] hc := false.elim (hc rfl)
| (l::lc) hc := list.mem_cons_self _ _

def dpll : cnf α → bool
| [] := tt
| (x::xs) := if h : [] ∈ x::xs then ff else
    have hx : x ≠ [], from λ hx, h $ or.inl hx.symm,
    have h1 : sizeof (unit_propagate (any_literal x hx) (x::xs)) < sizeof (x::xs),
      from sizeof_unit_propagate_of_mem (or.inl (any_literal_mem hx)) (list.mem_cons_self _ _),
    have h2 : sizeof (unit_propagate (any_literal x hx).inverse (x::xs)) < sizeof (x::xs), by
    { refine sizeof_unit_propagate_of_mem (or.inr _) (list.mem_cons_self _ _),
      simpa only [literal.inverse_inverse] using any_literal_mem hx },
    dpll (unit_propagate (any_literal x hx) (x::xs)) || dpll (unit_propagate (any_literal x hx).inverse (x::xs))

theorem dpll_correct : ∀ (c : cnf α), dpll c ↔ satisfiable c
| [] := by simp only [dpll, satisfiable_empty, coe_sort_tt]
| (x::xs) := if h : [] ∈ x::xs then by simpa [dpll, h] using not_satisfiable_of_empty_mem h else
    have hx : x ≠ [], from λ hx, h $ or.inl hx.symm,
    have h1 : sizeof (unit_propagate (any_literal x hx) (x::xs)) < sizeof (x::xs),
      from sizeof_unit_propagate_of_mem (or.inl (any_literal_mem hx)) (list.mem_cons_self _ _),
    have h2 : sizeof (unit_propagate (any_literal x hx).inverse (x::xs)) < sizeof (x::xs), by
    { refine sizeof_unit_propagate_of_mem (or.inr _) (list.mem_cons_self _ _),
      simpa only [literal.inverse_inverse] using any_literal_mem hx },
    begin
      simp only [dpll, h, dpll_correct, bor_coe_iff, bor, dif_neg, not_false_iff, literal.inverse],
      clear h1 h2,
      refine ⟨_, _⟩,
      { rintro (hr|hr),
        { apply satisfiable_of_satisfiable_unit_propagate hr },
        { apply satisfiable_of_satisfiable_unit_propagate hr } },
      { rintro ⟨ι, hι⟩,
        by_cases hlι : literal.satisfied ι (any_literal x hx),
        { exact or.inl ⟨ι, (satisfied_unit_propagate _ hlι).2 hι⟩ },
        { refine or.inr ⟨ι, (satisfied_unit_propagate _ _).2 hι⟩,
          simpa only [literal.satisfied_inverse] using hlι } }
    end

section
open literal

#eval dpll [[pos 5], [neg 5, pos 6], [neg 6]]

end

end cnf


import lambda_calculus.utlc.beta.distance
import complexity.basic

/-
 - Define complexity in terms of the number of β reductions
 - Programs and data need to be closed,
 -  additionally data needs to be fully reduced such that equivalence implies equality
 -/

namespace lambda_calculus
namespace utlc
namespace β
namespace encoding

structure encoded_program :=
mk :: (value: utlc) (proof: value.closed)

inductive encoding_type
| church
| scott
| compute

structure encoded_data (_: encoding_type) :=
mk :: (value: utlc) (proof: value.closed ∧ β.reduced value)

instance (et: encoding_type): has_equiv (encoded_data et) := ⟨ λ a b : encoded_data et, a.value = b.value ⟩

@[reducible, simp] def church_data := encoded_data encoding_type.church
@[reducible, simp] def scott_data := encoded_data encoding_type.scott
@[reducible, simp] def compute_data := encoded_data encoding_type.compute

local attribute [reducible] closed

def distance_model (et: encoding_type): complexity.model encoded_program (encoded_data et) ℕ :=
 ⟨ λ prog data cost, distance_le cost prog.value data.value,
   λ prog data, ⟨ prog.value·data.value, by simp [closed, prog.proof, data.proof.left] ⟩,
   λ prog x y cx cy hx hy, reduced_equiv_inj x.proof.right y.proof.right (equiv_trans (equiv_symm (equiv_of_distance_le hx)) (equiv_of_distance_le hy)),
   λ prog data c₀ c₁, distance_le_mono' ⟩

@[reducible, simp] def church_model := distance_model encoding_type.church
@[reducible, simp] def scott_model := distance_model encoding_type.scott
@[reducible, simp] def compute_model := distance_model encoding_type.compute

@[simp] theorem program_is_closed (a: encoded_program):
  a.value.closed := a.proof

@[simp] theorem program_is_closed_below (a: encoded_program):
  ∀ n, a.value.closed_below n :=
  λ n, closed_below_mono' a.proof (nat.zero_le _)

@[simp] theorem program_ignores_shift (a: encoded_program) (n: ℕ):
  a.value ↑¹ n = a.value := by rw [shift_of_closed a.proof]

@[simp] theorem program_ignores_substitution (a: encoded_program) (n: ℕ) (g: utlc):
  has_substitution.substitution a.value n g = a.value := by rw [substitution_of_closed a.proof]

variable {et: encoding_type}

@[simp] theorem data_is_closed (a: encoded_data et):
  a.value.closed := a.proof.left

@[simp] theorem data_is_closed_below (a: encoded_data et):
  ∀ n, a.value.closed_below n :=
  λ n, closed_below_mono' a.proof.left (nat.zero_le _)

@[simp] theorem data_is_closed_below' {α: Type}
  [f: complexity.has_encoding (distance_model et) α]
  (a: α) : ∀ n, (f.value.encode a).value.closed_below n :=
  λ n, closed_below_mono' (f.value.encode a).proof.left (nat.zero_le _)

@[simp] theorem data_is_reduced (a: encoded_data et):
   reduced a.value := a.proof.right

@[simp] theorem data_is_reduced' {α: Type}
  [f: complexity.has_encoding (distance_model et) α]
  (a: α) : reduced (f.value.encode a).value :=
  (f.value.encode a).proof.right

@[simp] theorem value_inj (a b: encoded_data et):
  a ≈ b ↔ a.value = b.value := by refl

@[simp] theorem data_value_inj {α: Type}
  [f: complexity.has_encoding (distance_model et) α] (a b: α):
  (f.value.encode a).value = (f.value.encode b).value ↔ a = b :=
by rw [← value_inj, complexity.encoding.inj_iff]

@[simp] theorem data_ignores_shift (a: encoded_data et) (n: ℕ):
  a.value ↑¹ n = a.value := by rw [shift_of_closed a.proof.left]

@[simp] theorem data_ignores_substitution (a: encoded_data et) (n: ℕ) (g: utlc):
  has_substitution.substitution a.value n g = a.value := by rw [substitution_of_closed a.proof.left]

end encoding
end β
end utlc
end lambda_calculus


import algebraic_geometry.AffineScheme
import for_mathlib.localized_module

open category_theory category_theory.limits opposite topological_space

namespace algebraic_geometry

universes v u

namespace structure_sheaf

noncomputable theory

open Spec

variables {R S : CommRing.{u}} (f : R ⟶ S) (p : prime_spectrum R)

/--
For an algebra `f : R →+* S`, this is the ring homomorphism `S →+* (f∗ 𝒪ₛ)ₚ` for a `p : Spec R`.
This is shown to be the localization at `p` in `is_localized_module_to_pushforward_stalk_alg_hom`.
-/
def to_pushforward_stalk :
  S ⟶ (Spec.Top_map f _* (structure_sheaf S).1).stalk p :=
structure_sheaf.to_open S ⊤ ≫
  @Top.presheaf.germ _ _ _ _ (Spec.Top_map f _* (structure_sheaf S).1) ⊤ ⟨p, trivial⟩

@[reassoc]
lemma to_pushforward_stalk_comp :
  f ≫ structure_sheaf.to_pushforward_stalk f p =
  structure_sheaf.to_stalk R p ≫
    (Top.presheaf.stalk_functor _ _).map (Spec.SheafedSpace_map f).c :=
begin
  rw structure_sheaf.to_stalk,
  erw category.assoc,
  rw Top.presheaf.stalk_functor_map_germ,
  exact Spec_Γ_naturality_assoc f _,
end

instance : algebra R ((Spec.Top_map f _* (structure_sheaf S).1).stalk p) :=
(f ≫ structure_sheaf.to_pushforward_stalk f p).to_algebra

lemma algebra_map_pushforward_stalk :
  algebra_map R ((Spec.Top_map f _* (structure_sheaf S).1).stalk p) =
    f ≫ structure_sheaf.to_pushforward_stalk f p := rfl

instance pushforward_stalk_algebra : algebra ((structure_sheaf R).presheaf.stalk p)
  ((Spec.Top_map f _* (structure_sheaf S).1).stalk p) :=
begin
  apply ring_hom.to_algebra,
  refine (@Top.presheaf.stalk_functor CommRing _ _ (Scheme.Spec.obj $ op R).carrier p).map _,
  exact (Scheme.Spec.map f.op).1.c
end

lemma algebra_map_pushforward_stalk_algebra :
  algebra_map ((structure_sheaf R).presheaf.stalk p)
    ((Spec.Top_map f _* (structure_sheaf S).1).stalk p) =
    (@Top.presheaf.stalk_functor CommRing _ _ (Scheme.Spec.obj $ op R).carrier p).map
      (Scheme.Spec.map f.op).1.c := rfl

instance : is_scalar_tower R ((structure_sheaf R).presheaf.stalk p)
  ((Spec.Top_map f _* (structure_sheaf S).1).stalk p) :=
begin
  apply is_scalar_tower.of_algebra_map_eq',
  exact to_pushforward_stalk_comp f p,
end

variables (R S) [algebra R S]

/--
This is the `alg_hom` version of `to_pushforward_stalk`, which is the map `S ⟶ (f∗ 𝒪ₛ)ₚ` for some
algebra `R ⟶ S` and some `p : Spec R`.
-/
@[simps]
def to_pushforward_stalk_alg_hom :
  S →ₐ[R] (Spec.Top_map (algebra_map R S) _* (structure_sheaf S).1).stalk p :=
{ commutes' := λ _, rfl, ..(structure_sheaf.to_pushforward_stalk (algebra_map R S) p) }

.
lemma is_localized_module_to_pushforward_stalk_alg_hom_aux (y) :
  ∃ (x : S × p.as_ideal.prime_compl), x.2 • y = to_pushforward_stalk_alg_hom R S p x.1 :=
begin
  obtain ⟨U, hp, s, e⟩ := Top.presheaf.germ_exist _ _ y,
  obtain ⟨_, ⟨r, rfl⟩, hpr, hrU⟩ := prime_spectrum.is_topological_basis_basic_opens
    .exists_subset_of_mem_open (show p ∈ U.1, from hp) U.2,
  change prime_spectrum.basic_open r ≤ U at hrU,
  replace e := ((Spec.Top_map (algebra_map R S) _* (structure_sheaf S).1)
    .germ_res_apply (hom_of_le hrU) ⟨p, hpr⟩ _).trans e,
  set s' := (Spec.Top_map (algebra_map R S) _* (structure_sheaf S).1).map (hom_of_le hrU).op s
    with h,
  rw ← h at e,
  clear_value s', clear_dependent U,
  obtain ⟨⟨s, ⟨_, n, rfl⟩⟩, hsn⟩ := @is_localization.surj _ _ _
    _ _ _ (structure_sheaf.is_localization.to_basic_open S $ algebra_map R S r) s',
  refine ⟨⟨s, ⟨r, hpr⟩ ^ n⟩, _⟩,
  rw [submonoid.smul_def, algebra.smul_def, algebra_map_pushforward_stalk, to_pushforward_stalk,
    comp_apply, comp_apply],
  iterate 2 { erw ← (Spec.Top_map (algebra_map R S) _* (structure_sheaf S).1).germ_res_apply
    (hom_of_le le_top) ⟨p, hpr⟩ },
  rw [← e, ← map_mul, mul_comm],
  dsimp only [subtype.coe_mk] at hsn,
  rw ← map_pow (algebra_map R S) at hsn,
  congr' 1
end

instance is_localized_module_to_pushforward_stalk_alg_hom :
  is_localized_module p.as_ideal.prime_compl (to_pushforward_stalk_alg_hom R S p).to_linear_map :=
begin
  apply is_localized_module.mk_of_algebra,
  { intros x hx, rw [algebra_map_pushforward_stalk, to_pushforward_stalk_comp, comp_apply],
    exact (is_localization.map_units ((structure_sheaf R).presheaf.stalk p) ⟨x, hx⟩).map _ },
  { apply is_localized_module_to_pushforward_stalk_alg_hom_aux },
  { intros x hx,
    rw [to_pushforward_stalk_alg_hom_apply, ring_hom.to_fun_eq_coe,
      ← (to_pushforward_stalk (algebra_map R S) p).map_zero, to_pushforward_stalk, comp_apply,
      comp_apply, map_zero] at hx,
    obtain ⟨U, hpU, i₁, i₂, e⟩ := Top.presheaf.germ_eq _ _ _ _ _ _ hx,
    obtain ⟨_, ⟨r, rfl⟩, hpr, hrU⟩ := prime_spectrum.is_topological_basis_basic_opens
      .exists_subset_of_mem_open (show p ∈ U.1, from hpU) U.2,
    change prime_spectrum.basic_open r ≤ U at hrU,
    apply_fun (Spec.Top_map (algebra_map R S) _* (structure_sheaf S).1).map (hom_of_le hrU).op at e,
    simp only [Top.presheaf.pushforward_obj_map, functor.op_map, map_zero, ← comp_apply,
      to_open_res] at e,
    have : to_open S (prime_spectrum.basic_open $ algebra_map R S r) x = 0,
    { refine eq.trans _ e, refl },
    have := (@is_localization.mk'_one _ _ _
      _ _ _ (structure_sheaf.is_localization.to_basic_open S $ algebra_map R S r) x).trans this,
    obtain ⟨⟨_, n, rfl⟩, e⟩ := (is_localization.mk'_eq_zero_iff _ _).mp this,
    refine ⟨⟨r, hpr⟩ ^ n, _⟩,
    rw [submonoid.smul_def, algebra.smul_def, submonoid.coe_pow, subtype.coe_mk, mul_comm, map_pow],
    exact e },
end
.

instance {R A : Type*} [comm_ring R] [comm_ring A] [algebra R A] (S : submonoid R)
  [H : is_localization S A] : is_localized_module S (algebra.of_id R A).to_linear_map :=
begin
  apply is_localized_module.mk_of_algebra,
  { exact λ x hx, H.1 ⟨x, hx⟩ },
  { simp_rw [submonoid.smul_def, algebra.smul_def, mul_comm], exact H.2 },
  { intros x hx, rw ← (algebra.of_id R A).map_zero at hx,
    simpa [submonoid.smul_def, mul_comm] using H.3.mp hx }
end

lemma _root_.algebraic_geometry.Spec.localized_module_map_iso_stalk_map :
  (is_localized_module.iso p.as_ideal.prime_compl
    (to_pushforward_stalk_alg_hom R S p).to_linear_map).to_linear_map.comp
    ((localized_module.map p.as_ideal.prime_compl
      (algebra.of_id R S).to_linear_map).restrict_scalars R) =
  (is_scalar_tower.to_alg_hom _ _ _).to_linear_map.comp
  (is_localized_module.iso p.as_ideal.prime_compl
    (algebra.of_id R ((structure_sheaf R).presheaf.stalk p)).to_linear_map).to_linear_map :=
begin
  ext x,
  induction x using localized_module.induction_on,
  rw [linear_map.comp_apply, linear_map.restrict_scalars_apply, localized_module.map_mk],
  refine is_localized_module.mk'_eq_iff.mpr _,
  rw [submonoid.smul_def, linear_map.comp_apply, ← linear_map.map_smul,
    linear_equiv.coe_to_linear_map, is_localized_module.iso_mk, ← is_localized_module.mk'_smul,
    ← submonoid.smul_def, is_localized_module.mk'_cancel],
  dsimp only [alg_hom.to_linear_map_apply, algebra.of_id_apply, is_scalar_tower.to_alg_hom_apply],
  rw ← is_scalar_tower.algebra_map_apply,
  refl,
end

lemma _root_.algebraic_geometry.Spec.localized_module_map_iso_stalk_map' :
  ((localized_module.map p.as_ideal.prime_compl
      (algebra.of_id R S).to_linear_map).restrict_scalars R) =
  (is_localized_module.iso p.as_ideal.prime_compl
    (to_pushforward_stalk_alg_hom R S p).to_linear_map).symm.to_linear_map.comp
  ((is_scalar_tower.to_alg_hom _ _ _).to_linear_map.comp
  (is_localized_module.iso p.as_ideal.prime_compl
    (algebra.of_id R ((structure_sheaf R).presheaf.stalk p)).to_linear_map).to_linear_map) :=
begin
  rw ← _root_.algebraic_geometry.Spec.localized_module_map_iso_stalk_map,
  ext1,
  exact (linear_equiv.symm_apply_apply _ _).symm
end

end structure_sheaf

end algebraic_geometry


example : ∃ n : Nat, n = n := by
  refine ⟨?n, ?h⟩
  case h => exact Eq.refl 3

example : ∃ n : Nat, n = n := by
  refine ⟨?n, ?h⟩
  case h => exact rfl
  case n => exact 3

example : ∃ n : Nat, n = n := by
  refine ⟨?n, by rfl⟩
  case n => exact 3

example : ∃ n : Nat, n = n := by
  refine ⟨?n, ?h⟩
  case h =>
    refine rfl
    case n => exact 3


import algebraic_topology.simplex_category
import algebraic_topology.simplicial_set
import algebraic_topology.simplicial_object
import category_theory.arrow
import category_theory.discrete_category
import category_theory.limits.shapes.terminal
import category_theory.limits.shapes.products
import category_theory.limits.shapes.equalizers
import category_theory.limits.presheaf
import category_theory.limits.preserves.shapes.equalizers

import simplex_category

open category_theory

noncomputable theory

open_locale simplicial

universe u

variable n : ℕ

structure boundary_part :=
  mk :: (i j : fin (n + 2)) (h : i ≤ j)

structure end_part :=
  mk :: (i : fin (n + 3))

def boundary_f (p : boundary_part n) := Δ[n]
def simplex_f (p : end_part n) := Δ[n+1]

def boundary_start := ∐ (boundary_f n)

def simplex_end := ∐ (simplex_f n)

def morph_boundary_1 : boundary_start n ⟶ simplex_end n :=
  limits.sigma.desc
    (λ idx : boundary_part n, yoneda.map (simplex_category.δ idx.i)
      ≫ (limits.sigma.ι (simplex_f n) ⟨idx.j.succ⟩))

def morph_boundary_2 : boundary_start n ⟶ simplex_end n :=
  limits.sigma.desc
    (λ idx, yoneda.map (simplex_category.δ idx.j)
      ≫ (limits.sigma.ι (simplex_f n) ⟨idx.i.cast_succ⟩))

def boundary_morphism : simplex_end n ⟶ ∂Δ[n + 2] :=
  limits.sigma.desc (λ b, yoneda_equiv.inv_fun ⟨simplex_category.δ b.i, by {
    simp only [not_exists, not_forall, coe_coe],
    use b.i,
    intros x,
    exact fin.succ_above_ne _ _,
  }⟩)

lemma boundary_coeq : morph_boundary_1 n ≫ boundary_morphism n = morph_boundary_2 n ≫ boundary_morphism n :=
begin
  rewrite [boundary_morphism, morph_boundary_1, morph_boundary_2],
  apply limits.colimit.hom_ext,
  simp only [limits.cofan.mk_ι_app, limits.colimit.ι_desc, limits.colimit.ι_desc_assoc, coe_coe,
    equiv.inv_fun_as_coe, category.assoc],
  intro idx,
  rw [←equiv.apply_eq_iff_eq yoneda_equiv],
  rw [←yoneda_equiv_naturality, ←yoneda_equiv_naturality],
  rw [equiv.apply_symm_apply, equiv.apply_symm_apply],
  dsimp only [sSet.boundary, simplex_category.hom.to_order_hom, coe_coe],
  simp only [quiver.hom.unop_op, subtype.coe_mk],
  cases idx with i j h,
  simp only [function.embedding.to_fun_eq_coe, rel_embedding.coe_fn_to_embedding],
  exact simplex_category.δ_comp_δ h,
end

def boundary_fork := limits.cofork.of_π (boundary_morphism n) (boundary_coeq n)

def boundary_hole {m n} (f : [m] ⟶ [n + 1]) (h : ¬ function.surjective f.to_order_hom)
  : ∃ i, i ∉ set.range f.to_order_hom :=
begin
  simp only [not_forall, not_exists] at h,
  cases h,
  use h_w,
  simpa only [set.mem_range, not_exists],
end

-- def boundary_colim : limits.is_colimit (boundary_fork n) :=
-- begin
--   apply limits.cofork.is_colimit.mk, swap 3,
--   focus {
--     intro s,
--     dsimp [boundary_fork],
--     refine nat_trans.mk _ _,
--     focus {
--       intros X f,
--       let m := X.unop.len,
--       have hX : X = opposite.op [m] := by simp only [simplex_category.mk_len, opposite.op_unop],
--       clear_value m,
--       subst hX,
--       cases f,
--       apply yoneda_equiv.to_fun,
--       dsimp [sSet.standard_simplex] at f_val,
--       refine _ ≫ _,
--       exact Δ[n + 1],
--       apply yoneda_equiv.inv_fun,
--       exact nonsurj_fun f_val f_property,
--       refine _ ≫ s.π,
--       exact limits.sigma.ι (simplex_f n) ⟨nonsurj_index f_val f_property⟩,
--     },
--     focus {
--       intros X Y f,
--       have sn := s.π.naturality f,
--       let m := X.unop.len, let k := Y.unop.len,
--       have hX : X = opposite.op [m] := by simp only [simplex_category.mk_len, opposite.op_unop],
--       have hY : Y = opposite.op [k] := by simp only [simplex_category.mk_len, opposite.op_unop],
--       clear_value m k,
--       subst hX, subst hY,
--       ext1,
--       dsimp [sSet.boundary, sSet.standard_simplex, simplex_end] at *,
--       cases x,
--       simp only [order_hom.comp_id, simplex_category.hom.mk_to_order_hom],
--       have sn' : ∀ x, ((∐ simplex_f n).map f ≫ s.π.app (opposite.op [k])) x
--         = (s.π.app (opposite.op [m]) ≫ s.X.map f) x := by { intro, rw [sn], },
--       simp only [types_comp_apply] at sn',
--       rw ←sn',
--       have cf := limits.cofork.condition s,
--       dsimp [morph_boundary_1, morph_boundary_2] at cf,
--     },

--     --have df := nonsurj_decomposition f_val f_property,
--   },
-- end


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import for_mathlib.dold_kan.decomposition

/-!

# Behaviour of P_infty with respect to degeneracies

For any `X : simplicial_object C` where `C` is an abelian category,
the projector `P_infty : K[X] ⟶ K[X]` is supposed to be the projection
on the normalized subcomplex, parallel to the degenerate subcomplex, i.e.
the subcomplex generated by the images of all `X.σ i`.

In this file, we obtain `degeneracy_comp_P_infty` which states that
if `X : simplicial_object C` with `C` a preadditive category,
`θ : [n] ⟶ Δ'` is a non injective map in `simplex_category`, then
`X.map θ.op ≫ P_infty.f n = 0`. It follows from the more precise
statement vanishing statement `σ_comp_P_eq_zero` for the `P q`.

-/

open category_theory category_theory.category category_theory.limits
  category_theory.preadditive opposite
open_locale simplicial dold_kan

namespace algebraic_topology

namespace dold_kan

variables {C : Type*} [category C] [preadditive C]

lemma higher_faces_vanish.comp_σ {Y : C} {X : simplicial_object C} {n b q : ℕ} {φ : Y ⟶ X _[n+1]}
  (v : higher_faces_vanish q φ) (hnbq : n + 1 = b + q) :
    higher_faces_vanish q (φ ≫ X.σ ⟨b,
    by simpa only [hnbq, nat.lt_succ_iff, le_add_iff_nonneg_right] using zero_le q⟩) :=
λ j hj, begin
  rw [assoc, simplicial_object.δ_comp_σ_of_gt', fin.pred_succ,
    v.comp_δ_eq_zero_assoc _ _ hj, zero_comp],
  { intro hj',
    simpa only [hj', hnbq, fin.coe_zero, zero_add, add_comm b, add_assoc, false_and,
      add_le_iff_nonpos_right, le_zero_iff, add_eq_zero_iff, nat.one_ne_zero] using hj, },
  { simp only [fin.lt_iff_coe_lt_coe, nat.lt_iff_add_one_le,
      fin.succ_mk, fin.coe_mk, fin.coe_succ, add_le_add_iff_right],
    linarith, },
end

lemma σ_comp_P_eq_zero (X : simplicial_object C)
  {n q : ℕ} (i : fin (n + 1)) (hi : n + 1 ≤ i + q) : (X.σ i) ≫ (P q).f (n + 1) = 0 :=
begin
  induction q with q hq generalizing i hi,
  { exfalso,
    have h := fin.is_lt i,
    linarith, },
  { by_cases n+1 ≤ (i : ℕ) + q,
    { unfold P,
      simp only [homological_complex.comp_f, ← assoc],
      rw [hq i h, zero_comp], },
    { have hi' : n = (i : ℕ) + q,
      { cases le_iff_exists_add.mp hi with j hj,
        rw [← nat.lt_succ_iff, nat.succ_eq_add_one, add_assoc, hj, not_lt,
          add_le_iff_nonpos_right, nonpos_iff_eq_zero] at h,
        rw [← add_left_inj 1, add_assoc, hj, self_eq_add_right, h], },
      cases n,
      { fin_cases i,
        rw [show q = 0, by linarith],
        unfold P,
        simp only [id_comp, homological_complex.add_f_apply, comp_add, homological_complex.id_f,
          Hσ, homotopy.null_homotopic_map'_f (c_mk 2 1 rfl) (c_mk 1 0 rfl),
          alternating_face_map_complex.obj_d_eq],
        erw [hσ'_eq' (zero_add 0).symm, hσ'_eq' (add_zero 1).symm, comp_id,
          fin.sum_univ_two, fin.sum_univ_succ, fin.sum_univ_two],
        simp only [pow_zero, pow_one, pow_two, fin.coe_zero, fin.coe_one, fin.coe_two,
          one_zsmul, neg_zsmul, fin.mk_zero, fin.mk_one, fin.coe_succ, pow_add, one_mul,
          neg_mul, neg_neg, fin.succ_zero_eq_one, fin.succ_one_eq_two, comp_neg, neg_comp,
          add_comp, comp_add],
        erw [simplicial_object.δ_comp_σ_self, simplicial_object.δ_comp_σ_self_assoc,
          simplicial_object.δ_comp_σ_succ, comp_id, simplicial_object.δ_comp_σ_of_le X
            (show (0 : fin(2)) ≤ fin.cast_succ 0, by rw fin.cast_succ_zero),
          simplicial_object.δ_comp_σ_self_assoc, simplicial_object.δ_comp_σ_succ_assoc],
        abel, },
      { rw [← id_comp (X.σ i), ← (P_add_Q_f q n.succ : _ = 𝟙 (X.obj _)), add_comp, add_comp],
        have v : higher_faces_vanish q ((P q).f n.succ ≫ X.σ i) :=
          (higher_faces_vanish.of_P q n).comp_σ hi',
        unfold P,
        erw [← assoc, v.comp_P_eq_self, homological_complex.add_f_apply,
          preadditive.comp_add, comp_id, v.comp_Hσ_eq hi', assoc,
          simplicial_object.δ_comp_σ_succ'_assoc, fin.eta,
          decomposition_Q n q, sum_comp, sum_comp, finset.sum_eq_zero, add_zero,
          add_neg_eq_zero], swap,
        { ext, simp only [fin.coe_mk, fin.coe_succ], },
        { intros j hj,
          simp only [true_and, finset.mem_univ, finset.mem_filter] at hj,
          simp only [nat.succ_eq_add_one] at hi',
          obtain ⟨k, hk⟩ := nat.le.dest (nat.lt_succ_iff.mp (fin.is_lt j)),
          rw add_comm at hk,
          have hi'' : i = fin.cast_succ ⟨i, by linarith⟩ :=
            by { ext, simp only [fin.cast_succ_mk, fin.eta], },
          have eq := hq j.rev.succ begin
            simp only [← hk, fin.rev_eq j hk.symm, nat.succ_eq_add_one, fin.succ_mk, fin.coe_mk],
            linarith,
          end,
          rw [homological_complex.comp_f, assoc, assoc, assoc, hi'',
            simplicial_object.σ_comp_σ_assoc, reassoc_of eq, zero_comp, comp_zero,
            comp_zero, comp_zero],
          simp only [fin.rev_eq j hk.symm, fin.le_iff_coe_le_coe, fin.coe_mk],
          linarith, }, }, }, }
end

@[simp, reassoc]
lemma σ_comp_P_infty (X : simplicial_object C) {n : ℕ} (i : fin (n+1)) :
  (X.σ i) ≫ P_infty.f (n+1) = 0 :=
begin
  rw [P_infty_f, σ_comp_P_eq_zero X i],
  simp only [le_add_iff_nonneg_left, zero_le],
end

@[reassoc]
lemma degeneracy_comp_P_infty (X : simplicial_object C)
  (n : ℕ) {Δ' : simplex_category} (θ : [n] ⟶ Δ') (hθ : ¬mono θ) :
  X.map θ.op ≫ P_infty.f n = 0 :=
begin
  rw simplex_category.mono_iff_injective at hθ,
  cases n,
  { exfalso,
    apply hθ,
    intros x y h,
    fin_cases x,
    fin_cases y, },
  { obtain ⟨i, α, h⟩ := simplex_category.eq_σ_comp_of_not_injective θ hθ,
    rw [h, op_comp, X.map_comp, assoc, (show X.map (simplex_category.σ i).op = X.σ i, by refl),
      σ_comp_P_infty, comp_zero], },
end

end dold_kan

end algebraic_topology


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import topology.opens
import ring_theory.ideal.prod
import ring_theory.ideal.over
import linear_algebra.finsupp
import algebra.punit_instances
import ring_theory.nilpotent
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 _ $ is_field.to_field R h) },
    { 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}`.

TODO: maybe define sober topological spaces, and generalise this instance to those
-/

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 _)
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