import tactic

def hom  {X Y : Type} (f : X → X) (g : Y → Y) : Type :=
{ h : X → Y // ∀ z, h (f z) = g (h z) }

instance {X Y : Type} (f : X → X) (g : Y → Y) :
  has_coe_to_fun (hom f g) (λ _, X → Y) :=
{ coe := subtype.val }

-- Σ (X : Type) (x : X), (X → X)

-- def T := Σ (X : Type), X → X

-- def C := Σ t : T, t.fst

@[simp] lemma map_f {X Y : Type} (f : X → X) (g : Y → Y)
  (h : hom f g) : ∀ z, h (f z) = g (h z) := h.2

@[simp] def iterate_aux {X : Type} (x : X) (f : X → X) : ℕ → X
| 0     := x
| (n+1) := f (iterate_aux n)

def iterate {X : Sort*} (x : X) (f : X → X) : ℕ → X :=
iterate_aux x f
-- #print nat.rec_on
def nat.rec_on2 {motive : ℕ → Sort*} (n : ℕ) (h0 : motive 0)
  (h1 : Π (n : ℕ), motive n → motive n.succ) : motive n :=
let x : Σ n, motive n := iterate ⟨0, h0⟩ (λ x, ⟨x.1 + 1, h1 x.1 x.2⟩) n in

def factorial (n : ℕ) : ℕ :=
(iterate (1, 1) (λ x, (x.1 + 1, x.1 * x.2)) n).2

lemma factorial_zero : factorial 0 = 1 := rfl

#eval factorial 0

@[simp] lemma iterate_zero {X : Type} (x : X) (f : X → X) :
  iterate x f 0 = x := rfl

@[simp] lemma iterate_succ {X : Type} (x : X) (f : X → X) (n : ℕ) :
  iterate x f n.succ = f (iterate x f n) := rfl

lemma factorial_succ_aux (n : ℕ) :
  (iterate (1, 1) (λ x, (x.1 + 1, x.1 * x.2)) (n + 1)) =
    let x := iterate (1, 1) (λ x, (x.1 + 1, x.1 * x.2)) n in
      (n + 2, (n + 1) * x.2) :=
by induction n; simp *

lemma factorial_succ (n : ℕ) : factorial (n + 1) = (n + 1) * factorial n :=
begin
  rw [factorial, factorial_succ_aux],
  refl
end

lemma app_iterate {X Y : Type} (h : X → Y) (x : X) (n : ℕ) (f : X → X)
  (g : Y → Y)
  (H : ∀ x, h (f x) = g (h x)) :
  h (iterate x f n) = iterate (h x) g n :=
begin
  induction n with n ih,
  { refl },
  { rw [iterate_succ, iterate_succ, H, ih], }
end

lemma iterate_iterate {X : Type} (f : X → X) (x : X) (g : ℕ → ℕ) (y : ℕ) (n : ℕ)
  (H : ∀ z, iterate x f (g z) = f (iterate x f z)) :
  iterate x f (iterate y g n) = iterate (iterate x f y) f n :=
begin
  induction n with n ih,
  { refl },
  { simp [H, ih] }
end

-- @[simp] lemma iterate_zero_succ : ⇑(iterate 0 nat.succ) = id :=
-- by funext n; induction n; simp *

-- @[simp] lemma iterate_one_succ : ⇑(iterate 1 nat.succ) = nat.succ :=
-- by funext n; induction n; simp *

lemma succ_iterate (g : ℕ → ℕ) (y : ℕ) (n : ℕ)
  (H : ∀ z, nat.succ (g z) = nat.succ z.succ) :
  nat.succ (iterate y g n) = iterate y.succ nat.succ n :=
begin
  have := iterate_iterate nat.succ 1,
  rw [iterate_one_succ] at this,
  apply this,
  assumption,
end

@[simp] lemma iterate_zero_id {X : Type} {x : X}: ⇑(iterate x id) = (λ _, x) :=
by funext n; induction n; simp *

lemma iterate_eq (x : ℕ) (f : ℕ → ℕ) (g : ℕ → ℕ) (n : ℕ)
  (h0 : x = g 0)
  (h1 : ∀ n, f (g n) = g n.succ) :
  iterate x f n = g n :=
begin
  subst h0,
  induction n,
  { simp },
  { simp * }
end

@[simp] def add (a : ℕ) : ℕ → ℕ := iterate a nat.succ
@[simp] def mul (a : ℕ) : ℕ → ℕ := iterate 0 (add a)

infix ` + ` := add
infix ` * ` := mul

lemma add_assoc' (a b c : ℕ) : add (add a b) c = add a (add b c) :=
begin
  dunfold add,
  rw [iterate_iterate],
  intros,
  simp,
end

lemma succ_add (a b : ℕ) : (add a b).succ = add a.succ b :=
begin
  simp [add],
  rw succ_iterate,
  intros, refl
end

meta def tactic.interactive.fold :=
`[repeat { rw [← add] }, repeat { rw ← mul}]

lemma mul_add' (a b c : ℕ) : mul a (add b c) = add (mul a b) (mul a c) :=
begin
  delta add mul,
  rw [app_iterate (iterate 0 (iterate a nat.succ)) b],
  rw iterate_iterate,
  { apply iterate_eq,
    { refl },
    { intro c,
      rw iterate_iterate,
      { simp,
        symmetry,
        rw iterate_iterate,
        { apply iterate_eq,
          { simp,
            induction a with a ih,
            { simp, },
            { simp,
              rw [ih],
              fold, }
             } }

          } } }
end

def succ_eq_iterate (n : ℕ) : n.succ = iterate n nat.succ 1 := rfl

lemma mul_assoc' (a b c : ℕ) : mul (mul a b) c = mul a (mul b c) :=
begin
  delta add mul,
  dsimp,
  rw [app_iterate],

end


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

import group_theory.finiteness
import ring_theory.algebra_tower
import ring_theory.ideal.quotient
import ring_theory.noetherian

/-!
# Finiteness conditions in commutative algebra

In this file we define several notions of finiteness that are common in commutative algebra.

## Main declarations

- `module.finite`, `algebra.finite`, `ring_hom.finite`, `alg_hom.finite`
  all of these express that some object is finitely generated *as module* over some base ring.
- `algebra.finite_type`, `ring_hom.finite_type`, `alg_hom.finite_type`
  all of these express that some object is finitely generated *as algebra* over some base ring.
- `algebra.finite_presentation`, `ring_hom.finite_presentation`, `alg_hom.finite_presentation`
  all of these express that some object is finitely presented *as algebra* over some base ring.

-/

open function (surjective)
open_locale big_operators polynomial

section module_and_algebra

variables (R A B M N : Type*)

/-- A module over a semiring is `finite` if it is finitely generated as a module. -/
class module.finite [semiring R] [add_comm_monoid M] [module R M] :
  Prop := (out : (⊤ : submodule R M).fg)

/-- An algebra over a commutative semiring is of `finite_type` if it is finitely generated
over the base ring as algebra. -/
class algebra.finite_type [comm_semiring R] [semiring A] [algebra R A] : Prop :=
(out : (⊤ : subalgebra R A).fg)

/-- An algebra over a commutative semiring is `finite_presentation` if it is the quotient of a
polynomial ring in `n` variables by a finitely generated ideal. -/
def algebra.finite_presentation [comm_semiring R] [semiring A] [algebra R A] : Prop :=
∃ (n : ℕ) (f : mv_polynomial (fin n) R →ₐ[R] A),
  surjective f ∧ f.to_ring_hom.ker.fg

namespace module

variables [semiring R] [add_comm_monoid M] [module R M] [add_comm_monoid N] [module R N]

lemma finite_def {R M} [semiring R] [add_comm_monoid M] [module R M] :
  finite R M ↔ (⊤ : submodule R M).fg := ⟨λ h, h.1, λ h, ⟨h⟩⟩

@[priority 100] -- see Note [lower instance priority]
instance is_noetherian.finite [is_noetherian R M] : finite R M :=
⟨is_noetherian.noetherian ⊤⟩

namespace finite
open _root_.submodule set

lemma iff_add_monoid_fg {M : Type*} [add_comm_monoid M] : module.finite ℕ M ↔ add_monoid.fg M :=
⟨λ h, add_monoid.fg_def.2 $ (fg_iff_add_submonoid_fg ⊤).1 (finite_def.1 h),
  λ h, finite_def.2 $ (fg_iff_add_submonoid_fg ⊤).2 (add_monoid.fg_def.1 h)⟩

lemma iff_add_group_fg {G : Type*} [add_comm_group G] : module.finite ℤ G ↔ add_group.fg G :=
⟨λ h, add_group.fg_def.2 $ (fg_iff_add_subgroup_fg ⊤).1 (finite_def.1 h),
  λ h, finite_def.2 $ (fg_iff_add_subgroup_fg ⊤).2 (add_group.fg_def.1 h)⟩

variables {R M N}

lemma exists_fin [finite R M] : ∃ (n : ℕ) (s : fin n → M), span R (range s) = ⊤ :=
submodule.fg_iff_exists_fin_generating_family.mp out

lemma of_surjective [hM : finite R M] (f : M →ₗ[R] N) (hf : surjective f) :
  finite R N :=
⟨begin
  rw [← linear_map.range_eq_top.2 hf, ← submodule.map_top],
  exact hM.1.map f
end⟩

lemma of_injective [is_noetherian R N] (f : M →ₗ[R] N)
  (hf : function.injective f) : finite R M :=
⟨fg_of_injective f hf⟩

variables (R)

instance self : finite R R :=
⟨⟨{1}, by simpa only [finset.coe_singleton] using ideal.span_singleton_one⟩⟩

variable (M)

lemma of_restrict_scalars_finite (R A M : Type*) [comm_semiring R] [semiring A] [add_comm_monoid M]
  [module R M] [module A M] [algebra R A] [is_scalar_tower R A M] [hM : finite R M] :
  finite A M :=
begin
  rw [finite_def, fg_def] at hM ⊢,
  obtain ⟨S, hSfin, hSgen⟩ := hM,
  refine ⟨S, hSfin, eq_top_iff.2 _⟩,
  have := submodule.span_le_restrict_scalars R A S,
  rw hSgen at this,
  exact this
end

variables {R M}

instance prod [hM : finite R M] [hN : finite R N] : finite R (M × N) :=
⟨begin
  rw ← submodule.prod_top,
  exact submodule.fg_prod hM.1 hN.1
end⟩

instance pi {ι : Type*} {M : ι → Type*} [fintype ι] [Π i, add_comm_monoid (M i)]
  [Π i, module R (M i)] [h : ∀ i, finite R (M i)] : finite R (Π i, M i) :=
⟨begin
  rw ← submodule.pi_top,
  exact submodule.fg_pi (λ i, (h i).1),
end⟩

lemma equiv [hM : finite R M] (e : M ≃ₗ[R] N) : finite R N :=
of_surjective (e : M →ₗ[R] N) e.surjective

section algebra

lemma trans {R : Type*} (A B : Type*) [comm_semiring R] [comm_semiring A] [algebra R A]
  [semiring B] [algebra R B] [algebra A B] [is_scalar_tower R A B] :
  ∀ [finite R A] [finite A B], finite R B
| ⟨⟨s, hs⟩⟩ ⟨⟨t, ht⟩⟩ := ⟨submodule.fg_def.2
  ⟨set.image2 (•) (↑s : set A) (↑t : set B),
    set.finite.image2 _ s.finite_to_set t.finite_to_set,
    by rw [set.image2_smul, submodule.span_smul hs (↑t : set B),
      ht, submodule.restrict_scalars_top]⟩⟩

@[priority 100] -- see Note [lower instance priority]
instance finite_type {R : Type*} (A : Type*) [comm_semiring R] [comm_semiring A]
  [algebra R A] [hRA : finite R A] : algebra.finite_type R A :=
⟨subalgebra.fg_of_submodule_fg hRA.1⟩

end algebra

end finite

end module

namespace algebra

variables [comm_ring R] [comm_ring A] [algebra R A] [comm_ring B] [algebra R B]
variables [add_comm_group M] [module R M]
variables [add_comm_group N] [module R N]

namespace finite_type

lemma self : finite_type R R := ⟨⟨{1}, subsingleton.elim _ _⟩⟩

section
open_locale classical

protected lemma mv_polynomial (ι : Type*) [fintype ι] : finite_type R (mv_polynomial ι R) :=
⟨⟨finset.univ.image mv_polynomial.X, begin
  rw eq_top_iff, refine λ p, mv_polynomial.induction_on' p
    (λ u x, finsupp.induction u (subalgebra.algebra_map_mem _ x)
      (λ i n f hif hn ih, _))
    (λ p q ihp ihq, subalgebra.add_mem _ ihp ihq),
  rw [add_comm, mv_polynomial.monomial_add_single],
  exact subalgebra.mul_mem _ ih
    (subalgebra.pow_mem _ (subset_adjoin $ finset.mem_image_of_mem _ $ finset.mem_univ _) _)
end⟩⟩
end

lemma of_restrict_scalars_finite_type [algebra A B] [is_scalar_tower R A B] [hB : finite_type R B] :
  finite_type A B :=
begin
  obtain ⟨S, hS⟩ := hB.out,
  refine ⟨⟨S, eq_top_iff.2 (λ b, _)⟩⟩,
  have le : adjoin R (S : set B) ≤ subalgebra.restrict_scalars R (adjoin A S),
  { apply (algebra.adjoin_le _ : _ ≤ (subalgebra.restrict_scalars R (adjoin A ↑S))),
    simp only [subalgebra.coe_restrict_scalars],
    exact algebra.subset_adjoin, },
  exact le (eq_top_iff.1 hS b),
end

variables {R A B}

lemma of_surjective (hRA : finite_type R A) (f : A →ₐ[R] B) (hf : surjective f) :
  finite_type R B :=
⟨begin
  convert subalgebra.fg_map _ f hRA.1,
  simpa only [map_top f, @eq_comm _ ⊤, eq_top_iff, alg_hom.mem_range] using hf
end⟩

lemma equiv (hRA : finite_type R A) (e : A ≃ₐ[R] B) : finite_type R B :=
hRA.of_surjective e e.surjective

lemma trans [algebra A B] [is_scalar_tower R A B] (hRA : finite_type R A) (hAB : finite_type A B) :
  finite_type R B :=
⟨fg_trans' hRA.1 hAB.1⟩

/-- An algebra is finitely generated if and only if it is a quotient
of a polynomial ring whose variables are indexed by a finset. -/
lemma iff_quotient_mv_polynomial : (finite_type R A) ↔ ∃ (s : finset A)
  (f : (mv_polynomial {x // x ∈ s} R) →ₐ[R] A), (surjective f) :=
begin
  split,
  { rintro ⟨s, hs⟩,
    use [s, mv_polynomial.aeval coe],
    intro x,
    have hrw : (↑s : set A) = (λ (x : A), x ∈ s.val) := rfl,
    rw [← set.mem_range, ← alg_hom.coe_range, ← adjoin_eq_range, ← hrw, hs],
    exact set.mem_univ x },
  { rintro ⟨s, ⟨f, hsur⟩⟩,
    exact finite_type.of_surjective (finite_type.mv_polynomial R {x // x ∈ s}) f hsur }
end

/-- An algebra is finitely generated if and only if it is a quotient
of a polynomial ring whose variables are indexed by a fintype. -/
lemma iff_quotient_mv_polynomial' : (finite_type R A) ↔ ∃ (ι : Type u_2) (_ : fintype ι)
  (f : (mv_polynomial ι R) →ₐ[R] A), (surjective f) :=
begin
  split,
  { rw iff_quotient_mv_polynomial,
    rintro ⟨s, ⟨f, hsur⟩⟩,
    use [{x // x ∈ s}, by apply_instance, f, hsur] },
  { rintro ⟨ι, ⟨hfintype, ⟨f, hsur⟩⟩⟩,
    letI : fintype ι := hfintype,
    exact finite_type.of_surjective (finite_type.mv_polynomial R ι) f hsur }
end

/-- An algebra is finitely generated if and only if it is a quotient of a polynomial ring in `n`
variables. -/
lemma iff_quotient_mv_polynomial'' : (finite_type R A) ↔ ∃ (n : ℕ)
  (f : (mv_polynomial (fin n) R) →ₐ[R] A), (surjective f) :=
begin
  split,
  { rw iff_quotient_mv_polynomial',
    rintro ⟨ι, hfintype, ⟨f, hsur⟩⟩,
    letI := hfintype,
    obtain ⟨equiv⟩ := @fintype.trunc_equiv_fin ι (classical.dec_eq ι) hfintype,
    replace equiv := mv_polynomial.rename_equiv R equiv,
    exact ⟨fintype.card ι, alg_hom.comp f equiv.symm, function.surjective.comp hsur
      (alg_equiv.symm equiv).surjective⟩ },
  { rintro ⟨n, ⟨f, hsur⟩⟩,
    exact finite_type.of_surjective (finite_type.mv_polynomial R (fin n)) f hsur }
end

/-- A finitely presented algebra is of finite type. -/
lemma of_finite_presentation : finite_presentation R A → finite_type R A :=
begin
  rintro ⟨n, f, hf⟩,
  apply (finite_type.iff_quotient_mv_polynomial'').2,
  exact ⟨n, f, hf.1⟩
end

instance prod [hA : finite_type R A] [hB : finite_type R B] : finite_type R (A × B) :=
⟨begin
  rw ← subalgebra.prod_top,
  exact subalgebra.fg_prod hA.1 hB.1
end⟩

end finite_type

namespace finite_presentation

variables {R A B}

/-- An algebra over a Noetherian ring is finitely generated if and only if it is finitely
presented. -/
lemma of_finite_type [is_noetherian_ring R] : finite_type R A ↔ finite_presentation R A :=
begin
  refine ⟨λ h, _, algebra.finite_type.of_finite_presentation⟩,
  obtain ⟨n, f, hf⟩ := algebra.finite_type.iff_quotient_mv_polynomial''.1 h,
  refine ⟨n, f, hf, _⟩,
  have hnoet : is_noetherian_ring (mv_polynomial (fin n) R) := by apply_instance,
  replace hnoet := (is_noetherian_ring_iff.1 hnoet).noetherian,
  exact hnoet f.to_ring_hom.ker,
end

/-- If `e : A ≃ₐ[R] B` and `A` is finitely presented, then so is `B`. -/
lemma equiv (hfp : finite_presentation R A) (e : A ≃ₐ[R] B) : finite_presentation R B :=
begin
  obtain ⟨n, f, hf⟩ := hfp,
  use [n, alg_hom.comp ↑e f],
  split,
  { exact function.surjective.comp e.surjective hf.1 },
  suffices hker : (alg_hom.comp ↑e f).to_ring_hom.ker = f.to_ring_hom.ker,
  { rw hker, exact hf.2 },
  { have hco : (alg_hom.comp ↑e f).to_ring_hom = ring_hom.comp ↑e.to_ring_equiv f.to_ring_hom,
    { have h : (alg_hom.comp ↑e f).to_ring_hom = e.to_alg_hom.to_ring_hom.comp f.to_ring_hom := rfl,
      have h1 : ↑(e.to_ring_equiv) = (e.to_alg_hom).to_ring_hom := rfl,
      rw [h, h1] },
    rw [ring_hom.ker_eq_comap_bot, hco, ← ideal.comap_comap, ← ring_hom.ker_eq_comap_bot,
      ring_hom.ker_coe_equiv (alg_equiv.to_ring_equiv e), ring_hom.ker_eq_comap_bot] }
end

variable (R)

/-- The ring of polynomials in finitely many variables is finitely presented. -/
protected lemma mv_polynomial (ι : Type u_2) [fintype ι] :
  finite_presentation R (mv_polynomial ι R) :=
begin
  obtain ⟨equiv⟩ := @fintype.trunc_equiv_fin ι (classical.dec_eq ι) _,
  replace equiv := mv_polynomial.rename_equiv R equiv,
  refine ⟨_, alg_equiv.to_alg_hom equiv.symm, _⟩,
  split,
  { exact (alg_equiv.symm equiv).surjective },
  suffices hinj : function.injective equiv.symm.to_alg_hom.to_ring_hom,
  { rw [(ring_hom.injective_iff_ker_eq_bot _).1 hinj],
    exact submodule.fg_bot },
  exact (alg_equiv.symm equiv).injective
end

/-- `R` is finitely presented as `R`-algebra. -/
lemma self : finite_presentation R R :=
equiv (finite_presentation.mv_polynomial R pempty) (mv_polynomial.is_empty_alg_equiv R pempty)

variable {R}

/-- The quotient of a finitely presented algebra by a finitely generated ideal is finitely
presented. -/
protected lemma quotient {I : ideal A} (h : I.fg) (hfp : finite_presentation R A) :
  finite_presentation R (A ⧸ I) :=
begin
  obtain ⟨n, f, hf⟩ := hfp,
  refine ⟨n, (ideal.quotient.mkₐ R I).comp f, _, _⟩,
  { exact (ideal.quotient.mkₐ_surjective R I).comp hf.1 },
  { refine ideal.fg_ker_comp _ _ hf.2 _ hf.1,
    simp [h] }
end

/-- If `f : A →ₐ[R] B` is surjective with finitely generated kernel and `A` is finitely presented,
then so is `B`. -/
lemma of_surjective {f : A →ₐ[R] B} (hf : function.surjective f) (hker : f.to_ring_hom.ker.fg)
  (hfp : finite_presentation R A) : finite_presentation R B :=
equiv (hfp.quotient hker) (ideal.quotient_ker_alg_equiv_of_surjective hf)

lemma iff : finite_presentation R A ↔
  ∃ n (I : ideal (mv_polynomial (fin n) R)) (e : (_ ⧸ I) ≃ₐ[R] A), I.fg :=
begin
  split,
  { rintros ⟨n, f, hf⟩,
    exact ⟨n, f.to_ring_hom.ker, ideal.quotient_ker_alg_equiv_of_surjective hf.1, hf.2⟩ },
  { rintros ⟨n, I, e, hfg⟩,
    exact equiv ((finite_presentation.mv_polynomial R _).quotient hfg) e }
end

/-- An algebra is finitely presented if and only if it is a quotient of a polynomial ring whose
variables are indexed by a fintype by a finitely generated ideal. -/
lemma iff_quotient_mv_polynomial' : finite_presentation R A ↔ ∃ (ι : Type u_2) (_ : fintype ι)
  (f : mv_polynomial ι R →ₐ[R] A), surjective f ∧ f.to_ring_hom.ker.fg :=
begin
  split,
  { rintro ⟨n, f, hfs, hfk⟩,
    set ulift_var := mv_polynomial.rename_equiv R equiv.ulift,
    refine ⟨ulift (fin n), infer_instance, f.comp ulift_var.to_alg_hom,
      hfs.comp ulift_var.surjective,
      ideal.fg_ker_comp _ _ _ hfk ulift_var.surjective⟩,
    convert submodule.fg_bot,
    exact ring_hom.ker_coe_equiv ulift_var.to_ring_equiv, },
  { rintro ⟨ι, hfintype, f, hf⟩,
    haveI : fintype ι := hfintype,
    obtain ⟨equiv⟩ := @fintype.trunc_equiv_fin ι (classical.dec_eq ι) _,
    replace equiv := mv_polynomial.rename_equiv R equiv,
    refine ⟨fintype.card ι, f.comp equiv.symm,
      hf.1.comp (alg_equiv.symm equiv).surjective,
      ideal.fg_ker_comp _ f _ hf.2 equiv.symm.surjective⟩,
    convert submodule.fg_bot,
    exact ring_hom.ker_coe_equiv (equiv.symm.to_ring_equiv), }
end

/-- If `A` is a finitely presented `R`-algebra, then `mv_polynomial (fin n) A` is finitely presented
as `R`-algebra. -/
lemma mv_polynomial_of_finite_presentation (hfp : finite_presentation R A) (ι : Type*)
  [fintype ι] : finite_presentation R (mv_polynomial ι A) :=
begin
  rw iff_quotient_mv_polynomial' at hfp ⊢,
  classical,
  obtain ⟨ι', _, f, hf_surj, hf_ker⟩ := hfp,
  resetI,
  let g := (mv_polynomial.map_alg_hom f).comp (mv_polynomial.sum_alg_equiv R ι ι').to_alg_hom,
  refine ⟨ι ⊕ ι', by apply_instance, g,
    (mv_polynomial.map_surjective f.to_ring_hom hf_surj).comp (alg_equiv.surjective _),
    ideal.fg_ker_comp _ _ _ _ (alg_equiv.surjective _)⟩,
  { convert submodule.fg_bot,
    exact ring_hom.ker_coe_equiv (mv_polynomial.sum_alg_equiv R ι ι').to_ring_equiv },
  { rw [alg_hom.to_ring_hom_eq_coe, mv_polynomial.map_alg_hom_coe_ring_hom, mv_polynomial.ker_map],
    exact hf_ker.map mv_polynomial.C, }
end

/-- If `A` is an `R`-algebra and `S` is an `A`-algebra, both finitely presented, then `S` is
  finitely presented as `R`-algebra. -/
lemma trans [algebra A B] [is_scalar_tower R A B] (hfpA : finite_presentation R A)
  (hfpB : finite_presentation A B) : finite_presentation R B :=
begin
  obtain ⟨n, I, e, hfg⟩ := iff.1 hfpB,
  exact equiv ((mv_polynomial_of_finite_presentation hfpA _).quotient hfg) (e.restrict_scalars R)
end

end finite_presentation

end algebra

end module_and_algebra

namespace ring_hom
variables {A B C : Type*} [comm_ring A] [comm_ring B] [comm_ring C]

/-- A ring morphism `A →+* B` is `finite` if `B` is finitely generated as `A`-module. -/
def finite (f : A →+* B) : Prop :=
by letI : algebra A B := f.to_algebra; exact module.finite A B

/-- A ring morphism `A →+* B` is of `finite_type` if `B` is finitely generated as `A`-algebra. -/
def finite_type (f : A →+* B) : Prop := @algebra.finite_type A B _ _ f.to_algebra

/-- A ring morphism `A →+* B` is of `finite_presentation` if `B` is finitely presented as
`A`-algebra. -/
def finite_presentation (f : A →+* B) : Prop := @algebra.finite_presentation A B _ _ f.to_algebra

namespace finite

variables (A)

lemma id : finite (ring_hom.id A) := module.finite.self A

variables {A}

lemma of_surjective (f : A →+* B) (hf : surjective f) : f.finite :=
begin
  letI := f.to_algebra,
  exact module.finite.of_surjective (algebra.of_id A B).to_linear_map hf
end

lemma comp {g : B →+* C} {f : A →+* B} (hg : g.finite) (hf : f.finite) : (g.comp f).finite :=
@module.finite.trans A B C _ _ f.to_algebra _ (g.comp f).to_algebra g.to_algebra
begin
  fconstructor,
  intros a b c,
  simp only [algebra.smul_def, ring_hom.map_mul, mul_assoc],
  refl
end
hf hg

lemma finite_type {f : A →+* B} (hf : f.finite) : finite_type f :=
@module.finite.finite_type _ _ _ _ f.to_algebra hf

lemma of_comp_finite {f : A →+* B} {g : B →+* C} (h : (g.comp f).finite) : g.finite :=
begin
  letI := f.to_algebra,
  letI := g.to_algebra,
  letI := (g.comp f).to_algebra,
  letI : is_scalar_tower A B C := restrict_scalars.is_scalar_tower A B C,
  letI : module.finite A C := h,
  exact module.finite.of_restrict_scalars_finite A B C
end

end finite

namespace finite_type

variables (A)

lemma id : finite_type (ring_hom.id A) := algebra.finite_type.self A

variables {A}

lemma comp_surjective {f : A →+* B} {g : B →+* C} (hf : f.finite_type) (hg : surjective g) :
  (g.comp f).finite_type :=
@algebra.finite_type.of_surjective A B C _ _ f.to_algebra _ (g.comp f).to_algebra hf
{ to_fun := g, commutes' := λ a, rfl, .. g } hg

lemma of_surjective (f : A →+* B) (hf : surjective f) : f.finite_type :=
by { rw ← f.comp_id, exact (id A).comp_surjective hf }

lemma comp {g : B →+* C} {f : A →+* B} (hg : g.finite_type) (hf : f.finite_type) :
  (g.comp f).finite_type :=
@algebra.finite_type.trans A B C _ _ f.to_algebra _ (g.comp f).to_algebra g.to_algebra
begin
  fconstructor,
  intros a b c,
  simp only [algebra.smul_def, ring_hom.map_mul, mul_assoc],
  refl
end
hf hg

lemma of_finite_presentation {f : A →+* B} (hf : f.finite_presentation) : f.finite_type :=
@algebra.finite_type.of_finite_presentation A B _ _ f.to_algebra hf

lemma of_comp_finite_type {f : A →+* B} {g : B →+* C} (h : (g.comp f).finite_type) :
  g.finite_type :=
begin
  letI := f.to_algebra,
  letI := g.to_algebra,
  letI := (g.comp f).to_algebra,
  letI : is_scalar_tower A B C := restrict_scalars.is_scalar_tower A B C,
  letI : algebra.finite_type A C := h,
  exact algebra.finite_type.of_restrict_scalars_finite_type A B C
end

end finite_type

namespace finite_presentation

variables (A)

lemma id : finite_presentation (ring_hom.id A) := algebra.finite_presentation.self A

variables {A}

lemma comp_surjective {f : A →+* B} {g : B →+* C} (hf : f.finite_presentation) (hg : surjective g)
  (hker : g.ker.fg) :  (g.comp f).finite_presentation :=
@algebra.finite_presentation.of_surjective A B C _ _ f.to_algebra _ (g.comp f).to_algebra
{ to_fun := g, commutes' := λ a, rfl, .. g } hg hker hf

lemma of_surjective (f : A →+* B) (hf : surjective f) (hker : f.ker.fg) : f.finite_presentation :=
by { rw ← f.comp_id, exact (id A).comp_surjective hf hker}

lemma of_finite_type [is_noetherian_ring A] {f : A →+* B} : f.finite_type ↔ f.finite_presentation :=
@algebra.finite_presentation.of_finite_type A B _ _ f.to_algebra _

lemma comp {g : B →+* C} {f : A →+* B} (hg : g.finite_presentation) (hf : f.finite_presentation) :
  (g.comp f).finite_presentation :=
@algebra.finite_presentation.trans A B C _ _ f.to_algebra _ (g.comp f).to_algebra g.to_algebra
{ smul_assoc := λ a b c, begin
    simp only [algebra.smul_def, ring_hom.map_mul, mul_assoc],
    refl
  end }
hf hg

end finite_presentation

end ring_hom

namespace alg_hom

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

/-- An algebra morphism `A →ₐ[R] B` is finite if it is finite as ring morphism.
In other words, if `B` is finitely generated as `A`-module. -/
def finite (f : A →ₐ[R] B) : Prop := f.to_ring_hom.finite

/-- An algebra morphism `A →ₐ[R] B` is of `finite_type` if it is of finite type as ring morphism.
In other words, if `B` is finitely generated as `A`-algebra. -/
def finite_type (f : A →ₐ[R] B) : Prop := f.to_ring_hom.finite_type

/-- An algebra morphism `A →ₐ[R] B` is of `finite_presentation` if it is of finite presentation as
ring morphism. In other words, if `B` is finitely presented as `A`-algebra. -/
def finite_presentation (f : A →ₐ[R] B) : Prop := f.to_ring_hom.finite_presentation

namespace finite

variables (R A)

lemma id : finite (alg_hom.id R A) := ring_hom.finite.id A

variables {R A}

lemma comp {g : B →ₐ[R] C} {f : A →ₐ[R] B} (hg : g.finite) (hf : f.finite) : (g.comp f).finite :=
ring_hom.finite.comp hg hf

lemma of_surjective (f : A →ₐ[R] B) (hf : surjective f) : f.finite :=
ring_hom.finite.of_surjective f hf

lemma finite_type {f : A →ₐ[R] B} (hf : f.finite) : finite_type f :=
ring_hom.finite.finite_type hf

lemma of_comp_finite {f : A →ₐ[R] B} {g : B →ₐ[R] C} (h : (g.comp f).finite) : g.finite :=
ring_hom.finite.of_comp_finite h

end finite

namespace finite_type

variables (R A)

lemma id : finite_type (alg_hom.id R A) := ring_hom.finite_type.id A

variables {R A}

lemma comp {g : B →ₐ[R] C} {f : A →ₐ[R] B} (hg : g.finite_type) (hf : f.finite_type) :
  (g.comp f).finite_type :=
ring_hom.finite_type.comp hg hf

lemma comp_surjective {f : A →ₐ[R] B} {g : B →ₐ[R] C} (hf : f.finite_type) (hg : surjective g) :
  (g.comp f).finite_type :=
ring_hom.finite_type.comp_surjective hf hg

lemma of_surjective (f : A →ₐ[R] B) (hf : surjective f) : f.finite_type :=
ring_hom.finite_type.of_surjective f hf

lemma of_finite_presentation {f : A →ₐ[R] B} (hf : f.finite_presentation) : f.finite_type :=
ring_hom.finite_type.of_finite_presentation hf

lemma of_comp_finite_type {f : A →ₐ[R] B} {g : B →ₐ[R] C} (h : (g.comp f).finite_type) :
g.finite_type :=
ring_hom.finite_type.of_comp_finite_type h

end finite_type

namespace finite_presentation

variables (R A)

lemma id : finite_presentation (alg_hom.id R A) := ring_hom.finite_presentation.id A

variables {R A}

lemma comp {g : B →ₐ[R] C} {f : A →ₐ[R] B} (hg : g.finite_presentation)
  (hf : f.finite_presentation) : (g.comp f).finite_presentation :=
ring_hom.finite_presentation.comp hg hf

lemma comp_surjective {f : A →ₐ[R] B} {g : B →ₐ[R] C} (hf : f.finite_presentation)
  (hg : surjective g) (hker : g.to_ring_hom.ker.fg) : (g.comp f).finite_presentation :=
ring_hom.finite_presentation.comp_surjective hf hg hker

lemma of_surjective (f : A →ₐ[R] B) (hf : surjective f) (hker : f.to_ring_hom.ker.fg) :
  f.finite_presentation :=
ring_hom.finite_presentation.of_surjective f hf hker

lemma of_finite_type [is_noetherian_ring A] {f : A →ₐ[R] B} :
  f.finite_type ↔ f.finite_presentation :=
ring_hom.finite_presentation.of_finite_type

end finite_presentation

end alg_hom

section monoid_algebra

variables {R : Type*} {M : Type*}

namespace add_monoid_algebra

open algebra add_submonoid submodule

section span

section semiring

variables [comm_semiring R] [add_monoid M]

/-- An element of `add_monoid_algebra R M` is in the subalgebra generated by its support. -/
lemma mem_adjoin_support (f : add_monoid_algebra R M) : f ∈ adjoin R (of' R M '' f.support) :=
begin
  suffices : span R (of' R M '' f.support) ≤ (adjoin R (of' R M '' f.support)).to_submodule,
  { exact this (mem_span_support f) },
  rw submodule.span_le,
  exact subset_adjoin
end

/-- If a set `S` generates, as algebra, `add_monoid_algebra R M`, then the set of supports of
elements of `S` generates `add_monoid_algebra R M`. -/
lemma support_gen_of_gen {S : set (add_monoid_algebra R M)} (hS : algebra.adjoin R S = ⊤) :
  algebra.adjoin R (⋃ f ∈ S, (of' R M '' (f.support : set M))) = ⊤ :=
begin
  refine le_antisymm le_top _,
  rw [← hS, adjoin_le_iff],
  intros f hf,
  have hincl : of' R M '' f.support ⊆
    ⋃ (g : add_monoid_algebra R M) (H : g ∈ S), of' R M '' g.support,
  { intros s hs,
    exact set.mem_Union₂.2 ⟨f, ⟨hf, hs⟩⟩ },
  exact adjoin_mono hincl (mem_adjoin_support f)
end

/-- If a set `S` generates, as algebra, `add_monoid_algebra R M`, then the image of the union of
the supports of elements of `S` generates `add_monoid_algebra R M`. -/
lemma support_gen_of_gen' {S : set (add_monoid_algebra R M)} (hS : algebra.adjoin R S = ⊤) :
  algebra.adjoin R (of' R M '' (⋃ f ∈ S, (f.support : set M))) = ⊤ :=
begin
  suffices : of' R M '' (⋃ f ∈ S, (f.support : set M)) = ⋃ f ∈ S, (of' R M '' (f.support : set M)),
  { rw this,
    exact support_gen_of_gen hS },
  simp only [set.image_Union]
end

end semiring

section ring

variables [comm_ring R] [add_comm_monoid M]

/-- If `add_monoid_algebra R M` is of finite type, there there is a `G : finset M` such that its
image generates, as algera, `add_monoid_algebra R M`. -/
lemma exists_finset_adjoin_eq_top [h : finite_type R (add_monoid_algebra R M)] :
  ∃ G : finset M, algebra.adjoin R (of' R M '' G) = ⊤ :=
begin
  unfreezingI { obtain ⟨S, hS⟩ := h },
  letI : decidable_eq M := classical.dec_eq M,
  use finset.bUnion S (λ f, f.support),
  have : (finset.bUnion S (λ f, f.support) : set M) = ⋃ f ∈ S, (f.support : set M),
  { simp only [finset.set_bUnion_coe, finset.coe_bUnion] },
  rw [this],
  exact support_gen_of_gen' hS
end

/-- The image of an element `m : M` in `add_monoid_algebra R M` belongs the submodule generated by
`S : set M` if and only if `m ∈ S`. -/
lemma of'_mem_span [nontrivial R] {m : M} {S : set M} :
  of' R M m ∈ span R (of' R M '' S) ↔ m ∈ S :=
begin
  refine ⟨λ h, _, λ h, submodule.subset_span $ set.mem_image_of_mem (of R M) h⟩,
  rw [of', ← finsupp.supported_eq_span_single, finsupp.mem_supported,
    finsupp.support_single_ne_zero (@one_ne_zero R _ (by apply_instance))] at h,
  simpa using h
end

/--If the image of an element `m : M` in `add_monoid_algebra R M` belongs the submodule generated by
the closure of some `S : set M` then `m ∈ closure S`. -/
lemma mem_closure_of_mem_span_closure [nontrivial R] {m : M} {S : set M}
  (h : of' R M m ∈ span R (submonoid.closure (of' R M '' S) : set (add_monoid_algebra R M))) :
  m ∈ closure S :=
begin
  suffices : multiplicative.of_add m ∈ submonoid.closure (multiplicative.to_add ⁻¹' S),
  { simpa [← to_submonoid_closure] },
  rw [set.image_congr' (show ∀ x, of' R M x = of R M x, from λ x, of'_eq_of x),
    ← monoid_hom.map_mclosure] at h,
  simpa using of'_mem_span.1 h
end

end ring

end span

variables [add_comm_monoid M]

/-- If a set `S` generates an additive monoid `M`, then the image of `M` generates, as algebra,
`add_monoid_algebra R M`. -/
lemma mv_polynomial_aeval_of_surjective_of_closure [comm_semiring R] {S : set M}
  (hS : closure S = ⊤) : function.surjective (mv_polynomial.aeval
  (λ (s : S), of' R M ↑s) : mv_polynomial S R → add_monoid_algebra R M) :=
begin
  refine λ f, induction_on f (λ m, _) _ _,
  { have : m ∈ closure S := hS.symm ▸ mem_top _,
    refine closure_induction this (λ m hm, _) _ _,
    { exact ⟨mv_polynomial.X ⟨m, hm⟩, mv_polynomial.aeval_X _ _⟩ },
    { exact ⟨1, alg_hom.map_one _⟩ },
    { rintro m₁ m₂ ⟨P₁, hP₁⟩ ⟨P₂, hP₂⟩,
      exact ⟨P₁ * P₂, by rw [alg_hom.map_mul, hP₁, hP₂, of_apply, of_apply, of_apply,
        single_mul_single, one_mul]; refl⟩ } },
  { rintro f g ⟨P, rfl⟩ ⟨Q, rfl⟩,
    exact ⟨P + Q, alg_hom.map_add _ _ _⟩ },
  { rintro r f ⟨P, rfl⟩,
    exact ⟨r • P, alg_hom.map_smul _ _ _⟩ }
end

variables (R M)

/-- If an additive monoid `M` is finitely generated then `add_monoid_algebra R M` is of finite
type. -/
instance finite_type_of_fg [comm_ring R] [h : add_monoid.fg M] :
  finite_type R (add_monoid_algebra R M) :=
begin
  obtain ⟨S, hS⟩ := h.out,
  exact (finite_type.mv_polynomial R (S : set M)).of_surjective (mv_polynomial.aeval
    (λ (s : (S : set M)), of' R M ↑s)) (mv_polynomial_aeval_of_surjective_of_closure hS)
end

variables {R M}

/-- An additive monoid `M` is finitely generated if and only if `add_monoid_algebra R M` is of
finite type. -/
lemma finite_type_iff_fg [comm_ring R] [nontrivial R] :
  finite_type R (add_monoid_algebra R M) ↔ add_monoid.fg M :=
begin
  refine ⟨λ h, _, λ h, @add_monoid_algebra.finite_type_of_fg _ _ _ _ h⟩,
  obtain ⟨S, hS⟩ := @exists_finset_adjoin_eq_top R M _ _ h,
  refine add_monoid.fg_def.2 ⟨S, (eq_top_iff' _).2 (λ m, _)⟩,
  have hm : of' R M m ∈ (adjoin R (of' R M '' ↑S)).to_submodule,
  { simp only [hS, top_to_submodule, submodule.mem_top], },
  rw [adjoin_eq_span] at hm,
  exact mem_closure_of_mem_span_closure hm
end

/-- If `add_monoid_algebra R M` is of finite type then `M` is finitely generated. -/
lemma fg_of_finite_type [comm_ring R] [nontrivial R] [h : finite_type R (add_monoid_algebra R M)] :
  add_monoid.fg M :=
finite_type_iff_fg.1 h

/-- An additive group `G` is finitely generated if and only if `add_monoid_algebra R G` is of
finite type. -/
lemma finite_type_iff_group_fg {G : Type*} [add_comm_group G] [comm_ring R] [nontrivial R] :
  finite_type R (add_monoid_algebra R G) ↔ add_group.fg G :=
by simpa [add_group.fg_iff_add_monoid.fg] using finite_type_iff_fg

end add_monoid_algebra

namespace monoid_algebra

open algebra submonoid submodule

section span

section semiring

variables [comm_semiring R] [monoid M]

/-- An element of `monoid_algebra R M` is in the subalgebra generated by its support. -/
lemma mem_adjoint_support (f : monoid_algebra R M) : f ∈ adjoin R (of R M '' f.support) :=
begin
  suffices : span R (of R M '' f.support) ≤ (adjoin R (of R M '' f.support)).to_submodule,
  { exact this (mem_span_support f) },
  rw submodule.span_le,
  exact subset_adjoin
end

/-- If a set `S` generates, as algebra, `monoid_algebra R M`, then the set of supports of elements
of `S` generates `monoid_algebra R M`. -/
lemma support_gen_of_gen {S : set (monoid_algebra R M)} (hS : algebra.adjoin R S = ⊤) :
  algebra.adjoin R (⋃ f ∈ S, (of R M '' (f.support : set M))) = ⊤ :=
begin
  refine le_antisymm le_top _,
  rw [← hS, adjoin_le_iff],
  intros f hf,
  have hincl : (of R M) '' f.support ⊆
    ⋃ (g : monoid_algebra R M) (H : g ∈ S), of R M '' g.support,
  { intros s hs,
    exact set.mem_Union₂.2 ⟨f, ⟨hf, hs⟩⟩ },
  exact adjoin_mono hincl (mem_adjoint_support f)
end

/-- If a set `S` generates, as algebra, `monoid_algebra R M`, then the image of the union of the
supports of elements of `S` generates `monoid_algebra R M`. -/
lemma support_gen_of_gen' {S : set (monoid_algebra R M)} (hS : algebra.adjoin R S = ⊤) :
  algebra.adjoin R (of R M '' (⋃ f ∈ S, (f.support : set M))) = ⊤ :=
begin
  suffices : of R M '' (⋃ f ∈ S, (f.support : set M)) = ⋃ f ∈ S, (of R M '' (f.support : set M)),
  { rw this,
    exact support_gen_of_gen hS },
  simp only [set.image_Union]
end

end semiring

section ring

variables [comm_ring R] [comm_monoid M]

/-- If `monoid_algebra R M` is of finite type, there there is a `G : finset M` such that its image
generates, as algera, `monoid_algebra R M`. -/
lemma exists_finset_adjoin_eq_top [h :finite_type R (monoid_algebra R M)] :
  ∃ G : finset M, algebra.adjoin R (of R M '' G) = ⊤ :=
begin
  unfreezingI { obtain ⟨S, hS⟩ := h },
  letI : decidable_eq M := classical.dec_eq M,
  use finset.bUnion S (λ f, f.support),
  have : (finset.bUnion S (λ f, f.support) : set M) = ⋃ f ∈ S, (f.support : set M),
  { simp only [finset.set_bUnion_coe, finset.coe_bUnion] },
  rw [this],
  exact support_gen_of_gen' hS
end

/-- The image of an element `m : M` in `monoid_algebra R M` belongs the submodule generated by
`S : set M` if and only if `m ∈ S`. -/
lemma of_mem_span_of_iff [nontrivial R] {m : M} {S : set M} :
  of R M m ∈ span R (of R M '' S) ↔ m ∈ S :=
begin
  refine ⟨λ h, _, λ h, submodule.subset_span $ set.mem_image_of_mem (of R M) h⟩,
  rw [of, monoid_hom.coe_mk, ← finsupp.supported_eq_span_single, finsupp.mem_supported,
    finsupp.support_single_ne_zero (@one_ne_zero R _ (by apply_instance))] at h,
  simpa using h
end

/--If the image of an element `m : M` in `monoid_algebra R M` belongs the submodule generated by the
closure of some `S : set M` then `m ∈ closure S`. -/
lemma mem_closure_of_mem_span_closure [nontrivial R] {m : M} {S : set M}
  (h : of R M m ∈ span R (submonoid.closure (of R M '' S) : set (monoid_algebra R M))) :
  m ∈ closure S :=
begin
  rw ← monoid_hom.map_mclosure at h,
  simpa using of_mem_span_of_iff.1 h
end

end ring

end span

variables [comm_monoid M]

/-- If a set `S` generates a monoid `M`, then the image of `M` generates, as algebra,
`monoid_algebra R M`. -/
lemma mv_polynomial_aeval_of_surjective_of_closure [comm_semiring R] {S : set M}
  (hS : closure S = ⊤) : function.surjective (mv_polynomial.aeval
  (λ (s : S), of R M ↑s) : mv_polynomial S R → monoid_algebra R M) :=
begin
  refine λ f, induction_on f (λ m, _) _ _,
  { have : m ∈ closure S := hS.symm ▸ mem_top _,
    refine closure_induction this (λ m hm, _) _ _,
    { exact ⟨mv_polynomial.X ⟨m, hm⟩, mv_polynomial.aeval_X _ _⟩ },
    { exact ⟨1, alg_hom.map_one _⟩ },
    { rintro m₁ m₂ ⟨P₁, hP₁⟩ ⟨P₂, hP₂⟩,
      exact ⟨P₁ * P₂, by rw [alg_hom.map_mul, hP₁, hP₂, of_apply, of_apply, of_apply,
        single_mul_single, one_mul]⟩ } },
  { rintro f g ⟨P, rfl⟩ ⟨Q, rfl⟩,
    exact ⟨P + Q, alg_hom.map_add _ _ _⟩ },
  { rintro r f ⟨P, rfl⟩,
    exact ⟨r • P, alg_hom.map_smul _ _ _⟩ }
end

/-- If a monoid `M` is finitely generated then `monoid_algebra R M` is of finite type. -/
instance finite_type_of_fg [comm_ring R] [monoid.fg M] : finite_type R (monoid_algebra R M) :=
(add_monoid_algebra.finite_type_of_fg R (additive M)).equiv (to_additive_alg_equiv R M).symm

/-- A monoid `M` is finitely generated if and only if `monoid_algebra R M` is of finite type. -/
lemma finite_type_iff_fg [comm_ring R] [nontrivial R] :
  finite_type R (monoid_algebra R M) ↔ monoid.fg M :=
⟨λ h, monoid.fg_iff_add_fg.2 $ add_monoid_algebra.finite_type_iff_fg.1 $ h.equiv $
  to_additive_alg_equiv R M, λ h, @monoid_algebra.finite_type_of_fg _ _ _ _ h⟩

/-- If `monoid_algebra R M` is of finite type then `M` is finitely generated. -/
lemma fg_of_finite_type [comm_ring R] [nontrivial R] [h : finite_type R (monoid_algebra R M)] :
  monoid.fg M :=
finite_type_iff_fg.1 h

/-- A group `G` is finitely generated if and only if `add_monoid_algebra R G` is of finite type. -/
lemma finite_type_iff_group_fg {G : Type*} [comm_group G] [comm_ring R] [nontrivial R] :
  finite_type R (monoid_algebra R G) ↔ group.fg G :=
by simpa [group.fg_iff_monoid.fg] using finite_type_iff_fg

end monoid_algebra

end monoid_algebra

section vasconcelos
variables {R : Type*} [comm_ring R] {M : Type*} [add_comm_group M] [module R M] (f : M →ₗ[R] M)

noncomputable theory

/-- The structure of a module `M` over a ring `R` as a module over `polynomial R` when given a
choice of how `X` acts by choosing a linear map `f : M →ₗ[R] M` -/
@[simps]
def module_polynomial_of_endo : module R[X] M :=
module.comp_hom M (polynomial.aeval f).to_ring_hom

include f
lemma module_polynomial_of_endo.is_scalar_tower : @is_scalar_tower R R[X] M _
  (by { letI := module_polynomial_of_endo f, apply_instance }) _ :=
begin
  letI := module_polynomial_of_endo f,
  constructor,
  intros x y z,
  simp,
end

open polynomial module

/-- A theorem/proof by Vasconcelos, given a finite module `M` over a commutative ring, any
surjective endomorphism of `M` is also injective. Based on,
https://math.stackexchange.com/a/239419/31917,
https://www.ams.org/journals/tran/1969-138-00/S0002-9947-1969-0238839-5/.
This is similar to `is_noetherian.injective_of_surjective_endomorphism` but only applies in the
commutative case, but does not use a Noetherian hypothesis. -/
theorem module.finite.injective_of_surjective_endomorphism [hfg : finite R M]
  (f_surj : function.surjective f) : function.injective f :=
begin
  letI := module_polynomial_of_endo f,
  haveI : is_scalar_tower R R[X] M := module_polynomial_of_endo.is_scalar_tower f,
  have hfgpoly : finite R[X] M, from finite.of_restrict_scalars_finite R _ _,
  have X_mul : ∀ o, (X : R[X]) • o = f o,
  { intro,
    simp, },
  have : (⊤ : submodule R[X] M) ≤ ideal.span {X} • ⊤,
  { intros a ha,
    obtain ⟨y, rfl⟩ := f_surj a,
    rw [← X_mul y],
    exact submodule.smul_mem_smul (ideal.mem_span_singleton.mpr (dvd_refl _)) trivial, },
  obtain ⟨F, hFa, hFb⟩ := submodule.exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul _
    (⊤ : submodule R[X] M) (finite_def.mp hfgpoly) this,
  rw [← linear_map.ker_eq_bot, linear_map.ker_eq_bot'],
  intros m hm,
  rw ideal.mem_span_singleton' at hFa,
  obtain ⟨G, hG⟩ := hFa,
  suffices : (F - 1) • m = 0,
  { have Fmzero := hFb m (by simp),
    rwa [← sub_add_cancel F 1, add_smul, one_smul, this, zero_add] at Fmzero, },
  rw [← hG, mul_smul, X_mul m, hm, smul_zero],
end

end vasconcelos


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

! This file was ported from Lean 3 source module category_theory.sites.compatible_plus
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Sites.Whiskering
import Mathbin.CategoryTheory.Sites.Plus

/-!

In this file, we prove that the plus functor is compatible with functors which
preserve the correct limits and colimits.

See `category_theory/sites/compatible_sheafification` for the compatibility
of sheafification, which follows easily from the content in this file.

-/

namespace CategoryTheory.GrothendieckTopology

open CategoryTheory

open CategoryTheory.Limits

open Opposite

universe w₁ w₂ v u

variable {C : Type u} [Category.{v} C] (J : GrothendieckTopology C)

variable {D : Type w₁} [Category.{max v u} D]

variable {E : Type w₂} [Category.{max v u} E]

variable (F : D ⥤ E)

noncomputable section

variable [∀ (α β : Type max v u) (fst snd : β → α), HasLimitsOfShape (WalkingMulticospan fst snd) D]

variable [∀ (α β : Type max v u) (fst snd : β → α), HasLimitsOfShape (WalkingMulticospan fst snd) E]

variable [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D), PreservesLimit (W.index P).multicospan F]

variable (P : Cᵒᵖ ⥤ D)

/-- The diagram used to define `P⁺`, composed with `F`, is isomorphic
to the diagram used to define `P ⋙ F`. -/
def diagramCompIso (X : C) : J.diagram P X ⋙ F ≅ J.diagram (P ⋙ F) X :=
  NatIso.ofComponents
    (fun W => by
      refine' _ ≪≫ has_limit.iso_of_nat_iso (W.unop.multicospan_comp _ _).symm
      refine'
        (is_limit_of_preserves F (limit.is_limit _)).conePointUniqueUpToIso (limit.is_limit _))
    (by
      intro A B f
      ext
      dsimp
      simp only [functor.map_cone_π_app, multiequalizer.multifork_π_app_left, iso.symm_hom,
        multiequalizer.lift_ι, eq_to_hom_refl, category.comp_id,
        limit.cone_point_unique_up_to_iso_hom_comp,
        grothendieck_topology.cover.multicospan_comp_hom_inv_left, has_limit.iso_of_nat_iso_hom_π,
        category.assoc]
      simp only [← F.map_comp, multiequalizer.lift_ι])
#align category_theory.grothendieck_topology.diagram_comp_iso CategoryTheory.GrothendieckTopology.diagramCompIso

@[simp, reassoc.1]
theorem diagramCompIso_hom_ι (X : C) (W : (J.cover X)ᵒᵖ) (i : W.unop.arrow) :
    (J.diagramCompIso F P X).Hom.app W ≫ Multiequalizer.ι _ i = F.map (Multiequalizer.ι _ _) :=
  by
  delta diagram_comp_iso
  dsimp
  simp
#align category_theory.grothendieck_topology.diagram_comp_iso_hom_ι CategoryTheory.GrothendieckTopology.diagramCompIso_hom_ι

variable [∀ X : C, HasColimitsOfShape (J.cover X)ᵒᵖ D]

variable [∀ X : C, HasColimitsOfShape (J.cover X)ᵒᵖ E]

variable [∀ X : C, PreservesColimitsOfShape (J.cover X)ᵒᵖ F]

/-- The isomorphism between `P⁺ ⋙ F` and `(P ⋙ F)⁺`. -/
def plusCompIso : J.plusObj P ⋙ F ≅ J.plusObj (P ⋙ F) :=
  NatIso.ofComponents
    (fun X => by
      refine' _ ≪≫ has_colimit.iso_of_nat_iso (J.diagram_comp_iso F P X.unop)
      refine'
        (is_colimit_of_preserves F
              (colimit.is_colimit (J.diagram P (unop X)))).coconePointUniqueUpToIso
          (colimit.is_colimit _))
    (by
      intro X Y f
      apply (is_colimit_of_preserves F (colimit.is_colimit (J.diagram P X.unop))).hom_ext
      intro W
      dsimp [plus_obj, plus_map]
      simp only [functor.map_comp, category.assoc]
      slice_rhs 1 2 =>
        erw [(is_colimit_of_preserves F (colimit.is_colimit (J.diagram P X.unop))).fac]
      slice_lhs 1 3 =>
        simp only [← F.map_comp]
        dsimp [colim_map, is_colimit.map, colimit.pre]
        simp only [colimit.ι_desc_assoc, colimit.ι_desc]
        dsimp [cocones.precompose]
        rw [category.assoc, colimit.ι_desc]
        dsimp [cocone.whisker]
        rw [F.map_comp]
      simp only [category.assoc]
      slice_lhs 2 3 =>
        erw [(is_colimit_of_preserves F (colimit.is_colimit (J.diagram P Y.unop))).fac]
      dsimp
      simp only [has_colimit.iso_of_nat_iso_ι_hom_assoc, grothendieck_topology.diagram_pullback_app,
        colimit.ι_pre, has_colimit.iso_of_nat_iso_ι_hom, ι_colim_map_assoc]
      simp only [← category.assoc]
      congr 1
      ext
      dsimp
      simp only [category.assoc]
      erw [multiequalizer.lift_ι, diagram_comp_iso_hom_ι, diagram_comp_iso_hom_ι, ← F.map_comp,
        multiequalizer.lift_ι])
#align category_theory.grothendieck_topology.plus_comp_iso CategoryTheory.GrothendieckTopology.plusCompIso

@[simp, reassoc.1]
theorem ι_plusCompIso_hom (X) (W) :
    F.map (colimit.ι _ W) ≫ (J.plusCompIso F P).Hom.app X =
      (J.diagramCompIso F P X.unop).Hom.app W ≫ colimit.ι _ W :=
  by
  delta diagram_comp_iso plus_comp_iso
  simp only [is_colimit.desc_cocone_morphism_hom, is_colimit.unique_up_to_iso_hom,
    cocones.forget_map, iso.trans_hom, nat_iso.of_components_hom_app, functor.map_iso_hom, ←
    category.assoc]
  erw [(is_colimit_of_preserves F (colimit.is_colimit (J.diagram P (unop X)))).fac]
  simp only [category.assoc, has_limit.iso_of_nat_iso_hom_π, iso.symm_hom,
    cover.multicospan_comp_hom_inv_left, eq_to_hom_refl, category.comp_id,
    limit.cone_point_unique_up_to_iso_hom_comp, functor.map_cone_π_app,
    multiequalizer.multifork_π_app_left, multiequalizer.lift_ι, functor.map_comp, eq_self_iff_true,
    category.assoc, iso.trans_hom, iso.cancel_iso_hom_left, nat_iso.of_components_hom_app,
    colimit.cocone_ι, category.assoc, has_colimit.iso_of_nat_iso_ι_hom]
#align category_theory.grothendieck_topology.ι_plus_comp_iso_hom CategoryTheory.GrothendieckTopology.ι_plusCompIso_hom

@[simp, reassoc.1]
theorem plusCompIso_whiskerLeft {F G : D ⥤ E} (η : F ⟶ G) (P : Cᵒᵖ ⥤ D)
    [∀ X : C, PreservesColimitsOfShape (J.cover X)ᵒᵖ F]
    [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D), PreservesLimit (W.index P).multicospan F]
    [∀ X : C, PreservesColimitsOfShape (J.cover X)ᵒᵖ G]
    [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D), PreservesLimit (W.index P).multicospan G] :
    whiskerLeft _ η ≫ (J.plusCompIso G P).Hom =
      (J.plusCompIso F P).Hom ≫ J.plusMap (whiskerLeft _ η) :=
  by
  ext X
  apply (is_colimit_of_preserves F (colimit.is_colimit (J.diagram P X.unop))).hom_ext
  intro W
  dsimp [plus_obj, plus_map]
  simp only [ι_plus_comp_iso_hom, ι_colim_map, whisker_left_app, ι_plus_comp_iso_hom_assoc,
    nat_trans.naturality_assoc, grothendieck_topology.diagram_nat_trans_app]
  simp only [← category.assoc]
  congr 1
  ext
  dsimp
  simpa
#align category_theory.grothendieck_topology.plus_comp_iso_whisker_left CategoryTheory.GrothendieckTopology.plusCompIso_whiskerLeft

/-- The isomorphism between `P⁺ ⋙ F` and `(P ⋙ F)⁺`, functorially in `F`. -/
@[simps hom_app inv_app]
def plusFunctorWhiskerLeftIso (P : Cᵒᵖ ⥤ D)
    [∀ (F : D ⥤ E) (X : C), PreservesColimitsOfShape (J.cover X)ᵒᵖ F]
    [∀ (F : D ⥤ E) (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D),
        PreservesLimit (W.index P).multicospan F] :
    (whiskeringLeft _ _ E).obj (J.plusObj P) ≅ (whiskeringLeft _ _ _).obj P ⋙ J.plusFunctor E :=
  NatIso.ofComponents (fun X => plusCompIso _ _ _) fun F G η => plusCompIso_whiskerLeft _ _ _
#align category_theory.grothendieck_topology.plus_functor_whisker_left_iso CategoryTheory.GrothendieckTopology.plusFunctorWhiskerLeftIso

@[simp, reassoc.1]
theorem plusCompIso_whiskerRight {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) :
    whiskerRight (J.plusMap η) F ≫ (J.plusCompIso F Q).Hom =
      (J.plusCompIso F P).Hom ≫ J.plusMap (whiskerRight η F) :=
  by
  ext X
  apply (is_colimit_of_preserves F (colimit.is_colimit (J.diagram P X.unop))).hom_ext
  intro W
  dsimp [plus_obj, plus_map]
  simp only [ι_colim_map, whisker_right_app, ι_plus_comp_iso_hom_assoc,
    grothendieck_topology.diagram_nat_trans_app]
  simp only [← category.assoc, ← F.map_comp]
  dsimp [colim_map, is_colimit.map]
  simp only [colimit.ι_desc]
  dsimp [cocones.precompose]
  simp only [functor.map_comp, category.assoc, ι_plus_comp_iso_hom]
  simp only [← category.assoc]
  congr 1
  ext
  dsimp
  simp only [diagram_comp_iso_hom_ι_assoc, multiequalizer.lift_ι, diagram_comp_iso_hom_ι,
    category.assoc]
  simp only [← F.map_comp, multiequalizer.lift_ι]
#align category_theory.grothendieck_topology.plus_comp_iso_whisker_right CategoryTheory.GrothendieckTopology.plusCompIso_whiskerRight

/-- The isomorphism between `P⁺ ⋙ F` and `(P ⋙ F)⁺`, functorially in `P`. -/
@[simps hom_app inv_app]
def plusFunctorWhiskerRightIso :
    J.plusFunctor D ⋙ (whiskeringRight _ _ _).obj F ≅
      (whiskeringRight _ _ _).obj F ⋙ J.plusFunctor E :=
  NatIso.ofComponents (fun P => J.plusCompIso _ _) fun P Q η => plusCompIso_whiskerRight _ _ _
#align category_theory.grothendieck_topology.plus_functor_whisker_right_iso CategoryTheory.GrothendieckTopology.plusFunctorWhiskerRightIso

@[simp, reassoc.1]
theorem whiskerRight_toPlus_comp_plusCompIso_hom :
    whiskerRight (J.toPlus _) _ ≫ (J.plusCompIso F P).Hom = J.toPlus _ :=
  by
  ext
  dsimp [to_plus]
  simp only [ι_plus_comp_iso_hom, functor.map_comp, category.assoc]
  simp only [← category.assoc]
  congr 1
  ext
  delta cover.to_multiequalizer
  simp only [diagram_comp_iso_hom_ι, category.assoc, ← F.map_comp]
  erw [multiequalizer.lift_ι, multiequalizer.lift_ι]
  rfl
#align category_theory.grothendieck_topology.whisker_right_to_plus_comp_plus_comp_iso_hom CategoryTheory.GrothendieckTopology.whiskerRight_toPlus_comp_plusCompIso_hom

@[simp]
theorem toPlus_comp_plusCompIso_inv :
    J.toPlus _ ≫ (J.plusCompIso F P).inv = whiskerRight (J.toPlus _) _ := by simp [iso.comp_inv_eq]
#align category_theory.grothendieck_topology.to_plus_comp_plus_comp_iso_inv CategoryTheory.GrothendieckTopology.toPlus_comp_plusCompIso_inv

theorem plusCompIso_inv_eq_plusLift (hP : Presheaf.IsSheaf J (J.plusObj P ⋙ F)) :
    (J.plusCompIso F P).inv = J.plusLift (whiskerRight (J.toPlus _) _) hP :=
  by
  apply J.plus_lift_unique
  simp [iso.comp_inv_eq]
#align category_theory.grothendieck_topology.plus_comp_iso_inv_eq_plus_lift CategoryTheory.GrothendieckTopology.plusCompIso_inv_eq_plusLift

end CategoryTheory.GrothendieckTopology


import QL.FOL.semantics order.filter.ultrafilter data.finset.basic
open encodable

universes u v

namespace fol

open_locale logic_symbol
open logic.semantics

variables {L : language.{u}} {μ : Type v} {n : ℕ} {I : Type u} [inhabited I] (F : ultrafilter I)
  {𝔄 : I → nonempty_Structure L}

def uequiv : (Π i, 𝔄 i) → (Π i, 𝔄 i) → Prop :=
λ u₁ u₂, {i | u₁ i = u₂ i} ∈ F

notation u` ~[`:80 F`] `v:80 := uequiv F u v

@[simp] lemma uequiv_refl (u : Π i, 𝔄 i) : u ~[F] u :=
by { simp[uequiv], exact F.univ_sets }

lemma uequiv_symm {u₁ u₂ : Π i, 𝔄 i} : u₁ ~[F] u₂ → u₂ ~[F] u₁ :=
by { simp[uequiv], have : {i | u₁ i = u₂ i} = {i | u₂ i = u₁ i}, { ext, simp, exact eq_comm }, simp[this] }

lemma uequiv_trans {u₁ u₂ u₃ : Π i, 𝔄 i} : u₁ ~[F] u₂ → u₂ ~[F] u₃ → u₁ ~[F] u₃ :=
by { simp[uequiv], intros h₁ h₂,
     have : {i | u₁ i = u₂ i} ∩ {i | u₂ i = u₃ i} ⊆ {i | u₁ i = u₃ i},
     { intros i hi, simp* at* },
     exact F.sets_of_superset (F.inter_sets h₁ h₂) this }

theorem uequiv_equivalence : equivalence (@uequiv L I _ F 𝔄) :=
⟨uequiv_refl F, λ _ _ , uequiv_symm F, λ _ _ _, uequiv_trans F⟩

@[reducible, simp, instance]
def ult (𝔄 : I → nonempty_Structure L) (F : ultrafilter I) : setoid (Π i, 𝔄 i) := ⟨@uequiv L I _ F 𝔄, uequiv_equivalence F⟩

def Ult (𝔄 : I → nonempty_Structure L) (F : ultrafilter I) : Type* :=
quotient (ult 𝔄 F: setoid (Π i, 𝔄 i))

def to_quotient {𝔄 : I → nonempty_Structure L} {F : ultrafilter I} (u : Π i, 𝔄 i) : Ult 𝔄 F := quotient.mk' u

notation `⟦`u`⟧*` :max := to_quotient u

instance : inhabited (Ult 𝔄 F) := ⟨⟦λ i, default⟧*⟩

namespace Ult
open logic.semantics

@[elab_as_eliminator]
protected lemma ind_on {C : Ult 𝔄 F → Prop} (u : Ult 𝔄 F)
  (h : ∀ u : Π i, 𝔄 i, C ⟦u⟧*) : C u :=
quotient.induction_on' u h

@[elab_as_eliminator, reducible]
protected def lift_on {φ} (d : Ult 𝔄 F) (f : (Π i, 𝔄 i) → φ)
  (h : ∀ (v u : Π i, 𝔄 i), v ~[F] u → f v = f u) : φ :=
quotient.lift_on' d f h

@[simp]
protected lemma lift_on_eq {φ} (u₀ : Π i, 𝔄 i) (f : (Π i, 𝔄 i) → φ)
  (h : ∀ v u, v ~[F] u → f v = f u) : fol.Ult.lift_on F ⟦u₀⟧* f h = f u₀ := rfl

@[elab_as_eliminator, reducible, simp]
protected def lift_on₂ {φ} (u₁ u₂ : Ult 𝔄 F) (f : (Π i, 𝔄 i) → (Π i, 𝔄 i) → φ)
  (h : ∀ u₁ u₂ v₁ v₂, u₁ ~[F] v₁ → u₂ ~[F] v₂ → f u₁ u₂ = f v₁ v₂) : φ :=
quotient.lift_on₂' u₁ u₂ f h

@[simp]
protected lemma lift_on₂_eq {φ} (u₁ u₂ : Π i, 𝔄 i) (f : (Π i, 𝔄 i) → (Π i, 𝔄 i) → φ)
  (h : ∀ t₁ t₂ u₁ u₂, (t₁ ~[F] u₁) → (t₂ ~[F] u₂) → f t₁ t₂ = f u₁ u₂) :
  fol.Ult.lift_on₂ F ⟦u₁⟧* ⟦u₂⟧* f h = f u₁ u₂ := rfl

@[elab_as_eliminator, reducible]
protected def lift_on_finitary {φ} {n : ℕ} (v : finitary (Ult 𝔄 F) n) (f : finitary (Π i, 𝔄 i) n → φ)
  (h : ∀ v₁ v₂ : finitary (Π i, 𝔄 i) n, (∀ n, (v₁ n) ~[F] (v₂ n)) → f v₁ = f v₂) : φ :=
quotient.lift_on_finitary v f h

@[simp]
protected lemma lift_on_finitary_eq {φ} {n} (v : finitary (Π i, 𝔄 i) n) (f : finitary (Π i, 𝔄 i) n → φ)
  (h : ∀ v₁ v₂ : finitary (Π i, 𝔄 i) n, (∀ n, (v₁ n) ~[F] (v₂ n)) → f v₁ = f v₂) :
  fol.Ult.lift_on_finitary F (λ x, ⟦v x⟧*) f h = f v :=
quotient.lift_on_finitary_eq v f h

@[simp] lemma of_eq_of {u₁ u₂ : Π i, 𝔄 i} : (⟦u₁⟧* : Ult 𝔄 F) = ⟦u₂⟧* ↔ u₁ ~[F] u₂ :=
by simp[to_quotient, quotient.eq']

lemma equivs_mem {n} {v₁ v₂ : finitary (Π i, 𝔄 i) n} (h : ∀ (x : fin n), {i : I | v₁ x i = v₂ x i} ∈ F) :
  {i | (λ x, v₁ x i) = (λ x, v₂ x i)} ∈ F :=
begin
  induction n with n IH,
  { have : {i : I | (λ x, v₁ x i) = (λ x, v₂ x i)} = set.univ,
    { ext i, simp }, rw this, exact F.univ_sets },
  { have ss : {i | v₁ 0 i = v₂ 0 i} ∩ {i | (λ x, v₁.tail x i) = (λ x, v₂.tail x i)} ⊆ {i : I | (λ x, v₁ x i) = (λ x, v₂ x i)},
    { intros i hi, simp[finitary.tail] at*,
      funext x, refine fin.cases _ _ x,
      { exact hi.1 },
      { intros j, have := congr_fun hi.2 j, simp at this, exact this } },
    have : {i | v₁ 0 i = v₂ 0 i} ∩ {i | (λ x, v₁.tail x i) = (λ x, v₂.tail x i)} ∈ F,
      from (F.inter_sets (h _) (@IH v₁.tail v₂.tail (λ x, h _))),
    refine F.sets_of_superset this ss }
end

lemma fn_equiv {n} {v₁ v₂ : finitary (Π i, 𝔄 i) n} (h : ∀ x, v₁ x ~[F] v₂ x) (f : L.fn n) :
  (λ i, (𝔄 i).fn f (λ x, v₁ x i)) ~[F] (λ i, (𝔄 i).fn f (λ x, v₂ x i)) :=
begin
  simp[uequiv] at*,
  have : {i | (λ x, v₁ x i) = (λ x, v₂ x i)} ⊆ {i | (𝔄 i).fn f (λ x, v₁ x i) = (𝔄 i).fn f (λ x, v₂ x i)},
  { intros i hi, simp* at* },
  exact F.sets_of_superset (equivs_mem F h) this
end

lemma pr_equiv : ∀ {n} {v₁ v₂ : finitary (Π i, 𝔄 i) n} (h : ∀ x, v₁ x ~[F] v₂ x) (p : L.pr n),
  {i | (𝔄 i).pr p (λ x, v₁ x i)} ∈ F ↔ {i | (𝔄 i).pr p (λ x, v₂ x i)} ∈ F :=
begin
  suffices : ∀ {n} {v₁ v₂ : finitary (Π i, 𝔄 i) n} (h : ∀ x, v₁ x ~[F] v₂ x) (p : L.pr n),
  {i | (𝔄 i).pr p (λ x, v₁ x i)} ∈ F → {i | (𝔄 i).pr p (λ x, v₂ x i)} ∈ F,
  { intros n v₁ v₂ eqn p, refine ⟨this eqn p, this (λ x, uequiv_symm _ (eqn x)) p⟩ },
  intros n v₁ v₂ eqn p h,
  have : {i | (𝔄 i).pr p (λ x, v₁ x i)} ∩ {i | (λ x, v₁ x i) = (λ x, v₂ x i)} ⊆ {i | (𝔄 i).pr p (λ x, v₂ x i)},
  { intros i hi, simp* at*, simp[←hi.2], exact hi.1 },
  refine F.sets_of_superset (F.inter_sets h (equivs_mem _ eqn)) this
end

def product_fn (k) (f : L.fn k) : finitary (Ult 𝔄 F) k → Ult 𝔄 F :=
λ v, fol.Ult.lift_on_finitary F v (λ v, (⟦λ i, (𝔄 i).fn f (λ x, v x i)⟧* : Ult 𝔄 F)) $ λ u₁ u₂ eqn,
by { simp, exact fn_equiv F eqn f }

def product_pr (n) (p : L.pr n) : finitary (Ult 𝔄 F) n → Prop :=
λ v, fol.Ult.lift_on_finitary F v (λ v, {i | (𝔄 i).pr p (λ x, v x i)} ∈ F) $ λ u₁ u₂ eqn,
by { simp, exact pr_equiv F eqn p }

@[reducible] def product (𝔄 : I → nonempty_Structure L) (F : ultrafilter I) : nonempty_Structure L :=
{ dom := Ult 𝔄 F,
  fn := product_fn F,
  pr := product_pr F,
  dom_inhabited := Ult.inhabited F }

variables {F}
open subformula

lemma Structure_fn_eq {n} (f : L.fn n) : (product 𝔄 F).fn f = product_fn F _ f := rfl

lemma Structure_pr_eq {n} (r : L.pr n) : (product 𝔄 F).pr r = product_pr F _ r := rfl

variables (Φ : Π i, μ → 𝔄 i) (e : Π i, fin n → 𝔄 i)

lemma val_subterm (t : subterm L μ n) :
  subterm.val (product 𝔄 F : Structure L) (λ x, ⟦λ i, Φ i x⟧*) (λ x, ⟦λ i, e i x⟧*) t = ⟦λ i, subterm.val (𝔄 i) (Φ i) (e i) t⟧* :=
by induction t; simp[Structure_fn_eq, product_fn, *]

private lemma concat_to_quo (u : Π i, 𝔄 i) :
  ((⟦u⟧* : Ult 𝔄 F) *> λ x, ⟦λ i, e i x⟧*) = λ x, ⟦λ i, (u i *> e i) x⟧* :=
by ext x; refine fin.cases _ _ x; simp

theorem subval_subformula : ∀ {n} (e : Π i, fin n → 𝔄 i) (p : subformula L μ n),
  subval (product 𝔄 F : Structure L) (λ x, ⟦λ i, Φ i x⟧*) (λ x, ⟦λ i, e i x⟧*) p ↔ {i | subval (𝔄 i : Structure L) (Φ i) (e i) p} ∈ F
| n e verum          := by simp[top_eq]; exact F.univ_sets
| n e (relation r v) := by simp[Structure_pr_eq, product_pr, val_subterm, (∘)]
| n e (imply p q)    :=
    by simp[imply_eq, subval_subformula _ p, subval_subformula _ q, decidable.imp_iff_not_or,
      ←ultrafilter.compl_mem_iff_not_mem]; exact ultrafilter.union_mem_iff.symm
| n e (neg p)        := by simp[neg_eq, subval_subformula _ p]; exact ultrafilter.compl_mem_iff_not_mem.symm
| n e (fal p)        :=
    begin
      simp[fal_eq],
      let e' := λ (u : Π i, 𝔄 i), (λ i, u i *> e i),
      calc (∀ u : product 𝔄 F, subval (product 𝔄 F : Structure L) (λ x, ⟦λ i, Φ i x⟧*) (u *> λ x, ⟦λ i, e i x⟧*) p)
          ↔ (∀ u : Π i, 𝔄 i, subval (product 𝔄 F : Structure L) (λ x, ⟦λ i, Φ i x⟧*) (λ x, ⟦λ i, e' u i x⟧*) p)
      : by { split,
             { intros h u, simpa[e', concat_to_quo] using h ⟦u⟧* },
             { intros h u, induction u using fol.Ult.ind_on, simpa[concat_to_quo] using h u } }
      ... ↔ ∀ u : Π i, 𝔄 i, {i | subval (𝔄 i : Structure L) (Φ i) (e' u i) p} ∈ F
      : by { exact forall_congr (λ u, subval_subformula (e' u) p) }
      ... ↔ {i : I | ∀ (x : 𝔄 i), subval (𝔄 i : Structure L) (Φ i) (x *> e i) p} ∈ F
      : by { simp[e'], split,
            { intros h,
              let u : Π i, 𝔄 i := λ i, classical.epsilon (λ u, ¬subval ↑(𝔄 i) (Φ i) (u *> e i) p),
              refine F.sets_of_superset (h u) _,
              { intros i, simp, intros hi, by_contradiction A, simp at A,
                have : ¬subval ↑(𝔄 i) (Φ i) (u i *> e i) p,
                from classical.epsilon_spec_aux _ _ A,
                contradiction } },
            { intros h u, refine filter.mem_of_superset h (by intros i hi; exact hi (u i)) } }
    end

-- Łoś's theorem
theorem fundamental_param (p : formula L μ) (Φ : ∀ i, μ → 𝔄 i) :
  val (product 𝔄 F : Structure L) (λ x, ⟦λ i, Φ i x⟧*) p ↔ {i | val (𝔄 i : Structure L) (Φ i) p} ∈ F :=
by have := @subval_subformula L _ _ _ F _ Φ _ (λ i, fin.nil) p; exact cast (by congr) this

theorem fundamental {σ : sentence L} :
  product 𝔄 F ⊧ σ ↔ {i | 𝔄 i ⊧ σ} ∈ F :=
by have := @fundamental_param L _ _ _ F 𝔄 σ (λ i, fin.nil); simp[nonempty_Structure.sentence_models_def];
   exact cast (by congr) this

end Ult
end fol

namespace fol
variables {L : language.{u}}

def finTheory (T : Theory L) := {s : finset (sentence L) // ↑s ⊆ T}

variables {T : Theory L}

def finTheory.empty {T : Theory L} : finTheory T := ⟨∅, by simp⟩
instance : inhabited (finTheory T) := ⟨⟨∅, by simp⟩⟩

noncomputable def finTheory.insert (P : finTheory T) {σ : sentence L} (h : σ ∈ T) : finTheory T :=
⟨insert σ P.val, λ x hx,  by { simp at hx, cases hx, simp[hx, h], refine P.property hx }⟩

@[simp] lemma finTheory.insert_val (P : finTheory T) {σ : sentence L} (h : σ ∈ T) :
  (P.insert h).val = insert σ P.val := rfl

instance : has_coe (finTheory T) (Theory L) := ⟨λ s, {p | p ∈ s.val}⟩

namespace compactness
open nonempty_Structure

variables (𝔄 : finTheory T → nonempty_Structure L)

def formdomain (p : sentence L) : set (finTheory T) := {i | 𝔄 i ⊧ p}

def F : set (set (finTheory T)) := {x | ∃ p, T p ∧ x = formdomain 𝔄 p}

private lemma finite_intersection_lmm (nonempty : ∃ p, T p) (H : ∀ (i : finTheory T) p, p ∈ i.val → 𝔄 i ⊧ p) :
  ∀ S : finset (set (finTheory T)), (↑S : set (set (finTheory T))) ⊆ F 𝔄 →
  ∃ P : finTheory T,
  (∀ p, p ∈ P.val → formdomain 𝔄 p ∈ S) ∧ (∀ S', S' ∈ S → ∃ p, p ∈ P.val ∧ S' = formdomain 𝔄 p) :=
begin
  intros S, induction S using finset.induction with i S i_fresh IH,
  { intros _, simp[set.nonempty], rcases nonempty with ⟨p₀, hyp_p₀⟩,
    refine ⟨⟨∅, by simp⟩, _⟩, unfold_coes, simp },
  { intros h, simp at*,
    have lmm₁ : ↑S ⊆ F 𝔄, from set.subset.trans (set.subset_insert _ _) h,
    have : ∃ (P : finTheory T),
      (∀ p, p ∈ ↑P → formdomain 𝔄 p ∈ S) ∧ (∀ S', S' ∈ S → ∃ p, p ∈ ↑P ∧ S' = formdomain 𝔄 p),
    from IH lmm₁, rcases this with ⟨P, IH₁, IH₂⟩,
    have : ∃ p, T p ∧ i = formdomain 𝔄 p, from h (set.mem_insert i ↑S),
    rcases this with ⟨p, hyp_p, rfl⟩,
    refine ⟨P.insert hyp_p, _, _, _⟩; unfold_coes; simp,
    { refine λ q hyp_q, or.inr (IH₁ _ hyp_q) },
    { refine ⟨p, or.inl rfl, rfl⟩ },
    { intros S' hyp_S',
      have : ∃ p, p ∈ ↑P ∧ S' = formdomain 𝔄 p, from IH₂ _ hyp_S', rcases this with ⟨p, hyp, rfl⟩,
      refine ⟨p, or.inr hyp, rfl⟩ } }
end

theorem finite_intersection (h : ∃ p, T p) (H : ∀ (i : finTheory T) p, p ∈ i.val → 𝔄 i ⊧ p) :
  ∀ S : finset (set (finTheory T)),
  (↑S : set (set (finTheory T))) ⊆ F 𝔄 → (⋂₀ (↑S : set (set (finTheory T)))).nonempty :=
begin
  intros S hS, have := finite_intersection_lmm _ h H S hS, rcases this with ⟨P, hyp⟩,
  refine ⟨P, λ S' hS', _⟩,
  have := hyp.2 S' hS', rcases this with ⟨p, hyp_p, rfl⟩, simp[formdomain] at*,
  refine H _ _ hyp_p
end

theorem ultrafilter_exists (h : ∃ p, p ∈ T) (H : ∀ (i : finTheory T) p, p ∈ i.val → 𝔄 i ⊧ p) :
  ∃ U : ultrafilter (finTheory T), F 𝔄 ⊆ U.to_filter.sets :=
ultrafilter.exists_ultrafilter_of_finite_inter_nonempty _ (finite_intersection _ h H)

theorem compact (T : Theory L) :
  Satisfiable T ↔ ∀ S : finset (sentence L), ↑S ⊆ T → Satisfiable (S : Theory L) :=
  ⟨by { intros H S hyp_S, rcases H with ⟨𝔄, hyp⟩,
        refine ⟨𝔄, λ p h, hyp (hyp_S h)⟩ },
   by { suffices : (∀ S : finTheory T, Satisfiable (↑S : Theory L)) → Satisfiable T,
        { intros h, refine this (λ S, _),
          rcases h S.val S.property with ⟨𝔄, hyp_𝔄⟩, refine ⟨𝔄, hyp_𝔄⟩ },
    intros H, by_cases C : T = ∅,
        { rcases C with rfl, refine ⟨default, by intros p; simp⟩ },
        { have ex : ∃ p, p ∈ T, { by_contra, simp at*, refine C _, { ext x, simp, refine h _ } },
          have : ∃ (𝔄 : finTheory T → nonempty_Structure L), ∀ (i : finTheory T) p, p ∈ i.val → 𝔄 i ⊧ p,
          from classical.skolem.mp H, rcases this with ⟨𝔄, hyp_𝔄⟩,
          have := @ultrafilter_exists _ _ 𝔄 ex hyp_𝔄, rcases this with ⟨U, hyp_U⟩,
          refine ⟨Ult.product 𝔄 U, _⟩, intros p hyp_p, rw Ult.fundamental,
          have : {i | 𝔄 i ⊧ p} ∈ F 𝔄, { refine ⟨p, hyp_p, rfl⟩ },
          exact hyp_U this } }⟩

end compactness

end fol


import algebraic_topology.simplicial_set
import category_theory.limits.kan_extension
import for_mathlib.split_simplicial_object
import for_mathlib.category_theory.limits.concrete
import data.fintype.basic

noncomputable theory

universes u

open category_theory
open category_theory.limits
open opposite
open_locale simplicial

namespace simplex_category

section
variables {X Y : simplex_category} (θ : X ⟶ Y)
instance : strong_epi (factor_thru_image θ) :=
strong_epi_factor_thru_image_of_strong_epi_mono_factorisation
  (has_strong_epi_mono_factorisations.has_fac θ).some

lemma is_iso_of_epi_and_card [hθ : epi θ] (h : X.len = Y.len) : is_iso θ :=
begin
  apply is_iso_of_bijective,
  split,
  { by_contra h',
    rw epi_iff_surjective at hθ,
    simpa only [fintype.card_fin, add_lt_add_iff_right, h, lt_self_iff_false]
      using fintype.card_lt_of_surjective_not_injective _ hθ h', },
  { change function.surjective θ.to_order_hom,
    rw ← epi_iff_surjective,
    apply_instance, },
end

end

--protected def rec {F : Π (X : simplex_category), Sort u} (h : ∀ (n : ℕ), F [n]) :
--  Π X, F X := λ n, h n.len

end simplex_category

namespace sSet

lemma map_comp' (X : sSet) {Δ₀ Δ₁ Δ₂ : simplex_categoryᵒᵖ} (θ : Δ₀ ⟶ Δ₁) (θ' : Δ₁ ⟶ Δ₂)
  (x : X.obj Δ₀) : X.map (θ ≫ θ') x = X.map θ' (X.map θ x) :=
congr_fun (X.map_comp θ θ') x

namespace truncated

def i (n : ℕ) : truncated n ⥤ sSet.{u} :=
Lan simplex_category.truncated.inclusion.op

def adjunction (n : ℕ) : i n ⊣ sk n :=
category_theory.Lan.adjunction _ simplex_category.truncated.inclusion.op

instance adjunction.unit_is_iso (n : ℕ) : is_iso (adjunction n).unit :=
Lan.coreflective _ _

end truncated

def sk' (n : ℕ) : sSet ⥤ sSet := sk n ⋙ truncated.i n

def ι_sk' (n : ℕ) : sk' n ⟶ 𝟭 sSet := (truncated.adjunction n).counit

instance sk_ι_sk'_is_iso (n : ℕ) : is_iso (whisker_right (ι_sk' n) (sk.{u} n)) :=
begin
  let f := (whisker_left (sk.{u} n) (truncated.adjunction n).unit),
  let g := whisker_right (truncated.adjunction n).counit (sk.{u} n),
  haveI : is_iso (f ≫ g),
  { rw (truncated.adjunction n).right_triangle,
    apply_instance, },
  change is_iso g,
  exact is_iso.of_is_iso_comp_left f g,
end

lemma ι_sk'_bij (X : sSet) (n : ℕ) (Δ : simplex_categoryᵒᵖ) (h : Δ.unop.len ≤ n) :
  is_iso (((ι_sk' n).app X).app Δ) :=
begin
  induction Δ using opposite.rec,
  have h' : ∃ (Δ' : simplex_category.truncated n), Δ = Δ'.1 := ⟨⟨Δ, h⟩, rfl⟩,
  cases h' with Δ' hΔ',
  subst hΔ',
  let e := as_iso (whisker_right (ι_sk' n) (sk n)),
  exact is_iso.of_iso ((e.app X).app (opposite.op Δ')),
end

def simplex_is_degenerate {X : sSet} {Δ : simplex_categoryᵒᵖ} (x : X.obj Δ) : Prop :=
∃ (Δ' : simplex_categoryᵒᵖ) (θ : Δ' ⟶ Δ) (hθ₁ : epi θ.unop) (hθ₂ : ¬mono θ.unop)
  (y : X.obj Δ'), x = X.map θ y

@[simp]
def nondegenerate_simplices (X : sSet) (Δ : simplex_categoryᵒᵖ) : set (X.obj Δ) :=
compl simplex_is_degenerate

lemma is_iso_of_nondegenerate_simplices {X : sSet} {Δ Δ' : simplex_categoryᵒᵖ}
  (x : X.nondegenerate_simplices Δ) (θ : Δ' ⟶ Δ) (hθ : epi θ.unop) (y : X.obj Δ')
  (hy : x.1 = X.map θ y) : is_iso θ :=
begin
  suffices : is_iso θ.unop,
  { haveI := this,
    change is_iso θ.unop.op,
    apply_instance, },
  apply simplex_category.is_iso_of_bijective,
  split,
  { change function.injective θ.unop.to_order_hom,
    rw ← simplex_category.mono_iff_injective,
    by_contra,
    exact x.2 ⟨Δ', θ, hθ, h, y, hy⟩, },
  { change function.surjective θ.unop.to_order_hom,
    rw ← simplex_category.epi_iff_surjective,
    exact hθ, },
end

@[simp]
def ι_nondegenerate_simplices (X : sSet.{u}) (Δ : simplex_categoryᵒᵖ) :
  (X.nondegenerate_simplices Δ : Type u) ⟶ X.obj Δ := subtype.val

lemma zero_simplices_are_nondegenerate (X : sSet) : X.nondegenerate_simplices (op [0]) = ⊤ :=
begin
  ext,
  split,
  { intro h,
    simp only [set.top_eq_univ], },
  { intros h₀ h,
    rcases h with ⟨Δ', θ, hθ₁, hθ₂, y, hy⟩,
    apply hθ₂,
    rw simplex_category.mono_iff_injective,
    intros a₁ a₂ h,
    rw [fin.eq_zero a₁, fin.eq_zero a₂], },
end

lemma is_epi_image_of_nondegenerate_simplex (X : sSet) {Δ : simplex_categoryᵒᵖ} (x : X.obj Δ) :
  ∃ (Δ' : simplex_categoryᵒᵖ) (θ : Δ' ⟶ Δ) (hθ : epi θ.unop) (y : X.obj Δ')
    (hy : y ∈ X.nondegenerate_simplices Δ'), x = X.map θ y :=
begin
  induction Δ using opposite.rec,
  induction Δ with n,
  induction n using nat.strong_rec' with n hn,
  cases n,
  { refine ⟨op [0], 𝟙 _, infer_instance, x, _, by simp only [functor_to_types.map_id_apply]⟩,
    rw zero_simplices_are_nondegenerate,
    simp only [set.top_eq_univ], },
 { by_cases x ∈ X.nondegenerate_simplices (op [n.succ]),
    { exact ⟨_, 𝟙 _, infer_instance, x, h, by simp only [functor_to_types.map_id_apply]⟩, },
    { dsimp [nondegenerate_simplices] at h,
      simp only [set.not_not_mem] at h,
      rcases h with ⟨Δ', π, hπ₁, hπ₂, y, hy⟩,
      induction Δ' using opposite.rec,
      induction Δ' with m,
      have hm : m < n.succ,
      { have hπ₁' := (simplex_category.len_le_of_epi hπ₁),
        dsimp at hπ₁',
        cases hπ₁'.lt_or_eq,
        { assumption, },
        { subst h,
          exfalso,
          apply hπ₂,
          rw simplex_category.mono_iff_injective,
          rw simplex_category.epi_iff_surjective at hπ₁,
          rw finite.injective_iff_bijective at ⊢,
          rw finite.surjective_iff_bijective at hπ₁,
          assumption, }, },
      rcases hn m hm y with ⟨Δ'', θ, hθ, z, hz, eq⟩,
      haveI := hπ₁,
      haveI := hθ,
      refine ⟨Δ'', θ ≫ π, by { rw unop_comp, apply epi_comp, }, z, hz, _⟩,
      simp only [functor_to_types.map_comp_apply, hy, eq], }, },
end

--lemma splitting.sum.concrete_bijective (N : ℕ → Type u) (Δ : simplex_categoryᵒᵖ) :
--  function.bijective (limits.concrete.coproduct_map (simplicial_object.splitting.summand N Δ) :
--    sigma (simplicial_object.splitting.summand N Δ) → simplicial_object.splitting.sum N Δ) :=
--limits.concrete.coproduct_map_bijective _

lemma image_of_nondegenerate_simplex_uniqueness₀ (X : sSet)
  {Δ Δ₁ Δ₂ : simplex_categoryᵒᵖ} (y₁ : X.obj Δ₁) (y₂ : X.obj Δ₂)
  (hy₁ : y₁ ∈ X.nondegenerate_simplices Δ₁)
  (θ₁ : Δ₁ ⟶ Δ) (θ₂ : Δ₂ ⟶ Δ) (hθ₁ : epi θ₁.unop) (hθ₂ : epi θ₂.unop)
  (eq : X.map θ₁ y₁ = X.map θ₂ y₂) : Δ₁.unop.len ≤ Δ₂.unop.len :=
begin
  haveI := is_split_epi_of_epi θ₁.unop,
  let f := section_ θ₁.unop ≫ θ₂.unop,
  have eq₁ : y₁ = X.map f.op y₂,
  { dsimp only [f],
    rw [op_comp, X.map_comp', quiver.hom.op_unop, ← eq, ← X.map_comp'],
    change _ = X.map (θ₁.unop.op ≫ _) _,
    rw [← op_comp, is_split_epi.id θ₁.unop, op_id, X.map_id, types_id_apply], },
  let F := limits.image.mono_factorisation f,
  rw [← F.fac, op_comp, X.map_comp'] at eq₁,
  haveI : epi F.e := by { simp only [limits.as_factor_thru_image], apply_instance, },
  haveI he := is_iso_of_nondegenerate_simplices ⟨y₁, hy₁⟩ F.e.op infer_instance _ eq₁,
  haveI : is_iso F.e,
  { change is_iso F.e.op.unop,
    apply_instance, },
  have hf : mono f,
  { rw ← F.fac,
    apply mono_comp, },
  exact simplex_category.len_le_of_mono hf,
end

lemma image_of_nondegenerate_simplex_uniqueness₁ (X : sSet)
  {Δ Δ₁ Δ₂ : simplex_categoryᵒᵖ} (y₁ : X.obj Δ₁) (y₂ : X.obj Δ₂)
  (hy₁ : y₁ ∈ X.nondegenerate_simplices Δ₁) (hy₂ : y₂ ∈ X.nondegenerate_simplices Δ₂)
  (θ₁ : Δ₁ ⟶ Δ) (θ₂ : Δ₂ ⟶ Δ) (hθ₁ : epi θ₁.unop) (hθ₂ : epi θ₂.unop)
  (eq : X.map θ₁ y₁ = X.map θ₂ y₂) : Δ₁ = Δ₂ :=
begin
  unfreezingI { induction Δ₁ using opposite.rec, induction Δ₂ using opposite.rec, },
  congr,
  ext,
  apply le_antisymm,
  { exact image_of_nondegenerate_simplex_uniqueness₀ X y₁ y₂ hy₁ θ₁ θ₂ hθ₁ hθ₂ eq, },
  { exact image_of_nondegenerate_simplex_uniqueness₀ X y₂ y₁ hy₂ θ₂ θ₁ hθ₂ hθ₁ eq.symm, },
end

lemma image_of_nondegenerate_simplex_uniqueness₂ (X : sSet)
  {Δ Δ' : simplex_categoryᵒᵖ} (y₁ : X.obj Δ') (y₂ : X.obj Δ')
  (hy₁ : y₁ ∈ X.nondegenerate_simplices Δ') (hy₂ : y₂ ∈ X.nondegenerate_simplices Δ')
  (θ₁ : Δ' ⟶ Δ) (θ₂ : Δ' ⟶ Δ) (hθ₁ : epi θ₁.unop) (hθ₂ : epi θ₂.unop)
  (eq : X.map θ₁ y₁ = X.map θ₂ y₂) : y₁ = y₂ :=
begin
  haveI := is_split_epi_of_epi θ₁.unop,
  let f := section_ θ₁.unop ≫ θ₂.unop,
  have eq₁ : y₁ = X.map f.op y₂,
  { dsimp only [f],
    rw [op_comp, X.map_comp', quiver.hom.op_unop, ← eq, ← X.map_comp'],
    change _ = X.map (θ₁.unop.op ≫ _) _,
    rw [← op_comp, is_split_epi.id θ₁.unop, op_id, X.map_id, types_id_apply], },
  have eq₂ := eq₁,
  let F := limits.image.mono_factorisation f,
  rw [← F.fac, op_comp, X.map_comp'] at eq₂,
  haveI : epi F.e := by { simp only [limits.as_factor_thru_image], apply_instance, },
  haveI he := is_iso_of_nondegenerate_simplices ⟨y₁, hy₁⟩ F.e.op infer_instance _ eq₂,
  haveI : is_iso F.e,
  { change is_iso F.e.op.unop,
    apply_instance, },
  haveI : mono f,
  { rw ← F.fac,
    apply mono_comp, },
  simpa only [simplex_category.eq_id_of_mono f, op_id, X.map_id, types_id_apply] using eq₁,
end

lemma ext_epi_of_sections {Δ₁ Δ₂ : simplex_category} (θ₁ θ₂ : Δ₁ ⟶ Δ₂) [epi θ₁]
  (h : ∀ (s : split_epi θ₁), s.section_ ≫ θ₂ = 𝟙 _) : θ₁ = θ₂ :=
begin
  ext1, ext1, ext1 x,
  have h₂ : ∃ (s : split_epi θ₁), s.section_.to_order_hom (θ₁.to_order_hom x) = x,
  { haveI := is_split_epi_of_epi θ₁,
    let α : fin (Δ₂.len+1) → fin (Δ₁.len+1) := λ y,
      if (y = θ₁.to_order_hom x) then x else (section_ θ₁).to_order_hom y,
    have hα : ∀ y, θ₁.to_order_hom (α y) = y,
    { intro y,
      dsimp [α],
      split_ifs with h₁,
      { rw ← h₁, },
      { have h₃ := congr_arg order_hom.to_fun (congr_arg simplex_category.hom.to_order_hom (is_split_epi.id θ₁)),
        exact congr_fun h₃ y, }, },
    let β : Δ₂ ⟶ Δ₁ := simplex_category.hom.mk ⟨α, begin
      intros x₁ x₂,
      contrapose,
      intro h,
      simp only [not_le] at h ⊢,
      suffices : x₂ ≤ x₁,
      { cases this.lt_or_eq with h₁ h₂,
        { assumption, },
        { exfalso,
          simpa only [h₂, lt_self_iff_false] using h, }, },
      simpa only [hα, order_hom.to_fun_eq_coe] using θ₁.to_order_hom.monotone' h.le,
    end⟩,
    refine ⟨⟨β, _⟩, _⟩,
    { ext1, ext1, ext1 y,
      apply hα, },
    { simp only [simplex_category.hom.to_order_hom_mk, order_hom.coe_fun_mk,
        ite_eq_left_iff, eq_self_iff_true, not_true, is_empty.forall_iff], }, },
  rcases h₂ with ⟨s, hs⟩,
  rw ← hs,
  have eq := h s,
  have h₃ := s.id',
  simp only [auto_param_eq] at h₃,
  rw ← h₃ at eq,
  have h₄ : (θ₁ ≫ s.section_ ≫ θ₁).to_order_hom x =
    (θ₁ ≫ s.section_ ≫ θ₂).to_order_hom x := by rw eq,
  exact h₄,
end

lemma image_of_nondegenerate_simplex_uniqueness₃ (X : sSet)
  {Δ Δ' : simplex_categoryᵒᵖ} (y : X.obj Δ')
  (hy : y ∈ X.nondegenerate_simplices Δ')
  (θ₁ : Δ' ⟶ Δ) (θ₂ : Δ' ⟶ Δ) (hθ₁ : epi θ₁.unop) (hθ₂ : epi θ₂.unop)
  (eq : X.map θ₁ y = X.map θ₂ y) : θ₁ = θ₂ :=
begin
  apply quiver.hom.unop_inj,
  apply ext_epi_of_sections,
  introI s,
  let f := s.section_ ≫ θ₂.unop,
  change f = 𝟙 _,
  have eq₁ : y = X.map f.op y,
  { dsimp only [f],
    rw [op_comp, X.map_comp', quiver.hom.op_unop, ← eq, ← X.map_comp'],
    change _ = X.map (θ₁.unop.op ≫ _) _,
    rw [← op_comp, s.id, op_id, X.map_id, types_id_apply], },
  let F := limits.image.mono_factorisation f,
  rw [← F.fac, op_comp, X.map_comp'] at eq₁,
  haveI : epi F.e := by { simp only [limits.as_factor_thru_image], apply_instance, },
  haveI he := is_iso_of_nondegenerate_simplices ⟨y, hy⟩ F.e.op infer_instance _ eq₁,
  haveI : is_iso F.e,
  { change is_iso F.e.op.unop,
    apply_instance, },
  haveI : mono f,
  { rw ← F.fac,
    apply mono_comp, },
  exact simplex_category.eq_id_of_mono f,
end

@[simp]
def splitting_map (X : sSet.{u}) (Δ : simplex_categoryᵒᵖ) :
  sigma (simplicial_object.splitting.summand
    (λ n, (X.nondegenerate_simplices (op [n]) : Type u)) Δ) → X.obj Δ :=
λ s, X.map s.1.e.op s.2.1

lemma splitting_map_bijective (X : sSet.{u}) (Δ : simplex_categoryᵒᵖ) :
  function.bijective (X.splitting_map Δ) :=
begin
  split,
  { rintros ⟨⟨Δ₁, θ₁, hθ₁⟩, y₁, hy₁⟩ ⟨⟨Δ₂, θ₂, hθ₂⟩, y₂, hy₂⟩ eq,
    induction Δ₁ using opposite.rec,
    induction Δ₂ using opposite.rec,
    have h₁ := X.image_of_nondegenerate_simplex_uniqueness₁ y₁ y₂ hy₁ hy₂ θ₁.op θ₂.op
      hθ₁ hθ₂ eq,
    simp only [simplex_category.mk_len, op_inj_iff, unop_op] at h₁,
    subst h₁,
    have h₂ := X.image_of_nondegenerate_simplex_uniqueness₂ y₁ y₂ hy₁ hy₂ θ₁.op θ₂.op
      hθ₁ hθ₂ eq,
    subst h₂,
    have h₃ := X.image_of_nondegenerate_simplex_uniqueness₃ y₁ hy₁ θ₁.op θ₂.op hθ₁ hθ₂ eq,
    have h₃' : θ₁ = θ₂ := by { apply quiver.hom.op_inj, exact h₃, },
    subst h₃', },
  { intro y,
    rcases X.is_epi_image_of_nondegenerate_simplex y with ⟨Δ', θ, hθ, y, hy, eq⟩,
    exact ⟨⟨⟨Δ', ⟨θ.unop, hθ⟩⟩, ⟨y, hy⟩⟩, eq.symm⟩, },
end

@[simps]
def splitting (X : sSet.{u}) : simplicial_object.splitting X :=
begin
  let N : ℕ → Type u := λ n, X.nondegenerate_simplices (op [n]),
  let ι : Π (n : ℕ), N n → X.obj (op [n]) := λ n, subtype.val,
  exact
  { N := N,
    ι := ι,
    map_is_iso' := λ Δ, begin
      rw is_iso_iff_bijective,
      let α := X.splitting_map Δ,
      let β := simplicial_object.splitting.map X ι Δ,
      let γ := concrete.coproduct_map (simplicial_object.splitting.summand N Δ),
      have hγ : function.bijective γ := concrete.coproduct_map_bijective _,
      change function.bijective β,
      have eq : β ∘ γ = α,
      { ext s,
        rcases s with ⟨A, x⟩,
        dsimp [α, β, γ],
        have h := comp_apply (simplicial_object.splitting.ι_coprod N A)
          (simplicial_object.splitting.map X ι Δ) x,
        simp only [concrete_category.has_coe_to_fun_Type,
          simplicial_object.splitting.ι_coprod, simplicial_object.splitting.map] at h,
        erw [colimit.ι_desc, cofan.mk_ι_app] at h,
        exact h.symm, },
      rw [← function.bijective.of_comp_iff β hγ, eq],
      apply splitting_map_bijective,
    end, },
end

end sSet


import data.set.basic -- hide
open set -- hide
/- Tactic : apply

## Summary

If `h : P → Q` is a hypothesis, and the goal is `⊢ Q` then
`apply h` changes the goal to `⊢ P`.

## Details

If you have a function `h : P → Q` and your goal is `⊢ Q`
then `apply h` changes the goal to `⊢ P`. The logic is
simple: if you are trying to create a term of type `Q`,
but `h` is a function which turns terms of type `P` into
terms of type `Q`, then it will suffice to construct a
term of type `P`. A mathematician might say: "we need
to construct an element of $Q$, but we have a function $h:P\to Q$
so it suffices to construct an element of $P$". Or alternatively
"we need to prove $Q$, but we have a proof $h$ that $P\implies Q$
so it suffices to prove $P$".

-/

/-
In this level we introduce the new tactic `apply`. Look at what it does and try to solve it!
-/

/- Hint : Click here for a hint, in case you get stuck.
Start with an `intro`, then try to `apply` the right hypothesis.
-/

variables {X Y : Type} -- hide

/- Lemma : no-side-bar
If A, B and C are sets and x ∈ A, and we know that x ∈ A → x ∈ B and that x ∈ B → x ∈ C, then
we can deduce that x ∈ C.
-/
lemma subset_transitive_basic (A B C : set X) (x : X) (hAB : x ∈ A → x ∈ B) (hBC : x ∈ B → x ∈ C) :
  x ∈ A → x ∈ C :=
begin
  intro h,
  apply hBC,
  apply hAB,
  exact h,

end


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad, Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.functor.multivariate
import Mathlib.data.pfunctor.univariate.default
import Mathlib.data.sigma.default
import Mathlib.PostPort

universes u l u_1

namespace Mathlib

/-!
# Multivariate polynomial functors.

Multivariate polynomial functors are used for defining M-types and W-types.
They map a type vector `α` to the type `Σ a : A, B a ⟹ α`, with `A : Type` and
`B : A → typevec n`. They interact well with Lean's inductive definitions because
they guarantee that occurrences of `α` are positive.
-/

/--
multivariate polynomial functors
-/
structure mvpfunctor (n : ℕ)
where
  A : Type u
  B : A → typevec n

namespace mvpfunctor

/-- Applying `P` to an object of `Type` -/
def obj {n : ℕ} (P : mvpfunctor n) (α : typevec n) :=
  sigma fun (a : A P) => typevec.arrow (B P a) α

/-- Applying `P` to a morphism of `Type` -/
def map {n : ℕ} (P : mvpfunctor n) {α : typevec n} {β : typevec n} (f : typevec.arrow α β) : obj P α → obj P β :=
  fun (_x : obj P α) => sorry

protected instance inhabited {n : ℕ} : Inhabited (mvpfunctor n) :=
  { default := mk Inhabited.default fun (_x : Inhabited.default) => Inhabited.default }

protected instance obj.inhabited {n : ℕ} (P : mvpfunctor n) {α : typevec n} [Inhabited (A P)] [(i : fin2 n) → Inhabited (α i)] : Inhabited (obj P α) :=
  { default := sigma.mk Inhabited.default fun (_x : fin2 n) (_x_1 : B P Inhabited.default _x) => Inhabited.default }

protected instance obj.mvfunctor {n : ℕ} (P : mvpfunctor n) : mvfunctor (obj P) :=
  mvfunctor.mk (map P)

theorem map_eq {n : ℕ} (P : mvpfunctor n) {α : typevec n} {β : typevec n} (g : typevec.arrow α β) (a : A P) (f : typevec.arrow (B P a) α) : mvfunctor.map g (sigma.mk a f) = sigma.mk a (typevec.comp g f) :=
  rfl

theorem id_map {n : ℕ} (P : mvpfunctor n) {α : typevec n} (x : obj P α) : mvfunctor.map typevec.id x = x :=
  sigma.cases_on x
    fun (x_fst : A P) (x_snd : typevec.arrow (B P x_fst) α) =>
      idRhs (mvfunctor.map typevec.id (sigma.mk x_fst x_snd) = mvfunctor.map typevec.id (sigma.mk x_fst x_snd)) rfl

theorem comp_map {n : ℕ} (P : mvpfunctor n) {α : typevec n} {β : typevec n} {γ : typevec n} (f : typevec.arrow α β) (g : typevec.arrow β γ) (x : obj P α) : mvfunctor.map (typevec.comp g f) x = mvfunctor.map g (mvfunctor.map f x) := sorry

protected instance obj.is_lawful_mvfunctor {n : ℕ} (P : mvpfunctor n) : is_lawful_mvfunctor (obj P) :=
  is_lawful_mvfunctor.mk (id_map P) (comp_map P)

/-- Constant functor where the input object does not affect the output -/
def const (n : ℕ) (A : Type u) : mvpfunctor n :=
  mk A fun (a : A) (i : fin2 n) => pempty

/-- Constructor for the constant functor -/
def const.mk (n : ℕ) {A : Type u} (x : A) {α : typevec n} : obj (const n A) α :=
  sigma.mk x fun (i : fin2 n) (a : B (const n A) x i) => pempty.elim a

/-- Destructor for the constant functor -/
def const.get {n : ℕ} {A : Type u} {α : typevec n} (x : obj (const n A) α) : A :=
  sigma.fst x

@[simp] theorem const.get_map {n : ℕ} {A : Type u} {α : typevec n} {β : typevec n} (f : typevec.arrow α β) (x : obj (const n A) α) : const.get (mvfunctor.map f x) = const.get x :=
  sigma.cases_on x
    fun (x_fst : A (const n A)) (x_snd : typevec.arrow (B (const n A) x_fst) α) =>
      Eq.refl (const.get (mvfunctor.map f (sigma.mk x_fst x_snd)))

@[simp] theorem const.get_mk {n : ℕ} {A : Type u} {α : typevec n} (x : A) : const.get (const.mk n x) = x :=
  Eq.refl (const.get (const.mk n x))

@[simp] theorem const.mk_get {n : ℕ} {A : Type u} {α : typevec n} (x : obj (const n A) α) : const.mk n (const.get x) = x := sorry

/-- Functor composition on polynomial functors -/
def comp {n : ℕ} {m : ℕ} (P : mvpfunctor n) (Q : fin2 n → mvpfunctor m) : mvpfunctor m :=
  mk (sigma fun (a₂ : A P) => (i : fin2 n) → B P a₂ i → A (Q i))
    fun (a : sigma fun (a₂ : A P) => (i : fin2 n) → B P a₂ i → A (Q i)) (i : fin2 m) =>
      sigma fun (j : fin2 n) => sigma fun (b : B P (sigma.fst a) j) => B (Q j) (sigma.snd a j b) i

/-- Constructor for functor composition -/
def comp.mk {n : ℕ} {m : ℕ} {P : mvpfunctor n} {Q : fin2 n → mvpfunctor m} {α : typevec m} (x : obj P fun (i : fin2 n) => obj (Q i) α) : obj (comp P Q) α :=
  sigma.mk (sigma.mk (sigma.fst x) fun (i : fin2 n) (a : B P (sigma.fst x) i) => sigma.fst (sigma.snd x i a))
    fun (i : fin2 m)
      (a :
      B (comp P Q) (sigma.mk (sigma.fst x) fun (i : fin2 n) (a : B P (sigma.fst x) i) => sigma.fst (sigma.snd x i a))
        i) =>
      sigma.snd (sigma.snd x (sigma.fst a) (sigma.fst (sigma.snd a))) i (sigma.snd (sigma.snd a))

/-- Destructor for functor composition -/
def comp.get {n : ℕ} {m : ℕ} {P : mvpfunctor n} {Q : fin2 n → mvpfunctor m} {α : typevec m} (x : obj (comp P Q) α) : obj P fun (i : fin2 n) => obj (Q i) α :=
  sigma.mk (sigma.fst (sigma.fst x))
    fun (i : fin2 n) (a : B P (sigma.fst (sigma.fst x)) i) =>
      sigma.mk (sigma.snd (sigma.fst x) i a)
        fun (j : fin2 m) (b : B (Q i) (sigma.snd (sigma.fst x) i a) j) => sigma.snd x j (sigma.mk i (sigma.mk a b))

theorem comp.get_map {n : ℕ} {m : ℕ} {P : mvpfunctor n} {Q : fin2 n → mvpfunctor m} {α : typevec m} {β : typevec m} (f : typevec.arrow α β) (x : obj (comp P Q) α) : comp.get (mvfunctor.map f x) = mvfunctor.map (fun (i : fin2 n) (x : obj (Q i) α) => mvfunctor.map f x) (comp.get x) :=
  sigma.cases_on x
    fun (x_fst : A (comp P Q)) (x_snd : typevec.arrow (B (comp P Q) x_fst) α) =>
      Eq.refl (comp.get (mvfunctor.map f (sigma.mk x_fst x_snd)))

@[simp] theorem comp.get_mk {n : ℕ} {m : ℕ} {P : mvpfunctor n} {Q : fin2 n → mvpfunctor m} {α : typevec m} (x : obj P fun (i : fin2 n) => obj (Q i) α) : comp.get (comp.mk x) = x := sorry

@[simp] theorem comp.mk_get {n : ℕ} {m : ℕ} {P : mvpfunctor n} {Q : fin2 n → mvpfunctor m} {α : typevec m} (x : obj (comp P Q) α) : comp.mk (comp.get x) = x := sorry

/-
lifting predicates and relations
-/

theorem liftp_iff {n : ℕ} {P : mvpfunctor n} {α : typevec n} (p : {i : fin2 n} → α i → Prop) (x : obj P α) : mvfunctor.liftp p x ↔
  ∃ (a : A P), ∃ (f : typevec.arrow (B P a) α), x = sigma.mk a f ∧ ∀ (i : fin2 n) (j : B P a i), p (f i j) := sorry

theorem liftp_iff' {n : ℕ} {P : mvpfunctor n} {α : typevec n} (p : {i : fin2 n} → α i → Prop) (a : A P) (f : typevec.arrow (B P a) α) : mvfunctor.liftp p (sigma.mk a f) ↔ ∀ (i : fin2 n) (x : B P a i), p (f i x) := sorry

theorem liftr_iff {n : ℕ} {P : mvpfunctor n} {α : typevec n} (r : {i : fin2 n} → α i → α i → Prop) (x : obj P α) (y : obj P α) : mvfunctor.liftr r x y ↔
  ∃ (a : A P),
    ∃ (f₀ : typevec.arrow (B P a) α),
      ∃ (f₁ : typevec.arrow (B P a) α),
        x = sigma.mk a f₀ ∧ y = sigma.mk a f₁ ∧ ∀ (i : fin2 n) (j : B P a i), r (f₀ i j) (f₁ i j) := sorry

theorem supp_eq {n : ℕ} {P : mvpfunctor n} {α : typevec n} (a : A P) (f : typevec.arrow (B P a) α) (i : fin2 n) : mvfunctor.supp (sigma.mk a f) i = f i '' set.univ := sorry

end mvpfunctor

/-
Decomposing an n+1-ary pfunctor.
-/

namespace mvpfunctor

/-- Split polynomial functor, get a n-ary functor
from a `n+1`-ary functor -/
def drop {n : ℕ} (P : mvpfunctor (n + 1)) : mvpfunctor n :=
  mk (A P) fun (a : A P) => typevec.drop (B P a)

/-- Split polynomial functor, get a univariate functor
from a `n+1`-ary functor -/
def last {n : ℕ} (P : mvpfunctor (n + 1)) : pfunctor :=
  pfunctor.mk (A P) fun (a : A P) => typevec.last (B P a)

/-- append arrows of a polynomial functor application -/
def append_contents {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {β : Type u_1} {a : A P} (f' : typevec.arrow (B (drop P) a) α) (f : pfunctor.B (last P) a → β) : typevec.arrow (B P a) (α ::: β) :=
  typevec.split_fun f' f


--

-- New notation that overlaps with existing notation
syntax (name := myPair) (priority := high) "(" term "," term ")" : term

macro_rules (kind := myPair)
| `(($a, $b)) => `([$a, $b])

#eval (1, 2) -- not ambiguous since myPair parser has higher priority

theorem ex1 : (1, 2) = [1, 2] :=
rfl

-- Define macro for expanding the builtin triple notation
-- Macros bypass builtin elaboration functions
macro_rules
| `(($a, $b, $c)) => `($a + $b + $c)

#eval (1, 2, 3)

syntax (name := mySingleton) "[" term "]" : term

macro_rules (kind := mySingleton)
| `([$a]) => `(2 * $a)

#check [1] -- ambiguous it can be `mySingleton` or the singleton list

syntax (priority := 100) "(" term "," term ", " term ")" : term -- priority without a kind

macro_rules
| `(($a, $b, $c)) => `([$a, $b, $c])

#eval (1,2,3)

theorem ex2 : (1, 2, 3) = [1, 2, 3] :=
rfl

theorem ex3 : (1, 2, 3, 4) = Prod.mk 1 (Prod.mk 2 (Prod.mk 3 4)) :=
rfl


import IIT.PropInversion
import IIT.ClarifyIndices

/-
iit A : Type
| ι   : (n : Nat) → A
| mid : (x y : A) → (p : lt' x y) → A

iit lt' : (x : A) → (y : A) → Type
| ι'    : (m n : Nat) → (p : m < n) → lt' (A.ι m) (A.ι n)
| mid_l : (x y : A) → (p : lt' x y) → lt' x (A.mid x y p)
| mid_r : (x y : A) → (p : lt' x y) → lt' (A.mid x y p) y
-/

mutual
inductive Aₑ : Type 1
| ιₑ   : Nat → Aₑ
| midₑ : (x y : Aₑ) → (p : lt'ₑ) → Aₑ

inductive lt'ₑ : Type 1
| ι'ₑ : (m n : Nat) → (p : m < n) → lt'ₑ
| mid_lₑ : (x y : Aₑ) → (p : lt'ₑ) → lt'ₑ
| mid_rₑ : (x y : Aₑ) → (p : lt'ₑ) → lt'ₑ
end

open Aₑ lt'ₑ

mutual
inductive A_w : Aₑ → Prop
| ι_w : ∀ n, A_w (ιₑ n)
| mid_w : ∀ {x}, A_w x → ∀ {y}, A_w y → ∀ {p}, lt'_w x y p → A_w (midₑ x y p)

inductive lt'_w : Aₑ → Aₑ → lt'ₑ → Prop
| ι'_w : ∀ m n p, lt'_w (ιₑ m) (ιₑ n) (ι'ₑ m n p)
| mid_l_w : ∀ {x}, A_w x → ∀ {y}, A_w y → ∀ {p}, lt'_w x y p
    → lt'_w x (midₑ x y p) (mid_lₑ x y p)
| mid_r_w : ∀ {x}, A_w x → ∀ {y}, A_w y → ∀ {p}, lt'_w x y p
    → lt'_w (midₑ x y p) y (mid_rₑ x y p)
end

open A_w lt'_w

def A := PSigma A_w
def lt' := fun (x y : A) => PSigma (lt'_w x.1 y.1)

def ι : Nat → A := fun n => ⟨ιₑ n, ι_w n⟩
def mid (x y : A) (p : lt' x y) : A := ⟨midₑ x.1 y.1 p.1, mid_w x.2 y.2 p.2⟩
def ι' (m n : Nat) (p : m < n) : lt' (ι m) (ι n) := ⟨ι'ₑ m n p, ι'_w m n p⟩
def mid_l (x y : A) (p : lt' x y) : lt' x (mid x y p) :=
  ⟨mid_lₑ x.1 y.1 p.1, mid_l_w x.2 y.2 p.2⟩
def mid_r (x y : A) (p : lt' x y) : lt' (mid x y p) y :=
  ⟨mid_rₑ x.1 y.1 p.1, mid_r_w x.2 y.2 p.2⟩

section
variable
  (Aₘ     : A → Type 1)
  (lt'ₘ   : ∀ {x}, Aₘ x → ∀ {y}, Aₘ y → lt' x y → Type 1)
  (ιₘ     : ∀ n, Aₘ (ι n))
  (midₘ   : ∀ {x}, (xₘ : Aₘ x) → ∀ {y}, (yₘ : Aₘ y) → ∀ {p}, (pₘ : lt'ₘ xₘ yₘ p) → Aₘ (mid x y p))
  (ι'ₘ    : ∀ m n p, lt'ₘ (ιₘ m) (ιₘ n) (ι' m n p))
  (mid_lₘ : ∀ {x}, (xₘ : Aₘ x) → ∀ {y}, (yₘ : Aₘ y) → ∀ {p}, (pₘ : lt'ₘ xₘ yₘ p)
    → lt'ₘ xₘ (midₘ xₘ yₘ pₘ) (mid_l x y p))
  (mid_rₘ : ∀ {x}, (xₘ : Aₘ x) → ∀ {y}, (yₘ : Aₘ y) → ∀ {p}, (pₘ : lt'ₘ xₘ yₘ p)
    → lt'ₘ (midₘ xₘ yₘ pₘ) yₘ (mid_r x y p))

mutual
inductive Aᵣ : (x : A) → Aₘ x → Type 1
| ιᵣ : ∀ n, Aᵣ (ι n) (ιₘ n)
| midᵣ : ∀ {x} {xₘ : Aₘ x}, Aᵣ x xₘ →
           ∀ {y} {yₘ : Aₘ y}, Aᵣ y yₘ →
             ∀ {p} {pₘ : lt'ₘ xₘ yₘ p}, lt'ᵣ xₘ yₘ p pₘ → Aᵣ (mid x y p) (midₘ xₘ yₘ pₘ)

inductive lt'ᵣ : {x : A} → (xₘ : Aₘ x) → {y : A} → (yₘ : Aₘ y) → (p : lt' x y) → lt'ₘ xₘ yₘ p → Type 1
| ι'ᵣ : ∀ m n p, lt'ᵣ (ιₘ m) (ιₘ n) (ι' m n p) (ι'ₘ m n p)
| mid_lᵣ : ∀ {x} {xₘ : Aₘ x}, Aᵣ x xₘ →
             ∀ {y} {yₘ : Aₘ y}, Aᵣ y yₘ →
               ∀ {p} {pₘ : lt'ₘ xₘ yₘ p}, lt'ᵣ xₘ yₘ p pₘ →
                 lt'ᵣ xₘ (midₘ xₘ yₘ pₘ) (mid_l x y p) (mid_lₘ xₘ yₘ pₘ)
| mid_rᵣ : ∀ {x} {xₘ : Aₘ x}, Aᵣ x xₘ →
             ∀ {y} {yₘ : Aₘ y}, Aᵣ y yₘ →
               ∀ {p} {pₘ : lt'ₘ xₘ yₘ p}, lt'ᵣ xₘ yₘ p pₘ →
                 lt'ᵣ (midₘ xₘ yₘ pₘ) yₘ (mid_r x y p) (mid_rₘ xₘ yₘ pₘ)
end

open Aᵣ lt'ᵣ

structure PSigmaUnique {α : Type _} (β : α → Type _) :=
  fst : α
  snd : β fst
  unique : ∀ {a}, β a → a = fst

noncomputable def A_tot (x : A) : PSigmaUnique (Aᵣ Aₘ lt'ₘ ιₘ midₘ ι'ₘ mid_lₘ mid_rₘ x) := by
  cases x with | mk xₑ x_w => ?_
  apply Aₑ.recOn xₑ
    (motive_1 := fun xₑ => ∀ x_w, PSigmaUnique (Aᵣ Aₘ lt'ₘ ιₘ midₘ ι'ₘ mid_lₘ mid_rₘ ⟨xₑ, x_w⟩))
    (motive_2 := fun pₑ => ∀ {x xₘ} (xᵣ : Aᵣ Aₘ lt'ₘ ιₘ midₘ ι'ₘ mid_lₘ mid_rₘ x xₘ)
                  {y yₘ} (yᵣ : Aᵣ Aₘ lt'ₘ ιₘ midₘ ι'ₘ mid_lₘ mid_rₘ y yₘ)
                   p_w, PSigmaUnique (lt'ᵣ Aₘ lt'ₘ ιₘ midₘ ι'ₘ mid_lₘ mid_rₘ xₘ yₘ ⟨pₑ, p_w⟩))
  skip
  · intro n _
    exact ⟨ιₘ n, ιᵣ n, fun {xₘ} xᵣ => by cases xᵣ; rfl⟩
  · intro x y p x_ih y_ih p_ih ctor_w
    inversion ctor_w with x_w y_w p_w
    cases x_ih x_w with | mk xₘ xᵣ x_unique => ?_
    cases y_ih y_w with | mk yₘ yᵣ y_unique => ?_
    cases p_ih xᵣ yᵣ p_w with | mk pₘ pᵣ p_unique => ?_
    exact ⟨midₘ xₘ yₘ pₘ, midᵣ xᵣ yᵣ pᵣ, fun {zₘ} zᵣ => by
      cases zᵣ with | @midᵣ x' x'ₘ x'ᵣ y' y'ₘ y'ᵣ p' p'ₘ p'ᵣ => ?_
      cases x_unique x'ᵣ
      cases y_unique y'ᵣ
      cases p_unique p'ᵣ
      rfl ⟩
  · intro m n p x xₘ xᵣ y yₘ yᵣ ctor_w
    cases x with | mk xₑ x_w => ?_
    cases y with | mk yₑ y_w => ?_
    simp only at ctor_w
    clarifyIndices ctor_w
    cases xᵣ
    cases yᵣ
    exact ⟨ι'ₘ m n p, ι'ᵣ m n p, fun {qₘ} qᵣ => by
      cases qᵣ
      rfl ⟩
  · intro yₑ zₑ pₑ y_ih z_ih p_ih x' x'ₘ x'ᵣ y' y'ₘ y'ᵣ ctor_w
    cases x' with | mk x'ₑ x'_w => ?_
    cases y' with | mk y'ₑ y'_w => ?_
    simp only at ctor_w
    clarifyIndices ctor_w
    cases y'ᵣ with | @midᵣ x'' x''ₘ x''ᵣ y'' y''ₘ y''ᵣ p'' p''ₘ p''ᵣ => ?_
    simp only at ctor_w
    cases x'' with | mk x''ₑ x''_w => ?_
    cases y'' with | mk y''ₑ y''_w => ?_
    cases p'' with | mk p''ₑ p''_w => ?_
    clarifyIndices ctor_w
    simp only at ctor_w
    cases y_ih x''_w with | mk x'''ₘ x'''ᵣ x'''_unique => ?_
    cases z_ih y''_w with | mk y'''ₘ y'''ᵣ y'''_unique => ?_
    cases p_ih x'''ᵣ y'''ᵣ p''_w with | mk p'''ₘ p'''ᵣ p'''_unique => ?_
    simp only at *
    cases x'''_unique x'ᵣ
    cases x'''_unique x''ᵣ
    cases y'''_unique y''ᵣ
    cases p'''_unique p''ᵣ
    exact ⟨mid_lₘ _ _ _, mid_lᵣ x''ᵣ y''ᵣ p''ᵣ, fun {qₘ} qᵣ => by
      match qᵣ with
      | mid_lᵣ x'''ᵣ y'''ᵣ p'''ᵣ => skip ⟩

noncomputable def Ty_tot (Γ : Con) (A : Ty Γ) :
  PSigma (Tyᵣ Conₘ Tyₘ nilₘ extₘ baseₘ piₘ (Con_tot Conₘ Tyₘ nilₘ extₘ baseₘ piₘ Γ).1 A) := by
  cases Γ with | mk Γₑ Γ_w => ?_
  cases A with | mk Aₑ A_w => ?_
  apply Tyₑ.recOn Aₑ
    (motive_1 := fun Γₑ => ∀ Γ_w, PSigma (Conᵣ Conₘ Tyₘ nilₘ extₘ baseₘ piₘ ⟨Γₑ, Γ_w⟩))
    (motive_2 := fun Aₑ => ∀ {Γ Γₘ} (Γᵣ : Conᵣ Conₘ Tyₘ nilₘ extₘ baseₘ piₘ Γ Γₘ)
                   A_w, PSigma (Tyᵣ Conₘ Tyₘ nilₘ extₘ baseₘ piₘ Γₘ ⟨Aₑ, A_w⟩))
  · intro Γ_w
    exact PSigma.mk nilₘ nilᵣ
  · intro Δₑ Aₑ Δ_ih A_ih ctor_w
    inversion ctor_w with Δ_w A_w
    cases Δ_ih Δ_w with | mk Δₘ Δᵣ => ?_
    cases A_ih Δᵣ A_w with | mk Aₘ Aᵣ => ?_
    exact PSigma.mk (extₘ Δₘ Aₘ) (extᵣ Δᵣ Aᵣ)
  · intro Γₑ Γ_ih Δ Δₘ Δᵣ ctor_w
    cases Δ with | mk Δₑ Δ_w => ?_
    simp only at ctor_w
    clarifyIndices ctor_w
    exact PSigma.mk (baseₘ Δₘ) (baseᵣ Δᵣ)
  · intro Δₑ Aₑ Bₑ Δ_ih A_ih B_ih Δ' Δ'ₘ Δ'ᵣ ctor_w
    cases Δ' with | mk Δ'ₑ Δ_w => ?_
    simp only at ctor_w
    clarifyIndices ctor_w
    inversion ctor_w with Δ_w A_w B_w
    cases A_ih Δ'ᵣ A_w with | mk Aₘ Aᵣ => ?_
    cases B_ih (extᵣ Δ'ᵣ Aᵣ) B_w with | mk Bₘ Bᵣ => ?_
    exact PSigma.mk (piₘ Δ'ₘ Aₘ Bₘ) (piᵣ Δ'ᵣ Aᵣ Bᵣ)
  · exact (Con_tot Conₘ Tyₘ nilₘ extₘ baseₘ piₘ ⟨Γₑ, Γ_w⟩).2

noncomputable def Con.rec (Γ : Con) : Conₘ Γ :=
(Con_tot Conₘ Tyₘ nilₘ extₘ baseₘ piₘ Γ).1

noncomputable def Ty.rec (Γ : Con) (A : Ty Γ) : Tyₘ (Con.rec Conₘ Tyₘ nilₘ extₘ baseₘ piₘ Γ) A :=
(Ty_tot Conₘ Tyₘ nilₘ extₘ baseₘ piₘ Γ A).1

theorem nil_beta : Con.rec Conₘ Tyₘ nilₘ extₘ baseₘ piₘ nil = nilₘ :=
rfl

theorem ext_beta (Γ : Con) (A : Ty Γ) :
  Con.rec Conₘ Tyₘ nilₘ extₘ baseₘ piₘ (ext Γ A)
  = extₘ (Con.rec Conₘ Tyₘ nilₘ extₘ baseₘ piₘ Γ)
    (Ty.rec Conₘ Tyₘ nilₘ extₘ baseₘ piₘ Γ A) :=
rfl

theorem base_beta (Γ : Con) :
  Ty.rec Conₘ Tyₘ nilₘ extₘ baseₘ piₘ Γ (base Γ)
  = baseₘ (Con.rec Conₘ Tyₘ nilₘ extₘ baseₘ piₘ Γ) :=
rfl

theorem pi_beta (Γ : Con) (A : Ty Γ) (B : Ty (ext Γ A)) :
  Ty.rec Conₘ Tyₘ nilₘ extₘ baseₘ piₘ Γ (pi Γ A B)
  = piₘ (Con.rec Conₘ Tyₘ nilₘ extₘ baseₘ piₘ Γ)
      (Ty.rec Conₘ Tyₘ nilₘ extₘ baseₘ piₘ Γ A)
      (Ty.rec Conₘ Tyₘ nilₘ extₘ baseₘ piₘ (ext Γ A) B) :=
rfl

end