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

! This file was ported from Lean 3 source module linear_algebra.matrix.charpoly.linear_map
! leanprover-community/mathlib commit 62c0a4ef1441edb463095ea02a06e87f3dfe135c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.Matrix.Charpoly.Coeff
import Mathbin.LinearAlgebra.Matrix.ToLin

/-!

# Calyley-Hamilton theorem for f.g. modules.

Given a fixed finite spanning set `b : ι → M` of a `R`-module `M`, we say that a matrix `M`
represents an endomorphism `f : M →ₗ[R] M` if the matrix as an endomorphism of `ι → R` commutes
with `f` via the projection `(ι → R) →ₗ[R] M` given by `b`.

We show that every endomorphism has a matrix representation, and if `f.range ≤ I • ⊤` for some
ideal `I`, we may furthermore obtain a matrix representation whose entries fall in `I`.

This is used to conclude the Cayley-Hamilton theorem for f.g. modules over arbitrary rings.
-/

variable {ι : Type _} [Fintype ι]

variable {M : Type _} [AddCommGroup M] (R : Type _) [CommRing R] [Module R M] (I : Ideal R)

variable (b : ι → M) (hb : Submodule.span R (Set.range b) = ⊤)

open BigOperators

open Polynomial

/-- The composition of a matrix (as an endomporphism of `ι → R`) with the projection
`(ι → R) →ₗ[R] M`.  -/
def PiToModule.fromMatrix [DecidableEq ι] : Matrix ι ι R →ₗ[R] (ι → R) →ₗ[R] M :=
  (LinearMap.llcomp R _ _ _ (Fintype.total R R b)).comp algEquivMatrix'.symm.toLinearMap
#align pi_to_module.from_matrix PiToModule.fromMatrix

theorem PiToModule.fromMatrix_apply [DecidableEq ι] (A : Matrix ι ι R) (w : ι → R) :
    PiToModule.fromMatrix R b A w = Fintype.total R R b (A.mulVec w) :=
  rfl
#align pi_to_module.from_matrix_apply PiToModule.fromMatrix_apply

theorem PiToModule.fromMatrix_apply_single_one [DecidableEq ι] (A : Matrix ι ι R) (j : ι) :
    PiToModule.fromMatrix R b A (Pi.single j 1) = ∑ i : ι, A i j • b i :=
  by
  rw [PiToModule.fromMatrix_apply, Fintype.total_apply, Matrix.mulVec_single]
  simp_rw [mul_one]
#align pi_to_module.from_matrix_apply_single_one PiToModule.fromMatrix_apply_single_one

/-- The endomorphisms of `M` acts on `(ι → R) →ₗ[R] M`, and takes the projection
to a `(ι → R) →ₗ[R] M`. -/
def PiToModule.fromEnd : Module.End R M →ₗ[R] (ι → R) →ₗ[R] M :=
  LinearMap.lcomp _ _ (Fintype.total R R b)
#align pi_to_module.from_End PiToModule.fromEnd

theorem PiToModule.fromEnd_apply (f : Module.End R M) (w : ι → R) :
    PiToModule.fromEnd R b f w = f (Fintype.total R R b w) :=
  rfl
#align pi_to_module.from_End_apply PiToModule.fromEnd_apply

theorem PiToModule.fromEnd_apply_single_one [DecidableEq ι] (f : Module.End R M) (i : ι) :
    PiToModule.fromEnd R b f (Pi.single i 1) = f (b i) :=
  by
  rw [PiToModule.fromEnd_apply]
  congr
  convert Fintype.total_apply_single R b i 1
  rw [one_smul]
#align pi_to_module.from_End_apply_single_one PiToModule.fromEnd_apply_single_one

theorem PiToModule.fromEnd_injective (hb : Submodule.span R (Set.range b) = ⊤) :
    Function.Injective (PiToModule.fromEnd R b) :=
  by
  intro x y e
  ext m
  obtain ⟨m, rfl⟩ : m ∈ (Fintype.total R R b).range :=
    by
    rw [(Fintype.range_total R b).trans hb]
    trivial
  exact (LinearMap.congr_fun e m : _)
#align pi_to_module.from_End_injective PiToModule.fromEnd_injective

section

variable {R} [DecidableEq ι]

/-- We say that a matrix represents an endomorphism of `M` if the matrix acting on `ι → R` is
equal to `f` via the projection `(ι → R) →ₗ[R] M` given by a fixed (spanning) set.  -/
def Matrix.Represents (A : Matrix ι ι R) (f : Module.End R M) : Prop :=
  PiToModule.fromMatrix R b A = PiToModule.fromEnd R b f
#align matrix.represents Matrix.Represents

variable {b}

theorem Matrix.Represents.congr_fun {A : Matrix ι ι R} {f : Module.End R M} (h : A.Represents b f)
    (x) : Fintype.total R R b (A.mulVec x) = f (Fintype.total R R b x) :=
  LinearMap.congr_fun h x
#align matrix.represents.congr_fun Matrix.Represents.congr_fun

theorem Matrix.represents_iff {A : Matrix ι ι R} {f : Module.End R M} :
    A.Represents b f ↔ ∀ x, Fintype.total R R b (A.mulVec x) = f (Fintype.total R R b x) :=
  ⟨fun e x => e.congr_fun x, fun H => LinearMap.ext fun x => H x⟩
#align matrix.represents_iff Matrix.represents_iff

theorem Matrix.represents_iff' {A : Matrix ι ι R} {f : Module.End R M} :
    A.Represents b f ↔ ∀ j, (∑ i : ι, A i j • b i) = f (b j) :=
  by
  constructor
  · intro h i
    have := LinearMap.congr_fun h (Pi.single i 1)
    rwa [PiToModule.fromEnd_apply_single_one, PiToModule.fromMatrix_apply_single_one] at this
  · intro h
    ext
    simp_rw [LinearMap.comp_apply, LinearMap.coe_single, PiToModule.fromEnd_apply_single_one,
      PiToModule.fromMatrix_apply_single_one]
    apply h
#align matrix.represents_iff' Matrix.represents_iff'

theorem Matrix.Represents.mul {A A' : Matrix ι ι R} {f f' : Module.End R M} (h : A.Represents b f)
    (h' : Matrix.Represents b A' f') : (A * A').Represents b (f * f') :=
  by
  delta Matrix.Represents PiToModule.fromMatrix
  rw [LinearMap.comp_apply, AlgEquiv.toLinearMap_apply, map_mul]
  ext
  dsimp [PiToModule.fromEnd]
  rw [← h'.congr_fun, ← h.congr_fun]
  rfl
#align matrix.represents.mul Matrix.Represents.mul

theorem Matrix.Represents.one : (1 : Matrix ι ι R).Represents b 1 :=
  by
  delta Matrix.Represents PiToModule.fromMatrix
  rw [LinearMap.comp_apply, AlgEquiv.toLinearMap_apply, map_one]
  ext
  rfl
#align matrix.represents.one Matrix.Represents.one

theorem Matrix.Represents.add {A A' : Matrix ι ι R} {f f' : Module.End R M} (h : A.Represents b f)
    (h' : Matrix.Represents b A' f') : (A + A').Represents b (f + f') := by
  delta Matrix.Represents at h h'⊢; rw [map_add, map_add, h, h']
#align matrix.represents.add Matrix.Represents.add

theorem Matrix.Represents.zero : (0 : Matrix ι ι R).Represents b 0 := by delta Matrix.Represents;
  rw [map_zero, map_zero]
#align matrix.represents.zero Matrix.Represents.zero

theorem Matrix.Represents.smul {A : Matrix ι ι R} {f : Module.End R M} (h : A.Represents b f)
    (r : R) : (r • A).Represents b (r • f) := by delta Matrix.Represents at h⊢;
  rw [map_smul, map_smul, h]
#align matrix.represents.smul Matrix.Represents.smul

theorem Matrix.Represents.eq {A : Matrix ι ι R} {f f' : Module.End R M} (h : A.Represents b f)
    (h' : A.Represents b f') : f = f' :=
  PiToModule.fromEnd_injective R b hb (h.symm.trans h')
#align matrix.represents.eq Matrix.Represents.eq

variable (b R)

/-- The subalgebra of `matrix ι ι R` that consists of matrices that actually represent
endomorphisms on `M`. -/
def Matrix.isRepresentation : Subalgebra R (Matrix ι ι R)
    where
  carrier := { A | ∃ f : Module.End R M, A.Represents b f }
  mul_mem' := fun A₁ A₂ ⟨f₁, e₁⟩ ⟨f₂, e₂⟩ => ⟨f₁ * f₂, e₁.mul e₂⟩
  one_mem' := ⟨1, Matrix.Represents.one⟩
  add_mem' := fun A₁ A₂ ⟨f₁, e₁⟩ ⟨f₂, e₂⟩ => ⟨f₁ + f₂, e₁.add e₂⟩
  zero_mem' := ⟨0, Matrix.Represents.zero⟩
  algebraMap_mem' r := ⟨r • 1, Matrix.Represents.one.smul r⟩
#align matrix.is_representation Matrix.isRepresentation

/-- The map sending a matrix to the endomorphism it represents. This is an `R`-algebra morphism. -/
noncomputable def Matrix.isRepresentation.toEnd : Matrix.isRepresentation R b →ₐ[R] Module.End R M
    where
  toFun A := A.2.some
  map_one' := (1 : Matrix.isRepresentation R b).2.choose_spec.Eq hb Matrix.Represents.one
  map_mul' A₁ A₂ := (A₁ * A₂).2.choose_spec.Eq hb (A₁.2.choose_spec.mul A₂.2.choose_spec)
  map_zero' := (0 : Matrix.isRepresentation R b).2.choose_spec.Eq hb Matrix.Represents.zero
  map_add' A₁ A₂ := (A₁ + A₂).2.choose_spec.Eq hb (A₁.2.choose_spec.add A₂.2.choose_spec)
  commutes' r :=
    (r • 1 : Matrix.isRepresentation R b).2.choose_spec.Eq hb (Matrix.Represents.one.smul r)
#align matrix.is_representation.to_End Matrix.isRepresentation.toEnd

theorem Matrix.isRepresentation.toEnd_represents (A : Matrix.isRepresentation R b) :
    (A : Matrix ι ι R).Represents b (Matrix.isRepresentation.toEnd R b hb A) :=
  A.2.choose_spec
#align matrix.is_representation.to_End_represents Matrix.isRepresentation.toEnd_represents

theorem Matrix.isRepresentation.eq_toEnd_of_represents (A : Matrix.isRepresentation R b)
    {f : Module.End R M} (h : (A : Matrix ι ι R).Represents b f) :
    Matrix.isRepresentation.toEnd R b hb A = f :=
  A.2.choose_spec.Eq hb h
#align matrix.is_representation.eq_to_End_of_represents Matrix.isRepresentation.eq_toEnd_of_represents

theorem Matrix.isRepresentation.toEnd_exists_mem_ideal (f : Module.End R M) (I : Ideal R)
    (hI : f.range ≤ I • ⊤) : ∃ M, Matrix.isRepresentation.toEnd R b hb M = f ∧ ∀ i j, M.1 i j ∈ I :=
  by
  have : ∀ x, f x ∈ (Ideal.finsuppTotal ι M I b).range :=
    by
    rw [Ideal.range_finsuppTotal, hb]
    exact fun x => hI (f.mem_range_self x)
  choose bM' hbM'
  let A : Matrix ι ι R := fun i j => bM' (b j) i
  have : A.represents b f := by
    rw [Matrix.represents_iff']
    dsimp [A]
    intro j
    specialize hbM' (b j)
    rwa [Ideal.finsuppTotal_apply_eq_of_fintype] at hbM'
  exact
    ⟨⟨A, f, this⟩, Matrix.isRepresentation.eq_toEnd_of_represents R b hb ⟨A, f, this⟩ this,
      fun i j => (bM' (b j) i).Prop⟩
#align matrix.is_representation.to_End_exists_mem_ideal Matrix.isRepresentation.toEnd_exists_mem_ideal

theorem Matrix.isRepresentation.toEnd_surjective :
    Function.Surjective (Matrix.isRepresentation.toEnd R b hb) :=
  by
  intro f
  obtain ⟨M, e, -⟩ := Matrix.isRepresentation.toEnd_exists_mem_ideal R b hb f ⊤ _
  exact ⟨M, e⟩
  simp
#align matrix.is_representation.to_End_surjective Matrix.isRepresentation.toEnd_surjective

end

/-- The **Cayley-Hamilton Theorem** for f.g. modules over arbitrary rings states that for each
`R`-endomorphism `φ` of an `R`-module `M` such that `φ(M) ≤ I • M` for some ideal `I`, there
exists some `n` and some `aᵢ ∈ Iⁱ` such that `φⁿ + a₁ φⁿ⁻¹ + ⋯ + aₙ = 0`.

This is the version found in Eisenbud 4.3, which is slightly weaker than Matsumura 2.1
(this lacks the constraint on `n`), and is slightly stronger than Atiyah-Macdonald 2.4.
-/
theorem LinearMap.exists_monic_and_coeff_mem_pow_and_aeval_eq_zero_of_range_le_smul
    [Module.Finite R M] (f : Module.End R M) (I : Ideal R) (hI : f.range ≤ I • ⊤) :
    ∃ p : R[X], p.Monic ∧ (∀ k, p.coeff k ∈ I ^ (p.natDegree - k)) ∧ Polynomial.aeval f p = 0 := by
  classical
    cases subsingleton_or_nontrivial R
    · exact ⟨0, Polynomial.monic_of_subsingleton _, by simp⟩
    obtain ⟨s : Finset M, hs : Submodule.span R (s : Set M) = ⊤⟩ := Module.Finite.out
    obtain ⟨A, rfl, h⟩ :=
      Matrix.isRepresentation.toEnd_exists_mem_ideal R (coe : s → M)
        (by rw [Subtype.range_coe_subtype, Finset.setOf_mem, hs]) f I hI
    refine' ⟨A.1.charpoly, A.1.charpoly_monic, _, _⟩
    · rw [A.1.charpoly_natDegree_eq_dim]
      exact coeff_charpoly_mem_ideal_pow h
    · rw [Polynomial.aeval_algHom_apply, ← map_zero (Matrix.isRepresentation.toEnd R coe _)]
      congr 1
      ext1
      rw [Polynomial.aeval_subalgebra_coe, Subtype.val_eq_coe, Matrix.aeval_self_charpoly,
        Subalgebra.coe_zero]
    · infer_instance
#align linear_map.exists_monic_and_coeff_mem_pow_and_aeval_eq_zero_of_range_le_smul LinearMap.exists_monic_and_coeff_mem_pow_and_aeval_eq_zero_of_range_le_smul

theorem LinearMap.exists_monic_and_aeval_eq_zero [Module.Finite R M] (f : Module.End R M) :
    ∃ p : R[X], p.Monic ∧ Polynomial.aeval f p = 0 :=
  (LinearMap.exists_monic_and_coeff_mem_pow_and_aeval_eq_zero_of_range_le_smul R f ⊤ (by simp)).imp
    fun p h => h.imp_right And.right
#align linear_map.exists_monic_and_aeval_eq_zero LinearMap.exists_monic_and_aeval_eq_zero


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Kevin Buzzard, Jujian Zhang
-/
import algebra.direct_sum.algebra
import algebra.direct_sum.decomposition
import algebra.direct_sum.internal
import algebra.direct_sum.ring
import group_theory.subgroup.basic

/-!
# Internally-graded algebras

This file defines the typeclass `graded_algebra 𝒜`, for working with an algebra `A` that is
internally graded by a collection of submodules `𝒜 : ι → submodule R A`.
See the docstring of that typeclass for more information.

## Main definitions

* `graded_algebra 𝒜`: the typeclass, which is a combination of `set_like.graded_monoid`, and
  `direct_sum.decomposition 𝒜`.
* `direct_sum.decompose_alg_equiv 𝒜 : A ≃ₐ[R] ⨁ i, 𝒜 i`, a more bundled version of
  `direct_sum.decompose 𝒜`.
* `graded_algebra.proj 𝒜 i` is the linear map from `A` to its degree `i : ι` component, such that
  `proj 𝒜 i x = decompose 𝒜 x i`.

## Implementation notes

For now, we do not have internally-graded semirings and internally-graded rings; these can be
represented with `𝒜 : ι → submodule ℕ A` and `𝒜 : ι → submodule ℤ A` respectively, since all
`semiring`s are ℕ-algebras via `algebra_nat`, and all `ring`s are `ℤ`-algebras via `algebra_int`.

## Tags

graded algebra, graded ring, graded semiring, decomposition
-/

open_locale direct_sum big_operators

section graded_algebra

variables {ι R A : Type*}
variables [decidable_eq ι] [add_monoid ι] [comm_semiring R] [semiring A] [algebra R A]
variables (𝒜 : ι → submodule R A)

/-- An internally-graded `R`-algebra `A` is one that can be decomposed into a collection
of `submodule R A`s indexed by `ι` such that the canonical map `A → ⨁ i, 𝒜 i` is bijective and
respects multiplication, i.e. the product of an element of degree `i` and an element of degree `j`
is an element of degree `i + j`.

Note that the fact that `A` is internally-graded, `graded_algebra 𝒜`, implies an externally-graded
algebra structure `direct_sum.galgebra R (λ i, ↥(𝒜 i))`, which in turn makes available an
`algebra R (⨁ i, 𝒜 i)` instance.
-/

class graded_algebra extends set_like.graded_monoid 𝒜, direct_sum.decomposition 𝒜.

protected lemma graded_algebra.is_internal [graded_algebra 𝒜] : direct_sum.is_internal 𝒜 :=
direct_sum.decomposition.is_internal _

/-- A helper to construct a `graded_algebra` when the `set_like.graded_monoid` structure is already
available. This makes the `left_inv` condition easier to prove, and phrases the `right_inv`
condition in a way that allows custom `@[ext]` lemmas to apply.

See note [reducible non-instances]. -/
@[reducible]
def graded_algebra.of_alg_hom [set_like.graded_monoid 𝒜] (decompose : A →ₐ[R] ⨁ i, 𝒜 i)
  (right_inv : (direct_sum.coe_alg_hom 𝒜).comp decompose = alg_hom.id R A)
  (left_inv : ∀ i (x : 𝒜 i), decompose (x : A) = direct_sum.of (λ i, ↥(𝒜 i)) i x) :
  graded_algebra 𝒜 :=
{ decompose' := decompose,
  left_inv := alg_hom.congr_fun right_inv,
  right_inv := begin
    suffices : decompose.comp (direct_sum.coe_alg_hom 𝒜) = alg_hom.id _ _,
    from alg_hom.congr_fun this,
    ext i x : 2,
    exact (decompose.congr_arg $ direct_sum.coe_alg_hom_of _ _ _).trans (left_inv i x),
  end}

variable [graded_algebra 𝒜]

namespace direct_sum

/-- If `A` is graded by `ι` with degree `i` component `𝒜 i`, then it is isomorphic as
an algebra to a direct sum of components. -/
@[simps]
def decompose_alg_equiv : A ≃ₐ[R] ⨁ i, 𝒜 i := alg_equiv.symm
{ map_mul' := (coe_alg_hom 𝒜).map_mul,
  map_add' := (coe_alg_hom 𝒜).map_add,
  commutes' := (coe_alg_hom 𝒜).commutes,
  ..(decompose_add_equiv 𝒜).symm }

@[simp] lemma decompose_one : decompose 𝒜 (1 : A) = 1 := map_one (decompose_alg_equiv 𝒜)
@[simp] lemma decompose_symm_one : (decompose 𝒜).symm 1 = (1 : A) :=
map_one (decompose_alg_equiv 𝒜).symm

@[simp] lemma decompose_mul (x y : A) : decompose 𝒜 (x * y) = decompose 𝒜 x * decompose 𝒜 y :=
map_mul (decompose_alg_equiv 𝒜) x y
@[simp] lemma decompose_symm_mul (x y : ⨁ i, 𝒜 i) :
  (decompose 𝒜).symm (x * y) = (decompose 𝒜).symm x * (decompose 𝒜).symm y :=
map_mul (decompose_alg_equiv 𝒜).symm x y

end direct_sum

open direct_sum

/-- The projection maps of graded algebra-/
def graded_algebra.proj (𝒜 : ι → submodule R A) [graded_algebra 𝒜] (i : ι) : A →ₗ[R] A :=
(𝒜 i).subtype.comp $
  (dfinsupp.lapply i).comp $
  (decompose_alg_equiv 𝒜).to_alg_hom.to_linear_map

@[simp] lemma graded_algebra.proj_apply (i : ι) (r : A) :
  graded_algebra.proj 𝒜 i r = (decompose 𝒜 r : ⨁ i, 𝒜 i) i := rfl

lemma graded_algebra.proj_recompose (a : ⨁ i, 𝒜 i) (i : ι) :
  graded_algebra.proj 𝒜 i ((decompose 𝒜).symm a) =
  (decompose 𝒜).symm (of _ i (a i)) :=
by rw [graded_algebra.proj_apply, decompose_symm_of, equiv.apply_symm_apply]

lemma graded_algebra.mem_support_iff [decidable_eq A] (r : A) (i : ι) :
  i ∈ (decompose 𝒜 r).support ↔ graded_algebra.proj 𝒜 i r ≠ 0 :=
dfinsupp.mem_support_iff.trans submodule.coe_eq_zero.not.symm

end graded_algebra

section canonical_order

open graded_algebra set_like.graded_monoid direct_sum

variables {ι R A : Type*}
variables [comm_semiring R] [semiring A]
variables [algebra R A] [decidable_eq ι]
variables [canonically_ordered_add_monoid ι]
variables (𝒜 : ι → submodule R A) [graded_algebra 𝒜]

/--
If `A` is graded by a canonically ordered add monoid, then the projection map `x ↦ x₀` is a ring
homomorphism.
-/
@[simps]
def graded_algebra.proj_zero_ring_hom : A →+* A :=
{ to_fun := λ a, decompose 𝒜 a 0,
  map_one' := decompose_of_mem_same 𝒜 one_mem,
  map_zero' := by simp only [subtype.ext_iff_val, decompose_zero, zero_apply, submodule.coe_zero],
  map_add' := λ _ _, by simp [subtype.ext_iff_val, decompose_add, add_apply, submodule.coe_add],
  map_mul' := λ x y,
    have m : ∀ x, x ∈ supr 𝒜,
    from λ x, (graded_algebra.is_internal 𝒜).submodule_supr_eq_top.symm ▸ submodule.mem_top,
    begin
    refine submodule.supr_induction 𝒜 (m x) (λ i c hc, _) _ _,
    { refine submodule.supr_induction 𝒜 (m y) (λ j c' hc', _) _ _,
      { by_cases h : i + j = 0,
        { rw [decompose_of_mem_same 𝒜 (show c * c' ∈ 𝒜 0, from h ▸ mul_mem hc hc'),
            decompose_of_mem_same 𝒜 (show c ∈ 𝒜 0, from (add_eq_zero_iff.mp h).1 ▸ hc),
            decompose_of_mem_same 𝒜 (show c' ∈ 𝒜 0, from (add_eq_zero_iff.mp h).2 ▸ hc')] },
        { rw [decompose_of_mem_ne 𝒜 (mul_mem hc hc') h],
          cases (show i ≠ 0 ∨ j ≠ 0, by rwa [add_eq_zero_iff, not_and_distrib] at h) with h' h',
          { simp only [decompose_of_mem_ne 𝒜 hc h', zero_mul] },
          { simp only [decompose_of_mem_ne 𝒜 hc' h', mul_zero] } } },
      { simp only [decompose_zero, zero_apply, submodule.coe_zero, mul_zero] },
      { intros _ _ hd he,
        simp only [mul_add, decompose_add, add_apply, submodule.coe_add, hd, he] } },
    { simp only [decompose_zero, zero_apply, submodule.coe_zero, zero_mul] },
    { rintros _ _ ha hb, simp only [add_mul, decompose_add, add_apply, submodule.coe_add, ha, hb] },
  end }

end canonical_order


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

universes u l u_1

namespace Mathlib

/-!
# The M construction as a multivariate polynomial functor.

M types are potentially infinite tree-like structures. They are defined
as the greatest fixpoint of a polynomial functor.

## Main definitions

 * `M.mk`     - constructor
 * `M.dest`   - destructor
 * `M.corec`  - corecursor: useful for formulating infinite, productive computations
 * `M.bisim`  - bisimulation: proof technique to show the equality of infinite objects

## Implementation notes

Dual view of M-types:

 * `Mp`: polynomial functor
 * `M`: greatest fixed point of a polynomial functor

Specifically, we define the polynomial functor `Mp` as:

 * A := a possibly infinite tree-like structure without information in the nodes
 * B := given the tree-like structure `t`, `B t` is a valid path
   from the root of `t` to any given node.

As a result `Mp.obj α` is made of a dataless tree and a function from
its valid paths to values of `α`

The difference with the polynomial functor of an initial algebra is
that `A` is a possibly infinite tree.

## Reference

 * [Jeremy Avigad, Mario M. Carneiro and Simon Hudon, *Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

namespace mvpfunctor

/-- A path from the root of a tree to one of its node -/
inductive M.path {n : ℕ} (P : mvpfunctor (n + 1)) : pfunctor.M (last P) → fin2 n → Type u
where
| root : (x : pfunctor.M (last P)) →
  (a : A P) →
    (f : pfunctor.B (last P) a → pfunctor.M (last P)) →
      pfunctor.M.dest x = sigma.mk a f → (i : fin2 n) → B (drop P) a i → M.path P x i
| child : (x : pfunctor.M (last P)) →
  (a : A P) →
    (f : pfunctor.B (last P) a → pfunctor.M (last P)) →
      pfunctor.M.dest x = sigma.mk a f → (j : pfunctor.B (last P) a) → (i : fin2 n) → M.path P (f j) i → M.path P x i

protected instance M.path.inhabited {n : ℕ} (P : mvpfunctor (n + 1)) (x : pfunctor.M (last P)) {i : fin2 n} [Inhabited (B (drop P) (pfunctor.M.head x) i)] : Inhabited (M.path P x i) :=
  { default := M.path.root x (pfunctor.M.head x) (pfunctor.M.children x) sorry i Inhabited.default }

/-- Polynomial functor of the M-type of `P`. `A` is a data-less
possibly infinite tree whereas, for a given `a : A`, `B a` is a valid
path in tree `a` so that `Wp.obj α` is made of a tree and a function
from its valid paths to the values it contains -/
def Mp {n : ℕ} (P : mvpfunctor (n + 1)) : mvpfunctor n :=
  mk (pfunctor.M (last P)) (M.path P)

/-- `n`-ary M-type for `P` -/
def M {n : ℕ} (P : mvpfunctor (n + 1)) (α : typevec n) :=
  obj (Mp P) α

protected instance mvfunctor_M {n : ℕ} (P : mvpfunctor (n + 1)) : mvfunctor (M P) :=
  id (obj.mvfunctor (Mp P))

protected instance inhabited_M {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} [I : Inhabited (A P)] [(i : fin2 n) → Inhabited (α i)] : Inhabited (M P α) :=
  obj.inhabited (Mp P)

/-- construct through corecursion the shape of an M-type
without its contents -/
def M.corec_shape {n : ℕ} (P : mvpfunctor (n + 1)) {β : Type u} (g₀ : β → A P) (g₂ : (b : β) → pfunctor.B (last P) (g₀ b) → β) : β → pfunctor.M (last P) :=
  pfunctor.M.corec fun (b : β) => sigma.mk (g₀ b) (g₂ b)

/-- Proof of type equality as an arrow -/
def cast_dropB {n : ℕ} (P : mvpfunctor (n + 1)) {a : A P} {a' : A P} (h : a = a') : typevec.arrow (B (drop P) a) (B (drop P) a') :=
  fun (i : fin2 n) (b : B (drop P) a i) => eq.rec_on h b

/-- Proof of type equality as a function -/
def cast_lastB {n : ℕ} (P : mvpfunctor (n + 1)) {a : A P} {a' : A P} (h : a = a') : pfunctor.B (last P) a → pfunctor.B (last P) a' :=
  fun (b : pfunctor.B (last P) a) => eq.rec_on h b

/-- Using corecursion, construct the contents of an M-type -/
def M.corec_contents {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {β : Type u} (g₀ : β → A P) (g₁ : (b : β) → typevec.arrow (B (drop P) (g₀ b)) α) (g₂ : (b : β) → pfunctor.B (last P) (g₀ b) → β) (x : pfunctor.M (last P)) (b : β) : x = M.corec_shape P g₀ g₂ b → typevec.arrow (M.path P x) α :=
  sorry

/-- Corecursor for M-type of `P` -/
def M.corec' {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {β : Type u} (g₀ : β → A P) (g₁ : (b : β) → typevec.arrow (B (drop P) (g₀ b)) α) (g₂ : (b : β) → pfunctor.B (last P) (g₀ b) → β) : β → M P α :=
  fun (b : β) => sigma.mk (M.corec_shape P g₀ g₂ b) (M.corec_contents P g₀ g₁ g₂ (M.corec_shape P g₀ g₂ b) b sorry)

/-- Corecursor for M-type of `P` -/
def M.corec {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {β : Type u} (g : β → obj P (α ::: β)) : β → M P α :=
  M.corec' P (fun (b : β) => sigma.fst (g b)) (fun (b : β) => typevec.drop_fun (sigma.snd (g b)))
    fun (b : β) => typevec.last_fun (sigma.snd (g b))

/-- Implementation of destructor for M-type of `P` -/
def M.path_dest_left {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {x : pfunctor.M (last P)} {a : A P} {f : pfunctor.B (last P) a → pfunctor.M (last P)} (h : pfunctor.M.dest x = sigma.mk a f) (f' : typevec.arrow (M.path P x) α) : typevec.arrow (B (drop P) a) α :=
  fun (i : fin2 n) (c : B (drop P) a i) => f' i (M.path.root x a f h i c)

/-- Implementation of destructor for M-type of `P` -/
def M.path_dest_right {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {x : pfunctor.M (last P)} {a : A P} {f : pfunctor.B (last P) a → pfunctor.M (last P)} (h : pfunctor.M.dest x = sigma.mk a f) (f' : typevec.arrow (M.path P x) α) (j : pfunctor.B (last P) a) : typevec.arrow (M.path P (f j)) α :=
  fun (i : fin2 n) (c : M.path P (f j) i) => f' i (M.path.child x a f h j i c)

/-- Destructor for M-type of `P` -/
def M.dest' {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {x : pfunctor.M (last P)} {a : A P} {f : pfunctor.B (last P) a → pfunctor.M (last P)} (h : pfunctor.M.dest x = sigma.mk a f) (f' : typevec.arrow (M.path P x) α) : obj P (α ::: M P α) :=
  sigma.mk a
    (typevec.split_fun (M.path_dest_left P h f')
      fun (x_1 : typevec.last (B P a)) => sigma.mk (f x_1) (M.path_dest_right P h f' x_1))

/-- Destructor for M-types -/
def M.dest {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} (x : M P α) : obj P (α ::: M P α) :=
  M.dest' P sorry (sigma.snd x)

/-- Constructor for M-types -/
def M.mk {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} : obj P (α ::: M P α) → M P α :=
  M.corec P fun (i : obj P (α ::: M P α)) => mvfunctor.map (typevec.id ::: M.dest P) i

theorem M.dest'_eq_dest' {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {x : pfunctor.M (last P)} {a₁ : A P} {f₁ : pfunctor.B (last P) a₁ → pfunctor.M (last P)} (h₁ : pfunctor.M.dest x = sigma.mk a₁ f₁) {a₂ : A P} {f₂ : pfunctor.B (last P) a₂ → pfunctor.M (last P)} (h₂ : pfunctor.M.dest x = sigma.mk a₂ f₂) (f' : typevec.arrow (M.path P x) α) : M.dest' P h₁ f' = M.dest' P h₂ f' := sorry

theorem M.dest_eq_dest' {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {x : pfunctor.M (last P)} {a : A P} {f : pfunctor.B (last P) a → pfunctor.M (last P)} (h : pfunctor.M.dest x = sigma.mk a f) (f' : typevec.arrow (M.path P x) α) : M.dest P (sigma.mk x f') = M.dest' P h f' :=
  M.dest'_eq_dest' P (M.dest._proof_1 P (sigma.mk x f')) h (sigma.snd (sigma.mk x f'))

theorem M.dest_corec' {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {β : Type u} (g₀ : β → A P) (g₁ : (b : β) → typevec.arrow (B (drop P) (g₀ b)) α) (g₂ : (b : β) → pfunctor.B (last P) (g₀ b) → β) (x : β) : M.dest P (M.corec' P g₀ g₁ g₂ x) = sigma.mk (g₀ x) (typevec.split_fun (g₁ x) (M.corec' P g₀ g₁ g₂ ∘ g₂ x)) :=
  rfl

theorem M.dest_corec {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {β : Type u} (g : β → obj P (α ::: β)) (x : β) : M.dest P (M.corec P g x) = mvfunctor.map (typevec.id ::: M.corec P g) (g x) := sorry

theorem M.bisim_lemma {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {a₁ : A (Mp P)} {f₁ : typevec.arrow (B (Mp P) a₁) α} {a' : A P} {f' : typevec.arrow (typevec.drop (B P a')) α} {f₁' : typevec.last (B P a') → M P α} (e₁ : M.dest P (sigma.mk a₁ f₁) = sigma.mk a' (typevec.split_fun f' f₁')) : ∃ (g₁' : pfunctor.B (last P) a' → pfunctor.M (last P)),
  ∃ (e₁' : pfunctor.M.dest a₁ = sigma.mk a' g₁'),
    f' = M.path_dest_left P e₁' f₁ ∧
      f₁' = fun (x : pfunctor.B (last P) a') => sigma.mk (g₁' x) (M.path_dest_right P e₁' f₁ x) := sorry

theorem M.bisim {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} (R : M P α → M P α → Prop) (h : ∀ (x y : M P α),
  R x y →
    ∃ (a : A P),
      ∃ (f : typevec.arrow (typevec.drop (B P a)) (typevec.drop (α ::: M P α))),
        ∃ (f₁ : typevec.last (B P a) → typevec.last (α ::: M P α)),
          ∃ (f₂ : typevec.last (B P a) → typevec.last (α ::: M P α)),
            M.dest P x = sigma.mk a (typevec.split_fun f f₁) ∧
              M.dest P y = sigma.mk a (typevec.split_fun f f₂) ∧ ∀ (i : typevec.last (B P a)), R (f₁ i) (f₂ i)) (x : M P α) (y : M P α) (r : R x y) : x = y := sorry

theorem M.bisim₀ {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} (R : M P α → M P α → Prop) (h₀ : equivalence R) (h : ∀ (x y : M P α),
  R x y → mvfunctor.map (typevec.id ::: Quot.mk R) (M.dest P x) = mvfunctor.map (typevec.id ::: Quot.mk R) (M.dest P y)) (x : M P α) (y : M P α) (r : R x y) : x = y := sorry

theorem M.bisim' {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} (R : M P α → M P α → Prop) (h : ∀ (x y : M P α),
  R x y → mvfunctor.map (typevec.id ::: Quot.mk R) (M.dest P x) = mvfunctor.map (typevec.id ::: Quot.mk R) (M.dest P y)) (x : M P α) (y : M P α) (r : R x y) : x = y := sorry

theorem M.dest_map {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {β : typevec n} (g : typevec.arrow α β) (x : M P α) : M.dest P (mvfunctor.map g x) = mvfunctor.map (g ::: fun (x : M P α) => mvfunctor.map g x) (M.dest P x) := sorry

theorem M.map_dest {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {β : typevec n} (g : typevec.arrow (α ::: M P α) (β ::: M P β)) (x : M P α) (h : ∀ (x : M P α), typevec.last_fun g x = mvfunctor.map (typevec.drop_fun g) x) : mvfunctor.map g (M.dest P x) = M.dest P (mvfunctor.map (typevec.drop_fun g) x) := sorry


import sets.algebra init2 sets.axioms sets.theories categories.basic categories.limits

universes v v' u u' w
hott_theory

namespace hott
open hott.eq hott.sigma hott.set hott.subset hott.is_trunc hott.is_equiv hott.equiv
     hott.categories hott.categories.limits

namespace categories

/- We define multi-sorted standard structures on categories and prove the Structure
   Identity Principle, following and generalizing the [HoTT-Book], Section 9.8.  -/
@[hott]
structure std_structure_on (C : Type u) [category.{v} C] :=
  (S : Set)   --the set of sorts of the structure
  (P : (S -> C) -> Type w)
  (H : Π {s t : S -> C} (α : P s) (β : P t) (f : Π (x : S), s x ⟶ t x),
                                                                trunctype.{0} -1)
  (id_H : ∀ {s : S -> C} (α : P s), H α α (λ x : S, 𝟙 (s x)))
  (comp_H : ∀ {s t u : S -> C} (α : P s) (β : P t) (γ : P u) (f : Π x : S, s x ⟶ t x)
              (g : Π x : S, t x ⟶ u x),
              H α β f -> H β γ g -> H α γ (λ x : S, f x ≫ g x))
  (std : ∀ {s : S ->C} (α β : P s),
           (H α β (λ x : S, 𝟙 (s x)) × H β α (λ x : S, 𝟙 (s x))) ≃ α = β)

@[hott]
structure std_structure {C : Type u} [category.{v} C] (std_str : std_structure_on C) :=
  (carrier : std_str.S -> C)
  (str : std_str.P carrier)

@[hott]
instance {C : Type u} [category.{v} C] (std_str : std_structure_on C) :
  has_coe (std_structure std_str) (std_str.S -> C) :=
⟨λ x : std_structure std_str, x.carrier⟩

@[hott]
def std_str_eta {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  (x : std_structure std_str) : x = std_structure.mk x.carrier x.str :=
begin hinduction x, refl end

@[hott, instance]
def std_str_is_set {C : Type u} [category.{v} C] (std_str : std_structure_on C) :
  ∀ s : std_str.S -> C, is_set (std_str.P s) :=
assume s,
have eq_eq : ∀ (α β : std_str.P s), is_prop (α = β), from
  assume α β, is_trunc_equiv_closed -1 (std_str.std α β) (prod.is_trunc_prod _ _ -1),
is_trunc_succ_intro eq_eq

@[hott, instance]
def std_str_po_is_prop {C : Type u} [category.{v} C] (std_str : std_structure_on C)
  {s t : std_str.S -> C} {α : std_str.P s} {β : std_str.P t} :
  ∀ p : s = t, is_prop (α =[p] β) :=
begin
  intro p, hinduction p,
  apply is_trunc_equiv_closed_rev -1 (pathover_idp _ α β),
  exact is_prop.mk (@is_set.elim _ _ α β)
end

/- Equalities like these should be produced automatically. -/
@[hott]
def ap_apd011_str {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  {s t : std_str.S -> C} {α : std_str.P s} {β : std_str.P t} : ∀ (p : s = t) (q : α =[p] β),
                     ap std_structure.carrier (apd011 std_structure.mk p q) = p :=
begin intros p q, hinduction p, hinduction q, refl end

@[hott]
def apd011_ap_str {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  {x y : std_structure std_str} : ∀ p : x = y,
  apd011 std_structure.mk (ap std_structure.carrier p)
         (pathover_ap std_str.P std_structure.carrier (apd std_structure.str p)) =
  (std_str_eta x)⁻¹ ⬝ p ⬝ (std_str_eta y) :=
begin intro p, hinduction p, hinduction x, refl end

/- As a first step, we need to construct the structure of a precategory on the standard
   structures. -/
@[hott, instance]
def std_str_has_hom {C : Type u} [category.{v} C] (std_str : std_structure_on C) :
  has_hom (std_structure std_str) :=
has_hom.mk (λ (str₁ str₂ : std_structure std_str),
            pred_Set (λ f : to_Set (Π x : std_str.S, (str₁.carrier x ⟶ str₂.carrier x)),
                       std_str.H (str₁.str) (str₂.str) f))

@[hott]
instance hom_std_C {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  {str₁ str₂ : std_structure std_str} :
  has_coe ↥(str₁ ⟶ str₂) (Π x : std_str.S, (str₁.carrier x ⟶ str₂.carrier x)) :=
⟨λ f : str₁ ⟶ str₂, pred_Set_map _ f⟩

@[hott]
def hom_H {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  {str₁ str₂ : std_structure std_str} :
  Π f : str₁ ⟶ str₂, std_str.H str₁.str str₂.str (↑f) :=
begin intro f, exact f.2 end

@[hott]
def hom_eq_C_std {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  {str₁ str₂ : std_structure std_str} (f g : str₁ ⟶ str₂) :
  (f.1 = (g.1 : Π x : std_str.S, (str₁.carrier x ⟶ str₂.carrier x))) -> (f = g) :=
assume (hom_eq_C : f.1 = g.1),
have H_eq : f.2 =[hom_eq_C; (λ f : to_Set (Π x : std_str.S, (str₁.carrier x ⟶ str₂.carrier x)),
                       std_str.H (str₁.str) (str₂.str) f)] g.2, from
  pathover_prop_eq _ hom_eq_C (hom_H f) (hom_H g),
calc f = ⟨f.1, f.2⟩ : (sigma.eta f)⁻¹
   ... = ⟨g.1, g.2⟩ : dpair_eq_dpair hom_eq_C H_eq
   ... = g : sigma.eta g

@[hott, instance]
def std_str_cat_struct {C : Type u} [category.{v} C] (std_str : std_structure_on C) :
  category_struct (std_structure std_str) :=
category_struct.mk (λ str : std_structure std_str,
                            ⟨λ x : std_str.S, 𝟙 (str.carrier x), std_str.id_H str.str⟩)
  (λ (str₁ str₂ str₃ : std_structure std_str) (f : str₁ ⟶ str₂) (g : str₂ ⟶ str₃),
     ⟨(λ x : std_str.S, (f : Π x : std_str.S, (str₁.carrier x ⟶ str₂.carrier x)) x ≫ g.1 x),
                        std_str.comp_H str₁.str str₂.str str₃.str ↑f ↑g (hom_H f) (hom_H g)⟩)

@[hott]
def idhom_std_C {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  (str : std_structure std_str) : ↑(𝟙 str) = λ x, 𝟙 (str.carrier x) :=
rfl

@[hott]
def comp_hom_std_C {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  {str₁ str₂ str₃ : std_structure std_str} (f : str₁ ⟶ str₂) (g : str₂ ⟶ str₃) :
  (f ≫ g).1 = λ x : std_str.S, f.1 x ≫ g.1 x :=
rfl

@[hott, instance]
def std_str_precategory {C : Type u} [category.{v} C] (std_str : std_structure_on C) :
  precategory (std_structure std_str) :=
have ic : ∀ (str₁ str₂ : std_structure std_str) (f : str₁ ⟶ str₂), 𝟙 str₁ ≫ f = f, from
begin
  intros str₁ str₂ f, apply hom_eq_C_std _ _, rwr comp_hom_std_C,
  apply eq_of_homotopy, intro x, hsimp
end,
have ci : ∀ (str₁ str₂ : std_structure std_str) (f : str₁ ⟶ str₂), f ≫ 𝟙 str₂ = f, from
begin
  intros str₁ str₂ f, apply hom_eq_C_std _ _, rwr comp_hom_std_C,
  apply eq_of_homotopy, intro x, hsimp
end,
have as : ∀ (str₁ str₂ str₃ str₄: std_structure std_str) (f : str₁ ⟶ str₂) (g : str₂ ⟶ str₃)
            (h : str₃ ⟶ str₄), (f ≫ g) ≫ h = f ≫ (g ≫ h), from
begin
  intros x y z w f g h, apply hom_eq_C_std _ _, repeat { rwr comp_hom_std_C },
  apply eq_of_homotopy, intro x, hsimp
end,
precategory.mk ic ci as

/- We prove the Structure Identity principle by splitting up the equivalence making the
   precategory into a category into 5 equivalence and by showing that the composition of the
   5 equivalence maps is `idtoiso`.

   The first equivalence introduces the structure components in standard structures equalities. -/
@[hott]
def std_str_comp_eq {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  {str₁ str₂ : std_structure std_str} :
  (str₁ = str₂) ≃
          (std_structure.mk str₁.carrier str₁.str = std_structure.mk str₂.carrier str₂.str) :=
begin hinduction str₁ with s α, hinduction str₂ with t β, exact equiv.rfl end

/- The second equivalence is the eta principle for standard structures equalities. -/
@[hott]
def std_str_eq_eta {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  {s t : std_str.S -> C} {α : std_str.P s} {β : std_str.P t} :
  (std_structure.mk s α = std_structure.mk t β) ≃ Σ (p : s = t), α =[p] β :=
let str₁ := std_structure.mk s α, str₂ := std_structure.mk t β,
    f := λ p : str₁ = str₂, @dpair (s = t) (λ p : s = t, α =[p] β)
         (ap std_structure.carrier p : s = t)
         (pathover_ap std_str.P std_structure.carrier (apd std_structure.str p)),
    g := λ pq : Σ (p : s = t), α =[p] β, apd011 std_structure.mk pq.1 pq.2 in
have rinv : ∀ pq : Σ (p : s = t), α =[p] β, f (g pq) = pq, from
  assume pq,
  have pq_1 : (f (g pq)).1 = pq.1, from
    calc (f (g pq)).1 = ap std_structure.carrier (apd011 std_structure.mk pq.1 pq.2) : rfl
         ... = pq.1 : ap_apd011_str pq.1 pq.2,
  have pq_2 : (f (g pq)).2 =[pq_1; λ p : s = t, α =[p] β] pq.2, from po_proofs pq_1 _ _,
  calc f (g pq) = ⟨(f (g pq)).1, (f (g pq)).2⟩ : sigma.eta (f (g pq))
       ... = ⟨pq.1, pq.2⟩ : apd011 sigma.mk pq_1 pq_2
       ... = pq : sigma.eta pq,
have linv : ∀ p : str₁ = str₂, g (f p) = p, from
  assume p,
  have qx : std_str_eta str₁ = idp, from rfl,
  calc g (f p) = apd011 std_structure.mk (ap std_structure.carrier p) (f p).2 : rfl
       ... = (std_str_eta str₁)⁻¹ ⬝ p ⬝ (std_str_eta str₂) : apd011_ap_str p
       ... = p : by rwr qx; rwr idp_inv; rwr idp_con p; rwr con_idp p,
equiv.mk f (adjointify f g rinv linv)

/- The third equivalence exchanges equalities and isomorphisms. -/
@[hott]
def strpair_id_to_iso {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  {s t : std_str.S -> C} {α : std_str.P s} {β : std_str.P t} :
  (Σ (p : s = t), α =[p] β) ≃ (Σ (f : Π x, s x ≅ t x), std_str.H α β (λ x, (f x).hom) and
                                                        std_str.H β α (λ x, (f x).inv)) :=
begin
  let str₁ := std_structure.mk s α, let str₂ := std_structure.mk t β,
  have po_hom : Π (p : s = t) (q : α =[p] β), std_str.H α β (λ x, (idtoiso (ap10 p x)).hom) and
                                              std_str.H β α (λ x, (idtoiso (ap10 p x)).inv), from
  begin
    intros p q, hinduction p,
    have q' : α = β, from eq_of_pathover_idp q,
    have r : (λ x : std_str.S, (idtoiso (ap10 (@idp _ s) x)).hom) =
              λ x : std_str.S, 𝟙 (s x), from rfl,
    have r' : (λ x : std_str.S, (idtoiso (ap10 (@idp _ s) x)).inv) =
               λ x : std_str.S, 𝟙 (s x), from rfl,
    rwr r, rwr r', rwr <- q', exact (std_str.id_H α, std_str.id_H α)
  end,
  have idtoiso_hom_po : ∀ p : s = t, std_str.H α β (λ x, (idtoiso (ap10 p x)).hom) and
                            std_str.H β α (λ x, (idtoiso (ap10 p x)).inv) -> α =[p] β, from
    begin intros p H, hinduction p, apply pathover_idp_of_eq, exact std_str.std α β H end,
  have hom_po : Π (f : Π x, s x ≅ t x), (std_str.H α β (λ x, (f x).hom) and
                  std_str.H β α (λ x, (f x).inv)) ->
                  α =[eq_of_homotopy (λ x, category.isotoid (f x))] β, from
    assume f H,
    have r : f = λ x, idtoiso (ap10 (eq_of_homotopy (λ x, category.isotoid (f x))) x), from
      begin
        apply eq_of_homotopy, intro x, change f x = idtoiso (apd10 _ x),
        rwr apd10_eq_of_homotopy, change _ = idtoiso (idtoiso⁻¹ᶠ (f x)),
        rwr category.idtoiso_rinv (f x)
      end,
    begin
      apply idtoiso_hom_po,
      rwr <- eq_of_homotopy (λ x, ap iso.hom (apd10 r x)),
      rwr <- eq_of_homotopy (λ x, ap iso.inv (apd10 r x)), exact H
    end,
  let F := λ (pq : Σ (p : s = t), α =[p] β), @dpair (Π x, s x ≅ t x)
    (λ f : Π x, s x ≅ t x, std_str.H α β (λ x, (f x).hom) and std_str.H β α (λ x, (f x).inv))
    (λ x, idtoiso (ap10 pq.1 x)) (po_hom pq.1 pq.2),
  let G := λ iso_H : (Σ (f : Π x, s x ≅ t x), std_str.H α β (λ x, (f x).hom) and
                       std_str.H β α (λ x, (f x).inv)), @dpair (s = t) (λ p : s = t, α =[p] β)
                (eq_of_homotopy (λ x, category.isotoid (iso_H.1 x))) (hom_po iso_H.1 iso_H.2),
  have rinv : ∀ iso_H, F (G iso_H) = iso_H, from
  begin
    intro iso_H, fapply sigma_eq,
    { apply eq_of_homotopy, intro x,
      change idtoiso (apd10 _ x) = iso_H.1 x, rwr apd10_eq_of_homotopy,
      change idtoiso (idtoiso⁻¹ᶠ (iso_H.1 x)) = iso_H.1 x,
      exact category.idtoiso_rinv (iso_H.1 x) },
    { apply pathover_of_eq_tr, exact is_prop.elim _ _ }
  end,
  have linv : ∀ (pq : Σ (p : s = t), α =[p] β), G (F pq) = pq, from
  begin
    intro pq, hinduction pq.1 with h,
    fapply sigma_eq,
    { change (eq_of_homotopy (λ x, idtoiso⁻¹ᶠ (idtoiso (apd10 pq.1 x)))) = _,
      have r : Π x, apd10 pq.1 x = @idp _ (s x), from begin intro x, rwr h end,
      have q : (λ x, idtoiso⁻¹ᶠ (idtoiso (apd10 pq.1 x))) = λ x, (@idp _ (s x)), from
      begin
        apply eq_of_homotopy, intro x, change idtoiso⁻¹ᶠ (idtoiso (apd10 pq.1 x)) = _,
        rwr r x, rwr category.idtoiso_linv ((@idp _ (s x)))
      end,
      rwr q, rwr h, rwr eq_of_homotopy_idp },
    { apply pathover_of_eq_tr, exact is_prop.elim _ _ },
  end,
  exact equiv.mk F (adjointify F G rinv linv)
end

/- The fourth equivalence splits up equalities of standard structure isomorphisms. -/
@[hott]
def iso_std_C {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  {str₁ str₂ : std_structure std_str} (F : str₁ ≅ str₂) : Π x, str₁.carrier x ≅ str₂.carrier x :=
let f := (F.hom : str₁ ⟶ str₂).1, g := F.inv.1 in
have rinv : Π x, (g x) ≫ (f x) = 𝟙 (str₂.carrier x),
  begin intro x, change (F.inv ≫ F.hom).1 x = _, rwr F.r_inv end,
have linv : Π x, (f x) ≫ (g x) = 𝟙 (str₁.carrier x),
  begin intro x, change (F.hom ≫ F.inv).1 x = _, rwr F.l_inv end,
assume x, iso.mk (f x) (g x) (rinv x) (linv x)

@[hott]
def str_iso_eq_comp {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  {s t : std_str.S -> C} {α : std_str.P s} {β : std_str.P t} :
  (Σ (f : Π x, s x ≅ t x), std_str.H α β (λ x, (f x).hom) and std_str.H β α (λ x, (f x).inv)) ≃
  (std_structure.mk s α ≅ std_structure.mk t β) :=
begin
  let str₁ := std_structure.mk s α, let str₂ := std_structure.mk t β,
  fapply equiv.mk,
  /- We define `F : (Σ (f : Π x, s x ≅ t x), std_str.H α β (λ x, (f x).hom) and`
                                            `std_str.H β α (λ x, (f x).inv)) -> (str₁ ≅ str₂)`. -/
  { intro iso_H,
    fapply iso.mk,
    { exact ⟨λ x, (iso_H.1 x).hom, iso_H.2.1⟩ },
    { exact ⟨λ x, (iso_H.1 x).inv, iso_H.2.2⟩ },
    { apply hom_eq_C_std _ _, repeat { rwr comp_hom_std_C }, hsimp,
      apply eq_of_homotopy, intro x, hsimp, rwr (iso_H.1 x).r_inv },
    { apply hom_eq_C_std _ _, repeat { rwr comp_hom_std_C }, hsimp,
      apply eq_of_homotopy, intro x, hsimp, rwr (iso_H.1 x).l_inv } },
  { fapply adjointify,
    /- Now we define `G : (str₁ ≅ str₂) -> (Σ (f : Π x, s x ≅ t x), std_str.H α β (λ x, (f x).hom) and`
                                            `std_str.H β α (λ x, (f x).inv))`. -/
    { intro f,
      fapply sigma.mk,
      { exact iso_std_C f },
      { exact (f.hom.2, f.inv.2) } },
    /- `r_inv : ∀ f : str₁ ≅ str₂, F (G f) = f` -/
    { intro f,
      apply hom_eq_to_iso_eq, apply hom_eq_C_std _ _,
      hsimp, refl },
    /- `l_inv : ∀ iso_H : (Σ (f : Π x, s x ≅ t x), std_str.H α β (λ x, (f x).hom) and`
                                            `std_str.H β α (λ x, (f x).inv)), G (F iso_H)) = iso_H` -/
    { intro iso_H,
      fapply sigma_eq,
      { apply eq_of_homotopy, intro x, apply hom_eq_to_iso_eq, refl },
      { apply pathover_of_eq_tr, exact is_prop.elim _ _ } } }
end

/- The last equivalence introduces the structure components in standard structures isomorphies. -/
@[hott]
def std_str_comp_iso {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  {str₁ str₂ : std_structure std_str} :
  (str₁ ≅ str₂) ≃ (std_structure.mk str₁.carrier str₁.str ≅ std_structure.mk str₂.carrier str₂.str) :=
begin hinduction str₁ with s α, hinduction str₂ with t β, exact equiv.rfl end

/- Finally, we show that the composition of the five equivalences is `idtoiso`. -/
@[hott]
def comp_eqv_idtoiso {C : Type u} [category.{v} C] {std_str : std_structure_on C}
  {str₁ str₂ : std_structure std_str} (p : str₁ = str₂) :
        (std_str_comp_iso.to_fun⁻¹ᶠ (str_iso_eq_comp.to_fun (strpair_id_to_iso.to_fun
                            (std_str_eq_eta.to_fun (std_str_comp_eq.to_fun p))))) = idtoiso p :=
begin
  hinduction p, hinduction str₁ with s α,
  let str := std_structure.mk s α,
  have p₁ : std_str_comp_eq.to_fun (refl str) = refl str, from rfl,
  have p₂ : std_str_eq_eta.to_fun (refl str) = ⟨refl s, idpo⟩, from rfl,
  have p₃ : strpair_id_to_iso.to_fun ⟨refl s, idpo⟩ =
            ⟨λ x, id_is_iso (s x), (std_str.id_H α, std_str.id_H α)⟩, from rfl,
  have p₄ : str_iso_eq_comp.to_fun ⟨λ x, id_is_iso (s x), (std_str.id_H α, std_str.id_H α)⟩ = id_is_iso str,
    by apply hom_eq_to_iso_eq; refl,
  rwr idtoiso_refl_eq, rwr p₁, rwr p₂, rwr p₃, rwr p₄
end

/- Now we can prove the equivalence and thus the Structure Identity Principle. -/
@[hott]
def std_str_eq_eqv_iso {C : Type u} [category.{v} C] {std_str : std_structure_on C} :
  ∀ x y : std_structure std_str, (x = y) ≃ (x ≅ y) :=
assume x y, std_str_comp_eq ⬝e std_str_eq_eta ⬝e strpair_id_to_iso ⬝e
            str_iso_eq_comp ⬝e std_str_comp_iso⁻¹ᵉ

@[hott, instance]
def structure_identity_principle {C : Type u} [category.{v} C] (std_str : std_structure_on C) :
  category (std_structure std_str) :=
have idtoiso_eq : ∀ x y : std_structure std_str, (std_str_eq_eqv_iso x y).to_fun = @idtoiso _ _ x y, from
  begin
    intros x y, apply eq_of_homotopy,
    intro p, exact comp_eqv_idtoiso p
  end,
have idtoiso_eqv : ∀ x y : std_structure std_str, is_equiv (@idtoiso _ _ x y), from
  assume x y,
  have eqv : is_equiv (std_str_eq_eqv_iso x y).to_fun, from (std_str_eq_eqv_iso x y).to_is_equiv,
  by rwr idtoiso_eq x y at eqv; exact eqv,
category.mk idtoiso_eqv

/- The forgetful functor from a category of multi-sorted standard structures to the underlying
   product category, with one object of the underlying category as a factor for each sort.

   Even if the underlying category of the standard structure has products, the forgetful
   functor should not map to the product of the objects corresponding to the sorts: The
   forgetful functor may not be faithful, as it's not clear how to get back the component
   morphisms from the morphisms between products - this only works if projections are epic, for
   example if the category has a zero = initial + terminal objects. But that's not the case
   already for sets.

   The product category is implemented as the functor category from the discrete set of sorts
   to the underlying category. -/
@[hott]
def forget_str {C : Type u} [category.{v} C] (std_str : std_structure_on C) :
  (std_structure std_str) ⥤ ((discrete std_str.S) ⥤ C) :=
begin
  fapply functor.mk,
  { intro str, exact discrete.functor str.carrier }, -- map of objects
  { intros str₁ str₂ f, exact discrete.nat_trans (λ s, f.1 s) }, -- map of morphisms
  { intro str₁, apply nat_trans_eq, refl },  -- preserves identity morphisms
  { intros str₁ str₂ str₃ f g, apply nat_trans_eq, refl }
                                                     -- preserves compositions of morphisms
end

/- The forgetful functor is faithful. -/
@[hott]
def forget_is_faithful {C : Type u} [category.{v} C] (std_str : std_structure_on C) :
  is_faithful_functor _ _ (forget_str std_str) :=
begin
  intros str₁ str₂ f₁ f₂ p, fapply sigma.sigma_eq,
  { apply eq_of_homotopy, intro s, exact apd10 (ap nat_trans.app p) s },
  { apply pathover_of_tr_eq, exact is_prop.elim _ _ }
end

/- We want to construct limits of diagrams of standard structures fom the limits of the associated
   diagrams in the underlying ategory indexed by the sorts. In principle these diagrams can be
   retrieved from the forgetful functor, but it is more effective to construct them directly:
   A `J`-diagram of standard structures yields a tupel of `J`-diagrams in the underlying category,
   indexed by the sorts. -/
@[hott]
def forget_diagram {J : Type.{u'}} [precategory.{v'} J] {C : Type u} [category.{v} C]
  {std_str : std_structure_on C} (F : J ⥤ std_structure std_str) : Π x : std_str.S, J ⥤ C :=
begin
  intro x,
  fapply functor.mk,
  { intro j, exact (F.obj j).carrier x },
  { intros j k f, exact (F.map f).1 x },
  { intro j, change (F.map (𝟙 j)).1 x = 𝟙 ((F.obj j).carrier x), rwr functor.map_id },
  { intros j k l f g, change (F.map (f ≫ g)).1 x  = ((F.map f).1 x) ≫ ((F.map g).1 x),
    rwr functor.map_comp }
end

/- Next, we extract cones in the underlying category indexed by the sorts from a cone of standard structures. -/
@[hott, reducible]
def str_cone_to_sort_cones {J : Set.{u'}} [precategory.{v'} J] {C : Type u} [category.{v} C]
  {std_str : std_structure_on C} {F : J ⥤ (std_structure std_str)} (s : cone F) :
  Π x : std_str.S, cone (forget_diagram F x) :=
begin
  intro x, fapply cone.mk,
  { exact s.X.carrier x },  -- vertex
  { fapply nat_trans.mk,
    { intro j, exact (s.π.app j).1 x },  --transformation of objects
    { intros j k f, hsimp, change (s.π.app k).1 x = (λ x, (s.π.app j).1 x ≫ (F.map f).1 x) x,
      rwr <- apd10 (comp_hom_std_C _ _) x, rwr <- ap sigma.fst (s.π.naturality f),
      rwr precategory.id_comp } }  --naturality
end

/- We can construct the limit cone of a diagram of standard structures from the limit cones of the diagrams of the
   underlying category associated to the sorts if (and only if, but we won' proof that)
   - the tupel of vertices of the limit cones carries a structure,
   - the tupel of leg morphisms of the limit cones associated to each diagram arrow respects the structures,
   - the tupel of lifting morphisms from the vertices of cones associated to each sort to the vertices of the limit
     cones respect the structures.

   To show this we collect the data of this criterion in a type: -/
@[hott]
structure limit_cone_str_data {J : Set.{u'}} [precategory.{v'} J] {C : Type u}
  [category.{v} C] {std_str : std_structure_on C} {F : J ⥤ (std_structure std_str)}
  (lc : Π x : std_str.S, limit_cone (forget_diagram F x)) :=
(lc_str : std_str.P (λ x, (lc x).cone.X))
(lc_legs_H : Π (j : J), std_str.H lc_str ((F.obj j).str) (λ x, (lc x).cone.π.app j))
(lift_H : Π (s : cone F), std_str.H s.X.str lc_str (λ x, (lc x).is_limit.lift (str_cone_to_sort_cones s x)))

@[hott]
def str_limit_cone {J : Set.{u'}} [precategory.{v'} J] {C : Type u} [category.{v} C]
  {std_str : std_structure_on C} {F : J ⥤ (std_structure.{v u w} std_str)}
  (lc : Π x : std_str.S, limit_cone (forget_diagram F x)) (lcd : limit_cone_str_data lc) : limit_cone F :=
begin
  fapply limit_cone.mk,
  { fapply cone.mk, -- the limit cone
    { exact std_structure.mk (λ x, (lc x).cone.X) lcd.lc_str },
    { fapply nat_trans.mk,
      { intro j,
        exact ⟨λ x, (lc x).cone.π.app j, lcd.lc_legs_H j⟩ },
      { intros j k f, hsimp,
        apply @hom_eq_C_std _ _ _ (std_structure.mk (λ x, (lc x).cone.X) lcd.lc_str) (F.obj k),
        rwr comp_hom_std_C, hsimp, apply eq_of_homotopy, intro x, hsimp,
        have H : (lc x).cone.π.app k = (𝟙 (lc x).cone.X) ≫ (lc x).cone.π.app k, by rwr precategory.id_comp,
        rwr H, exact (lc x).cone.π.naturality f } } },
  { fapply is_limit.mk, -- the limit cone is a limit
    { intro s,
      exact ⟨λ x, (lc x).is_limit.lift (str_cone_to_sort_cones s x), lcd.lift_H s⟩ },
    { intros s j, apply hom_eq_C_std, rwr comp_hom_std_C, hsimp, apply eq_of_homotopy, intro x,
      change (lc x).is_limit.lift (str_cone_to_sort_cones s x) ≫ (lc x).cone.π.app j = (s.π.app j).fst x,
      exact (lc x).is_limit.fac (str_cone_to_sort_cones s x) j },
    { intros s m fac_m, apply hom_eq_C_std, hsimp, apply eq_of_homotopy, intro x,
      have fac_m1 : ∀ j : J, m.1 x ≫ (lc x).cone.π.app j = (str_cone_to_sort_cones s x).π.app j, from
        begin intro j, change _ = (s.π.app j).1 x, rwr <- apd10 (ap sigma.fst (fac_m j)) x end,
      exact (lc x).is_limit.uniq (str_cone_to_sort_cones s x) (m.1 x) fac_m1 } }
end

@[hott]
def str_has_limit {J : Set.{u'}} [precategory.{v'} J] {C : Type u} [category.{v} C]
  [has_limits_of_shape J C] {std_str : std_structure_on C} (F : J ⥤ (std_structure std_str))
  (lcd : limit_cone_str_data (λ x, get_limit_cone (forget_diagram F x))) : has_limit F :=
has_limit.mk (str_limit_cone (λ x, get_limit_cone (forget_diagram F x)) lcd)

@[hott, instance]
def std_structure_has_limits_of_shape {J : Set.{u'}} [precategory.{v'} J] {C : Type u}
  [category.{v} C] [has_limits_of_shape J C] {std_str : std_structure_on C}
  (lcd_F : Π F : J ⥤ (std_structure std_str), limit_cone_str_data
                                                (λ x, get_limit_cone (forget_diagram  F x))) :
  has_limits_of_shape J (std_structure std_str) :=
has_limits_of_shape.mk (λ F, str_has_limit F (lcd_F F))

open signature

/- We define structures of a given signature over a category `C` with products. -/
@[hott]
structure Sig_structure_on {sign : fo_signature} {C : Type u} [category.{v} C]
  [has_products.{v u 0} C] (car : sign.sorts -> C) :=
( ops : ∀ o : sign.ops, ∏ (λ a : sign.ops_arity o, car (sign.ops_source o a)) ⟶
                                                                        car (sign.ops_target o) )
( rels : ∀ r : sign.rels, subobject (∏ (λ a : sign.rels_arity r, car (sign.rels_comp a))) )

@[hott]
def Sig_str_eq {sign : fo_signature} {C : Type u} [category.{v} C]
  [has_products.{v u 0} C] {car : sign.sorts -> C} {S T : Sig_structure_on car} :
  (S.ops = T.ops) -> (S.rels = T.rels) -> S = T :=
begin
  hinduction S with ops₁ rels₁, hinduction T with ops₂ rels₂, hsimp,
  intros ops_eq rels_eq, exact ap011 Sig_structure_on.mk ops_eq rels_eq
end

@[hott]
def Sig_str_eq_eta {sign : fo_signature} {C : Type u} [category.{v} C]
  [has_products.{v u 0} C] {car : sign.sorts -> C} {S T : Sig_structure_on car} (p : S = T) :
  Sig_str_eq (ap Sig_structure_on.ops p) (ap Sig_structure_on.rels p) = p :=
begin hinduction p, hinduction S, refl end

@[hott, instance]
def is_set_Sig_str_on {sign : fo_signature} {C : Type u} [category.{v} C]
  [has_products.{v u 0} C] (car : sign.sorts -> C) : is_set (Sig_structure_on car) :=
begin
  fapply is_set.mk, intros x y p q,
  rwr <- Sig_str_eq_eta p, rwr <- Sig_str_eq_eta q,
  apply ap011 Sig_str_eq, apply is_set.elim, apply is_set.elim
end

@[hott]
structure is_Sig_structure_hom {sign : fo_signature} {C : Type u} [category.{v} C]
  [has_products.{v u 0} C] {car₁ car₂ : sign.sorts -> C} (S₁ : Sig_structure_on car₁)
  (S₂ : Sig_structure_on car₂) (f : Π x : sign.sorts, car₁ x ⟶ car₂ x) :=
( ops_pres : Π o : sign.ops, S₁.ops o ≫ f (sign.ops_target o) =
                                               (∏h (λ a, f (sign.ops_source o a))) ≫ S₂.ops o )
( rels_pres : Π r : sign.rels, Σ h : (S₁.rels r).obj ⟶ (S₂.rels r).obj,
    (S₁.rels r).hom ≫ (∏h (λ a, f (sign.rels_comp a))) = h ≫ (S₂.rels r).hom )

@[hott, instance]
def is_prop_is_Sig_structure_hom {sign : fo_signature} {C : Type u} [category.{v} C]
  [has_products.{v u 0} C] {car₁ car₂ : sign.sorts -> C} {S₁ : Sig_structure_on car₁}
  {S₂ : Sig_structure_on car₂} (f : Π x : sign.sorts, car₁ x ⟶ car₂ x) :
  is_prop (is_Sig_structure_hom S₁ S₂ f) :=
begin
  fapply is_prop.mk, intros h₁ h₂, hinduction h₁ with op₁ rp₁, hinduction h₂ with op₂ rp₂,
  fapply ap011 is_Sig_structure_hom.mk,
  { apply eq_of_homotopy, intro o, exact is_prop.elim _ _ },
  { apply eq_of_homotopy, intro r, fapply sigma.sigma_eq,
    { exact (S₂.rels r).is_mono _ (rp₁ r).1 (rp₂ r).1 ((rp₁ r).2⁻¹⬝(rp₂ r).2) },
    { apply pathover_of_tr_eq, exact is_prop.elim _ _ } }
end

@[hott]
def id_is_Sig_str_hom {sign : fo_signature} {C : Type u} [category.{v} C]
  [has_products.{v u 0} C] {car : sign.sorts -> C} (S : Sig_structure_on car) :
  is_Sig_structure_hom S S (λ x, 𝟙 (car x)) :=
begin
  fapply is_Sig_structure_hom.mk,
  { intro o, rwr pi_hom_id, hsimp },
  { intro r, fapply dpair, exact 𝟙 (S.rels r).obj, rwr pi_hom_id, hsimp }
end

@[hott]
def std_str_of_Sig_str (sign : fo_signature) (C : Type u) [category.{v} C]
  [has_products.{v u 0} C] : std_structure_on C :=
begin
  fapply std_structure_on.mk,
  { exact sign.sorts }, --sorts
  { exact λ car : sign.sorts -> C, Sig_structure_on car }, --structure
  { intros x y S T h,
    exact prop_resize (to_Prop (is_Sig_structure_hom S T h)) }, --homomorphisms
  { intros car S, apply prop_to_prop_resize, fapply is_Sig_structure_hom.mk,
    { intro o, hsimp, rwr pi_hom_id, hsimp },
    { intro r, rwr pi_hom_id, fapply dpair, exact 𝟙 (S.rels r).obj, hsimp } }, --identity
  { intros car₁ car₂ car₃ S T U f g is_hom_f is_hom_g, apply prop_to_prop_resize,
    fapply is_Sig_structure_hom.mk,
    { intro o, rwr <- precategory.assoc,
      rwr (prop_resize_to_prop is_hom_f).ops_pres o, rwr precategory.assoc,
      rwr (prop_resize_to_prop is_hom_g).ops_pres o, rwr <- precategory.assoc,
      rwr pi_hom_comp },
    { intros r,
      let h₁ := ((prop_resize_to_prop is_hom_f).rels_pres r).1,
      let p₁ := ((prop_resize_to_prop is_hom_f).rels_pres r).2,
      let h₂ := ((prop_resize_to_prop is_hom_g).rels_pres r).1,
      let p₂ := ((prop_resize_to_prop is_hom_g).rels_pres r).2,
      fapply dpair,
      { exact h₁ ≫ h₂ },
      { rwr <- pi_hom_comp, rwr <- precategory.assoc, rwr p₁, rwr precategory.assoc, rwr p₂,
        rwr <- precategory.assoc } } }, --composition
  { intros car S T, fapply equiv.mk,
    { intro Sig_homs,
      hinduction S with ops₁ rels₁, hinduction T with ops₂ rels₂,
      fapply ap011 Sig_structure_on.mk,
      { apply eq_of_homotopy, intro o,
        rwr <- precategory.id_comp (ops₂ o), rwr <- precategory.comp_id (ops₁ o),
        rwr <- pi_hom_id, exact (prop_resize_to_prop Sig_homs.1).ops_pres o },
      { apply eq_of_homotopy, intro r, apply (iso_mono_to_equal_subobj _ _),
        apply (homs_eqv_iso_of_monos _ _).to_fun, fapply pair,
        { fapply hom_of_monos.mk,
          { exact ((prop_resize_to_prop Sig_homs.1).rels_pres r).1 },
          { let p₁ := ((prop_resize_to_prop Sig_homs.1).rels_pres r).2, rwr <- p₁, rwr pi_hom_id,
            hsimp } },
        { fapply hom_of_monos.mk,
          { exact ((prop_resize_to_prop Sig_homs.2).rels_pres r).1 },
          { let p₂ := ((prop_resize_to_prop Sig_homs.2).rels_pres r).2, rwr <- p₂, rwr pi_hom_id,
            hsimp } } } },
    { fapply adjointify,
      { intro Sig_str_eq, rwr Sig_str_eq, apply pair,
        exact prop_to_prop_resize (id_is_Sig_str_hom T),
        exact prop_to_prop_resize (id_is_Sig_str_hom T) },
      { intro b, exact is_set.elim _ _ },
      { intro a, exact is_prop.elim _ _ } } } --standard structure
end

@[hott, reducible]
def Sig_structure (sign : fo_signature) (C : Type u) [category.{v} C] [has_products.{v u 0} C] :=
  std_structure (std_str_of_Sig_str sign C)

@[hott, instance]
def Sig_str_precategory (sign : fo_signature) (C : Type u) [category.{v} C] [has_products.{v u 0} C] :
  precategory (Sig_structure sign C) :=
std_str_precategory (std_str_of_Sig_str sign C)

@[hott, instance]
def Sig_str_category (sign : fo_signature) (C : Type u) [category.{v} C] [has_products.{v u 0} C] :
  category (Sig_structure sign C) :=
structure_identity_principle (std_str_of_Sig_str sign C)

end categories

end hott