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

! This file was ported from Lean 3 source module algebraic_topology.dold_kan.decomposition
! leanprover-community/mathlib commit 9af20344b24ef1801b599d296aaed8b9fffdc360
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.AlgebraicTopology.DoldKan.PInfty

/-!

# Decomposition of the Q endomorphisms

In this file, we obtain a lemma `decomposition_Q` which expresses
explicitly the projection `(Q q).f (n+1) : X _[n+1] ⟶ X _[n+1]`
(`X : simplicial_object C` with `C` a preadditive category) as
a sum of terms which are postcompositions with degeneracies.

(TODO @joelriou: when `C` is abelian, define the degenerate
subcomplex of the alternating face map complex of `X` and show
that it is a complement to the normalized Moore complex.)

Then, we introduce an ad hoc structure `morph_components X n Z` which
can be used in order to define morphisms `X _[n+1] ⟶ Z` using the
decomposition provided by `decomposition_Q`. This shall play a critical
role in the proof that the functor
`N₁ : simplicial_object C ⥤ karoubi (chain_complex C ℕ))`
reflects isomorphisms.

-/

open CategoryTheory CategoryTheory.Category CategoryTheory.Preadditive Opposite

open BigOperators Simplicial

noncomputable section

namespace AlgebraicTopology

namespace DoldKan

variable {C : Type _} [Category C] [Preadditive C] {X X' : SimplicialObject C}

/-- In each positive degree, this lemma decomposes the idempotent endomorphism
`Q q` as a sum of morphisms which are postcompositions with suitable degeneracies.
As `Q q` is the complement projection to `P q`, this implies that in the case of
simplicial abelian groups, any $(n+1)$-simplex $x$ can be decomposed as
$x = x' + \sum (i=0}^{q-1} σ_{n-i}(y_i)$ where $x'$ is in the image of `P q` and
the $y_i$ are in degree $n$. -/
theorem decomposition_q (n q : ℕ) :
    ((q q).f (n + 1) : X _[n + 1] ⟶ X _[n + 1]) =
      ∑ i : Fin (n + 1) in Finset.filter (fun i : Fin (n + 1) => (i : ℕ) < q) Finset.univ,
        (p i).f (n + 1) ≫ X.δ i.rev.succ ≫ X.σ i.rev :=
  by
  induction' q with q hq
  ·
    simp only [Q_eq_zero, HomologicalComplex.zero_f_apply, Nat.not_lt_zero, Finset.filter_False,
      Finset.sum_empty]
  · by_cases hqn : q + 1 ≤ n + 1
    swap
    · rw [Q_is_eventually_constant (show n + 1 ≤ q by linarith), hq]
      congr
      ext
      have hx := x.is_lt
      simp only [Nat.succ_eq_add_one]
      constructor <;> intro h <;> linarith
    · cases' Nat.le.dest (nat.succ_le_succ_iff.mp hqn) with a ha
      rw [Q_eq, HomologicalComplex.sub_f_apply, HomologicalComplex.comp_f, hq]
      symm
      conv_rhs => rw [sub_eq_add_neg, add_comm]
      let q' : Fin (n + 1) := ⟨q, nat.succ_le_iff.mp hqn⟩
      convert Finset.sum_insert (_ : q' ∉ _)
      · ext i
        simp only [Finset.mem_insert, Finset.mem_filter, Finset.mem_univ, true_and_iff,
          Nat.lt_succ_iff_lt_or_eq, Fin.ext_iff]
        tauto
      · have hnaq' : n = a + q := by linarith
        simpa only [Fin.val_mk, (higher_faces_vanish.of_P q n).comp_hσ_eq hnaq', q'.rev_eq hnaq',
          neg_neg]
      · simp only [Finset.mem_filter, Fin.val_mk, lt_self_iff_false, and_false_iff, not_false_iff]
#align algebraic_topology.dold_kan.decomposition_Q AlgebraicTopology.DoldKan.decomposition_q

variable (X)

/-- The structure `morph_components` is an ad hoc structure that is used in
the proof that `N₁ : simplicial_object C ⥤ karoubi (chain_complex C ℕ))`
reflects isomorphisms. The fields are the data that are needed in order to
construct a morphism `X _[n+1] ⟶ Z` (see `φ`) using the decomposition of the
identity given by `decomposition_Q n (n+1)`. -/
@[ext, nolint has_nonempty_instance]
structure MorphComponents (n : ℕ) (Z : C) where
  a : X _[n + 1] ⟶ Z
  b : Fin (n + 1) → (X _[n] ⟶ Z)
#align algebraic_topology.dold_kan.morph_components AlgebraicTopology.DoldKan.MorphComponents

namespace MorphComponents

variable {X} {n : ℕ} {Z Z' : C} (f : MorphComponents X n Z) (g : X' ⟶ X) (h : Z ⟶ Z')

/-- The morphism `X _[n+1] ⟶ Z ` associated to `f : morph_components X n Z`. -/
def φ {Z : C} (f : MorphComponents X n Z) : X _[n + 1] ⟶ Z :=
  pInfty.f (n + 1) ≫ f.a + ∑ i : Fin (n + 1), (p i).f (n + 1) ≫ X.δ i.rev.succ ≫ f.b i.rev
#align algebraic_topology.dold_kan.morph_components.φ AlgebraicTopology.DoldKan.MorphComponents.φ

variable (X n)

/-- the canonical `morph_components` whose associated morphism is the identity
(see `F_id`) thanks to `decomposition_Q n (n+1)` -/
@[simps]
def id : MorphComponents X n (X _[n + 1])
    where
  a := pInfty.f (n + 1)
  b i := X.σ i
#align algebraic_topology.dold_kan.morph_components.id AlgebraicTopology.DoldKan.MorphComponents.id

@[simp]
theorem id_φ : (id X n).φ = 𝟙 _ :=
  by
  simp only [← P_add_Q_f (n + 1) (n + 1), φ]
  congr 1
  · simp only [id, P_infty_f, P_f_idem]
  · convert(decomposition_Q n (n + 1)).symm
    ext i
    simpa only [Finset.mem_univ, Finset.mem_filter, true_and_iff, true_iff_iff] using Fin.is_lt i
#align algebraic_topology.dold_kan.morph_components.id_φ AlgebraicTopology.DoldKan.MorphComponents.id_φ

variable {X n}

/-- A `morph_components` can be postcomposed with a morphism. -/
@[simps]
def postComp : MorphComponents X n Z' where
  a := f.a ≫ h
  b i := f.b i ≫ h
#align algebraic_topology.dold_kan.morph_components.post_comp AlgebraicTopology.DoldKan.MorphComponents.postComp

@[simp]
theorem postComp_φ : (f.postComp h).φ = f.φ ≫ h :=
  by
  unfold φ post_comp
  simp only [add_comp, sum_comp, assoc]
#align algebraic_topology.dold_kan.morph_components.post_comp_φ AlgebraicTopology.DoldKan.MorphComponents.postComp_φ

/-- A `morph_components` can be precomposed with a morphism of simplicial objects. -/
@[simps]
def preComp : MorphComponents X' n Z
    where
  a := g.app (op [n + 1]) ≫ f.a
  b i := g.app (op [n]) ≫ f.b i
#align algebraic_topology.dold_kan.morph_components.pre_comp AlgebraicTopology.DoldKan.MorphComponents.preComp

@[simp]
theorem preComp_φ : (f.preComp g).φ = g.app (op [n + 1]) ≫ f.φ :=
  by
  unfold φ pre_comp
  simp only [P_infty_f, comp_add]
  congr 1
  · simp only [P_f_naturality_assoc]
  · simp only [comp_sum, P_f_naturality_assoc, simplicial_object.δ_naturality_assoc]
#align algebraic_topology.dold_kan.morph_components.pre_comp_φ AlgebraicTopology.DoldKan.MorphComponents.preComp_φ

end MorphComponents

end DoldKan

end AlgebraicTopology


/-
Copyright (c) 2022 Alex J. Best, Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alex J. Best, Yaël Dillies
-/
import algebra.order.archimedean
import algebra.order.hom.monoid
import algebra.order.ring.defs
import algebra.ring.equiv
import tactic.by_contra
import tactic.wlog

/-!
# Ordered ring homomorphisms

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

Homomorphisms between ordered (semi)rings that respect the ordering.

## Main definitions

* `order_ring_hom` : Monotone semiring homomorphisms.
* `order_ring_iso` : Monotone semiring isomorphisms.

## Notation

* `→+*o`: Ordered ring homomorphisms.
* `≃+*o`: Ordered ring isomorphisms.

## Tags

ordered ring homomorphism, order homomorphism
-/

open function

variables {F α β γ δ : Type*}

/-- `order_ring_hom α β` is the type of monotone semiring homomorphisms from `α` to `β`.

When possible, instead of parametrizing results over `(f : order_ring_hom α β)`,
you should parametrize over `(F : Type*) [order_ring_hom_class F α β] (f : F)`.

When you extend this structure, make sure to extend `order_ring_hom_class`. -/
structure order_ring_hom (α β : Type*) [non_assoc_semiring α] [preorder α] [non_assoc_semiring β]
  [preorder β]
  extends α →+* β :=
(monotone' : monotone to_fun)

/-- Reinterpret an ordered ring homomorphism as a ring homomorphism. -/
add_decl_doc order_ring_hom.to_ring_hom

infix ` →+*o `:25 := order_ring_hom

/-- `order_ring_hom α β` is the type of order-preserving semiring isomorphisms between `α` and `β`.

When possible, instead of parametrizing results over `(f : order_ring_iso α β)`,
you should parametrize over `(F : Type*) [order_ring_iso_class F α β] (f : F)`.

When you extend this structure, make sure to extend `order_ring_iso_class`. -/
structure order_ring_iso (α β : Type*) [has_mul α] [has_add α] [has_le α] [has_mul β] [has_add β]
  [has_le β] extends α ≃+* β :=
(map_le_map_iff' {a b : α} : to_fun a ≤ to_fun b ↔ a ≤ b)

infix ` ≃+*o `:25 := order_ring_iso

/-- `order_ring_hom_class F α β` states that `F` is a type of ordered semiring homomorphisms.
You should extend this typeclass when you extend `order_ring_hom`. -/
class order_ring_hom_class (F : Type*) (α β : out_param $ Type*) [non_assoc_semiring α] [preorder α]
  [non_assoc_semiring β] [preorder β] extends ring_hom_class F α β :=
(monotone (f : F) : monotone f)

/-- `order_ring_iso_class F α β` states that `F` is a type of ordered semiring isomorphisms.
You should extend this class when you extend `order_ring_iso`. -/
class order_ring_iso_class (F : Type*) (α β : out_param Type*) [has_mul α] [has_add α] [has_le α]
  [has_mul β] [has_add β] [has_le β]
  extends ring_equiv_class F α β :=
(map_le_map_iff (f : F) {a b : α} : f a ≤ f b ↔ a ≤ b)

@[priority 100] -- See note [lower priority instance]
instance order_ring_hom_class.to_order_add_monoid_hom_class [non_assoc_semiring α] [preorder α]
  [non_assoc_semiring β] [preorder β] [order_ring_hom_class F α β] :
  order_add_monoid_hom_class F α β :=
{ .. ‹order_ring_hom_class F α β› }

@[priority 100] -- See note [lower priority instance]
instance order_ring_hom_class.to_order_monoid_with_zero_hom_class [non_assoc_semiring α]
  [preorder α] [non_assoc_semiring β] [preorder β] [order_ring_hom_class F α β] :
  order_monoid_with_zero_hom_class F α β :=
{ .. ‹order_ring_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance order_ring_iso_class.to_order_iso_class [has_mul α] [has_add α] [has_le α] [has_mul β]
  [has_add β] [has_le β] [order_ring_iso_class F α β] :
  order_iso_class F α β :=
{ ..‹order_ring_iso_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance order_ring_iso_class.to_order_ring_hom_class [non_assoc_semiring α] [preorder α]
  [non_assoc_semiring β] [preorder β] [order_ring_iso_class F α β] :
  order_ring_hom_class F α β :=
{ monotone := λ f, order_hom_class.mono f, ..‹order_ring_iso_class F α β› }

instance [non_assoc_semiring α] [preorder α] [non_assoc_semiring β] [preorder β]
  [order_ring_hom_class F α β] :
  has_coe_t F (α →+*o β) :=
⟨λ f, ⟨f, order_hom_class.mono f⟩⟩

instance [has_mul α] [has_add α] [has_le α] [has_mul β] [has_add β] [has_le β]
  [order_ring_iso_class F α β] :
  has_coe_t F (α ≃+*o β) :=
⟨λ f, ⟨f, λ a b, map_le_map_iff f⟩⟩

/-! ### Ordered ring homomorphisms -/

namespace order_ring_hom
variables [non_assoc_semiring α] [preorder α]

section preorder
variables [non_assoc_semiring β] [preorder β] [non_assoc_semiring γ] [preorder γ]
  [non_assoc_semiring δ] [preorder δ]

/-- Reinterpret an ordered ring homomorphism as an ordered additive monoid homomorphism. -/
def to_order_add_monoid_hom (f : α →+*o β) : α →+o β := { ..f }

/-- Reinterpret an ordered ring homomorphism as an order homomorphism. -/
def to_order_monoid_with_zero_hom (f : α →+*o β) : α →*₀o β := { ..f }

instance : order_ring_hom_class (α →+*o β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by obtain ⟨⟨_, _⟩, _⟩ := f; obtain ⟨⟨_, _⟩, _⟩ := g; congr',
  map_mul := λ f, f.map_mul',
  map_one := λ f, f.map_one',
  map_add := λ f, f.map_add',
  map_zero := λ f, f.map_zero',
  monotone := λ f, f.monotone' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (α →+*o β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

lemma to_fun_eq_coe (f : α →+*o β) : f.to_fun = ⇑f := rfl
@[ext] lemma ext {f g : α →+*o β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

@[simp] lemma to_ring_hom_eq_coe (f : α →+*o β) : f.to_ring_hom = f := ring_hom.ext $ λ _, rfl
@[simp] lemma to_order_add_monoid_hom_eq_coe (f : α →+*o β) : f.to_order_add_monoid_hom = f := rfl
@[simp] lemma to_order_monoid_with_zero_hom_eq_coe (f : α →+*o β) :
  f.to_order_monoid_with_zero_hom = f := rfl

@[simp] lemma coe_coe_ring_hom (f : α →+*o β) : ⇑(f : α →+* β) = f := rfl
@[simp] lemma coe_coe_order_add_monoid_hom (f : α →+*o β) : ⇑(f : α →+o β) = f := rfl
@[simp] lemma coe_coe_order_monoid_with_zero_hom (f : α →+*o β) : ⇑(f : α →*₀o β) = f := rfl

@[norm_cast] lemma coe_ring_hom_apply (f : α →+*o β) (a : α) : (f : α →+* β) a = f a := rfl
@[norm_cast] lemma coe_order_add_monoid_hom_apply (f : α →+*o β) (a : α) : (f : α →+o β) a = f a :=
rfl
@[norm_cast] lemma coe_order_monoid_with_zero_hom_apply (f : α →+*o β) (a : α) :
  (f : α →*₀o β) a = f a := rfl

/-- Copy of a `order_ring_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : α →+*o β) (f' : α → β) (h : f' = f) : α →+*o β :=
{ .. f.to_ring_hom.copy f' h, .. f.to_order_add_monoid_hom.copy f' h }

@[simp] lemma coe_copy (f : α →+*o β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' := rfl
lemma copy_eq (f : α →+*o β) (f' : α → β) (h : f' = f) : f.copy f' h = f := fun_like.ext' h

variable (α)

/-- The identity as an ordered ring homomorphism. -/
protected def id : α →+*o α := { ..ring_hom.id _, ..order_hom.id }

instance : inhabited (α →+*o α) := ⟨order_ring_hom.id α⟩

@[simp] lemma coe_id : ⇑(order_ring_hom.id α) = id := rfl

variable {α}

@[simp] lemma id_apply (a : α) : order_ring_hom.id α a = a := rfl

@[simp] lemma coe_ring_hom_id : (order_ring_hom.id α : α →+* α) = ring_hom.id α := rfl
@[simp] lemma coe_order_add_monoid_hom_id :
  (order_ring_hom.id α : α →+o α) = order_add_monoid_hom.id α := rfl
@[simp] lemma coe_order_monoid_with_zero_hom_id :
  (order_ring_hom.id α : α →*₀o α) = order_monoid_with_zero_hom.id α := rfl

/-- Composition of two `order_ring_hom`s as an `order_ring_hom`. -/
protected def comp (f : β →+*o γ) (g : α →+*o β) : α →+*o γ :=
{ ..f.to_ring_hom.comp g.to_ring_hom, ..f.to_order_add_monoid_hom.comp g.to_order_add_monoid_hom }

@[simp] lemma coe_comp (f : β →+*o γ) (g : α →+*o β) : ⇑(f.comp g) = f ∘ g := rfl
@[simp]

lemma cancel_right {f₁ f₂ : β →+*o γ} {g : α →+*o β} (hg : surjective g) :
  f₁.comp g = f₂.comp g ↔ f₁ = f₂ :=
⟨λ h, ext $ hg.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {f : β →+*o γ} {g₁ g₂ : α →+*o β} (hf : injective f) :
  f.comp g₁ = f.comp g₂ ↔ g₁ = g₂ :=
⟨λ h, ext $ λ a, hf $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end preorder

variables [non_assoc_semiring β]

instance [preorder β] : preorder (order_ring_hom α β) := preorder.lift (coe_fn : _ → α → β)

instance [partial_order β] : partial_order (order_ring_hom α β) :=
partial_order.lift _ fun_like.coe_injective

end order_ring_hom

/-! ### Ordered ring isomorphisms -/

namespace order_ring_iso
section has_le
variables [has_mul α] [has_add α] [has_le α] [has_mul β] [has_add β] [has_le β] [has_mul γ]
  [has_add γ] [has_le γ] [has_mul δ] [has_add δ] [has_le δ]

/-- Reinterpret an ordered ring isomorphism as an order isomorphism. -/
def to_order_iso (f : α ≃+*o β) : α ≃o β := ⟨f.to_ring_equiv.to_equiv, λ _ _, f.map_le_map_iff'⟩

instance : order_ring_iso_class (α ≃+*o β) α β :=
{ coe := λ f, f.to_fun,
  inv := λ f, f.inv_fun,
  coe_injective' := λ f g h₁ h₂, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_add := λ f, f.map_add',
  map_mul := λ f, f.map_mul',
  map_le_map_iff := λ f _ _, f.map_le_map_iff',
  left_inv := λ f, f.left_inv,
  right_inv := λ f, f.right_inv }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (α ≃+*o β) (λ _, α → β) := fun_like.has_coe_to_fun

lemma to_fun_eq_coe (f : α ≃+*o β) : f.to_fun = f := rfl

@[ext] lemma ext {f g : α ≃+*o β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

@[simp] lemma coe_mk (e : α ≃+* β) (h) : ⇑(⟨e, h⟩ : α ≃+*o β) = e := rfl
@[simp] lemma mk_coe (e : α ≃+*o β) (h) : (⟨e, h⟩ : α ≃+*o β) = e := ext $ λ _, rfl

@[simp] lemma to_ring_equiv_eq_coe (f : α ≃+*o β) : f.to_ring_equiv = f := ring_equiv.ext $ λ _, rfl
@[simp] lemma to_order_iso_eq_coe (f : α ≃+*o β) : f.to_order_iso = f := order_iso.ext rfl

@[simp, norm_cast] lemma coe_to_ring_equiv (f : α ≃+*o β) : ⇑(f : α ≃+* β) = f := rfl
@[simp, norm_cast] lemma coe_to_order_iso (f : α ≃+*o β) : ⇑(f : α ≃o β) = f := rfl

variable (α)

/-- The identity map as an ordered ring isomorphism. -/
@[refl] protected def refl : α ≃+*o α := ⟨ring_equiv.refl α, λ _ _, iff.rfl⟩

instance : inhabited (α ≃+*o α) := ⟨order_ring_iso.refl α⟩

@[simp] lemma refl_apply (x : α) : order_ring_iso.refl α x = x := rfl
@[simp] lemma coe_ring_equiv_refl : (order_ring_iso.refl α : α ≃+* α) = ring_equiv.refl α := rfl
@[simp] lemma coe_order_iso_refl : (order_ring_iso.refl α : α ≃o α) = order_iso.refl α := rfl

variables {α}

/-- The inverse of an ordered ring isomorphism as an ordered ring isomorphism. -/
@[symm] protected def symm (e : α ≃+*o β) : β ≃+*o α :=
⟨e.to_ring_equiv.symm,
  λ a b, by erw [←map_le_map_iff e, e.1.apply_symm_apply, e.1.apply_symm_apply]⟩

/-- See Note [custom simps projection] -/
def simps.symm_apply (e : α ≃+*o β) : β → α := e.symm

@[simp] lemma symm_symm (e : α ≃+*o β) : e.symm.symm = e := ext $ λ _, rfl

/-- Composition of `order_ring_iso`s as an `order_ring_iso`. -/
@[trans, simps] protected def trans (f : α ≃+*o β) (g : β ≃+*o γ) : α ≃+*o γ :=
⟨f.to_ring_equiv.trans g.to_ring_equiv, λ a b, (map_le_map_iff g).trans (map_le_map_iff f)⟩

@[simp] lemma trans_apply (f : α ≃+*o β) (g : β ≃+*o γ) (a : α) : f.trans g a = g (f a) := rfl

@[simp] lemma self_trans_symm (e : α ≃+*o β) : e.trans e.symm = order_ring_iso.refl α :=
ext e.left_inv
@[simp] lemma symm_trans_self (e : α ≃+*o β) : e.symm.trans e = order_ring_iso.refl β :=
ext e.right_inv

lemma symm_bijective : bijective (order_ring_iso.symm : (α ≃+*o β) → β ≃+*o α) :=
⟨λ f g h, f.symm_symm.symm.trans $ (congr_arg order_ring_iso.symm h).trans g.symm_symm,
  λ f, ⟨f.symm, f.symm_symm⟩⟩

end has_le

section non_assoc_semiring
variables [non_assoc_semiring α] [preorder α] [non_assoc_semiring β] [preorder β]
  [non_assoc_semiring γ] [preorder γ]

/-- Reinterpret an ordered ring isomorphism as an ordered ring homomorphism. -/
def to_order_ring_hom (f : α ≃+*o β) : α →+*o β :=
⟨f.to_ring_equiv.to_ring_hom, λ a b, (map_le_map_iff f).2⟩

@[simp] lemma to_order_ring_hom_eq_coe (f : α ≃+*o β) : f.to_order_ring_hom = f := rfl

@[simp, norm_cast] lemma coe_to_order_ring_hom (f : α ≃+*o β) : ⇑(f : α →+*o β) = f := rfl

@[simp]
lemma coe_to_order_ring_hom_refl : (order_ring_iso.refl α : α →+*o α) = order_ring_hom.id α := rfl

lemma to_order_ring_hom_injective : injective (to_order_ring_hom : (α ≃+*o β) → α →+*o β) :=
λ f g h, fun_like.coe_injective $ by convert fun_like.ext'_iff.1 h

end non_assoc_semiring
end order_ring_iso

/-!
### Uniqueness

There is at most one ordered ring homomorphism from a linear ordered field to an archimedean linear
ordered field. Reciprocally, such an ordered ring homomorphism exists when the codomain is further
conditionally complete.
-/

/-- There is at most one ordered ring homomorphism from a linear ordered field to an archimedean
linear ordered field. -/
instance order_ring_hom.subsingleton [linear_ordered_field α] [linear_ordered_field β]
  [archimedean β] :
  subsingleton (α →+*o β) :=
⟨λ f g, begin
  ext x,
  by_contra' h' : f x ≠ g x,
  wlog h : f x < g x,
  { exact this g f x (ne.symm h') (h'.lt_or_lt.resolve_left h), },
  obtain ⟨q, hf, hg⟩ := exists_rat_btwn h,
  rw ←map_rat_cast f at hf,
  rw ←map_rat_cast g at hg,
  exact (lt_asymm ((order_hom_class.mono g).reflect_lt hg) $
    (order_hom_class.mono f).reflect_lt hf).elim,
end⟩

/-- There is at most one ordered ring isomorphism between a linear ordered field and an archimedean
linear ordered field. -/
instance order_ring_iso.subsingleton_right [linear_ordered_field α] [linear_ordered_field β]
  [archimedean β] :
  subsingleton (α ≃+*o β) :=
order_ring_iso.to_order_ring_hom_injective.subsingleton

/-- There is at most one ordered ring isomorphism between an archimedean linear ordered field and a
linear ordered field. -/
instance order_ring_iso.subsingleton_left [linear_ordered_field α] [archimedean α]
  [linear_ordered_field β] :
  subsingleton (α ≃+*o β) :=
order_ring_iso.symm_bijective.injective.subsingleton


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

noncomputable theory

/- This one proves that a ring with axioms r1-r15,
   0 ≠ 1, and nothing between 0 and 1,
   is actually ℤ in disguise.

   This uses classical reasoning.

   r2 and r12 aren't used.
-/

/- Maybe r15 isn't necessary?

   See http://matwbn.icm.edu.pl/ksiazki/fm/fm85/fm85114.pdf ?
-/

constant ordring : Type
notation `ℝ` := ordring

namespace ordring

constant zero : ordring

constant one : ordring

constant add (x y: ordring) : ordring

constant mul (x y: ordring) : ordring

constant neg (x: ordring) : ordring

constant lt (x y: ordring) : Prop

instance : has_zero ℝ := ⟨zero⟩
instance : has_one ℝ := ⟨one⟩
instance : has_add ℝ := ⟨add⟩
instance : has_neg ℝ := ⟨neg⟩
instance : has_mul ℝ := ⟨mul⟩
instance : has_lt ℝ := ⟨lt⟩

variables (x y z t u: ordring)

axiom r1: x < x → false

axiom r2: x < y → y < z → x < z

axiom r3: x < 0 ∨ 0 = x ∨ 0 < x

axiom r4: x < y → x + z < y + z

axiom r5: 0 < x → 0 < y → 0 < x * y

axiom r6: 0 + x = x

axiom r7: 0 * x = 0

axiom r8: 1 * x = x

axiom r9: x + y = y + x

axiom r10: x * y = y * x

axiom r11: x + y + z = x + (y + z)

axiom r12: x * y * z = x * (y * z)

axiom r13: x * (y + z) = x * y + x * z

axiom r14: x + (-x) = 0

axiom r15: ∀ (f: ℕ → ℝ), (∀ (n: ℕ), f n < f (n + 1)) → (∃ (A: ℝ), ∀ (n: ℕ), f n < A) → (∃ (L: ℝ), ∀ (ε: ℝ), 0 < ε → ∃ (N: ℕ), ∀ n, N < n → L + -ε < f n ∧ f n < L + ε)

axiom r16: (0: ℝ) < 1 ∧ ¬(∃ x: ℝ, 0 < x ∧ x < 1)

theorem lt_irrefl : x < x → false := r1 x

theorem lt_trans : x < y → y < z → x < z := r2 x y z

theorem add_right_inj : x + y = x + z ↔ y = z :=
begin
  have l1: ∀ (x y z: ℝ), x = y → z + x = z + y,
  intros x y z h, rw [h],
  split ; intro h,
  have h2 := l1 _ _ (-x) h,
  rw [← r11, ← r11, r9 _ x, r14, r6, r6] at h2,
  assumption,
  apply l1, assumption,
end

theorem add_left_inj : y + x = z + x ↔ y = z :=
begin
  rw [r9 _ x, r9 _ x],
  apply add_right_inj,
end

theorem mul_pos : 0 < x → 0 < y → 0 < x * y := r5 x y

theorem mul_add : x * (y + z) = x * y + x * z :=  r13 x y z

theorem add_mul : (x + y) * z = x * z + y * z :=
begin
  rw [r10 _ z, r10 _ z, r10 _ z],
  apply r13
end

@[simp]
theorem neg_neg: (- (-x)) = x :=
begin
  rw [← add_right_inj, r14, r9, r14],
end

@[simp]
theorem neg_add: -(x + y) = (-x) + (-y) :=
begin
  rw [← add_right_inj (x + y), r14, r9 (-x), ← r11, r11 x, r14, r11, r6, r14],
end

@[simp]
theorem neg_mul:  -x * y = -(x * y) :=
begin
  rw [← add_right_inj, ← add_mul _ _ y, r14, r14, r7],
end

@[simp]
theorem mul_neg: x * (-y) = -(x * y) :=
begin
  rw [r10, neg_mul, r10]
end

@[simp]
theorem add_neg_self: x + (-x) = 0 := r14 x

@[simp]
theorem neg_add_self: (-x) + x = 0 :=
begin
  rw [r9, add_neg_self],
end

theorem zero_lt_one: (0: ℝ) < 1 :=
begin
  exact r16.left,
end

theorem add_comm : x + y = y + x := r9 x y

theorem add_assoc : x + y + z = x + (y + z) := r11 x y z

theorem mul_comm : x * y = y * x := r10 x y

theorem mul_assoc : x * y * z = x * (y * z) := r12 x y z

@[simp]
theorem zero_mul : 0 * x = 0 := r7 x

@[simp]
theorem mul_zero : x * 0 = 0 :=
begin
  rw [mul_comm, zero_mul],
end

@[simp]
theorem one_mul : 1 * x = x := r8 x

@[simp]
theorem mul_one : x * 1 = x :=
begin
  rw [mul_comm, one_mul],
end

@[simp]
theorem zero_add : 0 + x = x := r6 x

@[simp]
theorem add_zero : x + 0 = x :=
begin
  rw [add_comm, zero_add],
end

def sub (x y: ordring) : ordring := x + (-y)
instance : has_sub ℝ := ⟨sub⟩

@[simp]
private theorem add_simp_0 : x + (y + z) = x + y + z :=
  eq.symm (add_assoc x y z)

@[simp]
private theorem add_simp_1 : x + y + (-y) = x :=
begin
  rw [add_assoc, add_neg_self], simp
end

@[simp]
private theorem add_simp_2 : x + (-y) + y = x :=
begin
  rw [add_assoc, neg_add_self], simp
end

@[simp]
private theorem sub_simp_0 : x - y = x + (-y) := rfl

@[simp]
private theorem mul_simp_0 : x * (y * z) = x * y * z :=
  eq.symm (mul_assoc x y z)

@[simp]
theorem neg_zero : (-0) = (0: ℝ) :=
begin
  rw [← add_right_inj 0],
  rw [add_neg_self], simp
end

theorem add_switch : x + y + z = x + z + y :=
begin
  rw [add_assoc, add_comm y, ← add_assoc],
end

lemma lt_iff_zero_lt_sub : x < y ↔ 0 < y - x :=
begin
  split; intro h,
  have h2 := r4 _ _ (-x) h,
  simp at ⊢ h2, assumption,
  have h2 := r4 _ _ x h,
  simp at h2,
  assumption,
end

theorem neg_pos : 0 < -x ↔ x < 0 :=
begin
  split; intro h,
  have h1 := r4 _ _ x h,
  simp at h1, assumption,
  have h1 := r4 _ _ (-x) h,
  simp at h1, assumption,
end

theorem neg_lt_zero : -x < 0 ↔ 0 < x :=
begin
  rw [← neg_pos, neg_neg],
end

theorem lt_trichotomy : x < y ∨ x = y ∨ y < x :=
begin
  cases r3 (y-x) with h,
  right, right,
  rw [lt_iff_zero_lt_sub, ← neg_lt_zero],
  simp at *,
  rw [add_comm], assumption,
  cases h with h h,
  right, left,
  rw [← add_right_inj (-x), add_comm _ x, add_comm _ y],
  simp at *, assumption,
  left,
  rw [lt_iff_zero_lt_sub],
  assumption,
end

theorem add_lt_add_left : x + y < x + z ↔ y < z :=
begin
  split; intro h,
  have h1 := r4 _ _ (-x) h,
  rw [add_switch, add_neg_self, zero_add, add_switch, add_neg_self, zero_add ] at h1,
  assumption,
  rw [add_comm x, add_comm x], apply r4, assumption,
end

theorem add_lt_add_right : y + x < z + x ↔ y < z :=
begin
  rw [add_comm _ x, add_comm _ x],
  apply add_lt_add_left,
end

lemma mul_lt_mul_left (a0 : 0 < x) :  x * y < x * z ↔ y < z :=
begin
  have l : ∀ b c: ℝ, b < c → x * b < x * c,
  intros b c h,
  rw [lt_iff_zero_lt_sub] at h ⊢,
  simp at h ⊢,
  have h2 := mul_pos _ _ a0 h,
  rw [mul_add] at h2,
  simp at h2,
  exact h2,
  split; intro h,
  cases lt_trichotomy y z with h1 h1,
  assumption,
  cases h1 with h1 h1,
  exfalso, apply lt_irrefl (x * z), rw [h1] at h, assumption,
  have h2 := l z y h1,
  exfalso, apply lt_irrefl, apply lt_trans, exact h, assumption,
  apply l, assumption,
end

theorem mul_lt_mul_right (a0 : 0 < x): y * x < z * x ↔ y < z :=
begin
  rw [mul_comm _ x, mul_comm _ x],
  exact mul_lt_mul_left _ _ _ a0,
end

def le (x y: ℝ) : Prop := x < y ∨ x = y
instance : has_le ℝ := ⟨le⟩

private theorem le_def : x ≤ y ↔ x < y ∨ x = y :=
begin
  trivial
end

theorem le_refl : x ≤ x :=
begin
  rw [le_def], right, refl,
end

theorem le_lt_trans : x ≤ y → y < z → x < z :=
begin
  intros h1 h2,
  rw [le_def] at h1, cases h1 with h1 h1,
  apply lt_trans; assumption,
  rw [h1], assumption,
end

theorem lt_le_trans : x < y → y ≤ z → x < z :=
begin
  intros h1 h2,
  rw [le_def] at h2, cases h2 with h2 h2,
  apply lt_trans; assumption,
  rw [← h2], assumption,
end

theorem le_of_lt : x < y → x ≤ y :=
begin
  intro,
  rw [le_def], left, assumption,
end

theorem le_antisymm : x ≤ y → y ≤ x → x = y :=
begin
  intros h1 h2,
  rw [le_def] at h1, cases h1 with h1 h1,
  exfalso, apply lt_irrefl, apply le_lt_trans; assumption,
  assumption,
end

theorem le_trans : x ≤ y → y ≤ z → x ≤ z :=
begin
  intros h1 h2,
  rw [le_def] at h1, cases h1 with h1 h1,
  apply le_of_lt, apply lt_le_trans; assumption,
  rw [h1], assumption
end

theorem mul_nonneg : 0 ≤ x → 0 ≤ y → 0 ≤ x * y :=
begin
  intros h1 h2,
  rw [le_def] at h1 h2,
  cases h1 with h1 h1; cases h2 with h2 h2,
  apply le_of_lt, apply mul_pos,
  assumption,
  assumption,
  simp [← h2], apply le_refl,
  simp [← h1], apply le_refl,
  simp [← h2], apply le_refl,
end

theorem le_lt_dichotomy : x < y ∨ y ≤ x :=
begin
  cases lt_trichotomy x y with h h,
  left, assumption,
  cases h with h h,
  right, rw [h], apply le_refl,
  right, apply le_of_lt, assumption,
end

theorem le_dichotomy : x ≤ y ∨ y ≤ x :=
begin
  cases le_lt_dichotomy x y with h h,
  left, apply le_of_lt, assumption,
  right, assumption,
end

lemma le_iff_zero_le_sub : x ≤ y ↔ 0 ≤ y - x :=
begin
  rw [le_def, le_def], split; intro h,
  cases h with h h,
  left, rw [← lt_iff_zero_lt_sub], assumption,
  right, rw [h], simp,
  cases h with h h,
  left, rw [lt_iff_zero_lt_sub], assumption,
  right,
  rw [← add_left_inj (-x)], simp at *, assumption,
end

theorem add_le_add_left : x + y ≤ x + z ↔ y ≤ z :=
begin
  rw [le_iff_zero_le_sub, le_iff_zero_le_sub y],
  simp, rw [add_switch x, add_neg_self, zero_add],
end

theorem add_le_add_right : y + x ≤ z + x ↔ y ≤ z :=
begin
  rw [add_comm _ x, add_comm _ x],
  apply add_le_add_left,
end

theorem neg_nonneg : 0 ≤ -x ↔ x ≤ 0 :=
begin
  rw [le_iff_zero_le_sub, le_iff_zero_le_sub x],
  simp,
end

theorem neg_le_zero : -x ≤ 0 ↔ 0 ≤ x :=
begin
  rw [le_iff_zero_le_sub, le_iff_zero_le_sub 0],
  simp,
end

lemma mul_le_left (a0: 0 ≤ x) : y ≤ z → x * y ≤ x * z :=
begin
  rw [le_iff_zero_le_sub, le_iff_zero_le_sub (x * y)],
  simp,
  rw [← mul_neg, ← mul_add],
  intro,
  apply mul_nonneg, assumption, assumption,
end

lemma mul_le_right (a0 : 0 ≤ x) : y ≤ z → y * x ≤ z * x :=
begin
  rw [mul_comm _ x, mul_comm _ x],
  apply mul_le_left,
  assumption,
end

lemma mul_le_mul_left (a0 : 0 < x) :  x * y ≤ x * z ↔ y ≤ z :=
begin
  split; intro h,
  cases lt_trichotomy y z with h1 h1,
  apply le_of_lt, assumption,
  cases h1 with h1 h1,
  rw [h1], apply le_refl,
  exfalso, rw [← mul_lt_mul_left x] at h1,
  have h2 := lt_le_trans _ _ _ h1 h,
  apply lt_irrefl, exact h2,
  assumption,
  apply mul_le_left, apply le_of_lt, assumption,
  assumption,
end

theorem mul_le_mul_right (a0 : 0 < x): y * x ≤ z * x ↔ y ≤ z :=
begin
  rw [mul_comm _ x, mul_comm _ x],
  exact mul_le_mul_left _ _ _ a0,
end

theorem neg_lt_neg_iff : -x < -y ↔ y < x :=
begin
  rw [lt_iff_zero_lt_sub, lt_iff_zero_lt_sub y],
  simp,
  rw [add_comm _ x],
end

theorem neg_le_neg_iff : -x ≤ -y ↔ y ≤ x :=
begin
  rw [le_iff_zero_le_sub, le_iff_zero_le_sub y],
  simp,
  rw [add_comm _ x],
end

theorem zero_product : x * y = 0 → x = 0 ∨ y = 0 :=
begin
  intros xy,
  cases lt_trichotomy 0 x with hx hx; cases lt_trichotomy 0 y with hy hy,
  exfalso,
  have h1 := mul_pos _ _ hx hy,
  rw [xy] at h1,
  exact lt_irrefl _ h1,
  cases hy with hy hy,
  right, rw [hy],
  rw [← neg_lt_neg_iff] at hy, simp at hy,
  have h1 := mul_pos _ _ hx hy,
  simp at h1, rw [← neg_lt_neg_iff] at h1, simp at h1, rw [xy] at h1,
  exfalso, exact lt_irrefl _ h1,
  cases hx with hx hx,
  left, rw [hx],
  rw [← neg_lt_neg_iff] at hx, simp at hx,
  have h1 := mul_pos _ _ hx hy,
  simp at h1, rw [← neg_lt_neg_iff] at h1, simp at h1, rw [xy] at h1,
  exfalso, exact lt_irrefl _ h1,
  cases hx with hx hx; cases hy with hy hy,
  left, rw [hx],
  left, rw [hx],
  right, rw [hy],
  rw [← neg_lt_neg_iff] at hx, simp at hx,
  rw [← neg_lt_neg_iff] at hy, simp at hy,
  have h1 := mul_pos _ _ hx hy,
  simp at h1, rw [xy] at h1,
  exfalso, exact lt_irrefl _ h1,
end

theorem lt_add_lt : x < y → z < t → x + z < y + t :=
begin
  intros hxy hzt,
  apply lt_trans _ (y + z),
  rw [add_lt_add_right], assumption,
  rw [add_lt_add_left], assumption,
end

theorem lt_add_le : x < y → z ≤ t → x + z < y + t :=
begin
  intros hxy hzt,
  apply lt_le_trans _ (y + z),
  rw [add_lt_add_right], assumption,
  rw [add_le_add_left], assumption,
end

theorem le_add_lt : x ≤ y → z < t → x + z < y + t :=
begin
  intros hxy hzt,
  have l := lt_add_le _ _ _ _ hzt hxy,
  rw [add_comm x, add_comm y],
  assumption,
end

theorem le_add_le : x ≤ y → z ≤ t → x + z ≤ y + t :=
begin
  intros hxy hzt,
  apply le_trans _ (y + z),
  rw [add_le_add_right], assumption,
  rw [add_le_add_left], assumption,
end

theorem lt_iff_not_le : x < y ↔ ¬(y ≤ x) :=
begin
  split; intro h,
  intro h1,
  apply lt_irrefl, apply lt_le_trans; assumption,
  cases le_lt_dichotomy x y with h1 h1,
  assumption,
  exfalso, apply h, assumption,
end

theorem le_iff_not_lt : x ≤ y ↔ ¬(y < x) :=
begin
  split; intro h,
  intro h1, apply lt_irrefl, apply le_lt_trans; assumption,
  cases le_lt_dichotomy y x with h1 h1,
  exfalso, apply h, assumption,
  assumption,
end

theorem lt_self_add_one : x < x + 1 :=
begin
  rw [← add_lt_add_left (-x)], simp,
  apply zero_lt_one,
end

theorem add_nonneg : 0 ≤ x → 0 ≤ y → 0 ≤ x + y :=
begin
  intros hx hy,
  apply le_trans _ x,
  assumption,
  rw [le_iff_zero_le_sub], simp, rw [add_switch], simp, assumption,
end

theorem lt_mul_lt : 0 ≤ x → x < y → 0 ≤ z → z < t → x * z < y * t :=
begin
  intros x0 xy z0 zt,
  rw [lt_iff_zero_lt_sub] at xy zt ⊢,
  have h := mul_pos _ _ xy zt,
  simp at h ⊢,
  rw [mul_add, add_mul, add_mul] at h,
  simp at h,
  apply lt_le_trans,
  exact h,
  rw [le_iff_zero_le_sub],
  simp, rw [add_switch (y * t), add_neg_self, zero_add],
  have h1 :  -(x * z) + x * t + y * z + -(x * z) = x * (t - z) + (y - x) * z,
  simp, rw [mul_add, add_mul], simp,
  rw [add_comm (x * t)],
  rw [h1], apply add_nonneg,
  apply mul_nonneg, assumption, apply le_of_lt, assumption,
  apply mul_nonneg, apply le_of_lt, assumption, assumption,
end

noncomputable def npow : ℕ → ℝ → ℝ
| 0 x := one
| (nat.succ n) x := x * npow n x

instance : has_pow ℝ ℕ := {pow := λ x n, npow n x}

private lemma npow_succ : ∀ n: ℕ, npow (nat.succ n) x = x * npow n x :=
begin
  intro, unfold npow,
end

@[simp]
theorem pow_zero : x ^ 0 = 1 := begin refl, end

theorem pow_succ : ∀ n: ℕ, x ^ n.succ = x * (x ^ n) :=
begin
  intro, apply npow_succ,
end

@[simp]
theorem pow_one : x ^ 1 = x :=
begin
  rw [pow_succ], simp,
end

theorem pow_add : ∀ (m n: ℕ), x ^ (m + n) = x ^ m * x ^ n :=
begin
  intros m n,
  induction n with n hn,
  rw [nat.add_zero], simp,
  rw [nat.add_succ, pow_succ, hn, mul_comm, pow_succ, mul_assoc, mul_comm x],
end

theorem zero_pow : ∀ m: ℕ, 1 ≤ m → (0: ℝ) ^ m = 0 :=
begin
  intros m,
  induction m with m hm,
  intros hm0, exfalso, apply nat.le_lt_antisymm,
  exact hm0, apply nat.lt_succ_self,
  intro,
  rw [pow_succ, zero_mul],
end

--main result
noncomputable def nat_cast : ℕ → ℝ
| (0: ℕ) := (0: ℝ)
| (nat.succ n) := 1 + nat_cast n

def int_cast : ℤ → ℝ
| (int.of_nat n) := nat_cast n
| -[1+(n: ℕ)] := -(1: ℝ) - (nat_cast n)

theorem int_cast_of_nat (n: ℕ) : int_cast (int.of_nat n) = nat_cast n := by refl

theorem nat_cast_respects_zero : nat_cast 0 = 0 :=
begin
  refl
end

theorem nat_cast_respects_one : nat_cast 1 = 1 :=
begin
  simp [nat_cast],
end

theorem nat_cast_respects_add (m n: ℕ) : nat_cast (m + n) = (nat_cast m) + (nat_cast n) :=
begin
  induction m with m hm,
  rw [nat.zero_add, nat_cast_respects_zero, zero_add],
  rw [nat.succ_add], simp [nat_cast], rw [hm, add_assoc],
end

theorem nat_cast_respects_succ (m: ℕ) : nat_cast (m.succ) = nat_cast m + 1 :=
begin
  rw [add_comm], simp [nat_cast],
end

theorem nat_cast_respects_mul (m n: ℕ) : nat_cast (m * n) = (nat_cast m) * (nat_cast n) :=
begin
  induction m with m hm,
  rw [nat.zero_mul, nat_cast_respects_zero, zero_mul],
  rw [nat.succ_eq_add_one, nat.right_distrib, nat.one_mul, nat_cast_respects_add, hm,
  nat_cast_respects_add, add_mul, nat_cast_respects_one, one_mul],
end

private theorem nat_cast_nonneg (m: ℕ) : 0 ≤ nat_cast m :=
begin
  induction m with m hm,
  rw [nat_cast_respects_zero], apply le_refl,
  rw [nat_cast_respects_succ], apply le_trans _ (nat_cast m + 0),
  rw [add_zero], assumption,
  rw [add_le_add_left], apply le_of_lt, apply zero_lt_one,
end

private lemma nat_cast_respects_le_pre1 (m n: ℕ) : m ≤ n → nat_cast m ≤ nat_cast n :=
begin
  intros hmn,
  have h' := nat.add_sub_of_le hmn,
  rw [← h', nat_cast_respects_add, ← add_zero (nat_cast m), add_assoc, zero_add,
  add_le_add_left], apply nat_cast_nonneg
end

private lemma nat_cast_respects_le_pre2 (m n: ℕ) : m < n → nat_cast m < nat_cast n :=
begin
  intros hmn,
  have hmn' := nat_cast_respects_le_pre1 _ _ hmn,
  rw [nat_cast_respects_succ] at hmn',
  apply lt_le_trans _ (nat_cast m + 1),
  rw [← add_zero (nat_cast m), add_assoc, zero_add, add_lt_add_left], apply zero_lt_one,
  assumption,
end

theorem nat_cast_respects_le (m n: ℕ) : m ≤ n ↔ nat_cast m ≤ nat_cast n :=
begin
  split,
  apply nat_cast_respects_le_pre1,
  intro hmn,
  cases (nat.lt_or_ge n m),
  exfalso, apply lt_irrefl, apply le_lt_trans, assumption,
  apply nat_cast_respects_le_pre2, assumption,
  assumption,
end

theorem nat_cast_respects_lt (m n: ℕ) : m < n ↔ nat_cast m < nat_cast n :=
begin
  split,
  apply nat_cast_respects_le_pre2,
  intro hmn,
  cases (nat.lt_or_ge m n),
  assumption,
  exfalso, apply lt_irrefl, apply lt_le_trans, assumption,
  apply nat_cast_respects_le_pre1, assumption,
end

theorem nat_cast_respects_eq (m n: ℕ) : m = n ↔ nat_cast m = nat_cast n :=
begin
  split,
  intro hmn, rw [hmn],
  intro hmn,
  apply nat.le_antisymm; rw [nat_cast_respects_le]; rw [hmn]; apply le_refl,
end

theorem int_cast_respects_zero : int_cast 0 = 0 :=
begin
  refl,
end

theorem int_cast_respects_one: int_cast 1 = 1 :=
begin
  have : 1 = int.of_nat 1,
  refl,
  rw [this],
  simp [int_cast],
  apply nat_cast_respects_one,
end

private lemma int_cast_respects_add_pre (a b: ℕ) : int_cast (int.sub_nat_nat a b) = nat_cast a - nat_cast b :=
begin
  apply int.sub_nat_nat_elim a b (λ x y z, int_cast z = nat_cast x - nat_cast y),
  intros i n,
  simp [int_cast], rw [nat_cast_respects_add, add_switch], simp,
  intros i m,
  simp [int_cast], rw [nat_cast_respects_add, nat_cast_respects_add,
  nat_cast_respects_one],
  simp, rw [add_comm],
end

theorem int_cast_respects_add (m n: ℤ) : int_cast (m + n) = (int_cast m) + (int_cast n) :=
begin
  cases m with a a; cases n with b b,
  rw [int.of_nat_add_of_nat], simp [int_cast], apply nat_cast_respects_add,
  rw [int.of_nat_add_neg_succ_of_nat, int_cast_respects_add_pre],
  simp [int_cast], simp [nat_cast],
  rw [int.neg_succ_of_nat_add_of_nat, int_cast_respects_add_pre],
  simp [int_cast], simp [nat_cast], rw [add_comm _ (nat_cast b), add_assoc],
  rw [int.neg_succ_of_nat_add_neg_succ_of_nat], simp [int_cast, nat_cast],
  rw [nat_cast_respects_add], simp, rw [add_switch (-1) (-1)],
end

theorem int_cast_respects_neg (m: ℤ) : int_cast (-m) = -(int_cast m) :=
begin
  rw [← add_right_inj (int_cast m), ← int_cast_respects_add, int.add_right_neg, add_neg_self],
  rw [int_cast_respects_zero],
end

theorem int_cast_respects_sub (m n: ℤ) : int_cast (m - n) = int_cast m - int_cast n :=
begin
  rw [int.sub_eq_add_neg, int_cast_respects_add, int_cast_respects_neg],
  simp,
end

private theorem int_cast_respects_le_pre1 (m n: ℤ) : m ≤ n → int_cast m ≤ int_cast n :=
begin
  intros h1,
  have h2 := int.add_le_add_right h1 (-m),
  rw [int.add_right_neg] at h2,
  have h3 := int.of_nat_nat_abs_eq_of_nonneg h2,
  have h4 : int_cast (int.of_nat (n + -m).nat_abs) = int_cast (n + -m),
  rw [h3],
  rw [int_cast_of_nat] at h4,
  have h5 : 0 ≤ int_cast (n + -m),
  rw [← h4], apply nat_cast_nonneg,
  rw [int_cast_respects_add, int_cast_respects_neg, ← sub_simp_0, ← le_iff_zero_le_sub] at h5,
  assumption,
end

private theorem int_cast_respects_le_pre2 (m n: ℤ) : m < n → int_cast m < int_cast n :=
begin
  intros h1,
  have h2 := int_cast_respects_le_pre1 _ _ h1,
  rw [int_cast_respects_add, int_cast_respects_one] at h2,
  apply lt_le_trans _ (int_cast m + 1),
  rw [← add_zero (int_cast m), add_assoc, zero_add, add_lt_add_left],
  apply zero_lt_one,
  assumption,
end

theorem int_cast_respects_le (m n: ℤ) : m ≤ n ↔ int_cast m ≤ int_cast n :=
begin
  split; intro h,
  exact int_cast_respects_le_pre1 _ _ h,
  cases (le_or_lt m n) with h1 h1,
  assumption,
  have h2 := int_cast_respects_le_pre2 _ _ h1,
  exfalso, apply lt_irrefl, apply le_lt_trans; assumption,
end

theorem int_cast_respects_lt (m n: ℤ) : m < n ↔ int_cast m < int_cast n :=
begin
  split; intro h,
  exact int_cast_respects_le_pre2 _ _ h,
  cases (le_or_lt n m) with h1 h1,
  have h3 := int_cast_respects_le_pre1 _ _ h1,
  exfalso, apply lt_irrefl, apply le_lt_trans; assumption,
  assumption,
end

private lemma int_cast_respects_mul_pre (m: ℕ) (n: ℤ) : int_cast (int.of_nat m * n) = (int_cast (int.of_nat m)) * (int_cast n) :=
begin
  induction m with m hm,
  simp [int_cast, nat_cast],
  have : int.of_nat 0 = 0,
  refl,
  rw [this, int.zero_mul, int_cast_respects_zero],
  simp [int_cast, nat_cast],
  have rm : int.of_nat m.succ = int.of_nat m + 1,
  refl,
  rw [rm, int.distrib_right, int_cast_respects_add, hm], simp [int_cast],
  rw [int.one_mul, add_mul, one_mul], apply add_comm,
end

theorem int_cast_respects_mul (m n: ℤ) : int_cast (m * n) = (int_cast m) * (int_cast n) :=
begin
  cases m with b h,
  apply int_cast_respects_mul_pre,
  rw [← add_right_inj (int_cast ((1 +  int.of_nat h) * n))],
  rw [← int_cast_respects_add, int.distrib_right],
  rw [← int.distrib_right, ← int.distrib_right, int.neg_succ_of_nat_eq h],
  have l1 :  1 + int.of_nat h  = (↑h + 1),
  rw [int.add_comm], refl,
  have l2 : (↑h + 1) = int.of_nat (h + 1),
  rw [int.of_nat_add, int.of_nat_one], refl,
  rw [l1, int.add_right_neg, int.zero_mul, l2, int_cast_respects_mul_pre],
  rw [int_cast_respects_neg, ← add_mul, add_neg_self, int_cast_respects_zero, zero_mul],
end

theorem step_1 : ¬(∃ A > 0, ∀ (n: ℕ), nat_cast n ≠ A) :=
begin
  intro hA,
  cases hA with A hA,
  cases hA with hA hh,
  have hhr : ∀ n, nat_cast n < A,
  intros n,
  induction n with n hr,
  rw [nat_cast_respects_zero], assumption,
  cases lt_trichotomy (nat_cast n.succ) A with ht ht,
  assumption,
  cases ht with ht ht,
  exfalso, apply (hh n.succ), assumption,
  exfalso,
  rw [nat_cast_respects_succ] at ht,
  rw [← add_lt_add_left (- (nat_cast n))] at hr ht,
  simp at hr ht,
  apply r16.2,
  existsi (-nat_cast n + A),
  split; assumption,
  have hm := r15 (λ n, nat_cast n) _ _,
  cases hm with L hL,
  cases (hL 1 zero_lt_one) with N hN,
  simp at hN,
  have hm': ∀ n > N, (-L) + nat_cast n = 0,
  intros n hn,
  cases (hN n hn) with hn1 hn2,
  rw [← add_lt_add_left (-L)] at hn1 hn2,
  simp at hn1 hn2,
  cases lt_trichotomy (-L + nat_cast n) 0 with ht ht,
  exfalso,
  rw [← add_lt_add_left 1] at hn1 ht,
  simp at hn1 ht,
  apply r16.2,
  existsi (1 + -L + nat_cast n), split; assumption,
  cases ht with ht ht,
  assumption,
  exfalso,
  apply r16.2,
  existsi (-L + nat_cast n),
  split; assumption,
  have hm1 := hm' (N.succ) _,
  have hm2 := hm' (N.succ.succ) _,
  rw [nat_cast_respects_succ] at hm2,
  rw [← add_assoc, hm1, zero_add] at hm2,
  have hm3 := r16.1,
  rw [hm2] at hm3,
  apply lt_irrefl, assumption,
  apply nat.lt_trans, apply nat.lt_succ_self, apply nat.lt_succ_self,
  apply nat.lt_succ_self,
  intros n,
  simp,
  rw [nat_cast_respects_add, nat_cast_respects_one, add_comm],
  rw [lt_iff_zero_lt_sub], simp, apply r16.1,
  existsi A,
  simp,
  assumption,
end

--now we start reasoning classically
theorem step_2: ∀ A > 0, ∃ n, nat_cast n = A :=
begin
  intros A hA,
  by_cases (∃ (n: ℕ), nat_cast n = A),
  assumption,
  exfalso,
  apply step_1,
  existsi A, existsi hA,
  intros n hn,
  apply h,
  existsi n, assumption,
end

-- Surjectivity of int_cast.
---Combined with the injectivity
-- of int_cast (theorem int_cast_respects_lt),
-- and the fact that int_cast is a ring homomorphism
-- (theorems int_cast_respects_add, int_cast_respects_mul,
-- int_cast_respects_zero, int_cast_respects_one),
-- this gives the wanted result.
theorem final: ∀ x, ∃ n, int_cast n = x :=
begin
  have f1: ∀ x > 0, ∃ n, int_cast n = x,
  intros x hx,
  have s := step_2 x hx,
  cases s with n hn,
  existsi (int.of_nat n),
  rw [int_cast_of_nat], assumption,
  intros x,
  cases lt_trichotomy 0 x with ht ht,
  exact f1 x ht,
  cases ht with ht ht,
  rw [← ht],
  existsi (0: ℤ),
  apply int_cast_respects_zero,
  rw [← neg_lt_neg_iff, neg_zero] at ht,
  rw [← neg_neg x],
  cases (f1 (-x) ht) with n hn,
  existsi (-n),
  rw [int_cast_respects_neg, hn],
end

#print axioms final
end ordring


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin

! This file was ported from Lean 3 source module algebraic_geometry.locally_ringed_space
! leanprover-community/mathlib commit d39590fc8728fbf6743249802486f8c91ffe07bc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.AlgebraicGeometry.RingedSpace
import Mathbin.AlgebraicGeometry.Stalks
import Mathbin.Logic.Equiv.TransferInstance

/-!
# The category of locally ringed spaces

We define (bundled) locally ringed spaces (as `SheafedSpace CommRing` along with the fact that the
stalks are local rings), and morphisms between these (morphisms in `SheafedSpace` with
`is_local_ring_hom` on the stalk maps).
-/

universe v u

open CategoryTheory

open TopCat

open TopologicalSpace

open Opposite

open CategoryTheory.Category CategoryTheory.Functor

namespace AlgebraicGeometry

/-- A `LocallyRingedSpace` is a topological space equipped with a sheaf of commutative rings
such that all the stalks are local rings.

A morphism of locally ringed spaces is a morphism of ringed spaces
such that the morphisms induced on stalks are local ring homomorphisms. -/
@[nolint has_nonempty_instance]
structure LocallyRingedSpace extends SheafedSpace CommRingCat where
  LocalRing : ∀ x, LocalRing (presheaf.stalk x)
#align algebraic_geometry.LocallyRingedSpace AlgebraicGeometry.LocallyRingedSpace

attribute [instance] LocallyRingedSpace.local_ring

namespace LocallyRingedSpace

variable (X : LocallyRingedSpace)

/-- An alias for `to_SheafedSpace`, where the result type is a `RingedSpace`.
This allows us to use dot-notation for the `RingedSpace` namespace.
 -/
def toRingedSpace : RingedSpace :=
  X.toSheafedSpace
#align algebraic_geometry.LocallyRingedSpace.to_RingedSpace AlgebraicGeometry.LocallyRingedSpace.toRingedSpace

/-- The underlying topological space of a locally ringed space. -/
def toTop : TopCat :=
  X.1.carrier
#align algebraic_geometry.LocallyRingedSpace.to_Top AlgebraicGeometry.LocallyRingedSpace.toTop

instance : CoeSort LocallyRingedSpace (Type u) :=
  ⟨fun X : LocallyRingedSpace => (X.toTop : Type u)⟩

instance (x : X) : LocalRing (X.toPresheafedSpace.stalk x) :=
  X.LocalRing x

-- PROJECT: how about a typeclass "has_structure_sheaf" to mediate the 𝒪 notation, rather
-- than defining it over and over for PresheafedSpace, LRS, Scheme, etc.
/-- The structure sheaf of a locally ringed space. -/
def 𝒪 : Sheaf CommRingCat X.toTop :=
  X.toSheafedSpace.Sheaf
#align algebraic_geometry.LocallyRingedSpace.𝒪 AlgebraicGeometry.LocallyRingedSpace.𝒪

/-- A morphism of locally ringed spaces is a morphism of ringed spaces
 such that the morphims induced on stalks are local ring homomorphisms. -/
@[ext]
structure Hom (X Y : LocallyRingedSpace.{u}) : Type u where
  val : X.toSheafedSpace ⟶ Y.toSheafedSpace
  Prop : ∀ x, IsLocalRingHom (PresheafedSpace.stalkMap val x)
#align algebraic_geometry.LocallyRingedSpace.hom AlgebraicGeometry.LocallyRingedSpace.Hom

instance : Quiver LocallyRingedSpace :=
  ⟨Hom⟩

-- TODO perhaps we should make a bundled `LocalRing` and return one here?
-- TODO define `sheaf.stalk` so we can write `X.𝒪.stalk` here?
/-- The stalk of a locally ringed space, just as a `CommRing`.
-/
noncomputable def stalk (X : LocallyRingedSpace) (x : X) : CommRingCat :=
  X.Presheaf.stalk x
#align algebraic_geometry.LocallyRingedSpace.stalk AlgebraicGeometry.LocallyRingedSpace.stalk

/-- A morphism of locally ringed spaces `f : X ⟶ Y` induces
a local ring homomorphism from `Y.stalk (f x)` to `X.stalk x` for any `x : X`.
-/
noncomputable def stalkMap {X Y : LocallyRingedSpace} (f : X ⟶ Y) (x : X) :
    Y.stalk (f.1.1 x) ⟶ X.stalk x :=
  PresheafedSpace.stalkMap f.1 x
#align algebraic_geometry.LocallyRingedSpace.stalk_map AlgebraicGeometry.LocallyRingedSpace.stalkMap

instance {X Y : LocallyRingedSpace} (f : X ⟶ Y) (x : X) : IsLocalRingHom (stalkMap f x) :=
  f.2 x

instance {X Y : LocallyRingedSpace} (f : X ⟶ Y) (x : X) :
    IsLocalRingHom (PresheafedSpace.stalkMap f.1 x) :=
  f.2 x

/-- The identity morphism on a locally ringed space. -/
@[simps]
def id (X : LocallyRingedSpace) : Hom X X :=
  ⟨𝟙 _, fun x => by
    erw [PresheafedSpace.stalk_map.id]
    apply isLocalRingHom_id⟩
#align algebraic_geometry.LocallyRingedSpace.id AlgebraicGeometry.LocallyRingedSpace.id

instance (X : LocallyRingedSpace) : Inhabited (Hom X X) :=
  ⟨id X⟩

/-- Composition of morphisms of locally ringed spaces. -/
def comp {X Y Z : LocallyRingedSpace} (f : Hom X Y) (g : Hom Y Z) : Hom X Z :=
  ⟨f.val ≫ g.val, fun x => by
    erw [PresheafedSpace.stalk_map.comp]
    exact @isLocalRingHom_comp _ _ _ _ _ _ _ _ (f.2 _) (g.2 _)⟩
#align algebraic_geometry.LocallyRingedSpace.comp AlgebraicGeometry.LocallyRingedSpace.comp

/-- The category of locally ringed spaces. -/
instance : Category LocallyRingedSpace where
  Hom := Hom
  id := id
  comp X Y Z f g := comp f g
  comp_id' := by
    intros
    ext1
    simp [comp]
  id_comp' := by
    intros
    ext1
    simp [comp]
  assoc' := by
    intros
    ext1
    simp [comp]

/-- The forgetful functor from `LocallyRingedSpace` to `SheafedSpace CommRing`. -/
@[simps]
def forgetToSheafedSpace : LocallyRingedSpace ⥤ SheafedSpace CommRingCat
    where
  obj X := X.toSheafedSpace
  map X Y f := f.1
#align algebraic_geometry.LocallyRingedSpace.forget_to_SheafedSpace AlgebraicGeometry.LocallyRingedSpace.forgetToSheafedSpace

instance : Faithful forgetToSheafedSpace where

/-- The forgetful functor from `LocallyRingedSpace` to `Top`. -/
@[simps]
def forgetToTop : LocallyRingedSpace ⥤ TopCat :=
  forgetToSheafedSpace ⋙ SheafedSpace.forget _
#align algebraic_geometry.LocallyRingedSpace.forget_to_Top AlgebraicGeometry.LocallyRingedSpace.forgetToTop

@[simp]
theorem comp_val {X Y Z : LocallyRingedSpace} (f : X ⟶ Y) (g : Y ⟶ Z) :
    (f ≫ g).val = f.val ≫ g.val :=
  rfl
#align algebraic_geometry.LocallyRingedSpace.comp_val AlgebraicGeometry.LocallyRingedSpace.comp_val

@[simp]
theorem comp_val_c {X Y Z : LocallyRingedSpace.{u}} (f : X ⟶ Y) (g : Y ⟶ Z) :
    (f ≫ g).val.c = g.val.c ≫ (Presheaf.pushforward _ g.val.base).map f.val.c :=
  rfl
#align algebraic_geometry.LocallyRingedSpace.comp_val_c AlgebraicGeometry.LocallyRingedSpace.comp_val_c

theorem comp_val_c_app {X Y Z : LocallyRingedSpace} (f : X ⟶ Y) (g : Y ⟶ Z) (U : (Opens Z)ᵒᵖ) :
    (f ≫ g).val.c.app U = g.val.c.app U ≫ f.val.c.app (op <| (Opens.map g.val.base).obj U.unop) :=
  rfl
#align algebraic_geometry.LocallyRingedSpace.comp_val_c_app AlgebraicGeometry.LocallyRingedSpace.comp_val_c_app

/-- Given two locally ringed spaces `X` and `Y`, an isomorphism between `X` and `Y` as _sheafed_
spaces can be lifted to a morphism `X ⟶ Y` as locally ringed spaces.

See also `iso_of_SheafedSpace_iso`.
-/
@[simps]
def homOfSheafedSpaceHomOfIsIso {X Y : LocallyRingedSpace} (f : X.toSheafedSpace ⟶ Y.toSheafedSpace)
    [IsIso f] : X ⟶ Y :=
  Hom.mk f fun x =>
    -- Here we need to see that the stalk maps are really local ring homomorphisms.
    -- This can be solved by type class inference, because stalk maps of isomorphisms are isomorphisms
    -- and isomorphisms are local ring homomorphisms.
    show IsLocalRingHom (PresheafedSpace.stalkMap (SheafedSpace.forgetToPresheafedSpace.map f) x) by
      infer_instance
#align algebraic_geometry.LocallyRingedSpace.hom_of_SheafedSpace_hom_of_is_iso AlgebraicGeometry.LocallyRingedSpace.homOfSheafedSpaceHomOfIsIso

/-- Given two locally ringed spaces `X` and `Y`, an isomorphism between `X` and `Y` as _sheafed_
spaces can be lifted to an isomorphism `X ⟶ Y` as locally ringed spaces.

This is related to the property that the functor `forget_to_SheafedSpace` reflects isomorphisms.
In fact, it is slightly stronger as we do not require `f` to come from a morphism between
_locally_ ringed spaces.
-/
def isoOfSheafedSpaceIso {X Y : LocallyRingedSpace} (f : X.toSheafedSpace ≅ Y.toSheafedSpace) :
    X ≅ Y where
  Hom := homOfSheafedSpaceHomOfIsIso f.Hom
  inv := homOfSheafedSpaceHomOfIsIso f.inv
  hom_inv_id' := Hom.ext _ _ f.hom_inv_id
  inv_hom_id' := Hom.ext _ _ f.inv_hom_id
#align algebraic_geometry.LocallyRingedSpace.iso_of_SheafedSpace_iso AlgebraicGeometry.LocallyRingedSpace.isoOfSheafedSpaceIso

instance : ReflectsIsomorphisms forgetToSheafedSpace
    where reflects X Y f i :=
    {
      out :=
        ⟨hom_of_SheafedSpace_hom_of_is_iso (CategoryTheory.inv (forget_to_SheafedSpace.map f)),
          hom.ext _ _ (is_iso.hom_inv_id _), hom.ext _ _ (is_iso.inv_hom_id _)⟩ }

instance is_sheafedSpace_iso {X Y : LocallyRingedSpace} (f : X ⟶ Y) [IsIso f] : IsIso f.1 :=
  LocallyRingedSpace.forgetToSheafedSpace.map_isIso f
#align algebraic_geometry.LocallyRingedSpace.is_SheafedSpace_iso AlgebraicGeometry.LocallyRingedSpace.is_sheafedSpace_iso

/-- The restriction of a locally ringed space along an open embedding.
-/
@[simps]
def restrict {U : TopCat} (X : LocallyRingedSpace) {f : U ⟶ X.toTop} (h : OpenEmbedding f) :
    LocallyRingedSpace
    where
  LocalRing := by
    intro x
    dsimp at *
    -- We show that the stalk of the restriction is isomorphic to the original stalk,
    apply @RingEquiv.localRing _ _ _ (X.local_ring (f x))
    exact (X.to_PresheafedSpace.restrict_stalk_iso h x).symm.commRingIsoToRingEquiv
  toSheafedSpace := X.toSheafedSpace.restrict h
#align algebraic_geometry.LocallyRingedSpace.restrict AlgebraicGeometry.LocallyRingedSpace.restrict

/-- The canonical map from the restriction to the supspace. -/
def ofRestrict {U : TopCat} (X : LocallyRingedSpace) {f : U ⟶ X.toTop} (h : OpenEmbedding f) :
    X.restrict h ⟶ X :=
  ⟨X.toPresheafedSpace.of_restrict h, fun x => inferInstance⟩
#align algebraic_geometry.LocallyRingedSpace.of_restrict AlgebraicGeometry.LocallyRingedSpace.ofRestrict

/-- The restriction of a locally ringed space `X` to the top subspace is isomorphic to `X` itself.
-/
def restrictTopIso (X : LocallyRingedSpace) : X.restrict (Opens.openEmbedding ⊤) ≅ X :=
  @isoOfSheafedSpaceIso (X.restrict (Opens.openEmbedding ⊤)) X X.toSheafedSpace.restrictTopIso
#align algebraic_geometry.LocallyRingedSpace.restrict_top_iso AlgebraicGeometry.LocallyRingedSpace.restrictTopIso

/-- The global sections, notated Gamma.
-/
def Γ : LocallyRingedSpaceᵒᵖ ⥤ CommRingCat :=
  forgetToSheafedSpace.op ⋙ SheafedSpace.Γ
#align algebraic_geometry.LocallyRingedSpace.Γ AlgebraicGeometry.LocallyRingedSpace.Γ

theorem Γ_def : Γ = forgetToSheafedSpace.op ⋙ SheafedSpace.Γ :=
  rfl
#align algebraic_geometry.LocallyRingedSpace.Γ_def AlgebraicGeometry.LocallyRingedSpace.Γ_def

@[simp]
theorem Γ_obj (X : LocallyRingedSpaceᵒᵖ) : Γ.obj X = (unop X).Presheaf.obj (op ⊤) :=
  rfl
#align algebraic_geometry.LocallyRingedSpace.Γ_obj AlgebraicGeometry.LocallyRingedSpace.Γ_obj

theorem Γ_obj_op (X : LocallyRingedSpace) : Γ.obj (op X) = X.Presheaf.obj (op ⊤) :=
  rfl
#align algebraic_geometry.LocallyRingedSpace.Γ_obj_op AlgebraicGeometry.LocallyRingedSpace.Γ_obj_op

@[simp]
theorem Γ_map {X Y : LocallyRingedSpaceᵒᵖ} (f : X ⟶ Y) : Γ.map f = f.unop.1.c.app (op ⊤) :=
  rfl
#align algebraic_geometry.LocallyRingedSpace.Γ_map AlgebraicGeometry.LocallyRingedSpace.Γ_map

theorem Γ_map_op {X Y : LocallyRingedSpace} (f : X ⟶ Y) : Γ.map f.op = f.1.c.app (op ⊤) :=
  rfl
#align algebraic_geometry.LocallyRingedSpace.Γ_map_op AlgebraicGeometry.LocallyRingedSpace.Γ_map_op

theorem preimage_basicOpen {X Y : LocallyRingedSpace} (f : X ⟶ Y) {U : Opens Y}
    (s : Y.Presheaf.obj (op U)) :
    (Opens.map f.1.base).obj (Y.toRingedSpace.basicOpen s) =
      @RingedSpace.basicOpen X.toRingedSpace ((Opens.map f.1.base).obj U) (f.1.c.app _ s) :=
  by
  ext
  constructor
  · rintro ⟨⟨y, hyU⟩, hy : IsUnit _, rfl : y = _⟩
    erw [RingedSpace.mem_basic_open _ _ ⟨x, show x ∈ (opens.map f.1.base).obj U from hyU⟩]
    rw [← PresheafedSpace.stalk_map_germ_apply]
    exact (PresheafedSpace.stalk_map f.1 _).isUnit_map hy
  · rintro ⟨y, hy : IsUnit _, rfl⟩
    erw [RingedSpace.mem_basic_open _ _ ⟨f.1.base y.1, y.2⟩]
    rw [← PresheafedSpace.stalk_map_germ_apply] at hy
    exact (isUnit_map_iff (PresheafedSpace.stalk_map f.1 _) _).mp hy
#align algebraic_geometry.LocallyRingedSpace.preimage_basic_open AlgebraicGeometry.LocallyRingedSpace.preimage_basicOpen

-- This actually holds for all ringed spaces with nontrivial stalks.
@[simp]
theorem basicOpen_zero (X : LocallyRingedSpace) (U : Opens X.carrier) :
    X.toRingedSpace.basicOpen (0 : X.Presheaf.obj <| op U) = ⊥ :=
  by
  simp only [RingedSpace.basic_open, isUnit_zero_iff, map_zero, zero_ne_one' (X.presheaf.stalk _),
    Set.setOf_false, Set.image_empty]
  rfl
#align algebraic_geometry.LocallyRingedSpace.basic_open_zero AlgebraicGeometry.LocallyRingedSpace.basicOpen_zero

instance component_nontrivial (X : LocallyRingedSpace) (U : Opens X.carrier) [hU : Nonempty U] :
    Nontrivial (X.Presheaf.obj <| op U) :=
  (X.toPresheafedSpace.Presheaf.germ hU.some).domain_nontrivial
#align algebraic_geometry.LocallyRingedSpace.component_nontrivial AlgebraicGeometry.LocallyRingedSpace.component_nontrivial

end LocallyRingedSpace

end AlgebraicGeometry


/-
The Sinz at-most-one encoding.

Authors: Cayden Codel, Jeremy Avigad, Marijn Heule
Carnegie Mellon University
-/

import cnf.literal
import cnf.clause
import cnf.cnf
import cnf.encoding
import cnf.gensym

import cardinality.distinct
import cardinality.amk
import cardinality.alk

import data.list.basic
import data.nat.basic

variables {V : Type*} [inhabited V] [decidable_eq V]

namespace sinz_amo

open nat
open list
open literal
open clause
open cnf
open assignment
open encoding
open distinct
open gensym
open amk
open alk

variables {l : list (literal V)} {lit l₁ l₂ : literal V} {g : gensym V}
          {τ : assignment V} (hdis : disjoint g.stock (clause.vars l))
          {c : clause V}

lemma disjoint_fresh_of_disjoint : disjoint g.stock (clause.vars (lit :: l)) →
  disjoint g.fresh.2.stock (clause.vars l) :=
begin
  intro hdis,
  apply set.disjoint_right.mpr,
  intros v hv,
  have := (vars_subset_of_vars_cons lit l) hv,
  have := set.disjoint_right.mp hdis this,
  exact set.not_mem_subset (fresh_stock_subset g) this
end

lemma disjoint_fresh_of_disjoint_of_subset {l₂ : list (literal V)} :
  disjoint g.stock (clause.vars l) → l₂ ⊆ l → disjoint g.fresh.2.stock (clause.vars l₂) :=
begin
  intros hdis hss,
  apply set.disjoint_right.mpr,
  intros v hv,
  have := (clause.vars_subset_of_subset hss) hv,
  have := set.disjoint_right.mp hdis this,
  exact set.not_mem_subset (fresh_stock_subset g) this
end

-- A possible recursive definition. Proof was too challenging. Try again later?
/-
def sinz : Π (l : list (literal V)), Π (g : gensym V),
  (disjoint g.stock (clause.vars l)) → cnf V
| []               _ _            := []
| [l₁]             g hdis         := [] --[[l₁.flip, Pos (g.fresh.1)]] -- may be unneeded
| (l₁ :: l₂ :: ls) g hdis         :=
    [l₁.flip, Pos (g.fresh.1)] ::
    [Neg g.fresh.1, Pos g.fresh.2.fresh.1] ::
    [Neg g.fresh.1, l₂.flip] ::
    (sinz (l₂ :: ls) g.fresh.2 (disjoint_fresh_of_disjoint hdis))
-/

def xi_to_si (g : gensym V) (n i : nat) (lit : literal V) : cnf V :=
  if (i < n - 1) then [[lit.flip, Pos (g.nth i)]] else []

def si_to_next_si (g : gensym V) (n i : nat) : cnf V :=
  if (i < n - 2) then [[Neg (g.nth i), Pos (g.nth (i + 1))]] else []

def si_to_next_xi (g : gensym V) (i : nat) (lit : literal V) : cnf V :=
  if (0 < i) then [[Neg (g.nth (i - 1)), lit.flip]] else []

def sinz_amo (l : list (literal V)) (g : gensym V) : cnf V :=
if hl : length l < 2 then [] else
  join (map_with_index (λ (idx : nat) (lit : literal V),
    xi_to_si g (length l) idx lit ++
    si_to_next_si g (length l) idx ++
    si_to_next_xi g idx lit) l)

theorem xi_to_si_mem {l : list (literal V)} (hl : length l ≥ 2) (g : gensym V)
  {i : nat} (Hi' : i < length l - 1) (Hi : i < length l) :
  [(l.nth_le i Hi).flip, Pos (g.nth i)] ∈ sinz_amo l g :=
begin
  rw sinz_amo,
  simp [not_lt.mpr hl],
  use (xi_to_si g l.length i (l.nth_le i Hi) ++ si_to_next_si g l.length i ++ si_to_next_xi g i (l.nth_le i Hi)),
  split,
  { use [l.nth_le i Hi, i, Hi],
    simp only [eq_self_iff_true, append_assoc, and_self] },
  { simp [xi_to_si, Hi'] }
end

theorem si_to_next_si_mem {l : list (literal V)} (hl : length l ≥ 2) (g : gensym V)
  {i : nat} (Hi' : i < length l - 2) (Hi : i < length l) :
  [Neg (g.nth i), Pos (g.nth (i + 1))] ∈ sinz_amo l g :=
begin
  rw sinz_amo,
  simp [not_lt.mpr hl],
  use (xi_to_si g l.length i (l.nth_le i Hi) ++ si_to_next_si g l.length i ++ si_to_next_xi g i (l.nth_le i Hi)),
  split,
  { use [l.nth_le i Hi, i, Hi],
    simp only [eq_self_iff_true, append_assoc, and_self] },
  { simp [si_to_next_si, Hi'] }
end

theorem si_to_next_xi_mem {l : list (literal V)} (hl : length l ≥ 2) (g : gensym V)
  {i : nat} (Hi : 0 < i ∧ i < length l) :
  [Neg (g.nth (i - 1)), (l.nth_le i Hi.2).flip] ∈ sinz_amo l g :=
begin
  rw sinz_amo,
  simp [not_lt.mpr hl],
  use (xi_to_si g l.length i (l.nth_le i Hi.2) ++ si_to_next_si g l.length i ++ si_to_next_xi g i (l.nth_le i Hi.2)),
  split,
  { use [l.nth_le i Hi.2, i, Hi.2],
    simp only [eq_self_iff_true, append_assoc, and_self] },
  { simp [si_to_next_xi, Hi.1] }
end

def nth_from_var (g : gensym V) (v : V) : nat → nat
| 0       := 0
| (i + 1) := if v = g.nth (i + 1) then i + 1 else nth_from_var i

theorem nth_from_var_eq_nth_of_le (g : gensym V) {i n : nat} (Hi : i ≤ n) :
  nth_from_var g (g.nth i) n = i :=
begin
  induction n with n ih generalizing i,
  { cases i,
    { refl },
    { rw nonpos_iff_eq_zero at Hi,
      exact absurd Hi (succ_ne_zero _) } },
  { by_cases hn : i = n.succ,
    { subst hn,
      simp [nth_from_var] },
    { simp [nth_from_var, nth_ne_of_ne hn],
      exact ih (le_of_lt_succ (lt_of_le_of_ne Hi hn)) } }
end

def signal_truth (l : list (literal V)) (τ : assignment V) : nat → bool
| 0       := l.head.eval τ
| (i + 1) := if h : (i + 1) < length l then (l.nth_le (i + 1) h).eval τ || signal_truth i
             else ff

def sinz_tau (l : list (literal V)) (g : gensym V) (τ : assignment V) : assignment V :=
  λ v, if v ∈ clause.vars l then τ v else
    signal_truth l τ (nth_from_var g v (length l))

theorem signal_semantics {g : gensym V} {l : list (literal V)}
  (hdis : disjoint g.stock (clause.vars l)) {i : nat} :
  i < length l → ∀ {τ : assignment V},
  (signal_truth l τ i = tt ↔ alk.eval 1 τ (l.take (i + 1)) = tt) :=
begin
  intros hi τ,
  induction i with i ih,
  { simp [signal_truth, take_one_of_ne_nil (ne_nil_of_length_pos hi),
    alk.eval, alk, bool_symm] },
  { simp [signal_truth, hi],
    split,
    { rintros (hs | hs),
      { rw eval_take_tail_pos hi hs,
        exact eval_zero _ _ },
      { have ihred := (ih (lt_of_succ_lt hi)).mp hs,
        have := take_sublist_of_le (le_succ (i + 1)) l,
        exact eval_tt_of_sublist_of_eval_tt this ihred } },
    { intro hl,
      cases h : (l.nth_le (i + 1) _).eval τ,
      { rw eval_take_tail_neg hi h at hl,
        exact or.inr ((ih (lt_of_succ_lt hi)).mpr hl) },
      { simp only [eq_self_iff_true, true_or] } } }
end

lemma minus_two {n m : nat} : n < m - 2 → n + 1 < m :=
begin
  intro h, cases m,
  { linarith },
  { cases m,
    { linarith },
    { simp only [succ_sub_succ_eq_sub, tsub_zero] at h,
      exact lt_succ_of_lt (succ_lt_succ_iff.mpr h) } }
end

theorem xts_eval_tt {g : gensym V} {l : list (literal V)}
  (hdis : disjoint g.stock (clause.vars l)) {i : nat} (Hi : i < length l) :
  ∀ (τ : assignment V),
  (xi_to_si g (length l) i (l.nth_le i Hi)).eval (sinz_tau l g τ) = tt :=
begin
  intro τ,
  rw eval_tt_iff_forall_clause_eval_tt,
  intros c hc,
  rw [xi_to_si] at hc,
  by_cases Hi₂ : (i = l.length - 1),
  { simp [Hi₂] at hc, contradiction },
  { simp [lt_of_le_of_ne (le_pred_of_lt Hi) Hi₂] at hc,
    subst hc,
    rw eval_tt_iff_exists_literal_eval_tt,
    cases hl : (l.nth_le i Hi).eval τ,
    { use (l.nth_le i Hi).flip,
      have hmem := mem_vars_of_mem (nth_le_mem l i Hi),
      cases l.nth_le i Hi;
      { rw var at hmem,
        rw literal.eval at hl,
        simp [eval_flip, literal.eval, hl, sinz_tau, hmem] } },
    { use Pos (g.nth i),
      simp [literal.eval, sinz_tau, forall_nth_not_mem_of_disjoint' hdis i,
        nth_from_var_eq_nth_of_le g (le_of_lt Hi)],
      cases i,
      { rw signal_truth, rw nth_le_zero at hl, exact hl },
      { simp [signal_truth, Hi], exact or.inl hl } } }
end

theorem stns_eval_tt {g : gensym V} {l : list (literal V)}
  (hdis : disjoint g.stock (clause.vars l)) :
  ∀ (i : nat) (τ : assignment V),
  (si_to_next_si g (length l) i).eval (sinz_tau l g τ) = tt :=
begin
  intros i τ,
  rw eval_tt_iff_forall_clause_eval_tt,
  intros c hc,
  rw si_to_next_si at hc,
  by_cases hi : (i < l.length - 2),
  { simp [hi] at hc,
    subst hc,
    rw eval_tt_iff_exists_literal_eval_tt,
    cases hs : (sinz_tau l g τ) (g.nth i),
    { use Neg (g.nth i),
      simp [literal.eval, hs] },
    { use Pos (g.nth (i + 1)),
      simp [literal.eval, sinz_tau, forall_nth_not_mem_of_disjoint' hdis (i + 1)],
      have : i + 1 < l.length, from minus_two hi,
      rw nth_from_var_eq_nth_of_le g (le_of_lt this),
      simp [signal_truth, this],
      simp [sinz_tau, forall_nth_not_mem_of_disjoint' hdis i,
        nth_from_var_eq_nth_of_le g (le_of_lt (lt_of_succ_lt this))] at hs,
      exact or.inr hs } },
  { simp [hi] at hc, contradiction }
end

theorem stnx_eval_tt {g : gensym V} {l : list (literal V)}
  (hdis : disjoint g.stock (clause.vars l)) {i : nat} (Hi : i < length l) :
  ∀ (τ : assignment V), amk.eval 1 τ (l.take (i + 1)) = tt →
  (si_to_next_xi g i (l.nth_le i Hi)).eval (sinz_tau l g τ) = tt :=
begin
  intros τ hamo,
  rw eval_tt_iff_forall_clause_eval_tt,
  intros c hc,
  rw si_to_next_xi at hc,
  cases i; simp at hc,
  { contradiction },
  { subst hc,
    rw eval_tt_iff_exists_literal_eval_tt,
    cases hs : (sinz_tau l g τ) (g.nth i),
    { use Neg (g.nth i),
      simp [hs, literal.eval] },
    { simp [sinz_tau, forall_nth_not_mem_of_disjoint' hdis i] at hs,
      rw nth_from_var_eq_nth_of_le g (le_of_lt (lt_of_succ_lt Hi)) at hs,
      cases ht : (l.nth_le _ Hi).eval (sinz_tau l g τ),
      { use (l.nth_le _ Hi).flip,
        simp [eval_flip, literal.eval, ht] },
      { have heqod : eqod (sinz_tau l g τ) τ (clause.vars l),
        { rw sinz_tau,
          intros v hv,
          simp [hv] },
        have := (signal_semantics hdis (lt_of_succ_lt Hi)).mp hs,
        have hmem := mem_vars_of_mem (nth_le_mem l _ Hi),
        rw eval_eq_of_eqod_of_var_mem heqod hmem at ht,
        rw eval_tail_pos ht at hamo,
        rw alk_of_amk_of_gt hamo nat.one_pos at this,
        contradiction } } }
end

-- Forward direction
theorem sinz_forward {τ : assignment V} {l : list (literal V)} {g : gensym V}
  (hdis : disjoint g.stock (clause.vars l)) :
  amk.eval 1 τ l = tt → (sinz_amo l g).eval (sinz_tau l g τ) = tt :=
begin
  intro hamo,
  rw eval_tt_iff_forall_clause_eval_tt,
  intros c hc,
  by_cases hl : length l < 2,
  { simp [sinz_amo, hl] at hc, exfalso, exact hc },
  { simp [sinz_amo, hl] at hc,
    rcases hc with ⟨f, ⟨lit, i, ⟨Hi, rfl⟩, rfl⟩, hc⟩,
    simp at hc,
    rcases hc with (hc | hc | hc),
    { have := xts_eval_tt hdis Hi τ,
      exact eval_tt_iff_forall_clause_eval_tt.mp this _ hc },
    { have := stns_eval_tt hdis i τ,
      exact eval_tt_iff_forall_clause_eval_tt.mp this _ hc },
    { have := amk.eval_take hamo (i + 1),
      have := stnx_eval_tt hdis Hi τ this,
      rw si_to_next_xi at hc,
      by_cases hiz : (0 < i),
      { simp [hiz] at hc, subst hc,
        simp [si_to_next_xi, eval_tt_iff_forall_clause_eval_tt, hiz] at this,
        rw eval_tt_iff_exists_literal_eval_tt,
        rcases this with (hl | hl),
        { use Neg (g.nth (i - 1)), simp [hl] },
        { use (l.nth_le i Hi).flip, simp [hl] } },
      { simp [hiz] at hc, exfalso, exact hc } } }
end

-- Reverse direction --

-- Proofs for necessary conditions for setting signal variables to true
theorem signal_nec2 {τ} {l : list (literal V)} (hl : length l ≥ 2) {g : gensym V}
  {i : nat} (hi : i < length l - 2) :
  (sinz_amo l g).eval τ = tt →
  τ (g.nth i) = tt → ∀ {j : nat}, (j > i ∧ j < length l - 1) → τ (g.nth j) = tt :=
begin
  rintros hs hg j ⟨hij, hj⟩,
  induction j with j ih,
  { linarith },
  { by_cases hij' : i = j,
    { subst hij',
      have := si_to_next_si_mem hl g hi (lt_of_succ_lt (minus_two hi)),
      have := eval_tt_iff_forall_clause_eval_tt.mp hs _ this,
      simp [eval_tt_iff_exists_literal_eval_tt] at this,
      rcases this with (hl | hl),
      { rw [literal.eval, hg] at hl, contradiction },
      { rw literal.eval at hl, exact hl } },
    { have := lt_of_le_of_ne (le_of_lt_succ hij) hij',
      have ihred := ih this (lt_of_succ_lt hj),
      have hjl : j < length l,
      { rcases exists_eq_add_of_le hl with ⟨k, hk⟩,
        rw add_comm at hk,
        simp [hk] at hj |-,
        exact lt_of_succ_lt (lt_succ_of_lt hj) },
      have : j < length l - 2,
      { rcases exists_eq_add_of_le hl with ⟨k, hk⟩,
        rw add_comm at hk,
        simp [hk] at hj |-,
        exact succ_lt_succ_iff.mp hj },
      have := si_to_next_si_mem hl g this hjl,
      have := eval_tt_iff_forall_clause_eval_tt.mp hs _ this,
      simp [eval_tt_iff_exists_literal_eval_tt] at this,
      rcases this with (hl | hl),
      { rw [literal.eval, ihred] at hl, contradiction },
      { rw literal.eval at hl, exact hl } } }
end

theorem signal_nec {τ} {l : list (literal V)} (hl : length l ≥ 2) {g : gensym V}
  {i : nat} (hi : i < length l - 1) :
  (sinz_amo l g).eval τ = tt →
  alk.eval 1 τ (l.take (i + 1)) = tt → τ (g.nth i) = tt :=
begin
  intros hs hlk,
  induction i with i ih,
  { cases l with l ls,
    { rw length at hi, linarith },
    { rw length at hl,
      have : ls.length > 0, linarith,
      have : [l.flip, Pos (g.nth 0)] ∈ ite (0 < ls.length) [[l.flip, Pos (g.nth 0)]] [],
      { have : 0 < ls.length, exact this,
        simp [this] },
      simp [alk.eval, alk] at hlk,
      simp [sinz_amo, not_lt.mpr hl, eval_tt_iff_forall_clause_eval_tt, xi_to_si] at hs,
      have := hs _ (or.inl this),
      simp [eval_tt_iff_exists_literal_eval_tt] at this,
      rcases this with (hl | hl),
      { rw [eval_flip, ← hlk] at hl, contradiction },
      { rw literal.eval at hl, exact hl } } },
  { have : i + 1 < length l, from lt_of_lt_pred hi,
    cases hx : literal.eval τ (l.nth_le _ this),
    { rw eval_take_tail_neg this hx at hlk,
      have ihred := ih (lt_of_succ_lt hi) hlk,
      have : i < l.length - 2,
      { rcases exists_eq_add_of_le hl with ⟨k, hk⟩,
        rw add_comm at hk,
        simp [hk] at hi |-,
        exact succ_lt_succ_iff.mp hi },
      apply signal_nec2 hl this hs ihred,
      split,
      { exact lt_succ_self i },
      { rcases exists_eq_add_of_le hl with ⟨k, hk⟩,
        rw add_comm at hk,
        simp [hk] at this |-,
        exact succ_lt_succ_iff.mpr this } },
    { have hmem := xi_to_si_mem hl g hi this,
      have := eval_tt_iff_forall_clause_eval_tt.mp hs _ hmem,
      simp [eval_tt_iff_exists_literal_eval_tt] at this,
      rcases this with (hl | hl),
      { rw [eval_flip, hx] at hl, contradiction },
      { rw literal.eval at hl, exact hl } } }
end

theorem signal_nec3 {τ} {l : list (literal V)} (hl : length l ≥ 2) {g : gensym V}
  {i : nat} (hi : i < length l) :
  (sinz_amo l g).eval τ = tt → τ (g.nth i) = tt →
  ∀ {j : nat} (hj : (j > i ∧ j < length l)), (l.nth_le j hj.2).eval τ = ff :=
begin
  rintros hs hg j ⟨hij, hj⟩,
  have hs' := hs,
  rw eval_tt_iff_forall_clause_eval_tt at hs,
  have hc := hs _ (si_to_next_xi_mem hl g ⟨pos_of_gt hij, hj⟩),
  by_cases hj' : (j - 1) = i,
  { rw [hj', eval_tt_iff_exists_literal_eval_tt] at hc,
    simp at hc,
    rcases hc with ⟨lit, (rfl | rfl), he⟩,
    { simp [literal.eval, hg] at he, contradiction },
    { simp [eval_flip] at he, exact he } },
  { have hsub : j - 1 > i,
    { have := pos_of_gt hij,
      cases j,
      { linarith },
      { have : i ≤ j, exact lt_succ_iff.mp hij,
        simp at hj' |-,
        exact lt_of_le_of_ne this (ne.symm hj') } },
    have : j - 1 < length l - 1,
    { rcases exists_eq_add_of_le hl with ⟨k, hk⟩,
      rw add_comm at hk,
      simp [hk] at hj |-,
      cases j,
      { simp },
      { simp, exact succ_lt_succ_iff.mp hj } },
    have hi₂ : i < l.length - 2,
    { rcases exists_eq_add_of_le hl with ⟨k, hk⟩,
      rw add_comm at hk,
      simp [hk] at this |-,
      exact lt_of_lt_of_le hsub (le_of_lt_succ this) },
    have := signal_nec2 hl hi₂ hs' hg ⟨hsub, this⟩,
    simp [eval_tt_iff_exists_literal_eval_tt] at hc,
    rcases hc with (hl | hl),
    { rw [literal.eval, this] at hl, contradiction },
    { simp [eval_flip] at hl, exact hl } }
end

theorem sinz_reverse {τ} {l : list (literal V)} {g : gensym V}
  (hdis : disjoint g.stock (clause.vars l)) :
  (sinz_amo l g).eval τ = tt → amk.eval 1 τ l = tt :=
begin
  intro hs,
  by_cases hl : length l ≥ 2,
  { rw amo_eval_tt_iff_distinct_eval_ff_of_eval_tt,
    rintros lit₁ lit₂ ⟨i, j, hi, hj, hij, rfl, rfl⟩ hl₁,
    have : i < length l - 1, from lt_of_lt_of_le hij (le_pred_of_lt hj),
    have := signal_nec hl this hs (amo_take_of_tt hi hl₁),
    exact signal_nec3 hl hi hs this ⟨hij, hj⟩ },
  { rw not_le at hl,
    exact eval_tt_of_ge_length (le_of_lt_succ hl) _ }
end

theorem sinz_amo_encodes_amo {l : list (literal V)} {g : gensym V}
  (hdis : disjoint g.stock (clause.vars l)) :
  encodes (amk 1) (sinz_amo l g) l :=
begin
  intro τ, split,
  { intro hamo,
    use sinz_tau l g τ,
    split,
    { exact sinz_forward hdis hamo },
    { intros v hv, simp [sinz_tau, hv] } },
  { rintros ⟨σ, hs, heqod⟩,
    rw [← amk.eval, eval_eq_amk_of_eqod 1 heqod],
    exact sinz_reverse hdis hs }
end

/-
theorem mem_sinz_vars_of_mem {l : list (literal V)} {g : gensym V} :
  length l ≥ 2 → clause.vars l ⊆ cnf.vars (sinz_amo l g hdis) :=
begin
  intro hlen,
  induction l using strong_induction_on_lists with l ih generalizing g,
  rcases exists_cons_cons_of_length_ge_two hlen with ⟨l₁, l₂, ls, rfl⟩,
  intros v hv,
  rw sinz,
  simp [clause.vars] at hv,
  rcases hv with (rfl | rfl | hv),
  { simp [cnf.vars, clause.vars, flip_var_eq] },
  { simp [cnf.vars, clause.vars, flip_var_eq] },
  { cases ls with l₃ ls,
    { rw clause.vars_nil at hv,
      exact absurd hv (finset.not_mem_empty _) },
    { have hlen' : length (l₂ :: l₃ :: ls) ≥ 2, dec_trivial,
      have hless : length (l₂ :: l₃ :: ls) < length (l₁ :: l₂ :: l₃ :: ls), simp,
      have hdis' := disjoint_fresh_of_disjoint hdis,
      simp [cnf.vars],
      right, right, right,
      exact (ih _ hless hlen' hdis') (vars_subset_of_vars_cons l₂ (l₃ :: ls) hv) } }
end

theorem mem_or_mem_of_mem_vars {v : V} : v ∈ cnf.vars (sinz l g hdis) →
  v ∈ clause.vars l ∨ v ∈ g.stock :=
begin
  induction l using strong_induction_on_lists with l ih generalizing g,
  cases l with l₁ ls,
  { rw [sinz, cnf.vars_nil], intro h, exact absurd h (finset.not_mem_empty _) },
  cases ls with l₂ ls,
  { rw [sinz, cnf.vars_nil], intro h, exact absurd h (finset.not_mem_empty _) },
  rw sinz,
  intro h,
  simp [cnf.vars, clause.vars, flip_var_eq, var] at h,
  rcases h with (rfl | rfl | rfl | rfl | rfl | h),
  { left, simp [clause.vars] },
  { exact or.inr (fresh_mem_stock g) },
  { exact or.inr (fresh_fresh_mem_stock g) },
  { exact or.inr (fresh_mem_stock g) },
  { left, simp [clause.vars] },
  { cases ls with l₃ ls,
    { rw [sinz, cnf.vars_nil] at h,
      exact absurd h (finset.not_mem_empty _) },
    { have hlen := length_lt_length_cons l₁ (l₂ :: l₃ :: ls),
      have hdis' := disjoint_fresh_of_disjoint hdis,
      rcases ih _ hlen hdis' h with (hv | hv),
      { exact or.inl ((vars_subset_of_vars_cons l₁ _) hv) },
      { exact or.inr (fresh_stock_subset g hv) } } }
end

theorem not_mem_sinz_vars_of_not_mems {v : V} : v ∉ clause.vars l →
  v ∉ g.stock → v ∉ cnf.vars (sinz l g hdis) :=
begin
  intros hvar hstock,
  induction l using strong_induction_on_lists with l ih generalizing g,
  cases l with l₁ ls,
  { simp [sinz] },
  cases ls with l₂ ls,
  { simp [sinz] },
  have hg₁ : v ≠ g.fresh.1,
  { exact (ne_of_mem_of_not_mem (fresh_mem_stock g) hstock).symm },
  have hg₂ : v ≠ g.fresh.2.fresh.1,
  { exact (ne_of_mem_of_not_mem (fresh_fresh_mem_stock g) hstock).symm },
  cases ls with l₃ ls,
  { simp [clause.vars, not_or_distrib] at hvar,
    rcases hvar with ⟨hvar₁, hvar₂⟩,
    simp [sinz, cnf.vars, clause.vars, not_or_distrib, flip_var_eq, var,
      hvar₁, hvar₂, hg₁, hg₂] },
  { rw sinz,
    have hvar' : v ∉ clause.vars (l₂ :: l₃ :: ls),
    { rw clause.vars at hvar,
      simp only [not_or_distrib, finset.mem_union, finset.mem_singleton] at hvar,
      exact hvar.2 },
    have hless : length (l₂ :: l₃ :: ls) < length (l₁ :: l₂ :: l₃ :: ls), simp,
    have hdis' := disjoint_fresh_of_disjoint hdis,
    have : v ∉ g.fresh.2.stock,
    { intro hcon,
      exact hstock ((fresh_stock_subset g) hcon) },
    have ihred := ih _ hless hvar' hdis' this,
    simp [clause.vars, not_or_distrib] at hvar,
    rcases hvar with ⟨hvar₁, hvar₂, hvar₃, hvar⟩,
    simp [cnf.vars, clause.vars, not_or_distrib, flip_var_eq, var,
      hvar₁, hvar₂, hvar₃, hg₁, hg₂, ihred] }
end
-/

end sinz_amo


import metric_spaces.basic

/--
In this file we showed that the `closed_set` form a Galois insertion with
`Closure` being its Galois connection, and with that, we conclude `closed_set`
form a `complete_lattice`.

- `closed_set` is defined to be a closed subset of a metric space
- `Closure` is defined to be a `closed_set` with `closure' _` as its carrier
-/

variables {X : Type*} [metric_space X]
variables {Y : Type*} [metric_space Y]

open definitions set

namespace closed_set

open open_closed_sets.closure'

/- Defining the structure of a closed set -/
structure closed_set (X : Type*) [metric_space X] :=
(carrier : set X)
(is_closed : is_closed' carrier)

instance : has_coe (closed_set X) (set X) := ⟨closed_set.carrier⟩

def Closure (S : set X) : closed_set X :=
{ carrier := closure' S,
  is_closed := closure_closed S }

theorem ext' {S T : closed_set X} (h : (S : set X) = T) : S = T :=
by cases S; cases T; congr'

/- Closed sets form a partial order -/
instance : partial_order (closed_set X) :=
{.. partial_order.lift (coe : closed_set X → set X) (λ a b, ext') (by apply_instance)}

/- The closure of a closed_set is itself -/
lemma Closure_self (T : closed_set X) : T = Closure T.1 :=
ext' $ show ↑T = closure' T.carrier, by {rw closure_self, refl, from T.2}

/- Closed sets form a Galois insertion -/
def gi : @galois_insertion (set X) (closed_set X) _ _ Closure closed_set.carrier :=
{ choice := λ S h, Closure S,
  gc := λ S T,
    ⟨λ h, set.subset.trans subset_closure' h, λ h, by rw Closure_self T; from closure_mono' h⟩,
  le_l_u := λ S, subset_closure',
  choice_eq := λ _ _, rfl }

/- Closed sets form a complete lattice -/
instance : complete_lattice (closed_set X) :=
{ .. galois_insertion.lift_complete_lattice gi}

end closed_set


/-
Copyright (c) 2021 Kalle Kytölä. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kalle Kytölä
-/
import topology.algebra.weak_dual_topology
import analysis.normed_space.dual
import analysis.normed_space.operator_norm

/-!
# Weak dual of normed space

Let `E` be a normed space over a field `𝕜`. This file is concerned with properties of the weak-*
topology on the dual of `E`. By the dual, we mean either of the type synonyms
`normed_space.dual 𝕜 E` or `weak_dual 𝕜 E`, depending on whether it is viewed as equipped with its
usual operator norm topology or the weak-* topology.

It is shown that the canonical mapping `normed_space.dual 𝕜 E → weak_dual 𝕜 E` is continuous, and
as a consequence the weak-* topology is coarser than the topology obtained from the operator norm
(dual norm).

The file is a stub, some TODOs below.

## Main definitions

The main definitions concern the canonical mapping `dual 𝕜 E → weak_dual 𝕜 E`.

* `normed_space.dual.to_weak_dual` and `weak_dual.to_normed_dual`: Linear equivalences from
  `dual 𝕜 E` to `weak_dual 𝕜 E` and in the converse direction.
* `normed_space.dual.continuous_linear_map_to_weak_dual`: A continuous linear mapping from
  `dual 𝕜 E` to `weak_dual 𝕜 E` (same as `normed_space.dual.to_weak_dual` but different bundled
  data).

## Main results

The first main result concerns the comparison of the operator norm topology on `dual 𝕜 E` and the
weak-* topology on (its type synonym) `weak_dual 𝕜 E`:
* `dual_norm_topology_le_weak_dual_topology`: The weak-* topology on the dual of a normed space is
  coarser (not necessarily strictly) than the operator norm topology.

TODOs:
* Add that in finite dimensions, the weak-* topology and the dual norm topology coincide.
* Add that in infinite dimensions, the weak-* topology is strictly coarser than the dual norm
  topology.
* Add Banach-Alaoglu theorem (general version maybe in `topology.algebra.weak_dual_topology`).
* Add metrizability of the dual unit ball (more generally bounded subsets) of `weak_dual 𝕜 E`
  under the assumption of separability of `E`. Sequential Banach-Alaoglu theorem would then follow
  from the general one.

## Notations

No new notation is introduced.

## Implementation notes

Weak-* topology is defined generally in the file `topology.algebra.weak_dual_topology`.

When `E` is a normed space, the duals `dual 𝕜 E` and `weak_dual 𝕜 E` are type synonyms with
different topology instances.

## References

* https://en.wikipedia.org/wiki/Weak_topology#Weak-*_topology

## Tags

weak-star, weak dual

-/

noncomputable theory
open filter
open_locale topological_space

section weak_star_topology_for_duals_of_normed_spaces
/-!
### Weak star topology on duals of normed spaces
In this section, we prove properties about the weak-* topology on duals of normed spaces.
We prove in particular that the canonical mapping `dual 𝕜 E → weak_dual 𝕜 E` is continuous,
i.e., that the weak-* topology is coarser (not necessarily strictly) than the topology given
by the dual-norm (i.e. the operator-norm).
-/

open normed_space

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
variables {E : Type*} [normed_group E] [normed_space 𝕜 E]

/-- For normed spaces `E`, there is a canonical map `dual 𝕜 E → weak_dual 𝕜 E` (the "identity"
mapping). It is a linear equivalence. -/
def normed_space.dual.to_weak_dual : dual 𝕜 E ≃ₗ[𝕜] weak_dual 𝕜 E :=
linear_equiv.refl 𝕜 (E →L[𝕜] 𝕜)

/-- For normed spaces `E`, there is a canonical map `weak_dual 𝕜 E → dual 𝕜 E` (the "identity"
mapping). It is a linear equivalence. Here it is implemented as the inverse of the linear
equivalence `normed_space.dual.to_weak_dual` in the other direction. -/
def weak_dual.to_normed_dual : weak_dual 𝕜 E ≃ₗ[𝕜] dual 𝕜 E :=
normed_space.dual.to_weak_dual.symm

@[simp] lemma weak_dual.coe_to_fun_eq_normed_coe_to_fun (x' : dual 𝕜 E) :
  (x'.to_weak_dual : E → 𝕜) = x' := rfl

namespace normed_space.dual

@[simp] lemma to_weak_dual_eq_iff (x' y' : dual 𝕜 E) :
  x'.to_weak_dual = y'.to_weak_dual ↔ x' = y' :=
to_weak_dual.injective.eq_iff

@[simp] lemma _root_.weak_dual.to_normed_dual_eq_iff (x' y' : weak_dual 𝕜 E) :
  x'.to_normed_dual = y'.to_normed_dual ↔ x' = y' :=
weak_dual.to_normed_dual.injective.eq_iff

theorem to_weak_dual_continuous :
  continuous (λ (x' : dual 𝕜 E), x'.to_weak_dual) :=
begin
  apply weak_dual.continuous_of_continuous_eval,
  intros z,
  exact (inclusion_in_double_dual 𝕜 E z).continuous,
end

/-- For a normed space `E`, according to `to_weak_dual_continuous` the "identity mapping"
`dual 𝕜 E → weak_dual 𝕜 E` is continuous. This definition implements it as a continuous linear
map. -/
def continuous_linear_map_to_weak_dual : dual 𝕜 E →L[𝕜] weak_dual 𝕜 E :=
{ cont := to_weak_dual_continuous, .. to_weak_dual, }

/-- The weak-star topology is coarser than the dual-norm topology. -/
theorem dual_norm_topology_le_weak_dual_topology :
  (by apply_instance : topological_space (dual 𝕜 E)) ≤
    (by apply_instance : topological_space (weak_dual 𝕜 E)) :=
begin
  refine continuous.le_induced _,
  apply continuous_pi_iff.mpr,
  intros z,
  exact (inclusion_in_double_dual 𝕜 E z).continuous,
end

end normed_space.dual

end weak_star_topology_for_duals_of_normed_spaces


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

! This file was ported from Lean 3 source module category_theory.eq_to_hom
! leanprover-community/mathlib commit dc6c365e751e34d100e80fe6e314c3c3e0fd2988
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Opposites

/-!
# Morphisms from equations between objects.

When working categorically, sometimes one encounters an equation `h : X = Y` between objects.

Your initial aversion to this is natural and appropriate:
you're in for some trouble, and if there is another way to approach the problem that won't
rely on this equality, it may be worth pursuing.

You have two options:
1. Use the equality `h` as one normally would in Lean (e.g. using `rw` and `subst`).
   This may immediately cause difficulties, because in category theory everything is dependently
   typed, and equations between objects quickly lead to nasty goals with `eq.rec`.
2. Promote `h` to a morphism using `eqToHom h : X ⟶ Y`, or `eqToIso h : X ≅ Y`.

This file introduces various `simp` lemmas which in favourable circumstances
result in the various `eqToHom` morphisms to drop out at the appropriate moment!
-/

universe v₁ v₂ v₃ u₁ u₂ u₃

-- morphism levels before object levels. See note [CategoryTheory universes].
namespace CategoryTheory

open Opposite

variable {C : Type u₁} [Category.{v₁} C]

/-- An equality `X = Y` gives us a morphism `X ⟶ Y`.

It is typically better to use this, rather than rewriting by the equality then using `𝟙 _`
which usually leads to dependent type theory hell.
-/
def eqToHom {X Y : C} (p : X = Y) : X ⟶ Y := by rw [p]; exact 𝟙 _
#align category_theory.eq_to_hom CategoryTheory.eqToHom

@[simp]
theorem eqToHom_refl (X : C) (p : X = X) : eqToHom p = 𝟙 X :=
  rfl
#align category_theory.eq_to_hom_refl CategoryTheory.eqToHom_refl

@[reassoc (attr := simp)]
theorem eqToHom_trans {X Y Z : C} (p : X = Y) (q : Y = Z) :
    eqToHom p ≫ eqToHom q = eqToHom (p.trans q) :=
  by
  cases p
  cases q
  simp
#align category_theory.eq_to_hom_trans CategoryTheory.eqToHom_trans

theorem comp_eqToHom_iff {X Y Y' : C} (p : Y = Y') (f : X ⟶ Y) (g : X ⟶ Y') :
    f ≫ eqToHom p = g ↔ f = g ≫ eqToHom p.symm :=
  { mp := fun h => h ▸ by simp
    mpr := fun h => by simp [eq_whisker h (eqToHom p)] }
#align category_theory.comp_eq_to_hom_iff CategoryTheory.comp_eqToHom_iff

theorem eqToHom_comp_iff {X X' Y : C} (p : X = X') (f : X ⟶ Y) (g : X' ⟶ Y) :
    eqToHom p ≫ g = f ↔ g = eqToHom p.symm ≫ f :=
  { mp := fun h => h ▸ by simp
    mpr := fun h => h ▸ by simp [whisker_eq _ h] }
#align category_theory.eq_to_hom_comp_iff CategoryTheory.eqToHom_comp_iff

/- Porting note: simpNF complains about thsi not reducing but it is clearly used
in `congrArg_mrp_hom_left`. It has been no-linted. -/
/-- Reducible form of congrArg_mpr_hom_left -/
@[simp, nolint simpNF]
theorem congrArg_cast_hom_left {X Y Z : C} (p : X = Y) (q : Y ⟶  Z) :
    cast (congrArg (fun W : C => W ⟶  Z) p.symm) q = eqToHom p ≫ q := by
  cases p
  simp

 /-- If we (perhaps unintentionally) perform equational rewriting on
the source object of a morphism,
we can replace the resulting `_.mpr f` term by a composition with an `eqToHom`.

It may be advisable to introduce any necessary `eqToHom` morphisms manually,
rather than relying on this lemma firing.
-/
theorem congrArg_mpr_hom_left {X Y Z : C} (p : X = Y) (q : Y ⟶ Z) :
    (congrArg (fun W : C => W ⟶ Z) p).mpr q = eqToHom p ≫ q := by
  cases p
  simp
#align category_theory.congr_arg_mpr_hom_left CategoryTheory.congrArg_mpr_hom_left

/- Porting note: simpNF complains about thsi not reducing but it is clearly used
in `congrArg_mrp_hom_right`. It has been no-linted. -/
/-- Reducible form of `congrArg_mpr_hom_right` -/
@[simp, nolint simpNF]
theorem congrArg_cast_hom_right {X Y Z : C} (p : X ⟶ Y) (q : Z = Y) :
    cast (congrArg (fun W : C => X ⟶  W) q.symm) p = p ≫ eqToHom q.symm := by
  cases q
  simp

/-- If we (perhaps unintentionally) perform equational rewriting on
the target object of a morphism,
we can replace the resulting `_.mpr f` term by a composition with an `eqToHom`.

It may be advisable to introduce any necessary `eqToHom` morphisms manually,
rather than relying on this lemma firing.
-/
theorem congrArg_mpr_hom_right {X Y Z : C} (p : X ⟶ Y) (q : Z = Y) :
    (congrArg (fun W : C => X ⟶ W) q).mpr p = p ≫ eqToHom q.symm := by
  cases q
  simp
#align category_theory.congr_arg_mpr_hom_right CategoryTheory.congrArg_mpr_hom_right

/-- An equality `X = Y` gives us an isomorphism `X ≅ Y`.

It is typically better to use this, rather than rewriting by the equality then using `Iso.refl _`
which usually leads to dependent type theory hell.
-/
def eqToIso {X Y : C} (p : X = Y) : X ≅ Y :=
  ⟨eqToHom p, eqToHom p.symm, by simp, by simp⟩
#align category_theory.eq_to_iso CategoryTheory.eqToIso

@[simp]
theorem eqToIso.hom {X Y : C} (p : X = Y) : (eqToIso p).hom = eqToHom p :=
  rfl
#align category_theory.eq_to_iso.hom CategoryTheory.eqToIso.hom

@[simp]
theorem eqToIso.inv {X Y : C} (p : X = Y) : (eqToIso p).inv = eqToHom p.symm :=
  rfl
#align category_theory.eq_to_iso.inv CategoryTheory.eqToIso.inv

@[simp]
theorem eqToIso_refl {X : C} (p : X = X) : eqToIso p = Iso.refl X :=
  rfl
#align category_theory.eq_to_iso_refl CategoryTheory.eqToIso_refl

@[simp]
theorem eqToIso_trans {X Y Z : C} (p : X = Y) (q : Y = Z) :
    eqToIso p ≪≫ eqToIso q = eqToIso (p.trans q) := by ext; simp
#align category_theory.eq_to_iso_trans CategoryTheory.eqToIso_trans

@[simp]
theorem eqToHom_op {X Y : C} (h : X = Y) : (eqToHom h).op = eqToHom (congr_arg op h.symm) := by
  cases h
  rfl
#align category_theory.eq_to_hom_op CategoryTheory.eqToHom_op

@[simp]
theorem eqToHom_unop {X Y : Cᵒᵖ} (h : X = Y) :
    (eqToHom h).unop = eqToHom (congr_arg unop h.symm) := by
  cases h
  rfl
#align category_theory.eq_to_hom_unop CategoryTheory.eqToHom_unop

instance {X Y : C} (h : X = Y) : IsIso (eqToHom h) :=
  IsIso.of_iso (eqToIso h)

@[simp]
theorem inv_eqToHom {X Y : C} (h : X = Y) : inv (eqToHom h) = eqToHom h.symm := by
  aesop_cat
#align category_theory.inv_eq_to_hom CategoryTheory.inv_eqToHom

variable {D : Type u₂} [Category.{v₂} D]

namespace Functor

/-- Proving equality between functors. This isn't an extensionality lemma,
  because usually you don't really want to do this. -/
theorem ext {F G : C ⥤ D} (h_obj : ∀ X, F.obj X = G.obj X)
    (h_map : ∀ X Y f, F.map f = eqToHom (h_obj X) ≫ G.map f ≫ eqToHom (h_obj Y).symm) :
    F = G := by
  match F, G with
  | mk F_pre _ _ , mk G_pre _ _ =>
    match F_pre, G_pre with  -- Porting note: did not unfold the Prefunctor unlike Lean3
    | Prefunctor.mk F_obj _ , Prefunctor.mk G_obj _ =>
    obtain rfl : F_obj = G_obj := by
      ext X
      apply h_obj
    congr
    funext X Y f
    simpa using h_map X Y f
#align category_theory.functor.ext CategoryTheory.Functor.ext

/-- Two morphisms are conjugate via eqToHom if and only if they are heterogeneously equal. -/
theorem conj_eqToHom_iff_hEq {W X Y Z : C} (f : W ⟶ X) (g : Y ⟶ Z) (h : W = Y) (h' : X = Z) :
    f = eqToHom h ≫ g ≫ eqToHom h'.symm ↔ HEq f g := by
  cases h
  cases h'
  simp
#align category_theory.functor.conj_eq_to_hom_iff_heq CategoryTheory.Functor.conj_eqToHom_iff_hEq

/-- Proving equality between functors using heterogeneous equality. -/
theorem hext {F G : C ⥤ D} (h_obj : ∀ X, F.obj X = G.obj X)
    (h_map : ∀ (X Y) (f : X ⟶ Y), HEq (F.map f) (G.map f)) : F = G :=
  Functor.ext h_obj fun _ _ f => (conj_eqToHom_iff_hEq _ _ (h_obj _) (h_obj _)).2 <| h_map _ _ f
#align category_theory.functor.hext CategoryTheory.Functor.hext

-- Using equalities between functors.
theorem congr_obj {F G : C ⥤ D} (h : F = G) (X) : F.obj X = G.obj X := by rw [h]
#align category_theory.functor.congr_obj CategoryTheory.Functor.congr_obj

theorem congr_hom {F G : C ⥤ D} (h : F = G) {X Y} (f : X ⟶ Y) :
    F.map f = eqToHom (congr_obj h X) ≫ G.map f ≫ eqToHom (congr_obj h Y).symm := by
  subst h; simp
#align category_theory.functor.congr_hom CategoryTheory.Functor.congr_hom

theorem congr_inv_of_congr_hom (F G : C ⥤ D) {X Y : C} (e : X ≅ Y) (hX : F.obj X = G.obj X)
    (hY : F.obj Y = G.obj Y)
    (h₂ : F.map e.hom = eqToHom (by rw [hX]) ≫ G.map e.hom ≫ eqToHom (by rw [hY])) :
    F.map e.inv = eqToHom (by rw [hY]) ≫ G.map e.inv ≫ eqToHom (by rw [hX]) := by
  simp only [← IsIso.Iso.inv_hom e, Functor.map_inv, h₂, IsIso.inv_comp, inv_eqToHom,
    Category.assoc]
#align category_theory.functor.congr_inv_of_congr_hom CategoryTheory.Functor.congr_inv_of_congr_hom

theorem congr_map (F : C ⥤ D) {X Y : C} {f g : X ⟶ Y} (h : f = g) : F.map f = F.map g := by rw [h]
#align category_theory.functor.congr_map CategoryTheory.Functor.congr_map

section HEq

-- Composition of functors and maps w.r.t. heq
variable {E : Type u₃} [Category.{v₃} E] {F G : C ⥤ D} {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z}

theorem map_comp_hEq (hx : F.obj X = G.obj X) (hy : F.obj Y = G.obj Y) (hz : F.obj Z = G.obj Z)
    (hf : HEq (F.map f) (G.map f)) (hg : HEq (F.map g) (G.map g)) :
    HEq (F.map (f ≫ g)) (G.map (f ≫ g)) := by
  rw [F.map_comp, G.map_comp]
  congr
#align category_theory.functor.map_comp_heq CategoryTheory.Functor.map_comp_hEq

theorem map_comp_hEq' (hobj : ∀ X : C, F.obj X = G.obj X)
    (hmap : ∀ {X Y} (f : X ⟶ Y), HEq (F.map f) (G.map f)) :
    HEq (F.map (f ≫ g)) (G.map (f ≫ g)) := by
  rw [Functor.hext hobj fun _ _ => hmap]
#align category_theory.functor.map_comp_heq' CategoryTheory.Functor.map_comp_hEq'

theorem precomp_map_hEq (H : E ⥤ C) (hmap : ∀ {X Y} (f : X ⟶ Y), HEq (F.map f) (G.map f)) {X Y : E}
    (f : X ⟶ Y) : HEq ((H ⋙ F).map f) ((H ⋙ G).map f) :=
  hmap _
#align category_theory.functor.precomp_map_heq CategoryTheory.Functor.precomp_map_hEq

theorem postcomp_map_hEq (H : D ⥤ E) (hx : F.obj X = G.obj X) (hy : F.obj Y = G.obj Y)
    (hmap : HEq (F.map f) (G.map f)) : HEq ((F ⋙ H).map f) ((G ⋙ H).map f) := by
  dsimp
  congr
#align category_theory.functor.postcomp_map_heq CategoryTheory.Functor.postcomp_map_hEq

theorem postcomp_map_hEq' (H : D ⥤ E) (hobj : ∀ X : C, F.obj X = G.obj X)
    (hmap : ∀ {X Y} (f : X ⟶ Y), HEq (F.map f) (G.map f)) : HEq ((F ⋙ H).map f) ((G ⋙ H).map f) :=
  by rw [Functor.hext hobj fun _ _ => hmap]
#align category_theory.functor.postcomp_map_heq' CategoryTheory.Functor.postcomp_map_hEq'

theorem hcongr_hom {F G : C ⥤ D} (h : F = G) {X Y} (f : X ⟶ Y) : HEq (F.map f) (G.map f) := by
  rw [h]
#align category_theory.functor.hcongr_hom CategoryTheory.Functor.hcongr_hom

end HEq

end Functor

/-- This is not always a good idea as a `@[simp]` lemma,
as we lose the ability to use results that interact with `F`,
e.g. the naturality of a natural transformation.

In some files it may be appropriate to use `local attribute [simp] eqToHom_map`, however.
-/
theorem eqToHom_map (F : C ⥤ D) {X Y : C} (p : X = Y) :
    F.map (eqToHom p) = eqToHom (congr_arg F.obj p) := by cases p; simp
#align category_theory.eq_to_hom_map CategoryTheory.eqToHom_map

/-- See the note on `eqToHom_map` regarding using this as a `simp` lemma.
-/
theorem eqToIso_map (F : C ⥤ D) {X Y : C} (p : X = Y) :
    F.mapIso (eqToIso p) = eqToIso (congr_arg F.obj p) := by ext; cases p; simp
#align category_theory.eq_to_iso_map CategoryTheory.eqToIso_map

@[simp]
theorem eqToHom_app {F G : C ⥤ D} (h : F = G) (X : C) :
    (eqToHom h : F ⟶ G).app X = eqToHom (Functor.congr_obj h X) := by subst h; rfl
#align category_theory.eq_to_hom_app CategoryTheory.eqToHom_app

theorem NatTrans.congr {F G : C ⥤ D} (α : F ⟶ G) {X Y : C} (h : X = Y) :
    α.app X = F.map (eqToHom h) ≫ α.app Y ≫ G.map (eqToHom h.symm) := by
  rw [α.naturality_assoc]
  simp [eqToHom_map]
#align category_theory.nat_trans.congr CategoryTheory.NatTrans.congr

theorem eq_conj_eqToHom {X Y : C} (f : X ⟶ Y) : f = eqToHom rfl ≫ f ≫ eqToHom rfl := by
  simp only [Category.id_comp, eqToHom_refl, Category.comp_id]
#align category_theory.eq_conj_eq_to_hom CategoryTheory.eq_conj_eqToHom

theorem dcongr_arg {ι : Type _} {F G : ι → C} (α : ∀ i, F i ⟶ G i) {i j : ι} (h : i = j) :
    α i = eqToHom (congr_arg F h) ≫ α j ≫ eqToHom (congr_arg G h.symm) := by
  subst h
  simp
#align category_theory.dcongr_arg CategoryTheory.dcongr_arg

end CategoryTheory