/-
Copyright (c) 2021 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Riccardo Brasca
-/

import ring_theory.polynomial.cyclotomic.basic
import number_theory.number_field.basic
import algebra.char_p.algebra
import field_theory.galois

/-!
# Cyclotomic extensions

Let `A` and `B` be commutative rings with `algebra A B`. For `S : set ℕ+`, we define a class
`is_cyclotomic_extension S A B` expressing the fact that `B` is obtained from `A` by adding `n`-th
primitive roots of unity, for all `n ∈ S`.

## Main definitions

* `is_cyclotomic_extension S A B` : means that `B` is obtained from `A` by adding `n`-th primitive
  roots of unity, for all `n ∈ S`.
* `cyclotomic_field`: given `n : ℕ+` and a field `K`, we define `cyclotomic n K` as the splitting
  field of `cyclotomic n K`. If `n` is nonzero in `K`, it has the instance
  `is_cyclotomic_extension {n} K (cyclotomic_field n K)`.
* `cyclotomic_ring` : if `A` is a domain with fraction field `K` and `n : ℕ+`, we define
  `cyclotomic_ring n A K` as the `A`-subalgebra of `cyclotomic_field n K` generated by the roots of
  `X ^ n - 1`. If `n` is nonzero in `A`, it has the instance
  `is_cyclotomic_extension {n} A (cyclotomic_ring n A K)`.

## Main results

* `is_cyclotomic_extension.trans` : if `is_cyclotomic_extension S A B` and
  `is_cyclotomic_extension T B C`, then `is_cyclotomic_extension (S ∪ T) A C` if
  `function.injective (algebra_map B C)`.
* `is_cyclotomic_extension.union_right` : given `is_cyclotomic_extension (S ∪ T) A B`, then
  `is_cyclotomic_extension T (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }) B`.
* `is_cyclotomic_extension.union_right` : given `is_cyclotomic_extension T A B` and `S ⊆ T`, then
  `is_cyclotomic_extension S A (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 })`.
* `is_cyclotomic_extension.finite` : if `S` is finite and `is_cyclotomic_extension S A B`, then
  `B` is a finite `A`-algebra.
* `is_cyclotomic_extension.number_field` : a finite cyclotomic extension of a number field is a
  number field.
* `is_cyclotomic_extension.splitting_field_X_pow_sub_one` : if `is_cyclotomic_extension {n} K L`,
  then `L` is the splitting field of `X ^ n - 1`.
* `is_cyclotomic_extension.splitting_field_cyclotomic` : if `is_cyclotomic_extension {n} K L`,
  then `L` is the splitting field of `cyclotomic n K`.

## Implementation details

Our definition of `is_cyclotomic_extension` is very general, to allow rings of any characteristic
and infinite extensions, but it will mainly be used in the case `S = {n}` and for integral domains.
All results are in the `is_cyclotomic_extension` namespace.
Note that some results, for example `is_cyclotomic_extension.trans`,
`is_cyclotomic_extension.finite`, `is_cyclotomic_extension.number_field`,
`is_cyclotomic_extension.finite_dimensional`, `is_cyclotomic_extension.is_galois` and
`cyclotomic_field.algebra_base` are lemmas, but they can be made local instances. Some of them are
included in the `cyclotomic` locale.

-/

open polynomial algebra finite_dimensional set

open_locale big_operators

universes u v w z

variables (n : ℕ+) (S T : set ℕ+) (A : Type u) (B : Type v) (K : Type w) (L : Type z)
variables [comm_ring A] [comm_ring B] [algebra A B]
variables [field K] [field L] [algebra K L]

noncomputable theory

/-- Given an `A`-algebra `B` and `S : set ℕ+`, we define `is_cyclotomic_extension S A B` requiring
that there is a `n`-th primitive root of unity in `B` for all `n ∈ S` and that `B` is generated
over `A` by the roots of `X ^ n - 1`. -/
@[mk_iff] class is_cyclotomic_extension : Prop :=
(exists_prim_root {n : ℕ+} (ha : n ∈ S) : ∃ r : B, is_primitive_root r n)
(adjoin_roots : ∀ (x : B), x ∈ adjoin A { b : B | ∃ n : ℕ+, n ∈ S ∧ b ^ (n : ℕ) = 1 })

namespace is_cyclotomic_extension

section basic

/-- A reformulation of `is_cyclotomic_extension` that uses `⊤`. -/
lemma iff_adjoin_eq_top : is_cyclotomic_extension S A B ↔
 (∀ (n : ℕ+), n ∈ S → ∃ r : B, is_primitive_root r n) ∧
 (adjoin A { b : B | ∃ n : ℕ+, n ∈ S ∧ b ^ (n : ℕ) = 1 } = ⊤) :=
⟨λ h, ⟨λ _, h.exists_prim_root, algebra.eq_top_iff.2 h.adjoin_roots⟩,
  λ h, ⟨h.1, algebra.eq_top_iff.1 h.2⟩⟩

/-- A reformulation of `is_cyclotomic_extension` in the case `S` is a singleton. -/
lemma iff_singleton : is_cyclotomic_extension {n} A B ↔
 (∃ r : B, is_primitive_root r n) ∧
 (∀ x, x ∈ adjoin A { b : B | b ^ (n : ℕ) = 1 }) :=
by simp [is_cyclotomic_extension_iff]

/-- If `is_cyclotomic_extension ∅ A B`, then the image of `A` in `B` equals `B`. -/
lemma empty [h : is_cyclotomic_extension ∅ A B] : (⊥ : subalgebra A B) = ⊤ :=
by simpa [algebra.eq_top_iff, is_cyclotomic_extension_iff] using h

/-- If `is_cyclotomic_extension {1} A B`, then the image of `A` in `B` equals `B`. -/
lemma singleton_one [h : is_cyclotomic_extension {1} A B] : (⊥ : subalgebra A B) = ⊤ :=
algebra.eq_top_iff.2 (λ x, by simpa [adjoin_singleton_one]
  using ((is_cyclotomic_extension_iff _ _ _).1 h).2 x)

variables {A B}

/-- If `(⊥ : subalgebra A B) = ⊤`, then `is_cyclotomic_extension ∅ A B`. -/
lemma singleton_zero_of_bot_eq_top (h : (⊥ : subalgebra A B) = ⊤) :
  is_cyclotomic_extension ∅ A B :=
begin
  refine (iff_adjoin_eq_top _ _ _).2 ⟨λ s hs, by simpa using hs, _root_.eq_top_iff.2 (λ x hx, _)⟩,
  rw [← h] at hx,
  simpa using hx,
end

variables (A B)

/-- Transitivity of cyclotomic extensions. -/
lemma trans (C : Type w) [comm_ring C] [algebra A C] [algebra B C]
  [is_scalar_tower A B C] [hS : is_cyclotomic_extension S A B]
  [hT : is_cyclotomic_extension T B C] (h : function.injective (algebra_map B C)) :
  is_cyclotomic_extension (S ∪ T) A C :=
begin
  refine ⟨λ n hn, _, λ x, _⟩,
  { cases hn,
    { obtain ⟨b, hb⟩ := ((is_cyclotomic_extension_iff _ _ _).1 hS).1 hn,
      refine ⟨algebra_map B C b, _⟩,
      exact hb.map_of_injective h },
    { exact ((is_cyclotomic_extension_iff _ _ _).1 hT).1 hn } },
  { refine adjoin_induction (((is_cyclotomic_extension_iff _ _ _).1 hT).2 x) (λ c ⟨n, hn⟩,
      subset_adjoin ⟨n, or.inr hn.1, hn.2⟩) (λ b, _) (λ x y hx hy, subalgebra.add_mem _ hx hy)
      (λ x y hx hy, subalgebra.mul_mem _ hx hy),
    { let f := is_scalar_tower.to_alg_hom A B C,
      have hb : f b ∈ (adjoin A { b : B | ∃ (a : ℕ+), a ∈ S ∧ b ^ (a : ℕ) = 1 }).map f :=
        ⟨b, ((is_cyclotomic_extension_iff _ _ _).1 hS).2 b, rfl⟩,
      rw [is_scalar_tower.to_alg_hom_apply, ← adjoin_image] at hb,
      refine adjoin_mono (λ y hy, _) hb,
      obtain ⟨b₁, ⟨⟨n, hn⟩, h₁⟩⟩ := hy,
      exact ⟨n, ⟨mem_union_left T hn.1, by rw [← h₁, ← alg_hom.map_pow, hn.2, alg_hom.map_one]⟩⟩ } }
end

@[nontriviality] lemma subsingleton_iff [subsingleton B] :
  is_cyclotomic_extension S A B ↔ S = {} ∨ S = {1} :=
begin
  split,
  { rintro ⟨hprim, -⟩,
    rw ←subset_singleton_iff_eq,
    intros t ht,
    obtain ⟨ζ, hζ⟩ := hprim ht,
    rw [mem_singleton_iff, ←pnat.coe_eq_one_iff],
    exact_mod_cast hζ.unique (is_primitive_root.of_subsingleton ζ) },
  { rintro (rfl|rfl),
    { refine ⟨λ _ h, h.elim, λ x, by convert (mem_top : x ∈ ⊤)⟩ },
    { rw iff_singleton,
      refine ⟨⟨0, is_primitive_root.of_subsingleton 0⟩, λ x, by convert (mem_top : x ∈ ⊤)⟩ } }
end

/-- If `B` is a cyclotomic extension of `A` given by roots of unity of order in `S ∪ T`, then `B`
is a cyclotomic extension of `adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 } ` given by
roots of unity of order in `T`. -/
lemma union_right [h : is_cyclotomic_extension (S ∪ T) A B] :
  is_cyclotomic_extension T (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }) B :=
begin
  have : { b : B | ∃ (n : ℕ+), n ∈ S ∪ T ∧ b ^ (n : ℕ) = 1 } =
    { b : B | ∃ (n : ℕ+), n ∈ S ∧ b ^ (n : ℕ) = 1 } ∪
    { b : B | ∃ (n : ℕ+), n ∈ T ∧ b ^ (n : ℕ) = 1 },
  { refine le_antisymm (λ x hx, _) (λ x hx, _),
    { rcases hx with ⟨n, hn₁ | hn₂, hnpow⟩,
      { left, exact ⟨n, hn₁, hnpow⟩ },
      { right, exact ⟨n, hn₂, hnpow⟩ } },
    { rcases hx with ⟨n, hn⟩ | ⟨n, hn⟩,
      { exact ⟨n, or.inl hn.1, hn.2⟩ },
      { exact ⟨n, or.inr hn.1, hn.2⟩ } } },

  refine ⟨λ n hn, ((is_cyclotomic_extension_iff _ _ _).1 h).1 (mem_union_right S hn), λ b, _⟩,
  replace h := ((is_cyclotomic_extension_iff _ _ _).1 h).2 b,
  rwa [this, adjoin_union_eq_adjoin_adjoin, subalgebra.mem_restrict_scalars] at h
end

/-- If `B` is a cyclotomic extension of `A` given by roots of unity of order in `T` and `S ⊆ T`,
then `adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }` is a cyclotomic extension of `B`
given by roots of unity of order in `S`. -/
lemma union_left [h : is_cyclotomic_extension T A B] (hS : S ⊆ T) :
  is_cyclotomic_extension S A (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }) :=
begin
  refine ⟨λ n hn, _, λ b, _⟩,
  { obtain ⟨b, hb⟩ := ((is_cyclotomic_extension_iff _ _ _).1 h).1 (hS hn),
    refine ⟨⟨b, subset_adjoin ⟨n, hn, hb.pow_eq_one⟩⟩, _⟩,
    rwa [← is_primitive_root.coe_submonoid_class_iff, subtype.coe_mk] },
  { convert mem_top,
    rw [← adjoin_adjoin_coe_preimage, preimage_set_of_eq],
    norm_cast }
end

variables {n S}

/-- If `∀ s ∈ S, n ∣ s` and `S` is not empty, then `is_cyclotomic_extension S A B` implies
`is_cyclotomic_extension (S ∪ {n}) A B`. -/
lemma of_union_of_dvd (h : ∀ s ∈ S, n ∣ s) (hS : S.nonempty) [H : is_cyclotomic_extension S A B] :
  is_cyclotomic_extension (S ∪ {n}) A B :=
begin
  refine (iff_adjoin_eq_top _ _ _).2 ⟨λ s hs, _, _⟩,
  { rw [mem_union, mem_singleton_iff] at hs,
    obtain hs|rfl := hs,
    { exact H.exists_prim_root hs },
    { obtain ⟨m, hm⟩ := hS,
      obtain ⟨x, rfl⟩ := h m hm,
      obtain ⟨ζ, hζ⟩ := H.exists_prim_root hm,
      refine ⟨ζ ^ (x : ℕ), _⟩,
      convert hζ.pow_of_dvd x.ne_zero (dvd_mul_left (x : ℕ) s),
      simp only [pnat.mul_coe, nat.mul_div_left, pnat.pos] } },
  { refine _root_.eq_top_iff.2 _,
    rw [← ((iff_adjoin_eq_top S A B).1 H).2],
    refine adjoin_mono (λ x hx, _),
    simp only [union_singleton, mem_insert_iff, mem_set_of_eq] at ⊢ hx,
    obtain ⟨m, hm⟩ := hx,
    exact ⟨m, ⟨or.inr hm.1, hm.2⟩⟩ }
end

/-- If `∀ s ∈ S, n ∣ s` and `S` is not empty, then `is_cyclotomic_extension S A B` if and only if
`is_cyclotomic_extension (S ∪ {n}) A B`. -/
lemma iff_union_of_dvd (h : ∀ s ∈ S, n ∣ s) (hS : S.nonempty) :
  is_cyclotomic_extension S A B ↔ is_cyclotomic_extension (S ∪ {n}) A B :=
begin
  refine ⟨λ H, by exactI of_union_of_dvd A B h hS, λ H, (iff_adjoin_eq_top _ _ _).2 ⟨λ s hs, _, _⟩⟩,
  { exact H.exists_prim_root (subset_union_left _ _ hs) },
  { rw [_root_.eq_top_iff, ← ((iff_adjoin_eq_top _ A B).1 H).2],
    refine adjoin_mono (λ x hx, _),
    simp only [union_singleton, mem_insert_iff, mem_set_of_eq] at ⊢ hx,
    obtain ⟨m, rfl|hm, hxpow⟩ := hx,
    { obtain ⟨y, hy⟩ := hS,
      refine ⟨y, ⟨hy, _⟩⟩,
      obtain ⟨z, rfl⟩ := h y hy,
      simp only [pnat.mul_coe, pow_mul, hxpow, one_pow] },
    { exact ⟨m, ⟨hm, hxpow⟩⟩ } }
end

variables (n S)

/-- `is_cyclotomic_extension S A B` is equivalent to `is_cyclotomic_extension (S ∪ {1}) A B`. -/
lemma iff_union_singleton_one :
  is_cyclotomic_extension S A B ↔ is_cyclotomic_extension (S ∪ {1}) A B :=
begin
  obtain hS|rfl := S.eq_empty_or_nonempty.symm,
  { exact iff_union_of_dvd _ _ (λ s hs, one_dvd _) hS },
  rw [empty_union],
  refine ⟨λ H, _, λ H, _⟩,
  { refine (iff_adjoin_eq_top _ _ _).2 ⟨λ s hs, ⟨1, by simp [mem_singleton_iff.1 hs]⟩, _⟩,
    simp [adjoin_singleton_one, @empty _ _ _ _ _ H] },
  { refine (iff_adjoin_eq_top _ _ _).2 ⟨λ s hs, (not_mem_empty s hs).elim, _⟩,
    simp [@singleton_one A B _ _ _ H] }
end

variables {A B}

/-- If `(⊥ : subalgebra A B) = ⊤`, then `is_cyclotomic_extension {1} A B`. -/
lemma singleton_one_of_bot_eq_top (h : (⊥ : subalgebra A B) = ⊤) :
  is_cyclotomic_extension {1} A B :=
begin
  convert (iff_union_singleton_one _ _ _).1 (singleton_zero_of_bot_eq_top h),
  simp
end

/-- If `function.surjective (algebra_map A B)`, then `is_cyclotomic_extension {1} A B`. -/
lemma singleton_one_of_algebra_map_bijective (h : function.surjective (algebra_map A B)) :
  is_cyclotomic_extension {1} A B :=
singleton_one_of_bot_eq_top (surjective_algebra_map_iff.1 h).symm

variables (A B)

/-- Given `(f : B ≃ₐ[A] C)`, if `is_cyclotomic_extension S A B` then
`is_cyclotomic_extension S A C`. -/
@[protected]

@[protected]
lemma ne_zero [h : is_cyclotomic_extension {n} A B] [is_domain B] : ne_zero ((n : ℕ) : B) :=
begin
  obtain ⟨⟨r, hr⟩, -⟩ := (iff_singleton n A B).1 h,
  exact hr.ne_zero'
end

@[protected]
lemma ne_zero' [is_cyclotomic_extension {n} A B] [is_domain B] : ne_zero ((n : ℕ) : A) :=
begin
  apply ne_zero.nat_of_ne_zero (algebra_map A B),
  exact ne_zero n A B,
end

end basic

section fintype

lemma finite_of_singleton [is_domain B] [h : is_cyclotomic_extension {n} A B] : module.finite A B :=
begin
  classical,
  rw [module.finite_def, ← top_to_submodule, ← ((iff_adjoin_eq_top _ _ _).1 h).2],
  refine fg_adjoin_of_finite _ (λ b hb, _),
  { simp only [mem_singleton_iff, exists_eq_left],
    have : {b : B | b ^ (n : ℕ) = 1} = (nth_roots n (1 : B)).to_finset :=
      set.ext (λ x, ⟨λ h, by simpa using h, λ h, by simpa using h⟩),
    rw [this],
    exact (nth_roots ↑n 1).to_finset.finite_to_set },
  { simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq] at hb,
    refine ⟨X ^ (n : ℕ) - 1, ⟨monic_X_pow_sub_C _ n.pos.ne.symm, by simp [hb]⟩⟩ }
end

/-- If `S` is finite and `is_cyclotomic_extension S A B`, then `B` is a finite `A`-algebra. -/
@[protected]
lemma finite [is_domain B] [h₁ : finite S] [h₂ : is_cyclotomic_extension S A B] :
  module.finite A B :=
begin
  casesI nonempty_fintype S with h,
  unfreezingI {revert h₂ A B},
  refine set.finite.induction_on (set.finite.intro h) (λ A B, _) (λ n S hn hS H A B, _),
  { introsI _ _ _ _ _,
    refine module.finite_def.2 ⟨({1} : finset B), _⟩,
    simp [← top_to_submodule, ← empty, to_submodule_bot] },
  { introsI _ _ _ _ h,
    haveI : is_cyclotomic_extension S A (adjoin A { b : B | ∃ (n : ℕ+),
      n ∈ S ∧ b ^ (n : ℕ) = 1 }) := union_left _ (insert n S) _ _ (subset_insert n S),
    haveI := H A (adjoin A { b : B | ∃ (n : ℕ+), n ∈ S ∧ b ^ (n : ℕ) = 1 }),
    haveI : module.finite (adjoin A { b : B | ∃ (n : ℕ+), n ∈ S ∧ b ^ (n : ℕ) = 1 }) B,
    { rw [← union_singleton] at h,
      letI := @union_right S {n} A B _ _ _ h,
      exact finite_of_singleton n _ _ },
    exact module.finite.trans (adjoin A { b : B | ∃ (n : ℕ+), n ∈ S ∧ b ^ (n : ℕ) = 1 }) _ }
end

/-- A cyclotomic finite extension of a number field is a number field. -/
lemma number_field [h : number_field K] [_root_.finite S] [is_cyclotomic_extension S K L] :
  number_field L :=
{ to_char_zero := char_zero_of_injective_algebra_map (algebra_map K L).injective,
  to_finite_dimensional := @module.finite.trans _ K L _ _ _ _
    (@algebra_rat L _ (char_zero_of_injective_algebra_map (algebra_map K L).injective)) _ _
    h.to_finite_dimensional (finite S K L) }

localized "attribute [instance] is_cyclotomic_extension.number_field" in cyclotomic

/-- A finite cyclotomic extension of an integral noetherian domain is integral -/
lemma integral [is_domain B] [is_noetherian_ring A] [_root_.finite S]
  [is_cyclotomic_extension S A B] : algebra.is_integral A B :=
is_integral_of_noetherian $ is_noetherian_of_fg_of_noetherian' $ (finite S A B).out

/-- If `S` is finite and `is_cyclotomic_extension S K A`, then `finite_dimensional K A`. -/
lemma finite_dimensional (C : Type z) [_root_.finite S] [comm_ring C] [algebra K C] [is_domain C]
  [is_cyclotomic_extension S K C] : finite_dimensional K C :=
is_cyclotomic_extension.finite S K C

localized "attribute [instance] is_cyclotomic_extension.finite_dimensional" in cyclotomic

end fintype

section

variables {A B}

lemma adjoin_roots_cyclotomic_eq_adjoin_nth_roots [decidable_eq B] [is_domain B] {ζ : B}
  {n : ℕ+} (hζ : is_primitive_root ζ n) :
  adjoin A ↑((map (algebra_map A B) (cyclotomic n A)).roots.to_finset) =
  adjoin A {b : B | ∃ (a : ℕ+), a ∈ ({n} : set ℕ+) ∧ b ^ (a : ℕ) = 1} :=
begin
  simp only [mem_singleton_iff, exists_eq_left, map_cyclotomic],
  refine le_antisymm (adjoin_mono (λ x hx, _)) (adjoin_le (λ x hx, _)),
  { simp only [multiset.mem_to_finset, finset.mem_coe,
               map_cyclotomic, mem_roots (cyclotomic_ne_zero n B)] at hx,
    simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq],
    rw is_root_of_unity_iff n.pos,
    exact ⟨n, nat.mem_divisors_self n n.ne_zero, hx⟩ },
  { simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq] at hx,
    obtain ⟨i, hin, rfl⟩ := hζ.eq_pow_of_pow_eq_one hx n.pos,
    refine set_like.mem_coe.2 (subalgebra.pow_mem _ (subset_adjoin _) _),
    rwa [finset.mem_coe, multiset.mem_to_finset, mem_roots $ cyclotomic_ne_zero n B],
    exact hζ.is_root_cyclotomic n.pos }
end

lemma adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic {n : ℕ+} [decidable_eq B] [is_domain B]
  {ζ : B} (hζ : is_primitive_root ζ n) :
  adjoin A (((map (algebra_map A B) (cyclotomic n A)).roots.to_finset) : set B) = adjoin A ({ζ}) :=
begin
  refine le_antisymm (adjoin_le (λ x hx, _)) (adjoin_mono (λ x hx, _)),
  { suffices hx : x ^ ↑n = 1,
    obtain ⟨i, hin, rfl⟩ := hζ.eq_pow_of_pow_eq_one hx n.pos,
    exact set_like.mem_coe.2 (subalgebra.pow_mem _ (subset_adjoin $ mem_singleton ζ) _),
    rw is_root_of_unity_iff n.pos,
    refine ⟨n, nat.mem_divisors_self n n.ne_zero, _⟩,
    rwa [finset.mem_coe, multiset.mem_to_finset,
         map_cyclotomic, mem_roots $ cyclotomic_ne_zero n B] at hx },
  { simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq] at hx,
    simpa only [hx, multiset.mem_to_finset, finset.mem_coe, map_cyclotomic,
                mem_roots (cyclotomic_ne_zero n B)] using hζ.is_root_cyclotomic n.pos }
end

lemma adjoin_primitive_root_eq_top {n : ℕ+} [is_domain B] [h : is_cyclotomic_extension {n} A B]
  {ζ : B} (hζ : is_primitive_root ζ n) : adjoin A ({ζ} : set B) = ⊤ :=
begin
  classical,
  rw ←adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic hζ,
  rw adjoin_roots_cyclotomic_eq_adjoin_nth_roots hζ,
  exact ((iff_adjoin_eq_top {n} A B).mp h).2,
end

variable (A)

lemma _root_.is_primitive_root.adjoin_is_cyclotomic_extension {ζ : B} {n : ℕ+}
  (h : is_primitive_root ζ n) : is_cyclotomic_extension {n} A (adjoin A ({ζ} : set B)) :=
{ exists_prim_root := λ i hi,
  begin
    rw [set.mem_singleton_iff] at hi,
    refine ⟨⟨ζ, subset_adjoin $ set.mem_singleton ζ⟩, _⟩,
    rwa [← is_primitive_root.coe_submonoid_class_iff, subtype.coe_mk, hi],
  end,
  adjoin_roots := λ x,
  begin
    refine adjoin_induction' (λ b hb, _) (λ a, _) (λ b₁ b₂ hb₁ hb₂, _) (λ b₁ b₂ hb₁ hb₂, _) x,
    { rw [set.mem_singleton_iff] at hb,
      refine subset_adjoin _,
      simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq, hb],
      rw [← subalgebra.coe_eq_one, subalgebra.coe_pow, set_like.coe_mk],
      exact ((is_primitive_root.iff_def ζ n).1 h).1 },
    { exact subalgebra.algebra_map_mem _ _ },
    { exact subalgebra.add_mem _ hb₁ hb₂ },
    { exact subalgebra.mul_mem _ hb₁ hb₂ }
  end }

end

section field

variables {n S}

/-- A cyclotomic extension splits `X ^ n - 1` if `n ∈ S`.-/
lemma splits_X_pow_sub_one [H : is_cyclotomic_extension S K L] (hS : n ∈ S) :
  splits (algebra_map K L) (X ^ (n : ℕ) - 1) :=
begin
  rw [← splits_id_iff_splits, polynomial.map_sub, polynomial.map_one,
      polynomial.map_pow, polynomial.map_X],
  obtain ⟨z, hz⟩ := ((is_cyclotomic_extension_iff _ _ _).1 H).1 hS,
  exact X_pow_sub_one_splits hz,
end

/-- A cyclotomic extension splits `cyclotomic n K` if `n ∈ S` and `ne_zero (n : K)`.-/
lemma splits_cyclotomic [is_cyclotomic_extension S K L] (hS : n ∈ S) :
  splits (algebra_map K L) (cyclotomic n K) :=
begin
  refine splits_of_splits_of_dvd _ (X_pow_sub_C_ne_zero n.pos _)
    (splits_X_pow_sub_one K L hS) _,
  use (∏ (i : ℕ) in (n : ℕ).proper_divisors, polynomial.cyclotomic i K),
  rw [(eq_cyclotomic_iff n.pos _).1 rfl, ring_hom.map_one],
end

variables (n S)

section singleton

variables [is_cyclotomic_extension {n} K L]

/-- If `is_cyclotomic_extension {n} K L`, then `L` is the splitting field of `X ^ n - 1`. -/
lemma splitting_field_X_pow_sub_one : is_splitting_field K L (X ^ (n : ℕ) - 1) :=
{ splits := splits_X_pow_sub_one K L (mem_singleton n),
  adjoin_roots :=
  begin
    rw [← ((iff_adjoin_eq_top {n} K L).1 infer_instance).2],
    congr,
    refine set.ext (λ x, _),
    simp only [polynomial.map_pow, mem_singleton_iff, multiset.mem_to_finset, exists_eq_left,
      mem_set_of_eq, polynomial.map_X, polynomial.map_one, finset.mem_coe, polynomial.map_sub],
    rwa [← ring_hom.map_one C, mem_roots (@X_pow_sub_C_ne_zero L _ _ _ n.pos _), is_root.def,
      eval_sub, eval_pow, eval_C, eval_X, sub_eq_zero]
  end }

/-- Any two `n`-th cyclotomic extensions are isomorphic. -/
def alg_equiv (L' : Type*) [field L'] [algebra K L'] [is_cyclotomic_extension {n} K L'] :
  L ≃ₐ[K] L' :=
let _ := splitting_field_X_pow_sub_one n K L in let _ := splitting_field_X_pow_sub_one n K L' in
  by exactI (is_splitting_field.alg_equiv L (X ^ (n : ℕ) - 1)).trans
  (is_splitting_field.alg_equiv L' (X ^ (n : ℕ) - 1)).symm

localized "attribute [instance] is_cyclotomic_extension.splitting_field_X_pow_sub_one" in cyclotomic

include n

lemma is_galois : is_galois K L :=
begin
  letI := splitting_field_X_pow_sub_one n K L,
  exact is_galois.of_separable_splitting_field (X_pow_sub_one_separable_iff.2 ((ne_zero' n K L).1))
end

localized "attribute [instance] is_cyclotomic_extension.is_galois" in cyclotomic

/-- If `is_cyclotomic_extension {n} K L`, then `L` is the splitting field of `cyclotomic n K`. -/
lemma splitting_field_cyclotomic : is_splitting_field K L (cyclotomic n K) :=
{ splits := splits_cyclotomic K L (mem_singleton n),
  adjoin_roots :=
  begin
    rw [← ((iff_adjoin_eq_top {n} K L).1 infer_instance).2],
    letI := classical.dec_eq L,
    obtain ⟨ζ, hζ⟩ := @is_cyclotomic_extension.exists_prim_root {n} K L _ _ _ _ _ (mem_singleton n),
    exact adjoin_roots_cyclotomic_eq_adjoin_nth_roots hζ
  end }

localized "attribute [instance] is_cyclotomic_extension.splitting_field_cyclotomic" in cyclotomic

end singleton

end field

end is_cyclotomic_extension

section cyclotomic_field

/-- Given `n : ℕ+` and a field `K`, we define `cyclotomic_field n K` as the
splitting field of `cyclotomic n K`. If `n` is nonzero in `K`, it has
the instance `is_cyclotomic_extension {n} K (cyclotomic_field n K)`. -/
@[derive [field, algebra K, inhabited]]
def cyclotomic_field : Type w := (cyclotomic n K).splitting_field

namespace cyclotomic_field

instance [char_zero K] : char_zero (cyclotomic_field n K) :=
char_zero_of_injective_algebra_map ((algebra_map K _).injective)

instance is_cyclotomic_extension [ne_zero ((n : ℕ) : K)] :
  is_cyclotomic_extension {n} K (cyclotomic_field n K) :=
begin
  haveI : ne_zero ((n : ℕ) : (cyclotomic_field n K)) :=
    ne_zero.nat_of_injective (algebra_map K _).injective,
  letI := classical.dec_eq (cyclotomic_field n K),
  obtain ⟨ζ, hζ⟩ := exists_root_of_splits (algebra_map K (cyclotomic_field n K))
    (splitting_field.splits _) (degree_cyclotomic_pos n K n.pos).ne',
  rw [← eval_map, ← is_root.def, map_cyclotomic, is_root_cyclotomic_iff] at hζ,
  refine ⟨forall_eq.2 ⟨ζ, hζ⟩, _⟩,
  rw [←algebra.eq_top_iff, ←splitting_field.adjoin_roots, eq_comm],
  exact is_cyclotomic_extension.adjoin_roots_cyclotomic_eq_adjoin_nth_roots hζ,
end

end cyclotomic_field

end cyclotomic_field

section is_domain

variables [is_domain A] [algebra A K] [is_fraction_ring A K]

section cyclotomic_ring

/-- If `K` is the fraction field of `A`, the `A`-algebra structure on `cyclotomic_field n K`.
This is not an instance since it causes diamonds when `A = ℤ`. -/
@[nolint unused_arguments]
def cyclotomic_field.algebra_base : algebra A (cyclotomic_field n K) :=
((algebra_map K (cyclotomic_field n K)).comp (algebra_map A K)).to_algebra

local attribute [instance] cyclotomic_field.algebra_base

instance cyclotomic_field.no_zero_smul_divisors : no_zero_smul_divisors A (cyclotomic_field n K) :=
no_zero_smul_divisors.of_algebra_map_injective $ function.injective.comp
(no_zero_smul_divisors.algebra_map_injective _ _) $ is_fraction_ring.injective A K

/-- If `A` is a domain with fraction field `K` and `n : ℕ+`, we define `cyclotomic_ring n A K` as
the `A`-subalgebra of `cyclotomic_field n K` generated by the roots of `X ^ n - 1`. If `n`
is nonzero in `A`, it has the instance `is_cyclotomic_extension {n} A (cyclotomic_ring n A K)`. -/
@[derive [comm_ring, is_domain, inhabited]]
def cyclotomic_ring : Type w := adjoin A { b : (cyclotomic_field n K) | b ^ (n : ℕ) = 1 }

namespace cyclotomic_ring

/-- The `A`-algebra structure on `cyclotomic_ring n A K`.
This is not an instance since it causes diamonds when `A = ℤ`. -/
def algebra_base : algebra A (cyclotomic_ring n A K) := (adjoin A _).algebra

local attribute [instance] cyclotomic_ring.algebra_base

instance : no_zero_smul_divisors A (cyclotomic_ring n A K) := (adjoin A _).no_zero_smul_divisors_bot

lemma algebra_base_injective : function.injective $ algebra_map A (cyclotomic_ring n A K) :=
no_zero_smul_divisors.algebra_map_injective _ _

instance : algebra (cyclotomic_ring n A K) (cyclotomic_field n K) :=
(adjoin A _).to_algebra

lemma adjoin_algebra_injective :
  function.injective $ algebra_map (cyclotomic_ring n A K) (cyclotomic_field n K) :=
subtype.val_injective

instance : no_zero_smul_divisors (cyclotomic_ring n A K) (cyclotomic_field n K) :=
no_zero_smul_divisors.of_algebra_map_injective (adjoin_algebra_injective n A K)

instance : is_scalar_tower A (cyclotomic_ring n A K) (cyclotomic_field n K) :=
is_scalar_tower.subalgebra' _ _ _ _

instance is_cyclotomic_extension [ne_zero ((n : ℕ) : A)] :
  is_cyclotomic_extension {n} A (cyclotomic_ring n A K) :=
{ exists_prim_root := λ a han,
  begin
    rw mem_singleton_iff at han,
    subst a,
    haveI := ne_zero.of_no_zero_smul_divisors A K n,
    haveI := ne_zero.of_no_zero_smul_divisors A (cyclotomic_field n K) n,
    obtain ⟨μ, hμ⟩ :=
      (cyclotomic_field.is_cyclotomic_extension n K).exists_prim_root (mem_singleton n),
    refine ⟨⟨μ, subset_adjoin _⟩, _⟩,
    { apply (is_root_of_unity_iff n.pos (cyclotomic_field n K)).mpr,
      refine ⟨n, nat.mem_divisors_self _ n.ne_zero, _⟩,
      rwa [← is_root_cyclotomic_iff] at hμ },
    { rwa [← is_primitive_root.coe_submonoid_class_iff, subtype.coe_mk] }
  end,
  adjoin_roots := λ x,
  begin
    refine adjoin_induction' (λ y hy, _) (λ a, _) (λ y z hy hz, _) (λ y z hy hz, _) x,
    { refine subset_adjoin _,
      simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq],
      rwa [← subalgebra.coe_eq_one, subalgebra.coe_pow, subtype.coe_mk] },
    { exact subalgebra.algebra_map_mem _ a },
    { exact subalgebra.add_mem _ hy hz },
    { exact subalgebra.mul_mem _ hy hz },
  end }

instance [ne_zero ((n : ℕ) : A)] :
  is_fraction_ring (cyclotomic_ring n A K) (cyclotomic_field n K) :=
{ map_units := λ ⟨x, hx⟩, begin
    rw is_unit_iff_ne_zero,
    apply map_ne_zero_of_mem_non_zero_divisors,
    apply adjoin_algebra_injective,
    exact hx
  end,
  surj := λ x,
  begin
    letI : ne_zero ((n : ℕ) : K) := ne_zero.nat_of_injective (is_fraction_ring.injective A K),
    refine algebra.adjoin_induction (((is_cyclotomic_extension.iff_singleton n K _).1
      (cyclotomic_field.is_cyclotomic_extension n K)).2 x) (λ y hy, _) (λ k, _) _ _,
    { exact ⟨⟨⟨y, subset_adjoin hy⟩, 1⟩, by simpa⟩ },
    { have : is_localization (non_zero_divisors A) K := infer_instance,
      replace := this.surj,
      obtain ⟨⟨z, w⟩, hw⟩ := this k,
      refine ⟨⟨algebra_map A _ z, algebra_map A _ w, map_mem_non_zero_divisors _
        (algebra_base_injective n A K) w.2⟩, _⟩,
      letI : is_scalar_tower A K (cyclotomic_field n K) :=
        is_scalar_tower.of_algebra_map_eq (congr_fun rfl),
      rw [set_like.coe_mk, ← is_scalar_tower.algebra_map_apply,
        ← is_scalar_tower.algebra_map_apply, @is_scalar_tower.algebra_map_apply A K _ _ _ _ _
        (_root_.cyclotomic_field.algebra n K) _ _ w, ← ring_hom.map_mul, hw,
        ← is_scalar_tower.algebra_map_apply] },
    { rintro y z ⟨a, ha⟩ ⟨b, hb⟩,
      refine ⟨⟨a.1 * b.2 + b.1 * a.2, a.2 * b.2, mul_mem_non_zero_divisors.2 ⟨a.2.2, b.2.2⟩⟩, _⟩,
      rw [set_like.coe_mk, ring_hom.map_mul, add_mul, ← mul_assoc, ha,
        mul_comm ((algebra_map _ _) ↑a.2), ← mul_assoc, hb],
      simp only [map_add, map_mul] },
    { rintro y z ⟨a, ha⟩ ⟨b, hb⟩,
      refine ⟨⟨a.1 * b.1, a.2 * b.2, mul_mem_non_zero_divisors.2 ⟨a.2.2, b.2.2⟩⟩, _⟩,
      rw [set_like.coe_mk, ring_hom.map_mul, mul_comm ((algebra_map _ _) ↑a.2), mul_assoc,
        ← mul_assoc z, hb, ← mul_comm ((algebra_map _ _) ↑a.2), ← mul_assoc, ha],
      simp only [map_mul] }
  end,
  eq_iff_exists := λ x y, ⟨λ h, ⟨1, by rw adjoin_algebra_injective n A K h⟩,
    λ ⟨c, hc⟩, by rw mul_left_cancel₀ (non_zero_divisors.ne_zero c.prop) hc⟩ }

lemma eq_adjoin_primitive_root {μ : (cyclotomic_field n K)} (h : is_primitive_root μ n) :
  cyclotomic_ring n A K = adjoin A ({μ} : set ((cyclotomic_field n K))) :=
begin
  letI := classical.prop_decidable,
  rw [←is_cyclotomic_extension.adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic h,
      is_cyclotomic_extension.adjoin_roots_cyclotomic_eq_adjoin_nth_roots h],
  simp [cyclotomic_ring]
end

end cyclotomic_ring

end cyclotomic_ring

end is_domain

section is_alg_closed

variables [is_alg_closed K]

/-- Algebraically closed fields are `S`-cyclotomic extensions over themselves if
`ne_zero ((a : ℕ) : K))` for all `a ∈ S`. -/
lemma is_alg_closed.is_cyclotomic_extension (h : ∀ a ∈ S, ne_zero ((a : ℕ) : K)) :
  is_cyclotomic_extension S K K :=
begin
  refine ⟨λ a ha, _,  algebra.eq_top_iff.mp $ subsingleton.elim _ _ ⟩,
  obtain ⟨r, hr⟩ := is_alg_closed.exists_aeval_eq_zero K _ (degree_cyclotomic_pos a K a.pos).ne',
  refine ⟨r, _⟩,
  haveI := h a ha,
  rwa [coe_aeval_eq_eval, ← is_root.def, is_root_cyclotomic_iff] at hr,
end

instance is_alg_closed_of_char_zero.is_cyclotomic_extension [char_zero K] :
  ∀ S, is_cyclotomic_extension S K K :=
λ S, is_alg_closed.is_cyclotomic_extension S K (λ a ha, infer_instance)

end is_alg_closed


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Yury Kudryashov
-/
import topology.algebra.ordered.basic
import topology.extend_from

/-!
# Lemmas about `extend_from` in an order topology.
-/

open filter set topological_space
open_locale topological_space classical

universes u v
variables {α : Type u} {β : Type v}

lemma continuous_on_Icc_extend_from_Ioo [topological_space α] [linear_order α] [densely_ordered α]
  [order_topology α] [topological_space β] [regular_space β] {f : α → β} {a b : α}
  {la lb : β} (hab : a ≠ b) (hf : continuous_on f (Ioo a b))
  (ha : tendsto f (𝓝[>] a) (𝓝 la)) (hb : tendsto f (𝓝[<] b) (𝓝 lb)) :
  continuous_on (extend_from (Ioo a b) f) (Icc a b) :=
begin
  apply continuous_on_extend_from,
  { rw closure_Ioo hab },
  { intros x x_in,
    rcases mem_Ioo_or_eq_endpoints_of_mem_Icc x_in with rfl | rfl | h,
    { exact ⟨la, ha.mono_left $ nhds_within_mono _ Ioo_subset_Ioi_self⟩ },
    { exact ⟨lb, hb.mono_left $ nhds_within_mono _ Ioo_subset_Iio_self⟩ },
    { use [f x, hf x h] } }
end

lemma eq_lim_at_left_extend_from_Ioo [topological_space α] [linear_order α] [densely_ordered α]
  [order_topology α] [topological_space β] [t2_space β] {f : α → β} {a b : α}
  {la : β} (hab : a < b) (ha : tendsto f (𝓝[>] a) (𝓝 la)) :
  extend_from (Ioo a b) f a = la :=
begin
  apply extend_from_eq,
  { rw closure_Ioo hab.ne,
    simp only [le_of_lt hab, left_mem_Icc, right_mem_Icc] },
  { simpa [hab] }
end

lemma eq_lim_at_right_extend_from_Ioo [topological_space α] [linear_order α] [densely_ordered α]
  [order_topology α] [topological_space β] [t2_space β] {f : α → β} {a b : α}
  {lb : β} (hab : a < b) (hb : tendsto f (𝓝[<] b) (𝓝 lb)) :
  extend_from (Ioo a b) f b = lb :=
begin
  apply extend_from_eq,
  { rw closure_Ioo hab.ne,
    simp only [le_of_lt hab, left_mem_Icc, right_mem_Icc] },
  { simpa [hab] }
end

lemma continuous_on_Ico_extend_from_Ioo [topological_space α]
  [linear_order α] [densely_ordered α] [order_topology α] [topological_space β]
  [regular_space β] {f : α → β} {a b : α} {la : β} (hab : a < b) (hf : continuous_on f (Ioo a b))
  (ha : tendsto f (𝓝[>] a) (𝓝 la)) :
  continuous_on (extend_from (Ioo a b) f) (Ico a b) :=
begin
  apply continuous_on_extend_from,
  { rw [closure_Ioo hab.ne], exact Ico_subset_Icc_self, },
  { intros x x_in,
    rcases mem_Ioo_or_eq_left_of_mem_Ico x_in with rfl | h,
    { use la,
      simpa [hab] },
    { use [f x, hf x h] } }
end

lemma continuous_on_Ioc_extend_from_Ioo [topological_space α]
  [linear_order α] [densely_ordered α] [order_topology α] [topological_space β]
  [regular_space β] {f : α → β} {a b : α} {lb : β} (hab : a < b) (hf : continuous_on f (Ioo a b))
  (hb : tendsto f (𝓝[<] b) (𝓝 lb)) :
  continuous_on (extend_from (Ioo a b) f) (Ioc a b) :=
begin
  have := @continuous_on_Ico_extend_from_Ioo (order_dual α) _ _ _ _ _ _ _ f _ _ _ hab,
  erw [dual_Ico, dual_Ioi, dual_Ioo] at this,
  exact this hf hb
end


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

import order.closure
import model_theory.semantics
import model_theory.encoding

/-!
# First-Order Substructures
This file defines substructures of first-order structures in a similar manner to the various
substructures appearing in the algebra library.

## Main Definitions
* A `first_order.language.substructure` is defined so that `L.substructure M` is the type of all
substructures of the `L`-structure `M`.
* `first_order.language.substructure.closure` is defined so that if `s : set M`, `closure L s` is
the least substructure of `M` containing `s`.
* `first_order.language.substructure.comap` is defined so that `s.comap f` is the preimage of the
substructure `s` under the homomorphism `f`, as a substructure.
* `first_order.language.substructure.map` is defined so that `s.map f` is the image of the
substructure `s` under the homomorphism `f`, as a substructure.
* `first_order.language.hom.range` is defined so that `f.map` is the range of the
the homomorphism `f`, as a substructure.
* `first_order.language.hom.dom_restrict` and `first_order.language.hom.cod_restrict` restrict
the domain and codomain respectively of first-order homomorphisms to substructures.
* `first_order.language.embedding.dom_restrict` and `first_order.language.embedding.cod_restrict`
restrict the domain and codomain respectively of first-order embeddings to substructures.
* `first_order.language.substructure.inclusion` is the inclusion embedding between substructures.

## Main Results
* `L.substructure M` forms a `complete_lattice`.

-/

universes u v w

namespace first_order
namespace language

variables {L : language.{u v}} {M : Type w} {N P : Type*}
variables [L.Structure M] [L.Structure N] [L.Structure P]
open_locale first_order cardinal
open Structure cardinal

section closed_under

open set

variables {n : ℕ} (f : L.functions n) (s : set M)

/-- Indicates that a set in a given structure is a closed under a function symbol. -/
def closed_under : Prop :=
∀ (x : fin n → M), (∀ i : fin n, x i ∈ s) → fun_map f x ∈ s

variable (L)

@[simp] lemma closed_under_univ : closed_under f (univ : set M) :=
λ _ _, mem_univ _

variables {L f s} {t : set M}

namespace closed_under

lemma inter (hs : closed_under f s) (ht : closed_under f t) :
  closed_under f (s ∩ t) :=
λ x h, mem_inter (hs x (λ i, mem_of_mem_inter_left (h i)))
  (ht x (λ i, mem_of_mem_inter_right (h i)))

lemma inf (hs : closed_under f s) (ht : closed_under f t) :
  closed_under f (s ⊓ t) := hs.inter ht

variables {S : set (set M)}

lemma Inf (hS : ∀ s, s ∈ S → closed_under f s) : closed_under f (Inf S) :=
λ x h s hs, hS s hs x (λ i, h i s hs)

end closed_under
end closed_under

variables (L) (M)

/-- A substructure of a structure `M` is a set closed under application of function symbols. -/
structure substructure :=
(carrier : set M)
(fun_mem : ∀{n}, ∀ (f : L.functions n), closed_under f carrier)

variables {L} {M}

namespace substructure

instance : set_like (L.substructure M) M :=
⟨substructure.carrier, λ p q h, by cases p; cases q; congr'⟩

/-- See Note [custom simps projection] -/
def simps.coe (S : L.substructure M) : set M := S
initialize_simps_projections substructure (carrier → coe)

@[simp]
lemma mem_carrier {s : L.substructure M} {x : M} : x ∈ s.carrier ↔ x ∈ s := iff.rfl

/-- Two substructures are equal if they have the same elements. -/
@[ext]
theorem ext {S T : L.substructure M}
  (h : ∀ x, x ∈ S ↔ x ∈ T) : S = T := set_like.ext h

/-- Copy a substructure replacing `carrier` with a set that is equal to it. -/
protected def copy (S : L.substructure M) (s : set M) (hs : s = S) : L.substructure M :=
{ carrier := s,
  fun_mem := λ n f, hs.symm ▸ (S.fun_mem f) }

end substructure

variable {S : L.substructure M}

lemma term.realize_mem {α : Type*} (t : L.term α) (xs : α → M) (h : ∀ a, xs a ∈ S) :
  t.realize xs ∈ S :=
begin
  induction t with a n f ts ih,
  { exact h a },
  { exact substructure.fun_mem _ _ _ ih }
end

namespace substructure

@[simp] lemma coe_copy {s : set M} (hs : s = S) :
  (S.copy s hs : set M) = s := rfl

lemma copy_eq {s : set M} (hs : s = S) : S.copy s hs = S :=
set_like.coe_injective hs

lemma constants_mem (c : L.constants) : ↑c ∈ S :=
mem_carrier.2 (S.fun_mem c _ fin.elim0)

/-- The substructure `M` of the structure `M`. -/
instance : has_top (L.substructure M) :=
⟨{ carrier := set.univ,
   fun_mem := λ n f x h, set.mem_univ _ }⟩

instance : inhabited (L.substructure M) := ⟨⊤⟩

@[simp] lemma mem_top (x : M) : x ∈ (⊤ : L.substructure M) := set.mem_univ x

@[simp] lemma coe_top : ((⊤ : L.substructure M) : set M) = set.univ := rfl

/-- The inf of two substructures is their intersection. -/
instance : has_inf (L.substructure M) :=
⟨λ S₁ S₂,
  { carrier := S₁ ∩ S₂,
    fun_mem := λ n f, (S₁.fun_mem f).inf (S₂.fun_mem f) }⟩

@[simp]
lemma coe_inf (p p' : L.substructure M) : ((p ⊓ p' : L.substructure M) : set M) = p ∩ p' := rfl

@[simp]
lemma mem_inf {p p' : L.substructure M} {x : M} : x ∈ p ⊓ p' ↔ x ∈ p ∧ x ∈ p' := iff.rfl

instance : has_Inf (L.substructure M) :=
⟨λ s, { carrier := ⋂ t ∈ s, ↑t,
        fun_mem := λ n f, closed_under.Inf begin
          rintro _ ⟨t, rfl⟩,
          by_cases h : t ∈ s,
          { simpa [h] using t.fun_mem f },
          { simp [h] }
        end }⟩

@[simp, norm_cast]
lemma coe_Inf (S : set (L.substructure M)) :
  ((Inf S : L.substructure M) : set M) = ⋂ s ∈ S, ↑s := rfl

lemma mem_Inf {S : set (L.substructure M)} {x : M} : x ∈ Inf S ↔ ∀ p ∈ S, x ∈ p := set.mem_Inter₂

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

@[simp, norm_cast]
lemma coe_infi {ι : Sort*} {S : ι → L.substructure M} : (↑(⨅ i, S i) : set M) = ⋂ i, S i :=
by simp only [infi, coe_Inf, set.bInter_range]

/-- Substructures of a structure form a complete lattice. -/
instance : complete_lattice (L.substructure M) :=
{ le           := (≤),
  lt           := (<),
  top          := (⊤),
  le_top       := λ S x hx, mem_top x,
  inf          := (⊓),
  Inf          := has_Inf.Inf,
  le_inf       := λ a b c ha hb x hx, ⟨ha hx, hb hx⟩,
  inf_le_left  := λ a b x, and.left,
  inf_le_right := λ a b x, and.right,
  .. complete_lattice_of_Inf (L.substructure M) $ λ s,
    is_glb.of_image (λ S T,
      show (S : set M) ≤ T ↔ S ≤ T, from set_like.coe_subset_coe) is_glb_binfi }

variable (L)

/-- The `L.substructure` generated by a set. -/
def closure : lower_adjoint (coe : L.substructure M → set M) := ⟨λ s, Inf {S | s ⊆ S},
  λ s S, ⟨set.subset.trans (λ x hx, mem_Inf.2 $ λ S hS, hS hx), λ h, Inf_le h⟩⟩

variables {L} {s : set M}

lemma mem_closure {x : M} : x ∈ closure L s ↔ ∀ S : L.substructure M, s ⊆ S → x ∈ S :=
mem_Inf

/-- The substructure generated by a set includes the set. -/
@[simp]
lemma subset_closure : s ⊆ closure L s := (closure L).le_closure s

lemma not_mem_of_not_mem_closure {P : M} (hP : P ∉ closure L s) : P ∉ s :=
λ h, hP (subset_closure h)

@[simp]
lemma closed (S : L.substructure M) : (closure L).closed (S : set M) :=
congr rfl ((closure L).eq_of_le set.subset.rfl (λ x xS, mem_closure.2 (λ T hT, hT xS)))

open set

/-- A substructure `S` includes `closure L s` if and only if it includes `s`. -/
@[simp]
lemma closure_le : closure L s ≤ S ↔ s ⊆ S := (closure L).closure_le_closed_iff_le s S.closed

/-- Substructure closure of a set is monotone in its argument: if `s ⊆ t`,
then `closure L s ≤ closure L t`. -/
lemma closure_mono ⦃s t : set M⦄ (h : s ⊆ t) : closure L s ≤ closure L t :=
(closure L).monotone h

lemma closure_eq_of_le (h₁ : s ⊆ S) (h₂ : S ≤ closure L s) : closure L s = S :=
(closure L).eq_of_le h₁ h₂

lemma coe_closure_eq_range_term_realize :
  (closure L s : set M) = range (@term.realize L _ _ _ (coe : s → M)) :=
begin
  let S : L.substructure M := ⟨range (term.realize coe), λ n f x hx, _⟩,
  { change _ = (S : set M),
    rw ← set_like.ext'_iff,
    refine closure_eq_of_le (λ x hx, ⟨var ⟨x, hx⟩, rfl⟩) (le_Inf (λ S' hS', _)),
    { rintro _ ⟨t, rfl⟩,
      exact t.realize_mem _ (λ i, hS' i.2) } },
  { simp only [mem_range] at *,
    refine ⟨func f (λ i, (classical.some (hx i))), _⟩,
    simp only [term.realize, λ i, classical.some_spec (hx i)] }
end

instance small_closure [small.{u} s] :
  small.{u} (closure L s) :=
begin
  rw [← set_like.coe_sort_coe, substructure.coe_closure_eq_range_term_realize],
  exact small_range _,
end

lemma mem_closure_iff_exists_term {x : M} :
  x ∈ closure L s ↔ ∃ (t : L.term s), t.realize (coe : s → M) = x :=
by rw [← set_like.mem_coe, coe_closure_eq_range_term_realize, mem_range]

lemma lift_card_closure_le_card_term : cardinal.lift.{max u w} (# (closure L s)) ≤ # (L.term s) :=
begin
  rw [← set_like.coe_sort_coe, coe_closure_eq_range_term_realize],
  rw [← cardinal.lift_id'.{w (max u w)} (# (L.term s))],
  exact cardinal.mk_range_le_lift,
end

theorem lift_card_closure_le : cardinal.lift.{u w} (# (closure L s)) ≤
  max ℵ₀ (cardinal.lift.{u w} (#s) + cardinal.lift.{w u} (#(Σ i, L.functions i))) :=
begin
  rw ←lift_umax,
  refine lift_card_closure_le_card_term.trans (term.card_le.trans _),
  rw [mk_sum, lift_umax],
end

variable (L)

lemma _root_.set.countable.substructure_closure [countable (Σl, L.functions l)]
  (h : s.countable) :
  countable.{w + 1} (closure L s) :=
begin
  haveI : countable s := h.to_subtype,
  rw [← mk_le_aleph_0_iff, ← lift_le_aleph_0],
  exact lift_card_closure_le_card_term.trans mk_le_aleph_0
end

variables {L} (S)

/-- An induction principle for closure membership. If `p` holds for all elements of `s`, and
is preserved under function symbols, then `p` holds for all elements of the closure of `s`. -/
@[elab_as_eliminator] lemma closure_induction {p : M → Prop} {x} (h : x ∈ closure L s)
  (Hs : ∀ x ∈ s, p x)
  (Hfun : ∀ {n : ℕ} (f : L.functions n), closed_under f (set_of p)) : p x :=
(@closure_le L M _ ⟨set_of p, λ n, Hfun⟩ _).2 Hs h

/-- If `s` is a dense set in a structure `M`, `substructure.closure L s = ⊤`, then in order to prove
that some predicate `p` holds for all `x : M` it suffices to verify `p x` for `x ∈ s`, and verify
that `p` is preserved under function symbols. -/
@[elab_as_eliminator] lemma dense_induction {p : M → Prop} (x : M) {s : set M}
  (hs : closure L s = ⊤) (Hs : ∀ x ∈ s, p x)
  (Hfun : ∀ {n : ℕ} (f : L.functions n), closed_under f (set_of p)) : p x :=
have ∀ x ∈ closure L s, p x, from λ x hx, closure_induction hx Hs (λ n, Hfun),
by simpa [hs] using this x

variables (L) (M)

/-- `closure` forms a Galois insertion with the coercion to set. -/
protected def gi : galois_insertion (@closure L M _) coe :=
{ choice := λ s _, closure L s,
  gc := (closure L).gc,
  le_l_u := λ s, subset_closure,
  choice_eq := λ s h, rfl }

variables {L} {M}

/-- Closure of a substructure `S` equals `S`. -/
@[simp] lemma closure_eq : closure L (S : set M) = S := (substructure.gi L M).l_u_eq S

@[simp] lemma closure_empty : closure L (∅ : set M) = ⊥ :=
(substructure.gi L M).gc.l_bot

@[simp] lemma closure_univ : closure L (univ : set M) = ⊤ :=
@coe_top L M _ ▸ closure_eq ⊤

lemma closure_union (s t : set M) : closure L (s ∪ t) = closure L s ⊔ closure L t :=
(substructure.gi L M).gc.l_sup

lemma closure_Union {ι} (s : ι → set M) : closure L (⋃ i, s i) = ⨆ i, closure L (s i) :=
(substructure.gi L M).gc.l_supr

instance small_bot :
  small.{u} (⊥ : L.substructure M) :=
begin
  rw ← closure_empty,
  exact substructure.small_closure
end

/-!
### `comap` and `map`
-/

/-- The preimage of a substructure along a homomorphism is a substructure. -/
@[simps] def comap (φ : M →[L] N) (S : L.substructure N) : L.substructure M :=
{ carrier := (φ ⁻¹' S),
  fun_mem := λ n f x hx, begin
    rw [mem_preimage, φ.map_fun],
    exact S.fun_mem f (φ ∘ x) hx,
  end }

@[simp]
lemma mem_comap {S : L.substructure N} {f : M →[L] N} {x : M} : x ∈ S.comap f ↔ f x ∈ S := iff.rfl

lemma comap_comap (S : L.substructure P) (g : N →[L] P) (f : M →[L] N) :
  (S.comap g).comap f = S.comap (g.comp f) :=
rfl

@[simp]
lemma comap_id (S : L.substructure P) : S.comap (hom.id _ _) = S :=
ext (by simp)

/-- The image of a substructure along a homomorphism is a substructure. -/
@[simps] def map (φ : M →[L] N) (S : L.substructure M) : L.substructure N :=
{ carrier := (φ '' S),
  fun_mem := λ n f x hx, (mem_image _ _ _).1
    ⟨fun_map f (λ i, classical.some (hx i)),
     S.fun_mem f _ (λ i, (classical.some_spec (hx i)).1),
     begin
       simp only [hom.map_fun, set_like.mem_coe],
       exact congr rfl (funext (λ i, (classical.some_spec (hx i)).2)),
     end⟩ }

@[simp]
lemma mem_map {f : M →[L] N} {S : L.substructure M} {y : N} :
  y ∈ S.map f ↔ ∃ x ∈ S, f x = y :=
mem_image_iff_bex

lemma mem_map_of_mem (f : M →[L] N) {S : L.substructure M} {x : M} (hx : x ∈ S) : f x ∈ S.map f :=
mem_image_of_mem f hx

lemma apply_coe_mem_map (f : M →[L] N) (S : L.substructure M) (x : S) : f x ∈ S.map f :=
mem_map_of_mem f x.prop

lemma map_map (g : N →[L] P) (f : M →[L] N) : (S.map f).map g = S.map (g.comp f) :=
set_like.coe_injective $ image_image _ _ _

lemma map_le_iff_le_comap {f : M →[L] N} {S : L.substructure M} {T : L.substructure N} :
  S.map f ≤ T ↔ S ≤ T.comap f :=
image_subset_iff

lemma gc_map_comap (f : M →[L] N) : galois_connection (map f) (comap f) :=
λ S T, map_le_iff_le_comap

lemma map_le_of_le_comap {T : L.substructure N} {f : M →[L] N} : S ≤ T.comap f → S.map f ≤ T :=
(gc_map_comap f).l_le

lemma le_comap_of_map_le {T : L.substructure N} {f : M →[L] N} : S.map f ≤ T → S ≤ T.comap f :=
(gc_map_comap f).le_u

lemma le_comap_map {f : M →[L] N} : S ≤ (S.map f).comap f :=
(gc_map_comap f).le_u_l _

lemma map_comap_le {S : L.substructure N} {f : M →[L] N} : (S.comap f).map f ≤ S :=
(gc_map_comap f).l_u_le _

lemma monotone_map {f : M →[L] N} : monotone (map f) :=
(gc_map_comap f).monotone_l

lemma monotone_comap {f : M →[L] N} : monotone (comap f) :=
(gc_map_comap f).monotone_u

@[simp]
lemma map_comap_map {f : M →[L] N} : ((S.map f).comap f).map f = S.map f :=
(gc_map_comap f).l_u_l_eq_l _

@[simp]
lemma comap_map_comap {S : L.substructure N} {f : M →[L] N} :
  ((S.comap f).map f).comap f = S.comap f :=
(gc_map_comap f).u_l_u_eq_u _

lemma map_sup (S T : L.substructure M) (f : M →[L] N) : (S ⊔ T).map f = S.map f ⊔ T.map f :=
(gc_map_comap f).l_sup

lemma map_supr {ι : Sort*} (f : M →[L] N) (s : ι → L.substructure M) :
  (supr s).map f = ⨆ i, (s i).map f :=
(gc_map_comap f).l_supr

lemma comap_inf (S T : L.substructure N) (f : M →[L] N) : (S ⊓ T).comap f = S.comap f ⊓ T.comap f :=
(gc_map_comap f).u_inf

lemma comap_infi {ι : Sort*} (f : M →[L] N) (s : ι → L.substructure N) :
  (infi s).comap f = ⨅ i, (s i).comap f :=
(gc_map_comap f).u_infi

@[simp] lemma map_bot (f : M →[L] N) : (⊥ : L.substructure M).map f = ⊥ :=
(gc_map_comap f).l_bot

@[simp] lemma comap_top (f : M →[L] N) : (⊤ : L.substructure N).comap f = ⊤ :=
(gc_map_comap f).u_top

@[simp] lemma map_id (S : L.substructure M) : S.map (hom.id L M) = S :=
ext (λ x, ⟨λ ⟨_, h, rfl⟩, h, λ h, ⟨_, h, rfl⟩⟩)

lemma map_closure (f : M →[L] N) (s : set M) :
  (closure L s).map f = closure L (f '' s) :=
eq.symm $ closure_eq_of_le (set.image_subset f subset_closure) $ map_le_iff_le_comap.2 $
  closure_le.2 $ λ x hx, subset_closure ⟨x, hx, rfl⟩

@[simp] lemma closure_image (f : M →[L] N) :
  closure L (f '' s) = map f (closure L s) :=
(map_closure f s).symm

section galois_coinsertion

variables {ι : Type*} {f : M →[L] N} (hf : function.injective f)

include hf

/-- `map f` and `comap f` form a `galois_coinsertion` when `f` is injective. -/
def gci_map_comap : galois_coinsertion (map f) (comap f) :=
(gc_map_comap f).to_galois_coinsertion
  (λ S x, by simp [mem_comap, mem_map, hf.eq_iff])

lemma comap_map_eq_of_injective (S : L.substructure M) : (S.map f).comap f = S :=
(gci_map_comap hf).u_l_eq _

lemma comap_surjective_of_injective : function.surjective (comap f) :=
(gci_map_comap hf).u_surjective

lemma map_injective_of_injective : function.injective (map f) :=
(gci_map_comap hf).l_injective

lemma comap_inf_map_of_injective (S T : L.substructure M) : (S.map f ⊓ T.map f).comap f = S ⊓ T :=
(gci_map_comap hf).u_inf_l _ _

lemma comap_infi_map_of_injective (S : ι → L.substructure M) :
  (⨅ i, (S i).map f).comap f = infi S :=
(gci_map_comap hf).u_infi_l _

lemma comap_sup_map_of_injective (S T : L.substructure M) : (S.map f ⊔ T.map f).comap f = S ⊔ T :=
(gci_map_comap hf).u_sup_l _ _

lemma comap_supr_map_of_injective (S : ι → L.substructure M) :
  (⨆ i, (S i).map f).comap f = supr S :=
(gci_map_comap hf).u_supr_l _

lemma map_le_map_iff_of_injective {S T : L.substructure M} : S.map f ≤ T.map f ↔ S ≤ T :=
(gci_map_comap hf).l_le_l_iff

lemma map_strict_mono_of_injective : strict_mono (map f) :=
(gci_map_comap hf).strict_mono_l

end galois_coinsertion

section galois_insertion

variables {ι : Type*} {f : M →[L] N} (hf : function.surjective f)

include hf

/-- `map f` and `comap f` form a `galois_insertion` when `f` is surjective. -/
def gi_map_comap : galois_insertion (map f) (comap f) :=
(gc_map_comap f).to_galois_insertion
  (λ S x h, let ⟨y, hy⟩ := hf x in mem_map.2 ⟨y, by simp [hy, h]⟩)

lemma map_comap_eq_of_surjective (S : L.substructure N) : (S.comap f).map f = S :=
(gi_map_comap hf).l_u_eq _

lemma map_surjective_of_surjective : function.surjective (map f) :=
(gi_map_comap hf).l_surjective

lemma comap_injective_of_surjective : function.injective (comap f) :=
(gi_map_comap hf).u_injective

lemma map_inf_comap_of_surjective (S T : L.substructure N) :
  (S.comap f ⊓ T.comap f).map f = S ⊓ T :=
(gi_map_comap hf).l_inf_u _ _

lemma map_infi_comap_of_surjective (S : ι → L.substructure N) :
  (⨅ i, (S i).comap f).map f = infi S :=
(gi_map_comap hf).l_infi_u _

lemma map_sup_comap_of_surjective (S T : L.substructure N) :
  (S.comap f ⊔ T.comap f).map f = S ⊔ T :=
(gi_map_comap hf).l_sup_u _ _

lemma map_supr_comap_of_surjective (S : ι → L.substructure N) :
  (⨆ i, (S i).comap f).map f = supr S :=
(gi_map_comap hf).l_supr_u _

lemma comap_le_comap_iff_of_surjective {S T : L.substructure N} :
  S.comap f ≤ T.comap f ↔ S ≤ T :=
(gi_map_comap hf).u_le_u_iff

lemma comap_strict_mono_of_surjective : strict_mono (comap f) :=
(gi_map_comap hf).strict_mono_u

end galois_insertion

instance induced_Structure {S : L.substructure M} : L.Structure S :=
{ fun_map := λ n f x, ⟨fun_map f (λ i, x i), S.fun_mem f (λ i, x i) (λ i, (x i).2)⟩,
  rel_map := λ n r x, rel_map r (λ i, (x i : M)) }

/-- The natural embedding of an `L.substructure` of `M` into `M`. -/
def subtype (S : L.substructure M) : S ↪[L] M :=
{ to_fun := coe,
  inj' := subtype.coe_injective }

@[simp] theorem coe_subtype : ⇑S.subtype = coe := rfl

/-- The equivalence between the maximal substructure of a structure and the structure itself. -/
def top_equiv : (⊤ : L.substructure M) ≃[L] M  :=
{ to_fun := subtype ⊤,
  inv_fun := λ m, ⟨m, mem_top m⟩,
  left_inv := λ m, by simp,
  right_inv := λ m, rfl }

@[simp] lemma coe_top_equiv : ⇑(top_equiv : (⊤ : L.substructure M) ≃[L] M) = coe := rfl

/-- A dependent version of `substructure.closure_induction`. -/
@[elab_as_eliminator] lemma closure_induction' (s : set M) {p : Π x, x ∈ closure L s → Prop}
  (Hs : ∀ x (h : x ∈ s), p x (subset_closure h))
  (Hfun : ∀ {n : ℕ} (f : L.functions n), closed_under f {x | ∃ hx, p x hx})
  {x} (hx : x ∈ closure L s) :
  p x hx :=
begin
  refine exists.elim _ (λ (hx : x ∈ closure L s) (hc : p x hx), hc),
  exact closure_induction hx (λ x hx, ⟨subset_closure hx, Hs x hx⟩) @Hfun
end

end substructure

namespace Lhom
open substructure

variables {L' : language} [L'.Structure M] (φ : L →ᴸ L') [φ.is_expansion_on M]
include φ

/-- Reduces the language of a substructure along a language hom. -/
def substructure_reduct : L'.substructure M ↪o L.substructure M :=
{ to_fun := λ S, { carrier := S,
    fun_mem := λ n f x hx, begin
      have h := S.fun_mem (φ.on_function f) x hx,
      simp only [Lhom.map_on_function, substructure.mem_carrier] at h,
      exact h,
    end },
  inj' := λ S T h, begin
    simp only [set_like.coe_set_eq] at h,
    exact h,
  end,
  map_rel_iff' := λ S T, iff.rfl }

@[simp] lemma mem_substructure_reduct {x : M} {S : L'.substructure M} :
  x ∈ φ.substructure_reduct S ↔ x ∈ S := iff.rfl

@[simp] lemma coe_substructure_reduct {S : L'.substructure M} :
  (φ.substructure_reduct S : set M) = ↑S := rfl

end Lhom

namespace substructure

/-- Turns any substructure containing a constant set `A` into a `L[[A]]`-substructure. -/
def with_constants (S : L.substructure M) {A : set M} (h : A ⊆ S) : L[[A]].substructure M :=
{ carrier := S,
  fun_mem := λ n f, begin
    cases f,
    { exact S.fun_mem f },
    { cases n,
      { exact λ _ _, h f.2 },
      { exact is_empty_elim f } }
  end }

variables {A : set M} {s : set M} (h : A ⊆ S)

@[simp] lemma mem_with_constants {x : M} : x ∈ S.with_constants h ↔ x ∈ S := iff.rfl

@[simp] lemma coe_with_constants : (S.with_constants h : set M) = ↑S := rfl

@[simp] lemma reduct_with_constants :
  (L.Lhom_with_constants A).substructure_reduct (S.with_constants h) = S :=
by { ext, simp }

lemma subset_closure_with_constants : A ⊆ (closure (L[[A]]) s) :=
begin
  intros a ha,
  simp only [set_like.mem_coe],
  let a' : (L[[A]]).constants := sum.inr ⟨a, ha⟩,
  exact constants_mem a',
end

lemma closure_with_constants_eq : (closure (L[[A]]) s) = (closure L (A ∪ s)).with_constants
  ((A.subset_union_left s).trans subset_closure) :=
begin
  refine closure_eq_of_le ((A.subset_union_right s).trans subset_closure) _,
  rw ← ((L.Lhom_with_constants A).substructure_reduct).le_iff_le,
  simp only [subset_closure, reduct_with_constants, closure_le, Lhom.coe_substructure_reduct,
    set.union_subset_iff, and_true],
  { exact subset_closure_with_constants },
  { apply_instance },
  { apply_instance },
end

end substructure

namespace hom

open substructure

/-- The restriction of a first-order hom to a substructure `s ⊆ M` gives a hom `s → N`. -/
@[simps] def dom_restrict (f : M →[L] N) (p : L.substructure M) : p →[L] N :=
f.comp p.subtype.to_hom

/-- A first-order hom `f : M → N` whose values lie in a substructure `p ⊆ N` can be restricted to a
hom `M → p`. -/
@[simps] def cod_restrict (p : L.substructure N) (f : M →[L] N) (h : ∀c, f c ∈ p) : M →[L] p :=
{ to_fun := λc, ⟨f c, h c⟩,
  map_rel' := λ n R x h, f.map_rel R x h }

@[simp] lemma comp_cod_restrict (f : M →[L] N) (g : N →[L] P) (p : L.substructure P)
  (h : ∀b, g b ∈ p) :
  ((cod_restrict p g h).comp f : M →[L] p) = cod_restrict p (g.comp f) (assume b, h _) :=
ext $ assume b, rfl

@[simp] lemma subtype_comp_cod_restrict (f : M →[L] N) (p : L.substructure N) (h : ∀b, f b ∈ p) :
  p.subtype.to_hom.comp (cod_restrict p f h) = f :=
ext $ assume b, rfl

/-- The range of a first-order hom `f : M → N` is a submodule of `N`.
See Note [range copy pattern]. -/
def range (f : M →[L] N) : L.substructure N :=
(map f ⊤).copy (set.range f) set.image_univ.symm

theorem range_coe (f : M →[L] N) :
  (range f : set N) = set.range f := rfl

@[simp] theorem mem_range
  {f : M →[L] N} {x} : x ∈ range f ↔ ∃ y, f y = x :=
iff.rfl

lemma range_eq_map
  (f : M →[L] N) : f.range = map f ⊤ :=
by { ext, simp }

theorem mem_range_self
  (f : M →[L] N) (x : M) : f x ∈ f.range := ⟨x, rfl⟩

@[simp] theorem range_id : range (id L M) = ⊤ :=
set_like.coe_injective set.range_id

theorem range_comp (f : M →[L] N) (g : N →[L] P) :
  range (g.comp f : M →[L] P) = map g (range f) :=
set_like.coe_injective (set.range_comp g f)

theorem range_comp_le_range (f : M →[L] N) (g : N →[L] P) :
  range (g.comp f : M →[L] P) ≤ range g :=
set_like.coe_mono (set.range_comp_subset_range f g)

theorem range_eq_top {f : M →[L] N} :
  range f = ⊤ ↔ function.surjective f :=
by rw [set_like.ext'_iff, range_coe, coe_top, set.range_iff_surjective]

lemma range_le_iff_comap {f : M →[L] N} {p : L.substructure N} :
  range f ≤ p ↔ comap f p = ⊤ :=
by rw [range_eq_map, map_le_iff_le_comap, eq_top_iff]

lemma map_le_range {f : M →[L] N} {p : L.substructure M} :
  map f p ≤ range f :=
set_like.coe_mono (set.image_subset_range f p)

/-- The substructure of elements `x : M` such that `f x = g x` -/
def eq_locus (f g : M →[L] N) : substructure L M :=
{ carrier := {x : M | f x = g x},
  fun_mem := λ n fn x hx, by
  { have h : f ∘ x = g ∘ x := by { ext, repeat {rw function.comp_apply}, apply hx, },
    simp [h], } }

/-- If two `L.hom`s are equal on a set, then they are equal on its substructure closure. -/
lemma eq_on_closure {f g : M →[L] N} {s : set M} (h : set.eq_on f g s) :
  set.eq_on f g (closure L s) :=
show closure L s ≤ f.eq_locus g, from closure_le.2 h

lemma eq_of_eq_on_top {f g : M →[L] N} (h : set.eq_on f g (⊤ : substructure L M)) :
  f = g :=
ext $ λ x, h trivial

variable {s : set M}

lemma eq_of_eq_on_dense (hs : closure L s = ⊤) {f g : M →[L] N} (h : s.eq_on f g) :
  f = g :=
eq_of_eq_on_top $ hs ▸ eq_on_closure h

end hom

namespace embedding
open substructure

/-- The restriction of a first-order embedding to a substructure `s ⊆ M` gives an embedding `s → N`.
-/
def dom_restrict (f : M ↪[L] N) (p : L.substructure M) : p ↪[L] N :=
  f.comp p.subtype

@[simp] lemma dom_restrict_apply (f : M ↪[L] N) (p : L.substructure M) (x : p) :
  f.dom_restrict p x = f x := rfl

/-- A first-order embedding `f : M → N` whose values lie in a substructure `p ⊆ N` can be restricted
to an embedding `M → p`. -/
def cod_restrict (p : L.substructure N) (f : M ↪[L] N) (h : ∀c, f c ∈ p) : M ↪[L] p :=
{ to_fun := f.to_hom.cod_restrict p h,
  inj' := λ a b ab, f.injective (subtype.mk_eq_mk.1 ab),
  map_fun' := λ n F x, (f.to_hom.cod_restrict p h).map_fun' F x,
  map_rel' := λ n r x, begin
    simp only,
    rw [← p.subtype.map_rel, function.comp.assoc],
    change rel_map r ((hom.comp p.subtype.to_hom (f.to_hom.cod_restrict p h)) ∘ x) ↔ _,
    rw [hom.subtype_comp_cod_restrict, ← f.map_rel],
    refl,
  end }

@[simp] theorem cod_restrict_apply (p : L.substructure N) (f : M ↪[L] N) {h} (x : M) :
  (cod_restrict p f h x : N) = f x := rfl

@[simp] lemma comp_cod_restrict (f : M ↪[L] N) (g : N ↪[L] P) (p : L.substructure P)
  (h : ∀b, g b ∈ p) :
  ((cod_restrict p g h).comp f : M ↪[L] p) = cod_restrict p (g.comp f) (assume b, h _) :=
ext $ assume b, rfl

@[simp] lemma subtype_comp_cod_restrict (f : M ↪[L] N) (p : L.substructure N) (h : ∀b, f b ∈ p) :
  p.subtype.comp (cod_restrict p f h) = f :=
ext $ assume b, rfl

/-- The equivalence between a substructure `s` and its image `s.map f.to_hom`, where `f` is an
  embedding. -/
noncomputable def substructure_equiv_map (f : M ↪[L] N) (s : L.substructure M) :
  s ≃[L] s.map f.to_hom :=
{ to_fun := cod_restrict (s.map f.to_hom) (f.dom_restrict s) (λ ⟨m, hm⟩, ⟨m, hm, rfl⟩),
  inv_fun := λ n, ⟨classical.some n.2, (classical.some_spec n.2).1⟩,
  left_inv := λ ⟨m, hm⟩, subtype.mk_eq_mk.2 (f.injective ((classical.some_spec (cod_restrict
    (s.map f.to_hom) (f.dom_restrict s) (λ ⟨m, hm⟩, ⟨m, hm, rfl⟩) ⟨m, hm⟩).2).2)),
  right_inv := λ ⟨n, hn⟩, subtype.mk_eq_mk.2 (classical.some_spec hn).2 }

@[simp] lemma substructure_equiv_map_apply (f : M ↪[L] N) (p : L.substructure M) (x : p) :
  (f.substructure_equiv_map p x : N) = f x := rfl

/-- The equivalence between the domain and the range of an embedding `f`. -/
noncomputable def equiv_range (f : M ↪[L] N) :
  M ≃[L] f.to_hom.range :=
{ to_fun := cod_restrict f.to_hom.range f f.to_hom.mem_range_self,
  inv_fun := λ n, classical.some n.2,
  left_inv := λ m, f.injective (classical.some_spec (cod_restrict f.to_hom.range f
    f.to_hom.mem_range_self m).2),
  right_inv := λ ⟨n, hn⟩, subtype.mk_eq_mk.2 (classical.some_spec hn) }

@[simp] lemma equiv_range_apply (f : M ↪[L] N) (x : M) :
  (f.equiv_range x : N) = f x := rfl

end embedding

namespace equiv

lemma to_hom_range (f : M ≃[L] N) :
  f.to_hom.range = ⊤ :=
begin
  ext n,
  simp only [hom.mem_range, coe_to_hom, substructure.mem_top, iff_true],
  exact ⟨f.symm n, apply_symm_apply _ _⟩
end

end equiv

namespace substructure

/-- The embedding associated to an inclusion of substructures. -/
def inclusion {S T : L.substructure M} (h : S ≤ T) : S ↪[L] T :=
S.subtype.cod_restrict _ (λ x, h x.2)

@[simp] lemma coe_inclusion {S T : L.substructure M} (h : S ≤ T) :
  (inclusion h : S → T) = set.inclusion h := rfl

lemma range_subtype (S : L.substructure M) : S.subtype.to_hom.range = S :=
begin
  ext x,
  simp only [hom.mem_range, embedding.coe_to_hom, coe_subtype],
  refine ⟨_, λ h, ⟨⟨x, h⟩, rfl⟩⟩,
  rintros ⟨⟨y, hy⟩, rfl⟩,
  exact hy,
end

end substructure

end language
end first_order


-- Pruebas de ∀x (P(x) ∧ Q(x)) ↔ ∀x P(x) ∧ ∀x Q(x)
-- ===============================================

import tactic

section

variable  {U : Type}
variables {P Q : U -> Prop}

-- ----------------------------------------------------
-- Ej. 1. Demostrar
--    ∀x (P(x) ∧ Q(x)) ⊢ ∀x P(x) ∧ ∀x Q(x)
-- ----------------------------------------------------

-- 1ª demostración
example
  (h1 : ∀x, P x ∧ Q x)
  : (∀x, P x) ∧ (∀x, Q x) :=
have h5 : ∀x, P x, from
    assume a,
    have h3 : P a ∧ Q a,  from h1 a,
    show P a,             from and.elim_left h3,
have h9 : ∀x, Q x, from
    assume b,
    have h7 : P b ∧ Q b,  from h1 b,
    show Q b,              from and.elim_right h7,
show (∀x, P x) ∧ (∀x, Q x), from and.intro h5 h9

-- 2ª demostración
example
  (h1 : ∀x, P x ∧ Q x)
  : (∀x, P x) ∧ (∀x, Q x) :=
have h5 : ∀x, P x, from
    assume a,
    have h3 : P a ∧ Q a,  from h1 a,
    show P a,             from h3.left,
have h9 : ∀x, Q x, from
    assume b,
    have h7 : P b ∧ Q b,  from h1 b,
    show Q b,              from h7.right,
show (∀x, P x) ∧ (∀x, Q x), from ⟨h5, h9⟩

-- 3ª demostración
example
  (h1 : ∀x, P x ∧ Q x)
  : (∀x, P x) ∧ (∀x, Q x) :=
have h5 : ∀x, P x, from
    assume a,
    have h3 : P a ∧ Q a,  from h1 a,
    h3.left,
have h9 : ∀x, Q x, from
    assume b,
    have h7 : P b ∧ Q b,  from h1 b,
    h7.right,
show (∀x, P x) ∧ (∀x, Q x), from ⟨h5, h9⟩

-- 4ª demostración
example
  (h1 : ∀x, P x ∧ Q x)
  : (∀x, P x) ∧ (∀x, Q x) :=
have h5 : ∀x, P x, from
    assume a,
    (h1 a).left,
have h9 : ∀x, Q x, from
    assume b,
    (h1 b).right,
show (∀x, P x) ∧ (∀x, Q x), from ⟨h5, h9⟩

-- 5ª demostración
example
  (h1 : ∀x, P x ∧ Q x)
  : (∀x, P x) ∧ (∀x, Q x) :=
have h5 : ∀x, P x, from
    λ a, (h1 a).left,
have h9 : ∀x, Q x, from
    λ b, (h1 b).right,
show (∀x, P x) ∧ (∀x, Q x), from ⟨h5, h9⟩

-- 6ª demostración
example
  (h1 : ∀x, P x ∧ Q x)
  : (∀x, P x) ∧ (∀x, Q x) :=
have h5 : ∀x, P x, from
    λ a, (h1 a).left,
have h9 : ∀x, Q x, from
    λ b, (h1 b).right,
⟨h5, h9⟩

-- 7ª demostración
example
  (h1 : ∀x, P x ∧ Q x)
  : (∀x, P x) ∧ (∀x, Q x) :=
⟨λ a, (h1 a).left, λ b, (h1 b).right⟩

-- 8ª demostración
example
  (h1 : ∀x, P x ∧ Q x)
  : (∀x, P x) ∧ (∀x, Q x) :=
-- by library_search
forall_and_distrib.mp h1

-- 9ª demostración
example
  (h1 : ∀x, P x ∧ Q x)
  : (∀x, P x) ∧ (∀x, Q x) :=
begin
  split,
  { intro a,
    specialize h1 a,
    exact h1.left, },
  { intro b,
    specialize h1 b,
    exact h1.right, },
end

-- 9ª demostración
lemma aux1
  (h1 : ∀x, P x ∧ Q x)
  : (∀x, P x) ∧ (∀x, Q x) :=
-- by hint
by finish

-- ----------------------------------------------------
-- Ej. 2. Demostrar
--    ∀x P(x) ∧ ∀x Q(x) ⊢ ∀x (P(x) ∧ Q(x))
-- ----------------------------------------------------

-- 1ª demostración
example
  (h1 : (∀x, P x) ∧ (∀x, Q x))
  : ∀x, P x ∧ Q x :=
assume a,
have h3 : ∀x, P x, from and.elim_left h1,
have h4 : P a,     from h3 a,
have h5 : ∀x, Q x, from and.elim_right h1,
have h6 : Q a,     from h5 a,
show P a ∧ Q a,    from and.intro h4 h6

-- 2ª demostración
example
  (h1 : (∀x, P x) ∧ (∀x, Q x))
  : ∀x, P x ∧ Q x :=
assume a,
have h3 : ∀x, P x, from h1.left,
have h4 : P a,     from h3 a,
have h5 : ∀x, Q x, from h1.right,
have h6 : Q a,     from h5 a,
show P a ∧ Q a,    from ⟨h4, h6⟩

-- 3ª demostración
example
  (h1 : (∀x, P x) ∧ (∀x, Q x))
  : ∀x, P x ∧ Q x :=
assume a,
have h3 : ∀x, P x, from h1.left,
have h4 : P a,     from h3 a,
have h5 : ∀x, Q x, from h1.right,
have h6 : Q a,     from h5 a,
⟨h4, h6⟩

-- 4ª demostración
example
  (h1 : (∀x, P x) ∧ (∀x, Q x))
  : ∀x, P x ∧ Q x :=
assume a,
have h3 : ∀x, P x, from h1.left,
have h4 : P a,     from h3 a,
have h5 : ∀x, Q x, from h1.right,
⟨h4, h5 a⟩

-- 5ª demostración
example
  (h1 : (∀x, P x) ∧ (∀x, Q x))
  : ∀x, P x ∧ Q x :=
assume a,
have h3 : ∀x, P x, from h1.left,
have h4 : P a,     from h3 a,
⟨h4, h1.right a⟩

-- 6ª demostración
example
  (h1 : (∀x, P x) ∧ (∀x, Q x))
  : ∀x, P x ∧ Q x :=
assume a,
have h3 : ∀x, P x, from h1.left,
⟨h3 a, h1.right a⟩

-- 7ª demostración
example
  (h1 : (∀x, P x) ∧ (∀x, Q x))
  : ∀x, P x ∧ Q x :=
assume a,
⟨h1.left a, h1.right a⟩

-- 8ª demostración
example
  (h1 : (∀x, P x) ∧ (∀x, Q x))
  : ∀x, P x ∧ Q x :=
λ a, ⟨h1.left a, h1.right a⟩

-- 9ª demostración
example
  (h1 : (∀x, P x) ∧ (∀x, Q x))
  : ∀x, P x ∧ Q x :=
-- by library_search
forall_and_distrib.mpr h1

-- 10ª demostración
example
  (h1 : (∀x, P x) ∧ (∀x, Q x))
  : ∀x, P x ∧ Q x :=
begin
  cases h1 with h2 h3,
  intro a,
  split,
  { apply h2, },
  { apply h3, },
end

-- 11ª demostración
example
  (h1 : (∀x, P x) ∧ (∀x, Q x))
  : ∀x, P x ∧ Q x :=
-- by hint
by tauto

-- 12ª demostración
lemma aux2
  (h1 : (∀x, P x) ∧ (∀x, Q x))
  : ∀x, P x ∧ Q x :=
by finish

-- ----------------------------------------------------
-- Ej. 3. Demostrar
--    ∀x (P(x) ∧ Q(x)) ↔ ∀x P(x) ∧ ∀x Q(x)
-- ----------------------------------------------------

-- 1ª demostración
example :
  (∀x, P x ∧ Q x) ↔ (∀x, P x) ∧ (∀x, Q x) :=
iff.intro aux1 aux2

-- 2ª demostración
example :
  (∀x, P x ∧ Q x) ↔ (∀x, P x) ∧ (∀x, Q x) :=
-- by library_search
forall_and_distrib

-- 3ª demostración
example :
  (∀x, P x ∧ Q x) ↔ (∀x, P x) ∧ (∀x, Q x) :=
-- by hint
by finish

end


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.finset.finsupp
import data.finset.locally_finite
import data.finsupp.order

/-!
# Finite intervals of finitely supported functions

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

This file provides the `locally_finite_order` instance for `ι →₀ α` when `α` itself is locally
finite and calculates the cardinality of its finite intervals.

## Main declarations

* `finsupp.range_singleton`: Postcomposition with `has_singleton.singleton` on `finset` as a
  `finsupp`.
* `finsupp.range_Icc`: Postcomposition with `finset.Icc` as a `finsupp`.

Both these definitions use the fact that `0 = {0}` to ensure that the resulting function is finitely
supported.
-/

noncomputable theory

open finset finsupp function
open_locale big_operators classical pointwise

variables {ι α : Type*}

namespace finsupp
section range_singleton
variables [has_zero α] {f : ι →₀ α} {i : ι} {a : α}

/-- Pointwise `finset.singleton` bundled as a `finsupp`. -/
@[simps] def range_singleton (f : ι →₀ α) : ι →₀ finset α :=
{ to_fun := λ i, {f i},
  support := f.support,
  mem_support_to_fun := λ i, begin
    rw [←not_iff_not, not_mem_support_iff, not_ne_iff],
    exact singleton_injective.eq_iff.symm,
  end }

lemma mem_range_singleton_apply_iff : a ∈ f.range_singleton i ↔ a = f i := mem_singleton

end range_singleton

section range_Icc
variables [has_zero α] [partial_order α] [locally_finite_order α] {f g : ι →₀ α} {i : ι} {a : α}

/-- Pointwise `finset.Icc` bundled as a `finsupp`. -/
@[simps to_fun] def range_Icc (f g : ι →₀ α) : ι →₀ finset α :=
{ to_fun := λ i, Icc (f i) (g i),
  support := by haveI := classical.dec_eq ι; exact f.support ∪ g.support,
  mem_support_to_fun := λ i, begin
    rw [mem_union, ←not_iff_not, not_or_distrib, not_mem_support_iff, not_mem_support_iff,
      not_ne_iff],
    exact Icc_eq_singleton_iff.symm,
  end }

@[simp] lemma range_Icc_support [decidable_eq ι] (f g : ι →₀ α) :
  (range_Icc f g).support = f.support ∪ g.support :=
by convert rfl

lemma mem_range_Icc_apply_iff : a ∈ f.range_Icc g i ↔ f i ≤ a ∧ a ≤ g i := mem_Icc

end range_Icc

section partial_order
variables [partial_order α] [has_zero α] [locally_finite_order α] (f g : ι →₀ α)

instance : locally_finite_order (ι →₀ α) :=
by haveI := classical.dec_eq ι; haveI := classical.dec_eq α; exact
locally_finite_order.of_Icc (ι →₀ α)
  (λ f g, (f.support ∪ g.support).finsupp $ f.range_Icc g)
  (λ f g x, begin
    refine (mem_finsupp_iff_of_support_subset $ finset.subset_of_eq $
      range_Icc_support _ _).trans _,
    simp_rw mem_range_Icc_apply_iff,
    exact forall_and_distrib,
  end)

lemma Icc_eq [decidable_eq ι] : Icc f g = (f.support ∪ g.support).finsupp (f.range_Icc g) :=
by convert rfl

lemma card_Icc [decidable_eq ι] :
  (Icc f g).card = ∏ i in f.support ∪ g.support, (Icc (f i) (g i)).card :=
by simp_rw [Icc_eq, card_finsupp, range_Icc_to_fun]

lemma card_Ico [decidable_eq ι] :
  (Ico f g).card = ∏ i in f.support ∪ g.support, (Icc (f i) (g i)).card - 1 :=
by rw [card_Ico_eq_card_Icc_sub_one, card_Icc]

lemma card_Ioc [decidable_eq ι] :
  (Ioc f g).card = ∏ i in f.support ∪ g.support, (Icc (f i) (g i)).card - 1 :=
by rw [card_Ioc_eq_card_Icc_sub_one, card_Icc]

lemma card_Ioo [decidable_eq ι] :
  (Ioo f g).card = ∏ i in f.support ∪ g.support, (Icc (f i) (g i)).card - 2 :=
by rw [card_Ioo_eq_card_Icc_sub_two, card_Icc]

end partial_order

section canonically_ordered
variables [canonically_ordered_add_monoid α] [locally_finite_order α]

variables (f : ι →₀ α)

lemma card_Iic : (Iic f).card = ∏ i in f.support, (Iic (f i)).card :=
begin
  classical,
  simp_rw [Iic_eq_Icc, card_Icc, finsupp.bot_eq_zero, support_zero, empty_union, zero_apply,
    bot_eq_zero]
end

lemma card_Iio : (Iio f).card = ∏ i in f.support, (Iic (f i)).card - 1 :=
by rw [card_Iio_eq_card_Iic_sub_one, card_Iic]

end canonically_ordered

end finsupp


import Lean
import Lean.Elab
import Lean.Elab.Tactic
import Lean.Meta
open Lean Expr Elab Meta Tactic

set_option pp.proofs true
set_option pp.proofs.withType true

/-
If the expression is of the form
A₁ → A₂ → A₃ → … → Aₙ → … → B,
the output of `targetType` is the type of `B`.

Essentially, it recovers the type of the term at the end of a series of nested implications.
-/
def getTargetType (e : Expr) : MetaM Expr :=
  Meta.forallTelescope e (λ _ t => pure t)

/-
This is the backbone of the `findProof` tactic, which is meant to find proofs (or equivalently, construct terms) of propositions (or types) involving only implications (or function arrows).

It works by first introducing all the necessary hypotheses, and then scanning the local context for terms having the goal as the "target type" (see above for the definition of a target type).

Once such a term is found, the tactic tries to recursively construct terms required to "unlock" the target, i.e., if `f : A₁ → A₂ → … → Aₙ → … → B` is a term with target type equal to the goal, terms of types `A₁, A₂, …, Aₙ, …` must be constructed in order to apply `f` and obtain a term of type `B`.

If none of the terms in the local context are able to eventually yield the target, the tactic fails. In principle, if a type can be constructed entirely in terms of function applications, this tactic should be able to find a term (this may not happen in practice due to looping).
-/
partial def findProofTU (mvar : MVarId) : TacticM Unit := do
  let (_, imvar) ← intros mvar -- introduce all the necessary hypotheses

  withMVarContext imvar do
    let tgtType ← getMVarType imvar -- the type of the goal

    for v in (← getLCtx) do -- scanning the local context
      let vType ← getTargetType v.type -- the target type of the local variables
      if !v.isAuxDecl then if (← isDefEq tgtType vType) then
        try
          let amvars ← apply imvar v.toExpr -- the goals obtained after applying the candidate term
          for amvar in amvars do
            findProofTU amvar -- recursively trying to solve the new goals
          done

          if (← getGoals).isEmpty then do
            logInfo m!"Proof complete - by {v.type}"
            return ()
        catch _ => continue

    -- throws an error if none of the terms of the local context can be used to construct the goal
    throwError m!"There are unsolved goals: \n\t{goalsToMessageData (← getGoals)}"

/-
This is the actual implementation of the tactic.
-/
syntax (name := findProof) "findProof" : tactic
@[tactic findProof] def findProofT : Tactic := fun stx => do
  findProofTU (← getMainGoal)

section examples

-- a convoluted example of the tactic in action
example : String → Float → (Unit → Int) → (Int → Nat) → (String → Unit) → Nat := by
  findProof

def convolutedexample : String → Float → (Unit → Int) → (Int → Nat) → (String → Unit) → Nat := by
  findProof

#print convolutedexample

def contrapose (P Q R : Type) : (P → Q) → ((Q → R) → (P → R)) := by
  findProof

#print contrapose

/-
P -> Q
Q -> ⊥
P
----
⊥
-/

def ident {A : Type} : A → A := by
  findProof

#print ident

def proj₁ {A B : Type} : A → (B → A) := by
  findProof

#print proj₁

def modusPonens {P Q : Type} : (P → Q) → (P → (Q)) := by
  findProof

#print modusPonens

def gelfand_naimark {A ℂ : Type} : A → ((A → ℂ) → ℂ) := by
  findProof

#print gelfand_naimark

def adjoint {V W F : Type} : (V → W) → ((W → F) → (V → (F))) := by
  findProof

#print adjoint

def differential {M N ℝ S : Type} (f : M → N) : ((M → ℝ) → S) → ((N → ℝ) → S) := by findProof

def differential' {M N ℝ : Type} (f : M → N) : ((M → ℝ) → ℝ) → ((N → ℝ) → ℝ) := differential f

#print differential

def cov_yoneda_fwd (A : Type) (F : Type → Type)
(η : (X : Type) → (A → X) → F X) : F A := by sorry

def cov_yoneda_fwd_simple (A : Type) (F : Type → Type) (η : (A → A) → F A) : F A := by findProof

#print cov_yoneda_fwd_simple

def cov_yoneda_bwd (A : Type) (F : Type → Type) (Fmap : (P Q : Type) → (P → Q) → (F P → F Q)) (a : F A) :
  ((X : Type) → ((A → X) → F X)) := by sorry

def cov_yoneda_bwd_simple (A X : Type) (F : Type → Type) (Fmap : (A → X) → (F A → F X)) (a : F A) :
  ((f : A → X) → F X) := by findProof

#print cov_yoneda_bwd

end examples


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import data.equiv.basic
import control.applicative
import control.traversable.basic
import algebra.group.hom

/-!
# Free constructions

## Main definitions

* `free_magma α`: free magma (structure with binary operation without any axioms) over alphabet `α`,
  defined inductively, with traversable instance and decidable equality.
* `magma.free_semigroup α`: free semigroup over magma `α`.
* `free_semigroup α`: free semigroup over alphabet `α`, defined as a synonym for `α × list α`
  (i.e. nonempty lists), with traversable instance and decidable equality.
* `free_semigroup_free_magma α`: isomorphism between `magma.free_semigroup (free_magma α)` and
  `free_semigroup α`.
* `free_magma.lift`: the universal property of the free magma, expressing its adjointness.
-/

universes u v l

/-- Free magma over a given alphabet. -/
@[derive decidable_eq]
inductive free_magma (α : Type u) : Type u
| of : α → free_magma
| mul : free_magma → free_magma → free_magma

/-- Free nonabelian additive magma over a given alphabet. -/
@[derive decidable_eq]
inductive free_add_magma (α : Type u) : Type u
| of : α → free_add_magma
| add : free_add_magma → free_add_magma → free_add_magma

attribute [to_additive] free_magma

namespace free_magma

variables {α : Type u}

@[to_additive]
instance [inhabited α] : inhabited (free_magma α) := ⟨of (default _)⟩

@[to_additive]
instance : has_mul (free_magma α) := ⟨free_magma.mul⟩

attribute [pattern] has_mul.mul

@[simp, to_additive]
theorem mul_eq (x y : free_magma α) : mul x y = x * y := rfl

/-- Recursor for `free_magma` using `x * y` instead of `free_magma.mul x y`. -/
@[to_additive "Recursor for `free_add_magma` using `x + y` instead of `free_add_magma.add x y`."]
def rec_on' {C : free_magma α → Sort l} (x)
  (ih1 : ∀ x, C (of x)) (ih2 : ∀ x y, C x → C y → C (x * y)) :
  C x :=
free_magma.rec_on x ih1 ih2
attribute [elab_as_eliminator] rec_on' free_add_magma.rec_on'

end free_magma

/-- Lifts a function `α → β` to a magma homomorphism `free_magma α → β` given a magma `β`. -/
def free_magma.lift_aux {α : Type u} {β : Type v} [has_mul β] (f : α → β) : free_magma α → β
| (free_magma.of x) := f x
| (x * y)           := x.lift_aux * y.lift_aux

/-- Lifts a function `α → β` to an additive magma homomorphism `free_add_magma α → β` given
an additive magma `β`. -/
def free_add_magma.lift_aux {α : Type u} {β : Type v} [has_add β] (f : α → β) : free_add_magma α → β
| (free_add_magma.of x) := f x
| (x + y)               := x.lift_aux + y.lift_aux

attribute [to_additive free_add_magma.lift_aux] free_magma.lift_aux

namespace free_magma

variables {α : Type u} {β : Type v} [has_mul β] (f : α → β)

@[to_additive]
theorem lift_aux_unique (F : mul_hom (free_magma α) β) : ⇑F = lift_aux (F ∘ of) :=
funext $ λ x, free_magma.rec_on x (λ x, rfl) $ λ x y ih1 ih2,
(F.map_mul x y).trans $ congr (congr_arg _ ih1) ih2

/-- The universal property of the free magma expressing its adjointness. -/
@[to_additive "The universal property of the free additive magma expressing its adjointness."]
def lift : (α → β) ≃ mul_hom (free_magma α) β :=
{ to_fun    := λ f,
  { to_fun := lift_aux f,
    map_mul' := λ x y, rfl, },
  inv_fun   := λ F, F ∘ of,
  left_inv  := λ f, by { ext, simp only [lift_aux, mul_hom.coe_mk, function.comp_app], },
  right_inv := λ F, by { ext, rw [mul_hom.coe_mk, lift_aux_unique], } }

@[simp, to_additive] lemma lift_of (x) : lift f (of x) = f x := rfl

end free_magma

/-- The unique magma homomorphism `free_magma α → free_magma β` that sends
each `of x` to `of (f x)`. -/
def free_magma.map {α : Type u} {β : Type v} (f : α → β) : free_magma α → free_magma β
| (free_magma.of x) := free_magma.of (f x)
| (x * y)           := x.map * y.map

/-- The unique additive magma homomorphism `free_add_magma α → free_add_magma β` that sends
each `of x` to `of (f x)`. -/
def free_add_magma.map {α : Type u} {β : Type v} (f : α → β) : free_add_magma α → free_add_magma β
| (free_add_magma.of x) := free_add_magma.of (f x)
| (x + y)               := x.map + y.map

attribute [to_additive free_add_magma.map] free_magma.map

namespace free_magma

variables {α : Type u}

section map

variables {β : Type v} (f : α → β)

@[simp, to_additive] lemma map_of (x) : map f (of x) = of (f x) := rfl
@[simp, to_additive] lemma map_mul (x y) : map f (x * y) = map f x * map f y := rfl

end map

section category

@[to_additive]
instance : monad free_magma :=
{ pure := λ _, of,
  bind := λ _ _ x f, lift f x }

/-- Recursor on `free_magma` using `pure` instead of `of`. -/
@[elab_as_eliminator, to_additive "Recursor on `free_add_magma` using `pure` instead of `of`."]
protected def rec_on'' {C : free_magma α → Sort l} (x)
  (ih1 : ∀ x, C (pure x)) (ih2 : ∀ x y, C x → C y → C (x * y)) :
  C x :=
free_magma.rec_on' x ih1 ih2

variables {β : Type u}

@[simp, to_additive]
lemma map_pure (f : α → β) (x) : (f <$> pure x : free_magma β) = pure (f x) := rfl

@[simp, to_additive]
lemma map_mul' (f : α → β) (x y : free_magma α) : (f <$> (x * y)) = (f <$> x * f <$> y) := rfl

@[simp, to_additive]
lemma pure_bind (f : α → free_magma β) (x) : (pure x >>= f) = f x := rfl

@[simp, to_additive]
lemma mul_bind (f : α → free_magma β) (x y : free_magma α) :
  (x * y >>= f) = ((x >>= f) * (y >>= f)) := rfl

@[simp, to_additive]
lemma pure_seq {α β : Type u} {f : α → β} {x : free_magma α} : pure f <*> x = f <$> x := rfl

@[simp, to_additive]
lemma mul_seq {α β : Type u} {f g : free_magma (α → β)} {x : free_magma α} :
  (f * g) <*> x = (f <*> x) * (g <*> x) := rfl

@[to_additive]
instance : is_lawful_monad free_magma.{u} :=
{ pure_bind := λ _ _ _ _, rfl,
  bind_assoc := λ α β γ x f g, free_magma.rec_on'' x (λ x, rfl)
    (λ x y ih1 ih2, by rw [mul_bind, mul_bind, mul_bind, ih1, ih2]),
  id_map := λ α x, free_magma.rec_on'' x (λ _, rfl)
    (λ x y ih1 ih2, by rw [map_mul', ih1, ih2]) }

end category

end free_magma

/-- `free_magma` is traversable. -/
protected def free_magma.traverse {m : Type u → Type u} [applicative m] {α β : Type u}
  (F : α → m β) :
  free_magma α → m (free_magma β)
| (free_magma.of x) := free_magma.of <$> F x
| (x * y)           := (*) <$> x.traverse <*> y.traverse

/-- `free_add_magma` is traversable. -/
protected def free_add_magma.traverse {m : Type u → Type u} [applicative m] {α β : Type u}
  (F : α → m β) :
  free_add_magma α → m (free_add_magma β)
| (free_add_magma.of x) := free_add_magma.of <$> F x
| (x + y)               := (+) <$> x.traverse <*> y.traverse

attribute [to_additive free_add_magma.traverse] free_magma.traverse

namespace free_magma

variables {α : Type u}

section category

variables {β : Type u}

@[to_additive]
instance : traversable free_magma := ⟨@free_magma.traverse⟩

variables {m : Type u → Type u} [applicative m] (F : α → m β)

@[simp, to_additive]
lemma traverse_pure (x) : traverse F (pure x : free_magma α) = pure <$> F x := rfl

@[simp, to_additive]
lemma traverse_pure' : traverse F ∘ pure = λ x, (pure <$> F x : m (free_magma β)) := rfl

@[simp, to_additive]
lemma traverse_mul (x y : free_magma α) :
  traverse F (x * y) = (*) <$> traverse F x <*> traverse F y := rfl

@[simp, to_additive]
lemma traverse_mul' :
  function.comp (traverse F) ∘ @has_mul.mul (free_magma α) _ =
    λ x y, (*) <$> traverse F x <*> traverse F y := rfl

@[simp, to_additive]
lemma traverse_eq (x) : free_magma.traverse F x = traverse F x := rfl

@[simp, to_additive]
lemma mul_map_seq (x y : free_magma α) :
  ((*) <$> x <*> y : id (free_magma α)) = (x * y : free_magma α) := rfl

@[to_additive]
instance : is_lawful_traversable free_magma.{u} :=
{ id_traverse := λ α x, free_magma.rec_on'' x (λ x, rfl)
    (λ x y ih1 ih2, by rw [traverse_mul, ih1, ih2, mul_map_seq]),
  comp_traverse := λ F G hf1 hg1 hf2 hg2 α β γ f g x, free_magma.rec_on'' x
    (λ x, by resetI; simp only [traverse_pure, traverse_pure'] with functor_norm)
    (λ x y ih1 ih2, by resetI; rw [traverse_mul, ih1, ih2, traverse_mul];
      simp only [traverse_mul'] with functor_norm),
  naturality := λ F G hf1 hg1 hf2 hg2 η α β f x, free_magma.rec_on'' x
    (λ x, by simp only [traverse_pure] with functor_norm)
    (λ x y ih1 ih2, by simp only [traverse_mul] with functor_norm; rw [ih1, ih2]),
  traverse_eq_map_id := λ α β f x, free_magma.rec_on'' x (λ _, rfl)
    (λ x y ih1 ih2, by rw [traverse_mul, ih1, ih2, map_mul', mul_map_seq]; refl),
  .. free_magma.is_lawful_monad }

end category

end free_magma

/-- Representation of an element of a free magma. -/
protected def free_magma.repr {α : Type u} [has_repr α] : free_magma α → string
| (free_magma.of x) := repr x
| (x * y)           := "( " ++ x.repr ++ " * " ++ y.repr ++ " )"

/-- Representation of an element of a free additive magma. -/
protected def free_add_magma.repr {α : Type u} [has_repr α] : free_add_magma α → string
| (free_add_magma.of x) := repr x
| (x + y)               := "( " ++ x.repr ++ " + " ++ y.repr ++ " )"

attribute [to_additive free_add_magma.repr] free_magma.repr

@[to_additive]
instance {α : Type u} [has_repr α] : has_repr (free_magma α) := ⟨free_magma.repr⟩

/-- Length of an element of a free magma. -/
def free_magma.length {α : Type u} : free_magma α → ℕ
| (free_magma.of x) := 1
| (x * y)           := x.length + y.length

/-- Length of an element of a free additive magma. -/
def free_add_magma.length {α : Type u} : free_add_magma α → ℕ
| (free_add_magma.of x) := 1
| (x + y)               := x.length + y.length

attribute [to_additive free_add_magma.length] free_magma.length

/-- Associativity relations for a magma. -/
inductive magma.free_semigroup.r (α : Type u) [has_mul α] : α → α → Prop
| intro : ∀ x y z, magma.free_semigroup.r ((x * y) * z) (x * (y * z))
| left : ∀ w x y z, magma.free_semigroup.r (w * ((x * y) * z)) (w * (x * (y * z)))

/-- Associativity relations for an additive magma. -/
inductive add_magma.free_add_semigroup.r (α : Type u) [has_add α] : α → α → Prop
| intro : ∀ x y z, add_magma.free_add_semigroup.r ((x + y) + z) (x + (y + z))
| left : ∀ w x y z, add_magma.free_add_semigroup.r (w + ((x + y) + z)) (w + (x + (y + z)))

attribute [to_additive add_magma.free_add_semigroup.r] magma.free_semigroup.r

namespace magma

/-- Free semigroup over a magma. -/
@[to_additive add_magma.free_add_semigroup "Free additive semigroup over an additive magma."]
def free_semigroup (α : Type u) [has_mul α] : Type u :=
quot $ free_semigroup.r α

namespace free_semigroup

variables {α : Type u} [has_mul α]

/-- Embedding from magma to its free semigroup. -/
@[to_additive "Embedding from additive magma to its free additive semigroup."]
def of : α → free_semigroup α := quot.mk _

@[to_additive]
instance [inhabited α] : inhabited (free_semigroup α) := ⟨of (default _)⟩

@[elab_as_eliminator, to_additive]
protected lemma induction_on {C : free_semigroup α → Prop} (x : free_semigroup α)
  (ih : ∀ x, C (of x)) : C x :=
quot.induction_on x ih

@[to_additive]
theorem of_mul_assoc (x y z : α) : of ((x * y) * z) = of (x * (y * z)) :=
quot.sound $ r.intro x y z

@[to_additive]
theorem of_mul_assoc_left (w x y z : α) : of (w * ((x * y) * z)) = of (w * (x * (y * z))) :=
quot.sound $ r.left w x y z

@[to_additive]
theorem of_mul_assoc_right (w x y z : α) : of (((w * x) * y) * z) = of ((w * (x * y)) * z) :=
by rw [of_mul_assoc, of_mul_assoc, of_mul_assoc, of_mul_assoc_left]

@[to_additive]
instance : semigroup (free_semigroup α) :=
{ mul := λ x y, begin
    refine quot.lift_on x (λ p, quot.lift_on y (λ q, (quot.mk _ $ p * q : free_semigroup α)) _) _,
    { rintros a b (⟨c, d, e⟩ | ⟨c, d, e, f⟩); change of _ = of _,
      { rw of_mul_assoc_left },
      { rw [← of_mul_assoc, of_mul_assoc_left, of_mul_assoc] } },
    { refine quot.induction_on y (λ q, _),
      rintros a b (⟨c, d, e⟩ | ⟨c, d, e, f⟩); change of _ = of _,
      { rw of_mul_assoc_right },
      { rw [of_mul_assoc, of_mul_assoc, of_mul_assoc_left, of_mul_assoc_left, of_mul_assoc_left,
          ← of_mul_assoc c d, ← of_mul_assoc c d, of_mul_assoc_left] } }
  end,
  mul_assoc := λ x y z, quot.induction_on x $ λ p, quot.induction_on y $ λ q,
    quot.induction_on z $ λ r, of_mul_assoc p q r }

@[to_additive]
theorem of_mul (x y : α) : of (x * y) = of x * of y := rfl

section lift

variables {β : Type v} [semigroup β] (f : α → β)

/-- Lifts a magma homomorphism `α → β` to a semigroup homomorphism `magma.free_semigroup α → β`
given a semigroup `β`. -/
@[to_additive "Lifts an additive magma homomorphism `α → β` to an additive semigroup homomorphism
`add_magma.free_add_semigroup α → β` given an additive semigroup `β`."]
def lift (hf : ∀ x y, f (x * y) = f x * f y) : free_semigroup α → β :=
quot.lift f $ by rintros a b (⟨c, d, e⟩ | ⟨c, d, e, f⟩); simp only [hf, mul_assoc]

@[simp, to_additive] lemma lift_of {hf} (x : α) : lift f hf (of x) = f x := rfl

@[simp, to_additive] lemma lift_mul {hf} (x y) : lift f hf (x * y) = lift f hf x * lift f hf y :=
quot.induction_on x $ λ p, quot.induction_on y $ λ q, hf p q

@[to_additive]
theorem lift_unique (f : free_semigroup α → β) (hf : ∀ x y, f (x * y) = f x * f y) :
  f = lift (f ∘ of) (λ p q, hf (of p) (of q)) :=
funext $ λ x, quot.induction_on x $ λ p, rfl

end lift

variables {β : Type v} [has_mul β] (f : α → β)

/-- From a magma homomorphism `α → β` to a semigroup homomorphism
`magma.free_semigroup α → magma.free_semigroup β`. -/
@[to_additive "From an additive magma homomorphism `α → β` to an additive semigroup homomorphism
`add_magma.free_add_semigroup α → add_magma.free_add_semigroup β`."]
def map (hf : ∀ x y, f (x * y) = f x * f y) : free_semigroup α → free_semigroup β :=
lift (of ∘ f) (λ x y, congr_arg of $ hf x y)

@[simp, to_additive] lemma map_of {hf} (x) : map f hf (of x) = of (f x) := rfl
@[simp, to_additive] lemma map_mul {hf} (x y) : map f hf (x * y) = map f hf x * map f hf y :=
lift_mul _ _ _

end free_semigroup

end magma

/-- Free semigroup over a given alphabet.
(Note: In this definition, the free semigroup does not contain the empty word.) -/
@[to_additive "Free additive semigroup over a given alphabet."]
def free_semigroup (α : Type u) : Type u :=
α × list α

namespace free_semigroup

variables {α : Type u}

@[to_additive]
instance : semigroup (free_semigroup α) :=
{ mul := λ L1 L2, (L1.1, L1.2 ++ L2.1 :: L2.2),
  mul_assoc := λ L1 L2 L3, prod.ext rfl $ list.append_assoc _ _ _ }

/-- The embedding `α → free_semigroup α`. -/
@[to_additive "The embedding `α → free_add_semigroup α`."]
def of (x : α) : free_semigroup α :=
(x, [])

@[to_additive]
instance [inhabited α] : inhabited (free_semigroup α) := ⟨of (default _)⟩

/-- Recursor for free semigroup using `of` and `*`. -/
@[elab_as_eliminator, to_additive "Recursor for free additive semigroup using `of` and `+`."]
protected def rec_on {C : free_semigroup α → Sort l} (x)
  (ih1 : ∀ x, C (of x)) (ih2 : ∀ x y, C (of x) → C y → C (of x * y)) :
  C x :=
prod.rec_on x $ λ f s, list.rec_on s ih1 (λ hd tl ih f, ih2 f (hd, tl) (ih1 f) (ih hd)) f

end free_semigroup

/-- Auxiliary function for `free_semigroup.lift`. -/
def free_semigroup.lift' {α : Type u} {β : Type v} [semigroup β] (f : α → β) : α → list α → β
| x [] := f x
| x (hd::tl) := f x * free_semigroup.lift' hd tl

/-- Auxiliary function for `free_semigroup.lift`. -/
def free_add_semigroup.lift' {α : Type u} {β : Type v} [add_semigroup β] (f : α → β) :
  α → list α → β
| x [] := f x
| x (hd::tl) := f x + free_add_semigroup.lift' hd tl

attribute [to_additive free_add_semigroup.lift'] free_semigroup.lift'

namespace free_semigroup

variables {α : Type u}

section lift

variables {β : Type v} [semigroup β] (f : α → β)

/-- Lifts a function `α → β` to a semigroup homomorphism `free_semigroup α → β` given
a semigroup `β`. -/
@[to_additive "Lifts a function `α → β` to an additive semigroup homomorphism
`free_add_semigroup α → β` given an additive semigroup `β`."]
def lift (x : free_semigroup α) : β :=
lift' f x.1 x.2

@[simp, to_additive] lemma lift_of (x : α) : lift f (of x) = f x := rfl
@[to_additive] lemma lift_of_mul (x y) : lift f (of x * y) = f x * lift f y := rfl

@[simp, to_additive] lemma lift_mul (x y) : lift f (x * y) = lift f x * lift f y :=
free_semigroup.rec_on x (λ p, rfl)
  (λ p x ih1 ih2, by rw [mul_assoc, lift_of_mul, lift_of_mul, mul_assoc, ih2])

@[to_additive]
theorem lift_unique (f : free_semigroup α → β) (hf : ∀ x y, f (x * y) = f x * f y) :
  f = lift (f ∘ of) :=
funext $ λ ⟨x, L⟩, list.rec_on L (λ x, rfl) (λ hd tl ih x,
  (hf (of x) (hd, tl)).trans $ congr_arg _ $ ih _) x

end lift

section map

variables {β : Type v} (f : α → β)

/-- The unique semigroup homomorphism that sends `of x` to `of (f x)`. -/
@[to_additive "The unique additive semigroup homomorphism that sends `of x` to `of (f x)`."]
def map : free_semigroup α → free_semigroup β :=
lift $ of ∘ f

@[simp, to_additive] lemma map_of (x) : map f (of x) = of (f x) := rfl
@[simp, to_additive] lemma map_mul (x y) : map f (x * y) = map f x * map f y :=
lift_mul _ _ _

end map

section category

variables {β : Type u}

@[to_additive]
instance : monad free_semigroup :=
{ pure := λ _, of,
  bind := λ _ _ x f, lift f x }

/-- Recursor that uses `pure` instead of `of`. -/
@[elab_as_eliminator, to_additive "Recursor that uses `pure` instead of `of`."]
def rec_on' {C : free_semigroup α → Sort l} (x)
  (ih1 : ∀ x, C (pure x)) (ih2 : ∀ x y, C (pure x) → C y → C (pure x * y)) :
  C x :=
free_semigroup.rec_on x ih1 ih2

@[simp, to_additive]
lemma map_pure (f : α → β) (x) : (f <$> pure x : free_semigroup β) = pure (f x) := rfl

@[simp, to_additive]
lemma map_mul' (f : α → β) (x y : free_semigroup α) :
  (f <$> (x * y)) = (f <$> x * f <$> y) :=
map_mul _ _ _

@[simp, to_additive] lemma pure_bind (f : α → free_semigroup β) (x) :
  (pure x >>= f) = f x := rfl

@[simp, to_additive]
lemma mul_bind (f : α → free_semigroup β) (x y : free_semigroup α) :
  (x * y >>= f) = ((x >>= f) * (y >>= f)) :=
lift_mul _ _ _

@[simp, to_additive] lemma pure_seq {f : α → β} {x : free_semigroup α} :
  pure f <*> x = f <$> x := rfl

@[simp, to_additive]
lemma mul_seq {f g : free_semigroup (α → β)} {x : free_semigroup α} :
  (f * g) <*> x = (f <*> x) * (g <*> x) :=
mul_bind _ _ _

@[to_additive]
instance : is_lawful_monad free_semigroup.{u} :=
{ pure_bind := λ _ _ _ _, rfl,
  bind_assoc := λ α β γ x f g, rec_on' x (λ x, rfl)
    (λ x y ih1 ih2, by rw [mul_bind, mul_bind, mul_bind, ih1, ih2]),
  id_map := λ α x, rec_on' x (λ _, rfl) (λ x y ih1 ih2, by rw [map_mul', ih1, ih2]) }

/-- `free_semigroup` is traversable. -/
@[to_additive "`free_add_semigroup` is traversable."]
protected def traverse {m : Type u → Type u} [applicative m]
  {α β : Type u} (F : α → m β) (x : free_semigroup α) : m (free_semigroup β) :=
rec_on' x (λ x, pure <$> F x) (λ x y ihx ihy, (*) <$> ihx <*> ihy)

@[to_additive]
instance : traversable free_semigroup := ⟨@free_semigroup.traverse⟩

variables {m : Type u → Type u} [applicative m] (F : α → m β)

@[simp, to_additive]
lemma traverse_pure (x) :traverse F (pure x : free_semigroup α) = pure <$> F x := rfl
@[simp, to_additive]
lemma traverse_pure' : traverse F ∘ pure = λ x, (pure <$> F x : m (free_semigroup β)) := rfl

section
variables [is_lawful_applicative m]
@[simp, to_additive] lemma traverse_mul (x y : free_semigroup α) :
  traverse F (x * y) = (*) <$> traverse F x <*> traverse F y :=
let ⟨x, L1⟩ := x, ⟨y, L2⟩ := y in
list.rec_on L1 (λ x, rfl) (λ hd tl ih x,
  show (*) <$> pure <$> F x <*> traverse F ((hd, tl) * (y, L2) : free_semigroup α) =
  (*) <$> ((*) <$> pure <$> F x <*> traverse F (hd, tl)) <*> traverse F (y, L2),
  by rw ih; simp only [(∘), (mul_assoc _ _ _).symm] with functor_norm) x

@[simp, to_additive] lemma traverse_mul' :
  function.comp (traverse F) ∘ @has_mul.mul (free_semigroup α) _ =
    λ x y, (*) <$> traverse F x <*> traverse F y :=
funext $ λ x, funext $ λ y, traverse_mul F x y
end

@[simp, to_additive] lemma traverse_eq (x) : free_semigroup.traverse F x = traverse F x := rfl

@[simp, to_additive] lemma mul_map_seq (x y : free_semigroup α) :
  ((*) <$> x <*> y : id (free_semigroup α)) = (x * y : free_semigroup α) := rfl

@[to_additive]
instance : is_lawful_traversable free_semigroup.{u} :=
{ id_traverse := λ α x, free_semigroup.rec_on x (λ x, rfl)
    (λ x y ih1 ih2, by rw [traverse_mul, ih1, ih2, mul_map_seq]),
  comp_traverse := λ F G hf1 hg1 hf2 hg2 α β γ f g x, rec_on' x
    (λ x, by resetI; simp only [traverse_pure, traverse_pure'] with functor_norm)
    (λ x y ih1 ih2, by resetI; rw [traverse_mul, ih1, ih2, traverse_mul];
      simp only [traverse_mul'] with functor_norm),
  naturality := λ F G hf1 hg1 hf2 hg2 η α β f x, rec_on' x
    (λ x, by simp only [traverse_pure] with functor_norm)
    (λ x y ih1 ih2, by resetI; simp only [traverse_mul] with functor_norm; rw [ih1, ih2]),
  traverse_eq_map_id := λ α β f x, free_semigroup.rec_on x (λ _, rfl)
    (λ x y ih1 ih2, by rw [traverse_mul, ih1, ih2, map_mul', mul_map_seq]; refl),
  .. free_semigroup.is_lawful_monad }

end category

@[to_additive]
instance [decidable_eq α] : decidable_eq (free_semigroup α) := prod.decidable_eq

end free_semigroup

/-- Isomorphism between `magma.free_semigroup (free_magma α)` and `free_semigroup α`. -/
@[to_additive "Isomorphism between
`add_magma.free_add_semigroup (free_add_magma α)` and `free_add_semigroup α`."]
def free_semigroup_free_magma (α : Type u) :
  magma.free_semigroup (free_magma α) ≃ free_semigroup α :=
{ to_fun    :=
    magma.free_semigroup.lift (free_magma.lift free_semigroup.of) (free_magma.lift _).map_mul,
  inv_fun   := free_semigroup.lift (magma.free_semigroup.of ∘ free_magma.of),
  left_inv  := λ x, magma.free_semigroup.induction_on x $ λ p, by rw magma.free_semigroup.lift_of;
    exact free_magma.rec_on' p
      (λ x, by rw [free_magma.lift_of, free_semigroup.lift_of])
      (λ x y ihx ihy, by rw [mul_hom.map_mul, free_semigroup.lift_mul, ihx, ihy,
        magma.free_semigroup.of_mul]),
  right_inv := λ x, free_semigroup.rec_on x
    (λ x, by rw [free_semigroup.lift_of, magma.free_semigroup.lift_of, free_magma.lift_of])
    (λ x y ihx ihy, by rw [free_semigroup.lift_mul, magma.free_semigroup.lift_mul, ihx, ihy]) }

@[simp, to_additive] lemma free_semigroup_free_magma_mul {α : Type u} (x y) :
  free_semigroup_free_magma α (x * y) = free_semigroup_free_magma α x *
    free_semigroup_free_magma α y :=
magma.free_semigroup.lift_mul _ _ _