/-
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 tactic.nth_rewrite
import data.matrix.basic
import data.equiv.ring_aut
import linear_algebra.tensor_product
import ring_theory.subring
import deprecated.subring
import algebra.opposites

/-!
# Algebra over Commutative Semiring

In this file we define `algebra`s over commutative (semi)rings, algebra homomorphisms `alg_hom`,
algebra equivalences `alg_equiv`. We also define usual operations on `alg_hom`s
(`id`, `comp`).

`subalgebra`s are defined in `algebra.algebra.subalgebra`.

If `S` is an `R`-algebra and `A` is an `S`-algebra then `algebra.comap.algebra R S A` can be used
to provide `A` with a structure of an `R`-algebra. Other than that, `algebra.comap` is now
deprecated and replaced with `is_scalar_tower`.

For the category of `R`-algebras, denoted `Algebra R`, see the file
`algebra/category/Algebra/basic.lean`.

## Notations

* `A →ₐ[R] B` : `R`-algebra homomorphism from `A` to `B`.
* `A ≃ₐ[R] B` : `R`-algebra equivalence from `A` to `B`.
-/

universes u v w u₁ v₁

open_locale tensor_product big_operators

section prio
-- We set this priority to 0 later in this file
set_option extends_priority 200 /- control priority of
`instance [algebra R A] : has_scalar R A` -/

/--
Given a commutative (semi)ring `R`, an `R`-algebra is a (possibly noncommutative)
(semi)ring `A` endowed with a morphism of rings `R →+* A` which lands in the
center of `A`.

For convenience, this typeclass extends `has_scalar R A` where the scalar action must
agree with left multiplication by the image of the structure morphism.

Given an `algebra R A` instance, the structure morphism `R →+* A` is denoted `algebra_map R A`.
-/
@[nolint has_inhabited_instance]
class algebra (R : Type u) (A : Type v) [comm_semiring R] [semiring A]
  extends has_scalar R A, R →+* A :=
(commutes' : ∀ r x, to_fun r * x = x * to_fun r)
(smul_def' : ∀ r x, r • x = to_fun r * x)
end prio

/-- Embedding `R →+* A` given by `algebra` structure. -/
def algebra_map (R : Type u) (A : Type v) [comm_semiring R] [semiring A] [algebra R A] : R →+* A :=
algebra.to_ring_hom

/-- Creating an algebra from a morphism to the center of a semiring. -/
def ring_hom.to_algebra' {R S} [comm_semiring R] [semiring S] (i : R →+* S)
  (h : ∀ c x, i c * x = x * i c) :
  algebra R S :=
{ smul := λ c x, i c * x,
  commutes' := h,
  smul_def' := λ c x, rfl,
  to_ring_hom := i}

/-- Creating an algebra from a morphism to a commutative semiring. -/
def ring_hom.to_algebra {R S} [comm_semiring R] [comm_semiring S] (i : R →+* S) :
  algebra R S :=
i.to_algebra' $ λ _, mul_comm _

lemma ring_hom.algebra_map_to_algebra {R S} [comm_semiring R] [comm_semiring S]
  (i : R →+* S) :
  @algebra_map R S _ _ i.to_algebra = i :=
rfl

namespace algebra

variables {R : Type u} {S : Type v} {A : Type w} {B : Type*}

/-- Let `R` be a commutative semiring, let `A` be a semiring with a `module R` structure.
If `(r • 1) * x = x * (r • 1) = r • x` for all `r : R` and `x : A`, then `A` is an `algebra`
over `R`. -/
def of_module' [comm_semiring R] [semiring A] [module R A]
  (h₁ : ∀ (r : R) (x : A), (r • 1) * x = r • x)
  (h₂ : ∀ (r : R) (x : A), x * (r • 1) = r • x) : algebra R A :=
{ to_fun := λ r, r • 1,
  map_one' := one_smul _ _,
  map_mul' := λ r₁ r₂, by rw [h₁, mul_smul],
  map_zero' := zero_smul _ _,
  map_add' := λ r₁ r₂, add_smul r₁ r₂ 1,
  commutes' := λ r x, by simp only [h₁, h₂],
  smul_def' := λ r x, by simp only [h₁] }

/-- Let `R` be a commutative semiring, let `A` be a semiring with a `module R` structure.
If `(r • x) * y = x * (r • y) = r • (x * y)` for all `r : R` and `x y : A`, then `A`
is an `algebra` over `R`. -/
def of_module [comm_semiring R] [semiring A] [module R A]
  (h₁ : ∀ (r : R) (x y : A), (r • x) * y = r • (x * y))
  (h₂ : ∀ (r : R) (x y : A), x * (r • y) = r • (x * y)) : algebra R A :=
of_module' (λ r x, by rw [h₁, one_mul]) (λ r x, by rw [h₂, mul_one])

section semiring

variables [comm_semiring R] [comm_semiring S]
variables [semiring A] [algebra R A] [semiring B] [algebra R B]

lemma smul_def'' (r : R) (x : A) : r • x = algebra_map R A r * x :=
algebra.smul_def' r x

/--
To prove two algebra structures on a fixed `[comm_semiring R] [semiring A]` agree,
it suffices to check the `algebra_map`s agree.
-/
-- We'll later use this to show `algebra ℤ M` is a subsingleton.
@[ext]
lemma algebra_ext {R : Type*} [comm_semiring R] {A : Type*} [semiring A] (P Q : algebra R A)
  (w : ∀ (r : R), by { haveI := P, exact algebra_map R A r } =
    by { haveI := Q, exact algebra_map R A r }) :
  P = Q :=
begin
  unfreezingI { rcases P with ⟨⟨P⟩⟩, rcases Q with ⟨⟨Q⟩⟩ },
  congr,
  { funext r a,
    replace w := congr_arg (λ s, s * a) (w r),
    simp only [←algebra.smul_def''] at w,
    apply w, },
  { ext r,
    exact w r, },
  { apply proof_irrel_heq, },
  { apply proof_irrel_heq, },
end

@[priority 200] -- see Note [lower instance priority]
instance to_module : module R A :=
{ one_smul := by simp [smul_def''],
  mul_smul := by simp [smul_def'', mul_assoc],
  smul_add := by simp [smul_def'', mul_add],
  smul_zero := by simp [smul_def''],
  add_smul := by simp [smul_def'', add_mul],
  zero_smul := by simp [smul_def''] }

-- from now on, we don't want to use the following instance anymore
attribute [instance, priority 0] algebra.to_has_scalar

lemma smul_def (r : R) (x : A) : r • x = algebra_map R A r * x :=
algebra.smul_def' r x

lemma algebra_map_eq_smul_one (r : R) : algebra_map R A r = r • 1 :=
calc algebra_map R A r = algebra_map R A r * 1 : (mul_one _).symm
                   ... = r • 1                 : (algebra.smul_def r 1).symm

lemma algebra_map_eq_smul_one' : ⇑(algebra_map R A) = λ r, r • (1 : A) :=
funext algebra_map_eq_smul_one

theorem commutes (r : R) (x : A) : algebra_map R A r * x = x * algebra_map R A r :=
algebra.commutes' r x

theorem left_comm (r : R) (x y : A) : x * (algebra_map R A r * y) = algebra_map R A r * (x * y) :=
by rw [← mul_assoc, ← commutes, mul_assoc]

@[simp] lemma mul_smul_comm (s : R) (x y : A) :
  x * (s • y) = s • (x * y) :=
by rw [smul_def, smul_def, left_comm]

@[simp] lemma smul_mul_assoc (r : R) (x y : A) :
  (r • x) * y = r • (x * y) :=
by rw [smul_def, smul_def, mul_assoc]

lemma smul_mul_smul (r s : R) (x y : A) :
  (r • x) * (s • y) = (r * s) • (x * y) :=
by rw [algebra.smul_mul_assoc, algebra.mul_smul_comm, smul_smul]

section
variables {r : R} {a : A}

@[simp] lemma bit0_smul_one : bit0 r • (1 : A) = r • 2 :=
by simp [bit0, add_smul, smul_add]
@[simp] lemma bit0_smul_bit0 : bit0 r • bit0 a = r • (bit0 (bit0 a)) :=
by simp [bit0, add_smul, smul_add]
@[simp] lemma bit0_smul_bit1 : bit0 r • bit1 a = r • (bit0 (bit1 a)) :=
by simp [bit0, add_smul, smul_add]
@[simp] lemma bit1_smul_one : bit1 r • (1 : A) = r • 2 + 1 :=
by simp [bit1, add_smul, smul_add]
@[simp] lemma bit1_smul_bit0 : bit1 r • bit0 a = r • (bit0 (bit0 a)) + bit0 a :=
by simp [bit1, add_smul, smul_add]
@[simp] lemma bit1_smul_bit1 : bit1 r • bit1 a = r • (bit0 (bit1 a)) + bit1 a :=
by { simp only [bit0, bit1, add_smul, smul_add, one_smul], abel }

end

variables (R A)

/--
The canonical ring homomorphism `algebra_map R A : R →* A` for any `R`-algebra `A`,
packaged as an `R`-linear map.
-/
protected def linear_map : R →ₗ[R] A :=
{ map_smul' := λ x y, by simp [algebra.smul_def],
  ..algebra_map R A }

@[simp]
lemma linear_map_apply (r : R) : algebra.linear_map R A r = algebra_map R A r := rfl

instance id : algebra R R := (ring_hom.id R).to_algebra

variables {R A}

namespace id

@[simp] lemma map_eq_self (x : R) : algebra_map R R x = x := rfl

@[simp] lemma smul_eq_mul (x y : R) : x • y = x * y := rfl

end id

section prod
variables (R A B)

instance : algebra R (A × B) :=
{ commutes' := by { rintro r ⟨a, b⟩, dsimp, rw [commutes r a, commutes r b] },
  smul_def' := by { rintro r ⟨a, b⟩, dsimp, rw [smul_def r a, smul_def r b] },
  .. prod.module,
  .. ring_hom.prod (algebra_map R A) (algebra_map R B) }

variables {R A B}

@[simp] lemma algebra_map_prod_apply (r : R) :
  algebra_map R (A × B) r = (algebra_map R A r, algebra_map R B r) := rfl

end prod

/-- Algebra over a subsemiring. -/
instance of_subsemiring (S : subsemiring R) : algebra S A :=
{ smul := λ s x, (s : R) • x,
  commutes' := λ r x, algebra.commutes r x,
  smul_def' := λ r x, algebra.smul_def r x,
  .. (algebra_map R A).comp (subsemiring.subtype S) }

/-- Algebra over a subring. -/
instance of_subring {R A : Type*} [comm_ring R] [ring A] [algebra R A]
  (S : subring R) : algebra S A :=
{ smul := λ s x, (s : R) • x,
  commutes' := λ r x, algebra.commutes r x,
  smul_def' := λ r x, algebra.smul_def r x,
  .. (algebra_map R A).comp (subring.subtype S) }

lemma algebra_map_of_subring {R : Type*} [comm_ring R] (S : subring R) :
  (algebra_map S R : S →+* R) = subring.subtype S := rfl

lemma coe_algebra_map_of_subring {R : Type*} [comm_ring R] (S : subring R) :
  (algebra_map S R : S → R) = subtype.val := rfl

lemma algebra_map_of_subring_apply {R : Type*} [comm_ring R] (S : subring R) (x : S) :
  algebra_map S R x = x := rfl

section
local attribute [instance] subset.comm_ring

/-- Algebra over a set that is closed under the ring operations. -/
local attribute [instance]
def of_is_subring {R A : Type*} [comm_ring R] [ring A] [algebra R A]
  (S : set R) [is_subring S] : algebra S A :=
algebra.of_subring S.to_subring

lemma is_subring_coe_algebra_map_hom {R : Type*} [comm_ring R] (S : set R) [is_subring S] :
  (algebra_map S R : S →+* R) = is_subring.subtype S := rfl

lemma is_subring_coe_algebra_map {R : Type*} [comm_ring R] (S : set R) [is_subring S] :
  (algebra_map S R : S → R) = subtype.val := rfl

lemma is_subring_algebra_map_apply {R : Type*} [comm_ring R] (S : set R) [is_subring S] (x : S) :
  algebra_map S R x = x := rfl

lemma set_range_subset {R : Type*} [comm_ring R] {T₁ T₂ : set R} [is_subring T₁] (hyp : T₁ ⊆ T₂) :
  set.range (algebra_map T₁ R) ⊆ T₂ :=
begin
  rintros x ⟨⟨t, ht⟩, rfl⟩,
  exact hyp ht,
end

end

/-- Explicit characterization of the submonoid map in the case of an algebra.
`S` is made explicit to help with type inference -/
def algebra_map_submonoid (S : Type*) [semiring S] [algebra R S]
  (M : submonoid R) : (submonoid S) :=
submonoid.map (algebra_map R S : R →* S) M

lemma mem_algebra_map_submonoid_of_mem [algebra R S] {M : submonoid R} (x : M) :
  (algebra_map R S x) ∈ algebra_map_submonoid S M :=
set.mem_image_of_mem (algebra_map R S) x.2

end semiring

section ring
variables [comm_ring R]

variables (R)

/-- A `semiring` that is an `algebra` over a commutative ring carries a natural `ring` structure. -/
def semiring_to_ring [semiring A] [algebra R A] : ring A := {
  ..module.add_comm_monoid_to_add_comm_group R,
  ..(infer_instance : semiring A) }

variables {R}

lemma mul_sub_algebra_map_commutes [ring A] [algebra R A] (x : A) (r : R) :
  x * (x - algebra_map R A r) = (x - algebra_map R A r) * x :=
by rw [mul_sub, ←commutes, sub_mul]

lemma mul_sub_algebra_map_pow_commutes [ring A] [algebra R A] (x : A) (r : R) (n : ℕ) :
  x * (x - algebra_map R A r) ^ n = (x - algebra_map R A r) ^ n * x :=
begin
  induction n with n ih,
  { simp },
  { rw [pow_succ, ←mul_assoc, mul_sub_algebra_map_commutes,
      mul_assoc, ih, ←mul_assoc], }
end

/-- If `algebra_map R A` is injective and `A` has no zero divisors,
`R`-multiples in `A` are zero only if one of the factors is zero.

Cannot be an instance because there is no `injective (algebra_map R A)` typeclass.
-/
lemma no_zero_smul_divisors.of_algebra_map_injective
  [semiring A] [algebra R A] [no_zero_divisors A]
  (h : function.injective (algebra_map R A)) : no_zero_smul_divisors R A :=
⟨λ c x hcx, (mul_eq_zero.mp ((smul_def c x).symm.trans hcx)).imp_left
  ((algebra_map R A).injective_iff.mp h _)⟩

end ring

section field

variables [field R] [semiring A] [algebra R A]

@[priority 100] -- see note [lower instance priority]
instance [nontrivial A] [no_zero_divisors A] : no_zero_smul_divisors R A :=
no_zero_smul_divisors.of_algebra_map_injective (algebra_map R A).injective

end field

end algebra

namespace opposite

variables {R A : Type*} [comm_semiring R] [semiring A] [algebra R A]

instance : algebra R Aᵒᵖ :=
{ to_ring_hom := (algebra_map R A).to_opposite $ λ x y, algebra.commutes _ _,
  smul_def' := λ c x, unop_injective $
    by { dsimp, simp only [op_mul, algebra.smul_def, algebra.commutes, op_unop] },
  commutes' := λ r, op_induction $ λ x, by dsimp; simp only [← op_mul, algebra.commutes],
  ..opposite.has_scalar A R }

@[simp] lemma algebra_map_apply (c : R) : algebra_map R Aᵒᵖ c = op (algebra_map R A c) := rfl

end opposite

namespace module
variables (R : Type u) (M : Type v) [comm_semiring R] [add_comm_monoid M] [module R M]

instance endomorphism_algebra : algebra R (M →ₗ[R] M) :=
{ to_fun    := λ r, r • linear_map.id,
  map_one' := one_smul _ _,
  map_zero' := zero_smul _ _,
  map_add' := λ r₁ r₂, add_smul _ _ _,
  map_mul' := λ r₁ r₂, by { ext x, simp [mul_smul] },
  commutes' := by { intros, ext, simp },
  smul_def' := by { intros, ext, simp } }

lemma algebra_map_End_eq_smul_id (a : R) :
  (algebra_map R (End R M)) a = a • linear_map.id := rfl

@[simp] lemma algebra_map_End_apply (a : R) (m : M) :
  (algebra_map R (End R M)) a m = a • m := rfl

@[simp] lemma ker_algebra_map_End (K : Type u) (V : Type v)
  [field K] [add_comm_group V] [module K V] (a : K) (ha : a ≠ 0) :
  ((algebra_map K (End K V)) a).ker = ⊥ :=
linear_map.ker_smul _ _ ha

end module

instance matrix_algebra (n : Type u) (R : Type v)
  [decidable_eq n] [fintype n] [comm_semiring R] : algebra R (matrix n n R) :=
{ commutes' := by { intros, simp [matrix.scalar], },
  smul_def' := by { intros, simp [matrix.scalar], },
  ..(matrix.scalar n) }

@[simp] lemma matrix.algebra_map_eq_smul (n : Type u) {R : Type v} [decidable_eq n] [fintype n]
  [comm_semiring R] (r : R) : (algebra_map R (matrix n n R)) r = r • 1 := rfl

set_option old_structure_cmd true
/-- Defining the homomorphism in the category R-Alg. -/
@[nolint has_inhabited_instance]
structure alg_hom (R : Type u) (A : Type v) (B : Type w)
  [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B] extends ring_hom A B :=
(commutes' : ∀ r : R, to_fun (algebra_map R A r) = algebra_map R B r)

run_cmd tactic.add_doc_string `alg_hom.to_ring_hom "Reinterpret an `alg_hom` as a `ring_hom`"

infixr ` →ₐ `:25 := alg_hom _
notation A ` →ₐ[`:25 R `] ` B := alg_hom R A B

namespace alg_hom

variables {R : Type u} {A : Type v} {B : Type w} {C : Type u₁} {D : Type v₁}

section semiring

variables [comm_semiring R] [semiring A] [semiring B] [semiring C] [semiring D]
variables [algebra R A] [algebra R B] [algebra R C] [algebra R D]

instance : has_coe_to_fun (A →ₐ[R] B) := ⟨_, λ f, f.to_fun⟩

initialize_simps_projections alg_hom (to_fun → apply)

@[simp] lemma to_fun_eq_coe (f : A →ₐ[R] B) : f.to_fun = f := rfl

instance coe_ring_hom : has_coe (A →ₐ[R] B) (A →+* B) := ⟨alg_hom.to_ring_hom⟩

instance coe_monoid_hom : has_coe (A →ₐ[R] B) (A →* B) := ⟨λ f, ↑(f : A →+* B)⟩

instance coe_add_monoid_hom : has_coe (A →ₐ[R] B) (A →+ B) := ⟨λ f, ↑(f : A →+* B)⟩

@[simp, norm_cast] lemma coe_mk {f : A → B} (h₁ h₂ h₃ h₄ h₅) :
  ⇑(⟨f, h₁, h₂, h₃, h₄, h₅⟩ : A →ₐ[R] B) = f := rfl

@[simp, norm_cast] lemma coe_to_ring_hom (f : A →ₐ[R] B) : ⇑(f : A →+* B) = f := rfl

-- as `simp` can already prove this lemma, it is not tagged with the `simp` attribute.
@[norm_cast] lemma coe_to_monoid_hom (f : A →ₐ[R] B) : ⇑(f : A →* B) = f := rfl

-- as `simp` can already prove this lemma, it is not tagged with the `simp` attribute.
@[norm_cast] lemma coe_to_add_monoid_hom (f : A →ₐ[R] B) : ⇑(f : A →+ B) = f := rfl

variables (φ : A →ₐ[R] B)

theorem coe_fn_inj ⦃φ₁ φ₂ : A →ₐ[R] B⦄ (H : ⇑φ₁ = φ₂) : φ₁ = φ₂ :=
by { cases φ₁, cases φ₂, congr, exact H }

theorem coe_ring_hom_injective : function.injective (coe : (A →ₐ[R] B) → (A →+* B)) :=
λ φ₁ φ₂ H, coe_fn_inj $ show ((φ₁ : (A →+* B)) : A → B) = ((φ₂ : (A →+* B)) : A → B),
  from congr_arg _ H

theorem coe_monoid_hom_injective : function.injective (coe : (A →ₐ[R] B)  → (A →* B)) :=
ring_hom.coe_monoid_hom_injective.comp coe_ring_hom_injective

theorem coe_add_monoid_hom_injective : function.injective (coe : (A →ₐ[R] B)  → (A →+ B)) :=
ring_hom.coe_add_monoid_hom_injective.comp coe_ring_hom_injective

protected lemma congr_fun {φ₁ φ₂ : A →ₐ[R] B} (H : φ₁ = φ₂) (x : A) : φ₁ x = φ₂ x := H ▸ rfl
protected lemma congr_arg (φ : A →ₐ[R] B) {x y : A} (h : x = y) : φ x = φ y := h ▸ rfl

@[ext]
theorem ext {φ₁ φ₂ : A →ₐ[R] B} (H : ∀ x, φ₁ x = φ₂ x) : φ₁ = φ₂ :=
coe_fn_inj $ funext H

theorem ext_iff {φ₁ φ₂ : A →ₐ[R] B} : φ₁ = φ₂ ↔ ∀ x, φ₁ x = φ₂ x :=
⟨alg_hom.congr_fun, ext⟩

@[simp] theorem mk_coe {f : A →ₐ[R] B} (h₁ h₂ h₃ h₄ h₅) :
  (⟨f, h₁, h₂, h₃, h₄, h₅⟩ : A →ₐ[R] B) = f := ext $ λ _, rfl

@[simp]
theorem commutes (r : R) : φ (algebra_map R A r) = algebra_map R B r := φ.commutes' r

theorem comp_algebra_map : (φ : A →+* B).comp (algebra_map R A) = algebra_map R B :=
ring_hom.ext $ φ.commutes

@[simp] lemma map_add (r s : A) : φ (r + s) = φ r + φ s :=
φ.to_ring_hom.map_add r s

@[simp] lemma map_zero : φ 0 = 0 :=
φ.to_ring_hom.map_zero

@[simp] lemma map_mul (x y) : φ (x * y) = φ x * φ y :=
φ.to_ring_hom.map_mul x y

@[simp] lemma map_one : φ 1 = 1 :=
φ.to_ring_hom.map_one

@[simp] lemma map_smul (r : R) (x : A) : φ (r • x) = r • φ x :=
by simp only [algebra.smul_def, map_mul, commutes]

@[simp] lemma map_pow (x : A) (n : ℕ) : φ (x ^ n) = (φ x) ^ n :=
φ.to_ring_hom.map_pow x n

lemma map_sum {ι : Type*} (f : ι → A) (s : finset ι) :
  φ (∑ x in s, f x) = ∑ x in s, φ (f x) :=
φ.to_ring_hom.map_sum f s

lemma map_finsupp_sum {α : Type*} [has_zero α] {ι : Type*} (f : ι →₀ α) (g : ι → α → A) :
  φ (f.sum g) = f.sum (λ i a, φ (g i a)) :=
φ.map_sum _ _

@[simp] lemma map_nat_cast (n : ℕ) : φ n = n :=
φ.to_ring_hom.map_nat_cast n

@[simp] lemma map_bit0 (x) : φ (bit0 x) = bit0 (φ x) :=
φ.to_ring_hom.map_bit0 x

@[simp] lemma map_bit1 (x) : φ (bit1 x) = bit1 (φ x) :=
φ.to_ring_hom.map_bit1 x

/-- If a `ring_hom` is `R`-linear, then it is an `alg_hom`. -/
def mk' (f : A →+* B) (h : ∀ (c : R) x, f (c • x) = c • f x) : A →ₐ[R] B :=
{ to_fun := f,
  commutes' := λ c, by simp only [algebra.algebra_map_eq_smul_one, h, f.map_one],
  .. f }

@[simp] lemma coe_mk' (f : A →+* B) (h : ∀ (c : R) x, f (c • x) = c • f x) : ⇑(mk' f h) = f := rfl

section

variables (R A)
/-- Identity map as an `alg_hom`. -/
protected def id : A →ₐ[R] A :=
{ commutes' := λ _, rfl,
  ..ring_hom.id A  }

@[simp] lemma coe_id : ⇑(alg_hom.id R A) = id := rfl

@[simp] lemma id_to_ring_hom : (alg_hom.id R A : A →+* A) = ring_hom.id _ := rfl

end

lemma id_apply (p : A) : alg_hom.id R A p = p := rfl

/-- Composition of algebra homeomorphisms. -/
def comp (φ₁ : B →ₐ[R] C) (φ₂ : A →ₐ[R] B) : A →ₐ[R] C :=
{ commutes' := λ r : R, by rw [← φ₁.commutes, ← φ₂.commutes]; refl,
  .. φ₁.to_ring_hom.comp ↑φ₂ }

@[simp] lemma coe_comp (φ₁ : B →ₐ[R] C) (φ₂ : A →ₐ[R] B) : ⇑(φ₁.comp φ₂) = φ₁ ∘ φ₂ := rfl

lemma comp_apply (φ₁ : B →ₐ[R] C) (φ₂ : A →ₐ[R] B) (p : A) : φ₁.comp φ₂ p = φ₁ (φ₂ p) := rfl

lemma comp_to_ring_hom (φ₁ : B →ₐ[R] C) (φ₂ : A →ₐ[R] B) :
  ⇑(φ₁.comp φ₂ : A →+* C) = (φ₁ : B →+* C).comp ↑φ₂ := rfl

@[simp] theorem comp_id : φ.comp (alg_hom.id R A) = φ :=
ext $ λ x, rfl

@[simp] theorem id_comp : (alg_hom.id R B).comp φ = φ :=
ext $ λ x, rfl

theorem comp_assoc (φ₁ : C →ₐ[R] D) (φ₂ : B →ₐ[R] C) (φ₃ : A →ₐ[R] B) :
  (φ₁.comp φ₂).comp φ₃ = φ₁.comp (φ₂.comp φ₃) :=
ext $ λ x, rfl

/-- R-Alg ⥤ R-Mod -/
def to_linear_map : A →ₗ B :=
{ to_fun := φ,
  map_add' := φ.map_add,
  map_smul' := φ.map_smul }

@[simp] lemma to_linear_map_apply (p : A) : φ.to_linear_map p = φ p := rfl

theorem to_linear_map_inj {φ₁ φ₂ : A →ₐ[R] B} (H : φ₁.to_linear_map = φ₂.to_linear_map) : φ₁ = φ₂ :=
ext $ λ x, show φ₁.to_linear_map x = φ₂.to_linear_map x, by rw H

@[simp] lemma comp_to_linear_map (f : A →ₐ[R] B) (g : B →ₐ[R] C) :
  (g.comp f).to_linear_map = g.to_linear_map.comp f.to_linear_map := rfl

lemma map_list_prod (s : list A) :
  φ s.prod = (s.map φ).prod :=
φ.to_ring_hom.map_list_prod s

end semiring

section comm_semiring

variables [comm_semiring R] [comm_semiring A] [comm_semiring B]
variables [algebra R A] [algebra R B] (φ : A →ₐ[R] B)

lemma map_multiset_prod (s : multiset A) :
  φ s.prod = (s.map φ).prod :=
φ.to_ring_hom.map_multiset_prod s

lemma map_prod {ι : Type*} (f : ι → A) (s : finset ι) :
  φ (∏ x in s, f x) = ∏ x in s, φ (f x) :=
φ.to_ring_hom.map_prod f s

lemma map_finsupp_prod {α : Type*} [has_zero α] {ι : Type*} (f : ι →₀ α) (g : ι → α → A) :
  φ (f.prod g) = f.prod (λ i a, φ (g i a)) :=
φ.map_prod _ _

end comm_semiring

section ring

variables [comm_semiring R] [ring A] [ring B]
variables [algebra R A] [algebra R B] (φ : A →ₐ[R] B)

@[simp] lemma map_neg (x) : φ (-x) = -φ x :=
φ.to_ring_hom.map_neg x

@[simp] lemma map_sub (x y) : φ (x - y) = φ x - φ y :=
φ.to_ring_hom.map_sub x y

@[simp] lemma map_int_cast (n : ℤ) : φ n = n :=
φ.to_ring_hom.map_int_cast n

end ring

section division_ring

variables [comm_ring R] [division_ring A] [division_ring B]
variables [algebra R A] [algebra R B] (φ : A →ₐ[R] B)

@[simp] lemma map_inv (x) : φ (x⁻¹) = (φ x)⁻¹ :=
φ.to_ring_hom.map_inv x

@[simp] lemma map_div (x y) : φ (x / y) = φ x / φ y :=
φ.to_ring_hom.map_div x y

end division_ring

theorem injective_iff {R A B : Type*} [comm_semiring R] [ring A] [semiring B]
  [algebra R A] [algebra R B] (f : A →ₐ[R] B) :
  function.injective f ↔ (∀ x, f x = 0 → x = 0) :=
ring_hom.injective_iff (f : A →+* B)

end alg_hom

@[simp] lemma rat.smul_one_eq_coe {A : Type*} [division_ring A] [algebra ℚ A] (m : ℚ) :
  m • (1 : A) = ↑m :=
by rw [algebra.smul_def, mul_one, ring_hom.eq_rat_cast]

set_option old_structure_cmd true
/-- An equivalence of algebras is an equivalence of rings commuting with the actions of scalars. -/
structure alg_equiv (R : Type u) (A : Type v) (B : Type w)
  [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B]
  extends A ≃ B, A ≃* B, A ≃+ B, A ≃+* B :=
(commutes' : ∀ r : R, to_fun (algebra_map R A r) = algebra_map R B r)

attribute [nolint doc_blame] alg_equiv.to_ring_equiv
attribute [nolint doc_blame] alg_equiv.to_equiv
attribute [nolint doc_blame] alg_equiv.to_add_equiv
attribute [nolint doc_blame] alg_equiv.to_mul_equiv

notation A ` ≃ₐ[`:50 R `] ` A' := alg_equiv R A A'

namespace alg_equiv

variables {R : Type u} {A₁ : Type v} {A₂ : Type w} {A₃ : Type u₁}

section semiring

variables [comm_semiring R] [semiring A₁] [semiring A₂] [semiring A₃]
variables [algebra R A₁] [algebra R A₂] [algebra R A₃]
variables (e : A₁ ≃ₐ[R] A₂)

instance : has_coe_to_fun (A₁ ≃ₐ[R] A₂) := ⟨_, alg_equiv.to_fun⟩

@[ext]
lemma ext {f g : A₁ ≃ₐ[R] A₂} (h : ∀ a, f a = g a) : f = g :=
begin
  have h₁ : f.to_equiv = g.to_equiv := equiv.ext h,
  cases f, cases g, congr,
  { exact (funext h) },
  { exact congr_arg equiv.inv_fun h₁ }
end

protected lemma congr_arg {f : A₁ ≃ₐ[R] A₂} : Π {x x' : A₁}, x = x' → f x = f x'
| _ _ rfl := rfl

protected lemma congr_fun {f g : A₁ ≃ₐ[R] A₂} (h : f = g) (x : A₁) : f x = g x := h ▸ rfl

lemma ext_iff {f g : A₁ ≃ₐ[R] A₂} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, ext⟩

lemma coe_fun_injective : @function.injective (A₁ ≃ₐ[R] A₂) (A₁ → A₂) (λ e, (e : A₁ → A₂)) :=
begin
  intros f g w,
  ext,
  exact congr_fun w a,
end

instance has_coe_to_ring_equiv : has_coe (A₁ ≃ₐ[R] A₂) (A₁ ≃+* A₂) := ⟨alg_equiv.to_ring_equiv⟩

@[simp] lemma coe_mk {to_fun inv_fun left_inv right_inv map_mul map_add commutes} :
  ⇑(⟨to_fun, inv_fun, left_inv, right_inv, map_mul, map_add, commutes⟩ : A₁ ≃ₐ[R] A₂) = to_fun :=
rfl

@[simp] theorem mk_coe (e : A₁ ≃ₐ[R] A₂) (e' h₁ h₂ h₃ h₄ h₅) :
  (⟨e, e', h₁, h₂, h₃, h₄, h₅⟩ : A₁ ≃ₐ[R] A₂) = e := ext $ λ _, rfl

@[simp] lemma to_fun_eq_coe (e : A₁ ≃ₐ[R] A₂) : e.to_fun = e := rfl

-- TODO: decide on a simp-normal form so that only one of these two lemmas is needed
@[simp, norm_cast] lemma coe_ring_equiv : ((e : A₁ ≃+* A₂) : A₁ → A₂) = e := rfl
@[simp] lemma coe_ring_equiv' : (e.to_ring_equiv : A₁ → A₂) = e := rfl

lemma coe_ring_equiv_injective : function.injective (λ e : A₁ ≃ₐ[R] A₂, (e : A₁ ≃+* A₂)) :=
begin
  intros f g w,
  ext,
  replace w : ((f : A₁ ≃+* A₂) : A₁ → A₂) = ((g : A₁ ≃+* A₂) : A₁ → A₂) :=
    congr_arg (λ e : A₁ ≃+* A₂, (e : A₁ → A₂)) w,
  exact congr_fun w a,
end

@[simp] lemma map_add : ∀ x y, e (x + y) = e x + e y := e.to_add_equiv.map_add

@[simp] lemma map_zero : e 0 = 0 := e.to_add_equiv.map_zero

@[simp] lemma map_mul : ∀ x y, e (x * y) = (e x) * (e y) := e.to_mul_equiv.map_mul

@[simp] lemma map_one : e 1 = 1 := e.to_mul_equiv.map_one

@[simp] lemma commutes : ∀ (r : R), e (algebra_map R A₁ r) = algebra_map R A₂ r :=
  e.commutes'

lemma map_sum {ι : Type*} (f : ι → A₁) (s : finset ι) :
  e (∑ x in s, f x) = ∑ x in s, e (f x) :=
e.to_add_equiv.map_sum f s

lemma map_finsupp_sum {α : Type*} [has_zero α] {ι : Type*} (f : ι →₀ α) (g : ι → α → A₁) :
  e (f.sum g) = f.sum (λ i b, e (g i b)) :=
e.map_sum _ _

/-- Interpret an algebra equivalence as an algebra homomorphism.

This definition is included for symmetry with the other `to_*_hom` projections.
The `simp` normal form is to use the coercion of the `has_coe_to_alg_hom` instance. -/
def to_alg_hom : A₁ →ₐ[R] A₂ :=
{ map_one' := e.map_one, map_zero' := e.map_zero, ..e }

instance has_coe_to_alg_hom : has_coe (A₁ ≃ₐ[R] A₂) (A₁ →ₐ[R] A₂) :=
⟨to_alg_hom⟩

@[simp] lemma to_alg_hom_eq_coe : e.to_alg_hom = e := rfl

@[simp, norm_cast] lemma coe_alg_hom : ((e : A₁ →ₐ[R] A₂) : A₁ → A₂) = e :=
rfl

/-- The two paths coercion can take to a `ring_hom` are equivalent -/
lemma coe_ring_hom_commutes : ((e : A₁ →ₐ[R] A₂) : A₁ →+* A₂) = ((e : A₁ ≃+* A₂) : A₁ →+* A₂) :=
rfl

@[simp] lemma map_pow : ∀ (x : A₁) (n : ℕ), e (x ^ n) = (e x) ^ n := e.to_alg_hom.map_pow

lemma injective : function.injective e := e.to_equiv.injective

lemma surjective : function.surjective e := e.to_equiv.surjective

lemma bijective : function.bijective e := e.to_equiv.bijective

instance : has_one (A₁ ≃ₐ[R] A₁) := ⟨{commutes' := λ r, rfl, ..(1 : A₁ ≃+* A₁)}⟩

instance : inhabited (A₁ ≃ₐ[R] A₁) := ⟨1⟩

/-- Algebra equivalences are reflexive. -/
@[refl]
def refl : A₁ ≃ₐ[R] A₁ := 1

@[simp] lemma refl_to_alg_hom : ↑(refl : A₁ ≃ₐ[R] A₁) = alg_hom.id R A₁ := rfl

@[simp] lemma coe_refl : ⇑(refl : A₁ ≃ₐ[R] A₁) = id := rfl

/-- Algebra equivalences are symmetric. -/
@[symm]
def symm (e : A₁ ≃ₐ[R] A₂) : A₂ ≃ₐ[R] A₁ :=
{ commutes' := λ r, by { rw ←e.to_ring_equiv.symm_apply_apply (algebra_map R A₁ r), congr,
                         change _ = e _, rw e.commutes, },
  ..e.to_ring_equiv.symm, }

/-- See Note [custom simps projection] -/
def simps.symm_apply (e : A₁ ≃ₐ[R] A₂) : A₂ → A₁ := e.symm

initialize_simps_projections alg_equiv (to_fun → apply, inv_fun → symm_apply)

@[simp] lemma inv_fun_eq_symm {e : A₁ ≃ₐ[R] A₂} : e.inv_fun = e.symm := rfl

@[simp] lemma symm_symm (e : A₁ ≃ₐ[R] A₂) : e.symm.symm = e :=
by { ext, refl, }

lemma symm_bijective : function.bijective (symm : (A₁ ≃ₐ[R] A₂) → (A₂ ≃ₐ[R] A₁)) :=
equiv.bijective ⟨symm, symm, symm_symm, symm_symm⟩

@[simp] lemma mk_coe' (e : A₁ ≃ₐ[R] A₂) (f h₁ h₂ h₃ h₄ h₅) :
  (⟨f, e, h₁, h₂, h₃, h₄, h₅⟩ : A₂ ≃ₐ[R] A₁) = e.symm :=
symm_bijective.injective $ ext $ λ x, rfl

@[simp] theorem symm_mk (f f') (h₁ h₂ h₃ h₄ h₅) :
  (⟨f, f', h₁, h₂, h₃, h₄, h₅⟩ : A₁ ≃ₐ[R] A₂).symm =
  { to_fun := f', inv_fun := f,
    ..(⟨f, f', h₁, h₂, h₃, h₄, h₅⟩ : A₁ ≃ₐ[R] A₂).symm } := rfl

/-- Algebra equivalences are transitive. -/
@[trans]
def trans (e₁ : A₁ ≃ₐ[R] A₂) (e₂ : A₂ ≃ₐ[R] A₃) : A₁ ≃ₐ[R] A₃ :=
{ commutes' := λ r, show e₂.to_fun (e₁.to_fun _) = _, by rw [e₁.commutes', e₂.commutes'],
  ..(e₁.to_ring_equiv.trans e₂.to_ring_equiv), }

@[simp] lemma apply_symm_apply (e : A₁ ≃ₐ[R] A₂) : ∀ x, e (e.symm x) = x :=
  e.to_equiv.apply_symm_apply

@[simp] lemma symm_apply_apply (e : A₁ ≃ₐ[R] A₂) : ∀ x, e.symm (e x) = x :=
  e.to_equiv.symm_apply_apply

@[simp] lemma coe_trans (e₁ : A₁ ≃ₐ[R] A₂) (e₂ : A₂ ≃ₐ[R] A₃) :
  ⇑(e₁.trans e₂) = e₂ ∘ e₁ := rfl

lemma trans_apply (e₁ : A₁ ≃ₐ[R] A₂) (e₂ : A₂ ≃ₐ[R] A₃) (x : A₁) :
  (e₁.trans e₂) x = e₂ (e₁ x) := rfl

@[simp] lemma comp_symm (e : A₁ ≃ₐ[R] A₂) :
  alg_hom.comp (e : A₁ →ₐ[R] A₂) ↑e.symm = alg_hom.id R A₂ :=
by { ext, simp }

@[simp] lemma symm_comp (e : A₁ ≃ₐ[R] A₂) :
  alg_hom.comp ↑e.symm (e : A₁ →ₐ[R] A₂) = alg_hom.id R A₁ :=
by { ext, simp }

theorem left_inverse_symm (e : A₁ ≃ₐ[R] A₂) : function.left_inverse e.symm e := e.left_inv

theorem right_inverse_symm (e : A₁ ≃ₐ[R] A₂) : function.right_inverse e.symm e := e.right_inv

/-- If `A₁` is equivalent to `A₁'` and `A₂` is equivalent to `A₂'`, then the type of maps
`A₁ →ₐ[R] A₂` is equivalent to the type of maps `A₁' →ₐ[R] A₂'`. -/
def arrow_congr {A₁' A₂' : Type*} [semiring A₁'] [semiring A₂'] [algebra R A₁'] [algebra R A₂']
  (e₁ : A₁ ≃ₐ[R] A₁') (e₂ : A₂ ≃ₐ[R] A₂') : (A₁ →ₐ[R] A₂) ≃ (A₁' →ₐ[R] A₂') :=
{ to_fun := λ f, (e₂.to_alg_hom.comp f).comp e₁.symm.to_alg_hom,
  inv_fun := λ f, (e₂.symm.to_alg_hom.comp f).comp e₁.to_alg_hom,
  left_inv := λ f, by { simp only [alg_hom.comp_assoc, to_alg_hom_eq_coe, symm_comp],
    simp only [←alg_hom.comp_assoc, symm_comp, alg_hom.id_comp, alg_hom.comp_id] },
  right_inv := λ f, by { simp only [alg_hom.comp_assoc, to_alg_hom_eq_coe, comp_symm],
    simp only [←alg_hom.comp_assoc, comp_symm, alg_hom.id_comp, alg_hom.comp_id] } }

lemma arrow_congr_comp {A₁' A₂' A₃' : Type*} [semiring A₁'] [semiring A₂'] [semiring A₃']
  [algebra R A₁'] [algebra R A₂'] [algebra R A₃'] (e₁ : A₁ ≃ₐ[R] A₁') (e₂ : A₂ ≃ₐ[R] A₂')
  (e₃ : A₃ ≃ₐ[R] A₃') (f : A₁ →ₐ[R] A₂) (g : A₂ →ₐ[R] A₃) :
  arrow_congr e₁ e₃ (g.comp f) = (arrow_congr e₂ e₃ g).comp (arrow_congr e₁ e₂ f) :=
by { ext, simp only [arrow_congr, equiv.coe_fn_mk, alg_hom.comp_apply],
  congr, exact (e₂.symm_apply_apply _).symm }

@[simp] lemma arrow_congr_refl :
  arrow_congr alg_equiv.refl alg_equiv.refl = equiv.refl (A₁ →ₐ[R] A₂) :=
by { ext, refl }

@[simp] lemma arrow_congr_trans {A₁' A₂' A₃' : Type*} [semiring A₁'] [semiring A₂'] [semiring A₃']
  [algebra R A₁'] [algebra R A₂'] [algebra R A₃'] (e₁ : A₁ ≃ₐ[R] A₂) (e₁' : A₁' ≃ₐ[R] A₂')
  (e₂ : A₂ ≃ₐ[R] A₃) (e₂' : A₂' ≃ₐ[R] A₃') :
  arrow_congr (e₁.trans e₂) (e₁'.trans e₂') = (arrow_congr e₁ e₁').trans (arrow_congr e₂ e₂') :=
by { ext, refl }

@[simp] lemma arrow_congr_symm {A₁' A₂' : Type*} [semiring A₁'] [semiring A₂']
  [algebra R A₁'] [algebra R A₂'] (e₁ : A₁ ≃ₐ[R] A₁') (e₂ : A₂ ≃ₐ[R] A₂') :
  (arrow_congr e₁ e₂).symm = arrow_congr e₁.symm e₂.symm :=
by { ext, refl }

/-- If an algebra morphism has an inverse, it is a algebra isomorphism. -/
def of_alg_hom (f : A₁ →ₐ[R] A₂) (g : A₂ →ₐ[R] A₁) (h₁ : f.comp g = alg_hom.id R A₂)
  (h₂ : g.comp f = alg_hom.id R A₁) : A₁ ≃ₐ[R] A₂ :=
{ inv_fun   := g,
  left_inv  := alg_hom.ext_iff.1 h₂,
  right_inv := alg_hom.ext_iff.1 h₁,
  ..f }

/-- Promotes a bijective algebra homomorphism to an algebra equivalence. -/
noncomputable def of_bijective (f : A₁ →ₐ[R] A₂) (hf : function.bijective f) : A₁ ≃ₐ[R] A₂ :=
{ .. ring_equiv.of_bijective (f : A₁ →+* A₂) hf, .. f }

/-- Forgetting the multiplicative structures, an equivalence of algebras is a linear equivalence. -/
def to_linear_equiv (e : A₁ ≃ₐ[R] A₂) : A₁ ≃ₗ[R] A₂ :=
{ to_fun    := e.to_fun,
  map_add'  := λ x y, by simp,
  map_smul' := λ r x, by simp [algebra.smul_def''],
  inv_fun   := e.symm.to_fun,
  left_inv  := e.left_inv,
  right_inv := e.right_inv, }

@[simp] lemma to_linear_equiv_apply (e : A₁ ≃ₐ[R] A₂) (x : A₁) : e.to_linear_equiv x = e x := rfl

theorem to_linear_equiv_inj {e₁ e₂ : A₁ ≃ₐ[R] A₂} (H : e₁.to_linear_equiv = e₂.to_linear_equiv) :
  e₁ = e₂ :=
ext $ λ x, show e₁.to_linear_equiv x = e₂.to_linear_equiv x, by rw H

/-- Interpret an algebra equivalence as a linear map. -/
def to_linear_map : A₁ →ₗ[R] A₂ :=
e.to_alg_hom.to_linear_map

@[simp] lemma to_alg_hom_to_linear_map :
  (e : A₁ →ₐ[R] A₂).to_linear_map = e.to_linear_map := rfl

@[simp] lemma to_linear_equiv_to_linear_map :
  e.to_linear_equiv.to_linear_map = e.to_linear_map := rfl

@[simp] lemma to_linear_map_apply (x : A₁) : e.to_linear_map x = e x := rfl

theorem to_linear_map_inj {e₁ e₂ : A₁ ≃ₐ[R] A₂} (H : e₁.to_linear_map = e₂.to_linear_map) :
  e₁ = e₂ :=
ext $ λ x, show e₁.to_linear_map x = e₂.to_linear_map x, by rw H

@[simp] lemma trans_to_linear_map (f : A₁ ≃ₐ[R] A₂) (g : A₂ ≃ₐ[R] A₃) :
  (f.trans g).to_linear_map = g.to_linear_map.comp f.to_linear_map := rfl

section of_linear_equiv

variables (l : A₁ ≃ₗ[R] A₂)
  (map_mul : ∀ x y : A₁, l (x * y) = l x * l y)
  (commutes : ∀ r : R, l (algebra_map R A₁ r) = algebra_map R A₂ r)

/--
Upgrade a linear equivalence to an algebra equivalence,
given that it distributes over multiplication and action of scalars.
-/
def of_linear_equiv : A₁ ≃ₐ[R] A₂ :=
{ to_fun := l,
  inv_fun := l.symm,
  map_mul' := map_mul,
  commutes' := commutes,
  ..l }

@[simp] lemma of_linear_equiv_to_linear_equiv (map_mul) (commutes) :
  of_linear_equiv e.to_linear_equiv map_mul commutes = e :=
by { ext, refl }

@[simp] lemma to_linear_equiv_of_linear_equiv :
  to_linear_equiv (of_linear_equiv l map_mul commutes) = l :=
by { ext, refl }

@[simp] lemma of_linear_equiv_apply (x : A₁) : of_linear_equiv l map_mul commutes x = l x := rfl

end of_linear_equiv

instance aut : group (A₁ ≃ₐ[R] A₁) :=
{ mul := λ ϕ ψ, ψ.trans ϕ,
  mul_assoc := λ ϕ ψ χ, rfl,
  one := 1,
  one_mul := λ ϕ, by { ext, refl },
  mul_one := λ ϕ, by { ext, refl },
  inv := symm,
  mul_left_inv := λ ϕ, by { ext, exact symm_apply_apply ϕ a } }

@[simp] lemma mul_apply (e₁ e₂ : A₁ ≃ₐ[R] A₁) (x : A₁) : (e₁ * e₂) x = e₁ (e₂ x) := rfl

/-- An algebra isomorphism induces a group isomorphism between automorphism groups -/
@[simps apply]
def aut_congr (ϕ : A₁ ≃ₐ[R] A₂) : (A₁ ≃ₐ[R] A₁) ≃* (A₂ ≃ₐ[R] A₂) :=
{ to_fun := λ ψ, ϕ.symm.trans (ψ.trans ϕ),
  inv_fun := λ ψ, ϕ.trans (ψ.trans ϕ.symm),
  left_inv := λ ψ, by { ext, simp_rw [trans_apply, symm_apply_apply] },
  right_inv := λ ψ, by { ext, simp_rw [trans_apply, apply_symm_apply] },
  map_mul' := λ ψ χ, by { ext, simp only [mul_apply, trans_apply, symm_apply_apply] } }

@[simp] lemma aut_congr_refl : aut_congr (alg_equiv.refl) = mul_equiv.refl (A₁ ≃ₐ[R] A₁) :=
by { ext, refl }

@[simp] lemma aut_congr_symm (ϕ : A₁ ≃ₐ[R] A₂) : (aut_congr ϕ).symm = aut_congr ϕ.symm := rfl

@[simp] lemma aut_congr_trans (ϕ : A₁ ≃ₐ[R] A₂) (ψ : A₂ ≃ₐ[R] A₃) :
  (aut_congr ϕ).trans (aut_congr ψ) = aut_congr (ϕ.trans ψ) := rfl

end semiring

section comm_semiring

variables [comm_semiring R] [comm_semiring A₁] [comm_semiring A₂]
variables [algebra R A₁] [algebra R A₂] (e : A₁ ≃ₐ[R] A₂)

lemma map_prod {ι : Type*} (f : ι → A₁) (s : finset ι) :
  e (∏ x in s, f x) = ∏ x in s, e (f x) :=
e.to_alg_hom.map_prod f s

lemma map_finsupp_prod {α : Type*} [has_zero α] {ι : Type*} (f : ι →₀ α) (g : ι → α → A₁) :
  e (f.prod g) = f.prod (λ i a, e (g i a)) :=
e.to_alg_hom.map_finsupp_prod f g

end comm_semiring

section ring

variables [comm_ring R] [ring A₁] [ring A₂]
variables [algebra R A₁] [algebra R A₂] (e : A₁ ≃ₐ[R] A₂)

@[simp] lemma map_neg (x) : e (-x) = -e x :=
e.to_alg_hom.map_neg x

@[simp] lemma map_sub (x y) : e (x - y) = e x - e y :=
e.to_alg_hom.map_sub x y

end ring

section division_ring

variables [comm_ring R] [division_ring A₁] [division_ring A₂]
variables [algebra R A₁] [algebra R A₂] (e : A₁ ≃ₐ[R] A₂)

@[simp] lemma map_inv (x) : e (x⁻¹) = (e x)⁻¹ :=
e.to_alg_hom.map_inv x

@[simp] lemma map_div (x y) : e (x / y) = e x / e y :=
e.to_alg_hom.map_div x y

end division_ring

end alg_equiv

namespace matrix

/-! ### `matrix` section

Specialize `matrix.one_map` and `matrix.zero_map` to `alg_hom` and `alg_equiv`.
TODO: there should be a way to avoid restating these for each `foo_hom`.
-/

variables {R A₁ A₂ n : Type*} [fintype n]

section semiring

variables [comm_semiring R] [semiring A₁] [algebra R A₁] [semiring A₂] [algebra R A₂]

/-- A version of `matrix.one_map` where `f` is an `alg_hom`. -/
@[simp] lemma alg_hom_map_one [decidable_eq n]
  (f : A₁ →ₐ[R] A₂) : (1 : matrix n n A₁).map f = 1 :=
one_map f.map_zero f.map_one

/-- A version of `matrix.one_map` where `f` is an `alg_equiv`. -/
@[simp] lemma alg_equiv_map_one [decidable_eq n]
  (f : A₁ ≃ₐ[R] A₂) : (1 : matrix n n A₁).map f = 1 :=
one_map f.map_zero f.map_one

/-- A version of `matrix.zero_map` where `f` is an `alg_hom`. -/
@[simp] lemma alg_hom_map_zero
  (f : A₁ →ₐ[R] A₂) : (0 : matrix n n A₁).map f = 0 :=
map_zero f.map_zero

/-- A version of `matrix.zero_map` where `f` is an `alg_equiv`. -/
@[simp] lemma alg_equiv_map_zero
  (f : A₁ ≃ₐ[R] A₂) : (0 : matrix n n A₁).map f = 0 :=
map_zero f.map_zero

end semiring

end matrix

namespace algebra

variables (R : Type u) (S : Type v) (A : Type w)
include R S A

/-- `comap R S A` is a type alias for `A`, and has an R-algebra structure defined on it
  when `algebra R S` and `algebra S A`. If `S` is an `R`-algebra and `A` is an `S`-algebra then
  `algebra.comap.algebra R S A` can be used to provide `A` with a structure of an `R`-algebra.
  Other than that, `algebra.comap` is now deprecated and replaced with `is_scalar_tower`. -/
/- This is done to avoid a type class search with meta-variables `algebra R ?m_1` and
    `algebra ?m_1 A -/
/- The `nolint` attribute is added because it has unused arguments `R` and `S`, but these are
  necessary for synthesizing the appropriate type classes -/
@[nolint unused_arguments]
def comap : Type w := A

instance comap.inhabited [h : inhabited A] : inhabited (comap R S A) := h
instance comap.semiring [h : semiring A] : semiring (comap R S A) := h
instance comap.ring [h : ring A] : ring (comap R S A) := h
instance comap.comm_semiring [h : comm_semiring A] : comm_semiring (comap R S A) := h
instance comap.comm_ring [h : comm_ring A] : comm_ring (comap R S A) := h

instance comap.algebra' [comm_semiring S] [semiring A] [h : algebra S A] :
  algebra S (comap R S A) := h

/-- Identity homomorphism `A →ₐ[S] comap R S A`. -/
def comap.to_comap [comm_semiring S] [semiring A] [algebra S A] :
  A →ₐ[S] comap R S A := alg_hom.id S A
/-- Identity homomorphism `comap R S A →ₐ[S] A`. -/
def comap.of_comap [comm_semiring S] [semiring A] [algebra S A] :
  comap R S A →ₐ[S] A := alg_hom.id S A

variables [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A]

/-- `R ⟶ S` induces `S-Alg ⥤ R-Alg` -/
instance comap.algebra : algebra R (comap R S A) :=
{ smul := λ r x, (algebra_map R S r • x : A),
  commutes' := λ r x, algebra.commutes _ _,
  smul_def' := λ _ _, algebra.smul_def _ _,
  .. (algebra_map S A).comp (algebra_map R S) }

/-- Embedding of `S` into `comap R S A`. -/
def to_comap : S →ₐ[R] comap R S A :=
{ commutes' := λ r, rfl,
  .. algebra_map S A }

theorem to_comap_apply (x) : to_comap R S A x = algebra_map S A x := rfl

end algebra

section

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

/-- R ⟶ S induces S-Alg ⥤ R-Alg.

See `alg_hom.restrict_scalars` for the version that uses `is_scalar_tower` instead of `comap`. -/
def alg_hom.comap (φ : A →ₐ[S] B) : algebra.comap R S A →ₐ[R] algebra.comap R S B :=
{ commutes' := λ r, φ.commutes (algebra_map R S r)
  ..φ }

/-- `alg_hom.comap` for `alg_equiv`.

See `alg_equiv.restrict_scalars` for the version that uses `is_scalar_tower` instead of `comap`. -/
def alg_equiv.comap (φ : A ≃ₐ[S] B) : algebra.comap R S A ≃ₐ[R] algebra.comap R S B :=
{ commutes' := λ r, φ.commutes (algebra_map R S r)
  ..φ }

end

section nat

variables {R : Type*} [semiring R]

-- Lower the priority so that `algebra.id` is picked most of the time when working with
-- `ℕ`-algebras. This is only an issue since `algebra.id` and `algebra_nat` are not yet defeq.
-- TODO: fix this by adding an `of_nat` field to semirings.
/-- Semiring ⥤ ℕ-Alg -/
@[priority 99] instance algebra_nat : algebra ℕ R :=
{ commutes' := nat.cast_commute,
  smul_def' := λ _ _, nsmul_eq_mul _ _,
  to_ring_hom := nat.cast_ring_hom R }

instance nat_algebra_subsingleton : subsingleton (algebra ℕ R) :=
⟨λ P Q, by { ext, simp, }⟩

end nat

namespace ring_hom

variables {R S : Type*}

/-- Reinterpret a `ring_hom` as an `ℕ`-algebra homomorphism. -/
def to_nat_alg_hom [semiring R] [semiring S] (f : R →+* S) :
  R →ₐ[ℕ] S :=
{ to_fun := f, commutes' := λ n, by simp, .. f }

/-- Reinterpret a `ring_hom` as a `ℤ`-algebra homomorphism. -/
def to_int_alg_hom [ring R] [ring S] [algebra ℤ R] [algebra ℤ S] (f : R →+* S) :
  R →ₐ[ℤ] S :=
{ commutes' := λ n, by simp, .. f }

@[simp] lemma map_rat_algebra_map [ring R] [ring S] [algebra ℚ R] [algebra ℚ S] (f : R →+* S)
  (r : ℚ) :
  f (algebra_map ℚ R r) = algebra_map ℚ S r :=
ring_hom.ext_iff.1 (subsingleton.elim (f.comp (algebra_map ℚ R)) (algebra_map ℚ S)) r

/-- Reinterpret a `ring_hom` as a `ℚ`-algebra homomorphism. -/
def to_rat_alg_hom [ring R] [ring S] [algebra ℚ R] [algebra ℚ S] (f : R →+* S) :
  R →ₐ[ℚ] S :=
{ commutes' := f.map_rat_algebra_map, .. f }

end ring_hom

namespace rat

instance algebra_rat {α} [division_ring α] [char_zero α] : algebra ℚ α :=
(rat.cast_hom α).to_algebra' $ λ r x, r.cast_commute x

@[simp] theorem algebra_map_rat_rat : algebra_map ℚ ℚ = ring_hom.id ℚ :=
subsingleton.elim _ _

-- TODO[gh-6025]: make this an instance once safe to do so
lemma algebra_rat_subsingleton {α} [semiring α] :
  subsingleton (algebra ℚ α) :=
⟨λ x y, algebra.algebra_ext x y $ ring_hom.congr_fun $ subsingleton.elim _ _⟩

end rat

namespace algebra
open module

variables (R : Type u) (A : Type v)

variables [comm_semiring R] [semiring A] [algebra R A]

/-- `algebra_map` as an `alg_hom`. -/
def of_id : R →ₐ[R] A :=
{ commutes' := λ _, rfl, .. algebra_map R A }
variables {R}

theorem of_id_apply (r) : of_id R A r = algebra_map R A r := rfl

variables (R A)
/-- The multiplication in an algebra is a bilinear map. -/
def lmul : A →ₐ[R] (End R A) :=
{ map_one' := by { ext a, exact one_mul a },
  map_mul' := by { intros a b, ext c, exact mul_assoc a b c },
  map_zero' := by { ext a, exact zero_mul a },
  commutes' := by { intro r, ext a, dsimp, rw [smul_def] },
  .. (show A →ₗ[R] A →ₗ[R] A, from linear_map.mk₂ R (*)
  (λ x y z, add_mul x y z)
  (λ c x y, by rw [smul_def, smul_def, mul_assoc _ x y])
  (λ x y z, mul_add x y z)
  (λ c x y, by rw [smul_def, smul_def, left_comm])) }

variables {A}

/-- The multiplication on the left in an algebra is a linear map. -/
def lmul_left (r : A) : A →ₗ A :=
lmul R A r

/-- The multiplication on the right in an algebra is a linear map. -/
def lmul_right (r : A) : A →ₗ A :=
(lmul R A).to_linear_map.flip r

/-- Simultaneous multiplication on the left and right is a linear map. -/
def lmul_left_right (vw: A × A) : A →ₗ[R] A :=
(lmul_right R vw.2).comp (lmul_left R vw.1)

/-- The multiplication map on an algebra, as an `R`-linear map from `A ⊗[R] A` to `A`. -/
def lmul' : A ⊗[R] A →ₗ[R] A :=
tensor_product.lift (lmul R A).to_linear_map

variables {R A}

@[simp] lemma lmul_apply (p q : A) : lmul R A p q = p * q := rfl
@[simp] lemma lmul_left_apply (p q : A) : lmul_left R p q = p * q := rfl
@[simp] lemma lmul_right_apply (p q : A) : lmul_right R p q = q * p := rfl
@[simp] lemma lmul_left_right_apply (vw : A × A) (p : A) :
  lmul_left_right R vw p = vw.1 * p * vw.2 := rfl

@[simp] lemma lmul_left_one : lmul_left R (1:A) = linear_map.id :=
by { ext, simp only [linear_map.id_coe, one_mul, id.def, lmul_left_apply] }

@[simp] lemma lmul_left_mul (a b : A) :
  lmul_left R (a * b) = (lmul_left R a).comp (lmul_left R b) :=
by { ext, simp only [lmul_left_apply, linear_map.comp_apply, mul_assoc] }

@[simp] lemma lmul_right_one : lmul_right R (1:A) = linear_map.id :=
by { ext, simp only [linear_map.id_coe, mul_one, id.def, lmul_right_apply] }

@[simp] lemma lmul_right_mul (a b : A) :
  lmul_right R (a * b) = (lmul_right R b).comp (lmul_right R a) :=
by { ext, simp only [lmul_right_apply, linear_map.comp_apply, mul_assoc] }

@[simp] lemma lmul'_apply {x y : A} : lmul' R (x ⊗ₜ y) = x * y :=
by simp only [algebra.lmul', tensor_product.lift.tmul, alg_hom.to_linear_map_apply, lmul_apply]

instance linear_map.module' (R : Type u) [comm_semiring R]
  (M : Type v) [add_comm_monoid M] [module R M]
  (S : Type w) [comm_semiring S] [algebra R S] : module S (M →ₗ[R] S) :=
{ smul := λ s f, linear_map.llcomp _ _ _ _ (algebra.lmul R S s) f,
  one_smul := λ f, linear_map.ext $ λ x, one_mul _,
  mul_smul := λ s₁ s₂ f, linear_map.ext $ λ x, mul_assoc _ _ _,
  smul_add := λ s f g, linear_map.map_add _ _ _,
  smul_zero := λ s, linear_map.map_zero _,
  add_smul := λ s₁ s₂ f, linear_map.ext $ λ x, add_mul _ _ _,
  zero_smul := λ f, linear_map.ext $ λ x, zero_mul _ }

end algebra

section ring

namespace algebra

variables {R A : Type*} [comm_semiring R] [ring A] [algebra R A]

lemma lmul_left_injective [no_zero_divisors A] {x : A} (hx : x ≠ 0) :
  function.injective (lmul_left R x) :=
by { letI : domain A := { exists_pair_ne := ⟨x, 0, hx⟩, ..‹ring A›, ..‹no_zero_divisors A› },
     exact mul_right_injective' hx }

lemma lmul_right_injective [no_zero_divisors A] {x : A} (hx : x ≠ 0) :
  function.injective (lmul_right R x) :=
by { letI : domain A := { exists_pair_ne := ⟨x, 0, hx⟩, ..‹ring A›, ..‹no_zero_divisors A› },
     exact mul_left_injective' hx }

lemma lmul_injective [no_zero_divisors A] {x : A} (hx : x ≠ 0) :
  function.injective (lmul R A x) :=
by { letI : domain A := { exists_pair_ne := ⟨x, 0, hx⟩, ..‹ring A›, ..‹no_zero_divisors A› },
     exact mul_right_injective' hx }

end algebra

end ring

section int

variables (R : Type*) [ring R]

-- Lower the priority so that `algebra.id` is picked most of the time when working with
-- `ℤ`-algebras. This is only an issue since `algebra.id ℤ` and `algebra_int ℤ` are not yet defeq.
-- TODO: fix this by adding an `of_int` field to rings.
/-- Ring ⥤ ℤ-Alg -/
@[priority 99] instance algebra_int : algebra ℤ R :=
{ commutes' := int.cast_commute,
  smul_def' := λ _ _, gsmul_eq_mul _ _,
  to_ring_hom := int.cast_ring_hom R }

variables {R}

instance int_algebra_subsingleton : subsingleton (algebra ℤ R) :=
⟨λ P Q, by { ext, simp, }⟩

end int

/-!
The R-algebra structure on `Π i : I, A i` when each `A i` is an R-algebra.

We couldn't set this up back in `algebra.pi_instances` because this file imports it.
-/
namespace pi

variable {I : Type u}     -- The indexing type
variable {R : Type*}      -- The scalar type
variable {f : I → Type v} -- The family of types already equipped with instances
variables (x y : Π i, f i) (i : I)
variables (I f)

instance algebra {r : comm_semiring R}
  [s : ∀ i, semiring (f i)] [∀ i, algebra R (f i)] :
  algebra R (Π i : I, f i) :=
{ commutes' := λ a f, begin ext, simp [algebra.commutes], end,
  smul_def' := λ a f, begin ext, simp [algebra.smul_def''], end,
  ..pi.ring_hom (λ i, algebra_map R (f i)) }

@[simp] lemma algebra_map_apply {r : comm_semiring R}
  [s : ∀ i, semiring (f i)] [∀ i, algebra R (f i)] (a : R) (i : I) :
  algebra_map R (Π i, f i) a i = algebra_map R (f i) a := rfl

-- One could also build a `Π i, R i`-algebra structure on `Π i, A i`,
-- when each `A i` is an `R i`-algebra, although I'm not sure that it's useful.

variables (R) (f)

/-- `function.eval` as an `alg_hom`. The name matches `ring_hom.apply`, `monoid_hom.apply`, etc. -/
@[simps]
def alg_hom.apply {r : comm_semiring R} [Π i, semiring (f i)] [Π i, algebra R (f i)] (i : I) :
  (Π i, f i) →ₐ[R] f i :=
{ commutes' := λ r, rfl, .. ring_hom.apply f i}

end pi

section is_scalar_tower

variables {R : Type*} [comm_semiring R]
variables (A : Type*) [semiring A] [algebra R A]
variables {M : Type*} [add_comm_monoid M] [module A M] [module R M] [is_scalar_tower R A M]
variables {N : Type*} [add_comm_monoid N] [module A N] [module R N] [is_scalar_tower R A N]

lemma algebra_compatible_smul (r : R) (m : M) : r • m = ((algebra_map R A) r) • m :=
by rw [←(one_smul A m), ←smul_assoc, algebra.smul_def, mul_one, one_smul]

@[simp] lemma algebra_map_smul (r : R) (m : M) : ((algebra_map R A) r) • m = r • m :=
(algebra_compatible_smul A r m).symm

variable {A}

@[priority 100] -- see Note [lower instance priority]
instance is_scalar_tower.to_smul_comm_class : smul_comm_class R A M :=
⟨λ r a m, by rw [algebra_compatible_smul A r (a • m), smul_smul, algebra.commutes, mul_smul,
  ←algebra_compatible_smul]⟩

@[priority 100] -- see Note [lower instance priority]
instance is_scalar_tower.to_smul_comm_class' : smul_comm_class A R M :=
smul_comm_class.symm _ _ _

lemma smul_algebra_smul_comm (r : R) (a : A) (m : M) : a • r • m = r • a • m :=
smul_comm _ _ _

namespace linear_map

instance coe_is_scalar_tower : has_coe (M →ₗ[A] N) (M →ₗ[R] N) :=
⟨restrict_scalars R⟩

variables (R) {A M N}

@[simp, norm_cast squash] lemma coe_restrict_scalars_eq_coe (f : M →ₗ[A] N) :
  (f.restrict_scalars R : M → N) = f := rfl

@[simp, norm_cast squash] lemma coe_coe_is_scalar_tower (f : M →ₗ[A] N) :
  ((f : M →ₗ[R] N) : M → N) = f := rfl

/-- `A`-linearly coerce a `R`-linear map from `M` to `A` to a function, given an algebra `A` over
a commutative semiring `R` and `M` a module over `R`. -/
def lto_fun (R : Type u) (M : Type v) (A : Type w)
  [comm_semiring R] [add_comm_monoid M] [module R M] [comm_ring A] [algebra R A] :
  (M →ₗ[R] A) →ₗ[A] (M → A) :=
{ to_fun := linear_map.to_fun,
  map_add' := λ f g, rfl,
  map_smul' := λ c f, rfl }

end linear_map

end is_scalar_tower

section restrict_scalars
/- In this section, we describe restriction of scalars: if `S` is an algebra over `R`, then
`S`-modules are also `R`-modules. -/

section type_synonym
variables (R A M : Type*)

/--
Warning: use this type synonym judiciously!
The preferred way of working with an `A`-module `M` as `R`-module (where `A` is an `R`-algebra),
is by `[module R M] [module A M] [is_scalar_tower R A M]`.

When `M` is a module over a ring `A`, and `A` is an algebra over `R`, then `M` inherits a
module structure over `R`, provided as a type synonym `module.restrict_scalars R A M := M`.
-/
@[nolint unused_arguments]
def restrict_scalars (R A M : Type*) : Type* := M

instance [I : inhabited M] : inhabited (restrict_scalars R A M) := I

instance [I : add_comm_monoid M] : add_comm_monoid (restrict_scalars R A M) := I

instance [I : add_comm_group M] : add_comm_group (restrict_scalars R A M) := I

instance restrict_scalars.module_orig [semiring A] [add_comm_monoid M] [I : module A M] :
  module A (restrict_scalars R A M) := I

variables [comm_semiring R] [semiring A] [algebra R A]
variables [add_comm_monoid M] [module A M]

/--
When `M` is a module over a ring `A`, and `A` is an algebra over `R`, then `M` inherits a
module structure over `R`.

The preferred way of setting this up is `[module R M] [module A M] [is_scalar_tower R A M]`.
-/
instance : module R (restrict_scalars R A M) :=
module.comp_hom M (algebra_map R A)

lemma restrict_scalars_smul_def (c : R) (x : restrict_scalars R A M) :
  c • x = ((algebra_map R A c) • x : M) := rfl

instance : is_scalar_tower R A (restrict_scalars R A M) :=
⟨λ r A M, by { rw [algebra.smul_def, mul_smul], refl }⟩

instance submodule.restricted_module (V : submodule A M) :
  module R V :=
restrict_scalars.module R A V

instance submodule.restricted_module_is_scalar_tower (V : submodule A M) :
  is_scalar_tower R A V :=
restrict_scalars.is_scalar_tower R A V

end type_synonym

/-! TODO: The following lemmas no longer involve `algebra` at all, and could be moved closer
to `algebra/module/submodule.lean`. Currently this is tricky because `ker`, `range`, `⊤`, and `⊥`
are all defined in `linear_algebra/basic.lean`. -/
section module
open module

variables (R S M N : Type*) [semiring R] [semiring S] [has_scalar R S]
variables [add_comm_monoid M] [module R M] [module S M] [is_scalar_tower R S M]
variables [add_comm_monoid N] [module R N] [module S N] [is_scalar_tower R S N]

variables {S M N}

namespace submodule

/--
`V.restrict_scalars R` is the `R`-submodule of the `R`-module given by restriction of scalars,
corresponding to `V`, an `S`-submodule of the original `S`-module.
-/
@[simps]
def restrict_scalars (V : submodule S M) : submodule R M :=
{ carrier := V.carrier,
  zero_mem' := V.zero_mem,
  smul_mem' := λ c m h, V.smul_of_tower_mem c h,
  add_mem' := λ x y hx hy, V.add_mem hx hy }

@[simp]
lemma restrict_scalars_mem (V : submodule S M) (m : M) :
  m ∈ V.restrict_scalars R ↔ m ∈ V :=
iff.refl _

variables (R S M)

lemma restrict_scalars_injective :
  function.injective (restrict_scalars R : submodule S M → submodule R M) :=
λ V₁ V₂ h, ext $ by convert set.ext_iff.1 (set_like.ext'_iff.1 h); refl

@[simp] lemma restrict_scalars_inj {V₁ V₂ : submodule S M} :
  restrict_scalars R V₁ = restrict_scalars R V₂ ↔ V₁ = V₂ :=
(restrict_scalars_injective R _ _).eq_iff

@[simp]
lemma restrict_scalars_bot : restrict_scalars R (⊥ : submodule S M) = ⊥ := rfl

@[simp]
lemma restrict_scalars_top : restrict_scalars R (⊤ : submodule S M) = ⊤ := rfl

/-- If `S` is an `R`-algebra, then the `R`-module generated by a set `X` is included in the
`S`-module generated by `X`. -/
lemma span_le_restrict_scalars (X : set M) : span R (X : set M) ≤ restrict_scalars R (span S X) :=
submodule.span_le.mpr submodule.subset_span

end submodule

@[simp]
lemma linear_map.ker_restrict_scalars (f : M →ₗ[S] N) :
  (f.restrict_scalars R).ker = f.ker.restrict_scalars R :=
rfl

end module

end restrict_scalars

namespace submodule

variables (R A M : Type*)
variables [comm_semiring R] [semiring A] [algebra R A] [add_comm_monoid M]
variables [module R M] [module A M] [is_scalar_tower R A M]

/-- If `A` is an `R`-algebra such that the induced morhpsim `R →+* A` is surjective, then the
`R`-module generated by a set `X` equals the `A`-module generated by `X`. -/
lemma span_eq_restrict_scalars (X : set M) (hsur : function.surjective (algebra_map R A)) :
  span R X = restrict_scalars R (span A X) :=
begin
  apply (span_le_restrict_scalars R A M X).antisymm (λ m hm, _),
  refine span_induction hm subset_span (zero_mem _) (λ _ _, add_mem _) (λ a m hm, _),
  obtain ⟨r, rfl⟩ := hsur a,
  simpa [algebra_map_smul] using smul_mem _ r hm
end

end submodule


def myid (a : α) := a -- works
set_option relaxedAutoImplicit false
#check myid 10
#check myid true

theorem ex1 (a : α) : myid a = a := rfl

def cnst (b : β) : α → β := fun _ => b -- works

theorem ex2 (b : β) (a : α) : cnst b a = b := rfl

def Vec (α : Type) (n : Nat) := { a : Array α // a.size = n }

def mkVec : Vec α 0 := ⟨ #[], rfl ⟩

def Vec.map (xs : Vec α n) (f : α → β) : Vec β n :=
  ⟨ xs.val.map f, sorry ⟩

/- unbound implicit locals must be greek or lower case letters followed by numerical digits -/
def Vec.map2 (xs : Vec α size /- error: unknown identifier size -/) (f : α → β) : Vec β n :=
  ⟨ xs.val.map f, sorry ⟩

set_option autoImplicit false in
def Vec.map3 (xs : Vec α n) (f : α → β) : Vec β n := -- Errors, unknown identifiers 'α', 'n', 'β'
  ⟨ xs.val.map f, sorry ⟩

def double [Add α] (a : α) := a + a

variable (xs : Vec α n) -- works

def f := xs

#check @f

#check f mkVec

#check f (α := Nat) mkVec

def g (a : α) := xs.val.push a

theorem ex3 : g ⟨#[0], rfl⟩ 1 = #[0, 1] :=
  rfl

inductive Tree (α β : Type) :=
  | leaf1 : α → Tree α β
  | leaf2 : β → Tree α β
  | node : Tree α β → Tree α β → Tree α β

inductive TreeElem1 : α → Tree α β → Prop
  | leaf1     : (a : α) → TreeElem1 a (Tree.leaf1 (β := β) a)
  | nodeLeft  : (a : α) → (left : Tree α β) → (right : Tree α β) → TreeElem1 a left  → TreeElem1 a (Tree.node left right)
  | nodeRight : (a : α) → (left : Tree α β) → (right : Tree α β) → TreeElem1 a right → TreeElem1 a (Tree.node left right)

inductive TreeElem2 : β → Tree α β → Prop
  | leaf2     : (b : β) → TreeElem2 b (Tree.leaf2 (α := α) b)
  | nodeLeft  : (b : β) → (left : Tree α β) → (right : Tree α β) → TreeElem2 b left  → TreeElem2 b (Tree.node left right)
  | nodeRight : (b : β) → (left : Tree α β) → (right : Tree α β) → TreeElem2 b right → TreeElem2 b (Tree.node left right)

namespace Ex1

def findSomeRevM? [Monad m] (as : Array α) (f : α → m (Option β)) : m (Option β) :=
  pure none

def findSomeRev? (as : Array α) (f : α → Option β) : Option β :=
  Id.run <| findSomeRevM? as f

end Ex1

def apply {α : Type u₁} {β : α → Type u₂} (f : (a : α) → β a) (a : α) : β a :=
  f a

def pair (a : α₁) := (a, a)


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import data.list.sigma
import data.int.range
import data.finsupp.basic
import data.finsupp.to_dfinsupp
import tactic.pretty_cases
import testing.slim_check.sampleable
import testing.slim_check.testable

/-!
## `slim_check`: generators for functions

This file defines `sampleable` instances for `α → β` functions and
`ℤ → ℤ` injective functions.

Functions are generated by creating a list of pairs and one more value
using the list as a lookup table and resorting to the additional value
when a value is not found in the table.

Injective functions are generated by creating a list of numbers and
a permutation of that list. The permutation insures that every input
is mapped to a unique output. When an input is not found in the list
the input itself is used as an output.

Injective functions `f : α → α` could be generated easily instead of
`ℤ → ℤ` by generating a `list α`, removing duplicates and creating a
permutations. One has to be careful when generating the domain to make
if vast enough that, when generating arguments to apply `f` to,
they argument should be likely to lie in the domain of `f`. This is
the reason that injective functions `f : ℤ → ℤ` are generated by
fixing the domain to the range `[-2*size .. -2*size]`, with `size`
the size parameter of the `gen` monad.

Much of the machinery provided in this file is applicable to generate
injective functions of type `α → α` and new instances should be easy
to define.

Other classes of functions such as monotone functions can generated using
similar techniques. For monotone functions, generating two lists, sorting them
and matching them should suffice, with appropriate default values.
Some care must be taken for shrinking such functions to make sure
their defining property is invariant through shrinking. Injective
functions are an example of how complicated it can get.
-/

universes u v w
variables {α : Type u} {β : Type v} {γ : Sort w}

namespace slim_check

/-- Data structure specifying a total function using a list of pairs
and a default value returned when the input is not in the domain of
the partial function.

`with_default f y` encodes `x ↦ f x` when `x ∈ f` and `x ↦ y`
otherwise.

We use `Σ` to encode mappings instead of `×` because we
rely on the association list API defined in `data.list.sigma`.
 -/
inductive total_function (α : Type u) (β : Type v) : Type (max u v)
| with_default : list (Σ _ : α, β) → β → total_function

instance total_function.inhabited [inhabited β] : inhabited (total_function α β) :=
⟨ total_function.with_default ∅ default ⟩

namespace total_function

/-- Apply a total function to an argument. -/
def apply [decidable_eq α] : total_function α β → α → β
| (total_function.with_default m y) x := (m.lookup x).get_or_else y

/--
Implementation of `has_repr (total_function α β)`.

Creates a string for a given `finmap` and output, `x₀ ↦ y₀, .. xₙ ↦ yₙ`
for each of the entries. The brackets are provided by the calling function.
-/
def repr_aux [has_repr α] [has_repr β] (m : list (Σ _ : α, β)) : string :=
string.join $ list.qsort (λ x y, x < y)
  (m.map $ λ x, sformat!"{repr $ sigma.fst x} ↦ {repr $ sigma.snd x}, ")

/--
Produce a string for a given `total_function`.
The output is of the form `[x₀ ↦ f x₀, .. xₙ ↦ f xₙ, _ ↦ y]`.
-/
protected def repr [has_repr α] [has_repr β] : total_function α β → string
| (total_function.with_default m y) := sformat!"[{repr_aux m}_ ↦ {has_repr.repr y}]"

instance (α : Type u) (β : Type v) [has_repr α] [has_repr β] : has_repr (total_function α β) :=
⟨ total_function.repr ⟩

/-- Create a `finmap` from a list of pairs. -/
def list.to_finmap' (xs : list (α × β)) : list (Σ _ : α, β) :=
xs.map prod.to_sigma

section

variables [sampleable α] [sampleable β]

/-- Redefine `sizeof` to follow the structure of `sampleable` instances. -/
def total.sizeof : total_function α β → ℕ
| ⟨m, x⟩ := 1 + @sizeof _ sampleable.wf m + sizeof x

@[priority 2000]
instance : has_sizeof (total_function α β) :=
⟨ total.sizeof ⟩

variables [decidable_eq α]

/-- Shrink a total function by shrinking the lists that represent it. -/
protected def shrink : shrink_fn (total_function α β)
| ⟨m, x⟩ := (sampleable.shrink (m, x)).map $ λ ⟨⟨m', x'⟩, h⟩, ⟨⟨list.erase_dupkeys m', x'⟩,
            lt_of_le_of_lt
              (by unfold_wf; refine @list.sizeof_erase_dupkeys _ _ _ (@sampleable.wf _ _) _) h ⟩

variables [has_repr α] [has_repr β]

instance pi.sampleable_ext : sampleable_ext (α → β) :=
{ proxy_repr := total_function α β,
  interp := total_function.apply,
  sample := do
  { xs ← (sampleable.sample (list (α × β)) : gen ((list (α × β)))),
    ⟨x⟩ ← (uliftable.up $ sample β : gen (ulift.{max u v} β)),
    pure $ total_function.with_default (list.to_finmap' xs) x },
  shrink := total_function.shrink }

end

section finsupp

variables [has_zero β]
/-- Map a total_function to one whose default value is zero so that it represents a finsupp. -/
@[simp]
def zero_default : total_function α β → total_function α β
| (with_default A y) := with_default A 0

variables [decidable_eq α] [decidable_eq β]
/-- The support of a zero default `total_function`. -/
@[simp]
def zero_default_supp : total_function α β → finset α
| (with_default A y) :=
  list.to_finset $ (A.erase_dupkeys.filter (λ ab, sigma.snd ab ≠ 0)).map sigma.fst

/-- Create a finitely supported function from a total function by taking the default value to
zero. -/
def apply_finsupp (tf : total_function α β) : α →₀ β :=
{ support := zero_default_supp tf,
  to_fun := tf.zero_default.apply,
  mem_support_to_fun := begin
    intro a,
    rcases tf with ⟨A, y⟩,
    simp only [apply, zero_default_supp, list.mem_map, list.mem_filter, exists_and_distrib_right,
      list.mem_to_finset, exists_eq_right, sigma.exists, ne.def, zero_default],
    split,
    { rintro ⟨od, hval, hod⟩,
      have := list.mem_lookup (list.nodupkeys_erase_dupkeys A) hval,
      rw (_ : list.lookup a A = od),
      { simpa, },
      { simpa [list.lookup_erase_dupkeys, with_top.some_eq_coe], }, },
    { intro h,
      use (A.lookup a).get_or_else (0 : β),
      rw ← list.lookup_erase_dupkeys at h ⊢,
      simp only [h, ←list.mem_lookup_iff A.nodupkeys_erase_dupkeys,
        and_true, not_false_iff, option.mem_def],
      cases list.lookup a A.erase_dupkeys,
      { simpa using h, },
      { simp, }, }
  end }

variables [sampleable α] [sampleable β]
instance finsupp.sampleable_ext [has_repr α] [has_repr β] : sampleable_ext (α →₀ β) :=
{ proxy_repr := total_function α β,
  interp := total_function.apply_finsupp,
  sample := (do
    xs ← (sampleable.sample (list (α × β)) : gen (list (α × β))),
    ⟨x⟩ ← (uliftable.up $ sample β : gen (ulift.{max u v} β)),
    pure $ total_function.with_default (list.to_finmap' xs) x),
  shrink := total_function.shrink }

-- TODO: support a non-constant codomain type
instance dfinsupp.sampleable_ext [has_repr α] [has_repr β] : sampleable_ext (Π₀ a : α, β) :=
{ proxy_repr := total_function α β,
  interp := finsupp.to_dfinsupp ∘ total_function.apply_finsupp,
  sample := (do
    xs ← (sampleable.sample (list (α × β)) : gen (list (α × β))),
    ⟨x⟩ ← (uliftable.up $ sample β : gen (ulift.{max u v} β)),
    pure $ total_function.with_default (list.to_finmap' xs) x),
  shrink := total_function.shrink }

end finsupp

section sampleable_ext
open sampleable_ext

@[priority 2000]
instance pi_pred.sampleable_ext [sampleable_ext (α → bool)] :
  sampleable_ext.{u+1} (α → Prop) :=
{ proxy_repr := proxy_repr (α → bool),
  interp := λ m x, interp (α → bool) m x,
  sample := sample (α → bool),
  shrink := shrink }

@[priority 2000]
instance pi_uncurry.sampleable_ext
  [sampleable_ext (α × β → γ)] : sampleable_ext.{(imax (u+1) (v+1) w)} (α → β → γ) :=
{ proxy_repr := proxy_repr (α × β → γ),
  interp := λ m x y, interp (α × β → γ) m (x, y),
  sample := sample (α × β → γ),
  shrink := shrink }

end sampleable_ext

end total_function

/--
Data structure specifying a total function using a list of pairs
and a default value returned when the input is not in the domain of
the partial function.

`map_to_self f` encodes `x ↦ f x` when `x ∈ f` and `x ↦ x`,
i.e. `x` to itself, otherwise.

We use `Σ` to encode mappings instead of `×` because we
rely on the association list API defined in `data.list.sigma`.
-/
inductive injective_function (α : Type u) : Type u
| map_to_self (xs : list (Σ _ : α, α)) :
    xs.map sigma.fst ~ xs.map sigma.snd → list.nodup (xs.map sigma.snd) → injective_function

instance : inhabited (injective_function α) :=
⟨ ⟨ [], list.perm.nil, list.nodup_nil ⟩ ⟩

namespace injective_function

/-- Apply a total function to an argument. -/
def apply [decidable_eq α] : injective_function α → α → α
| (injective_function.map_to_self m _ _) x := (m.lookup x).get_or_else x

/--
Produce a string for a given `total_function`.
The output is of the form `[x₀ ↦ f x₀, .. xₙ ↦ f xₙ, x ↦ x]`.
Unlike for `total_function`, the default value is not a constant
but the identity function.
-/
protected def repr [has_repr α] : injective_function α → string
| (injective_function.map_to_self m _ _) := sformat!"[{total_function.repr_aux m}x ↦ x]"

instance (α : Type u) [has_repr α] : has_repr (injective_function α) :=
⟨ injective_function.repr ⟩

/-- Interpret a list of pairs as a total function, defaulting to
the identity function when no entries are found for a given function -/
def list.apply_id [decidable_eq α] (xs : list (α × α)) (x : α) : α :=
((xs.map prod.to_sigma).lookup x).get_or_else x

@[simp]
lemma list.apply_id_cons [decidable_eq α] (xs : list (α × α)) (x y z : α) :
  list.apply_id ((y, z) :: xs) x = if y = x then z else list.apply_id xs x :=
by simp only [list.apply_id, list.lookup, eq_rec_constant, prod.to_sigma, list.map]; split_ifs; refl

open function _root_.list _root_.prod (to_sigma)
open _root_.nat

lemma list.apply_id_zip_eq [decidable_eq α] {xs ys : list α} (h₀ : list.nodup xs)
  (h₁ : xs.length = ys.length) (x y : α) (i : ℕ)
  (h₂ : xs.nth i = some x) :
  list.apply_id.{u} (xs.zip ys) x = y ↔ ys.nth i = some y :=
begin
  induction xs generalizing ys i,
  case list.nil : ys i h₁ h₂
  { cases h₂ },
  case list.cons : x' xs xs_ih ys i h₁ h₂
  { cases i,
    { injection h₂ with h₀ h₁, subst h₀,
      cases ys,
      { cases h₁ },
      { simp only [list.apply_id, to_sigma, option.get_or_else_some, nth, lookup_cons_eq,
                   zip_cons_cons, list.map], } },
    { cases ys,
      { cases h₁ },
      { cases h₀ with _ _ h₀ h₁,
        simp only [nth, zip_cons_cons, list.apply_id_cons] at h₂ ⊢,
        rw if_neg,
        { apply xs_ih; solve_by_elim [succ.inj] },
        { apply h₀, apply nth_mem h₂ } } } }
end

lemma apply_id_mem_iff [decidable_eq α] {xs ys : list α} (h₀ : list.nodup xs)
  (h₁ : xs ~ ys)
  (x : α) :
  list.apply_id.{u} (xs.zip ys) x ∈ ys ↔ x ∈ xs :=
begin
  simp only [list.apply_id],
  cases h₃ : (lookup x (map prod.to_sigma (xs.zip ys))),
  { dsimp [option.get_or_else],
    rw h₁.mem_iff },
  { have h₂ : ys.nodup := h₁.nodup_iff.1 h₀,
    replace h₁ : xs.length = ys.length := h₁.length_eq,
    dsimp,
    induction xs generalizing ys,
    case list.nil : ys h₃ h₂ h₁
    { contradiction },
    case list.cons : x' xs xs_ih ys h₃ h₂ h₁
    { cases ys with y ys,
      { cases h₃ },
      dsimp [lookup] at h₃, split_ifs at h₃,
      { subst x', subst val,
        simp only [mem_cons_iff, true_or, eq_self_iff_true], },
      { cases h₀ with _ _ h₀ h₅,
        cases h₂ with _ _ h₂ h₄,
        have h₆ := nat.succ.inj h₁,
        specialize @xs_ih h₅ ys h₃ h₄ h₆,
        simp only [ne.symm h, xs_ih, mem_cons_iff, false_or],
        suffices : val ∈ ys, tauto!,
        erw [← option.mem_def, mem_lookup_iff] at h₃,
        simp only [to_sigma, mem_map, heq_iff_eq, prod.exists] at h₃,
        rcases h₃ with ⟨a, b, h₃, h₄, h₅⟩,
        subst a, subst b,
        apply (mem_zip h₃).2,
        simp only [nodupkeys, keys, comp, prod.fst_to_sigma, map_map],
        rwa map_fst_zip _ _ (le_of_eq h₆) } } }
end

lemma list.apply_id_eq_self [decidable_eq α] {xs ys : list α} (x : α) :
  x ∉ xs → list.apply_id.{u} (xs.zip ys) x = x :=
begin
  intro h,
  dsimp [list.apply_id],
  rw lookup_eq_none.2, refl,
  simp only [keys, not_exists, to_sigma, exists_and_distrib_right, exists_eq_right, mem_map,
             comp_app, map_map, prod.exists],
  intros y hy,
  exact h (mem_zip hy).1,
end

lemma apply_id_injective [decidable_eq α] {xs ys : list α} (h₀ : list.nodup xs)
  (h₁ : xs ~ ys) : injective.{u+1 u+1} (list.apply_id (xs.zip ys)) :=
begin
  intros x y h,
  by_cases hx : x ∈ xs;
    by_cases hy : y ∈ xs,
  { rw mem_iff_nth at hx hy,
    cases hx with i hx,
    cases hy with j hy,
    suffices : some x = some y,
    { injection this },
    have h₂ := h₁.length_eq,
    rw [list.apply_id_zip_eq h₀ h₂ _ _ _ hx] at h,
    rw [← hx, ← hy], congr,
    apply nth_injective _ (h₁.nodup_iff.1 h₀),
    { symmetry, rw h,
      rw ← list.apply_id_zip_eq; assumption },
    { rw ← h₁.length_eq,
      rw nth_eq_some at hx,
      cases hx with hx hx',
      exact hx } },
  { rw ← apply_id_mem_iff h₀ h₁ at hx hy,
    rw h at hx,
    contradiction, },
  { rw ← apply_id_mem_iff h₀ h₁ at hx hy,
    rw h at hx,
    contradiction, },
  { rwa [list.apply_id_eq_self, list.apply_id_eq_self] at h; assumption },
end

open total_function (list.to_finmap')
open sampleable

/--
Remove a slice of length `m` at index `n` in a list and a permutation, maintaining the property
that it is a permutation.
-/
def perm.slice [decidable_eq α] (n m : ℕ) :
  (Σ' xs ys : list α, xs ~ ys ∧ ys.nodup) → (Σ' xs ys : list α, xs ~ ys ∧ ys.nodup)
| ⟨xs, ys, h, h'⟩ :=
  let xs' := list.slice n m xs in
  have h₀ : xs' ~ ys.inter xs',
    from perm.slice_inter _ _ h h',
  ⟨xs', ys.inter xs', h₀, nodup_inter_of_nodup _ h'⟩

/--
A lazy list, in decreasing order, of sizes that should be
sliced off a list of length `n`
-/
def slice_sizes : ℕ → lazy_list ℕ+
| n :=
if h : 0 < n then
  have n / 2 < n, from div_lt_self h dec_trivial,
  lazy_list.cons ⟨_, h⟩ (slice_sizes $ n / 2)
else lazy_list.nil

/--
Shrink a permutation of a list, slicing a segment in the middle.

The sizes of the slice being removed start at `n` (with `n` the length
of the list) and then `n / 2`, then `n / 4`, etc down to 1. The slices
will be taken at index `0`, `n / k`, `2n / k`, `3n / k`, etc.
-/
protected def shrink_perm {α : Type} [decidable_eq α] [has_sizeof α] :
  shrink_fn (Σ' xs ys : list α, xs ~ ys ∧ ys.nodup)
| xs := do
  let k := xs.1.length,
  n ← slice_sizes k,
  i ← lazy_list.of_list $ list.fin_range $ k / n,
  have ↑i * ↑n < xs.1.length,
    from nat.lt_of_div_lt_div
      (lt_of_le_of_lt (by simp only [nat.mul_div_cancel, gt_iff_lt, fin.val_eq_coe, pnat.pos]) i.2),
  pure ⟨perm.slice (i*n) n xs,
    by rcases xs with ⟨a,b,c,d⟩; dsimp [sizeof_lt]; unfold_wf; simp only [perm.slice];
       unfold_wf; apply list.sizeof_slice_lt _ _ n.2 _ this⟩

instance [has_sizeof α] : has_sizeof (injective_function α) :=
⟨ λ ⟨xs,_,_⟩, sizeof (xs.map sigma.fst) ⟩

/--
Shrink an injective function slicing a segment in the middle of the domain and removing
the corresponding elements in the codomain, hence maintaining the property that
one is a permutation of the other.
-/
protected def shrink {α : Type} [has_sizeof α] [decidable_eq α] : shrink_fn (injective_function α)
| ⟨xs, h₀, h₁⟩ := do
  ⟨⟨xs', ys', h₀, h₁⟩, h₂⟩ ← injective_function.shrink_perm ⟨_, _, h₀, h₁⟩,
  have h₃ : xs'.length ≤ ys'.length, from le_of_eq (perm.length_eq h₀),
  have h₄ : ys'.length ≤ xs'.length, from le_of_eq (perm.length_eq h₀.symm),
  pure ⟨⟨(list.zip xs' ys').map prod.to_sigma,
    by simp only [comp, map_fst_zip, map_snd_zip, *, prod.fst_to_sigma, prod.snd_to_sigma, map_map],
    by simp only [comp, map_snd_zip, *, prod.snd_to_sigma, map_map] ⟩,
    by revert h₂; dsimp [sizeof_lt]; unfold_wf;
       simp only [has_sizeof._match_1, map_map, comp, map_fst_zip, *, prod.fst_to_sigma];
       unfold_wf; intro h₂; convert h₂ ⟩

/-- Create an injective function from one list and a permutation of that list. -/
protected def mk (xs ys : list α) (h : xs ~ ys) (h' : ys.nodup) : injective_function α :=
have h₀ : xs.length ≤ ys.length, from le_of_eq h.length_eq,
have h₁ : ys.length ≤ xs.length, from le_of_eq h.length_eq.symm,
injective_function.map_to_self (list.to_finmap' (xs.zip ys))
  (by { simp only [list.to_finmap', comp, map_fst_zip, map_snd_zip, *,
                   prod.fst_to_sigma, prod.snd_to_sigma, map_map] })
  (by { simp only [list.to_finmap', comp, map_snd_zip, *, prod.snd_to_sigma, map_map] })

protected lemma injective [decidable_eq α] (f : injective_function α) :
  injective (apply f) :=
begin
  cases f with xs hperm hnodup,
  generalize h₀ : map sigma.fst xs = xs₀,
  generalize h₁ : xs.map (@id ((Σ _ : α, α) → α) $ @sigma.snd α (λ _ : α, α)) = xs₁,
  dsimp [id] at h₁,
  have hxs : xs = total_function.list.to_finmap' (xs₀.zip xs₁),
  { rw [← h₀, ← h₁, list.to_finmap'], clear h₀ h₁ xs₀ xs₁ hperm hnodup,
    induction xs,
    case list.nil
    { simp only [zip_nil_right, map_nil] },
    case list.cons : xs_hd xs_tl xs_ih
    { simp only [true_and, to_sigma, eq_self_iff_true, sigma.eta, zip_cons_cons, list.map],
      exact xs_ih }, },
  revert hperm hnodup,
  rw hxs, intros,
  apply apply_id_injective,
  { rwa [← h₀, hxs, hperm.nodup_iff], },
  { rwa [← hxs, h₀, h₁] at hperm, },
end

instance pi_injective.sampleable_ext : sampleable_ext { f : ℤ → ℤ // function.injective f } :=
{ proxy_repr := injective_function ℤ,
  interp := λ f, ⟨ apply f, f.injective ⟩,
  sample := gen.sized $ λ sz, do
  { let xs' := int.range (-(2*sz+2)) (2*sz + 2),
    ys ← gen.permutation_of xs',
    have Hinj : injective (λ (r : ℕ), -(2*sz + 2 : ℤ) + ↑r),
      from λ x y h, int.coe_nat_inj (add_right_injective _ h),
    let r : injective_function ℤ :=
      injective_function.mk.{0} xs' ys.1 ys.2 (ys.2.nodup_iff.1 $ nodup_map Hinj (nodup_range _)) in
    pure r },
  shrink := @injective_function.shrink ℤ _ _ }

end injective_function

open function

instance injective.testable (f : α → β)
  [I : testable (named_binder "x" $
    ∀ x : α, named_binder "y" $ ∀ y : α, named_binder "H" $ f x = f y → x = y)] :
  testable (injective f) := I

instance monotone.testable [preorder α] [preorder β] (f : α → β)
  [I : testable (named_binder "x" $
    ∀ x : α, named_binder "y" $ ∀ y : α, named_binder "H" $ x ≤ y → f x ≤ f y)] :
  testable (monotone f) := I

instance antitone.testable [preorder α] [preorder β] (f : α → β)
  [I : testable (named_binder "x" $
    ∀ x : α, named_binder "y" $ ∀ y : α, named_binder "H" $ x ≤ y → f y ≤ f x)] :
  testable (antitone f) := I

end slim_check


import data.finsupp.basic

/-- An inductive type from which to index the variables of the mv_polynomials the proof manages -/
@[derive decidable_eq]
inductive vars : Type
| y : vars
| z : vars

-- lemma finsupp_vars_eq_ext (f g : vars →₀ ℕ) : f = g ↔
--   f vars.α = g vars.α ∧ f vars.β = g vars.β ∧ f vars.γ = g vars.γ ∧ f vars.δ = g vars.δ ∧ f vars.x = g vars.x :=
-- begin
--   rw finsupp.ext_iff,
--   split,
--     {
--       intro h,
--       split, exact h vars.α,
--       split, exact h vars.β,
--       split, exact h vars.γ,
--       split, exact h vars.δ,
--       exact h vars.x,
--     },
--     {
--       intro h,
--       intro a,
--       induction a,
--       finish,
--       finish,
--       finish,
--       finish,
--       finish,
--     },
-- end

lemma finsupp_vars_eq_ext (f g : vars →₀ ℕ) : f = g ↔
  f vars.y = g vars.y ∧ f vars.z = g vars.z :=
begin
  rw finsupp.ext_iff,
  split,
    {
      intro h,
      split, exact h vars.y,
      -- split, exact h vars.β,
      -- split, exact h vars.γ,
      exact h vars.z,
    },
    {
      intro h,
      intro a,
      induction a,
      finish,
      finish,
    },
  -- induction,
end


import SciLean.Prelude
import SciLean.Algebra
import SciLean.Mathlib.Data.PowType

def Array.intro {α} (f : Fin n → α) : Array α := Id.run do
  let mut u : Array α := Array.mkEmpty n
  for i in [0:n] do
    u := u.push (f ⟨i, sorry⟩)
  u

def Array.mkConstant {α} (a : α) (n : Nat) : Array α := Array.intro λ i : Fin n => a

def Nat.toInt (n : ℕ) : Int := Int.ofNat n

def applyNTimes {α} (n : Nat) (f : α → α) (a : α) : α := Id.run do
  match n with
  | 0 => a
  | (n + 1) => applyNTimes n f (f a)

namespace SciLean

instance : PowType ℤ where
  powType n := {u : Array ℤ // u.size = n}
  intro {n} f := Id.run do
    let mut u : Array ℤ := Array.mkEmpty n
    for i in [0:n] do
      u := u.push (f ⟨i, sorry⟩)
    ⟨u, sorry⟩
  get v i := v.1.get ⟨i, by rw[v.2] apply i.2⟩
  set v i val := ⟨v.1.set ⟨i, by rw[v.2] apply i.2⟩ val, sorry⟩
  ext := sorry

namespace Tree

inductive Node (Data : Type) : Type where
| empty : Node Data
| leaf  (data : Data) : Node Data
| node  (children : Array (Node Data)) : Node Data

  namespace Node

  def IsEmpty (node : Node Data) : Prop :=
    match node with
    | .empty => True
    | _ => False

  instance (node : Node Data) : Decidable (node.IsEmpty) :=
    match node with
    | .empty  => isTrue (by simp[IsEmpty] done)
    | .leaf _ => isFalse (by simp[IsEmpty] done)
    | .node _ => isFalse (by simp[IsEmpty] done)

  def IsLeaf (node : Node Data) : Prop :=
    match node with
    | .leaf _ => True
    | _ => False

  instance (node : Node Data) : Decidable (node.IsLeaf) :=
    match node with
    | .leaf _ => isTrue (by simp[IsLeaf] done)
    | .empty  => isFalse (by simp[IsLeaf] done)
    | .node _ => isFalse (by simp[IsLeaf] done)

  inductive Branching (n : Nat) : Node Data → Prop where
    | empty : Branching n empty
    | leaf  : (d : Data) → Branching n (leaf d)
    | node  : {cs : Array (Node Data)} → cs.size = n → (∀ i, Branching n (cs.get i)) → Branching n (node cs)

  -- Leafs are only allowed at a specified depths
  -- The tree also can not exceed the depth
  inductive LeafsAtDepth : Nat → Node Data → Prop where
    | empty (n : Nat) : LeafsAtDepth n empty
    | leaf  : (d : Data) → LeafsAtDepth 0 (leaf d)
    | node  : {cs : Array (Node Data)} → (n : Nat) → (∀ i, LeafsAtDepth n (cs.get i)) → LeafsAtDepth (n+1) (node cs)

  theorem not_a_leaf (node : Node Data) : node.LeafsAtDepth (d+1) → ¬node.IsLeaf := sorry

  end Node

end Tree

/-
  -- Grid Tree --
  ---------------

  Grid tree is quadtree/octree over integer grid.
-/

namespace Tree

  structure GNode (Data : Type) (m d : Nat) where
    node : Node Data
    depth_and_branching : node.Branching m ∧ node.LeafsAtDepth d

  namespace GNode

  -- def IsEmpty (node : GNode Data m d) : Prop := node.1.IsEmpty
  -- instance (node : GNode Data m d) : Decidable (node.IsEmpty) := by simp[IsEmpty]; infer_instance; done

  -- def IsLeaf (node : GNode Data m d) : Prop := node.1.IsLeaf
  -- instance (node : GNode Data m d) : Decidable (node.IsLeaf) := by simp[IsLeaf]; infer_instance; done

  -- def getData {m d} (node : GNode Data m d) (h : node.IsLeaf) : Data :=
  --   match node with
  --   | ⟨.leaf data, _, _⟩ => data

  -- def getData! {m d} (node : GNode Data m d) (default : Data) : Data :=
  --   match node with
  --   | ⟨.leaf data, _, _⟩ => data
  --   | _ => default

  -- def modifyData {m} (node : GNode Data m 0) (f : Data → Data) [Inhabited Data] : GNode Data m 0 :=
  --   match node with
  --   | ⟨.leaf data, _, _⟩ => ⟨.leaf (f data), Node.Branching.leaf (f data), Node.LeafsAtDepth.leaf (f data)⟩
  --   | ⟨.empty, _, _⟩ => ⟨.leaf (f default), Node.Branching.leaf (f default), Node.LeafsAtDepth.leaf (f default)⟩

  -- def setData {m} (node : GNode Data m 0) (data : Data) [Inhabited Data] : GNode Data m 0 :=
  --   node.modifyData (λ _ => data)

  -- def getChild {m d} (node : GNode Data m (d+1)) (i : Fin m) : GNode Data m d :=
  --   match node.1 with
  --   | .node ch => ⟨ch.get ⟨i.1, sorry⟩, sorry⟩
  --   | _ => ⟨.empty, sorry⟩

  -- def modifyChild {m d} (node : GNode Data m (d+1)) (i : Fin m) (f : GNode Data m d → GNode Data m d) : GNode Data m (d+1) :=
  --   match node with
  --   | ⟨.node ch, _, _⟩ =>
  --     let child := f ⟨ch.get ⟨i.1, sorry⟩, sorry⟩
  --     ⟨.node (ch.set ⟨i.1, sorry⟩ child.1), sorry⟩
  --   | ⟨.empty, _, _⟩ => Id.run do
  --     let ch : Array (Node Data) := (Array.mkConstant .empty m)
  --     let child :=  f ⟨.empty, sorry⟩
  --     ⟨.node (ch.set ⟨i.1, sorry⟩ child.1), sorry⟩

  -- def setChild {m d} (node : GNode Data m (d+1)) (i : Fin m) (child : GNode Data m d) : GNode Data m (d+1) :=
  --   node.modifyChild i λ _ => child

  -- Path from a `node : GNode m d` to leaf node
  structure Index (m d : Nat) where
    path : List (Fin m)
    h_len : path.length = d

  instance (m d : Nat) : ToString (Index m d) := ⟨λ i => toString i.1⟩

  def Index.head {m d} (idx : Index m (d+1)) : Fin m := idx.path.head sorry
  def Index.tail {m d} (idx : Index m (d+1)) : Index m d := ⟨idx.path.tail!, sorry⟩

  def getData {m d} (node : GNode Data m d) (idx : Index m d) [Inhabited Data] : Data :=
    match d, node, idx with
    | 0, ⟨.leaf data, _⟩, _ => data
    | 0, ⟨.empty, _⟩, _ => default
    | (d+1), ⟨.empty, _⟩, _ => default
    | (d+1), ⟨.node ch, b, _⟩, ⟨id::ids, h⟩ =>
      let child : GNode Data m d := ⟨ch.get ⟨id, by cases b; rename_i a _; rw[a]; apply id.2;⟩, sorry, sorry⟩
      child.getData ⟨ids, sorry⟩

  def modifyData {m d} (node : GNode Data m d) (idx : Index m d) (f : Data → Data) : GNode Data m d :=
    match d, node, idx with
    |     0, ⟨.leaf data, _⟩, _ => ⟨.leaf (f data), sorry⟩
    |     _,     ⟨.empty, _⟩, _ => ⟨.empty, sorry⟩
    | (d+1),   ⟨.node ch, _⟩, ⟨id::ids, h⟩ =>
      let child : GNode Data m d := ⟨ch.get ⟨id, sorry⟩, sorry⟩
      -- reset `dir` child in the array `ch` to decrement reference counter
      let ch := ch.set ⟨id, sorry⟩ .empty
      -- modify component, hopefully here we do inplace modification
      let child := modifyData child ⟨ids, sorry⟩ f
      ⟨.node (ch.set ⟨id, sorry⟩ child.1), sorry⟩

  def setData {m d} (node : GNode Data m d) (idx : Index m d) (data : Data) : GNode Data m d :=
    match d, node, idx with
    | 0, ⟨.leaf data, _, _⟩, _ => ⟨.leaf data, sorry⟩
    | 0, ⟨.empty, _, _⟩, _ => ⟨.leaf data, sorry⟩
    | (d+1), ⟨.empty, _, _⟩, ⟨id::ids, h⟩ =>
      let child : GNode Data m d := setData ⟨.empty, sorry⟩ ⟨ids, sorry⟩ data
      let ch : Array (Node Data) := Array.mkConstant .empty m
      ⟨.node (ch.set ⟨id, sorry⟩ child.1), sorry⟩
    | (d+1), ⟨.node ch, b, _⟩, ⟨id::ids, h⟩ =>
      let child : GNode Data m d := ⟨ch.get ⟨id, sorry⟩, sorry⟩
      -- reset `dir` child in the array `ch` to decrement reference counter
      let ch := ch.set ⟨id, sorry⟩ .empty
      -- modify component, hopefully here we do inplace modification
      let child := setData child ⟨ids, sorry⟩ data
      ⟨.node (ch.set ⟨id, sorry⟩ child.1), sorry⟩

  def activate {m d} (node : GNode Data m d) (idx : Index m d) [Inhabited Data] : GNode Data m d :=
    node.setData idx default

  def setChild {m d} (node : GNode Data m (d+1)) (i : Fin m) (child : GNode Data m d) : GNode Data m (d+1) :=
    match node with
    | ⟨.empty, _⟩ =>
      let ch : Array (Node Data) := Array.mkConstant .empty m
      ⟨.node (ch.set ⟨i, sorry⟩ child.1), sorry⟩
    | ⟨.node ch, _⟩ =>
      ⟨.node (ch.set ⟨i, sorry⟩ child.1), sorry⟩

  end GNode

end Tree

  -- Represents box with side length `2^depth` and minimal corner `min`
  structure Shape (dim : ℕ) where
    min   : ℤ^dim
    depth : ℕ

  def Shape.size {dim} (ns : Shape dim) : ℕ := (2:ℕ)^(ns.depth)

  def Shape.max {dim} (ns : Shape dim) : ℤ^dim :=
    ns.min + (ns.size-1).toInt * (1:ℤ^dim)

  def Shape.Contains {dim} (ns : Shape dim) (p : ℤ^dim) : Prop :=
    ns.min ≤ p ∧ p ≤ ns.max

  instance {dim} (ns : Shape dim) (p : ℤ^dim) : Decidable (ns.Contains p) :=
    if h : (ns.min ≤ p) ∧ (p ≤ ns.max) then isTrue h else isFalse h

  -- Each box is diveded to 2^dim boxed of half size, they are index with `idx : Fin ((2:ℕ)^dim)`
  -- This function converts this index to directional vector(consisting of 0 and 1) from `min` of a box to `min` of smaller box.
  def Shape.idxToDir {dim : Nat} (idx : Fin ((2:ℕ)^dim)) : ℤ^dim :=
    PowType.intro λ i => ((idx.1 >>> i.1) &&& 1).toInt

  def Shape.child {dim} (s : Shape dim) (idx : Fin ((2:ℕ)^dim)) : Shape dim :=
    if s.depth = 0 then
      s
    else
      let r := (s.size / 2).toInt
      ⟨s.min + r * idxToDir idx, s.depth - 1⟩

  -- Gets a bigger box whose `idx` child is `s`
  def Shape.parent {dim} (s : Shape dim) (idx : Fin ((2:ℕ)^dim)) : Shape dim :=
    ⟨s.min - s.size.toInt * idxToDir idx, s.depth + 1⟩

  -- When we want to create parent that contains point `p`
  -- Gives you (idx, n) telling you that you have to call `parent idx` `n`-times to get a box
  -- containing `p`
  def Shape.parentIdx {dim : Nat} (s : Shape dim) (p : ℤ^dim) : Fin ((2:ℕ)^dim) × ℕ := Id.run do
    let p := p - s.min
    let mut idx : ℕ := 0
    let mut n : ℕ := 0
    for i in [0:dim] do
      let i := !i
      if p[i] < 0 then
        idx := idx ||| (1 <<< i.1)
      n := Nat.max n (Nat.log2 ((Int.fdiv (p[i]) s.size).natAbs * 2))
    (!idx, n)

  --- Applying parent `n` times with `idx` given from `parentIdx` ensures that
  --- point `p` is contained in the resulting box
  theorem Shape.parentIdx_parent {dim} (s : Shape dim) (p : ℤ^dim)
    : let (idx, n) := s.parentIdx p
      let f := λ s' => Shape.parent s' idx
      (applyNTimes n f s).Contains p
    := sorry

  theorem Shape.parentIdx_idxToDir {dim : ℕ} (s : Shape dim) (idx : Fin ((2:ℕ)^dim))
    : (parentIdx s (s.min - idxToDir idx)).1 = idx := sorry

  -- These should hold
  theorem Shape.child_parent {dim} (s : Shape dim) (idx : Fin ((2:ℕ)^dim))
    : s.depth ≠ 0 → (s.child idx).parent idx = s :=
  by
    intro h
    simp [parent,child,h,size]
    rw [!?(s.depth - 1 + 1 = s.depth)]
    rw [!?(((2:ℕ)^s.depth) / 2 = (2:ℕ)^(s.depth - 1))]
    -- Now it is obvious
    admit

  theorem Shape.parent_child {dim} (s : Shape dim) (idx : Fin ((2:ℕ)^dim))
    : (s.parent idx).child idx = s :=
  by
    simp [parent,child,size]
    rw [!?(s.depth + 1 - 1 = s.depth)]
    rw [!?(((2:ℕ)^(s.depth + 1)) / 2 = (2:ℕ)^(s.depth))]
    -- Now it is obvious
    admit

  -- Sequence on how to recurse the tree with shape `ns` to reach point `p`
  -- Effectively preforming bit-wise transposition of `p-s.min`
  def Shape.getIndex {dim} (s : Shape dim) (p : ℤ^dim) (h : s.Contains p)
    : Tree.GNode.Index ((2:ℕ)^dim) s.depth := Id.run do
    let p := p - s.min
    let mut l : List (Fin ((2:ℕ)^dim)) := []
    for i in [0:s.depth] do
      let mut c : Nat := 0
      for j in [0:dim] do
        let pj := p[!j].toNat
        c := c ||| (((pj >>> i) &&& 1) <<< j)
      l := (!c) :: l
    ⟨l,sorry⟩

  def s : Shape 2 := ⟨^[1,-1],2⟩

  #eval s.size
  #eval s.min
  #eval s.max
  #eval s.getIndex  ^[4,4] sorry
  #eval s.parentIdx ^[1,7]
  -- example : (Shape.mk ^[(0:ℤ),0] 2).parentIdx ^[(15:ℤ),-13] = (2,2) := by rfl

----------------------------------------------------------------------

  structure GridTree (Data : Type) (dim : Nat) where
    shape : Shape dim
    root  : Tree.GNode Data ((2:ℕ)^dim) shape.depth

  namespace GridTree

    def Contains {dim} (tree : GridTree Data dim) (p : ℤ^dim) : Prop :=
      tree.shape.Contains p

    instance {dim} (tree : GridTree Data dim) (p : ℤ^dim) : Decidable (tree.Contains p) :=
      by simp[Contains]; infer_instance; done

    def setContained {dim} (tree : GridTree Data dim) (p : ℤ^dim) (data : Data) (h : tree.Contains p) : GridTree Data dim :=
      let idx := tree.shape.getIndex p h
      ⟨tree.shape, tree.root.setData idx data⟩

    -- -- Makes sure that the tree contains p
    def extend {dim} (tree : GridTree Data dim) (p : ℤ^dim) : GridTree Data dim := Id.run do
      let (idx, n) := tree.shape.parentIdx p
      let mut tree := tree
      for i in [0:n] do
        let ⟨shape, root⟩ := tree
        tree := ⟨shape.parent idx, Tree.GNode.setChild ⟨.empty, sorry⟩ idx root⟩
      tree

    theorem extend_Contains  {dim} (tree : GridTree Data dim) (p : ℤ^dim)
      : (tree.extend p).Contains p := sorry

    def set {dim} (tree : GridTree Data dim) (p : ℤ^dim) (data : Data) : GridTree Data dim := Id.run do
      tree |>.extend p |>.setContained p data (extend_Contains _ _)

    -- {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (f : β → α → m β) (init : β) (as : Array α) (start := 0) (stop := as.size) : m β
    --- {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : Array α) (f : Fin as.size → α → m β) : m (Array β)

    def OrderIndependent {dim : ℕ} {Data : Type} {m : Type v → Type w} [Monad m]
      (f : (ℤ^dim) → Data → m PUnit) : Prop
      := ∀ p p' d d', (do f p d; f p' d') = (do f p' d'; f p d : m PUnit)

    def forIdxM {dim : ℕ} {m : Type v → Type w} [Monad m]
      (f : (ℤ^dim) → Data → m PUnit) (tree : GridTree Data dim) (h : OrderIndependent f) : m PUnit := sorry

    -- Run over all points in a ball, i.e. for all points `p` such that: `∥p-center∥² ≤ radius2`
    def forBallIdxM {dim : ℕ} {m : Type v → Type w} [Monad m]
      (f : (ℤ^dim) → Data → m PUnit) (tree : GridTree Data dim) (center : ℤ^dim) (radius2 : ℕ) (h : OrderIndependent f) : m PUnit := sorry

    theorem forBallIdxM_forIdxM {dim : ℕ} {m : Type v → Type w} [Monad m]
      (f : (ℤ^dim) → Data → m PUnit) (tree : GridTree Data dim) (center : ℤ^dim) (radius2 : ℕ) (h : OrderIndependent f)
      : (do tree.forBallIdxM f center radius2 h)
        =
        (do tree.forIdxM
             (λ p d =>
               if (∑ i, (p[i] - center[i])^2) ≤ radius2
               then f p d
               else pure PUnit.unit) sorry : m PUnit)
        := sorry

    -- Run over all point in a box, i.e. for all point `p` such that:
    def forBoxIdxM {dim : ℕ} {m : Type v → Type w} [Monad m]
      (f : (ℤ^dim) → Data → m PUnit) (tree : GridTree Data dim) (min max : ℤ^dim) (h : OrderIndependent f) : m PUnit := sorry

    theorem forBoxIdxM_forIdxM {dim : ℕ} {m : Type v → Type w} [Monad m]
      (f : (ℤ^dim) → Data → m PUnit) (tree : GridTree Data dim) (min max : ℤ^dim) (h : OrderIndependent f)
      : (do tree.forBoxIdxM f min max h)
        =
        (do tree.forIdxM
             (λ p d =>
               if (min ≤ p) ∧ (p ≤ max)
               then f p d
               else pure PUnit.unit) sorry : m PUnit)
        := sorry

    -- Somehow run over pairs
    -- How to formulate order independence?
    -- Probably:
    --    1. Unorder pairs:      (do f p1 d1 p2 d2) = (do f p2 d2 p1 d2)
    --    2. Order independence: (do f p1 d1 p2 d2; f p1' d1' p2' d2') = (do f p1' d1' p2' d2'; f p1 d1 p2 d2)
    -- def forPairsIdxM

  end GridTree

 -- variable {dim : ℕ} (u v : ℤ^dim)

  -- def set (tree : Tree Data dim) (p : ℤ^dim) (data : Data) : Tree Data dim :=
  --   if tree.root.isEmpty then
  --     ⟨(Node.mkWithEmptyChildren dim), ⟨p, 1⟩⟩
  --   else
  --     let r := (2:ℕ)^depth
  --     sorry
  -- mutual

  -- inductive Node (Data : Type) : (dim : Nat) → (level : Nat) → Type where
  -- | empty (lvl : Nat) : Node Data dim lvl
  -- | node  (lvl : Nat) (children1 : Children Data dim lvl) : Node Data dim (lvl+1)
  -- | leaf  (data : Data) : Node Data dim 0

  -- inductive Children (Data : Type) : (dim : Nat) → (level : Nat) → Type where
  -- | childs {lvl : Nat} (left right : Node Data dim lvl) : Children Data dim lvl
  -- | next   {lvl : Nat} (left right : Children Data d lvl) : Children Data (d+1) lvl

  -- end

---------------------------------------------------------------------


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.applicative
import control.traversable.basic

/-!
# Traversing collections

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

This file proves basic properties of traversable and applicative functors and defines
`pure_transformation F`, the natural applicative transformation from the identity functor to `F`.

## References

Inspired by [The Essence of the Iterator Pattern][gibbons2009].
-/

universes u

open is_lawful_traversable
open function (hiding comp)
open functor

attribute [functor_norm] is_lawful_traversable.naturality
attribute [simp] is_lawful_traversable.id_traverse

namespace traversable

variable {t : Type u → Type u}
variables [traversable t] [is_lawful_traversable t]
variables F G : Type u → Type u

variables [applicative F] [is_lawful_applicative F]
variables [applicative G] [is_lawful_applicative G]
variables {α β γ : Type u}
variables g : α → F β
variables h : β → G γ
variables f : β → γ

/-- The natural applicative transformation from the identity functor
to `F`, defined by `pure : Π {α}, α → F α`. -/
def pure_transformation : applicative_transformation id F :=
{ app := @pure F _,
  preserves_pure' := λ α x, rfl,
  preserves_seq' := λ α β f x, by { simp only [map_pure, seq_pure], refl } }

@[simp]

variables {F G} (x : t β)

lemma map_eq_traverse_id : map f = @traverse t _ _ _ _ _ (id.mk ∘ f) :=
funext $ λ y, (traverse_eq_map_id f y).symm

theorem map_traverse (x : t α) : map f <$> traverse g x = traverse (map f ∘ g) x :=
begin
  rw @map_eq_traverse_id t _ _ _ _ f,
  refine (comp_traverse (id.mk ∘ f) g x).symm.trans _,
  congr, apply comp.applicative_comp_id
end

theorem traverse_map (f : β → F γ) (g : α → β) (x : t α) :
  traverse f (g <$> x) = traverse (f ∘ g) x :=
begin
  rw @map_eq_traverse_id t _ _ _ _ g,
  refine (comp_traverse f (id.mk ∘ g) x).symm.trans _,
  congr, apply comp.applicative_id_comp
end

lemma pure_traverse (x : t α) : traverse pure x = (pure x : F (t α)) :=
by have : traverse pure x = pure (traverse id.mk x) :=
     (naturality (pure_transformation F) id.mk x).symm;
   rwa id_traverse at this

lemma id_sequence (x : t α) : sequence (id.mk <$> x) = id.mk x :=
by simp [sequence, traverse_map, id_traverse]; refl

lemma comp_sequence (x : t (F (G α))) :
  sequence (comp.mk <$> x) = comp.mk (sequence <$> sequence x) :=
by simp [sequence, traverse_map]; rw ← comp_traverse; simp [map_id]

lemma naturality' (η : applicative_transformation F G) (x : t (F α)) :
  η (sequence x) = sequence (@η _ <$> x) :=
by simp [sequence, naturality, traverse_map]

@[functor_norm]
lemma traverse_id : traverse id.mk = (id.mk : t α → id (t α)) :=
by { ext, exact id_traverse _ }

@[functor_norm]
lemma traverse_comp (g : α → F β) (h : β → G γ) :
  traverse (comp.mk ∘ map h ∘ g) =
  (comp.mk ∘ map (traverse h) ∘ traverse g : t α → comp F G (t γ)) :=
by { ext, exact comp_traverse _ _ _ }

lemma traverse_eq_map_id' (f : β → γ) : traverse (id.mk ∘ f) = id.mk ∘ (map f : t β → t γ) :=
by { ext, exact traverse_eq_map_id _ _ }

-- @[functor_norm]
lemma traverse_map' (g : α → β) (h : β → G γ) :
  traverse (h ∘ g) = (traverse h ∘ map g : t α → G (t γ)) :=
by { ext, rw [comp_app, traverse_map] }

lemma map_traverse' (g : α → G β) (h : β → γ) :
  traverse (map h ∘ g) = (map (map h) ∘ traverse g : t α → G (t γ)) :=
by { ext, rw [comp_app, map_traverse] }

lemma naturality_pf (η : applicative_transformation F G) (f : α → F β) :
  traverse (@η _ ∘ f) = @η _ ∘ (traverse f : t α → F (t β)) :=
by { ext, rw [comp_app, naturality] }

end traversable


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.concrete_category.basic
import category_theory.functor.reflects_isomorphisms

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

A `forget₂ C D` forgetful functor between concrete categories `C` and `D`
whose forgetful functors both reflect isomorphisms, itself reflects isomorphisms.
-/

universes u

namespace category_theory

instance : reflects_isomorphisms (forget (Type u)) :=
{ reflects := λ X Y f i, i }

variables (C : Type (u+1)) [category C] [concrete_category.{u} C]
variables (D : Type (u+1)) [category D] [concrete_category.{u} D]

/--
A `forget₂ C D` forgetful functor between concrete categories `C` and `D`
where `forget C` reflects isomorphisms, itself reflects isomorphisms.
-/
-- This should not be an instance, as it causes a typeclass loop
-- with `category_theory.has_forget_to_Type`
lemma reflects_isomorphisms_forget₂ [has_forget₂ C D] [reflects_isomorphisms (forget C)] :
  reflects_isomorphisms (forget₂ C D) :=
{ reflects := λ X Y f i,
  begin
    resetI,
    haveI i' : is_iso ((forget D).map ((forget₂ C D).map f)) := functor.map_is_iso (forget D) _,
    haveI : is_iso ((forget C).map f) :=
    begin
      have := has_forget₂.forget_comp,
      dsimp at this,
      rw ←this,
      exact i',
    end,
    apply is_iso_of_reflects_iso f (forget C),
  end }

end category_theory