/-
Copyright (c) 2021 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth
-/
import analysis.inner_product_space.rayleigh
import analysis.inner_product_space.pi_L2

/-! # Spectral theory of self-adjoint operators

This file covers the spectral theory of self-adjoint operators on an inner product space.

The first part of the file covers general properties, true without any condition on boundedness or
compactness of the operator or finite-dimensionality of the underlying space, notably:
* `is_self_adjoint.conj_eigenvalue_eq_self`: the eigenvalues are real
* `is_self_adjoint.orthogonal_family_eigenspaces`: the eigenspaces are orthogonal
* `is_self_adjoint.orthogonal_supr_eigenspaces`: the restriction of the operator to the mutual
  orthogonal complement of the eigenspaces has, itself, no eigenvectors

The second part of the file covers properties of self-adjoint operators in finite dimension.
Letting `T` be a self-adjoint operator on a finite-dimensional inner product space `T`,
* The definition `is_self_adjoint.diagonalization` provides a linear isometry equivalence `E` to
  the direct sum of the eigenspaces of `T`.  The theorem
  `is_self_adjoint.diagonalization_apply_self_apply` states that, when `T` is transferred via this
  equivalence to an operator on the direct sum, it acts diagonally.
* The definition `is_self_adjoint.eigenvector_basis` provides an orthonormal basis for `E`
  consisting of eigenvectors of `T`, with `is_self_adjoint.eigenvalues` giving the corresponding
  list of eigenvalues, as real numbers.  The definition `is_self_adjoint.diagonalization_basis`
  gives the associated linear isometry equivalence from `E` to Euclidean space, and the theorem
  `is_self_adjoint.diagonalization_basis_apply_self_apply` states that, when `T` is transferred via
  this equivalence to an operator on Euclidean space, it acts diagonally.
These are forms of the *diagonalization theorem* for self-adjoint operators on finite-dimensional
inner product spaces.

## TODO

Spectral theory for compact self-adjoint operators, bounded self-adjoint operators.

## Tags

self-adjoint operator, spectral theorem, diagonalization theorem

-/

variables {𝕜 : Type*} [is_R_or_C 𝕜] [dec_𝕜 : decidable_eq 𝕜]
variables {E : Type*} [inner_product_space 𝕜 E]

local notation `⟪`x`, `y`⟫` := @inner 𝕜 E _ x y

local attribute [instance] fact_one_le_two_real

open_locale big_operators complex_conjugate
open module.End

namespace is_self_adjoint

variables {T : E →ₗ[𝕜] E} (hT : is_self_adjoint T)
include hT

/-- A self-adjoint operator preserves orthogonal complements of its eigenspaces. -/
lemma invariant_orthogonal_eigenspace (μ : 𝕜) (v : E) (hv : v ∈ (eigenspace T μ)ᗮ) :
  T v ∈ (eigenspace T μ)ᗮ :=
begin
  intros w hw,
  have : T w = (μ:𝕜) • w := by rwa mem_eigenspace_iff at hw,
  simp [← hT w, this, inner_smul_left, hv w hw]
end

/-- The eigenvalues of a self-adjoint operator are real. -/
lemma conj_eigenvalue_eq_self {μ : 𝕜} (hμ : has_eigenvalue T μ) : conj μ = μ :=
begin
  obtain ⟨v, hv₁, hv₂⟩ := hμ.exists_has_eigenvector,
  rw mem_eigenspace_iff at hv₁,
  simpa [hv₂, inner_smul_left, inner_smul_right, hv₁] using hT v v
end

/-- The eigenspaces of a self-adjoint operator are mutually orthogonal. -/
lemma orthogonal_family_eigenspaces : orthogonal_family 𝕜 (eigenspace T) :=
begin
  intros μ ν hμν v hv w hw,
  by_cases hv' : v = 0,
  { simp [hv'] },
  have H := hT.conj_eigenvalue_eq_self (has_eigenvalue_of_has_eigenvector ⟨hv, hv'⟩),
  rw mem_eigenspace_iff at hv hw,
  refine or.resolve_left _ hμν.symm,
  simpa [inner_smul_left, inner_smul_right, hv, hw, H] using (hT v w).symm
end

lemma orthogonal_family_eigenspaces' : orthogonal_family 𝕜 (λ μ : eigenvalues T, eigenspace T μ) :=
hT.orthogonal_family_eigenspaces.comp subtype.coe_injective

/-- The mutual orthogonal complement of the eigenspaces of a self-adjoint operator on an inner
product space is an invariant subspace of the operator. -/
lemma orthogonal_supr_eigenspaces_invariant ⦃v : E⦄ (hv : v ∈ (⨆ μ, eigenspace T μ)ᗮ) :
  T v ∈ (⨆ μ, eigenspace T μ)ᗮ :=
begin
  rw ← submodule.infi_orthogonal at ⊢ hv,
  exact T.infi_invariant hT.invariant_orthogonal_eigenspace v hv
end

/-- The mutual orthogonal complement of the eigenspaces of a self-adjoint operator on an inner
product space has no eigenvalues. -/
lemma orthogonal_supr_eigenspaces (μ : 𝕜) :
  eigenspace (T.restrict hT.orthogonal_supr_eigenspaces_invariant) μ = ⊥ :=
begin
  set p : submodule 𝕜 E := (⨆ μ, eigenspace T μ)ᗮ,
  refine eigenspace_restrict_eq_bot hT.orthogonal_supr_eigenspaces_invariant _,
  have H₂ : p ≤ (eigenspace T μ)ᗮ := submodule.orthogonal_le (le_supr _ _),
  exact (eigenspace T μ).orthogonal_disjoint.mono_right H₂
end

/-! ### Finite-dimensional theory -/

variables [finite_dimensional 𝕜 E]

/-- The mutual orthogonal complement of the eigenspaces of a self-adjoint operator on a
finite-dimensional inner product space is trivial. -/
lemma orthogonal_supr_eigenspaces_eq_bot : (⨆ μ, eigenspace T μ)ᗮ = ⊥ :=
begin
  have hT' : is_self_adjoint _ := hT.restrict_invariant hT.orthogonal_supr_eigenspaces_invariant,
  -- a self-adjoint operator on a nontrivial inner product space has an eigenvalue
  haveI := hT'.subsingleton_of_no_eigenvalue_finite_dimensional hT.orthogonal_supr_eigenspaces,
  exact submodule.eq_bot_of_subsingleton _,
end

lemma orthogonal_supr_eigenspaces_eq_bot' : (⨆ μ : eigenvalues T, eigenspace T μ)ᗮ = ⊥ :=
show (⨆ μ : {μ // (eigenspace T μ) ≠ ⊥}, eigenspace T μ)ᗮ = ⊥,
by rw [supr_ne_bot_subtype, hT.orthogonal_supr_eigenspaces_eq_bot]

include dec_𝕜

/-- The eigenspaces of a self-adjoint operator on a finite-dimensional inner product space `E` give
an internal direct sum decomposition of `E`. -/
lemma direct_sum_submodule_is_internal :
  direct_sum.submodule_is_internal (λ μ : eigenvalues T, eigenspace T μ) :=
hT.orthogonal_family_eigenspaces'.submodule_is_internal_iff.mpr
  hT.orthogonal_supr_eigenspaces_eq_bot'

section version1

/-- Isometry from an inner product space `E` to the direct sum of the eigenspaces of some
self-adjoint operator `T` on `E`. -/
noncomputable def diagonalization : E ≃ₗᵢ[𝕜] pi_Lp 2 (λ μ : eigenvalues T, eigenspace T μ) :=
hT.direct_sum_submodule_is_internal.isometry_L2_of_orthogonal_family
  hT.orthogonal_family_eigenspaces'

@[simp] lemma diagonalization_symm_apply (w : pi_Lp 2 (λ μ : eigenvalues T, eigenspace T μ)) :
  hT.diagonalization.symm w = ∑ μ, w μ :=
hT.direct_sum_submodule_is_internal.isometry_L2_of_orthogonal_family_symm_apply
  hT.orthogonal_family_eigenspaces' w

/-- *Diagonalization theorem*, *spectral theorem*; version 1: A self-adjoint operator `T` on a
finite-dimensional inner product space `E` acts diagonally on the decomposition of `E` into the
direct sum of the eigenspaces of `T`. -/
lemma diagonalization_apply_self_apply (v : E) (μ : eigenvalues T) :
  hT.diagonalization (T v) μ = (μ : 𝕜) • hT.diagonalization v μ :=
begin
  suffices : ∀ w : pi_Lp 2 (λ μ : eigenvalues T, eigenspace T μ),
    (T (hT.diagonalization.symm w)) = hT.diagonalization.symm (λ μ, (μ : 𝕜) • w μ),
  { simpa [linear_isometry_equiv.symm_apply_apply, -is_self_adjoint.diagonalization_symm_apply]
      using congr_arg (λ w, hT.diagonalization w μ) (this (hT.diagonalization v)) },
  intros w,
  have hwT : ∀ μ : eigenvalues T, T (w μ) = (μ : 𝕜) • w μ,
  { intros μ,
    simpa [mem_eigenspace_iff] using (w μ).prop },
  simp [hwT],
end

end version1

section version2
variables {n : ℕ} (hn : finite_dimensional.finrank 𝕜 E = n)

/-- A choice of orthonormal basis of eigenvectors for self-adjoint operator `T` on a
finite-dimensional inner product space `E`.

TODO Postcompose with a permutation so that these eigenvectors are listed in increasing order of
eigenvalue. -/
noncomputable def eigenvector_basis : basis (fin n) 𝕜 E :=
hT.direct_sum_submodule_is_internal.subordinate_orthonormal_basis hn

lemma eigenvector_basis_orthonormal : orthonormal 𝕜 (hT.eigenvector_basis hn) :=
hT.direct_sum_submodule_is_internal.subordinate_orthonormal_basis_orthonormal hn
  hT.orthogonal_family_eigenspaces'

/-- The sequence of real eigenvalues associated to the standard orthonormal basis of eigenvectors
for a self-adjoint operator `T` on `E`.

TODO Postcompose with a permutation so that these eigenvalues are listed in increasing order. -/
noncomputable def eigenvalues (i : fin n) : ℝ :=
@is_R_or_C.re 𝕜 _ $ hT.direct_sum_submodule_is_internal.subordinate_orthonormal_basis_index hn i

lemma has_eigenvector_eigenvector_basis (i : fin n) :
  has_eigenvector T (hT.eigenvalues hn i) (hT.eigenvector_basis hn i) :=
begin
  let v : E := hT.eigenvector_basis hn i,
  let μ : 𝕜 := hT.direct_sum_submodule_is_internal.subordinate_orthonormal_basis_index hn i,
  change has_eigenvector T (is_R_or_C.re μ) v,
  have key : has_eigenvector T μ v,
  { have H₁ : v ∈ eigenspace T μ,
    { exact hT.direct_sum_submodule_is_internal.subordinate_orthonormal_basis_subordinate hn i },
    have H₂ : v ≠ 0 := (hT.eigenvector_basis_orthonormal hn).ne_zero i,
    exact ⟨H₁, H₂⟩ },
  have re_μ : ↑(is_R_or_C.re μ) = μ,
  { rw ← is_R_or_C.eq_conj_iff_re,
    exact hT.conj_eigenvalue_eq_self (has_eigenvalue_of_has_eigenvector key) },
  simpa [re_μ] using key,
end

attribute [irreducible] eigenvector_basis eigenvalues

@[simp] lemma apply_eigenvector_basis (i : fin n) :
  T (hT.eigenvector_basis hn i) = (hT.eigenvalues hn i : 𝕜) • hT.eigenvector_basis hn i :=
mem_eigenspace_iff.mp (hT.has_eigenvector_eigenvector_basis hn i).1

/-- An isometry from an inner product space `E` to Euclidean space, induced by a choice of
orthonormal basis of eigenvectors for a self-adjoint operator `T` on `E`. -/
noncomputable def diagonalization_basis : E ≃ₗᵢ[𝕜] euclidean_space 𝕜 (fin n) :=
(hT.eigenvector_basis hn).isometry_euclidean_of_orthonormal (hT.eigenvector_basis_orthonormal hn)

@[simp] lemma diagonalization_basis_symm_apply (w : euclidean_space 𝕜 (fin n)) :
  (hT.diagonalization_basis hn).symm w = ∑ i, w i • hT.eigenvector_basis hn i :=
by simp [diagonalization_basis]

/-- *Diagonalization theorem*, *spectral theorem*; version 2: A self-adjoint operator `T` on a
finite-dimensional inner product space `E` acts diagonally on the identification of `E` with
Euclidean space induced by an orthonormal basis of eigenvectors of `T`. -/
lemma diagonalization_basis_apply_self_apply (v : E) (i : fin n) :
  hT.diagonalization_basis hn (T v) i = hT.eigenvalues hn i * hT.diagonalization_basis hn v i :=
begin
  suffices : ∀ w : euclidean_space 𝕜 (fin n),
    T ((hT.diagonalization_basis hn).symm w)
    = (hT.diagonalization_basis hn).symm (λ i, hT.eigenvalues hn i * w i),
  { simpa [-diagonalization_basis_symm_apply] using
      congr_arg (λ v, hT.diagonalization_basis hn v i) (this (hT.diagonalization_basis hn v)) },
  intros w,
  simp [mul_comm, mul_smul],
end

end version2

end is_self_adjoint


/-
Copyright (c) 2021 Yakov Pechersky. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yakov Pechersky
-/
import algebra.big_operators.basic
import data.list.min_max
import algebra.tropical.basic
import order.conditionally_complete_lattice.finset

/-!

# Tropicalization of finitary operations

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

This file provides the "big-op" or notation-based finitary operations on tropicalized types.
This allows easy conversion between sums to Infs and prods to sums. Results here are important
for expressing that evaluation of tropical polynomials are the minimum over a finite piecewise
collection of linear functions.

## Main declarations

* `untrop_sum`

## Implementation notes

No concrete (semi)ring is used here, only ones with inferrable order/lattice structure, to support
real, rat, ereal, and others (erat is not yet defined).

Minima over `list α` are defined as producing a value in `with_top α` so proofs about lists do not
directly transfer to minima over multisets or finsets.

-/

open_locale big_operators

variables {R S : Type*}

open tropical finset

lemma list.trop_sum [add_monoid R] (l : list R) : trop l.sum = list.prod (l.map trop) :=
begin
  induction l with hd tl IH,
  { simp },
  { simp [←IH] }
end

lemma multiset.trop_sum [add_comm_monoid R] (s : multiset R) :
  trop s.sum = multiset.prod (s.map trop) :=
quotient.induction_on s (by simpa using list.trop_sum)

lemma trop_sum [add_comm_monoid R] (s : finset S) (f : S → R) :
  trop (∑ i in s, f i) = ∏ i in s, trop (f i) :=
begin
  cases s,
  convert multiset.trop_sum _,
  simp
end

lemma list.untrop_prod [add_monoid R] (l : list (tropical R)) :
  untrop l.prod = list.sum (l.map untrop) :=
begin
  induction l with hd tl IH,
  { simp },
  { simp [←IH] }
end

lemma multiset.untrop_prod [add_comm_monoid R] (s : multiset (tropical R)) :
  untrop s.prod = multiset.sum (s.map untrop) :=
quotient.induction_on s (by simpa using list.untrop_prod)

lemma untrop_prod [add_comm_monoid R] (s : finset S) (f : S → tropical R) :
  untrop (∏ i in s, f i) = ∑ i in s, untrop (f i) :=
begin
  cases s,
  convert multiset.untrop_prod _,
  simp
end

lemma list.trop_minimum [linear_order R] (l : list R) :
  trop l.minimum = list.sum (l.map (trop ∘ coe)) :=
begin
  induction l with hd tl IH,
  { simp },
  { simp [list.minimum_cons, ←IH] }
end

lemma multiset.trop_inf [linear_order R] [order_top R] (s : multiset R) :
  trop s.inf = multiset.sum (s.map trop) :=
begin
  induction s using multiset.induction with s x IH,
  { simp },
  { simp [←IH] }
end

lemma finset.trop_inf [linear_order R] [order_top R] (s : finset S) (f : S → R) :
  trop (s.inf f) = ∑ i in s, trop (f i) :=
begin
  cases s,
  convert multiset.trop_inf _,
  simp
end

lemma trop_Inf_image [conditionally_complete_linear_order R] (s : finset S)
  (f : S → with_top R) : trop (Inf (f '' s)) = ∑ i in s, trop (f i) :=
begin
  rcases s.eq_empty_or_nonempty with rfl|h,
  { simp only [set.image_empty, coe_empty, sum_empty, with_top.cInf_empty, trop_top] },
  rw [←inf'_eq_cInf_image _ h, inf'_eq_inf, s.trop_inf],
end

lemma trop_infi [conditionally_complete_linear_order R] [fintype S] (f : S → with_top R) :
  trop (⨅ (i : S), f i) = ∑ (i : S), trop (f i) :=
by rw [infi, ←set.image_univ, ←coe_univ, trop_Inf_image]

lemma multiset.untrop_sum [linear_order R] [order_top R] (s : multiset (tropical R)) :
  untrop s.sum = multiset.inf (s.map untrop) :=
begin
  induction s using multiset.induction with s x IH,
  { simp },
  { simpa [←IH] }
end

lemma finset.untrop_sum' [linear_order R] [order_top R] (s : finset S)
  (f : S → tropical R) : untrop (∑ i in s, f i) = s.inf (untrop ∘ f) :=
begin
  cases s,
  convert multiset.untrop_sum _,
  simpa
end

lemma untrop_sum_eq_Inf_image [conditionally_complete_linear_order R] (s : finset S)
  (f : S → tropical (with_top R)) :
  untrop (∑ i in s, f i) = Inf (untrop ∘ f '' s) :=
begin
  rcases s.eq_empty_or_nonempty with rfl|h,
  { simp only [set.image_empty, coe_empty, sum_empty, with_top.cInf_empty, untrop_zero] },
  rw [←inf'_eq_cInf_image _ h, inf'_eq_inf, finset.untrop_sum'],
end

lemma untrop_sum [conditionally_complete_linear_order R] [fintype S]
  (f : S → tropical (with_top R)) :
  untrop (∑ i : S, f i) = ⨅ i : S, untrop (f i) :=
by rw [infi, ←set.image_univ, ←coe_univ, untrop_sum_eq_Inf_image]

/-- Note we cannot use `i ∈ s` instead of `i : s` here
as it is simply not true on conditionally complete lattices! -/
lemma finset.untrop_sum [conditionally_complete_linear_order R] (s : finset S)
  (f : S → tropical (with_top R)) : untrop (∑ i in s, f i) = ⨅ i : s, untrop (f i) :=
by simpa [←untrop_sum] using sum_attach.symm


/-
Copyright (c) 2021 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import algebra.free_monoid
import group_theory.congruence
import data.list.chain
/-!
# The free product of groups or monoids

Given an `ι`-indexed family `M` of monoids, we define their free product (categorical coproduct)
`free_product M`. When `ι` and all `M i` have decidable equality, the free product bijects with the
type `word M` of reduced words. This bijection is constructed by defining an action of
`free_product M` on `word M`.

When `M i` are all groups, `free_product M` is also a group (and the coproduct in the category of
groups).

## Main definitions

- `free_product M`: the free product, defined as a quotient of a free monoid.
- `free_product.of {i} : M i →* free_product M`.
- `free_product.lift : (Π {i}, M i →* N) ≃ (free_product M →* N)`: the universal property.
- `free_product.word M`: the type of reduced words.
- `free_product.word.equiv M : free_product M ≃ word M`.

## Remarks

There are many answers to the question "what is the free product of a family `M` of monoids?", and
they are all equivalent but not obviously equivalent. We provide two answers. The first, almost
tautological answer is given by `free_product M`, which is a quotient of the type of words in the
alphabet `Σ i, M i`. It's straightforward to define and easy to prove its universal property. But
this answer is not completely satisfactory, because it's difficult to tell when two elements
`x y : free_product M` are distinct since `free_product M` is defined as a quotient.

The second, maximally efficient answer is given by `word M`. An element of `word M` is a word in the
alphabet `Σ i, M i`, where the letter `⟨i, 1⟩` doesn't occur and no adjacent letters share an index
`i`. Since we only work with reduced words, there is no need for quotienting, and it is easy to tell
when two elements are distinct. However it's not obvious that this is even a monoid!

We prove that every element of `free_product M` can be represented by a unique reduced word, i.e.
`free_product M` and `word M` are equivalent types. This means that `word M` can be given a monoid
structure, and it lets us tell when two elements of `free_product M` are distinct.

There is also a completely tautological, maximally inefficient answer given by
`algebra.category.Mon.colimits`. Whereas `free_product M` at least ensures that (any instance of)
associativity holds by reflexivity, in this answer associativity holds because of quotienting. Yet
another answer, which is constructively more satisfying, could be obtained by showing that
`free_product.rel` is confluent.

## References

[van der Waerden, *Free products of groups*][MR25465]

-/

variables {ι : Type*} (M : Π i : ι, Type*) [Π i, monoid (M i)]

/-- A relation on the free monoid on alphabet `Σ i, M i`, relating `⟨i, 1⟩` with `1` and
`⟨i, x⟩ * ⟨i, y⟩` with `⟨i, x * y⟩`. -/
inductive free_product.rel : free_monoid (Σ i, M i) → free_monoid (Σ i, M i) → Prop
| of_one (i : ι) : free_product.rel (free_monoid.of ⟨i, 1⟩) 1
| of_mul {i : ι} (x y : M i) : free_product.rel (free_monoid.of ⟨i, x⟩ * free_monoid.of ⟨i, y⟩)
  (free_monoid.of ⟨i, x * y⟩)

/-- The free product (categorical coproduct) of an indexed family of monoids. -/
@[derive [monoid, inhabited]]
def free_product : Type* := (con_gen (free_product.rel M)).quotient

namespace free_product

/-- The type of reduced words. A reduced word cannot contain a letter `1`, and no two adjacent
letters can come from the same summand. -/
@[ext] structure word :=
(to_list : list (Σ i, M i))
(ne_one : ∀ l ∈ to_list, sigma.snd l ≠ 1)
(chain_ne : to_list.chain' (λ l l', sigma.fst l ≠ sigma.fst l'))

variable {M}

/-- The inclusion of a summand into the free product. -/
def of {i : ι} : M i →* free_product M :=
{ to_fun   := λ x, con.mk' _ (free_monoid.of $ sigma.mk i x),
  map_one' := (con.eq _).mpr (con_gen.rel.of _ _ (free_product.rel.of_one i)),
  map_mul' := λ x y, eq.symm $ (con.eq _).mpr (con_gen.rel.of _ _ (free_product.rel.of_mul x y)) }

lemma of_apply {i} (m : M i) : of m = con.mk' _ (free_monoid.of $ sigma.mk i m) := rfl

variables {N : Type*} [monoid N]

/-- See note [partially-applied ext lemmas]. -/
@[ext] lemma ext_hom (f g : free_product M →* N) (h : ∀ i, f.comp (of : M i →* _) = g.comp of) :
  f = g :=
(monoid_hom.cancel_right con.mk'_surjective).mp $ free_monoid.hom_eq $ λ ⟨i, x⟩,
  by rw [monoid_hom.comp_apply, monoid_hom.comp_apply, ←of_apply,
    ←monoid_hom.comp_apply, ←monoid_hom.comp_apply, h]

/-- A map out of the free product corresponds to a family of maps out of the summands. This is the
universal property of the free product, charaterizing it as a categorical coproduct. -/
@[simps symm_apply]
def lift : (Π i, M i →* N) ≃ (free_product M →* N) :=
{ to_fun := λ fi, con.lift _ (free_monoid.lift $ λ p : Σ i, M i, fi p.fst p.snd) $ con.con_gen_le
    begin
      simp_rw [con.rel_eq_coe, con.ker_rel],
      rintros _ _ (i | ⟨i, x, y⟩),
      { change free_monoid.lift _ (free_monoid.of _) = free_monoid.lift _ 1,
        simp only [monoid_hom.map_one, free_monoid.lift_eval_of], },
      { change free_monoid.lift _ (free_monoid.of _ * free_monoid.of _) =
          free_monoid.lift _ (free_monoid.of _),
        simp only [monoid_hom.map_mul, free_monoid.lift_eval_of], }
    end,
  inv_fun := λ f i, f.comp of,
  left_inv := by { intro fi, ext i x,
    rw [monoid_hom.comp_apply, of_apply, con.lift_mk', free_monoid.lift_eval_of], },
  right_inv := by { intro f, ext i x,
    simp only [monoid_hom.comp_apply, of_apply, con.lift_mk', free_monoid.lift_eval_of], } }

@[simp] lemma lift_of {N} [monoid N] (fi : Π i, M i →* N) {i} (m : M i) :
  lift fi (of m) = fi i m :=
by conv_rhs { rw [←lift.symm_apply_apply fi, lift_symm_apply, monoid_hom.comp_apply] }

@[elab_as_eliminator]
lemma induction_on {C : free_product M → Prop}
  (m : free_product M)
  (h_one : C 1)
  (h_of : ∀ (i) (m : M i), C (of m))
  (h_mul : ∀ (x y), C x → C y → C (x * y)) :
  C m :=
begin
  let S : submonoid (free_product M) := ⟨set_of C, h_one, h_mul⟩,
  convert subtype.prop (lift (λ i, of.cod_mrestrict S (h_of i)) m),
  change monoid_hom.id _ m = S.subtype.comp _ m,
  congr,
  ext,
  simp [monoid_hom.cod_mrestrict],
end

lemma of_left_inverse [decidable_eq ι] (i : ι) :
  function.left_inverse (lift $ function.update 1 i (monoid_hom.id (M i))) of :=
λ x, by simp only [lift_of, function.update_same, monoid_hom.id_apply]

lemma of_injective (i : ι) : function.injective ⇑(of : M i →* _) :=
by { classical, exact (of_left_inverse i).injective }

section group

variables (G : ι → Type*) [Π i, group (G i)]

instance : has_inv (free_product G) :=
{ inv := mul_opposite.unop ∘
    lift (λ i, (of : G i →* _).op.comp (mul_equiv.inv' (G i)).to_monoid_hom) }

lemma inv_def (x : free_product G) : x⁻¹ = mul_opposite.unop
  (lift (λ i, (of : G i →* _).op.comp (mul_equiv.inv' (G i)).to_monoid_hom) x) := rfl

instance : group (free_product G) :=
{ mul_left_inv := begin
    intro m,
    rw inv_def,
    apply m.induction_on,
    { rw [monoid_hom.map_one, mul_opposite.unop_one, one_mul], },
    { intros i m, change of m⁻¹ * of m = 1, rw [←of.map_mul, mul_left_inv, of.map_one], },
    { intros x y hx hy,
      rw [monoid_hom.map_mul, mul_opposite.unop_mul, mul_assoc, ← mul_assoc _ x y, hx,
        one_mul, hy], },
  end,
  ..free_product.has_inv G,
  ..free_product.monoid G }

end group

namespace word

/-- The empty reduced word. -/
def empty : word M := { to_list := [], ne_one := λ _, false.elim, chain_ne := list.chain'_nil }

instance : inhabited (word M) := ⟨empty⟩

/-- A reduced word determines an element of the free product, given by multiplication. -/
def prod (w : word M) : free_product M :=
list.prod (w.to_list.map $ λ l, of l.snd)

@[simp] lemma prod_nil : prod (empty : word M) = 1 := rfl

/-- `fst_idx w` is `some i` if the first letter of `w` is `⟨i, m⟩` with `m : M i`. If `w` is empty
then it's `none`. -/
def fst_idx (w : word M) : option ι := w.to_list.head'.map sigma.fst

lemma fst_idx_ne_iff {w : word M} {i} :
  fst_idx w ≠ some i ↔ ∀ l ∈ w.to_list.head', i ≠ sigma.fst l :=
not_iff_not.mp $ by simp [fst_idx]

variable (M)

/-- Given an index `i : ι`, `pair M i` is the type of pairs `(head, tail)` where `head : M i` and
`tail : word M`, subject to the constraint that first letter of `tail` can't be `⟨i, m⟩`.
By prepending `head` to `tail`, one obtains a new word. We'll show that any word can be uniquely
obtained in this way. -/
@[ext] structure pair (i : ι) :=
(head : M i)
(tail : word M)
(fst_idx_ne : fst_idx tail ≠ some i)

instance (i : ι) : inhabited (pair M i) := ⟨⟨1, empty, by tauto⟩⟩

variable {M}

variables [∀ i, decidable_eq (M i)]

/-- Given a pair `(head, tail)`, we can form a word by prepending `head` to `tail`, except if `head`
is `1 : M i` then we have to just return `word` since we need the result to be reduced. -/
def rcons {i} (p : pair M i) : word M :=
if h : p.head = 1 then p.tail
else { to_list  := ⟨i, p.head⟩ :: p.tail.to_list,
       ne_one   := by { rintros l (rfl | hl), exact h, exact p.tail.ne_one l hl },
       chain_ne := p.tail.chain_ne.cons' (fst_idx_ne_iff.mp p.fst_idx_ne) }

/-- Given a word of the form `⟨l :: ls, h1, h2⟩`, we can form a word of the form `⟨ls, _, _⟩`,
dropping the first letter. -/
private def mk_aux {l} (ls : list (Σ i, M i)) (h1 : ∀ l' ∈ l :: ls, sigma.snd l' ≠ 1)
  (h2 : (l :: ls).chain' _) : word M :=
⟨ls, λ l' hl, h1 _ (list.mem_cons_of_mem _ hl), h2.tail⟩

lemma cons_eq_rcons {i} {m : M i} {ls h1 h2} :
  word.mk (⟨i, m⟩ :: ls) h1 h2 = rcons ⟨m, mk_aux ls h1 h2, fst_idx_ne_iff.mpr h2.rel_head'⟩ :=
by { rw [rcons, dif_neg], refl, exact h1 ⟨i, m⟩ (ls.mem_cons_self _) }

@[simp] lemma prod_rcons {i} (p : pair M i) :
  prod (rcons p) = of p.head * prod p.tail :=
if hm : p.head = 1 then by rw [rcons, dif_pos hm, hm, monoid_hom.map_one, one_mul]
else by rw [rcons, dif_neg hm, prod, list.map_cons, list.prod_cons, prod]

lemma rcons_inj {i} : function.injective (rcons : pair M i → word M) :=
begin
  rintros ⟨m, w, h⟩ ⟨m', w', h'⟩ he,
  by_cases hm : m = 1;
  by_cases hm' : m' = 1,
  { simp only [rcons, dif_pos hm, dif_pos hm'] at he, cc, },
  { exfalso, simp only [rcons, dif_pos hm, dif_neg hm'] at he, rw he at h, exact h rfl },
  { exfalso, simp only [rcons, dif_pos hm', dif_neg hm] at he, rw ←he at h', exact h' rfl, },
  { have : m = m' ∧ w.to_list = w'.to_list,
    { simpa only [rcons, dif_neg hm, dif_neg hm', true_and, eq_self_iff_true, subtype.mk_eq_mk,
      heq_iff_eq, ←subtype.ext_iff_val] using he },
    rcases this with ⟨rfl, h⟩,
    congr, exact word.ext _ _ h, }
end

variable [decidable_eq ι]

/-- Given `i : ι`, any reduced word can be decomposed into a pair `p` such that `w = rcons p`. -/
-- This definition is computable but not very nice to look at. Thankfully we don't have to inspect
-- it, since `rcons` is known to be injective.
private def equiv_pair_aux (i) : Π w : word M, { p : pair M i // rcons p = w }
| w@⟨[], _, _⟩             := ⟨⟨1, w, by rintro ⟨⟩⟩, dif_pos rfl⟩
| w@⟨⟨j, m⟩ :: ls, h1, h2⟩ := if ij : i = j then
  { val := { head := ij.symm.rec m,
             tail := mk_aux ls h1 h2,
             fst_idx_ne := by cases ij; exact fst_idx_ne_iff.mpr h2.rel_head' },
    property := by cases ij; exact cons_eq_rcons.symm }
else ⟨⟨1, w, (option.some_injective _).ne (ne.symm ij)⟩, dif_pos rfl⟩

/-- The equivalence between words and pairs. Given a word, it decomposes it as a pair by removing
the first letter if it comes from `M i`. Given a pair, it prepends the head to the tail. -/
def equiv_pair (i) : word M ≃ pair M i :=
{ to_fun := λ w, (equiv_pair_aux i w).val,
  inv_fun := rcons,
  left_inv := λ w, (equiv_pair_aux i w).property,
  right_inv := λ p, rcons_inj (equiv_pair_aux i _).property }

lemma equiv_pair_symm (i) (p : pair M i) : (equiv_pair i).symm p = rcons p := rfl

lemma equiv_pair_eq_of_fst_idx_ne {i} {w : word M} (h : fst_idx w ≠ some i) :
  equiv_pair i w = ⟨1, w, h⟩ :=
(equiv_pair i).apply_eq_iff_eq_symm_apply.mpr $ eq.symm (dif_pos rfl)

instance summand_action (i) : mul_action (M i) (word M) :=
{ smul     := λ m w, rcons { head := m * (equiv_pair i w).head, ..equiv_pair i w },
  one_smul := λ w, by { simp_rw [one_mul], apply (equiv_pair i).symm_apply_eq.mpr, ext; refl },
  mul_smul := λ m m' w, by simp only [mul_assoc, ←equiv_pair_symm, equiv.apply_symm_apply], }

instance : mul_action (free_product M) (word M) :=
mul_action.of_End_hom (lift (λ i, mul_action.to_End_hom))

lemma of_smul_def (i) (w : word M) (m : M i) :
  of m • w = rcons { head := m * (equiv_pair i w).head, ..equiv_pair i w } := rfl

lemma cons_eq_smul {i} {m : M i} {ls h1 h2} :
  word.mk (⟨i, m⟩ :: ls) h1 h2 = of m • mk_aux ls h1 h2 :=
by rw [cons_eq_rcons, of_smul_def, equiv_pair_eq_of_fst_idx_ne _]; simp only [mul_one]

lemma smul_induction {C : word M → Prop}
  (h_empty : C empty)
  (h_smul : ∀ i (m : M i) w, C w → C (of m • w))
  (w : word M) : C w :=
begin
  cases w with ls h1 h2,
  induction ls with l ls ih,
  { exact h_empty },
  cases l with i m,
  rw cons_eq_smul,
  exact h_smul _ _ _ (ih _ _),
end

@[simp] lemma prod_smul (m) : ∀ w : word M, prod (m • w) = m * prod w :=
begin
  apply m.induction_on,
  { intro, rw [one_smul, one_mul] },
  { intros, rw [of_smul_def, prod_rcons, of.map_mul, mul_assoc, ←prod_rcons,
      ←equiv_pair_symm, equiv.symm_apply_apply] },
  { intros x y hx hy w, rw [mul_smul, hx, hy, mul_assoc] },
end

/-- Each element of the free product corresponds to a unique reduced word. -/
def equiv : free_product M ≃ word M :=
{ to_fun := λ m, m • empty,
  inv_fun := λ w, prod w,
  left_inv := λ m, by dsimp only; rw [prod_smul, prod_nil, mul_one],
  right_inv := begin
    apply smul_induction,
    { dsimp only, rw [prod_nil, one_smul], },
    { dsimp only, intros i m w ih, rw [prod_smul, mul_smul, ih], },
  end }

instance : decidable_eq (word M) := function.injective.decidable_eq word.ext
instance : decidable_eq (free_product M) := word.equiv.decidable_eq

end word

end free_product


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

! This file was ported from Lean 3 source module model_theory.order
! leanprover-community/mathlib commit 1ed3a113dbc6f5b33eae3b96211d4e26ca3a5e9d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.ModelTheory.Semantics

/-!
# Ordered First-Ordered Structures
This file defines ordered first-order languages and structures, as well as their theories.

## Main Definitions
* `first_order.language.order` is the language consisting of a single relation representing `≤`.
* `first_order.language.order_Structure` is the structure on an ordered type, assigning the symbol
representing `≤` to the actual relation `≤`.
* `first_order.language.is_ordered` points out a specific symbol in a language as representing `≤`.
* `first_order.language.ordered_structure` indicates that the `≤` symbol in an ordered language
is interpreted as the actual relation `≤` in a particular structure.
* `first_order.language.linear_order_theory` and similar define the theories of preorders,
partial orders, and linear orders.
* `first_order.language.DLO` defines the theory of dense linear orders without endpoints, a
particularly useful example in model theory.

## Main Results
* `partial_order`s model the theory of partial orders, `linear_order`s model the theory of
linear orders, and dense linear orders without endpoints model `Theory.DLO`.

-/

universe u v w w'

namespace FirstOrder

namespace Language

open FirstOrder

open Structure

variable {L : Language.{u, v}} {α : Type w} {M : Type w'} {n : ℕ}

/-- The language consisting of a single relation representing `≤`. -/
protected def order : Language :=
  Language.mk₂ Empty Empty Empty Empty Unit
#align first_order.language.order FirstOrder.Language.order

instance orderStructure [LE M] : Language.order.Structure M :=
  Structure.mk₂ Empty.elim Empty.elim Empty.elim Empty.elim fun _ => (· ≤ ·)
#align first_order.language.order_Structure FirstOrder.Language.orderStructure

namespace Order

instance : IsRelational Language.order :=
  Language.isRelational_mk₂

instance : Subsingleton (Language.order.Relations n) :=
  Language.subsingleton_mk₂_relations

end Order

/-- A language is ordered if it has a symbol representing `≤`. -/
class IsOrdered (L : Language.{u, v}) where
  leSymb : L.Relations 2
#align first_order.language.is_ordered FirstOrder.Language.IsOrdered

export IsOrdered (leSymb)

section IsOrdered

variable [IsOrdered L]

/-- Joins two terms `t₁, t₂` in a formula representing `t₁ ≤ t₂`. -/
def Term.le (t₁ t₂ : L.term (Sum α (Fin n))) : L.BoundedFormula α n :=
  leSymb.boundedFormula₂ t₁ t₂
#align first_order.language.term.le FirstOrder.Language.Term.le

/-- Joins two terms `t₁, t₂` in a formula representing `t₁ < t₂`. -/
def Term.lt (t₁ t₂ : L.term (Sum α (Fin n))) : L.BoundedFormula α n :=
  t₁.le t₂ ⊓ ∼(t₂.le t₁)
#align first_order.language.term.lt FirstOrder.Language.Term.lt

variable (L)

/-- The language homomorphism sending the unique symbol `≤` of `language.order` to `≤` in an ordered
 language. -/
def orderLhom : Language.order →ᴸ L :=
  Lhom.mk₂ Empty.elim Empty.elim Empty.elim Empty.elim fun _ => leSymb
#align first_order.language.order_Lhom FirstOrder.Language.orderLhom

end IsOrdered

instance : IsOrdered Language.order :=
  ⟨Unit.unit⟩

@[simp]
theorem orderLhom_leSymb [L.IsOrdered] :
    (orderLhom L).onRelation leSymb = (leSymb : L.Relations 2) :=
  rfl
#align first_order.language.order_Lhom_le_symb FirstOrder.Language.orderLhom_leSymb

@[simp]
theorem orderLhom_order : orderLhom Language.order = Lhom.id Language.order :=
  Lhom.funext (Subsingleton.elim _ _) (Subsingleton.elim _ _)
#align first_order.language.order_Lhom_order FirstOrder.Language.orderLhom_order

instance : IsOrdered (L.Sum Language.order) :=
  ⟨Sum.inr IsOrdered.leSymb⟩

section

variable (L) [IsOrdered L]

/-- The theory of preorders. -/
def preorderTheory : L.Theory :=
  {leSymb.Reflexive, leSymb.Transitive}
#align first_order.language.preorder_theory FirstOrder.Language.preorderTheory

/-- The theory of partial orders. -/
def partialOrderTheory : L.Theory :=
  {leSymb.Reflexive, leSymb.antisymmetric, leSymb.Transitive}
#align first_order.language.partial_order_theory FirstOrder.Language.partialOrderTheory

/-- The theory of linear orders. -/
def linearOrderTheory : L.Theory :=
  {leSymb.Reflexive, leSymb.antisymmetric, leSymb.Transitive, leSymb.Total}
#align first_order.language.linear_order_theory FirstOrder.Language.linearOrderTheory

/-- A sentence indicating that an order has no top element:
$\forall x, \exists y, \neg y \le x$.   -/
def noTopOrderSentence : L.Sentence :=
  ∀'∃'∼((&1).le &0)
#align first_order.language.no_top_order_sentence FirstOrder.Language.noTopOrderSentence

/-- A sentence indicating that an order has no bottom element:
$\forall x, \exists y, \neg x \le y$. -/
def noBotOrderSentence : L.Sentence :=
  ∀'∃'∼((&0).le &1)
#align first_order.language.no_bot_order_sentence FirstOrder.Language.noBotOrderSentence

/-- A sentence indicating that an order is dense:
$\forall x, \forall y, x < y \to \exists z, x < z \wedge z < y$. -/
def denselyOrderedSentence : L.Sentence :=
  ∀'∀'((&0).lt &1 ⟹ ∃'((&0).lt &2 ⊓ (&2).lt &1))
#align first_order.language.densely_ordered_sentence FirstOrder.Language.denselyOrderedSentence

/-- The theory of dense linear orders without endpoints. -/
def dLO : L.Theory :=
  L.linearOrderTheory ∪ {L.noTopOrderSentence, L.noBotOrderSentence, L.denselyOrderedSentence}
#align first_order.language.DLO FirstOrder.Language.dLO

end

variable (L M)

/-- A structure is ordered if its language has a `≤` symbol whose interpretation is -/
abbrev OrderedStructure [IsOrdered L] [LE M] [L.Structure M] : Prop :=
  Lhom.IsExpansionOn (orderLhom L) M
#align first_order.language.ordered_structure FirstOrder.Language.OrderedStructure

variable {L M}

@[simp]
theorem orderedStructure_iff [IsOrdered L] [LE M] [L.Structure M] :
    L.OrderedStructure M ↔ Lhom.IsExpansionOn (orderLhom L) M :=
  Iff.rfl
#align first_order.language.ordered_structure_iff FirstOrder.Language.orderedStructure_iff

instance orderedStructure_lE [LE M] : OrderedStructure Language.order M :=
  by
  rw [ordered_structure_iff, order_Lhom_order]
  exact Lhom.id_is_expansion_on M
#align first_order.language.ordered_structure_has_le FirstOrder.Language.orderedStructure_lE

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
instance model_preorder [Preorder M] : M ⊨ Language.order.preorderTheory :=
  by
  simp only [preorder_theory, Theory.model_iff, Set.mem_insert_iff, Set.mem_singleton_iff,
    forall_eq_or_imp, relations.realize_reflexive, rel_map_apply₂, forall_eq,
    relations.realize_transitive]
  exact ⟨le_refl, fun _ _ _ => le_trans⟩
#align first_order.language.model_preorder FirstOrder.Language.model_preorder

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
instance model_partialOrder [PartialOrder M] : M ⊨ Language.order.partialOrderTheory :=
  by
  simp only [partial_order_theory, Theory.model_iff, Set.mem_insert_iff, Set.mem_singleton_iff,
    forall_eq_or_imp, relations.realize_reflexive, rel_map_apply₂, relations.realize_antisymmetric,
    forall_eq, relations.realize_transitive]
  exact ⟨le_refl, fun _ _ => le_antisymm, fun _ _ _ => le_trans⟩
#align first_order.language.model_partial_order FirstOrder.Language.model_partialOrder

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
instance model_linearOrder [LinearOrder M] : M ⊨ Language.order.linearOrderTheory :=
  by
  simp only [linear_order_theory, Theory.model_iff, Set.mem_insert_iff, Set.mem_singleton_iff,
    forall_eq_or_imp, relations.realize_reflexive, rel_map_apply₂, relations.realize_antisymmetric,
    relations.realize_transitive, forall_eq, relations.realize_total]
  exact ⟨le_refl, fun _ _ => le_antisymm, fun _ _ _ => le_trans, le_total⟩
#align first_order.language.model_linear_order FirstOrder.Language.model_linearOrder

section OrderedStructure

variable [IsOrdered L] [L.Structure M]

@[simp]
theorem relMap_leSymb [LE M] [L.OrderedStructure M] {a b : M} :
    RelMap (leSymb : L.Relations 2) ![a, b] ↔ a ≤ b :=
  by
  rw [← order_Lhom_le_symb, Lhom.map_on_relation]
  rfl
#align first_order.language.rel_map_le_symb FirstOrder.Language.relMap_leSymb

@[simp]
theorem Term.realize_le [LE M] [L.OrderedStructure M] {t₁ t₂ : L.term (Sum α (Fin n))} {v : α → M}
    {xs : Fin n → M} :
    (t₁.le t₂).realize v xs ↔ t₁.realize (Sum.elim v xs) ≤ t₂.realize (Sum.elim v xs) := by
  simp [term.le]
#align first_order.language.term.realize_le FirstOrder.Language.Term.realize_le

@[simp]
theorem Term.realize_lt [Preorder M] [L.OrderedStructure M] {t₁ t₂ : L.term (Sum α (Fin n))}
    {v : α → M} {xs : Fin n → M} :
    (t₁.lt t₂).realize v xs ↔ t₁.realize (Sum.elim v xs) < t₂.realize (Sum.elim v xs) := by
  simp [term.lt, lt_iff_le_not_le]
#align first_order.language.term.realize_lt FirstOrder.Language.Term.realize_lt

end OrderedStructure

section LE

variable [LE M]

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem realize_noTopOrder_iff : M ⊨ Language.order.noTopOrderSentence ↔ NoTopOrder M :=
  by
  simp only [no_top_order_sentence, sentence.realize, formula.realize, bounded_formula.realize_all,
    bounded_formula.realize_ex, bounded_formula.realize_not, realize, term.realize_le, Sum.elim_inr]
  refine' ⟨fun h => ⟨fun a => h a⟩, _⟩
  intro h a
  exact exists_not_le a
#align first_order.language.realize_no_top_order_iff FirstOrder.Language.realize_noTopOrder_iff

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem realize_noTopOrder [h : NoTopOrder M] : M ⊨ Language.order.noTopOrderSentence :=
  realize_noTopOrder_iff.2 h
#align first_order.language.realize_no_top_order FirstOrder.Language.realize_noTopOrder

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem realize_noBotOrder_iff : M ⊨ Language.order.noBotOrderSentence ↔ NoBotOrder M :=
  by
  simp only [no_bot_order_sentence, sentence.realize, formula.realize, bounded_formula.realize_all,
    bounded_formula.realize_ex, bounded_formula.realize_not, realize, term.realize_le, Sum.elim_inr]
  refine' ⟨fun h => ⟨fun a => h a⟩, _⟩
  intro h a
  exact exists_not_ge a
#align first_order.language.realize_no_bot_order_iff FirstOrder.Language.realize_noBotOrder_iff

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem realize_noBotOrder [h : NoBotOrder M] : M ⊨ Language.order.noBotOrderSentence :=
  realize_noBotOrder_iff.2 h
#align first_order.language.realize_no_bot_order FirstOrder.Language.realize_noBotOrder

end LE

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem realize_denselyOrdered_iff [Preorder M] :
    M ⊨ Language.order.denselyOrderedSentence ↔ DenselyOrdered M :=
  by
  simp only [densely_ordered_sentence, sentence.realize, formula.realize,
    bounded_formula.realize_imp, bounded_formula.realize_all, realize, term.realize_lt,
    Sum.elim_inr, bounded_formula.realize_ex, bounded_formula.realize_inf]
  refine' ⟨fun h => ⟨fun a b ab => h a b ab⟩, _⟩
  intro h a b ab
  exact exists_between ab
#align first_order.language.realize_densely_ordered_iff FirstOrder.Language.realize_denselyOrdered_iff

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem realize_denselyOrdered [Preorder M] [h : DenselyOrdered M] :
    M ⊨ Language.order.denselyOrderedSentence :=
  realize_denselyOrdered_iff.2 h
#align first_order.language.realize_densely_ordered FirstOrder.Language.realize_denselyOrdered

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
instance model_dLO [LinearOrder M] [DenselyOrdered M] [NoTopOrder M] [NoBotOrder M] :
    M ⊨ Language.order.dLO :=
  by
  simp only [DLO, Set.union_insert, Set.union_singleton, Theory.model_iff, Set.mem_insert_iff,
    forall_eq_or_imp, realize_no_top_order, realize_no_bot_order, realize_densely_ordered,
    true_and_iff]
  rw [← Theory.model_iff]
  infer_instance
#align first_order.language.model_DLO FirstOrder.Language.model_dLO

end Language

end FirstOrder


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri, Andrew Yang
-/

import ring_theory.adjoin.basic
import algebra.lie.of_associative
import ring_theory.ideal.cotangent
import ring_theory.is_tensor_product

/-!
# Derivations

This file defines derivation. A derivation `D` from the `R`-algebra `A` to the `A`-module `M` is an
`R`-linear map that satisfy the Leibniz rule `D (a * b) = a * D b + D a * b`.

## Main results

- `derivation`: The type of `R`-derivations from `A` to `M`. This has an `A`-module structure.
- `derivation.llcomp`: We may compose linear maps and derivations to obtain a derivation,
  and the composition is bilinear.
- `derivation.lie_algebra`: The `R`-derivations from `A` to `A` form an lie algebra over `R`.
- `derivation_to_square_zero_equiv_lift`: The `R`-derivations from `A` into a square-zero ideal `I`
  of `B` corresponds to the lifts `A →ₐ[R] B` of the map `A →ₐ[R] B ⧸ I`.
- `kaehler_differential`: The module of kaehler differentials. For an `R`-algebra `S`, we provide
  the notation `Ω[S⁄R]` for `kaehler_differential R S`.
  Note that the slash is `\textfractionsolidus`.
- `kaehler_differential.D`: The derivation into the module of kaehler differentials.
- `kaehler_differential.span_range_derivation`: The image of `D` spans `Ω[S⁄R]` as an `S`-module.
- `kaehler_differential.linear_map_equiv_derivation`:
  The isomorphism `Hom_R(Ω[S⁄R], M) ≃ₗ[S] Der_R(S, M)`.
- `kaehler_differential.quot_ker_total_equiv`: An alternative description of `Ω[S⁄R]` as `S` copies
  of `S` with kernel (`kaehler_differential.ker_total`) generated by the relations:
  1. `dx + dy = d(x + y)`
  2. `x dy + y dx = d(x * y)`
  3. `dr = 0` for `r ∈ R`
- `kaehler_differential.map`: Given a map between the arrows `R → A` and `S → B`, we have an
  `A`-linear map `Ω[A⁄R] → Ω[B⁄S]`.

## Future project

- Generalize derivations into bimodules.
- Define a `is_kaehler_differential` predicate.

-/

open algebra
open_locale big_operators

/-- `D : derivation R A M` is an `R`-linear map from `A` to `M` that satisfies the `leibniz`
equality. We also require that `D 1 = 0`. See `derivation.mk'` for a constructor that deduces this
assumption from the Leibniz rule when `M` is cancellative.

TODO: update this when bimodules are defined. -/
@[protect_proj]
structure derivation (R : Type*) (A : Type*) [comm_semiring R] [comm_semiring A]
  [algebra R A] (M : Type*) [add_comm_monoid M] [module A M] [module R M]
  extends A →ₗ[R] M :=
(map_one_eq_zero' : to_linear_map 1 = 0)
(leibniz' (a b : A) : to_linear_map (a * b) = a • to_linear_map b + b • to_linear_map a)

/-- The `linear_map` underlying a `derivation`. -/
add_decl_doc derivation.to_linear_map

namespace derivation

section

variables {R : Type*} [comm_semiring R]
variables {A : Type*} [comm_semiring A] [algebra R A]
variables {M : Type*} [add_comm_monoid M] [module A M] [module R M]
variables (D : derivation R A M) {D1 D2 : derivation R A M} (r : R) (a b : A)

instance : add_monoid_hom_class (derivation R A M) A M :=
{ coe := λ D, D.to_fun,
  coe_injective' := λ D1 D2 h, by { cases D1, cases D2, congr, exact fun_like.coe_injective h },
  map_add := λ D, D.to_linear_map.map_add',
  map_zero := λ D, D.to_linear_map.map_zero }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (derivation R A M) (λ _, A → M) := ⟨λ D, D.to_linear_map.to_fun⟩

-- Not a simp lemma because it can be proved via `coe_fn_coe` + `to_linear_map_eq_coe`
lemma to_fun_eq_coe : D.to_fun = ⇑D := rfl

instance has_coe_to_linear_map : has_coe (derivation R A M) (A →ₗ[R] M) :=
⟨λ D, D.to_linear_map⟩

@[simp] lemma to_linear_map_eq_coe : D.to_linear_map = D := rfl

@[simp] lemma mk_coe (f : A →ₗ[R] M) (h₁ h₂) :
  ((⟨f, h₁, h₂⟩ : derivation R A M) : A → M) = f := rfl

@[simp, norm_cast]
lemma coe_fn_coe (f : derivation R A M) : ⇑(f : A →ₗ[R] M) = f := rfl

lemma coe_injective : @function.injective (derivation R A M) (A → M) coe_fn :=
fun_like.coe_injective

@[ext] theorem ext (H : ∀ a, D1 a = D2 a) : D1 = D2 :=
fun_like.ext _ _ H

lemma congr_fun (h : D1 = D2) (a : A) : D1 a = D2 a := fun_like.congr_fun h a

protected lemma map_add : D (a + b) = D a + D b := map_add D a b
protected lemma map_zero : D 0 = 0 := map_zero D
@[simp] lemma map_smul : D (r • a) = r • D a := D.to_linear_map.map_smul r a
@[simp] lemma leibniz : D (a * b) = a • D b + b • D a := D.leibniz' _ _

lemma map_sum {ι : Type*} (s : finset ι) (f : ι → A) : D (∑ i in s, f i) = ∑ i in s, D (f i) :=
D.to_linear_map.map_sum

@[simp, priority 900] lemma map_smul_of_tower {S : Type*} [has_smul S A] [has_smul S M]
  [linear_map.compatible_smul A M S R] (D : derivation R A M) (r : S) (a : A) :
  D (r • a) = r • D a :=
D.to_linear_map.map_smul_of_tower r a

@[simp] lemma map_one_eq_zero : D 1 = 0 := D.map_one_eq_zero'

@[simp] lemma map_algebra_map : D (algebra_map R A r) = 0 :=
by rw [←mul_one r, ring_hom.map_mul, ring_hom.map_one, ←smul_def, map_smul, map_one_eq_zero,
  smul_zero]

@[simp] lemma map_coe_nat (n : ℕ) : D (n : A) = 0 :=
by rw [← nsmul_one, D.map_smul_of_tower n, map_one_eq_zero, smul_zero]

@[simp] lemma leibniz_pow (n : ℕ) : D (a ^ n) = n • a ^ (n - 1) • D a :=
begin
  induction n with n ihn,
  { rw [pow_zero, map_one_eq_zero, zero_smul] },
  { rcases (zero_le n).eq_or_lt with (rfl|hpos),
    { rw [pow_one, one_smul, pow_zero, one_smul] },
    { have : a * a ^ (n - 1) = a ^ n, by rw [← pow_succ, nat.sub_add_cancel hpos],
      simp only [pow_succ, leibniz, ihn, smul_comm a n, smul_smul a, add_smul, this,
        nat.succ_eq_add_one, nat.add_succ_sub_one, add_zero, one_nsmul] } }
end

lemma eq_on_adjoin {s : set A} (h : set.eq_on D1 D2 s) : set.eq_on D1 D2 (adjoin R s) :=
λ x hx, algebra.adjoin_induction hx h
  (λ r, (D1.map_algebra_map r).trans (D2.map_algebra_map r).symm)
  (λ x y hx hy, by simp only [map_add, *])
  (λ x y hx hy, by simp only [leibniz, *])

/-- If adjoin of a set is the whole algebra, then any two derivations equal on this set are equal
on the whole algebra. -/
lemma ext_of_adjoin_eq_top (s : set A) (hs : adjoin R s = ⊤) (h : set.eq_on D1 D2 s) : D1 = D2 :=
ext $ λ a, eq_on_adjoin h $ hs.symm ▸ trivial

/- Data typeclasses -/

instance : has_zero (derivation R A M) :=
⟨{ to_linear_map := 0,
   map_one_eq_zero' := rfl,
   leibniz' := λ a b, by simp only [add_zero, linear_map.zero_apply, smul_zero] }⟩

@[simp] lemma coe_zero : ⇑(0 : derivation R A M) = 0 := rfl
@[simp] lemma coe_zero_linear_map : ↑(0 : derivation R A M) = (0 : A →ₗ[R] M) := rfl
lemma zero_apply (a : A) : (0 : derivation R A M) a = 0 := rfl

instance : has_add (derivation R A M) :=
⟨λ D1 D2,
  { to_linear_map := D1 + D2,
    map_one_eq_zero' := by simp,
    leibniz' := λ a b, by simp only [leibniz, linear_map.add_apply,
      coe_fn_coe, smul_add, add_add_add_comm] }⟩

@[simp] lemma coe_add (D1 D2 : derivation R A M) : ⇑(D1 + D2) = D1 + D2 := rfl
@[simp] lemma coe_add_linear_map (D1 D2 : derivation R A M) : ↑(D1 + D2) = (D1 + D2 : A →ₗ[R] M) :=
rfl
lemma add_apply : (D1 + D2) a = D1 a + D2 a := rfl

instance : inhabited (derivation R A M) := ⟨0⟩

section scalar

variables {S : Type*} [monoid S] [distrib_mul_action S M] [smul_comm_class R S M]
  [smul_comm_class S A M]

@[priority 100]
instance : has_smul S (derivation R A M) :=
⟨λ r D,
  { to_linear_map := r • D,
    map_one_eq_zero' := by rw [linear_map.smul_apply, coe_fn_coe, D.map_one_eq_zero, smul_zero],
    leibniz' := λ a b, by simp only [linear_map.smul_apply, coe_fn_coe, leibniz, smul_add,
      smul_comm r] }⟩

@[simp] lemma coe_smul (r : S) (D : derivation R A M) : ⇑(r • D) = r • D := rfl
@[simp] lemma coe_smul_linear_map (r : S) (D : derivation R A M) :
  ↑(r • D) = (r • D : A →ₗ[R] M) := rfl
lemma smul_apply (r : S) (D : derivation R A M) : (r • D) a = r • D a := rfl

instance : add_comm_monoid (derivation R A M) :=
coe_injective.add_comm_monoid _ coe_zero coe_add (λ _ _, rfl)

/-- `coe_fn` as an `add_monoid_hom`. -/
def coe_fn_add_monoid_hom : derivation R A M →+ (A → M) :=
{ to_fun := coe_fn, map_zero' := coe_zero, map_add' := coe_add }

@[priority 100]
instance : distrib_mul_action S (derivation R A M) :=
function.injective.distrib_mul_action coe_fn_add_monoid_hom coe_injective coe_smul

instance [distrib_mul_action Sᵐᵒᵖ M] [is_central_scalar S M] :
  is_central_scalar S (derivation R A M) :=
{ op_smul_eq_smul := λ _ _, ext $ λ _, op_smul_eq_smul _ _}

end scalar

@[priority 100]
instance {S : Type*} [semiring S] [module S M] [smul_comm_class R S M] [smul_comm_class S A M] :
  module S (derivation R A M) :=
function.injective.module S coe_fn_add_monoid_hom coe_injective coe_smul

instance [is_scalar_tower R A M] : is_scalar_tower R A (derivation R A M) :=
⟨λ x y z, ext (λ a, smul_assoc _ _ _)⟩

section push_forward

variables {N : Type*} [add_comm_monoid N] [module A N] [module R N] [is_scalar_tower R A M]
  [is_scalar_tower R A N]
variables (f : M →ₗ[A] N) (e : M ≃ₗ[A] N)

/-- We can push forward derivations using linear maps, i.e., the composition of a derivation with a
linear map is a derivation. Furthermore, this operation is linear on the spaces of derivations. -/
def _root_.linear_map.comp_der : derivation R A M →ₗ[R] derivation R A N :=
{ to_fun    := λ D,
  { to_linear_map := (f : M →ₗ[R] N).comp (D : A →ₗ[R] M),
    map_one_eq_zero' := by simp only [linear_map.comp_apply, coe_fn_coe, map_one_eq_zero, map_zero],
    leibniz'  := λ a b, by simp only [coe_fn_coe, linear_map.comp_apply, linear_map.map_add,
      leibniz, linear_map.coe_coe_is_scalar_tower, linear_map.map_smul] },
  map_add'  := λ D₁ D₂, by { ext, exact linear_map.map_add _ _ _, },
  map_smul' := λ r D, by { ext, exact linear_map.map_smul _ _ _, }, }

@[simp] lemma coe_to_linear_map_comp :
  (f.comp_der D : A →ₗ[R] N) = (f : M →ₗ[R] N).comp (D : A →ₗ[R] M) :=
rfl

@[simp] lemma coe_comp :
  (f.comp_der D : A → N) = (f : M →ₗ[R] N).comp (D : A →ₗ[R] M) :=
rfl

/-- The composition of a derivation with a linear map as a bilinear map -/
@[simps]
def llcomp : (M →ₗ[A] N) →ₗ[A] derivation R A M →ₗ[R] derivation R A N :=
{ to_fun := λ f, f.comp_der,
  map_add' := λ f₁ f₂, by { ext, refl },
  map_smul' := λ r D, by { ext, refl } }

/-- Pushing a derivation foward through a linear equivalence is an equivalence. -/
def _root_.linear_equiv.comp_der : derivation R A M ≃ₗ[R] derivation R A N :=
{ inv_fun := e.symm.to_linear_map.comp_der,
  left_inv := λ D, by { ext a, exact e.symm_apply_apply (D a) },
  right_inv := λ D, by { ext a, exact e.apply_symm_apply (D a) },
  ..e.to_linear_map.comp_der }

end push_forward

section restrict_scalars

variables {S : Type*} [comm_semiring S]
variables [algebra S A] [module S M] [linear_map.compatible_smul A M R S]

variables (R)

/-- If `A` is both an `R`-algebra and an `S`-algebra; `M` is both an `R`-module and an `S`-module,
then an `S`-derivation `A → M` is also an `R`-derivation if it is also `R`-linear. -/
protected
def restrict_scalars (d : derivation S A M) : derivation R A M :=
{ map_one_eq_zero' := d.map_one_eq_zero,
  leibniz' := d.leibniz,
  to_linear_map := d.to_linear_map.restrict_scalars R }

end restrict_scalars

end

section cancel

variables {R : Type*} [comm_semiring R] {A : Type*} [comm_semiring A] [algebra R A]
  {M : Type*} [add_cancel_comm_monoid M] [module R M] [module A M]

/-- Define `derivation R A M` from a linear map when `M` is cancellative by verifying the Leibniz
rule. -/
def mk' (D : A →ₗ[R] M) (h : ∀ a b, D (a * b) = a • D b + b • D a) : derivation R A M :=
{ to_linear_map := D,
  map_one_eq_zero' := add_right_eq_self.1 $ by simpa only [one_smul, one_mul] using (h 1 1).symm,
  leibniz' := h }

@[simp] lemma coe_mk' (D : A →ₗ[R] M) (h) : ⇑(mk' D h) = D := rfl
@[simp] lemma coe_mk'_linear_map (D : A →ₗ[R] M) (h) : (mk' D h : A →ₗ[R] M) = D := rfl

end cancel

section

variables {R : Type*} [comm_ring R]
variables {A : Type*} [comm_ring A] [algebra R A]

section

variables {M : Type*} [add_comm_group M] [module A M] [module R M]
variables (D : derivation R A M) {D1 D2 : derivation R A M} (r : R) (a b : A)

protected lemma map_neg : D (-a) = -D a := map_neg D a
protected lemma map_sub : D (a - b) = D a - D b := map_sub D a b

@[simp] lemma map_coe_int (n : ℤ) : D (n : A) = 0 :=
by rw [← zsmul_one, D.map_smul_of_tower n, map_one_eq_zero, smul_zero]

lemma leibniz_of_mul_eq_one {a b : A} (h : a * b = 1) : D a = -a^2 • D b :=
begin
  rw neg_smul,
  refine eq_neg_of_add_eq_zero_left _,
  calc D a + a ^ 2 • D b = a • b • D a + a • a • D b : by simp only [smul_smul, h, one_smul, sq]
                     ... = a • D (a * b)             : by rw [leibniz, smul_add, add_comm]
                     ... = 0                         : by rw [h, map_one_eq_zero, smul_zero]
end

lemma leibniz_inv_of [invertible a] : D (⅟a) = -⅟a^2 • D a :=
D.leibniz_of_mul_eq_one $ inv_of_mul_self a

lemma leibniz_inv {K : Type*} [field K] [module K M] [algebra R K] (D : derivation R K M) (a : K) :
  D (a⁻¹) = -a⁻¹ ^ 2 • D a :=
begin
  rcases eq_or_ne a 0 with (rfl|ha),
  { simp },
  { exact D.leibniz_of_mul_eq_one (inv_mul_cancel ha) }
end

instance : has_neg (derivation R A M) :=
⟨λ D, mk' (-D) $  λ a b,
  by simp only [linear_map.neg_apply, smul_neg, neg_add_rev, leibniz, coe_fn_coe, add_comm]⟩

@[simp] lemma coe_neg (D : derivation R A M) : ⇑(-D) = -D := rfl
@[simp] lemma coe_neg_linear_map (D : derivation R A M) : ↑(-D) = (-D : A →ₗ[R] M) :=
rfl
lemma neg_apply : (-D) a = -D a := rfl

instance : has_sub (derivation R A M) :=
⟨λ D1 D2, mk' (D1 - D2 : A →ₗ[R] M) $ λ a b,
  by simp only [linear_map.sub_apply, leibniz, coe_fn_coe, smul_sub, add_sub_add_comm]⟩

@[simp] lemma coe_sub (D1 D2 : derivation R A M) : ⇑(D1 - D2) = D1 - D2 := rfl
@[simp] lemma coe_sub_linear_map (D1 D2 : derivation R A M) : ↑(D1 - D2) = (D1 - D2 : A →ₗ[R] M) :=
rfl
lemma sub_apply : (D1 - D2) a = D1 a - D2 a := rfl

instance : add_comm_group (derivation R A M) :=
coe_injective.add_comm_group _ coe_zero coe_add coe_neg coe_sub (λ _ _, rfl) (λ _ _, rfl)

end

section lie_structures

/-! # Lie structures -/

variables (D : derivation R A A) {D1 D2 : derivation R A A} (r : R) (a b : A)

/-- The commutator of derivations is again a derivation. -/
instance : has_bracket (derivation R A A) (derivation R A A) :=
⟨λ D1 D2, mk' (⁅(D1 : module.End R A), (D2 : module.End R A)⁆) $ λ a b,
  by { simp only [ring.lie_def, map_add, id.smul_eq_mul, linear_map.mul_apply, leibniz, coe_fn_coe,
    linear_map.sub_apply], ring, }⟩

@[simp] lemma commutator_coe_linear_map :
  ↑⁅D1, D2⁆ = ⁅(D1 : module.End R A), (D2 : module.End R A)⁆ := rfl

lemma commutator_apply : ⁅D1, D2⁆ a = D1 (D2 a) - D2 (D1 a) := rfl

instance : lie_ring (derivation R A A) :=
{ add_lie     := λ d e f, by { ext a, simp only [commutator_apply, add_apply, map_add], ring, },
  lie_add     := λ d e f, by { ext a, simp only [commutator_apply, add_apply, map_add], ring, },
  lie_self    := λ d, by { ext a, simp only [commutator_apply, add_apply, map_add], ring_nf, },
  leibniz_lie := λ d e f,
    by { ext a, simp only [commutator_apply, add_apply, sub_apply, map_sub], ring, } }

instance : lie_algebra R (derivation R A A) :=
{ lie_smul := λ r d e, by { ext a, simp only [commutator_apply, map_smul, smul_sub, smul_apply]},
  ..derivation.module }

end lie_structures

end

end derivation

section to_square_zero

universes u v w

variables {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [comm_semiring A] [comm_ring B]
variables [algebra R A] [algebra R B] (I : ideal B) (hI : I ^ 2 = ⊥)

/-- If `f₁ f₂ : A →ₐ[R] B` are two lifts of the same `A →ₐ[R] B ⧸ I`,
  we may define a map `f₁ - f₂ : A →ₗ[R] I`. -/
def diff_to_ideal_of_quotient_comp_eq (f₁ f₂ : A →ₐ[R] B)
  (e : (ideal.quotient.mkₐ R I).comp f₁ = (ideal.quotient.mkₐ R I).comp f₂) :
  A →ₗ[R] I :=
linear_map.cod_restrict (I.restrict_scalars _) (f₁.to_linear_map - f₂.to_linear_map)
begin
  intro x,
  change f₁ x - f₂ x ∈ I,
  rw [← ideal.quotient.eq, ← ideal.quotient.mkₐ_eq_mk R, ← alg_hom.comp_apply, e],
  refl,
end

@[simp]
lemma diff_to_ideal_of_quotient_comp_eq_apply (f₁ f₂ : A →ₐ[R] B)
  (e : (ideal.quotient.mkₐ R I).comp f₁ = (ideal.quotient.mkₐ R I).comp f₂) (x : A) :
  ((diff_to_ideal_of_quotient_comp_eq I f₁ f₂ e) x : B) = f₁ x - f₂ x :=
rfl

variables [algebra A B] [is_scalar_tower R A B]

include hI

/-- Given a tower of algebras `R → A → B`, and a square-zero `I : ideal B`, each lift `A →ₐ[R] B`
of the canonical map `A →ₐ[R] B ⧸ I` corresponds to a `R`-derivation from `A` to `I`. -/
def derivation_to_square_zero_of_lift
  (f : A →ₐ[R] B) (e : (ideal.quotient.mkₐ R I).comp f = is_scalar_tower.to_alg_hom R A (B ⧸ I)) :
  derivation R A I :=
begin
  refine
  { map_one_eq_zero' := _,
    leibniz' := _,
    ..(diff_to_ideal_of_quotient_comp_eq I f (is_scalar_tower.to_alg_hom R A B) _) },
  { rw e, ext, refl },
  { ext, change f 1 - algebra_map A B 1 = 0, rw [map_one, map_one, sub_self] },
  { intros x y,
    let F := diff_to_ideal_of_quotient_comp_eq I f (is_scalar_tower.to_alg_hom R A B)
      (by { rw e, ext, refl }),
    have : (f x - algebra_map A B x) * (f y - algebra_map A B y) = 0,
    { rw [← ideal.mem_bot, ← hI, pow_two],
      convert (ideal.mul_mem_mul (F x).2 (F y).2) using 1 },
    ext,
    dsimp only [submodule.coe_add, submodule.coe_mk, linear_map.coe_mk,
      diff_to_ideal_of_quotient_comp_eq_apply, submodule.coe_smul_of_tower,
      is_scalar_tower.coe_to_alg_hom', linear_map.to_fun_eq_coe],
    simp only [map_mul, sub_mul, mul_sub, algebra.smul_def] at ⊢ this,
    rw [sub_eq_iff_eq_add, sub_eq_iff_eq_add] at this,
    rw this,
    ring }
end

lemma derivation_to_square_zero_of_lift_apply (f : A →ₐ[R] B)
  (e : (ideal.quotient.mkₐ R I).comp f = is_scalar_tower.to_alg_hom R A (B ⧸ I))
  (x : A) : (derivation_to_square_zero_of_lift I hI f e x : B) = f x - algebra_map A B x := rfl

/-- Given a tower of algebras `R → A → B`, and a square-zero `I : ideal B`, each `R`-derivation
from `A` to `I` corresponds to a lift `A →ₐ[R] B` of the canonical map `A →ₐ[R] B ⧸ I`. -/
@[simps {attrs := []}]
def lift_of_derivation_to_square_zero (f : derivation R A I) :
  A →ₐ[R] B :=
{ to_fun := λ x, f x + algebra_map A B x,
  map_one' := by rw [map_one, f.map_one_eq_zero, submodule.coe_zero, zero_add],
  map_mul' := λ x y, begin
    have : (f x : B) * (f y) = 0,
    { rw [← ideal.mem_bot, ← hI, pow_two], convert (ideal.mul_mem_mul (f x).2 (f y).2) using 1 },
    simp only [map_mul, f.leibniz, add_mul, mul_add, submodule.coe_add,
      submodule.coe_smul_of_tower, algebra.smul_def, this],
    ring
  end,
  commutes' := λ r,
    by simp only [derivation.map_algebra_map, eq_self_iff_true, zero_add, submodule.coe_zero,
      ←is_scalar_tower.algebra_map_apply R A B r],
  map_zero' := ((I.restrict_scalars R).subtype.comp f.to_linear_map +
    (is_scalar_tower.to_alg_hom R A B).to_linear_map).map_zero,
  ..((I.restrict_scalars R).subtype.comp f.to_linear_map +
    (is_scalar_tower.to_alg_hom R A B).to_linear_map : A →ₗ[R] B) }

@[simp] lemma lift_of_derivation_to_square_zero_mk_apply (d : derivation R A I) (x : A) :
  ideal.quotient.mk I (lift_of_derivation_to_square_zero I hI d x) = algebra_map A (B ⧸ I) x :=
by { rw [lift_of_derivation_to_square_zero_apply, map_add,
  ideal.quotient.eq_zero_iff_mem.mpr (d x).prop, zero_add], refl }

/-- Given a tower of algebras `R → A → B`, and a square-zero `I : ideal B`,
there is a 1-1 correspondance between `R`-derivations from `A` to `I` and
lifts `A →ₐ[R] B` of the canonical map `A →ₐ[R] B ⧸ I`. -/
@[simps]
def derivation_to_square_zero_equiv_lift :
  derivation R A I ≃
    { f : A →ₐ[R] B // (ideal.quotient.mkₐ R I).comp f = is_scalar_tower.to_alg_hom R A (B ⧸ I) } :=
begin
  refine ⟨λ d, ⟨lift_of_derivation_to_square_zero I hI d, _⟩, λ f,
    (derivation_to_square_zero_of_lift I hI f.1 f.2 : _), _, _⟩,
  { ext x, exact lift_of_derivation_to_square_zero_mk_apply I hI d x },
  { intro d, ext x, exact add_sub_cancel (d x : B) (algebra_map A B x) },
  { rintro ⟨f, hf⟩, ext x,  exact sub_add_cancel (f x) (algebra_map A B x) }
end

end to_square_zero

section kaehler_differential

open_locale tensor_product

variables (R S : Type*) [comm_ring R] [comm_ring S] [algebra R S]

/-- The kernel of the multiplication map `S ⊗[R] S →ₐ[R] S`. -/
abbreviation kaehler_differential.ideal : ideal (S ⊗[R] S) :=
ring_hom.ker (tensor_product.lmul' R : S ⊗[R] S →ₐ[R] S)

variable {S}

lemma kaehler_differential.one_smul_sub_smul_one_mem_ideal (a : S) :
  (1 : S) ⊗ₜ[R] a - a ⊗ₜ[R] (1 : S) ∈ kaehler_differential.ideal R S :=
by simp [ring_hom.mem_ker]

variables {R}

variables {M : Type*} [add_comm_group M] [module R M] [module S M] [is_scalar_tower R S M]

/-- For a `R`-derivation `S → M`, this is the map `S ⊗[R] S →ₗ[S] M` sending `s ⊗ₜ t ↦ s • D t`. -/
def derivation.tensor_product_to (D : derivation R S M) : S ⊗[R] S →ₗ[S] M :=
tensor_product.algebra_tensor_module.lift ((linear_map.lsmul S (S →ₗ[R] M)).flip D.to_linear_map)

lemma derivation.tensor_product_to_tmul (D : derivation R S M) (s t : S) :
  D.tensor_product_to (s ⊗ₜ t) = s • D t :=
rfl

lemma derivation.tensor_product_to_mul (D : derivation R S M) (x y : S ⊗[R] S) :
  D.tensor_product_to (x * y) = tensor_product.lmul' R x • D.tensor_product_to y +
    tensor_product.lmul' R y • D.tensor_product_to x :=
begin
  apply tensor_product.induction_on x,
  { rw [zero_mul, map_zero, map_zero, zero_smul, smul_zero, add_zero] },
  swap, { rintros, simp only [add_mul, map_add, add_smul, *, smul_add], rw add_add_add_comm },
  intros x₁ x₂,
  apply tensor_product.induction_on y,
  { rw [mul_zero, map_zero, map_zero, zero_smul, smul_zero, add_zero] },
  swap, { rintros, simp only [mul_add, map_add, add_smul, *, smul_add], rw add_add_add_comm },
  intros x y,
  simp only [tensor_product.tmul_mul_tmul, derivation.tensor_product_to,
    tensor_product.algebra_tensor_module.lift_apply, tensor_product.lift.tmul',
    tensor_product.lmul'_apply_tmul],
  dsimp,
  rw D.leibniz,
  simp only [smul_smul, smul_add, mul_comm (x * y) x₁, mul_right_comm x₁ x₂, ← mul_assoc],
end

variables (R S)

/-- The kernel of `S ⊗[R] S →ₐ[R] S` is generated by `1 ⊗ s - s ⊗ 1` as a `S`-module. -/
lemma kaehler_differential.submodule_span_range_eq_ideal :
  submodule.span S (set.range $ λ s : S, (1 : S) ⊗ₜ[R] s - s ⊗ₜ[R] (1 : S)) =
    (kaehler_differential.ideal R S).restrict_scalars S :=
begin
  apply le_antisymm,
  { rw submodule.span_le,
    rintros _ ⟨s, rfl⟩,
    exact kaehler_differential.one_smul_sub_smul_one_mem_ideal _ _ },
  { rintros x (hx : _ = _),
    have : x - (tensor_product.lmul' R x) ⊗ₜ[R] (1 : S)   = x,
    { rw [hx, tensor_product.zero_tmul, sub_zero] },
    rw ← this,
    clear this hx,
    apply tensor_product.induction_on x; clear x,
    { rw [map_zero, tensor_product.zero_tmul, sub_zero], exact zero_mem _ },
    { intros x y,
      convert_to x • (1 ⊗ₜ y - y ⊗ₜ 1) ∈ _,
      { rw [tensor_product.lmul'_apply_tmul, smul_sub, tensor_product.smul_tmul',
          tensor_product.smul_tmul', smul_eq_mul, smul_eq_mul, mul_one] },
      { refine submodule.smul_mem _ x _,
        apply submodule.subset_span,
        exact set.mem_range_self y } },
    { intros x y hx hy,
      rw [map_add, tensor_product.add_tmul, ← sub_add_sub_comm],
      exact add_mem hx hy } }
end

lemma kaehler_differential.span_range_eq_ideal :
  ideal.span (set.range $ λ s : S, (1 : S) ⊗ₜ[R] s - s ⊗ₜ[R] (1 : S)) =
    kaehler_differential.ideal R S :=
begin
  apply le_antisymm,
  { rw ideal.span_le,
    rintros _ ⟨s, rfl⟩,
    exact kaehler_differential.one_smul_sub_smul_one_mem_ideal _ _ },
  { change (kaehler_differential.ideal R S).restrict_scalars S ≤ (ideal.span _).restrict_scalars S,
    rw [← kaehler_differential.submodule_span_range_eq_ideal, ideal.span],
    conv_rhs { rw ← submodule.span_span_of_tower S },
    exact submodule.subset_span }
end

/--
The module of Kähler differentials (Kahler differentials, Kaehler differentials).
This is implemented as `I / I ^ 2` with `I` the kernel of the multiplication map `S ⊗[R] S →ₐ[R] S`.
To view elements as a linear combination of the form `s • D s'`, use
`kaehler_differential.tensor_product_to_surjective` and `derivation.tensor_product_to_tmul`.

We also provide the notation `Ω[S⁄R]` for `kaehler_differential R S`.
Note that the slash is `\textfractionsolidus`.
-/
@[derive [add_comm_group, module (S ⊗[R] S)]]
def kaehler_differential : Type* := (kaehler_differential.ideal R S).cotangent

notation `Ω[`:100 S `⁄`:0 R `]`:0 := kaehler_differential R S

instance : nonempty Ω[S⁄R] := ⟨0⟩

instance kaehler_differential.module' {R' : Type*} [comm_ring R'] [algebra R' S] :
  module R' Ω[S⁄R] :=
(module.comp_hom (kaehler_differential.ideal R S).cotangent (algebra_map R' S) : _)

instance : is_scalar_tower S (S ⊗[R] S) Ω[S⁄R] :=
ideal.cotangent.is_scalar_tower _

instance kaehler_differential.is_scalar_tower_of_tower {R₁ R₂ : Type*} [comm_ring R₁] [comm_ring R₂]
  [algebra R₁ S] [algebra R₂ S] [algebra R₁ R₂] [is_scalar_tower R₁ R₂ S] :
  is_scalar_tower R₁ R₂ Ω[S⁄R] :=
begin
  convert restrict_scalars.is_scalar_tower R₁ R₂ Ω[S⁄R] using 1,
  ext x m,
  show algebra_map R₁ S x • m = algebra_map R₂ S (algebra_map R₁ R₂ x) • m,
  rw ← is_scalar_tower.algebra_map_apply,
end

instance kaehler_differential.is_scalar_tower' :
  is_scalar_tower R (S ⊗[R] S) Ω[S⁄R] :=
begin
  convert restrict_scalars.is_scalar_tower R (S ⊗[R] S) Ω[S⁄R] using 1,
  ext x m,
  show algebra_map R S x • m = algebra_map R (S ⊗[R] S) x • m,
  simp_rw [is_scalar_tower.algebra_map_apply R S (S ⊗[R] S), is_scalar_tower.algebra_map_smul]
end

/-- The quotient map `I → Ω[S⁄R]` with `I` being the kernel of `S ⊗[R] S → S`. -/
def kaehler_differential.from_ideal : kaehler_differential.ideal R S →ₗ[S ⊗[R] S] Ω[S⁄R] :=
(kaehler_differential.ideal R S).to_cotangent

/-- (Implementation) The underlying linear map of the derivation into `Ω[S⁄R]`. -/
def kaehler_differential.D_linear_map : S →ₗ[R] Ω[S⁄R] :=
((kaehler_differential.from_ideal R S).restrict_scalars R).comp
  ((tensor_product.include_right.to_linear_map - tensor_product.include_left.to_linear_map :
    S →ₗ[R] S ⊗[R] S).cod_restrict ((kaehler_differential.ideal R S).restrict_scalars R)
      (kaehler_differential.one_smul_sub_smul_one_mem_ideal R) : _ →ₗ[R] _)

lemma kaehler_differential.D_linear_map_apply (s : S) :
  kaehler_differential.D_linear_map R S s = (kaehler_differential.ideal R S).to_cotangent
    ⟨1 ⊗ₜ s - s ⊗ₜ 1, kaehler_differential.one_smul_sub_smul_one_mem_ideal R s⟩ :=
rfl

/-- The universal derivation into `Ω[S⁄R]`. -/
def kaehler_differential.D : derivation R S Ω[S⁄R] :=
{ map_one_eq_zero' := begin
    dsimp [kaehler_differential.D_linear_map_apply],
    rw [ideal.to_cotangent_eq_zero, subtype.coe_mk, sub_self],
    exact zero_mem _
  end,
  leibniz' := λ a b, begin
    dsimp [kaehler_differential.D_linear_map_apply],
    rw [← linear_map.map_smul_of_tower, ← linear_map.map_smul_of_tower, ← map_add,
      ideal.to_cotangent_eq, pow_two],
    convert submodule.mul_mem_mul (kaehler_differential.one_smul_sub_smul_one_mem_ideal R a : _)
      (kaehler_differential.one_smul_sub_smul_one_mem_ideal R b : _) using 1,
    simp only [add_subgroup_class.coe_sub, submodule.coe_add, submodule.coe_mk,
      tensor_product.tmul_mul_tmul, mul_sub, sub_mul, mul_comm b,
      submodule.coe_smul_of_tower, smul_sub, tensor_product.smul_tmul', smul_eq_mul, mul_one],
    ring_nf,
  end,
  ..(kaehler_differential.D_linear_map R S) }

lemma kaehler_differential.D_apply (s : S) :
  kaehler_differential.D R S s = (kaehler_differential.ideal R S).to_cotangent
    ⟨1 ⊗ₜ s - s ⊗ₜ 1, kaehler_differential.one_smul_sub_smul_one_mem_ideal R s⟩ :=
rfl

lemma kaehler_differential.span_range_derivation :
  submodule.span S (set.range $ kaehler_differential.D R S) = ⊤ :=
begin
  rw _root_.eq_top_iff,
  rintros x -,
  obtain ⟨⟨x, hx⟩, rfl⟩ := ideal.to_cotangent_surjective _ x,
  have : x ∈ (kaehler_differential.ideal R S).restrict_scalars S := hx,
  rw ← kaehler_differential.submodule_span_range_eq_ideal at this,
  suffices : ∃ hx, (kaehler_differential.ideal R S).to_cotangent ⟨x, hx⟩ ∈
    submodule.span S (set.range $ kaehler_differential.D R S),
  { exact this.some_spec },
  apply submodule.span_induction this,
  { rintros _ ⟨x, rfl⟩,
    refine ⟨kaehler_differential.one_smul_sub_smul_one_mem_ideal R x, _⟩,
    apply submodule.subset_span,
    exact ⟨x, kaehler_differential.D_linear_map_apply R S x⟩ },
  { exact ⟨zero_mem _, submodule.zero_mem _⟩ },
  { rintros x y ⟨hx₁, hx₂⟩ ⟨hy₁, hy₂⟩, exact ⟨add_mem hx₁ hy₁, submodule.add_mem _ hx₂ hy₂⟩ },
  { rintros r x ⟨hx₁, hx₂⟩, exact ⟨((kaehler_differential.ideal R S).restrict_scalars S).smul_mem
      r hx₁, submodule.smul_mem _ r hx₂⟩ }
end

variables {R S}

/-- The linear map from `Ω[S⁄R]`, associated with a derivation. -/
def derivation.lift_kaehler_differential (D : derivation R S M) : Ω[S⁄R] →ₗ[S] M :=
begin
  refine ((kaehler_differential.ideal R S • ⊤ :
    submodule (S ⊗[R] S) (kaehler_differential.ideal R S)).restrict_scalars S).liftq _ _,
  { exact D.tensor_product_to.comp ((kaehler_differential.ideal R S).subtype.restrict_scalars S) },
  { intros x hx,
    change _ = _,
    apply submodule.smul_induction_on hx; clear hx x,
    { rintros x (hx : _ = _) ⟨y, hy : _ = _⟩ -,
      dsimp,
      rw [derivation.tensor_product_to_mul, hx, hy, zero_smul, zero_smul, zero_add] },
    { intros x y ex ey, rw [map_add, ex, ey, zero_add] } }
end

lemma derivation.lift_kaehler_differential_apply (D : derivation R S M) (x) :
  D.lift_kaehler_differential
    ((kaehler_differential.ideal R S).to_cotangent x) = D.tensor_product_to x :=
rfl

lemma derivation.lift_kaehler_differential_comp (D : derivation R S M) :
  D.lift_kaehler_differential.comp_der (kaehler_differential.D R S) = D :=
begin
  ext a,
  dsimp [kaehler_differential.D_apply],
  refine (D.lift_kaehler_differential_apply _).trans _,
  rw [subtype.coe_mk, map_sub, derivation.tensor_product_to_tmul,
    derivation.tensor_product_to_tmul, one_smul, D.map_one_eq_zero, smul_zero, sub_zero],
end

@[simp] lemma derivation.lift_kaehler_differential_comp_D (D' : derivation R S M) (x : S) :
  D'.lift_kaehler_differential (kaehler_differential.D R S x) = D' x :=
derivation.congr_fun D'.lift_kaehler_differential_comp x

@[ext]
lemma derivation.lift_kaehler_differential_unique
  (f f' : Ω[S⁄R] →ₗ[S] M)
  (hf : f.comp_der (kaehler_differential.D R S) =
    f'.comp_der (kaehler_differential.D R S)) :
  f = f' :=
begin
  apply linear_map.ext,
  intro x,
  have : x ∈ submodule.span S (set.range $ kaehler_differential.D R S),
  { rw kaehler_differential.span_range_derivation, trivial },
  apply submodule.span_induction this,
  { rintros _ ⟨x, rfl⟩, exact congr_arg (λ D : derivation R S M, D x) hf },
  { rw [map_zero, map_zero] },
  { intros x y hx hy, rw [map_add, map_add, hx, hy] },
  { intros a x e, rw [map_smul, map_smul, e] }
end

variables (R S)

lemma derivation.lift_kaehler_differential_D :
  (kaehler_differential.D R S).lift_kaehler_differential = linear_map.id :=
derivation.lift_kaehler_differential_unique _ _
  (kaehler_differential.D R S).lift_kaehler_differential_comp

variables {R S}

lemma kaehler_differential.D_tensor_product_to (x : kaehler_differential.ideal R S) :
  (kaehler_differential.D R S).tensor_product_to x =
    (kaehler_differential.ideal R S).to_cotangent x :=
begin
  rw [← derivation.lift_kaehler_differential_apply, derivation.lift_kaehler_differential_D],
  refl,
end

variables (R S)

lemma kaehler_differential.tensor_product_to_surjective :
  function.surjective (kaehler_differential.D R S).tensor_product_to :=
begin
  intro x, obtain ⟨x, rfl⟩ := (kaehler_differential.ideal R S).to_cotangent_surjective x,
  exact ⟨x, kaehler_differential.D_tensor_product_to x⟩
end

/-- The `S`-linear maps from `Ω[S⁄R]` to `M` are (`S`-linearly) equivalent to `R`-derivations
from `S` to `M`.  -/
def kaehler_differential.linear_map_equiv_derivation : (Ω[S⁄R] →ₗ[S] M) ≃ₗ[S] derivation R S M :=
{ inv_fun := derivation.lift_kaehler_differential,
  left_inv := λ f, derivation.lift_kaehler_differential_unique _ _
    (derivation.lift_kaehler_differential_comp _),
  right_inv := derivation.lift_kaehler_differential_comp,
  ..(derivation.llcomp.flip $ kaehler_differential.D R S) }

/-- The quotient ring of `S ⊗ S ⧸ J ^ 2` by `Ω[S⁄R]` is isomorphic to `S`. -/
def kaehler_differential.quotient_cotangent_ideal_ring_equiv :
  (S ⊗ S ⧸ kaehler_differential.ideal R S ^ 2) ⧸
    (kaehler_differential.ideal R S).cotangent_ideal ≃+* S :=
begin
  have : function.right_inverse tensor_product.include_left
    (↑(tensor_product.lmul' R : S ⊗[R] S →ₐ[R] S) : S ⊗[R] S →+* S),
  { intro x, rw [alg_hom.coe_to_ring_hom, ← alg_hom.comp_apply,
      tensor_product.lmul'_comp_include_left], refl },
  refine (ideal.quot_cotangent _).trans _,
  refine (ideal.quot_equiv_of_eq _).trans (ring_hom.quotient_ker_equiv_of_right_inverse this),
  ext, refl,
end

/-- The quotient ring of `S ⊗ S ⧸ J ^ 2` by `Ω[S⁄R]` is isomorphic to `S` as an `S`-algebra. -/
def kaehler_differential.quotient_cotangent_ideal :
  ((S ⊗ S ⧸ kaehler_differential.ideal R S ^ 2) ⧸
    (kaehler_differential.ideal R S).cotangent_ideal) ≃ₐ[S] S :=
{ commutes' := (kaehler_differential.quotient_cotangent_ideal_ring_equiv R S).apply_symm_apply,
  ..kaehler_differential.quotient_cotangent_ideal_ring_equiv R S }

lemma kaehler_differential.End_equiv_aux (f : S →ₐ[R] S ⊗ S ⧸ kaehler_differential.ideal R S ^ 2) :
  (ideal.quotient.mkₐ R (kaehler_differential.ideal R S).cotangent_ideal).comp f =
    is_scalar_tower.to_alg_hom R S _ ↔
  (tensor_product.lmul' R : S ⊗[R] S →ₐ[R] S).ker_square_lift.comp f = alg_hom.id R S :=
begin
  rw [alg_hom.ext_iff, alg_hom.ext_iff],
  apply forall_congr,
  intro x,
  have e₁ : (tensor_product.lmul' R : S ⊗[R] S →ₐ[R] S).ker_square_lift (f x) =
    kaehler_differential.quotient_cotangent_ideal_ring_equiv R S
      (ideal.quotient.mk (kaehler_differential.ideal R S).cotangent_ideal $ f x),
  { generalize : f x = y, obtain ⟨y, rfl⟩ := ideal.quotient.mk_surjective y, refl },
  have e₂ : x = kaehler_differential.quotient_cotangent_ideal_ring_equiv
    R S (is_scalar_tower.to_alg_hom R S _ x),
  { exact (mul_one x).symm },
  split,
  { intro e,
    exact (e₁.trans (@ring_equiv.congr_arg _ _ _ _ _ _
      (kaehler_differential.quotient_cotangent_ideal_ring_equiv R S) _ _ e)).trans e₂.symm },
  { intro e, apply (kaehler_differential.quotient_cotangent_ideal_ring_equiv R S).injective,
    exact e₁.symm.trans (e.trans e₂) }
end

/-- Derivations into `Ω[S⁄R]` is equivalent to derivations
into `(kaehler_differential.ideal R S).cotangent_ideal` -/
-- This has type
-- `derivation R S Ω[ S / R ] ≃ₗ[R] derivation R S (kaehler_differential.ideal R S).cotangent_ideal`
-- But lean times-out if this is given explicitly.
noncomputable
def kaehler_differential.End_equiv_derivation' :=
@linear_equiv.comp_der R _ _ _ _ Ω[S⁄R] _ _ _ _ _ _ _ _ _
  ((kaehler_differential.ideal R S).cotangent_equiv_ideal.restrict_scalars S)

/-- (Implementation) An `equiv` version of `kaehler_differential.End_equiv_aux`.
Used in `kaehler_differential.End_equiv`. -/
def kaehler_differential.End_equiv_aux_equiv :
  {f // (ideal.quotient.mkₐ R (kaehler_differential.ideal R S).cotangent_ideal).comp f =
    is_scalar_tower.to_alg_hom R S _ } ≃
  { f // (tensor_product.lmul' R : S ⊗[R] S →ₐ[R] S).ker_square_lift.comp f = alg_hom.id R S } :=
(equiv.refl _).subtype_equiv (kaehler_differential.End_equiv_aux R S)

/--
The endomorphisms of `Ω[S⁄R]` corresponds to sections of the surjection `S ⊗[R] S ⧸ J ^ 2 →ₐ[R] S`,
with `J` being the kernel of the multiplication map `S ⊗[R] S →ₐ[R] S`.
-/
noncomputable
def kaehler_differential.End_equiv :
  module.End S Ω[S⁄R] ≃
    { f // (tensor_product.lmul' R : S ⊗[R] S →ₐ[R] S).ker_square_lift.comp f = alg_hom.id R S } :=
(kaehler_differential.linear_map_equiv_derivation R S).to_equiv.trans $
  (kaehler_differential.End_equiv_derivation' R S).to_equiv.trans $
  (derivation_to_square_zero_equiv_lift
  (kaehler_differential.ideal R S).cotangent_ideal
  (kaehler_differential.ideal R S).cotangent_ideal_square).trans $
  kaehler_differential.End_equiv_aux_equiv R S

section presentation

open kaehler_differential (D)
open finsupp (single)

/-- The `S`-submodule of `S →₀ S` (the direct sum of copies of `S` indexed by `S`) generated by
the relations:
1. `dx + dy = d(x + y)`
2. `x dy + y dx = d(x * y)`
3. `dr = 0` for `r ∈ R`
where `db` is the unit in the copy of `S` with index `b`.

This is the kernel of the surjection `finsupp.total S Ω[S⁄R] S (kaehler_differential.D R S)`.
See `kaehler_differential.ker_total_eq` and `kaehler_differential.total_surjective`.
-/
noncomputable
def kaehler_differential.ker_total : submodule S (S →₀ S) :=
submodule.span S
  ((set.range (λ (x : S × S), single x.1 1 + single x.2 1 - single (x.1 + x.2) 1)) ∪
  (set.range (λ (x : S × S), single x.2 x.1 + single x.1 x.2 - single (x.1 * x.2) 1)) ∪
  (set.range (λ x : R, single (algebra_map R S x) 1)))

local notation x `𝖣` y := (kaehler_differential.ker_total R S).mkq (single y x)

lemma kaehler_differential.ker_total_mkq_single_add (x y z) :
  (z 𝖣 (x + y)) = (z 𝖣 x) + (z 𝖣 y) :=
begin
  rw [← map_add, eq_comm, ← sub_eq_zero, ← map_sub, submodule.mkq_apply,
    submodule.quotient.mk_eq_zero],
  simp_rw [← finsupp.smul_single_one _ z, ← smul_add, ← smul_sub],
  exact submodule.smul_mem _ _ (submodule.subset_span (or.inl $ or.inl $ ⟨⟨_, _⟩, rfl⟩)),
end

lemma kaehler_differential.ker_total_mkq_single_mul (x y z) :
  (z 𝖣 (x * y)) = ((z * x) 𝖣 y) + ((z * y) 𝖣 x) :=
begin
  rw [← map_add, eq_comm, ← sub_eq_zero, ← map_sub, submodule.mkq_apply,
    submodule.quotient.mk_eq_zero],
  simp_rw [← finsupp.smul_single_one _ z, ← @smul_eq_mul _ _ z,
    ← finsupp.smul_single, ← smul_add, ← smul_sub],
  exact submodule.smul_mem _ _ (submodule.subset_span (or.inl $ or.inr $ ⟨⟨_, _⟩, rfl⟩)),
end

lemma kaehler_differential.ker_total_mkq_single_algebra_map (x y) :
  (y 𝖣 (algebra_map R S x)) = 0 :=
begin
  rw [submodule.mkq_apply, submodule.quotient.mk_eq_zero, ← finsupp.smul_single_one _ y],
  exact submodule.smul_mem _ _ (submodule.subset_span (or.inr $ ⟨_, rfl⟩)),
end

lemma kaehler_differential.ker_total_mkq_single_algebra_map_one (x) :
  (x 𝖣 1) = 0 :=
begin
  rw [← (algebra_map R S).map_one, kaehler_differential.ker_total_mkq_single_algebra_map],
end

lemma kaehler_differential.ker_total_mkq_single_smul (r : R) (x y) :
  (y 𝖣 (r • x)) = r • (y 𝖣 x) :=
begin
  rw [algebra.smul_def, kaehler_differential.ker_total_mkq_single_mul,
    kaehler_differential.ker_total_mkq_single_algebra_map, add_zero,
    ← linear_map.map_smul_of_tower, finsupp.smul_single, mul_comm, algebra.smul_def],
end

/-- The (universal) derivation into `(S →₀ S) ⧸ kaehler_differential.ker_total R S`. -/
noncomputable
def kaehler_differential.derivation_quot_ker_total :
  derivation R S ((S →₀ S) ⧸ kaehler_differential.ker_total R S) :=
{ to_fun := λ x, 1 𝖣 x,
  map_add' := λ x y, kaehler_differential.ker_total_mkq_single_add _ _ _ _ _,
  map_smul' := λ r s, kaehler_differential.ker_total_mkq_single_smul _ _ _ _ _,
  map_one_eq_zero' := kaehler_differential.ker_total_mkq_single_algebra_map_one _ _ _,
  leibniz' := λ a b, (kaehler_differential.ker_total_mkq_single_mul _ _ _ _ _).trans
    (by { simp_rw [← finsupp.smul_single_one _ (1 * _ : S)], dsimp, simp }) }

lemma kaehler_differential.derivation_quot_ker_total_apply (x) :
  kaehler_differential.derivation_quot_ker_total R S x = (1 𝖣 x) := rfl

lemma kaehler_differential.derivation_quot_ker_total_lift_comp_total :
  (kaehler_differential.derivation_quot_ker_total R S).lift_kaehler_differential.comp
    (finsupp.total S Ω[S⁄R] S (kaehler_differential.D R S)) = submodule.mkq _ :=
begin
  apply finsupp.lhom_ext,
  intros a b,
  conv_rhs { rw [← finsupp.smul_single_one a b, linear_map.map_smul] },
  simp [kaehler_differential.derivation_quot_ker_total_apply],
end

lemma kaehler_differential.ker_total_eq :
  (finsupp.total S Ω[S⁄R] S (kaehler_differential.D R S)).ker =
    kaehler_differential.ker_total R S :=
begin
  apply le_antisymm,
  { conv_rhs { rw ← (kaehler_differential.ker_total R S).ker_mkq },
    rw ← kaehler_differential.derivation_quot_ker_total_lift_comp_total,
    exact linear_map.ker_le_ker_comp _ _ },
  { rw [kaehler_differential.ker_total, submodule.span_le],
    rintros _ ((⟨⟨x, y⟩, rfl⟩|⟨⟨x, y⟩, rfl⟩)|⟨x, rfl⟩); dsimp; simp [linear_map.mem_ker] },
end

lemma kaehler_differential.total_surjective :
  function.surjective (finsupp.total S Ω[S⁄R] S (kaehler_differential.D R S)) :=
begin
  rw [← linear_map.range_eq_top, finsupp.range_total, kaehler_differential.span_range_derivation],
end

/-- `Ω[S⁄R]` is isomorphic to `S` copies of `S` with kernel `kaehler_differential.ker_total`. -/
@[simps] noncomputable
def kaehler_differential.quot_ker_total_equiv :
  ((S →₀ S) ⧸ kaehler_differential.ker_total R S) ≃ₗ[S] Ω[S⁄R] :=
{ inv_fun := (kaehler_differential.derivation_quot_ker_total R S).lift_kaehler_differential,
  left_inv := begin
    intro x,
    obtain ⟨x, rfl⟩ := submodule.mkq_surjective _ x,
    exact linear_map.congr_fun
      (kaehler_differential.derivation_quot_ker_total_lift_comp_total R S : _) x,
  end,
  right_inv := begin
    intro x,
    obtain ⟨x, rfl⟩ := kaehler_differential.total_surjective R S x,
    erw linear_map.congr_fun
      (kaehler_differential.derivation_quot_ker_total_lift_comp_total R S : _) x,
    refl
  end,
  ..(kaehler_differential.ker_total R S).liftq
    (finsupp.total S Ω[S⁄R] S (kaehler_differential.D R S))
    (kaehler_differential.ker_total_eq R S).ge }

lemma kaehler_differential.quot_ker_total_equiv_symm_comp_D :
  (kaehler_differential.quot_ker_total_equiv R S).symm.to_linear_map.comp_der
    (kaehler_differential.D R S) = kaehler_differential.derivation_quot_ker_total R S :=
by convert
  (kaehler_differential.derivation_quot_ker_total R S).lift_kaehler_differential_comp using 0

variables (A B : Type*) [comm_ring A] [comm_ring B] [algebra R A] [algebra S B] [algebra R B]
variables [algebra A B] [is_scalar_tower R S B] [is_scalar_tower R A B]

-- The map `(A →₀ A) →ₗ[A] (B →₀ B)`
local notation `finsupp_map` := ((finsupp.map_range.linear_map (algebra.of_id A B).to_linear_map)
  .comp (finsupp.lmap_domain A A (algebra_map A B)))

lemma kaehler_differential.ker_total_map (h : function.surjective (algebra_map A B)) :
  (kaehler_differential.ker_total R A).map finsupp_map ⊔
    submodule.span A (set.range (λ x : S, single (algebra_map S B x) (1 : B))) =
    (kaehler_differential.ker_total S B).restrict_scalars _  :=
begin
  rw [kaehler_differential.ker_total, submodule.map_span, kaehler_differential.ker_total,
    submodule.restrict_scalars_span _ _ h],
  simp_rw [set.image_union, submodule.span_union, ← set.image_univ, set.image_image,
    set.image_univ, map_sub, map_add],
  simp only [linear_map.comp_apply, finsupp.map_range.linear_map_apply, finsupp.map_range_single,
    finsupp.lmap_domain_apply, finsupp.map_domain_single, alg_hom.to_linear_map_apply,
    algebra.of_id_apply, ← is_scalar_tower.algebra_map_apply, map_one, map_add, map_mul],
  simp_rw [sup_assoc, ← (h.prod_map h).range_comp],
  congr' 3,
  rw [sup_eq_right],
  apply submodule.span_mono,
  simp_rw is_scalar_tower.algebra_map_apply R S B,
  exact set.range_comp_subset_range (algebra_map R S) (λ x, single (algebra_map S B x) (1 : B))
end

end presentation

section exact_sequence

local attribute [irreducible] kaehler_differential

/- We have the commutative diagram
A --→ B
↑     ↑
|     |
R --→ S -/
variables (A B : Type*) [comm_ring A] [comm_ring B] [algebra R A] [algebra R B]
variables [algebra A B] [algebra S B] [is_scalar_tower R A B] [is_scalar_tower R S B]

variables {R B}

/-- For a tower `R → A → B` and an `R`-derivation `B → M`, we may compose with `A → B` to obtain an
`R`-derivation `A → M`. -/
def derivation.comp_algebra_map [module A M] [module B M] [is_scalar_tower A B M]
  (d : derivation R B M) : derivation R A M :=
{ map_one_eq_zero' := by simp,
  leibniz' := λ a b, by simp,
  to_linear_map := d.to_linear_map.comp (is_scalar_tower.to_alg_hom R A B).to_linear_map }

variables (R B)

/-- The map `Ω[A⁄R] →ₗ[A] Ω[B⁄R]` given a square
A --→ B
↑     ↑
|     |
R --→ S -/
def kaehler_differential.map : Ω[A⁄R] →ₗ[A] Ω[B⁄S] :=
derivation.lift_kaehler_differential
  (((kaehler_differential.D S B).restrict_scalars R).comp_algebra_map A)

lemma kaehler_differential.map_comp_der :
  (kaehler_differential.map R S A B).comp_der (kaehler_differential.D R A) =
    (((kaehler_differential.D S B).restrict_scalars R).comp_algebra_map A) :=
derivation.lift_kaehler_differential_comp _

lemma kaehler_differential.map_D (x : A) :
  kaehler_differential.map R S A B (kaehler_differential.D R A x) =
    kaehler_differential.D S B (algebra_map A B x) :=
derivation.congr_fun (kaehler_differential.map_comp_der R S A B) x

open is_scalar_tower (to_alg_hom)

lemma kaehler_differential.map_surjective_of_surjective
  (h : function.surjective (algebra_map A B)) :
  function.surjective (kaehler_differential.map R S A B) :=
begin
  rw [← linear_map.range_eq_top, _root_.eq_top_iff, ← @submodule.restrict_scalars_top B A,
    ← kaehler_differential.span_range_derivation, submodule.restrict_scalars_span _ _ h,
    submodule.span_le],
  rintros _ ⟨x, rfl⟩,
  obtain ⟨y, rfl⟩ := h x,
  rw ← kaehler_differential.map_D R S A B,
  exact ⟨_, rfl⟩,
end

/-- The lift of the map `Ω[A⁄R] →ₗ[A] Ω[B⁄R]` to the base change along `A → B`.
This is the first map in the exact sequence `B ⊗[A] Ω[A⁄R] → Ω[B⁄R] → Ω[B⁄A] → 0`. -/
noncomputable
def kaehler_differential.map_base_change : B ⊗[A] Ω[A⁄R] →ₗ[B] Ω[B⁄R] :=
(tensor_product.is_base_change A Ω[A⁄R] B).lift (kaehler_differential.map R R A B)

@[simp]
lemma kaehler_differential.map_base_change_tmul (x : B) (y : Ω[A⁄R]) :
  kaehler_differential.map_base_change R A B (x ⊗ₜ y) =
    x • kaehler_differential.map R R A B y :=
begin
  conv_lhs { rw [← mul_one x, ← smul_eq_mul, ← tensor_product.smul_tmul', linear_map.map_smul] },
  congr' 1,
  exact is_base_change.lift_eq _ _ _
end

end exact_sequence

end kaehler_differential


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

! This file was ported from Lean 3 source module data.complex.determinant
! leanprover-community/mathlib commit 65ec59902eb17e4ab7da8d7e3d0bd9774d1b8b99
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Complex.Module
import Mathbin.LinearAlgebra.Determinant

/-!
# Determinants of maps in the complex numbers as a vector space over `ℝ`

This file provides results about the determinants of maps in the complex numbers as a vector
space over `ℝ`.

-/

namespace Complex

/-- The determinant of `conj_ae`, as a linear map. -/
@[simp]
theorem det_conjAe : conjAe.toLinearMap.det = -1 :=
  by
  rw [← LinearMap.det_toMatrix basis_one_I, to_matrix_conj_ae, Matrix.det_fin_two_of]
  simp
#align complex.det_conj_ae Complex.det_conjAe

/-- The determinant of `conj_ae`, as a linear equiv. -/
@[simp]
theorem linearEquiv_det_conjAe : conjAe.toLinearEquiv.det = -1 := by
  rw [← Units.eq_iff, LinearEquiv.coe_det, ← LinearEquiv.toLinearMap_eq_coe,
    AlgEquiv.toLinearEquiv_toLinearMap, det_conj_ae, Units.coe_neg_one]
#align complex.linear_equiv_det_conj_ae Complex.linearEquiv_det_conjAe

end Complex


variable {a b c : Prop}

theorem ex1 (Ha : a) (Hab : a → b) (Hbc : b → c) : c :=
  suffices b from Hbc this
  suffices a from Hab this
  Ha

theorem ex2 (Ha : a) (Hab : a → b) (Hbc : b → c) : c :=
  suffices b by apply Hbc; assumption
  suffices a by apply Hab; exact this
  Ha

theorem ex3 (Ha : a) (Hab : a → b) (Hbc : b → c) : c := by
  suffices b by apply Hbc; assumption
  suffices a by apply Hab; assumption
  assumption

theorem ex4 (Ha : a) (Hab : a → b) (Hbc : b → c) : c :=
  suffices h1 : b from Hbc h1
  suffices h2 : a from Hab h2
  Ha

theorem ex5 (Ha : a) (Hab : a → b) (Hbc : b → c) : c := by
  suffices h1 : b by apply Hbc; assumption
  suffices h2 : a by apply Hab; exact h2
  assumption


-- Definición del condicional mediante la negación y la disyunción
-- ===============================================================

import tactic

variables (P Q : Prop)

open_locale classical

-- ----------------------------------------------------
-- Ejercicio. Demostrar que
--    (P → Q) ↔ (¬ P ∨ Q)
-- ----------------------------------------------------

-- 1ª demostración
example :
  (P → Q) ↔ (¬ P ∨ Q) :=
begin
  split,
  { intro hPQ,
    by_cases hP : P,
    { right,
      apply hPQ,
      exact hP, },
    { left,
      exact hP, }},
  { intros h hP,
    cases h with hnP hQ,
    { exact absurd hP hnP, },
    { exact hQ, }},
end

-- 2ª demostración
example :
  (P → Q) ↔ (¬ P ∨ Q) :=
begin
  split,
  { intro hPQ,
    by_cases hP : P,
    { exact or.inr (hPQ hP), },
    { exact or.inl hP, }},
  { rintros (hnP | hQ) hP,
    { exact absurd hP hnP, },
    { exact hQ, }},
end

-- 3ª demostración
example :
  (P → Q) ↔ (¬ P ∨ Q) :=
iff.intro
  ( assume hPQ : P → Q,
    show ¬P ∨ Q, from
      or.elim (em P)
      ( assume hP : P,
        have hQ : Q,
          from hPQ hP,
        show ¬P ∨ Q,
          from or.inr hQ)
      ( assume hnP : ¬P,
        show ¬P ∨ Q,
          from or.inl hnP))
  ( assume hnPQ : ¬P ∨ Q,
    assume hP: P,
    show Q, from
      or.elim hnPQ
        ( assume hnP : ¬P,
          show Q,
            from absurd hP hnP)
        ( assume hQ : Q,
          show Q,
            from hQ))

-- 4ª demostración
example :
  (P → Q) ↔ (¬ P ∨ Q) :=
iff.intro
  (λ hPQ, or.elim (em P)
    (λ hP,  or.inr (hPQ hP))
    (λ hnP, or.inl hnP))
  (λ hnPQ hP, or.elim hnPQ
    (λ hnP, absurd hP hnP)
    id)

-- 5ª demostración
example :
  (P → Q) ↔ (¬ P ∨ Q) :=
-- by library_search
imp_iff_not_or

-- 6ª demostración
example :
  (P → Q) ↔ (¬ P ∨ Q) :=
⟨λ hPQ, if hP : P then or.inr (hPQ hP) else or.inl hP,
 λ hnPQ hP, or.elim hnPQ (λ hnP, absurd hP hnP) id⟩

-- 7ª demostración
example :
  (P → Q) ↔ (¬ P ∨ Q) :=
-- by hint
by tauto

-- 8ª demostración
example :
  (P → Q) ↔ (¬ P ∨ Q) :=
by finish