/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Yury Kudryashov
-/
import algebra.algebra.basic
import data.set.Union_lift
import linear_algebra.finsupp
import ring_theory.ideal.operations

/-!
# Subalgebras over Commutative Semiring

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

In this file we define `subalgebra`s and the usual operations on them (`map`, `comap`).

More lemmas about `adjoin` can be found in `ring_theory.adjoin`.
-/
universes u u' v w w'

open_locale big_operators

set_option old_structure_cmd true

/-- A subalgebra is a sub(semi)ring that includes the range of `algebra_map`. -/
structure subalgebra (R : Type u) (A : Type v)
  [comm_semiring R] [semiring A] [algebra R A] extends subsemiring A : Type v :=
(algebra_map_mem' : ∀ r, algebra_map R A r ∈ carrier)
(zero_mem' := (algebra_map R A).map_zero ▸ algebra_map_mem' 0)
(one_mem' := (algebra_map R A).map_one ▸ algebra_map_mem' 1)

/-- Reinterpret a `subalgebra` as a `subsemiring`. -/
add_decl_doc subalgebra.to_subsemiring

namespace subalgebra

variables {R' : Type u'} {R : Type u} {A : Type v} {B : Type w} {C : Type w'}
variables [comm_semiring R]
variables [semiring A] [algebra R A] [semiring B] [algebra R B] [semiring C] [algebra R C]
include R

instance : set_like (subalgebra R A) A :=
{ coe := subalgebra.carrier,
  coe_injective' := λ p q h, by cases p; cases q; congr' }

instance : subsemiring_class (subalgebra R A) A :=
{ add_mem := add_mem',
  mul_mem := mul_mem',
  one_mem := one_mem',
  zero_mem := zero_mem' }

@[simp]
lemma mem_carrier {s : subalgebra R A} {x : A} : x ∈ s.carrier ↔ x ∈ s := iff.rfl

@[ext] theorem ext {S T : subalgebra R A} (h : ∀ x : A, x ∈ S ↔ x ∈ T) : S = T := set_like.ext h

@[simp] lemma mem_to_subsemiring {S : subalgebra R A} {x} : x ∈ S.to_subsemiring ↔ x ∈ S := iff.rfl

@[simp] lemma coe_to_subsemiring (S : subalgebra R A) : (↑S.to_subsemiring : set A) = S := rfl

theorem to_subsemiring_injective :
  function.injective (to_subsemiring : subalgebra R A → subsemiring A) :=
λ S T h, ext $ λ x, by rw [← mem_to_subsemiring, ← mem_to_subsemiring, h]

theorem to_subsemiring_inj {S U : subalgebra R A} : S.to_subsemiring = U.to_subsemiring ↔ S = U :=
to_subsemiring_injective.eq_iff

/-- Copy of a subalgebra with a new `carrier` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (S : subalgebra R A) (s : set A) (hs : s = ↑S) : subalgebra R A :=
{ carrier := s,
  add_mem' := λ _ _, hs.symm ▸ S.add_mem',
  mul_mem' := λ _ _, hs.symm ▸ S.mul_mem',
  algebra_map_mem' := hs.symm ▸ S.algebra_map_mem' }

@[simp] lemma coe_copy (S : subalgebra R A) (s : set A) (hs : s = ↑S) :
  (S.copy s hs : set A) = s := rfl

lemma copy_eq (S : subalgebra R A) (s : set A) (hs : s = ↑S) : S.copy s hs = S :=
set_like.coe_injective hs

variables (S : subalgebra R A)

theorem algebra_map_mem (r : R) : algebra_map R A r ∈ S :=
S.algebra_map_mem' r

theorem srange_le : (algebra_map R A).srange ≤ S.to_subsemiring :=
λ x ⟨r, hr⟩, hr ▸ S.algebra_map_mem r

theorem range_subset : set.range (algebra_map R A) ⊆ S :=
λ x ⟨r, hr⟩, hr ▸ S.algebra_map_mem r

theorem range_le : set.range (algebra_map R A) ≤ S :=
S.range_subset

theorem smul_mem {x : A} (hx : x ∈ S) (r : R) : r • x ∈ S :=
(algebra.smul_def r x).symm ▸ mul_mem (S.algebra_map_mem r) hx

protected theorem one_mem : (1 : A) ∈ S := one_mem S
protected theorem mul_mem {x y : A} (hx : x ∈ S) (hy : y ∈ S) : x * y ∈ S := mul_mem hx hy
protected theorem pow_mem {x : A} (hx : x ∈ S) (n : ℕ) : x ^ n ∈ S := pow_mem hx n
protected theorem zero_mem : (0 : A) ∈ S := zero_mem S
protected theorem add_mem {x y : A} (hx : x ∈ S) (hy : y ∈ S) : x + y ∈ S := add_mem hx hy
protected theorem nsmul_mem {x : A} (hx : x ∈ S) (n : ℕ) : n • x ∈ S := nsmul_mem hx n
protected theorem coe_nat_mem (n : ℕ) : (n : A) ∈ S := coe_nat_mem S n
protected theorem list_prod_mem {L : list A} (h : ∀ x ∈ L, x ∈ S) : L.prod ∈ S := list_prod_mem h
protected theorem list_sum_mem {L : list A} (h : ∀ x ∈ L, x ∈ S) : L.sum ∈ S := list_sum_mem h
protected theorem multiset_sum_mem {m : multiset A} (h : ∀ x ∈ m, x ∈ S) : m.sum ∈ S :=
multiset_sum_mem m h
protected theorem sum_mem {ι : Type w} {t : finset ι} {f : ι → A} (h : ∀ x ∈ t, f x ∈ S) :
  ∑ x in t, f x ∈ S :=
sum_mem h

protected theorem multiset_prod_mem {R : Type u} {A : Type v} [comm_semiring R] [comm_semiring A]
  [algebra R A] (S : subalgebra R A) {m : multiset A} (h : ∀ x ∈ m, x ∈ S) : m.prod ∈ S :=
multiset_prod_mem m h
protected theorem prod_mem {R : Type u} {A : Type v} [comm_semiring R] [comm_semiring A]
  [algebra R A] (S : subalgebra R A) {ι : Type w} {t : finset ι} {f : ι → A}
  (h : ∀ x ∈ t, f x ∈ S) : ∏ x in t, f x ∈ S :=
prod_mem h

instance {R A : Type*} [comm_ring R] [ring A] [algebra R A] : subring_class (subalgebra R A) A :=
{ neg_mem := λ S x hx, neg_one_smul R x ▸ S.smul_mem hx _,
  .. subalgebra.subsemiring_class }

protected theorem neg_mem {R : Type u} {A : Type v} [comm_ring R] [ring A]
  [algebra R A] (S : subalgebra R A) {x : A} (hx : x ∈ S) : -x ∈ S :=
neg_mem hx
protected theorem sub_mem {R : Type u} {A : Type v} [comm_ring R] [ring A]
  [algebra R A] (S : subalgebra R A) {x y : A} (hx : x ∈ S) (hy : y ∈ S) : x - y ∈ S :=
sub_mem hx hy

protected theorem zsmul_mem {R : Type u} {A : Type v} [comm_ring R] [ring A]
  [algebra R A] (S : subalgebra R A) {x : A} (hx : x ∈ S) (n : ℤ) : n • x ∈ S :=
zsmul_mem hx n
protected theorem coe_int_mem {R : Type u} {A : Type v} [comm_ring R] [ring A]
  [algebra R A] (S : subalgebra R A) (n : ℤ) : (n : A) ∈ S :=
coe_int_mem S n

/-- The projection from a subalgebra of `A` to an additive submonoid of `A`. -/
def to_add_submonoid {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
  (S : subalgebra R A) : add_submonoid A :=
S.to_subsemiring.to_add_submonoid

/-- The projection from a subalgebra of `A` to a submonoid of `A`. -/
def to_submonoid {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
  (S : subalgebra R A) : submonoid A :=
S.to_subsemiring.to_submonoid

/-- A subalgebra over a ring is also a `subring`. -/
def to_subring {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A] (S : subalgebra R A) :
  subring A :=
{ neg_mem' := λ _, S.neg_mem,
  .. S.to_subsemiring }

@[simp] lemma mem_to_subring {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A]
  {S : subalgebra R A} {x} : x ∈ S.to_subring ↔ x ∈ S := iff.rfl

@[simp] lemma coe_to_subring {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A]
  (S : subalgebra R A) : (↑S.to_subring : set A) = S := rfl

theorem to_subring_injective {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A] :
  function.injective (to_subring : subalgebra R A → subring A) :=
λ S T h, ext $ λ x, by rw [← mem_to_subring, ← mem_to_subring, h]

theorem to_subring_inj {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A]
  {S U : subalgebra R A} : S.to_subring = U.to_subring ↔ S = U :=
to_subring_injective.eq_iff

instance : inhabited S := ⟨(0 : S.to_subsemiring)⟩

section

/-! `subalgebra`s inherit structure from their `subsemiring` / `semiring` coercions. -/

instance to_semiring {R A}
  [comm_semiring R] [semiring A] [algebra R A] (S : subalgebra R A) :
  semiring S := S.to_subsemiring.to_semiring
instance to_comm_semiring {R A}
  [comm_semiring R] [comm_semiring A] [algebra R A] (S : subalgebra R A) :
  comm_semiring S := S.to_subsemiring.to_comm_semiring
instance to_ring {R A}
  [comm_ring R] [ring A] [algebra R A] (S : subalgebra R A) :
  ring S := S.to_subring.to_ring
instance to_comm_ring {R A}
  [comm_ring R] [comm_ring A] [algebra R A] (S : subalgebra R A) :
  comm_ring S := S.to_subring.to_comm_ring

instance to_ordered_semiring {R A}
  [comm_semiring R] [ordered_semiring A] [algebra R A] (S : subalgebra R A) :
  ordered_semiring S := S.to_subsemiring.to_ordered_semiring
instance to_strict_ordered_semiring {R A}
  [comm_semiring R] [strict_ordered_semiring A] [algebra R A] (S : subalgebra R A) :
  strict_ordered_semiring S := S.to_subsemiring.to_strict_ordered_semiring
instance to_ordered_comm_semiring {R A}
  [comm_semiring R] [ordered_comm_semiring A] [algebra R A] (S : subalgebra R A) :
  ordered_comm_semiring S := S.to_subsemiring.to_ordered_comm_semiring
instance to_strict_ordered_comm_semiring {R A}
  [comm_semiring R] [strict_ordered_comm_semiring A] [algebra R A] (S : subalgebra R A) :
  strict_ordered_comm_semiring S := S.to_subsemiring.to_strict_ordered_comm_semiring
instance to_ordered_ring {R A}
  [comm_ring R] [ordered_ring A] [algebra R A] (S : subalgebra R A) :
  ordered_ring S := S.to_subring.to_ordered_ring
instance to_ordered_comm_ring {R A}
  [comm_ring R] [ordered_comm_ring A] [algebra R A] (S : subalgebra R A) :
  ordered_comm_ring S := S.to_subring.to_ordered_comm_ring

instance to_linear_ordered_semiring {R A}
  [comm_semiring R] [linear_ordered_semiring A] [algebra R A] (S : subalgebra R A) :
  linear_ordered_semiring S := S.to_subsemiring.to_linear_ordered_semiring
instance to_linear_ordered_comm_semiring {R A}
 [comm_semiring R] [linear_ordered_comm_semiring A] [algebra R A] (S : subalgebra R A) :
  linear_ordered_comm_semiring S := S.to_subsemiring.to_linear_ordered_comm_semiring
instance to_linear_ordered_ring {R A}
  [comm_ring R] [linear_ordered_ring A] [algebra R A] (S : subalgebra R A) :
  linear_ordered_ring S := S.to_subring.to_linear_ordered_ring
instance to_linear_ordered_comm_ring {R A}
  [comm_ring R] [linear_ordered_comm_ring A] [algebra R A] (S : subalgebra R A) :
  linear_ordered_comm_ring S := S.to_subring.to_linear_ordered_comm_ring

end

/-- The forgetful map from `subalgebra` to `submodule` as an `order_embedding` -/
def to_submodule : subalgebra R A ↪o submodule R A :=
{ to_embedding :=
  { to_fun := λ S,
    { carrier := S,
      zero_mem' := (0:S).2,
      add_mem' := λ x y hx hy, (⟨x, hx⟩ + ⟨y, hy⟩ : S).2,
      smul_mem' := λ c x hx, (algebra.smul_def c x).symm ▸
        (⟨algebra_map R A c, S.range_le ⟨c, rfl⟩⟩ * ⟨x, hx⟩:S).2 },
    inj' := λ S T h, ext $ by apply set_like.ext_iff.1 h },
  map_rel_iff' := λ S T, set_like.coe_subset_coe.symm.trans set_like.coe_subset_coe }
/- TODO: bundle other forgetful maps between algebraic substructures, e.g.
  `to_subsemiring` and `to_subring` in this file. -/

@[simp] lemma mem_to_submodule {x} : x ∈ S.to_submodule ↔ x ∈ S := iff.rfl

@[simp] lemma coe_to_submodule (S : subalgebra R A) : (↑S.to_submodule : set A) = S := rfl

section

/-! `subalgebra`s inherit structure from their `submodule` coercions. -/

instance module' [semiring R'] [has_smul R' R] [module R' A] [is_scalar_tower R' R A] :
  module R' S :=
S.to_submodule.module'
instance : module R S := S.module'

instance [semiring R'] [has_smul R' R] [module R' A] [is_scalar_tower R' R A] :
  is_scalar_tower R' R S :=
S.to_submodule.is_scalar_tower

instance algebra' [comm_semiring R'] [has_smul R' R] [algebra R' A]
  [is_scalar_tower R' R A] : algebra R' S :=
{ commutes' := λ c x, subtype.eq $ algebra.commutes _ _,
  smul_def' := λ c x, subtype.eq $ algebra.smul_def _ _,
  .. (algebra_map R' A).cod_restrict S $ λ x, begin
    rw [algebra.algebra_map_eq_smul_one, ←smul_one_smul R x (1 : A),
      ←algebra.algebra_map_eq_smul_one],
    exact algebra_map_mem S _,
  end }
instance : algebra R S := S.algebra'

end

instance no_zero_smul_divisors_bot [no_zero_smul_divisors R A] : no_zero_smul_divisors R S :=
⟨λ c x h,
  have c = 0 ∨ (x : A) = 0,
  from eq_zero_or_eq_zero_of_smul_eq_zero (congr_arg coe h),
  this.imp_right (@subtype.ext_iff _ _ x 0).mpr⟩

protected lemma coe_add (x y : S) : (↑(x + y) : A) = ↑x + ↑y := rfl
protected lemma coe_mul (x y : S) : (↑(x * y) : A) = ↑x * ↑y := rfl
protected lemma coe_zero : ((0 : S) : A) = 0 := rfl
protected lemma coe_one : ((1 : S) : A) = 1 := rfl
protected lemma coe_neg {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A]
  {S : subalgebra R A} (x : S) : (↑(-x) : A) = -↑x := rfl
protected lemma coe_sub {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A]
  {S : subalgebra R A} (x y : S) : (↑(x - y) : A) = ↑x - ↑y := rfl
@[simp, norm_cast] lemma coe_smul [semiring R'] [has_smul R' R] [module R' A]
  [is_scalar_tower R' R A] (r : R') (x : S) : (↑(r • x) : A) = r • ↑x := rfl
@[simp, norm_cast] lemma coe_algebra_map [comm_semiring R'] [has_smul R' R] [algebra R' A]
  [is_scalar_tower R' R A] (r : R') :
  ↑(algebra_map R' S r) = algebra_map R' A r := rfl

protected lemma coe_pow (x : S) (n : ℕ) : (↑(x^n) : A) = (↑x)^n := submonoid_class.coe_pow x n
protected lemma coe_eq_zero {x : S} : (x : A) = 0 ↔ x = 0 := zero_mem_class.coe_eq_zero
protected lemma coe_eq_one {x : S} : (x : A) = 1 ↔ x = 1 := one_mem_class.coe_eq_one

-- todo: standardize on the names these morphisms
-- compare with submodule.subtype

/-- Embedding of a subalgebra into the algebra. -/
def val : S →ₐ[R] A :=
by refine_struct { to_fun := (coe : S → A) }; intros; refl

@[simp] lemma coe_val : (S.val : S → A) = coe := rfl

lemma val_apply (x : S) : S.val x = (x : A) := rfl

@[simp] lemma to_subsemiring_subtype : S.to_subsemiring.subtype = (S.val : S →+* A) :=
rfl

@[simp] lemma to_subring_subtype {R A : Type*} [comm_ring R] [ring A]
  [algebra R A] (S : subalgebra R A) : S.to_subring.subtype = (S.val : S →+* A) :=
rfl

/-- Linear equivalence between `S : submodule R A` and `S`. Though these types are equal,
we define it as a `linear_equiv` to avoid type equalities. -/
def to_submodule_equiv (S : subalgebra R A) : S.to_submodule ≃ₗ[R] S :=
linear_equiv.of_eq _ _ rfl

/-- Transport a subalgebra via an algebra homomorphism. -/
def map (f : A →ₐ[R] B) (S : subalgebra R A) : subalgebra R B :=
{ algebra_map_mem' := λ r, f.commutes r ▸ set.mem_image_of_mem _ (S.algebra_map_mem r),
  .. S.to_subsemiring.map (f : A →+* B) }

lemma map_mono {S₁ S₂ : subalgebra R A} {f : A →ₐ[R] B} :
  S₁ ≤ S₂ → S₁.map f ≤ S₂.map f :=
set.image_subset f

lemma map_injective {f : A →ₐ[R] B} (hf : function.injective f) :
  function.injective (map f) :=
λ S₁ S₂ ih, ext $ set.ext_iff.1 $ set.image_injective.2 hf $ set.ext $ set_like.ext_iff.mp ih

@[simp] lemma map_id (S : subalgebra R A) : S.map (alg_hom.id R A) = S :=
set_like.coe_injective $ set.image_id _

lemma mem_map {S : subalgebra R A} {f : A →ₐ[R] B} {y : B} :
  y ∈ map f S ↔ ∃ x ∈ S, f x = y :=
subsemiring.mem_map

lemma map_to_submodule {S : subalgebra R A} {f : A →ₐ[R] B} :
  (S.map f).to_submodule = S.to_submodule.map f.to_linear_map :=
set_like.coe_injective rfl

lemma map_to_subsemiring {S : subalgebra R A} {f : A →ₐ[R] B} :
  (S.map f).to_subsemiring = S.to_subsemiring.map f.to_ring_hom :=
set_like.coe_injective rfl

@[simp] lemma coe_map (S : subalgebra R A) (f : A →ₐ[R] B) :
  (S.map f : set B) = f '' S :=
rfl

/-- Preimage of a subalgebra under an algebra homomorphism. -/
def comap (f : A →ₐ[R] B) (S : subalgebra R B) : subalgebra R A :=
{ algebra_map_mem' := λ r, show f (algebra_map R A r) ∈ S,
    from (f.commutes r).symm ▸ S.algebra_map_mem r,
  .. S.to_subsemiring.comap (f : A →+* B) }

theorem map_le {S : subalgebra R A} {f : A →ₐ[R] B} {U : subalgebra R B} :
  map f S ≤ U ↔ S ≤ comap f U :=
set.image_subset_iff

lemma gc_map_comap (f : A →ₐ[R] B) : galois_connection (map f) (comap f) :=
λ S U, map_le

@[simp] lemma mem_comap (S : subalgebra R B) (f : A →ₐ[R] B) (x : A) :
  x ∈ S.comap f ↔ f x ∈ S :=
iff.rfl

@[simp, norm_cast] lemma coe_comap (S : subalgebra R B) (f : A →ₐ[R] B) :
  (S.comap f : set A) = f ⁻¹' (S : set B) :=
rfl

instance no_zero_divisors {R A : Type*} [comm_semiring R] [semiring A] [no_zero_divisors A]
  [algebra R A] (S : subalgebra R A) : no_zero_divisors S :=
S.to_subsemiring.no_zero_divisors

instance is_domain {R A : Type*} [comm_ring R] [ring A] [is_domain A] [algebra R A]
  (S : subalgebra R A) : is_domain S :=
subring.is_domain S.to_subring

end subalgebra

namespace submodule

variables {R A : Type*} [comm_semiring R] [semiring A] [algebra R A]
variables (p : submodule R A)

/-- A submodule containing `1` and closed under multiplication is a subalgebra. -/
def to_subalgebra (p : submodule R A) (h_one : (1 : A) ∈ p)
  (h_mul : ∀ x y, x ∈ p → y ∈ p → x * y ∈ p) : subalgebra R A :=
{ mul_mem' := h_mul,
  algebra_map_mem' := λ r, begin
    rw algebra.algebra_map_eq_smul_one,
    exact p.smul_mem _ h_one,
  end,
  ..p}

@[simp] lemma mem_to_subalgebra {p : submodule R A} {h_one h_mul} {x} :
  x ∈ p.to_subalgebra h_one h_mul ↔ x ∈ p := iff.rfl

@[simp] lemma coe_to_subalgebra (p : submodule R A) (h_one h_mul) :
  (p.to_subalgebra h_one h_mul : set A) = p := rfl

@[simp] lemma to_subalgebra_mk (s : set A) (h0 hadd hsmul h1 hmul) :
  (submodule.mk s hadd h0 hsmul : submodule R A).to_subalgebra h1 hmul =
    subalgebra.mk s @hmul h1 @hadd h0
      (λ r, by { rw algebra.algebra_map_eq_smul_one, exact hsmul r h1 }) := rfl

@[simp] lemma to_subalgebra_to_submodule (p : submodule R A) (h_one h_mul) :
  (p.to_subalgebra h_one h_mul).to_submodule = p :=
set_like.coe_injective rfl

@[simp] lemma _root_.subalgebra.to_submodule_to_subalgebra (S : subalgebra R A) :
  S.to_submodule.to_subalgebra S.one_mem (λ _ _, S.mul_mem) = S :=
set_like.coe_injective rfl

end submodule

namespace alg_hom

variables {R' : Type u'} {R : Type u} {A : Type v} {B : Type w} {C : Type w'}
variables [comm_semiring R]
variables [semiring A] [algebra R A] [semiring B] [algebra R B] [semiring C] [algebra R C]
variables (φ : A →ₐ[R] B)

/-- Range of an `alg_hom` as a subalgebra. -/
protected def range (φ : A →ₐ[R] B) : subalgebra R B :=
{ algebra_map_mem' := λ r, ⟨algebra_map R A r, φ.commutes r⟩,
  .. φ.to_ring_hom.srange }

@[simp] lemma mem_range (φ : A →ₐ[R] B) {y : B} :
  y ∈ φ.range ↔ ∃ x, φ x = y := ring_hom.mem_srange

theorem mem_range_self (φ : A →ₐ[R] B) (x : A) : φ x ∈ φ.range := φ.mem_range.2 ⟨x, rfl⟩

@[simp] lemma coe_range (φ : A →ₐ[R] B) : (φ.range : set B) = set.range φ :=
by { ext, rw [set_like.mem_coe, mem_range], refl }

theorem range_comp (f : A →ₐ[R] B) (g : B →ₐ[R] C) : (g.comp f).range = f.range.map g :=
set_like.coe_injective (set.range_comp g f)

theorem range_comp_le_range (f : A →ₐ[R] B) (g : B →ₐ[R] C) : (g.comp f).range ≤ g.range :=
set_like.coe_mono (set.range_comp_subset_range f g)

/-- Restrict the codomain of an algebra homomorphism. -/
def cod_restrict (f : A →ₐ[R] B) (S : subalgebra R B) (hf : ∀ x, f x ∈ S) : A →ₐ[R] S :=
{ commutes' := λ r, subtype.eq $ f.commutes r,
  .. ring_hom.cod_restrict (f : A →+* B) S hf }

@[simp] lemma val_comp_cod_restrict (f : A →ₐ[R] B) (S : subalgebra R B) (hf : ∀ x, f x ∈ S) :
  S.val.comp (f.cod_restrict S hf) = f :=
alg_hom.ext $ λ _, rfl

@[simp] lemma coe_cod_restrict (f : A →ₐ[R] B) (S : subalgebra R B) (hf : ∀ x, f x ∈ S) (x : A) :
  ↑(f.cod_restrict S hf x) = f x := rfl

theorem injective_cod_restrict (f : A →ₐ[R] B) (S : subalgebra R B) (hf : ∀ x, f x ∈ S) :
  function.injective (f.cod_restrict S hf) ↔ function.injective f :=
⟨λ H x y hxy, H $ subtype.eq hxy, λ H x y hxy, H (congr_arg subtype.val hxy : _)⟩

/-- Restrict the codomain of a alg_hom `f` to `f.range`.

This is the bundled version of `set.range_factorization`. -/
@[reducible] def range_restrict (f : A →ₐ[R] B) : A →ₐ[R] f.range :=
f.cod_restrict f.range f.mem_range_self

/-- The equalizer of two R-algebra homomorphisms -/
def equalizer (ϕ ψ : A →ₐ[R] B) : subalgebra R A :=
{ carrier := {a | ϕ a = ψ a},
  add_mem' := λ x y (hx : ϕ x = ψ x) (hy : ϕ y = ψ y),
    by rw [set.mem_set_of_eq, ϕ.map_add, ψ.map_add, hx, hy],
  mul_mem' := λ x y (hx : ϕ x = ψ x) (hy : ϕ y = ψ y),
    by rw [set.mem_set_of_eq, ϕ.map_mul, ψ.map_mul, hx, hy],
  algebra_map_mem' := λ x,
    by rw [set.mem_set_of_eq, alg_hom.commutes, alg_hom.commutes] }

@[simp] lemma mem_equalizer (ϕ ψ : A →ₐ[R] B) (x : A) :
  x ∈ ϕ.equalizer ψ ↔ ϕ x = ψ x := iff.rfl

/-- The range of a morphism of algebras is a fintype, if the domain is a fintype.

Note that this instance can cause a diamond with `subtype.fintype` if `B` is also a fintype. -/
instance fintype_range [fintype A] [decidable_eq B] (φ : A →ₐ[R] B) : fintype φ.range :=
set.fintype_range φ

end alg_hom

namespace alg_equiv

variables {R : Type u} {A : Type v} {B : Type w}
variables [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B]

/-- Restrict an algebra homomorphism with a left inverse to an algebra isomorphism to its range.

This is a computable alternative to `alg_equiv.of_injective`. -/
def of_left_inverse
  {g : B → A} {f : A →ₐ[R] B} (h : function.left_inverse g f) :
  A ≃ₐ[R] f.range :=
{ to_fun := f.range_restrict,
  inv_fun := g ∘ f.range.val,
  left_inv := h,
  right_inv := λ x, subtype.ext $
    let ⟨x', hx'⟩ := f.mem_range.mp x.prop in
    show f (g x) = x, by rw [←hx', h x'],
  ..f.range_restrict }

@[simp] lemma of_left_inverse_apply
  {g : B → A} {f : A →ₐ[R] B} (h : function.left_inverse g f) (x : A) :
  ↑(of_left_inverse h x) = f x := rfl

@[simp] lemma of_left_inverse_symm_apply
  {g : B → A} {f : A →ₐ[R] B} (h : function.left_inverse g f) (x : f.range) :
  (of_left_inverse h).symm x = g x := rfl

/-- Restrict an injective algebra homomorphism to an algebra isomorphism -/
noncomputable def of_injective (f : A →ₐ[R] B) (hf : function.injective f) :
  A ≃ₐ[R] f.range :=
of_left_inverse (classical.some_spec hf.has_left_inverse)

@[simp] lemma of_injective_apply (f : A →ₐ[R] B) (hf : function.injective f) (x : A) :
  ↑(of_injective f hf x) = f x := rfl

/-- Restrict an algebra homomorphism between fields to an algebra isomorphism -/
noncomputable def of_injective_field {E F : Type*} [division_ring E] [semiring F]
  [nontrivial F] [algebra R E] [algebra R F] (f : E →ₐ[R] F) : E ≃ₐ[R] f.range :=
of_injective f f.to_ring_hom.injective

/-- Given an equivalence `e : A ≃ₐ[R] B` of `R`-algebras and a subalgebra `S` of `A`,
`subalgebra_map` is the induced equivalence between `S` and `S.map e` -/
@[simps] def subalgebra_map (e : A ≃ₐ[R] B) (S : subalgebra R A) :
  S ≃ₐ[R] (S.map e.to_alg_hom) :=
{ commutes' := λ r, by { ext, simp },
  ..e.to_ring_equiv.subsemiring_map S.to_subsemiring }

end alg_equiv

namespace algebra

variables (R : Type u) {A : Type v} {B : Type w}
variables [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B]

/-- The minimal subalgebra that includes `s`. -/
def adjoin (s : set A) : subalgebra R A :=
{ algebra_map_mem' := λ r, subsemiring.subset_closure $ or.inl ⟨r, rfl⟩,
  .. subsemiring.closure (set.range (algebra_map R A) ∪ s) }
variables {R}

protected lemma gc : galois_connection (adjoin R : set A → subalgebra R A) coe :=
λ s S, ⟨λ H, le_trans (le_trans (set.subset_union_right _ _) subsemiring.subset_closure) H,
λ H, show subsemiring.closure (set.range (algebra_map R A) ∪ s) ≤ S.to_subsemiring,
     from subsemiring.closure_le.2 $ set.union_subset S.range_subset H⟩

/-- Galois insertion between `adjoin` and `coe`. -/
protected def gi : galois_insertion (adjoin R : set A → subalgebra R A) coe :=
{ choice := λ s hs, (adjoin R s).copy s $ le_antisymm (algebra.gc.le_u_l s) hs,
  gc := algebra.gc,
  le_l_u := λ S, (algebra.gc (S : set A) (adjoin R S)).1 $ le_rfl,
  choice_eq := λ _ _, subalgebra.copy_eq _ _ _ }

instance : complete_lattice (subalgebra R A) :=
galois_insertion.lift_complete_lattice algebra.gi

@[simp]
lemma coe_top : (↑(⊤ : subalgebra R A) : set A) = set.univ := rfl

@[simp] lemma mem_top {x : A} : x ∈ (⊤ : subalgebra R A) :=
set.mem_univ x

@[simp] lemma top_to_submodule : (⊤ : subalgebra R A).to_submodule = ⊤ := rfl

@[simp] lemma top_to_subsemiring : (⊤ : subalgebra R A).to_subsemiring = ⊤ := rfl

@[simp] lemma top_to_subring {R A : Type*} [comm_ring R] [ring A] [algebra R A] :
  (⊤ : subalgebra R A).to_subring = ⊤ := rfl

@[simp] lemma to_submodule_eq_top {S : subalgebra R A} : S.to_submodule = ⊤ ↔ S = ⊤ :=
subalgebra.to_submodule.injective.eq_iff' top_to_submodule

@[simp] lemma to_subsemiring_eq_top {S : subalgebra R A} : S.to_subsemiring = ⊤ ↔ S = ⊤ :=
subalgebra.to_subsemiring_injective.eq_iff' top_to_subsemiring

@[simp] lemma to_subring_eq_top {R A : Type*} [comm_ring R] [ring A] [algebra R A]
  {S : subalgebra R A} : S.to_subring = ⊤ ↔ S = ⊤ :=
subalgebra.to_subring_injective.eq_iff' top_to_subring

lemma mem_sup_left {S T : subalgebra R A} : ∀ {x : A}, x ∈ S → x ∈ S ⊔ T :=
show S ≤ S ⊔ T, from le_sup_left

lemma mem_sup_right {S T : subalgebra R A} : ∀ {x : A}, x ∈ T → x ∈ S ⊔ T :=
show T ≤ S ⊔ T, from le_sup_right

lemma mul_mem_sup {S T : subalgebra R A} {x y : A} (hx : x ∈ S) (hy : y ∈ T) :
  x * y ∈ S ⊔ T :=
(S ⊔ T).mul_mem (mem_sup_left hx) (mem_sup_right hy)

lemma map_sup (f : A →ₐ[R] B) (S T : subalgebra R A) : (S ⊔ T).map f = S.map f ⊔ T.map f :=
(subalgebra.gc_map_comap f).l_sup

@[simp, norm_cast]
lemma coe_inf (S T : subalgebra R A) : (↑(S ⊓ T) : set A) = S ∩ T := rfl

@[simp]
lemma mem_inf {S T : subalgebra R A} {x : A} : x ∈ S ⊓ T ↔ x ∈ S ∧ x ∈ T := iff.rfl

@[simp] lemma inf_to_submodule (S T : subalgebra R A) :
  (S ⊓ T).to_submodule = S.to_submodule ⊓ T.to_submodule := rfl

@[simp] lemma inf_to_subsemiring (S T : subalgebra R A) :
  (S ⊓ T).to_subsemiring = S.to_subsemiring ⊓ T.to_subsemiring := rfl

@[simp, norm_cast]
lemma coe_Inf (S : set (subalgebra R A)) : (↑(Inf S) : set A) = ⋂ s ∈ S, ↑s := Inf_image

lemma mem_Inf {S : set (subalgebra R A)} {x : A} : x ∈ Inf S ↔ ∀ p ∈ S, x ∈ p :=
by simp only [← set_like.mem_coe, coe_Inf, set.mem_Inter₂]

@[simp] lemma Inf_to_submodule (S : set (subalgebra R A)) :
  (Inf S).to_submodule = Inf (subalgebra.to_submodule '' S) :=
set_like.coe_injective $ by simp

@[simp] lemma Inf_to_subsemiring (S : set (subalgebra R A)) :
  (Inf S).to_subsemiring = Inf (subalgebra.to_subsemiring '' S) :=
set_like.coe_injective $ by simp

@[simp, norm_cast]
lemma coe_infi {ι : Sort*} {S : ι → subalgebra R A} : (↑(⨅ i, S i) : set A) = ⋂ i, S i :=
by simp [infi]

lemma mem_infi {ι : Sort*} {S : ι → subalgebra R A} {x : A} : (x ∈ ⨅ i, S i) ↔ ∀ i, x ∈ S i :=
by simp only [infi, mem_Inf, set.forall_range_iff]

@[simp] lemma infi_to_submodule {ι : Sort*} (S : ι → subalgebra R A) :
  (⨅ i, S i).to_submodule = ⨅ i, (S i).to_submodule :=
set_like.coe_injective $ by simp

instance : inhabited (subalgebra R A) := ⟨⊥⟩

theorem mem_bot {x : A} : x ∈ (⊥ : subalgebra R A) ↔ x ∈ set.range (algebra_map R A) :=
suffices (of_id R A).range = (⊥ : subalgebra R A),
by { rw [← this, ←set_like.mem_coe, alg_hom.coe_range], refl },
le_bot_iff.mp (λ x hx, subalgebra.range_le _ ((of_id R A).coe_range ▸ hx))

theorem to_submodule_bot : (⊥ : subalgebra R A).to_submodule = R ∙ 1 :=
by { ext x, simp [mem_bot, -set.singleton_one, submodule.mem_span_singleton, algebra.smul_def] }

@[simp] theorem coe_bot : ((⊥ : subalgebra R A) : set A) = set.range (algebra_map R A) :=
by simp [set.ext_iff, algebra.mem_bot]

theorem eq_top_iff {S : subalgebra R A} :
  S = ⊤ ↔ ∀ x : A, x ∈ S :=
⟨λ h x, by rw h; exact mem_top, λ h, by ext x; exact ⟨λ _, mem_top, λ _, h x⟩⟩

lemma range_top_iff_surjective (f : A →ₐ[R] B) :
  f.range = (⊤ : subalgebra R B) ↔ function.surjective f :=
algebra.eq_top_iff

@[simp] theorem range_id : (alg_hom.id R A).range = ⊤ :=
set_like.coe_injective set.range_id

@[simp] theorem map_top (f : A →ₐ[R] B) : (⊤ : subalgebra R A).map f = f.range :=
set_like.coe_injective set.image_univ

@[simp] theorem map_bot (f : A →ₐ[R] B) : (⊥ : subalgebra R A).map f = ⊥ :=
set_like.coe_injective $
  by simp only [← set.range_comp, (∘), algebra.coe_bot, subalgebra.coe_map, f.commutes]

@[simp] theorem comap_top (f : A →ₐ[R] B) : (⊤ : subalgebra R B).comap f = ⊤ :=
eq_top_iff.2 $ λ x, mem_top

/-- `alg_hom` to `⊤ : subalgebra R A`. -/
def to_top : A →ₐ[R] (⊤ : subalgebra R A) :=
(alg_hom.id R A).cod_restrict ⊤ (λ _, mem_top)

theorem surjective_algebra_map_iff :
  function.surjective (algebra_map R A) ↔ (⊤ : subalgebra R A) = ⊥ :=
⟨λ h, eq_bot_iff.2 $ λ y _, let ⟨x, hx⟩ := h y in hx ▸ subalgebra.algebra_map_mem _ _,
λ h y, algebra.mem_bot.1 $ eq_bot_iff.1 h (algebra.mem_top : y ∈ _)⟩

theorem bijective_algebra_map_iff {R A : Type*} [field R] [semiring A] [nontrivial A]
  [algebra R A] :
  function.bijective (algebra_map R A) ↔ (⊤ : subalgebra R A) = ⊥ :=
⟨λ h, surjective_algebra_map_iff.1 h.2,
λ h, ⟨(algebra_map R A).injective, surjective_algebra_map_iff.2 h⟩⟩

/-- The bottom subalgebra is isomorphic to the base ring. -/
noncomputable def bot_equiv_of_injective (h : function.injective (algebra_map R A)) :
  (⊥ : subalgebra R A) ≃ₐ[R] R :=
alg_equiv.symm $ alg_equiv.of_bijective (algebra.of_id R _)
⟨λ x y hxy, h (congr_arg subtype.val hxy : _),
 λ ⟨y, hy⟩, let ⟨x, hx⟩ := algebra.mem_bot.1 hy in ⟨x, subtype.eq hx⟩⟩

/-- The bottom subalgebra is isomorphic to the field. -/
@[simps symm_apply]
noncomputable def bot_equiv (F R : Type*) [field F] [semiring R] [nontrivial R] [algebra F R] :
  (⊥ : subalgebra F R) ≃ₐ[F] F :=
bot_equiv_of_injective (ring_hom.injective _)

end algebra

namespace subalgebra
open algebra

variables {R : Type u} {A : Type v} {B : Type w}
variables [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B]
variables (S : subalgebra R A)

/-- The top subalgebra is isomorphic to the algebra.

This is the algebra version of `submodule.top_equiv`. -/
@[simps] def top_equiv : (⊤ : subalgebra R A) ≃ₐ[R] A :=
alg_equiv.of_alg_hom (subalgebra.val ⊤) to_top rfl $ alg_hom.ext $ λ _, subtype.ext rfl

instance subsingleton_of_subsingleton [subsingleton A] : subsingleton (subalgebra R A) :=
⟨λ B C, ext (λ x, by { simp only [subsingleton.elim x 0, zero_mem B, zero_mem C] })⟩

instance _root_.alg_hom.subsingleton [subsingleton (subalgebra R A)] : subsingleton (A →ₐ[R] B) :=
⟨λ f g, alg_hom.ext $ λ a,
  have a ∈ (⊥ : subalgebra R A) := subsingleton.elim (⊤ : subalgebra R A) ⊥ ▸ mem_top,
  let ⟨x, hx⟩ := set.mem_range.mp (mem_bot.mp this) in
  hx ▸ (f.commutes _).trans (g.commutes _).symm⟩

instance _root_.alg_equiv.subsingleton_left [subsingleton (subalgebra R A)] :
  subsingleton (A ≃ₐ[R] B) :=
⟨λ f g, alg_equiv.ext (λ x, alg_hom.ext_iff.mp (subsingleton.elim f.to_alg_hom g.to_alg_hom) x)⟩

instance _root_.alg_equiv.subsingleton_right [subsingleton (subalgebra R B)] :
  subsingleton (A ≃ₐ[R] B) :=
⟨λ f g, by rw [← f.symm_symm, subsingleton.elim f.symm g.symm, g.symm_symm]⟩

lemma range_val : S.val.range = S :=
ext $ set.ext_iff.1 $ S.val.coe_range.trans subtype.range_val

instance : unique (subalgebra R R) :=
{ uniq :=
  begin
    intro S,
    refine le_antisymm (λ r hr, _) bot_le,
    simp only [set.mem_range, mem_bot, id.map_eq_self, exists_apply_eq_apply, default],
  end
  .. algebra.subalgebra.inhabited }

/-- The map `S → T` when `S` is a subalgebra contained in the subalgebra `T`.

This is the subalgebra version of `submodule.of_le`, or `subring.inclusion`  -/
def inclusion {S T : subalgebra R A} (h : S ≤ T) : S →ₐ[R] T :=
{ to_fun := set.inclusion h,
  map_one' := rfl,
  map_add' := λ _ _, rfl,
  map_mul' := λ _ _, rfl,
  map_zero' := rfl,
  commutes' := λ _, rfl }

lemma inclusion_injective {S T : subalgebra R A} (h : S ≤ T) :
  function.injective (inclusion h) :=
λ _ _, subtype.ext ∘ subtype.mk.inj

@[simp] lemma inclusion_self {S : subalgebra R A}:
  inclusion (le_refl S) = alg_hom.id R S :=
alg_hom.ext $ λ x, subtype.ext rfl

@[simp] lemma inclusion_mk {S T : subalgebra R A} (h : S ≤ T) (x : A) (hx : x ∈ S) :
  inclusion h ⟨x, hx⟩ = ⟨x, h hx⟩ := rfl

lemma inclusion_right {S T : subalgebra R A} (h : S ≤ T) (x : T)
  (m : (x : A) ∈ S) : inclusion h ⟨x, m⟩ = x := subtype.ext rfl

@[simp] lemma inclusion_inclusion {S T U : subalgebra R A} (hst : S ≤ T) (htu : T ≤ U)
  (x : S) : inclusion htu (inclusion hst x) = inclusion (le_trans hst htu) x :=
subtype.ext rfl

@[simp] lemma coe_inclusion {S T : subalgebra R A} (h : S ≤ T) (s : S) :
  (inclusion h s : A) = s := rfl

/-- Two subalgebras that are equal are also equivalent as algebras.

This is the `subalgebra` version of `linear_equiv.of_eq` and `equiv.set.of_eq`. -/
@[simps apply]
def equiv_of_eq (S T : subalgebra R A) (h : S = T) : S ≃ₐ[R] T :=
{ to_fun := λ x, ⟨x, h ▸ x.2⟩,
  inv_fun := λ x, ⟨x, h.symm ▸ x.2⟩,
  map_mul' := λ _ _, rfl,
  commutes' := λ _, rfl,
  .. linear_equiv.of_eq _ _ (congr_arg to_submodule h) }

@[simp] lemma equiv_of_eq_symm (S T : subalgebra R A) (h : S = T) :
  (equiv_of_eq S T h).symm = equiv_of_eq T S h.symm :=
rfl

@[simp] lemma equiv_of_eq_rfl (S : subalgebra R A) :
  equiv_of_eq S S rfl = alg_equiv.refl :=
by { ext, refl }

@[simp] lemma equiv_of_eq_trans (S T U : subalgebra R A) (hST : S = T) (hTU : T = U) :
  (equiv_of_eq S T hST).trans (equiv_of_eq T U hTU) = equiv_of_eq S U (trans hST hTU) :=
rfl

section prod

variables (S₁ : subalgebra R B)

/-- The product of two subalgebras is a subalgebra. -/
def prod : subalgebra R (A × B) :=
{ carrier := S ×ˢ S₁,
  algebra_map_mem' := λ r, ⟨algebra_map_mem _ _, algebra_map_mem _ _⟩,
  .. S.to_subsemiring.prod S₁.to_subsemiring }

@[simp] lemma coe_prod : (prod S S₁ : set (A × B)) = S ×ˢ S₁ := rfl

lemma prod_to_submodule :
  (S.prod S₁).to_submodule = S.to_submodule.prod S₁.to_submodule := rfl

@[simp] lemma mem_prod {S : subalgebra R A} {S₁ : subalgebra R B} {x : A × B} :
  x ∈ prod S S₁ ↔ x.1 ∈ S ∧ x.2 ∈ S₁ := set.mem_prod

@[simp] lemma prod_top : (prod ⊤ ⊤ : subalgebra R (A × B)) = ⊤ :=
by ext; simp

lemma prod_mono {S T : subalgebra R A} {S₁ T₁ : subalgebra R B} :
  S ≤ T → S₁ ≤ T₁ → prod S S₁ ≤ prod T T₁ := set.prod_mono

@[simp] lemma prod_inf_prod {S T : subalgebra R A} {S₁ T₁ : subalgebra R B} :
  S.prod S₁ ⊓ T.prod T₁ = (S ⊓ T).prod (S₁ ⊓ T₁) :=
set_like.coe_injective set.prod_inter_prod

end prod

section supr_lift
variables {ι : Type*}

lemma coe_supr_of_directed [nonempty ι] {S : ι → subalgebra R A}
  (dir : directed (≤) S) : ↑(supr S) = ⋃ i, (S i : set A) :=
let K : subalgebra R A :=
  { carrier := ⋃ i, (S i),
    mul_mem' := λ x y hx hy,
      let ⟨i, hi⟩ := set.mem_Union.1 hx in
      let ⟨j, hj⟩ := set.mem_Union.1 hy in
      let ⟨k, hik, hjk⟩ := dir i j in
      set.mem_Union.2 ⟨k, subalgebra.mul_mem (S k) (hik hi) (hjk hj)⟩ ,
    add_mem' := λ x y hx hy,
      let ⟨i, hi⟩ := set.mem_Union.1 hx in
      let ⟨j, hj⟩ := set.mem_Union.1 hy in
      let ⟨k, hik, hjk⟩ := dir i j in
      set.mem_Union.2 ⟨k, subalgebra.add_mem (S k) (hik hi) (hjk hj)⟩,
    algebra_map_mem' := λ r, let i := @nonempty.some ι infer_instance in
      set.mem_Union.2 ⟨i, subalgebra.algebra_map_mem _ _⟩ } in
have supr S = K,
  from le_antisymm (supr_le (λ i, set.subset_Union (λ i, ↑(S i)) i))
    (set_like.coe_subset_coe.1
      (set.Union_subset (λ i, set_like.coe_subset_coe.2 (le_supr _ _)))),
this.symm ▸ rfl

/-- Define an algebra homomorphism on a directed supremum of subalgebras by defining
it on each subalgebra, and proving that it agrees on the intersection of subalgebras. -/
noncomputable def supr_lift [nonempty ι]
  (K : ι → subalgebra R A)
  (dir : directed (≤) K)
  (f : Π i, K i →ₐ[R] B)
  (hf : ∀ (i j : ι) (h : K i ≤ K j), f i = (f j).comp (inclusion h))
  (T : subalgebra R A) (hT : T = supr K) :
  ↥T →ₐ[R] B :=
by subst hT; exact
{ to_fun := set.Union_lift (λ i, ↑(K i)) (λ i x, f i x)
    (λ i j x hxi hxj,
      let ⟨k, hik, hjk⟩ := dir i j in
      begin
        rw [hf i k hik, hf j k hjk],
        refl
      end) ↑(supr K)
    (by rw coe_supr_of_directed dir; refl),
  map_one' := set.Union_lift_const _ (λ _, 1) (λ _, rfl) _ (by simp),
  map_zero' := set.Union_lift_const _ (λ _, 0) (λ _, rfl) _ (by simp),
  map_mul' := set.Union_lift_binary (coe_supr_of_directed dir) dir _
    (λ _, (*)) (λ _ _ _, rfl) _ (by simp),
  map_add' := set.Union_lift_binary (coe_supr_of_directed dir) dir _
    (λ _, (+)) (λ _ _ _, rfl) _ (by simp),
  commutes' := λ r, set.Union_lift_const _ (λ _, algebra_map _ _ r)
    (λ _, rfl) _ (λ i, by erw [alg_hom.commutes (f i)]) }

variables [nonempty ι] {K : ι → subalgebra R A} {dir : directed (≤) K}
  {f : Π i, K i →ₐ[R] B}
  {hf : ∀ (i j : ι) (h : K i ≤ K j), f i = (f j).comp (inclusion h)}
  {T : subalgebra R A} {hT : T = supr K}

@[simp] lemma supr_lift_inclusion {i : ι} (x : K i) (h : K i ≤ T) :
  supr_lift K dir f hf T hT (inclusion h x) = f i x :=
by subst T; exact set.Union_lift_inclusion _ _

@[simp] lemma supr_lift_comp_inclusion {i : ι} (h : K i ≤ T) :
  (supr_lift K dir f hf T hT).comp (inclusion h) = f i :=
by ext; simp

@[simp] lemma supr_lift_mk {i : ι} (x : K i) (hx : (x : A) ∈ T) :
  supr_lift K dir f hf T hT ⟨x, hx⟩ = f i x :=
by subst hT; exact set.Union_lift_mk x hx

lemma supr_lift_of_mem {i : ι} (x : T) (hx : (x : A) ∈ K i) :
  supr_lift K dir f hf T hT x = f i ⟨x, hx⟩ :=
by subst hT; exact set.Union_lift_of_mem x hx

end supr_lift

/-! ## Actions by `subalgebra`s

These are just copies of the definitions about `subsemiring` starting from
`subring.mul_action`.
-/
section actions

variables {α β : Type*}

/-- The action by a subalgebra is the action by the underlying algebra. -/
instance [has_smul A α] (S : subalgebra R A) : has_smul S α := S.to_subsemiring.has_smul

lemma smul_def [has_smul A α] {S : subalgebra R A} (g : S) (m : α) : g • m = (g : A) • m := rfl

instance smul_comm_class_left
  [has_smul A β] [has_smul α β] [smul_comm_class A α β] (S : subalgebra R A) :
  smul_comm_class S α β :=
S.to_subsemiring.smul_comm_class_left

instance smul_comm_class_right
  [has_smul α β] [has_smul A β] [smul_comm_class α A β] (S : subalgebra R A) :
  smul_comm_class α S β :=
S.to_subsemiring.smul_comm_class_right

/-- Note that this provides `is_scalar_tower S R R` which is needed by `smul_mul_assoc`. -/
instance is_scalar_tower_left
  [has_smul α β] [has_smul A α] [has_smul A β] [is_scalar_tower A α β] (S : subalgebra R A) :
  is_scalar_tower S α β :=
S.to_subsemiring.is_scalar_tower

instance is_scalar_tower_mid {R S T : Type*} [comm_semiring R] [semiring S] [add_comm_monoid T]
  [algebra R S] [module R T] [module S T] [is_scalar_tower R S T] (S' : subalgebra R S) :
  is_scalar_tower R S' T :=
⟨λ x y z, (smul_assoc _ (y : S) _ : _)⟩

instance [has_smul A α] [has_faithful_smul A α] (S : subalgebra R A) :
  has_faithful_smul S α :=
S.to_subsemiring.has_faithful_smul

/-- The action by a subalgebra is the action by the underlying algebra. -/
instance [mul_action A α] (S : subalgebra R A) : mul_action S α :=
S.to_subsemiring.mul_action

/-- The action by a subalgebra is the action by the underlying algebra. -/
instance [add_monoid α] [distrib_mul_action A α] (S : subalgebra R A) : distrib_mul_action S α :=
S.to_subsemiring.distrib_mul_action

/-- The action by a subalgebra is the action by the underlying algebra. -/
instance [has_zero α] [smul_with_zero A α] (S : subalgebra R A) : smul_with_zero S α :=
S.to_subsemiring.smul_with_zero

/-- The action by a subalgebra is the action by the underlying algebra. -/
instance [has_zero α] [mul_action_with_zero A α] (S : subalgebra R A) : mul_action_with_zero S α :=
S.to_subsemiring.mul_action_with_zero

/-- The action by a subalgebra is the action by the underlying algebra. -/
instance module_left [add_comm_monoid α] [module A α] (S : subalgebra R A) : module S α :=
S.to_subsemiring.module

/-- The action by a subalgebra is the action by the underlying algebra. -/
instance to_algebra {R A : Type*} [comm_semiring R] [comm_semiring A] [semiring α]
  [algebra R A] [algebra A α] (S : subalgebra R A) : algebra S α :=
algebra.of_subsemiring S.to_subsemiring

lemma algebra_map_eq {R A : Type*} [comm_semiring R] [comm_semiring A] [semiring α]
  [algebra R A] [algebra A α] (S : subalgebra R A) :
  algebra_map S α = (algebra_map A α).comp S.val := rfl

@[simp] lemma srange_algebra_map {R A : Type*} [comm_semiring R] [comm_semiring A]
  [algebra R A] (S : subalgebra R A) :
  (algebra_map S A).srange = S.to_subsemiring :=
by rw [algebra_map_eq, algebra.id.map_eq_id, ring_hom.id_comp, ← to_subsemiring_subtype,
       subsemiring.srange_subtype]

@[simp] lemma range_algebra_map {R A : Type*} [comm_ring R] [comm_ring A]
  [algebra R A] (S : subalgebra R A) :
  (algebra_map S A).range = S.to_subring :=
by rw [algebra_map_eq, algebra.id.map_eq_id, ring_hom.id_comp, ← to_subring_subtype,
       subring.range_subtype]

instance no_zero_smul_divisors_top [no_zero_divisors A] (S : subalgebra R A) :
  no_zero_smul_divisors S A :=
⟨λ c x h,
  have (c : A) = 0 ∨ x = 0,
  from eq_zero_or_eq_zero_of_mul_eq_zero h,
  this.imp_left (@subtype.ext_iff _ _ c 0).mpr⟩

end actions

section center

lemma _root_.set.algebra_map_mem_center (r : R) : algebra_map R A r ∈ set.center A :=
by simp [algebra.commutes, set.mem_center_iff]

variables (R A)

/-- The center of an algebra is the set of elements which commute with every element. They form a
subalgebra. -/
def center : subalgebra R A :=
{ algebra_map_mem' := set.algebra_map_mem_center,
  .. subsemiring.center A }

lemma coe_center : (center R A : set A) = set.center A := rfl

@[simp] lemma center_to_subsemiring :
  (center R A).to_subsemiring = subsemiring.center A :=
rfl

@[simp] lemma center_to_subring (R A : Type*) [comm_ring R] [ring A] [algebra R A] :
  (center R A).to_subring = subring.center A :=
rfl

@[simp] lemma center_eq_top (A : Type*) [comm_semiring A] [algebra R A] : center R A = ⊤ :=
set_like.coe_injective (set.center_eq_univ A)

variables {R A}

instance : comm_semiring (center R A) := subsemiring.center.comm_semiring

instance {A : Type*} [ring A] [algebra R A] : comm_ring (center R A) := subring.center.comm_ring

lemma mem_center_iff {a : A} : a ∈ center R A ↔ ∀ (b : A), b*a = a*b := iff.rfl

end center

section centralizer

@[simp]
lemma _root_.set.algebra_map_mem_centralizer
  {s : set A} (r : R) : algebra_map R A r ∈ s.centralizer :=
λ a h, (algebra.commutes _ _).symm

variables (R)

/-- The centralizer of a set as a subalgebra. -/
def centralizer (s : set A) : subalgebra R A :=
{ algebra_map_mem' := set.algebra_map_mem_centralizer,
  ..subsemiring.centralizer s, }

@[simp, norm_cast]
lemma coe_centralizer (s : set A) : (centralizer R s : set A) = s.centralizer := rfl

lemma mem_centralizer_iff {s : set A} {z : A} :
  z ∈ centralizer R s ↔ ∀ g ∈ s, g * z = z * g :=
iff.rfl

lemma centralizer_le (s t : set A) (h : s ⊆ t) :
  centralizer R t ≤ centralizer R s :=
set.centralizer_subset h

@[simp]
lemma centralizer_univ : centralizer R set.univ = center R A :=
set_like.ext' (set.centralizer_univ A)

end centralizer

/-- Suppose we are given `∑ i, lᵢ * sᵢ = 1` in `S`, and `S'` a subalgebra of `S` that contains
`lᵢ` and `sᵢ`. To check that an `x : S` falls in `S'`, we only need to show that
`r ^ n • x ∈ M'` for some `n` for each `r : s`. -/
lemma mem_of_finset_sum_eq_one_of_pow_smul_mem {S : Type*} [comm_ring S]
  [algebra R S] (S' : subalgebra R S) {ι : Type*} (ι' : finset ι) (s : ι → S) (l : ι → S)
  (e : ∑ i in ι', l i * s i = 1)
  (hs : ∀ i, s i ∈ S') (hl : ∀ i, l i ∈ S') (x : S)
  (H : ∀ i, ∃ (n : ℕ), (s i ^ n : S) • x ∈ S') : x ∈ S' :=
begin
  classical,
  suffices : x ∈ (algebra.of_id S' S).range.to_submodule,
  { obtain ⟨x, rfl⟩ := this, exact x.2 },
  choose n hn using H,
  let s' : ι → S' := λ x, ⟨s x, hs x⟩,
  have : ideal.span (s' '' ι')= ⊤,
  { rw [ideal.eq_top_iff_one, ideal.span, finsupp.mem_span_iff_total],
    refine ⟨(finsupp.of_support_finite (λ i : ι', (⟨l i, hl i⟩ : S')) (set.to_finite _))
      .map_domain $ λ i, ⟨s' i, i, i.2, rfl⟩, S'.to_submodule.injective_subtype _⟩,
    rw [finsupp.total_map_domain, finsupp.total_apply, finsupp.sum_fintype,
      map_sum, submodule.subtype_apply, subalgebra.coe_one],
    { exact finset.sum_attach.trans e },
    { exact λ _, zero_smul _ _ } },
  let N := ι'.sup n,
  have hs' := ideal.span_pow_eq_top _ this N,
  apply (algebra.of_id S' S).range.to_submodule.mem_of_span_top_of_smul_mem _ hs',
  rintros ⟨_, _, ⟨i, hi, rfl⟩, rfl⟩,
  change s i ^ N • x ∈ _,
  rw [← tsub_add_cancel_of_le (show n i ≤ N, from finset.le_sup hi), pow_add, mul_smul],
  refine submodule.smul_mem _ (⟨_, pow_mem (hs i) _⟩ : S') _,
  exact ⟨⟨_, hn i⟩, rfl⟩,
end

lemma mem_of_span_eq_top_of_smul_pow_mem {S : Type*} [comm_ring S] [algebra R S]
  (S' : subalgebra R S) (s : set S) (l : s →₀ S) (hs : finsupp.total s S S coe l = 1)
  (hs' : s ⊆ S') (hl : ∀ i, l i ∈ S') (x : S)
  (H : ∀ r : s, ∃ (n : ℕ), (r ^ n : S) • x ∈ S') : x ∈ S' :=
mem_of_finset_sum_eq_one_of_pow_smul_mem S' l.support coe l hs (λ x, hs' x.2) hl x H

end subalgebra

section nat

variables {R : Type*} [semiring R]

/-- A subsemiring is a `ℕ`-subalgebra. -/
def subalgebra_of_subsemiring (S : subsemiring R) : subalgebra ℕ R :=
{ algebra_map_mem' := λ i, coe_nat_mem S i,
  .. S }

@[simp] lemma mem_subalgebra_of_subsemiring {x : R} {S : subsemiring R} :
  x ∈ subalgebra_of_subsemiring S ↔ x ∈ S :=
iff.rfl

end nat

section int

variables {R : Type*} [ring R]

/-- A subring is a `ℤ`-subalgebra. -/
def subalgebra_of_subring (S : subring R) : subalgebra ℤ R :=
{ algebra_map_mem' := λ i, int.induction_on i (by simpa using S.zero_mem)
  (λ i ih, by simpa using S.add_mem ih S.one_mem)
  (λ i ih, show ((-i - 1 : ℤ) : R) ∈ S, by { rw [int.cast_sub, int.cast_one],
    exact S.sub_mem ih S.one_mem }),
  .. S }

variables {S : Type*} [semiring S]

@[simp] lemma mem_subalgebra_of_subring {x : R} {S : subring R} :
  x ∈ subalgebra_of_subring S ↔ x ∈ S :=
iff.rfl

end int


import analysis.topology.topological_space
import analysis.topology.continuity
import analysis.topology.topological_structures
import ex1

open tactic expr
variables {X : Type*} {Y : Type*} {Z : Type*} {W : Type*} {f f₁ f₂ : X → Y} {g : Y → Z} {h : Z → W}
variables [topological_space X] [topological_space Y] [topological_space Z] [topological_space W]

/- Push a given lambda expression inside in the goal:
 -
 - Takes an expression of the form 'λ x, f _[x]',
 - creates a hypothesis 'λ x, f _[x] = f ∘ (λ x, _[x])',
 - and rewrites the main goal using this hypothesis.
 -/
meta def push_lam_inside (e : expr) : tactic unit :=
do lam name binfo bdomain bbody ← return e
       <|> (fail "The given expression must be a λ."),

   app fn arg ← return bbody <|> fail "The outermost part must be a function application.",

   -- create hypothesis
   can_push_inside ← to_expr ``(%%e = %%fn ∘ %%(expr.lam name binfo bdomain arg)),
   -- prove hypothesis
   h_can_push_inside ← assert "can_push_λ_inside" can_push_inside,
   reflexivity <|> fail "Can't prove that λ can be pushed inside by reflexivity.",
   -- rewrite target
   rewrite_target h_can_push_inside,
   return ()

example (_ : continuous f) (_ : continuous g) :
  continuous (λ x, g $ f x) :=
begin
(do to_expr ```(λ x, g $ f x) >>= push_lam_inside),
contcomp,
end

-- Same as contcomp, put pushes λ inside if possible.
meta def contcomp2 : tactic unit :=
do `(continuous %%e) ← target <|> fail "goal has to be of the form 'continuous _'",

  -- if the goal is to show that the expression e is continuous, check if it is an assumption
  assumption <|>

  -- if e is not continuous by assumption, check if it is of the form 'f ∘ g' for some f and g
  match e with
  | `(%%outer ∘ %%inner) :=
    do
    -- assert that the outer function is continuous, if not, rotate the goal away
    outer_continuous ← to_expr ``(continuous %%outer),
    outer_is_continuous ← assert "h_outer_cont" outer_continuous,
    contcomp <|> rotate 1,

    -- assert that the inner function is continuous, if not, rotate the goal away
    inner_continuous ← to_expr ``(continuous %%inner),
    inner_is_continuous ← assert "h_inner_cont" inner_continuous,
    contcomp <|> rotate 1,

    -- knowing that inner and outer function are continuous, apply the theorem continuous.comp
    -- which shows that the composite is continuous
    cont_comp ← to_expr ``(continuous.comp %%inner_is_continuous %%outer_is_continuous),
    exact cont_comp
  | `(λ _, _) :=
    -- if we can move the lambda inside, to that and apply contcomp2 recursively
    do push_lam_inside e <|> fail "can't move lambda inside",
       contcomp2
  | _ := fail "neither composite nor lambda expression"
  end

example (_ : continuous f) (_ : continuous g) [add_monoid Y] :
  continuous (λ x, g $ f x) :=
by contcomp2

example (_ : continuous f₁) (_ : continuous f₂) [add_monoid Y] :
  continuous (λ x, f₁ x + f₂ x) :=
by contcomp2

example [add_monoid X] [topological_add_monoid X]:
  continuous (λ x : X, x + x) :=
by do to_expr ```(has_add.add) >>= push_lam_inside; repeat sorry


import category_theory.limits.shapes.biproducts

/-!
Let's show that every preadditive category embeds into a preadditive category with biproducts,
and identify a good universal property.

This is a more advanced exercise, for which I've indicated a suggested structure,
but not written a full solution. I hope this structure will work out!
-/

noncomputable theory

universes v u

variables (C : Type u)

structure additive_envelope :=
(ι : Type)
[fintype : fintype ι]
[decidable_eq : decidable_eq ι]
(val : ι → C)

attribute [instance] additive_envelope.fintype additive_envelope.decidable_eq

variables {C}

def dmatrix {X Y : additive_envelope C} (Z : X.ι → Y.ι → Type*) := Π (i : X.ι) (j : Y.ι), Z i j
-- You may need to develop some API for `dmatrix`, parallel to that in `data.matrix.basic`.
-- One thing you'll certainly need is an "extensionality" lemma,
-- showing that you can prove two `dmatrix`s are equal by checking componentwise.

open category_theory

variables [category C] [preadditive C]

namespace family

def hom (X Y : additive_envelope C) := dmatrix (λ i j, X.val i ⟶ Y.val j)

open_locale big_operators

instance : category (additive_envelope C) :=
{ hom := hom,
  id := λ X i j, if h : i = j then eq_to_hom (by subst h) else 0,
  comp := λ X Y Z f g i k, ∑ (j : Y.ι), f i j ≫ g j k,
  id_comp' := sorry,
  comp_id' := sorry,
  assoc' := sorry, }

variables (C)

@[simps]
def embedding : C ⥤ additive_envelope C :=
{ obj := λ X, ⟨unit, λ _, X⟩,
  map := λ X Y f _ _, f,
  map_id' := sorry,
  map_comp' := sorry, }

lemma embedding.faithful : faithful (embedding C) :=
sorry

instance : preadditive (additive_envelope C) :=
sorry -- probably best to go back and make `dmatrix` an `add_comm_group` first.

open category_theory.limits

instance : has_finite_biproducts (additive_envelope C) :=
{ has_biproducts_of_shape := λ J _,
  by { classical, exactI -- this makes the `fintype` instance on `J` available as well as decidable equality
  { has_biproduct := λ F, has_biproduct.mk
    { bicone :=
      { X :=
        { ι := Σ (j : J), (F j).ι,
          val := λ p, (F p.1).val p.2 },
        ι := sorry,
        π := sorry,
        ι_π := sorry, },
      is_bilimit := sorry }}} }

variables {C}

def factor {D : Type u} [category.{v} D] [preadditive D] [has_finite_biproducts D]
  (F : C ⥤ D) : additive_envelope C ⥤ D :=
{ obj := λ X, ⨁ (λ i, F.obj (X.val i)),
  map := sorry,
  map_id' := sorry,
  map_comp' := sorry, }

def factor_factorisation {D : Type u} [category D] [preadditive D] [has_finite_biproducts D]
  (F : C ⥤ D) : F ≅ embedding C ⋙ factor F :=
sorry

end family


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.category.Group.preadditive
import Mathlib.group_theory.quotient_group
import Mathlib.category_theory.limits.limits
import Mathlib.category_theory.limits.concrete_category
import Mathlib.category_theory.limits.shapes.kernels
import Mathlib.category_theory.limits.shapes.concrete_category
import Mathlib.PostPort

universes v l u_1

namespace Mathlib

/-!
# The category of additive commutative groups has all colimits.

This file uses a "pre-automated" approach, just as for `Mon/colimits.lean`.
It is a very uniform approach, that conceivably could be synthesised directly
by a tactic that analyses the shape of `add_comm_group` and `monoid_hom`.

TODO:
In fact, in `AddCommGroup` there is a much nicer model of colimits as quotients
of finitely supported functions, and we really should implement this as well (or instead).
-/

-- [ROBOT VOICE]:

-- You should pretend for now that this file was automatically generated.

-- It follows the same template as colimits in Mon.

namespace AddCommGroup.colimits

/-!
We build the colimit of a diagram in `AddCommGroup` by constructing the
free group on the disjoint union of all the abelian groups in the diagram,
then taking the quotient by the abelian group laws within each abelian group,
and the identifications given by the morphisms in the diagram.
-/

/--
An inductive type representing all group expressions (without relations)
on a collection of types indexed by the objects of `J`.
-/
-- There's always `of`

inductive prequotient {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup) where
| of : (j : J) → ↥(category_theory.functor.obj F j) → prequotient F
| zero : prequotient F
| neg : prequotient F → prequotient F
| add : prequotient F → prequotient F → prequotient F

-- Then one generator for each operation

protected instance prequotient.inhabited {J : Type v} [category_theory.small_category J]
    (F : J ⥤ AddCommGroup) : Inhabited (prequotient F) :=
  { default := prequotient.zero }

/--
The relation on `prequotient` saying when two expressions are equal
because of the abelian group laws, or
because one element is mapped to another by a morphism in the diagram.
-/
-- Make it an equivalence relation:

inductive relation {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup) :
    prequotient F → prequotient F → Prop
    where
| refl : ∀ (x : prequotient F), relation F x x
| symm : ∀ (x y : prequotient F), relation F x y → relation F y x
| trans : ∀ (x y z : prequotient F), relation F x y → relation F y z → relation F x z
| map :
    ∀ (j j' : J) (f : j ⟶ j') (x : ↥(category_theory.functor.obj F j)),
      relation F (prequotient.of j' (coe_fn (category_theory.functor.map F f) x))
        (prequotient.of j x)
| zero : ∀ (j : J), relation F (prequotient.of j 0) prequotient.zero
| neg :
    ∀ (j : J) (x : ↥(category_theory.functor.obj F j)),
      relation F (prequotient.of j (-x)) (prequotient.neg (prequotient.of j x))
| add :
    ∀ (j : J) (x y : ↥(category_theory.functor.obj F j)),
      relation F (prequotient.of j (x + y))
        (prequotient.add (prequotient.of j x) (prequotient.of j y))
| neg_1 :
    ∀ (x x' : prequotient F), relation F x x' → relation F (prequotient.neg x) (prequotient.neg x')
| add_1 :
    ∀ (x x' y : prequotient F),
      relation F x x' → relation F (prequotient.add x y) (prequotient.add x' y)
| add_2 :
    ∀ (x y y' : prequotient F),
      relation F y y' → relation F (prequotient.add x y) (prequotient.add x y')
| zero_add : ∀ (x : prequotient F), relation F (prequotient.add prequotient.zero x) x
| add_zero : ∀ (x : prequotient F), relation F (prequotient.add x prequotient.zero) x
| add_left_neg :
    ∀ (x : prequotient F), relation F (prequotient.add (prequotient.neg x) x) prequotient.zero
| add_comm : ∀ (x y : prequotient F), relation F (prequotient.add x y) (prequotient.add y x)
| add_assoc :
    ∀ (x y z : prequotient F),
      relation F (prequotient.add (prequotient.add x y) z) (prequotient.add x (prequotient.add y z))

-- There's always a `map` relation

-- Then one relation per operation, describing the interaction with `of`

-- Then one relation per argument of each operation

-- And one relation per axiom

/--
The setoid corresponding to group expressions modulo abelian group relations and identifications.
-/
instance colimit_setoid {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup) :
    setoid (prequotient F) :=
  setoid.mk (relation F) sorry

/--
The underlying type of the colimit of a diagram in `AddCommGroup`.
-/
def colimit_type {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup) :=
  quotient (colimit_setoid F)

protected instance colimit_type.add_comm_group {J : Type v} [category_theory.small_category J]
    (F : J ⥤ AddCommGroup) : add_comm_group (colimit_type F) :=
  add_comm_group.mk
    (Quot.lift
      (fun (x : prequotient F) =>
        Quot.lift (fun (y : prequotient F) => Quot.mk setoid.r (prequotient.add x y)) sorry)
      sorry)
    sorry (Quot.mk setoid.r prequotient.zero) sorry sorry
    (Quot.lift (fun (x : prequotient F) => Quot.mk setoid.r (prequotient.neg x)) sorry)
    (add_group.sub._default
      (Quot.lift
        (fun (x : prequotient F) =>
          Quot.lift (fun (y : prequotient F) => Quot.mk setoid.r (prequotient.add x y)) sorry)
        sorry)
      sorry (Quot.mk setoid.r prequotient.zero) sorry sorry
      (Quot.lift (fun (x : prequotient F) => Quot.mk setoid.r (prequotient.neg x)) sorry))
    sorry sorry

@[simp] theorem quot_zero {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup) :
    Quot.mk setoid.r prequotient.zero = 0 :=
  rfl

@[simp] theorem quot_neg {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup)
    (x : prequotient F) : Quot.mk setoid.r (prequotient.neg x) = -Quot.mk setoid.r x :=
  rfl

@[simp] theorem quot_add {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup)
    (x : prequotient F) (y : prequotient F) :
    Quot.mk setoid.r (prequotient.add x y) = Quot.mk setoid.r x + Quot.mk setoid.r y :=
  rfl

/-- The bundled abelian group giving the colimit of a diagram. -/
def colimit {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup) : AddCommGroup :=
  of (colimit_type F)

/-- The function from a given abelian group in the diagram to the colimit abelian group. -/
def cocone_fun {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup) (j : J)
    (x : ↥(category_theory.functor.obj F j)) : colimit_type F :=
  Quot.mk setoid.r (prequotient.of j x)

/-- The group homomorphism from a given abelian group in the diagram to the colimit abelian
group. -/
def cocone_morphism {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup) (j : J) :
    category_theory.functor.obj F j ⟶ colimit F :=
  add_monoid_hom.mk (cocone_fun F j) sorry sorry

@[simp] theorem cocone_naturality {J : Type v} [category_theory.small_category J]
    (F : J ⥤ AddCommGroup) {j : J} {j' : J} (f : j ⟶ j') :
    category_theory.functor.map F f ≫ cocone_morphism F j' = cocone_morphism F j :=
  ext (category_theory.functor.obj F j) (colimit F)
    (category_theory.functor.map F f ≫ cocone_morphism F j') (cocone_morphism F j)
    fun (x : ↥(category_theory.functor.obj F j)) => quot.sound (relation.map j j' f x)

@[simp] theorem cocone_naturality_components {J : Type v} [category_theory.small_category J]
    (F : J ⥤ AddCommGroup) (j : J) (j' : J) (f : j ⟶ j') (x : ↥(category_theory.functor.obj F j)) :
    coe_fn (cocone_morphism F j') (coe_fn (category_theory.functor.map F f) x) =
        coe_fn (cocone_morphism F j) x :=
  sorry

/-- The cocone over the proposed colimit abelian group. -/
def colimit_cocone {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup) :
    category_theory.limits.cocone F :=
  category_theory.limits.cocone.mk (colimit F) (category_theory.nat_trans.mk (cocone_morphism F))

/-- The function from the free abelian group on the diagram to the cone point of any other
cocone. -/
@[simp] def desc_fun_lift {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup)
    (s : category_theory.limits.cocone F) : prequotient F → ↥(category_theory.limits.cocone.X s) :=
  sorry

/-- The function from the colimit abelian group to the cone point of any other cocone. -/
def desc_fun {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup)
    (s : category_theory.limits.cocone F) : colimit_type F → ↥(category_theory.limits.cocone.X s) :=
  Quot.lift (desc_fun_lift F s) sorry

/-- The group homomorphism from the colimit abelian group to the cone point of any other cocone. -/
def desc_morphism {J : Type v} [category_theory.small_category J] (F : J ⥤ AddCommGroup)
    (s : category_theory.limits.cocone F) : colimit F ⟶ category_theory.limits.cocone.X s :=
  add_monoid_hom.mk (desc_fun F s) sorry sorry

/-- Evidence that the proposed colimit is the colimit. -/
def colimit_cocone_is_colimit {J : Type v} [category_theory.small_category J]
    (F : J ⥤ AddCommGroup) : category_theory.limits.is_colimit (colimit_cocone F) :=
  category_theory.limits.is_colimit.mk
    fun (s : category_theory.limits.cocone F) => desc_morphism F s

protected instance has_colimits_AddCommGroup : category_theory.limits.has_colimits AddCommGroup :=
  category_theory.limits.has_colimits.mk
    fun (J : Type u_1) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.has_colimits_of_shape.mk
        fun (F : J ⥤ AddCommGroup) =>
          category_theory.limits.has_colimit.mk
            (category_theory.limits.colimit_cocone.mk (colimit_cocone F)
              (colimit_cocone_is_colimit F))

end AddCommGroup.colimits

namespace AddCommGroup

/--
The categorical cokernel of a morphism in `AddCommGroup`
agrees with the usual group-theoretical quotient.
-/
def cokernel_iso_quotient {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H) :
    category_theory.limits.cokernel f ≅ of (quotient_add_group.quotient (add_monoid_hom.range f)) :=
  category_theory.iso.mk
    (category_theory.limits.cokernel.desc f (quotient_add_group.mk' (add_monoid_hom.range f)) sorry)
    (add_monoid_hom.of
      ⇑(quotient_add_group.lift (add_monoid_hom.range f) (category_theory.limits.cokernel.π f)
          sorry))

end Mathlib


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Anne Baanen
-/
import algebra.order.field

/-!
# Absolute values

This file defines a bundled type of absolute values `absolute_value R S`.

## Main definitions

 * `absolute_value R S` is the type of absolute values on `R` mapping to `S`.
 * `absolute_value.abs` is the "standard" absolute value on `S`, mapping negative `x` to `-x`.
 * `absolute_value.to_monoid_with_zero_hom`: absolute values mapping to a
   linear ordered field preserve `0`, `*` and `1`
 * `is_absolute_value`: a type class stating that `f : β → α` satisfies the axioms of an abs val
-/

/-- `absolute_value R S` is the type of absolute values on `R` mapping to `S`:
the maps that preserve `*`, are nonnegative, positive definite and satisfy the triangle equality. -/
structure absolute_value (R S : Type*) [semiring R] [ordered_semiring S]
  extends mul_hom R S :=
(nonneg' : ∀ x, 0 ≤ to_fun x)
(eq_zero' : ∀ x, to_fun x = 0 ↔ x = 0)
(add_le' : ∀ x y, to_fun (x + y) ≤ to_fun x + to_fun y)

namespace absolute_value

attribute [nolint doc_blame] absolute_value.to_mul_hom

initialize_simps_projections absolute_value (to_mul_hom_to_fun → apply)

section ordered_semiring

variables {R S : Type*} [semiring R] [ordered_semiring S] (abv : absolute_value R S)

instance : has_coe_to_fun (absolute_value R S) (λ f, R → S) := ⟨λ f, f.to_fun⟩

@[simp] lemma coe_to_mul_hom : ⇑abv.to_mul_hom = abv := rfl

protected theorem nonneg (x : R) : 0 ≤ abv x := abv.nonneg' x
@[simp] protected theorem eq_zero {x : R} : abv x = 0 ↔ x = 0 := abv.eq_zero' x
protected theorem add_le (x y : R) : abv (x + y) ≤ abv x + abv y := abv.add_le' x y
@[simp] protected theorem map_mul (x y : R) : abv (x * y) = abv x * abv y := abv.map_mul' x y

protected theorem pos {x : R} (hx : x ≠ 0) : 0 < abv x :=
lt_of_le_of_ne (abv.nonneg x) (ne.symm $ mt abv.eq_zero.mp hx)

@[simp] protected theorem pos_iff {x : R} : 0 < abv x ↔ x ≠ 0 :=
⟨λ h₁, mt abv.eq_zero.mpr h₁.ne', abv.pos⟩

protected theorem ne_zero {x : R} (hx : x ≠ 0) : abv x ≠ 0 := (abv.pos hx).ne'

@[simp] protected theorem map_zero : abv 0 = 0 := abv.eq_zero.2 rfl

end ordered_semiring

section ordered_ring

variables {R S : Type*} [ring R] [ordered_ring S] (abv : absolute_value R S)

protected lemma sub_le (a b c : R) : abv (a - c) ≤ abv (a - b) + abv (b - c) :=
by simpa [sub_eq_add_neg, add_assoc] using abv.add_le (a - b) (b - c)

protected lemma le_sub (a b : R) : abv a - abv b ≤ abv (a - b) :=
sub_le_iff_le_add.2 $ by simpa using abv.add_le (a - b) b

@[simp] lemma map_sub_eq_zero_iff (a b : R) : abv (a - b) = 0 ↔ a = b :=
abv.eq_zero.trans sub_eq_zero

end ordered_ring

section linear_ordered_ring

variables {R S : Type*} [semiring R] [linear_ordered_ring S] (abv : absolute_value R S)

/-- `absolute_value.abs` is `abs` as a bundled `absolute_value`. -/
@[simps]
protected def abs : absolute_value S S :=
{ to_fun := abs,
  nonneg' := abs_nonneg,
  eq_zero' := λ _, abs_eq_zero,
  add_le' := abs_add,
  map_mul' := abs_mul }

instance : inhabited (absolute_value S S) := ⟨absolute_value.abs⟩

variables [nontrivial R]

@[simp] protected theorem map_one : abv 1 = 1 :=
(mul_right_inj' $ abv.ne_zero one_ne_zero).1 $
by rw [← abv.map_mul, mul_one, mul_one]

/-- Absolute values from a nontrivial `R` to a linear ordered ring preserve `*`, `0` and `1`. -/
def to_monoid_with_zero_hom : monoid_with_zero_hom R S :=
{ to_fun := abv,
  map_zero' := abv.map_zero,
  map_one' := abv.map_one,
  .. abv }

@[simp] lemma coe_to_monoid_with_zero_hom : ⇑abv.to_monoid_with_zero_hom = abv := rfl

/-- Absolute values from a nontrivial `R` to a linear ordered ring preserve `*` and `1`. -/
def to_monoid_hom : monoid_hom R S :=
{ to_fun := abv,
  map_one' := abv.map_one,
  .. abv }

@[simp] lemma coe_to_monoid_hom : ⇑abv.to_monoid_hom = abv := rfl

@[simp] protected lemma map_pow (a : R) (n : ℕ) : abv (a ^ n) = abv a ^ n :=
abv.to_monoid_hom.map_pow a n

end linear_ordered_ring

section linear_ordered_comm_ring

section ring

variables {R S : Type*} [ring R] [linear_ordered_comm_ring S] (abv : absolute_value R S)

@[simp] protected theorem map_neg (a : R) : abv (-a) = abv a :=
begin
  by_cases ha : a = 0, { simp [ha] },
  refine (mul_self_eq_mul_self_iff.mp
    (by rw [← abv.map_mul, neg_mul_neg, abv.map_mul])).resolve_right _,
  exact ((neg_lt_zero.mpr (abv.pos ha)).trans (abv.pos (neg_ne_zero.mpr ha))).ne'
end

protected theorem map_sub (a b : R) : abv (a - b) = abv (b - a) :=
by rw [← neg_sub, abv.map_neg]

lemma abs_abv_sub_le_abv_sub (a b : R) :
  abs (abv a - abv b) ≤ abv (a - b) :=
abs_sub_le_iff.2 ⟨abv.le_sub _ _, by rw abv.map_sub; apply abv.le_sub⟩

end ring

end linear_ordered_comm_ring

section linear_ordered_field

section field

variables {R S : Type*} [division_ring R] [linear_ordered_field S] (abv : absolute_value R S)

@[simp] protected theorem map_inv (a : R) : abv a⁻¹ = (abv a)⁻¹ :=
abv.to_monoid_with_zero_hom.map_inv a

@[simp] protected theorem map_div (a b : R) : abv (a / b) = abv a / abv b :=
abv.to_monoid_with_zero_hom.map_div a b

end field

end linear_ordered_field

end absolute_value

section is_absolute_value

/-- A function `f` is an absolute value if it is nonnegative, zero only at 0, additive, and
multiplicative.

See also the type `absolute_value` which represents a bundled version of absolute values.
-/
class is_absolute_value {S} [ordered_semiring S]
  {R} [semiring R] (f : R → S) : Prop :=
(abv_nonneg [] : ∀ x, 0 ≤ f x)
(abv_eq_zero [] : ∀ {x}, f x = 0 ↔ x = 0)
(abv_add [] : ∀ x y, f (x + y) ≤ f x + f y)
(abv_mul [] : ∀ x y, f (x * y) = f x * f y)

namespace is_absolute_value

section ordered_semiring

variables {S : Type*} [ordered_semiring S]
variables {R : Type*} [semiring R] (abv : R → S) [is_absolute_value abv]

/-- A bundled absolute value is an absolute value. -/
instance absolute_value.is_absolute_value
  (abv : absolute_value R S) : is_absolute_value abv :=
{ abv_nonneg := abv.nonneg,
  abv_eq_zero := λ _, abv.eq_zero,
  abv_add := abv.add_le,
  abv_mul := abv.map_mul }

/-- Convert an unbundled `is_absolute_value` to a bundled `absolute_value`. -/
@[simps]
def to_absolute_value : absolute_value R S :=
{ to_fun := abv,
  add_le' := abv_add abv,
  eq_zero' := λ _, abv_eq_zero abv,
  nonneg' := abv_nonneg abv,
  map_mul' := abv_mul abv }

theorem abv_zero : abv 0 = 0 := (abv_eq_zero abv).2 rfl

theorem abv_pos {a : R} : 0 < abv a ↔ a ≠ 0 :=
by rw [lt_iff_le_and_ne, ne, eq_comm]; simp [abv_eq_zero abv, abv_nonneg abv]

end ordered_semiring

section linear_ordered_ring

variables {S : Type*} [linear_ordered_ring S]
variables {R : Type*} [semiring R] (abv : R → S) [is_absolute_value abv]

instance abs_is_absolute_value {S} [linear_ordered_ring S] :
  is_absolute_value (abs : S → S) :=
{ abv_nonneg  := abs_nonneg,
  abv_eq_zero := λ _, abs_eq_zero,
  abv_add     := abs_add,
  abv_mul     := abs_mul }

end linear_ordered_ring

section linear_ordered_comm_ring

variables {S : Type*} [linear_ordered_comm_ring S]

section semiring
variables {R : Type*} [semiring R] (abv : R → S) [is_absolute_value abv]

theorem abv_one [nontrivial R] : abv 1 = 1 :=
(mul_right_inj' $ mt (abv_eq_zero abv).1 one_ne_zero).1 $
by rw [← abv_mul abv, mul_one, mul_one]

/-- `abv` as a `monoid_with_zero_hom`. -/
def abv_hom [nontrivial R] : monoid_with_zero_hom R S :=
⟨abv, abv_zero abv, abv_one abv, abv_mul abv⟩

lemma abv_pow [nontrivial R] (abv : R → S) [is_absolute_value abv]
  (a : R) (n : ℕ) : abv (a ^ n) = abv a ^ n :=
(abv_hom abv).to_monoid_hom.map_pow a n

end semiring

end linear_ordered_comm_ring

section linear_ordered_field
variables {S : Type*} [linear_ordered_field S]

section ring
variables {R : Type*} [ring R] (abv : R → S) [is_absolute_value abv]

theorem abv_neg (a : R) : abv (-a) = abv a :=
by rw [← mul_self_inj_of_nonneg (abv_nonneg abv _) (abv_nonneg abv _),
← abv_mul abv, ← abv_mul abv]; simp

lemma abv_sub_le (a b c : R) : abv (a - c) ≤ abv (a - b) + abv (b - c) :=
by simpa [sub_eq_add_neg, add_assoc] using abv_add abv (a - b) (b - c)

lemma sub_abv_le_abv_sub (a b : R) : abv a - abv b ≤ abv (a - b) :=
sub_le_iff_le_add.2 $ by simpa using abv_add abv (a - b) b

lemma abs_abv_sub_le_abv_sub (a b : R) :
  abs (abv a - abv b) ≤ abv (a - b) :=
abs_sub_le_iff.2 ⟨sub_abv_le_abv_sub abv _ _,
  by rw abv_sub abv; apply sub_abv_le_abv_sub abv⟩
end ring

section field
variables {R : Type*} [division_ring R] (abv : R → S) [is_absolute_value abv]

theorem abv_inv (a : R) : abv a⁻¹ = (abv a)⁻¹ :=
(abv_hom abv).map_inv a

theorem abv_div (a b : R) : abv (a / b) = abv a / abv b :=
(abv_hom abv).map_div a b

end field

end linear_ordered_field

end is_absolute_value

end is_absolute_value


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison, Floris van Doorn
-/
import category_theory.functor.category
import category_theory.isomorphism

/-!
# Natural isomorphisms

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

For the most part, natural isomorphisms are just another sort of isomorphism.

We provide some special support for extracting components:
* if `α : F ≅ G`, then `a.app X : F.obj X ≅ G.obj X`,
and building natural isomorphisms from components:
*
```
nat_iso.of_components
  (app : ∀ X : C, F.obj X ≅ G.obj X)
  (naturality : ∀ {X Y : C} (f : X ⟶ Y), F.map f ≫ (app Y).hom = (app X).hom ≫ G.map f) :
F ≅ G
```
only needing to check naturality in one direction.

## Implementation

Note that `nat_iso` is a namespace without a corresponding definition;
we put some declarations that are specifically about natural isomorphisms in the `iso`
namespace so that they are available using dot notation.
-/

open category_theory

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄

namespace category_theory
open nat_trans

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]
  {E : Type u₃} [category.{v₃} E]

namespace iso

/-- The application of a natural isomorphism to an object. We put this definition in a different
namespace, so that we can use `α.app` -/
@[simps] def app {F G : C ⥤ D} (α : F ≅ G) (X : C) : F.obj X ≅ G.obj X :=
{ hom := α.hom.app X,
  inv := α.inv.app X,
  hom_inv_id' := begin rw [← comp_app, iso.hom_inv_id], refl end,
  inv_hom_id' := begin rw [← comp_app, iso.inv_hom_id], refl end }

@[simp, reassoc]
lemma hom_inv_id_app {F G : C ⥤ D} (α : F ≅ G) (X : C) :
  α.hom.app X ≫ α.inv.app X = 𝟙 (F.obj X) :=
congr_fun (congr_arg nat_trans.app α.hom_inv_id) X

@[simp, reassoc]
lemma inv_hom_id_app {F G : C ⥤ D} (α : F ≅ G) (X : C) :
  α.inv.app X ≫ α.hom.app X = 𝟙 (G.obj X) :=
congr_fun (congr_arg nat_trans.app α.inv_hom_id) X

end iso

namespace nat_iso

open category_theory.category category_theory.functor

@[simp] lemma trans_app {F G H : C ⥤ D} (α : F ≅ G) (β : G ≅ H) (X : C) :
  (α ≪≫ β).app X = α.app X ≪≫ β.app X := rfl

lemma app_hom {F G : C ⥤ D} (α : F ≅ G) (X : C) : (α.app X).hom = α.hom.app X := rfl
lemma app_inv {F G : C ⥤ D} (α : F ≅ G) (X : C) : (α.app X).inv = α.inv.app X := rfl

variables {F G : C ⥤ D}

instance hom_app_is_iso (α : F ≅ G) (X : C) : is_iso (α.hom.app X) :=
⟨⟨α.inv.app X,
  ⟨by rw [←comp_app, iso.hom_inv_id, ←id_app], by rw [←comp_app, iso.inv_hom_id, ←id_app]⟩⟩⟩

instance inv_app_is_iso (α : F ≅ G) (X : C) : is_iso (α.inv.app X) :=
⟨⟨α.hom.app X,
  ⟨by rw [←comp_app, iso.inv_hom_id, ←id_app], by rw [←comp_app, iso.hom_inv_id, ←id_app]⟩⟩⟩

section
/-!
Unfortunately we need a separate set of cancellation lemmas for components of natural isomorphisms,
because the `simp` normal form is `α.hom.app X`, rather than `α.app.hom X`.

(With the later, the morphism would be visibly part of an isomorphism, so general lemmas about
isomorphisms would apply.)

In the future, we should consider a redesign that changes this simp norm form,
but for now it breaks too many proofs.
-/

variables (α : F ≅ G)

@[simp] lemma cancel_nat_iso_hom_left {X : C} {Z : D} (g g' : G.obj X ⟶ Z) :
  α.hom.app X ≫ g = α.hom.app X ≫ g' ↔ g = g' :=
by simp only [cancel_epi]

@[simp] lemma cancel_nat_iso_inv_left {X : C} {Z : D} (g g' : F.obj X ⟶ Z) :
  α.inv.app X ≫ g = α.inv.app X ≫ g' ↔ g = g' :=
by simp only [cancel_epi]

@[simp] lemma cancel_nat_iso_hom_right {X : D} {Y : C} (f f' : X ⟶ F.obj Y) :
  f ≫ α.hom.app Y = f' ≫ α.hom.app Y ↔ f = f' :=
by simp only [cancel_mono]

@[simp] lemma cancel_nat_iso_inv_right {X : D} {Y : C} (f f' : X ⟶ G.obj Y) :
  f ≫ α.inv.app Y = f' ≫ α.inv.app Y ↔ f = f' :=
by simp only [cancel_mono]

@[simp] lemma cancel_nat_iso_hom_right_assoc {W X X' : D} {Y : C}
  (f : W ⟶ X) (g : X ⟶ F.obj Y) (f' : W ⟶ X') (g' : X' ⟶ F.obj Y)  :
  f ≫ g ≫ α.hom.app Y = f' ≫ g' ≫ α.hom.app Y ↔ f ≫ g = f' ≫ g' :=
by simp only [←category.assoc, cancel_mono]

@[simp] lemma cancel_nat_iso_inv_right_assoc {W X X' : D} {Y : C}
  (f : W ⟶ X) (g : X ⟶ G.obj Y) (f' : W ⟶ X') (g' : X' ⟶ G.obj Y)  :
  f ≫ g ≫ α.inv.app Y = f' ≫ g' ≫ α.inv.app Y ↔ f ≫ g = f' ≫ g' :=
by simp only [←category.assoc, cancel_mono]

@[simp] lemma inv_inv_app {F G : C ⥤ D} (e : F ≅ G) (X : C) :
  inv (e.inv.app X) = e.hom.app X := by { ext, simp }

end

variables {X Y : C}

lemma naturality_1 (α : F ≅ G) (f : X ⟶ Y) :
  α.inv.app X ≫ F.map f ≫ α.hom.app Y = G.map f :=
by simp
lemma naturality_2 (α : F ≅ G) (f : X ⟶ Y) :
  α.hom.app X ≫ G.map f ≫ α.inv.app Y = F.map f :=
by simp

lemma naturality_1' (α : F ⟶ G) (f : X ⟶ Y) [is_iso (α.app X)] :
  inv (α.app X) ≫ F.map f ≫ α.app Y = G.map f :=
by simp
@[simp, reassoc] lemma naturality_2' (α : F ⟶ G) (f : X ⟶ Y) [is_iso (α.app Y)] :
  α.app X ≫ G.map f ≫ inv (α.app Y) = F.map f :=
by rw [←category.assoc, ←naturality, category.assoc, is_iso.hom_inv_id, category.comp_id]

/--
The components of a natural isomorphism are isomorphisms.
-/
instance is_iso_app_of_is_iso (α : F ⟶ G) [is_iso α] (X) : is_iso (α.app X) :=
⟨⟨(inv α).app X,
  ⟨congr_fun (congr_arg nat_trans.app (is_iso.hom_inv_id α)) X,
   congr_fun (congr_arg nat_trans.app (is_iso.inv_hom_id α)) X⟩⟩⟩

@[simp] lemma is_iso_inv_app (α : F ⟶ G) [is_iso α] (X) : (inv α).app X = inv (α.app X) :=
by { ext, rw ←nat_trans.comp_app, simp, }

@[simp] lemma inv_map_inv_app (F : C ⥤ D ⥤ E) {X Y : C} (e : X ≅ Y) (Z : D) :
  inv ((F.map e.inv).app Z) = (F.map e.hom).app Z :=
by { ext, simp, }

/--
Construct a natural isomorphism between functors by giving object level isomorphisms,
and checking naturality only in the forward direction.
-/
@[simps] def of_components (app : ∀ X : C, F.obj X ≅ G.obj X)
  (naturality : ∀ {X Y : C} (f : X ⟶ Y), F.map f ≫ (app Y).hom = (app X).hom ≫ G.map f) :
  F ≅ G :=
{ hom := { app := λ X, (app X).hom },
  inv :=
  { app := λ X, (app X).inv,
    naturality' := λ X Y f,
    begin
      have h := congr_arg (λ f, (app X).inv ≫ (f ≫ (app Y).inv)) (naturality f).symm,
      simp only [iso.inv_hom_id_assoc, iso.hom_inv_id, assoc, comp_id, cancel_mono] at h,
      exact h
    end }, }

@[simp] lemma of_components.app (app' : ∀ X : C, F.obj X ≅ G.obj X) (naturality) (X) :
  (of_components app' naturality).app X = app' X :=
by tidy

/--
A natural transformation is an isomorphism if all its components are isomorphisms.
-/
-- Making this an instance would cause a typeclass inference loop with `is_iso_app_of_is_iso`.
lemma is_iso_of_is_iso_app (α : F ⟶ G) [∀ X : C, is_iso (α.app X)] : is_iso α :=
⟨(is_iso.of_iso (of_components (λ X, as_iso (α.app X)) (by tidy))).1⟩

/-- Horizontal composition of natural isomorphisms. -/
@[simps]
def hcomp {F G : C ⥤ D} {H I : D ⥤ E} (α : F ≅ G) (β : H ≅ I) : F ⋙ H ≅ G ⋙ I :=
begin
  refine ⟨α.hom ◫ β.hom, α.inv ◫ β.inv, _, _⟩,
  { ext, rw [←nat_trans.exchange], simp, refl },
  ext, rw [←nat_trans.exchange], simp, refl
end

lemma is_iso_map_iff {F₁ F₂ : C ⥤ D} (e : F₁ ≅ F₂) {X Y : C} (f : X ⟶ Y) :
  is_iso (F₁.map f) ↔ is_iso (F₂.map f) :=
begin
  revert F₁ F₂,
  suffices : ∀ {F₁ F₂ : C ⥤ D} (e : F₁ ≅ F₂) (hf : is_iso (F₁.map f)), is_iso (F₂.map f),
  { exact λ F₁ F₂ e, ⟨this e, this e.symm⟩, },
  introsI F₁ F₂ e hf,
  refine is_iso.mk ⟨e.inv.app Y ≫ inv (F₁.map f) ≫ e.hom.app X, _, _⟩,
  { simp only [nat_trans.naturality_assoc, is_iso.hom_inv_id_assoc, iso.inv_hom_id_app], },
  { simp only [assoc, ← e.hom.naturality, is_iso.inv_hom_id_assoc, iso.inv_hom_id_app], },
end

end nat_iso

end category_theory


import data.set.basic

namespace MCL

inductive type
| int
| float

open type

@[reducible]
def signature := string → type

@[reducible]
def create_signature : list (string × type) → signature
| [] n := int
| ((m, t) :: xs) n := if m = n then t else create_signature xs n

@[reducible]
def type_map : type → Type
| int := ℕ
| float := ℕ

@[reducible]
def state (sig : signature) : Type := Π n : string, type_map (sig n)

def state.update {sig : signature} (name : string) (val : type_map (sig name)) (s : state sig) : state sig :=
λn, if h : n = name then by rw [h]; exact val else (s n)

def state.update' {sig : signature} {t : type} {name : string} (eq : sig name = t) (val : type_map t) (s : state sig) : state sig :=
state.update name (by rw [eq]; exact val) s

def state.get' {sig : signature} {t : type} {name : string} (eq : sig name = t) (s : state sig) : type_map t :=
by rw [← eq]; exact s name

inductive expression (sig : signature) (t : type) : Type
| var (n : string) (h : sig n = t) : expression
| add : expression → expression → expression
| const_int {} (n : ℕ) (h : t = int) : expression

instance (sig : signature) (t : type) : has_add (expression sig t) := ⟨expression.add⟩
instance (sig : signature) : has_zero (expression sig int) := ⟨expression.const_int 0 rfl⟩
instance (sig : signature) : has_one (expression sig int) := ⟨expression.const_int 1 rfl⟩

notation `v(` n `)`:= expression.var n (by refl)
infixr ` ~+ `:90 := expression.add
notation `i(` n `)`:= expression.const_int n (by refl)

open expression

inductive program (sig : signature)
| assign (n : string) : list (expression sig int) → (expression sig (sig n)) → program
| seq : program → program → program
| loop (n : string) (h : sig n = int) :
  expression sig int → program → program
| skip : program

infixr ` ;; `:90 := program.seq

open program

def type_map_add : Π{t : type}, type_map t → type_map t → type_map t
| int a b := a + b
| float a b := a + b

def eval_expression {sig : signature} (s : state sig) {t : type} : expression sig t → type_map t
| (var n h) := (by rw [←h]; exact s n)
| (add a b) := type_map_add (eval_expression a) (eval_expression b)
| (const_int n h) := (by rw [h]; exact n)

def den {sig : signature} : program sig → state sig → state sig
| (assign var_name indices expr) s := s.update var_name (eval_expression s expr)
| (seq p₁ p₂) s := den p₂ (den p₁ s)
| (loop loop_var h expr p) s' := nat.iterate (λ s, (den p s).update' h (s.get' h + 1)) (eval_expression s' expr) (s'.update' h 0)
| (skip _) s := s

notation `⟦` p `⟧`:= den p

inductive big_step {sig : signature} : (program sig × (state sig)) → (state sig) → Prop
| skip {s} :
    big_step (skip sig, s) s
| seq {p₁ p₂ s t u} (h₁ : big_step (p₁, s) t) (h₂ : big_step (p₂, t) u) :
    big_step (seq p₁ p₂, s) u
| assign {var_name indices s u ty} {expr : expression sig ty} (hvty : sig var_name = ty)
    (h : state.get' hvty u = eval_expression s expr) (h₂ : ∀m, ¬(var_name = m) → s m = u m) :
    big_step (assign var_name indices expr, s) u
| loop_zero {n hni expr p s} (h : eval_expression s expr = 0) :
    big_step (loop n hni expr p, s) s
| loop_step {l hli expr p s u v} {n : type_map int} (h₁ : eval_expression s expr = (n + 1)) (h₂ : big_step (loop l hli i(n) p, u) v) (h₃ : big_step (p, s) v) :
    big_step (loop l hli expr p, s) v

infix ` ⟹ `:110 := big_step

@[reducible]
def S1 := (create_signature [("m", int), ("n", int)])

def s : state S1 := sorry

#eval eval_expression s i(10)

def P1 : program S1 :=
    (assign "n" [] i(3)) ;;
    (assign "m" [] (i(39) + v("n")))

#reduce den P1 s "m" -- computes 42
example (s : state S1) : (show nat, from den P1 s "m") = 42 := rfl

example {α β : Sort} (h : α = β) (b : β) : eq.mpr h b = eq.mpr h b := begin
    refl,
end

example {α β : Sort} (h₁ : β = α) (h₂ : α = β) (b : β) : eq.mpr h₁ (eq.mpr h₂ b) = b := begin
    refl,
end

theorem eq_mpr_switch {α β : Sort} {a b} (h : α = β)  : a = eq.mpr h b → eq.mpr (eq.symm h) a = b := begin
    intro,
    refl,
end

theorem eq_mpr_switch' {α β : Type} {a : α} {b : β} (h : α = β)  : eq.mpr (eq.symm h) a = b → a = eq.mpr h b := begin
    intro,
    sorry
end

-- set_option pp.all true

theorem w {n v} {sig : signature} {s u : state sig} (ht : sig v = int) (hp : (assign v list.nil (const_int n ht), s) ⟹ u) : u.get' ht = n := begin
    cases hp,
    rw state.get' at hp_h,
    apply eq_mpr_switch',
    rw hp_h,
end

example {t} : (P1, s)⟹t → (t "m") = (42 : nat) := begin
    intro p,
    cases p with _ _ _ _ u _ p₁ p₂,
    have a : (show nat, from u "n") = 3 := begin
        cases p₁,
        rw eq.mpr  at p₁_h,
        rw state.get' at p₁_h,

    end,
    cases p_h₂,
    simp at p_h₂_hvty,
    unfold S1 at p_h₂_hvty,

end

def P2 : program S1 :=
    (assign "m" [] i(0)) ;;
    (loop "n" (by refl) i(4)) (
        (assign "m" [] (v("m") ~+ v("n"))
    ))

#eval den P2 s "m"

set_option trace.simplify.rewrite true

example (sig : signature) (p₁ p₂ : program sig) (s : state sig) : ⟦ p₁ ;; p₂ ⟧ s = den p₂ (den p₁ s) := by reflexivity

--set_option pp.all true

lemma eval_const_int { sig : signature } { s : state sig } (n : ℕ) : @eval_expression sig s int (const_int n (by refl)) = n := by refl

-- overapproximated
def modifies {sig : signature} : program sig → set (string)
| (assign n _ _) := { n }
| (seq p₁ p₂) := modifies p₁ ∪ modifies p₂
| (loop n _ _ p) := { n } ∪ modifies p

def expr_reads {sig : signature} {t : type} : expression sig t → set (string)
| (var n _) := { n }
| (add s₁ s₂) := expr_reads s₁ ∪ expr_reads s₂
| (const_int  _ _) := { }

#check (@var S1 int "m" (by refl))

#reduce expr_reads (@const_int S1 int 39 (by refl)) -- empty set
-- sets aren't computable
--#reduce expr_reads (@var S1 int "m" (by refl)) "m"

example : "m" ∈ expr_reads (@var S1 int "m" (by refl)) :=
begin
    rw expr_reads,
    simp,
end

-- does not include array accesses yet
def reads { sig : signature } : program sig → set (string)
| (assign _ _ expr) := expr_reads expr
| (seq p₁ p₂) := reads p₁ ∪ reads p₂
| (loop _ _ expr p) := expr_reads expr ∪ reads p

def uses {sig : signature} : program sig → set (string)
| p := modifies p ∪ reads p

@[simp]
lemma state_update_lookup_success (sig : signature) (s : state sig) (a : string) (va : type_map (sig a))
    : (s.update a va) a = va :=
begin
    unfold state.update,
    simp,
    rw eq.mpr,
end

@[simp]
lemma state_update_lookup_skip (sig : signature) (s : state sig) (a b : string) (va : type_map (sig a))
    : ¬(b = a) → (s.update a va) b = s b :=
begin
    intro hneq,
    unfold state.update,
    simp[hneq],
end

@[simp]
lemma state_update_lookup_skip' (sig : signature) (s : state sig) (a b : string) (va : type_map (sig a))
    : ¬(a = b) → (s.update a va) b = s b :=
begin
    intro hneq,
    apply state_update_lookup_skip,
    intro,
    apply hneq,
    simp[*]
end

lemma state_update_assoc (sig : signature) (s : state sig) (a b: string) (va : type_map (sig a)) (vb : type_map (sig b))
    : ¬(a = b) → state.update a va (state.update b vb s) = state.update b vb (state.update a va s) :=
begin
    intro hneq,
    funext x,
    -- we do case distinction, either x is a or b or neither
    by_cases hxa : x = a,
    {
        rw hxa,
        simp,
        rw state_update_lookup_skip,
        simp,
        assumption
    }, {
        by_cases hxb : x = b,
        {
            rw hxb,
            simp,
            rw state_update_lookup_skip',
            simp,
            assumption
        }, {
            repeat { rw state_update_lookup_skip },
            repeat { assumption }
        }
    }
end

lemma state_eliminate_update' (sig : signature) (s : state sig) (a b : string) (t : type) (hat : sig a = t) (hnab : ¬(b = a) ) (val : type_map t)
  : (s.update' hat val) b = s b :=
begin
    rw state.update',
    apply state_update_lookup_skip,
    assumption,
end

lemma uses_neq (sig : signature) (p : program sig) (a b : string) (hpua : uses p a) (hpnub : ¬(uses p b)) : ¬(a = b) := begin
    cases hpua,
    case or.inl {
        intro heq,
        apply hpnub,
        rw uses,
        left,
        rw ← heq,
        exact hpua
    },
    case or.inr {
        intro heq,
        apply hpnub,
        rw uses,
        right,
        rw ← heq,
        exact hpua
    }
end

lemma uses_loop_condition (sig : signature) (n : string)
    (h : sig n = int) (p : program sig) (expr : expression sig int)
    : uses (loop n h expr p) n := begin
    rw uses,
    left,
    rw modifies,
    left,
    simp,
end

lemma uses_not_seq_left (sig : signature) (p₁ p₂ : program sig) (a : string) : ¬uses (p₁ ;; p₂) a → ¬uses p₁ a := begin
    intro hnseq,
    intro hup1,
    apply hnseq,
    unfold uses,
    cases hup1,
    case or.inl {
        left,
        rw modifies,
        left,
        exact hup1,
    },
    case or.inr {
        right,
        rw reads,
        left,
        exact hup1
    }
end

lemma uses_not_seq_right (sig : signature) (p₁ p₂ : program sig) (a : string) : ¬uses (p₁ ;; p₂) a → ¬uses p₂ a := begin
    intro hnseq,
    intro hup2,
    apply hnseq,
    unfold uses,
    cases hup2,
    case or.inl {
        left,
        rw modifies,
        right,
        exact hup2,
    },
    case or.inr {
        right,
        rw reads,
        right,
        exact hup2
    }
end

lemma uses_not_loop_program (sig : signature) (n a : string)
    (h : sig n = int) (p : program sig) (expr : expression sig int)
    : ¬uses (loop n h expr p) a → ¬uses p a := begin
    intro hlnu,
    intro hpu,
    apply hlnu,
    rw uses,
    cases hpu,
    {
        left,
        rw modifies,
        right,
        assumption,
    }, {
        right,
        rw reads,
        right,
        assumption,
    }
end

-- potential tactic to solve uses

-- end MCL
-- namespace tactic.interactive

-- open tactic MCL

-- @[reducible]
-- meta def match_uses (n : expr) : expr → Prop
-- | `(¬uses %%p %%m) := (n = m)
-- | _ := false

-- meta instance (n : expr) : decidable_pred (match_uses n) := sorry

-- meta def solve_uses (h : name) : tactic unit := do
--   t ← target,
--   match t with
--   | `(¬uses %%p %%n) := do
--     gs <- get_goals,
--     trace "Possible candidates",
--     trace (gs.filter (match_uses n))
--   | _ := fail "Goal is not uses"
--   end

-- end tactic.interactive

-- namespace MCL

-- open expression program

#print prefix eval_expression
-- set_option pp.proofs true

lemma expr_uses_update_eliminate (sig : signature) (s : state sig) (a : string) (val : type_map (sig a))
      (t : type) (expr : expression sig t) (hnu : ¬(expr_reads expr a))
      : eval_expression (s.update a val) expr = eval_expression s expr :=
begin
  induction expr,
  case var : n h {
    have hneq : ¬(a = n) := begin
        intro han,
        subst han,
        apply hnu,
        rw expr_reads,
        sorry -- another one of those set things
    end,
    have : state.update a val s n = s n := begin
        rw state_update_lookup_skip',
        assumption,
    end,
    simp [eval_expression, this],
  },
    case add : a b ih_a ih_b {
      simp [eval_expression],
      rw ih_a,
      rw ih_b,
      repeat { sorry } -- use the yet to written tactic
    },
    case expression.const_int : {
        simp [eval_expression],
    }
end

lemma expr_uses_update'_eliminate (sig : signature) (s : state sig) (a : string) (t t' : type)
    (hat : sig a = t) (val : type_map t) (expr : expression sig t') (hnu : ¬(expr_reads expr a))
    : eval_expression (s.update' hat val) expr = eval_expression s expr := begin
    unfold state.update',
    apply expr_uses_update_eliminate,
    exact hnu
end

lemma iterate_outer {α : Type} (f : α → α) (n : ℕ) (a : α) : f^[n+1] a = f ((f^[n]) a) := sorry

-- set_option pp.all true

lemma state_postpone_update' (sig : signature) (s : state sig) (a : string) (t : type)
    (hat : sig a = t) (val : type_map t) (p : program sig) (hnu : ¬(uses p a))
    : ⟦ p ⟧ (s.update' hat val) = (⟦ p ⟧ s).update' hat val :=
begin
    rw state.update',
    rw state.update',
    induction p generalizing s,
    case assign : b idxs expr {
        rw den,
        rw den,
        have hpub : uses (assign b idxs expr) b := begin
            rw uses,
            left,
            rw modifies,
            simp
        end,
        have hneq : ¬(b = a) := begin
            apply uses_neq sig (assign b idxs expr) b a,
            repeat { assumption }
        end,
        have hnrea : ¬expr_reads expr a := begin
            intro hrea,
            apply hnu,
            rw uses,
            right,
            exact hrea
        end,
        rw expr_uses_update_eliminate,
        repeat { exact hnrea },
        rw state_update_assoc,
        exact hneq,
    },
    case seq : p₁ p₂ ih₁ ih₂ {
        repeat { rw den },
        rw ih₁,
        {
            apply ih₂,
            apply uses_not_seq_right,
            exact hnu,
        }, {
            apply uses_not_seq_left,
            exact hnu,
        }
    },
    case loop : n h_n_is_int expr p ih {
        have hneq : ¬(n = a) := begin
            apply uses_neq _ (loop n h_n_is_int expr p),
            {
                apply uses_loop_condition,
            },
            assumption
        end,
        repeat { rw den },
        simp,
        repeat { rw state.update' },
        rw state_update_assoc,
        rw expr_uses_update_eliminate,
        generalize : (eval_expression s expr) = i,
        induction i,
        case nat.zero {
            rw nat.iterate,
            rw nat.iterate,
        },
        case nat.succ : i loop_ih {
            -- we must take of one loop, but it must the top one
            rw iterate_outer,
            rw loop_ih,
            rw ih,
            rw state.update',
            rw state_update_assoc,
            rw state.get',
            rw state_update_lookup_skip,
            --level the RHS
            rw iterate_outer,
            rw state.update',
            rw state.get',

            repeat {assumption},
            apply uses_not_loop_program,
            apply hnu,
        }, {
            --
            intro hrea,
            apply hnu,
            sorry, -- use cool new tactic
        }, {
            assumption
        }
    },
end

lemma loop_var {sig : signature} {l : string} (hli : sig l = int) (p : program sig) (n : ℕ) (s : state sig) (expr : expression sig int) (he : eval_expression s expr = n) :
    (⟦loop l hli expr p⟧ s).get' hli = n := begin
    rw den,
    rw he,
    clear he,
    induction n,
    case nat.zero {
        rw nat.iterate,
        rw state.update',
        rw state.get',
        rw state_update_lookup_success,
        sorry
    },
    case nat.succ : n ih {
        rw iterate_outer,
        rw state.get',
        rw [ih],
        rw state.update',
        rw state_update_lookup_success,
        simp[nat.add_succ],
        sorry,
    }
end

-- do we model for or foreach here?
lemma loop_seq (sig : signature) (l : string) (hli : sig l = int) (p : program sig) (n : ℕ) :
  ⟦ loop l hli i(n + 1) p ⟧ = ⟦ loop l hli i(n) p ;; p ;; assign l [] (const_int (n + 1) hli) ⟧ := begin
    funext s v,
    rw den,
    rw eval_const_int,
    rw iterate_outer,
    rw <- @eval_const_int sig s n,
    rw [<-den],
    rw [<-den],
    rw loop_var hli _ n _ _,
    simp,
    rw eval_const_int,
    rw [den],
    rw [den],
    rw [den],
    rw [den],
    rw [den],
    rw [den],
    rw eval_const_int,
    rw eval_const_int (1 + n),
    sorry
end

-- seq p1 p1 = loop n 2 p1
lemma loop_seq' (sig : signature) (s₁ : state sig) (v : string) (l : string) (hli : sig l = int)
        (p : program sig) (hnu : ¬(uses p l)) (hnv : ¬ (v = l)) :
        ⟦ p ;; p ⟧ s₁ v = ⟦ loop l hli i(2) p ⟧ s₁ v :=
begin
    rw den,
    rw eval_const_int,
    rw nat.iterate,
    rw nat.iterate,
    rw nat.iterate,
    rw den,
    rw state_eliminate_update' ,
    repeat { rw state_postpone_update' },
    repeat { rw state_eliminate_update' },
    repeat { assumption },
end

-- lemma : ⟦ assign a ; assign a ⟧ = ⟦ assign a ⟧

end MCL

-- todo: make sig a parameter
-- todo: introduce notation
-- todo: make signature implicit