import sets.algebra init2 sets.axioms

universes v v' u u' w
hott_theory

namespace hott
open hott.eq hott.set hott.subset hott.is_trunc hott.is_equiv hott.equiv

/- Categories in the algebraic hierarchy are categories of structured sets. The structures can
   be constructed by an instance of a more general technique: as the model structure of an
   (algebraic) first-order theory built on a first-order signature in a category with suitable
   properties. The Ω-structures made up of functions and relations on sets in [HoTT-Book],
   Sec.9.8) are another example of this technique, but the more general construction also
   allows the construction of categories of topological groups or locally ringed sheaves.

   We mainly follow the introduction to categorical model theory by [Caramello14].

   First-order signatures prescribe the types of arguments and the arity of functions and
   relations in a first-order theory.

   For infinitary conjunctions and disjunctions we need index sets, which we fix to universe
   level 0 and only allow a choice from a set of universe level 0, to avoid universe problems.
   The idea of a Grothendieck universe or a von Neumann universe/cumulitative hierarchy does
   not help because we cannot quantify over a type of universe level 0 without raising the
   universe level to 1.

   We also need a restriction on contexts because too large sets of variables may not
   allowed to be index sets of products in interpreting categories. -/
namespace signature

@[hott]
structure var (labels : Set.{0}) (sorts : Set.{0}) :=
  (label : labels)
  (sort : sorts)

/- The following three lemmas should be produced automatically. -/
@[hott]
def var_eq {labels : Set.{0}} {sorts : Set.{0}} {v₁ v₂ : var labels sorts} :
  (v₁.label = v₂.label) -> (v₁.sort = v₂.sort) -> (v₁ = v₂) :=
begin
  intros p_label p_sort,
  hinduction v₁ with l₁ s₁, hinduction v₂ with l₂ s₂,
  exact ap011 var.mk p_label p_sort
end

@[hott]
def var_eq_eta {labels : Set.{0}} {sorts : Set.{0}} {v₁ v₂ : var labels sorts} (p : v₁ = v₂) :
  var_eq (ap var.label p) (ap var.sort p) = p :=
begin hinduction p, hinduction v₁, reflexivity end

@[hott, instance]
def var_is_set {labels : Set.{0}} {sorts : Set.{0}}  : is_set (var labels sorts) :=
begin
  fapply is_set.mk, intros x y p q,
  rwr <- var_eq_eta p, rwr <- var_eq_eta q,
  apply ap011 var_eq, apply is_set.elim, apply is_set.elim
end

@[hott]
structure fo_signature :=
  (sorts : Set.{0})
  (var_labels : Set.{0})
  (cont_pred : Subset (to_Set (var var_labels sorts)) -> trunctype.{0} -1)
                       -- This prescribes which sets of variables are allowed as contexts
  (ops : Set.{0})
  (ops_arity : Π (o : ops), Set.{0})
  (ops_source : Π (o : ops), ops_arity o -> sorts)
  (ops_target : Π (o : ops), sorts)
  (rels : Set.{0})
  (rels_arity : Π (r : rels), Set.{0})
  (rels_comp : Π {r : rels}, rels_arity r -> sorts)
  (I : Set.{0})
  (V : I -> Set.{0}) --sets over which infinite dis/conjunction can be taken, indexed by `I`

@[hott]
inductive term_of_sort {sign : fo_signature} : sign.sorts -> Type
| var : Π (s : sign.sorts) (v : var sign.var_labels sign.sorts), (v.sort = s) ->
                                                                          term_of_sort s
| op : Π (s : sign.sorts) (f : sign.ops) (p : sign.ops_target f = s)
         (args : Π (k : sign.ops_arity f), term_of_sort (sign.ops_source f k)),
         term_of_sort s

namespace term

@[hott]
structure term (sign : fo_signature) :=
  (sort : sign.sorts)
  (term : term_of_sort sort)

@[hott]
def term_eq_sort {sign : fo_signature} {term₁ term₂ : term sign} :
  term₁ = term₂ -> term₁.sort = term₂.sort :=
assume p, ap term.sort p

@[hott]
def term_eq_term {sign : fo_signature} {term₁ term₂ : term sign} :
  Π (q : term₁ = term₂), term₁.term =[term_eq_sort q] term₂.term :=
begin intro q, hinduction q, exact idpo end

@[hott]
protected def code {sign : fo_signature} :
  term sign -> term sign -> Type :=
begin
  intro term₁, hinduction term₁ with s₁ t₁, hinduction t₁,
  { intro term₂, hinduction term₂ with s₂ t₂, hinduction t₂,
    exact v = v_1, exact Zero },
  { intro term₂, hinduction term₂ with s₂ t₂, hinduction t₂,
    { exact Zero },
    { exact Σ (q : f = f_1), Π k, ih k (⟨_, args_1 (q ▸ k)⟩) } }
end

@[hott, instance]
def code_is_prop  {sign : fo_signature} :
  Π term₁ term₂ : term sign, is_prop (term.code term₁ term₂) :=
begin
  intro term₁, hinduction term₁ with s₁ t₁, hinduction t₁ with s v p,
  { intro term₂, hinduction term₂ with s₂ t₂, hinduction t₂ with s v' p',
    { change is_prop (v = v'), apply is_prop.mk, intros q q', exact is_set.elim _ _ },
    { change is_prop Zero, apply_instance } },
  { intro term₂, hinduction term₂ with s₂ t₂,
    hinduction t₂ with s v' p' s f' p' args' ih',
    { change is_prop Zero, apply_instance },
    { apply is_prop.mk, intros t₁_code t₂_code, fapply sigma.sigma_eq,
      { exact is_set.elim _ _ },
      { apply pathover_of_tr_eq, apply tr_eq_of_eq_inv_tr,
        apply eq_of_homotopy, intro k, exact @is_prop.elim _ (ih k _) _ _ } } }
end

@[hott]
protected def refl {sign : fo_signature} : Π t : term sign, term.code t t :=
begin
  intro term, hinduction term with s t, hinduction t,
  exact rfl , exact ⟨rfl, λ k, ih k⟩
end

@[hott]
def encode {sign : fo_signature} {term₁ term₂ : term sign}
  (p : term₁ = term₂) : term.code term₁ term₂ :=
p ▸ (term.refl term₁)

@[hott, hsimp]
def decode {sign : fo_signature} :
  Π {term₁ term₂ : term sign}, term.code term₁ term₂ -> term₁ = term₂ :=
begin
  intro term₁, hinduction term₁ with s₁ t₁, hinduction t₁,
  { intro term₂, hinduction term₂ with s₂ t₂, hinduction t₂,
    { intro t_code,
      have q : v = v_1, from t_code, hinduction q,
      have r : s = s_1, from a⁻¹ ⬝ a_1, hinduction r,
      fapply apd011 term.mk, exact rfl, apply pathover_idp_of_eq,
      exact ap (term_of_sort.var s v) (is_set.elim _ _) },
    { intro t_code, hinduction t_code } },
  { intro term₂, hinduction term₂ with s₂ t₂, hinduction t₂,
    { intro t_code, hinduction t_code },
    { intro t_code, hinduction t_code with q args_code, hinduction q,
      have r : s = s_1, from p⁻¹ ⬝ p_1, hinduction r,
      have r' : p = p_1, from is_prop.elim _ _, hinduction r',
      fapply apd011 term.mk, exact rfl, apply pathover_idp_of_eq,
      apply ap (term_of_sort.op s f p), apply eq_of_homotopy, intro k, hsimp,
      have q : term.mk _ (args k) = term.mk _ (args_1 k), from ih k (args_code k),
      have p' : term_eq_sort q = idp, from is_set.elim _ _,
      let q'' := term_eq_term q, rwr p' at q'', exact eq_of_pathover_idp q'' } }
end

@[hott]
def code_is_contr_to_refl {sign : fo_signature} (term₁ : term sign) :
  Π (t_code : Σ (term₂ : term sign), term.code term₁ term₂), t_code =
                                                           ⟨term₁, term.refl term₁⟩ :=
begin
  intro t_code, fapply sigma.sigma_eq,
  { exact (decode t_code.2)⁻¹ },
  { apply pathover_of_tr_eq, exact is_prop.elim _ _ }
end

@[hott, instance]
def code_is_contr {sign : fo_signature} (term₁ : term sign) :
  is_contr (Σ (term₂ : term sign), term.code term₁ term₂) :=
is_contr.mk _ (λ t_code, (code_is_contr_to_refl term₁ t_code)⁻¹)

@[hott, instance]
def term_is_set {sign : fo_signature} : is_set (term sign) :=
begin
  apply is_trunc_succ_intro, intros term₁ term₂,
  have eqv : (term₁ = term₂) ≃ (term.code term₁ term₂), from
    equiv.mk _ (tot_space_contr_id_equiv ⟨term.code term₁, term.refl term₁⟩
                                         (code_is_contr term₁) term₂),
  exact is_trunc_equiv_closed_rev -1 eqv (code_is_prop _ _)
end

end term

open term

/- Terms of a specific sort also form a set. -/
@[hott]
def term_eq {sign : fo_signature} {term₁ term₂ : term sign} :
  Π (p : term₁.sort = term₂.sort), (term₁.term =[p] term₂.term) -> (term₁ = term₂) :=
begin
  intros p q, hinduction term₁ with s₁ t₁, hinduction term₂ with s₂ t₂,
  exact apd011 term.mk p q
end

@[hott]
def term_of_sort_of_term {sign : fo_signature} (s : sign.sorts) :
  (term_of_sort s) ≃ (Σ (t : term sign), t.sort = s) :=
begin
  fapply equiv.mk,
  { intro t, exact ⟨term.mk s t, rfl⟩ },
  { fapply adjointify,
    { intro t, exact t.2 ▸ t.1.term },
    { intro t, hsimp, fapply sigma.sigma_eq,
      { fapply term_eq,
        { hsimp, exact t.2⁻¹ },
        { hsimp, apply pathover_of_tr_eq, rwr idp_inv, hsimp } },
      { apply pathover_of_tr_eq, exact is_set.elim _ _ } },
    { intro t, hsimp } }
end

@[hott, instance]
def term_of_sort_is_set {sign : fo_signature} (s : sign.sorts) :
  is_set (term_of_sort s) :=
begin apply is_trunc_equiv_closed_rev 0 (term_of_sort_of_term s), apply_instance end

/- To define formulas we need the free variables of a term. -/
@[hott]
def free_vars_of_term {sign : fo_signature} : term sign ->
  Subset (to_Set (var sign.var_labels sign.sorts)) :=
begin
  intro t, hinduction t, hinduction term,
  { exact elem_to_Subset v },
  { exact iUnion ih }
end

/- Terms and later formulas and sequents should always only contain free variables from a
   `context`. -/
@[hott]
structure context (sign : fo_signature) :=
  (vars : Subset (to_Set (var sign.var_labels sign.sorts)))
  (pred : sign.cont_pred vars)

@[hott]
def context_eq {sign : fo_signature} {cont₁ cont₂ : context sign} :
  (cont₁.vars = cont₂.vars) -> (cont₁ = cont₂) :=
begin
  intro p_vars,
  hinduction cont₁ with vars₁ pred₁, hinduction cont₂ with vars₂ pred₂,
  apply apd011 context.mk p_vars, apply pathover_of_tr_eq, exact is_prop.elim _ _
end

@[hott]
def context_eq_refl {sign : fo_signature} (cont : context sign) :
  context_eq (@idp _ (cont.vars)) = (@idp _ cont) :=
begin
  hinduction cont, hsimp, change apd011 context.mk (@idp _ vars) _ = _,
  have H' : is_prop.elim ((@idp _ vars) ▸[λ v, sign.cont_pred v] pred) pred = idp, from
    is_set.elim _ _,
  rwr H'
end

@[hott]
def context_eq_eta {sign : fo_signature} {cont₁ cont₂ : context sign} (p : cont₁ = cont₂) :
  context_eq (ap context.vars p) = p :=
begin hinduction p, hsimp, exact context_eq_refl cont₁ end

@[hott, instance]
def context_is_set {sign : fo_signature} : is_set (context sign) :=
begin
  fapply is_set.mk, intros x y p q,
  rwr <- context_eq_eta p, rwr <- context_eq_eta q,
  apply ap context_eq, apply is_set.elim
end

@[hott]
structure term_in_context {sign : fo_signature} (cont : context sign) :=
  (t : term sign)
  (in_cont : free_vars_of_term t ⊆ cont.vars)

/- Formulas in the first-order language built upon a first-order signature, together with
   the free variables that they contain, are defined inductively.   -/
namespace formula

@[hott]
inductive formula (sign : fo_signature)
| eq_terms : Π (t₁ t₂ : term sign), (t₁.sort = t₂.sort) -> formula
| rel_terms : Π (r : sign.rels)
       (comp : Π (k : sign.rels_arity r), term_of_sort (sign.rels_comp k)), formula
| T : formula
| F : formula
| conj : formula -> formula -> formula
| disj : formula -> formula -> formula
| impl : formula -> formula -> formula
| neg : formula -> formula
| ex : var sign.var_labels sign.sorts -> formula -> formula
| univ : var sign.var_labels sign.sorts -> formula -> formula
| inf_conj : Π (i : sign.I), (sign.V i -> formula) -> formula
| inf_disj : Π (i : sign.I), (sign.V i -> formula) -> formula

@[hott]
protected def code {sign : fo_signature} : formula sign -> formula sign -> Type :=
/- A match-expression does not work because we need proper induction. -/
begin
  intro form₁, hinduction form₁ with t₁ t₂ p r comp f₁ f₁',
  { all_goals { intro form₂, hinduction form₂ with t₁' t₂' p' }, --equality of terms
    all_goals { try { exact (t₁ = t₁') × (t₂ = t₂') } },
    all_goals { exact Zero } },
  { all_goals { intro form₂, hinduction form₂ with t₁' t₂' p' }, --relations
    all_goals { try { exact Σ (q : r = r_1),
      comp =[q; λ s, Π (k : sign.rels_arity s), term_of_sort (sign.rels_comp k)] comp_1 } },
    all_goals { exact Zero } },
  { all_goals { intro form₂, hinduction form₂ with t₁' t₂' p' }, --T
    exact Zero, exact Zero, exact One, all_goals { exact Zero } },
  { all_goals { intro form₂, hinduction form₂ with t₁' t₂' p' }, --F
    exact Zero, exact Zero, exact Zero, exact One, all_goals { exact Zero } },
  { all_goals { intro form₂, hinduction form₂ with t₁' t₂' p' }, --conj
    exact Zero, exact Zero, exact Zero, exact Zero, exact prod (ih_a a) (ih_a_1 a_1),
    all_goals { exact Zero } },
  { all_goals { intro form₂, hinduction form₂ with t₁' t₂' p' }, --disj
    exact Zero, exact Zero, exact Zero, exact Zero, exact Zero,
    exact prod (ih_a a_2) (ih_a_1 a_3), all_goals { exact Zero } },
  { all_goals { intro form₂, hinduction form₂ with t₁' t₂' p' }, --impl
    exact Zero, exact Zero, exact Zero, exact Zero, exact Zero, exact Zero,
    exact prod (ih_a a_2) (ih_a_1 a_3), all_goals { exact Zero } },
  { all_goals { intro form₂, hinduction form₂ with t₁' t₂' p' }, --neg
    exact Zero, exact Zero, exact Zero, exact Zero, exact Zero, exact Zero, exact Zero,
    exact ih a_1, all_goals { exact Zero } },
  { all_goals { intro form₂, hinduction form₂ }, --ex
    exact Zero, exact Zero, exact Zero, exact Zero, exact Zero, exact Zero, exact Zero,
    exact Zero, exact prod (a = a_2) (ih a_3), exact Zero, exact Zero, exact Zero },
  { all_goals { intro form₂, hinduction form₂ }, --univ
    exact Zero, exact Zero, exact Zero, exact Zero, exact Zero, exact Zero, exact Zero,
    exact Zero, exact Zero, exact prod (a = a_2) (ih a_3), exact Zero, exact Zero },
  { all_goals { intro form₂, hinduction form₂ }, --inf_conj
    exact Zero, exact Zero, exact Zero, exact Zero, exact Zero, exact Zero, exact Zero,
    exact Zero, exact Zero, exact Zero,
    exact Σ (q : i = i_1), Π v : sign.V i, ih v (a_1 (q ▸ v)), exact Zero },
  { all_goals { intro form₂, hinduction form₂ }, --inf_disj
    exact Zero, exact Zero, exact Zero, exact Zero, exact Zero, exact Zero, exact Zero,
    exact Zero, exact Zero, exact Zero, exact Zero,
    exact Σ (q : i = i_1), Π v : sign.V i, ih v (a_1 (q ▸ v)) }
end

@[hott, instance]
def code_is_prop  {sign : fo_signature} :
  Π form₁ form₂ : formula sign, is_prop (formula.code form₁ form₂) :=
begin
  intro form₁, hinduction form₁ with term₁ term₂ p,
  all_goals { intro form₂, hinduction form₂ with term₁' term₂' p' },
  all_goals { try { exact Zero_is_prop } },
  all_goals { try { exact One_is_prop } },
  { apply is_prop.mk, intros q q', apply pair_eq,
      exact is_prop.elim _ _, exact is_prop.elim _ _ },
  { apply is_prop.mk, intros code₁ code₂,
    apply @sigma_Prop_eq (r = r_1) (λ q, to_Prop (comp =[q; λ s, Π (k : sign.rels_arity s),
                                                    term_of_sort (sign.rels_comp k)] comp_1)),
    exact is_set.elim _ _ },
  all_goals { try { apply is_prop.mk, intros code₁ code₂, apply pair_eq,
            exact @is_prop.elim _ (ih_a a_2) _ _, exact @is_prop.elim _ (ih_a_1 a_3) _ _ } },
  { apply is_prop.mk, intros code₁ code₂, exact @is_prop.elim _ (ih a_1) _ _ },
  all_goals { try { apply is_prop.mk, intros code₁ code₂, apply pair_eq,
              exact is_prop.elim _ _, exact @is_prop.elim _ (ih a_3) _ _ } },
  all_goals { try { apply is_prop.mk, intros code₁ code₂, fapply sigma.sigma_eq,
    exact is_prop.elim _ _ , apply pathover_of_tr_eq, apply eq_of_homotopy, intro v,
    exact @is_prop.elim _ (ih v (a_1 (code₂.fst ▸[λ i, sign.V i] v))) _ (code₂.2 v) } }
end

@[hott]
protected def refl {sign : fo_signature} : Π t : formula sign, formula.code t t :=
begin
  intro t, hinduction t, exact ⟨idp, idp⟩, exact ⟨idp, idpo⟩, exact One.star, exact One.star,
  exact ⟨ih_a, ih_a_1⟩, exact ⟨ih_a, ih_a_1⟩, exact ⟨ih_a, ih_a_1⟩, exact ih, exact ⟨idp, ih⟩,
  exact ⟨idp, ih⟩, exact ⟨idp, ih⟩, exact ⟨idp, ih⟩
end

@[hott]
def encode {sign : fo_signature} {form₁ form₂ : formula sign} (p : form₁ = form₂) :
  formula.code form₁ form₂ := p ▸ (formula.refl form₁)

@[hott, hsimp]
def decode {sign : fo_signature} :
  Π {form₁ form₂ : formula sign}, formula.code form₁ form₂ -> form₁ = form₂ :=
begin
  intro form₁, hinduction form₁,
  all_goals { intro form₂, hinduction form₂, all_goals { intro code, try { hinduction code } } },
  { fapply apd001, assumption, assumption, apply pathover_of_eq_tr, exact is_prop.elim _ _ },
  { exact apd011 formula.rel_terms fst snd },
  refl, refl,
  { exact ap011 formula.conj (ih_a fst) (ih_a_1 snd) },
  { exact ap011 formula.disj (ih_a fst) (ih_a_1 snd) },
  { exact ap011 formula.impl (ih_a fst) (ih_a_1 snd) },
  { exact ap formula.neg (ih code) },
  { exact ap011 formula.ex fst (ih snd) },
  { exact ap011 formula.univ fst (ih snd) },
  { fapply apd011 formula.inf_conj, exact fst, apply pathover_of_tr_eq,
    apply eq_of_homotopy, intro v, exact (tr_dep_fn_eval_tr fst v) ⬝ (ih (fst⁻¹ ▸ v)
                   (snd (fst⁻¹ ▸ v))) ⬝ (ap a_1 (@tr_inv_tr _ (λ i, sign.V i) _ _ fst v)) },
  { fapply apd011 formula.inf_disj, exact fst, apply pathover_of_tr_eq,
    apply eq_of_homotopy, intro v, exact (tr_dep_fn_eval_tr fst v) ⬝ (ih (fst⁻¹ ▸ v)
                   (snd (fst⁻¹ ▸ v))) ⬝ (ap a_1 (@tr_inv_tr _ (λ i, sign.V i) _ _ fst v)) }
end

@[hott]
def code_is_contr_to_refl {sign : fo_signature} (form₁ : formula sign) :
  Π (f_code : Σ (form₂ : formula sign), formula.code form₁ form₂), f_code =
                                                           ⟨form₁, formula.refl form₁⟩ :=
begin
  intro a_code, fapply sigma.sigma_eq,
  { exact (decode a_code.2)⁻¹ },
  { apply pathover_of_tr_eq, exact is_prop.elim _ _ }
end

@[hott, instance]
def code_is_contr {sign : fo_signature} (form₁ : formula sign) :
  is_contr (Σ (form₂ : formula sign), formula.code form₁ form₂) :=
is_contr.mk _ (λ f_code, (code_is_contr_to_refl form₁ f_code)⁻¹)

@[hott, instance]
def form_is_set {sign : fo_signature} : is_set (formula sign) :=
begin
  apply is_trunc_succ_intro, intros form₁ form₂,
  have eqv : (form₁ = form₂) ≃ (formula.code form₁ form₂), from
    equiv.mk _ (tot_space_contr_id_equiv ⟨formula.code form₁, formula.refl form₁⟩
                                         (code_is_contr form₁) form₂),
  exact is_trunc_equiv_closed_rev -1 eqv (code_is_prop _ _)
end

/- We use the class mechanism to implement the hierarchy of fragments in the first-order
   language given by the signature. -/
@[hott]
protected def atomic {sign : fo_signature} (φ : formula sign) : trunctype.{0} -1 :=
begin hinduction φ, exact True, exact True, all_goals {exact False} end

@[hott]
class is_atomic {sign : fo_signature} (φ : formula sign) :=
  (atom : formula.atomic φ)

@[hott]
protected def horn {sign : fo_signature} (φ : formula sign) : trunctype.{0} -1 :=
begin
  hinduction φ, exact True, exact True, exact True, exact False, exact ih_a and ih_a_1,
  all_goals {exact False}
end

@[hott]
class is_horn {sign : fo_signature} (φ : formula sign) :=
  (horn : formula.horn φ)

@[hott]
def atomic_implies_horn {sign : fo_signature} (φ : formula sign) :
  formula.atomic φ -> formula.horn φ :=
begin hinduction φ, all_goals { intro a; try { exact a }; hinduction a } end

@[hott, instance]
def atomic.to_horn {sign : fo_signature} (φ : formula sign) [H : is_atomic φ] : is_horn φ :=
  begin apply is_horn.mk, exact atomic_implies_horn φ H.atom end

@[hott]
protected def regular {sign : fo_signature} (φ : formula sign) : trunctype.{0} -1 :=
begin
  hinduction φ, exact True, exact True, exact True, exact False, exact ih_a and ih_a_1,
  exact False, exact False, exact False, exact ih, all_goals {exact False}
end

@[hott]
class is_regular {sign : fo_signature} (φ : formula sign) :=
  (reg : formula.regular φ)

@[hott]
def horn_implies_regular {sign : fo_signature} (φ : formula sign) :
  formula.horn φ -> formula.regular φ :=
begin
  hinduction φ, all_goals { intro h }, exact h, exact h, exact h, exact h,
  exact ⟨(ih_a h.1), (ih_a_1 h.2)⟩, all_goals { hinduction h }
end

@[hott, instance]
def horn.to_regular {sign : fo_signature} (φ : formula sign) [H : is_horn φ] : is_regular φ :=
  begin apply is_regular.mk, exact horn_implies_regular φ H.horn end

@[hott]
protected def coherent {sign : fo_signature} (φ : formula sign) : trunctype.{0} -1 :=
begin
  hinduction φ, exact True, exact True, exact True, exact True, exact ih_a and ih_a_1,
  exact ih_a and ih_a_1, exact False, exact False, exact ih, all_goals {exact False}
end

@[hott]
class is_coherent {sign : fo_signature} (φ : formula sign) :=
  (coh : formula.coherent φ)

@[hott]
def regular_implies_coherent {sign : fo_signature} (φ : formula sign) :
  formula.regular φ -> formula.coherent φ :=
begin
  hinduction φ, all_goals { intro r }, exact r, exact r, exact r, hinduction r,
  exact ⟨(ih_a r.1), (ih_a_1 r.2)⟩, hinduction r, hinduction r,
  hinduction r, exact ih r, all_goals { hinduction r }
end

@[hott, instance]
def regular.to_coherent {sign : fo_signature} (φ : formula sign) [H : is_regular φ] :
  is_coherent φ :=
begin apply is_coherent.mk, exact regular_implies_coherent φ H.reg end

@[hott]
protected def first_order {sign : fo_signature} (φ : formula sign) : trunctype.{0} -1 :=
begin
  hinduction φ, exact True, exact True, exact True, exact True, exact ih_a and ih_a_1,
  exact ih_a and ih_a_1, exact ih_a and ih_a_1, exact ih, exact ih, exact ih,
  all_goals {exact False}
end

@[hott]
class is_first_order {sign : fo_signature} (φ : formula sign) :=
  (fo : formula.first_order φ)

@[hott]
def coherent_implies_first_order {sign : fo_signature} (φ : formula sign) :
  formula.coherent φ -> formula.first_order φ :=
begin
  hinduction φ, all_goals { intro c }, exact c, exact c, exact c, exact c,
  exact ⟨(ih_a c.1), (ih_a_1 c.2)⟩, exact ⟨(ih_a c.1), (ih_a_1 c.2)⟩, hinduction c,
  hinduction c, exact ih c, all_goals { hinduction c }
end

@[hott, instance]
def coherent.to_first_order {sign : fo_signature} (φ : formula sign) [H : is_coherent φ] :
  is_first_order φ :=
begin apply is_first_order.mk, exact coherent_implies_first_order φ H.coh end

@[hott]
protected def geometric {sign : fo_signature} (φ : formula sign) : trunctype.{0} -1 :=
begin
  hinduction φ, exact True, exact True, exact True, exact True, exact ih_a and ih_a_1,
  exact ih_a and ih_a_1, exact False, exact False, exact ih, exact False, exact False,
  exact inf_conj ih
end

@[hott]
class is_geometric {sign : fo_signature} (φ : formula sign) :=
  (geom : formula.geometric φ)

@[hott]
def coherent_implies_geometric {sign : fo_signature} (φ : formula sign) :
  formula.coherent φ -> formula.geometric φ :=
begin
  hinduction φ, all_goals { intro c }, exact c, exact c, exact c, exact c,
  exact ⟨(ih_a c.1), (ih_a_1 c.2)⟩, exact ⟨(ih_a c.1), (ih_a_1 c.2)⟩, hinduction c,
  hinduction c, exact ih c, all_goals { hinduction c }
end

@[hott, instance]
def coherent.to_geometric {sign : fo_signature} (φ : formula sign) [H : is_coherent φ] :
  is_geometric φ :=
begin apply is_geometric.mk, exact coherent_implies_geometric φ H.coh end

/- Infinitary first-order formulas are just formulas and don't need a separate label. -/

@[hott]
protected def free_vars {sign : fo_signature} :
  formula sign -> Subset (to_Set (var sign.var_labels sign.sorts)) :=
begin
  intro form, hinduction form,
  { exact (free_vars_of_term t₁) ∪ (free_vars_of_term t₂) },
  { exact iUnion (λ (k : sign.rels_arity r), free_vars_of_term ⟨sign.rels_comp k, comp k⟩) },
  exact empty_Subset _, exact empty_Subset _,
  exact subset.union ih_a ih_a_1, exact subset.union ih_a ih_a_1,
  exact subset.union ih_a ih_a_1, exact ih, exact setminus ih (elem_to_Subset a),
  exact setminus ih (elem_to_Subset a), exact iUnion ih, exact iUnion ih
end

@[hott]
structure formula_in_context {sign : fo_signature} (cont : context sign) :=
  (φ : formula sign)
  (in_cont : formula.free_vars φ ⊆ cont.vars)

@[hott]
def formula_in_context_eq {sign : fo_signature} {cont : context sign}
  {φ₁ φ₂ : formula_in_context cont} :
  Π (p : φ₁.φ = φ₂.φ), φ₁.in_cont =[p; λ φ, formula.free_vars φ ⊆ cont.vars] φ₂.in_cont ->
  φ₁ = φ₂ :=
begin intros, hinduction φ₁, hinduction φ₂, apply apdd _ p a end

@[hott]
def formula_in_context_eq_eta {sign : fo_signature} {cont : context sign}
  {φ₁ φ₂ : formula_in_context cont} (p : φ₁ = φ₂) :
  formula_in_context_eq (ap formula_in_context.φ p) ((@apo01 _ _
     (λ f, formula.free_vars f⊆cont.vars) formula_in_context.φ (λ f, f.in_cont) _ _ p).1
     (apd formula_in_context.in_cont p)) = p :=
begin hinduction p, hinduction φ₁, exact idp end

@[hott, instance]
def formula_in_context_is_set {sign : fo_signature} (cont : context sign) :
  is_set (formula_in_context cont) :=
begin
  apply is_set.mk, intros φ₁ φ₂ p q,
  rwr <- formula_in_context_eq_eta p, rwr <- formula_in_context_eq_eta q,
    fapply apd011 formula_in_context_eq, exact is_set.elim _ _,
  { apply pathover_of_tr_eq, exact dep_set_eq_eq _ _ _ } end

end formula

open formula

@[hott]
structure sequent (sign : fo_signature) :=
  (cont : context sign)
  (ass : formula_in_context cont)
  (con : formula_in_context cont)

@[hott, hsimp]
def sequent_eq {sign : fo_signature} {seq₁ seq₂ : sequent sign} :
  Π (p : seq₁.cont = seq₂.cont), seq₁.ass =[p] seq₂.ass -> seq₁.con =[p] seq₂.con ->
                                                                         seq₁ = seq₂ :=
begin intros, hinduction seq₁, hinduction seq₂, apply apdd2 sequent.mk p a a_1 end

@[hott]
def sequent_eq_eta {sign : fo_signature} {seq₁ seq₂ : sequent sign} (p : seq₁ = seq₂) :
  sequent_eq (ap sequent.cont p)
      ((apo01 sequent.cont (λ (a : sequent sign), a.ass) p).1 (apd sequent.ass p))
      ((apo01 sequent.cont (λ (a : sequent sign), a.con) p).1 (apd sequent.con p))  = p :=
begin hinduction p, hinduction seq₁, exact idp end

@[hott, instance]
def sequent_is_set {sign : fo_signature} : is_set (sequent sign) :=
begin
  fapply is_set.mk, intros seq₁ seq₂ p q,
  rwr <- sequent_eq_eta p, rwr <- sequent_eq_eta q,
  fapply apd0111 sequent_eq, exact is_set.elim _ _,
  { apply pathover_of_tr_eq, exact dep_set_eq_eq _ _ _ },
  { apply pathover_of_tr_eq, exact dep_set_eq_eq _ _ _ }
end

/- We may need to introduce classes of sequents later on, if we need to invoke the class
   mechanism. For now we just define the properties. -/

@[hott]
def sequent.horn {sign : fo_signature} (seq : sequent sign) : trunctype.{0} -1 :=
  (formula.horn seq.ass.φ) and (formula.horn seq.con.φ)

@[hott]
def sequent.regular {sign : fo_signature} (seq : sequent sign) : trunctype.{0} -1 :=
  (formula.regular seq.ass.φ) and (formula.regular seq.con.φ)

@[hott]
def sequent.coherent {sign : fo_signature} (seq : sequent sign) : trunctype.{0} -1 :=
  (formula.coherent seq.ass.φ) and (formula.coherent seq.con.φ)

@[hott]
def sequent.first_order {sign : fo_signature} (seq : sequent sign) : trunctype.{0} -1 :=
  (formula.first_order seq.ass.φ) and (formula.first_order seq.con.φ)

@[hott]
def sequent.geometric {sign : fo_signature} (seq : sequent sign) : trunctype.{0} -1 :=
  (formula.geometric seq.ass.φ) and (formula.geometric seq.con.φ)

/- We need notations for formulas and sequents. -/

@[hott]
def fo_theory (sign : fo_signature) := Subset (to_Set (sequent sign))

/- To define modules and algebras we need two sorts in an otherwise algebraic theory. So we
   drop the requirement of only one sort in an algebraic theory. -/
@[hott]
def theory.algebraic {sign : fo_signature} (th : fo_theory sign) : trunctype.{0} -1 :=
  prop_resize (to_Prop (Zero ≃ sign.rels) and
              (to_Prop (Π seq : to_Set (sequent sign), seq ∈ th ->
                        (prod (seq.ass.φ = formula.T sign) (formula.atomic seq.con.φ)))))

@[hott]
def theory.horn {sign : fo_signature} (th : fo_theory sign) : trunctype.{0} -1 :=
  prop_resize (to_Prop (Π seq : to_Set (sequent sign), seq ∈ th ->
                        (prod (formula.horn seq.ass.φ) (formula.horn seq.con.φ))))

@[hott]
def theory.regular {sign : fo_signature} (th : fo_theory sign) : trunctype.{0} -1 :=
  prop_resize (to_Prop (Π seq : to_Set (sequent sign), seq ∈ th ->
                        (prod (formula.regular seq.ass.φ) (formula.regular seq.con.φ))))

@[hott]
def theory.coherent {sign : fo_signature} (th : fo_theory sign) : trunctype.{0} -1 :=
  prop_resize (to_Prop (Π seq : to_Set (sequent sign), seq ∈ th ->
                        (prod (formula.coherent seq.ass.φ) (formula.coherent seq.con.φ))))

@[hott]
def theory.geometric {sign : fo_signature} (th : fo_theory sign) : trunctype.{0} -1 :=
  prop_resize (to_Prop (Π seq : to_Set (sequent sign), seq ∈ th ->
                        (prod (formula.geometric seq.ass.φ) (formula.geometric seq.con.φ))))

end signature

end hott


import tactic natree.natree

namespace chapter3

  --equational "axioms"
  @[simp] def kernel {y z} : △⬝△⬝y⬝z = y := natree.kernel
  @[simp] def stem {x y z} : △⬝(△⬝x)⬝y⬝z = y⬝z⬝(x⬝z) := natree.stem
  @[simp] def fork {w x y z} : △⬝(△⬝w⬝x)⬝y⬝z = z⬝w⬝x := natree.fork

  --K combinator (similar to Kernel rule)
  def derive_K : {K : 𝕋 // ∀ x y, K⬝x⬝y = x} := begin
    --metavariable ?m_1 introduced for K
    split,
    intros x y,

    --use kernel rule
    symmetry,
    transitivity,
    symmetry,
    apply kernel,
    exact y,
    symmetry,

    --remove trailing ys
    apply congr,
    apply congr,
    refl,

    --remove trailing xs
    apply congr,
    apply congr,
    refl,

    --?m_1 = △⬝△

    --finish proof
    repeat {refl},
  end

  def K : 𝕋 := △⬝△

  --I combinator (Identity combinator)
  def derive_I : {I : 𝕋 // ∀ x, I⬝x = x} := begin
    --metavariable ?m_1 introduced for I
    split,
    intro x,

    --use kernel rule
    symmetry,
    transitivity,
    symmetry,
    apply kernel,
    exact △⬝x,
    symmetry,

    --use stem rule
    symmetry,
    transitivity,
    symmetry,
    apply stem,
    symmetry,

    --remove trailing xs
    apply congr,
    apply congr,
    refl,

    --?m_1 = △⬝(△⬝△)⬝(△⬝△)

    --finish proof
    repeat {refl},
  end

  def I : 𝕋 := △⬝(△⬝△)⬝(△⬝△)

  --D combinator (flipped S combinator, similar to Stem rule)
  def derive_D : {D : 𝕋 // ∀ x y z, D⬝x⬝y⬝z = y⬝z⬝(x⬝z)} := begin
    --metavariable ?m_1 introduced for D
    split,
    intros x y z,

    --use stem rule
    symmetry,
    transitivity,
    symmetry,
    apply stem,
    symmetry,

    --remove trailing zs
    apply congr,
    apply congr,
    refl,

    --remove trailing ys
    apply congr,
    apply congr,
    refl,

    --replace △ with K⬝△⬝x
    symmetry,
    transitivity,
    apply congr,
    apply congr,
    refl,
    symmetry,
    show K⬝△⬝x = △,
    apply derive_K.property,
    refl,
    symmetry,

    --use stem rule
    symmetry,
    transitivity,
    symmetry,
    apply stem,
    symmetry,

    --remove trailing xs
    apply congr,
    apply congr,
    refl,

    --unfold definition of K
    symmetry,
    transitivity,
    apply congr,
    refl,
    apply congr,
    apply congr,
    refl,
    show K = △⬝△,
    refl,
    refl,
    symmetry,

    --?m_1 = △⬝(△⬝△)⬝(△⬝△⬝△)

    --finish proof
    repeat {refl},
  end

  def D : 𝕋 := △⬝(△⬝△)⬝(△⬝△⬝△)

  --d function (shorter version of D)
  def d (x : 𝕋) : 𝕋 := △⬝(△⬝x)
  lemma d_equiv_D {x} : D⬝x = d x := by simp [d, D]

  --iterated application
  def iterate : ℕ → 𝕋 → 𝕋 → 𝕋
  | 0 a b := b
  | (n+1) a b := a⬝(iterate n a b)
  notation a ^ n ⬝ b := iterate n a b

  --derivation of the fundamental queries
  def derive_q {a b c e} : {q : 𝕋 // ∀ x, q⬝x = △⬝x⬝a⬝b⬝c⬝e} := begin
    --metavariable ?m_1 introduced for q
    split,
    intro x,

    --replace △⬝x⬝a with D⬝(K⬝a)⬝△⬝x (utilizing Stem rule)
    symmetry,
    transitivity,
    apply congr,
    apply congr,
    refl,
    apply congr,
    apply congr,
    refl,
    apply congr,
    apply congr,
    refl,
    show △⬝x⬝a = D⬝(K⬝a)⬝△⬝x,
    symmetry,
    have h : D = derive_D.val := rfl,
    rw h,
    transitivity,
    apply derive_D.property,
    apply congr,
    refl,
    have h₂ : K = derive_K.val := rfl,
    rw h₂,
    apply derive_K.property,
    refl,
    refl,
    refl,
    symmetry,

    --replace (D⬝(K⬝a)⬝△)⬝x⬝b with D⬝(K⬝b)⬝(D⬝(K⬝a)⬝△)⬝x (utilizing Stem rule)
    symmetry,
    transitivity,
    apply congr,
    apply congr,
    refl,
    apply congr,
    apply congr,
    refl,
    show (D⬝(K⬝a)⬝△)⬝x⬝b = D⬝(K⬝b)⬝(D⬝(K⬝a)⬝△)⬝x,
    symmetry,
    have h : D = derive_D.val := rfl,
    rw h,
    transitivity,
    apply derive_D.property,
    apply congr,
    refl,
    have h₂ : K = derive_K.val := rfl,
    rw h₂,
    apply derive_K.property,
    refl,
    refl,
    symmetry,

    --replace D⬝(K⬝b)⬝(D⬝(K⬝a)⬝△)⬝x⬝c with D⬝(K⬝c)⬝(D⬝(K⬝b)⬝(D⬝(K⬝a)⬝△))⬝x (utilizing Stem rule)
    symmetry,
    transitivity,
    apply congr,
    apply congr,
    refl,
    show D⬝(K⬝b)⬝(D⬝(K⬝a)⬝△)⬝x⬝c = D⬝(K⬝c)⬝(D⬝(K⬝b)⬝(D⬝(K⬝a)⬝△))⬝x,
    symmetry,
    have h : D = derive_D.val := rfl,
    rw h,
    transitivity,
    apply derive_D.property,
    apply congr,
    refl,
    have h₂ : K = derive_K.val := rfl,
    rw h₂,
    apply derive_K.property,
    refl,
    symmetry,

    --replace D⬝(K⬝c)⬝(D⬝(K⬝b)⬝(D⬝(K⬝a)⬝△))⬝x⬝d with D⬝(K⬝d)⬝(D⬝(K⬝c)⬝(D⬝(K⬝b)⬝(D⬝(K⬝a)⬝△)))⬝x (utilizing Stem rule)
    symmetry,
    transitivity,
    show D⬝(K⬝c)⬝(D⬝(K⬝b)⬝(D⬝(K⬝a)⬝△))⬝x⬝e = D⬝(K⬝e)⬝(D⬝(K⬝c)⬝(D⬝(K⬝b)⬝(D⬝(K⬝a)⬝△)))⬝x,
    symmetry,
    have h : D = derive_D.val := rfl,
    rw h,
    transitivity,
    apply derive_D.property,
    apply congr,
    refl,
    have h₂ : K = derive_K.val := rfl,
    rw h₂,
    apply derive_K.property,
    symmetry,

    --remove xs
    apply congr,
    apply congr,
    refl,

    --replace with ds
    symmetry,
    repeat {
      transitivity,
      rw d_equiv_D,
    },
    symmetry,

    --?m_1 = d (K⬝e)⬝(d (K⬝c)⬝(d (K⬝b)⬝(d (K⬝a)⬝△)))

    --finish proof
    repeat {refl},
  end

  def bool_to_natree : bool → 𝕋
  | tt := K
  | ff := K⬝I

  structure solution_property (f g h k : 𝕋) (is0 is1 is2 : bool) : Prop :=
  (eq0 : △⬝△⬝f⬝g⬝h⬝k = bool_to_natree is0)
  (eq1 : ∀ x, △⬝(△⬝x)⬝f⬝g⬝h⬝k = bool_to_natree is1)
  (eq2 : ∀ x y, △⬝(△⬝x⬝y)⬝f⬝g⬝h⬝k = bool_to_natree is2)

  lemma k2 {a b c} : (K^2⬝a)⬝b⬝c = a := begin
    --rewrite in terms of derive_K.val
    repeat {rw iterate},
    have h : K = derive_K.val := rfl,
    rw h,

    --remove c
    transitivity,
    apply congr,
    apply congr,
    refl,

    --simplify using K-rule
    apply derive_K.property,
    refl,

    --simplify using K-rule again
    apply derive_K.property,
  end

  lemma k4 {a b c d e} : (K^4⬝a)⬝b⬝c⬝d⬝e = a := begin
    --rewrite in terms of derive_K.val
    repeat {rw iterate},
    have h : K = derive_K.val := rfl,
    rw h,

    --remove c, d and e
    transitivity,
    apply congr,
    apply congr,
    refl,
    apply congr,
    apply congr,
    refl,
    apply congr,
    apply congr,
    refl,

    --simplify using K-rule
    apply derive_K.property,
    refl,
    refl,
    refl,

    --remove d and e
    transitivity,
    apply congr,
    apply congr,
    refl,
    apply congr,
    apply congr,
    refl,

    --simplify using K-rule
    apply derive_K.property,
    refl,
    refl,

    --remove e
    transitivity,
    apply congr,
    apply congr,
    refl,

    --simplify using K-rule
    apply derive_K.property,
    refl,

    --simplify using K-rule again
    apply derive_K.property,
  end

  lemma kI {a b} : K⬝I⬝a⬝b = b := begin
    transitivity,
    apply congr,
    apply congr,
    refl,
    have h : K = derive_K.val := rfl,
    show K⬝I⬝a = I,
    rw h,
    apply derive_K.property,
    refl,
    have h₂ : I = derive_I.val := rfl,
    rw h₂,
    apply derive_I.property,
  end

  def prove_query {is0 is1 is2} : Σ' f g h k, solution_property f g h k is0 is1 is2 := begin
    --apply naive solution for f (K^2⬝(bool_to_natree is0))
    split,
    show 𝕋,
    exact K^2⬝(bool_to_natree is0),

    --apply naive solution for g (K^4⬝(bool_to_natree is2))
    split,
    show 𝕋,
    exact K^4⬝(bool_to_natree is2),

    --apply derived solution for h (bool_to_natree is1)
    split,
    show 𝕋,
    exact bool_to_natree is1,

    --apply derived solution for k (bool_to_natree is1)
    split,
    show 𝕋,
    exact bool_to_natree is1,

    split,

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

    --remove h and k
    transitivity,
    apply congr,
    apply congr,
    refl,
    apply congr,
    apply congr,
    refl,

    --use kernel rule
    apply kernel,
    refl,
    refl,

    --use k2
    apply k2,

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

    intro x,

    --remove h and k
    transitivity,
    apply congr,
    apply congr,
    refl,
    apply congr,
    apply congr,
    refl,

    --use stem rule and k2
    transitivity,
    apply stem,
    apply k2,
    refl,
    refl,

    --split on cases
    cases is0,

    --case false
    rw bool_to_natree,
    apply kI,

    --case true
    rw bool_to_natree,
    have h : K = derive_K.val := rfl,
    rw h,
    apply derive_K.property,

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

    intros x y,

    --remove h and k
    transitivity,
    apply congr,
    apply congr,
    refl,
    apply congr,
    apply congr,
    refl,

    --use fork rule and k4
    transitivity,
    apply fork,
    refl,
    refl,
    refl,
    apply k4,
  end

  --D in terms of K and S
  def S : 𝕋 := (d (K⬝D))⬝((d K)⬝(K⬝D))
  lemma S_prop {x y z} : S⬝x⬝y⬝z = x⬝z⬝(y⬝z) := by simp [S, d, D, K]

  def D' : 𝕋 := S⬝(K⬝(S⬝S))⬝K
  example {x y z} : D'⬝x⬝y⬝z = y⬝z⬝(x⬝z) := by simp [D', S, d, D, K]

  --Defining fst and snd
  def fst : 𝕋 := S⬝(K⬝(△⬝(K⬝K)⬝△))⬝△
  example {x y} : fst⬝(△⬝x⬝y) = x := by simp [fst, S, d, D, K]

  def snd : 𝕋 := S⬝(K⬝(△⬝(K⬝(K⬝I))⬝△))⬝△
  example {x y} : snd⬝(△⬝x⬝y) = y := by simp [snd, S, d, D, K, I]

  def unseat : 𝕋 := S⬝(K⬝(S⬝I))⬝K
  example {x y} : unseat⬝x⬝y = y⬝x := by simp [unseat, S, d, D, K, I]
  --flip⬝(b⬝x⬝y) = b⬝y⬝x

  --Exercise 8

  --binary trees indexed by depth
  inductive btree : ℕ → Type
  | kernel : btree 0
  | stem {n} : btree n → btree (n + 1)
  | fork {n₁ n₂} : btree n₁ → btree n₂ → btree (max n₁ n₂)

  example : fintype (btree 0) := begin
    split,
    show finset _,
    split,
    show multiset _,
    exact ⟦[btree.kernel]⟧,
    rw multiset.nodup,
    dsimp at *,
  end

  /-
  https://oeis.org/A002065

  Two sequences:

  a_0 = 0
  a_1 = 1
  a(n) = a(n-1) * (a(n-1) + 2) - a(n-2) * (a(n-2) + 1)
       = a(n-1)^2 + (2*a(n-1) - a(n-2)^2 - a(n-2))
       = a(n-1) + a(n-1)^2 + 1

  a(n) gives number of binary trees where depth <= n-1

  b(0) = 0
  b(1) = 1
  b(n) = b(n-1) + a(n-1)^2 - a(n-2)^2
       = b(n-1) * (a(n-1) + a(n-2)  + 1)
       = b(n-1) * (2a(n-1) - b(n-1) + 1)
       = a(n) - a(n-1)
       = a(n-1)^2 + 1

  b(n) gives number of binary trees where depth = n-1

  Depth 0:
  ●

  Depth 1:
  │  ┌┴┐
  ●  ● ●

  Depth 2:
  │   │   ┌┴┐  ┌┴─┐   ┌┴┐  ┌┴┐  ┌┴─┐    ┌─┴┐   ┌─┴┐   ┌─┴─┐
  │  ┌┴┐  ● │  ● ┌┴┐  │ ●  │ │  │ ┌┴┐  ┌┴┐ ●  ┌┴┐ │  ┌┴┐ ┌┴┐
  ●  ● ●    ●    ● ●  ●    ● ●  ● ● ●  ● ●    ● ● ●  ● ● ● ●

  ...
  -/

end chapter3


-- Source: https://github.com/bottine/mathlib/blob/bottine/combinatorics.simple_graph.metric/some_lemmas/src/combinatorics/simple_graph/metric.lean

/-
Copyright (c) 2022 Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kyle Miller, Vincent Beffara
-/
import combinatorics.simple_graph.connectivity
import data.nat.lattice
import data.enat.lattice
import algebra.order.pointwise
import topology.metric_space.emetric_space
import topology.metric_space.lipschitz
import data.real.enat_ennreal

open_locale ennreal

namespace enat

lemma add_one_lt_add_one {a b : ℕ∞} (ab : a < b) : a + 1 < b + 1 := sorry
lemma le_add (n m : ℕ∞) : n ≤ n + m := sorry
lemma add_le_add {n n' m m' : ℕ∞} (hn : n ≤ n') (hm : m ≤ m') : n + m ≤ n' + m' := add_le_add hn hm
lemma lt_add_one_iff_le {n m : ℕ∞} (h : m ≠ ⊤) : n < m + 1 ↔ n ≤ m  := sorry
lemma mul_right_le {a b c : ℕ∞} (h : a ≤ b) : a * c ≤ b * c := sorry
lemma coe_ennreal_inj {n m : ℕ∞} : (↑n : ℝ≥0∞) = ↑m ↔ n = m := sorry
@[simp] lemma top_mul_left {a : ℕ∞} : ⊤ * a = ⊤ := sorry
@[simp] lemma top_mul_right {a : ℕ∞} : a * ⊤ = ⊤ := sorry
@[simp] lemma top_add_left {a : ℕ∞} : ⊤ + a = ⊤ := sorry
@[simp] lemma top_add_right {a : ℕ∞} : a + ⊤ = ⊤ := sorry
lemma ne_top_iff_lt_top {a : ℕ∞} : a ≠ ⊤ ↔ a < ⊤ := sorry

end enat

namespace simple_graph
variables {V V' : Type*} (G : simple_graph V) (G' : simple_graph V')

/-! ## Metric -/

noncomputable
def edist (u v : V) : ℕ∞ := ⨅ w : G.walk u v, w.length

variables {G}

protected
lemma reachable.exists_walk {u v : V} (h : G.reachable u v) :
  ∃ (p : G.walk u v), (p.length : ℕ∞) = G.edist u v :=
begin
  haveI : nonempty (G.walk u v) := h,
  refine ⟨function.argmin (λ w : G.walk u v, (w.length : ℕ)) nat.lt_wf,
          le_antisymm (le_infi (λ w', _)) (infi_le _ _)⟩,
  simp only [nat.cast_le, function.argmin_le],
end

lemma reachable_iff_exists_walk {u v : V} :
  G.reachable u v ↔ ∃ (p : G.walk u v), (p.length : ℕ∞) = G.edist u v :=
⟨reachable.exists_walk, λ p, ⟨p.some⟩⟩

lemma not_reachable_iff_edist_eq_top {u v : V} :
  ¬ G.reachable u v ↔ G.edist u v = ⊤ :=
begin
  rw [edist, reachable, not_nonempty_iff, infi_eq_top],
  exact ⟨λ h p, h.elim p, λ h, ⟨λ p,  with_top.nat_ne_top _ (h p)⟩⟩,
end

lemma reachable_iff_edist_ne_top {u v : V} :
  G.reachable u v ↔ G.edist u v ≠ ⊤ :=
by rw [←not_iff_not, not_reachable_iff_edist_eq_top, not_not]

lemma reachable_iff_edist_lt_top {u v : V} :
  G.reachable u v ↔ G.edist u v < ⊤ :=
by rw [reachable_iff_edist_ne_top, enat.ne_top_iff_lt_top]

lemma exists_walk_iff_edist_ne_top {u v : V} :
  (∃ (p : G.walk u v), (p.length : ℕ∞) = G.edist u v) ↔ G.edist u v ≠ ⊤ :=
by rw [←reachable_iff_edist_ne_top, ←reachable_iff_exists_walk]

lemma exists_walk_of_edist_eq_nat {u v : V} {n : ℕ} (h : G.edist u v = n) :
  (∃ (p : G.walk u v), p.length = n) :=
begin
  have : ∃ (p : G.walk u v), ↑(p.length) = G.edist u v, by
  { rw [exists_walk_iff_edist_ne_top, h],
    apply with_top.nat_ne_top _, },
  rw h at this,
  obtain ⟨w, hw⟩ := this,
  simp only [nat.cast_inj] at hw,
  exact ⟨w, hw⟩,
end

protected
lemma preconnected.exists_walk (hconn : G.preconnected) (u v : V) :
  ∃ (p : G.walk u v), (p.length : ℕ∞) = G.edist u v :=
(hconn u v).exists_walk

noncomputable
def preconnected.dist (hconn : G.preconnected) (u v : V) : ℕ := (hconn.exists_walk u v).some.length

@[simp]
lemma preconnected.dist_eq (hconn : G.preconnected) (u v : V) :
  (hconn.dist u v : ℕ∞) = G.edist u v := (hconn.exists_walk u v).some_spec

lemma edist_le {u v : V} (p : G.walk u v) : G.edist u v ≤ p.length := infi_le _ p

lemma le_edist {u v : V} {n : ℕ} (h : ∀ p : G.walk u v, n ≤ p.length) : (n : ℕ∞) ≤ G.edist u v :=
le_infi (λ p, nat.cast_le.mpr $ h p)

@[simp]
lemma edist_self {v : V} : edist G v v = 0 := by
begin
  convert le_antisymm (infi_le _ (walk.nil' v)) _,
  simp only [walk.length_nil, enat.coe_zero, zero_le],
end

lemma edist_comm {u v : V} : edist G u v = edist G v u :=
begin
  dsimp [edist],
  refine le_antisymm (le_infi (λ w, _)) (le_infi (λ w, _));
  { rw ←walk.length_reverse,
    apply infi_le _ _, }
end

lemma edist_triangle {u v w : V} :
  G.edist u w ≤ G.edist u v + G.edist v w :=
begin
  by_cases huv : nonempty (G.walk u v),
  by_cases hvw : nonempty (G.walk v w),
  { obtain ⟨p, hp⟩ := reachable.exists_walk huv,
    obtain ⟨q, hq⟩ := reachable.exists_walk hvw,
    rw [←hp, ←hq, ←enat.coe_add, ←walk.length_append],
    apply edist_le, },
  { simp only [not_reachable_iff_edist_eq_top.mp hvw, with_top.add_top, le_top], },
  { simp only [not_reachable_iff_edist_eq_top.mp huv, with_top.top_add, le_top], },
end

@[simp] lemma edist_eq_zero_iff_eq {u v : V} : G.edist u v = 0 ↔ u = v :=
⟨λ h, walk.eq_of_length_eq_zero (exists_walk_of_edist_eq_nat h).some_spec, λ h, h ▸ edist_self⟩

@[simp]
lemma edist_eq_one_iff_adj {u v : V} : G.edist u v = 1 ↔ G.adj u v :=
begin
  split,
  { rintro h,
    obtain ⟨w, hw⟩ := exists_walk_of_edist_eq_nat h,
    -- exact walk.adj_of_length_eq_one hw,
    sorry,
    },
  { refine λ a, le_antisymm (edist_le (walk.cons a walk.nil)) (le_edist (λ w, _)),
    simp only [nat.one_le_iff_ne_zero, walk.length_cons, walk.length_nil, ne.def],
    exact λ h, (a.ne $ walk.eq_of_length_eq_zero h), },
end

lemma exists_edist_eq_of_edist_eq_succ {u v : V} {n : ℕ} (h : G.edist u v = n+1) :
  ∃ w, G.edist w v = n ∧ G.edist u w = 1 :=
begin
  obtain ⟨p, hp⟩ := exists_walk_of_edist_eq_nat h,
  cases p with _ u w v a q,
  { simpa only using hp, },
  { simp only [edist_eq_one_iff_adj],
    refine ⟨w, _, a⟩,
    simp only [walk.length_cons, add_left_inj] at hp,
    refine le_antisymm (hp ▸ edist_le _) _,
    { by_contra' h',
      rw ←edist_eq_one_iff_adj at a,
      refine ((enat.add_one_lt_add_one h').trans_le (_ : ↑n + 1 ≤ G.edist w v + 1)).ne rfl,
      rw [←h, ←a, add_comm],
      apply edist_triangle, }, },
end

@[reducible]
def closed_ball (G : simple_graph V) (v : V) (n : ℕ) := {u | G.edist u v ≤ n}

lemma closed_ball_zero_eq (v : V) : G.closed_ball v 0 = {v} :=
by simp only [closed_ball, edist_eq_zero_iff_eq, enat.coe_zero, nonpos_iff_eq_zero,
              set.set_of_eq_eq_singleton]

lemma closed_ball_succ_eq  (v : V) (n : ℕ) :
  G.closed_ball v (n+1) = G.closed_ball v n ∪ (⋃ u ∈ G.closed_ball v n, G.neighbor_set u) :=
begin
  ext x,
  simp only [enat.coe_add, enat.coe_one, set.mem_set_of_eq, set.mem_union, set.mem_Union,
             mem_neighbor_set, exists_prop],
  split,
  { rintro hx, rw [le_iff_eq_or_lt] at hx,
    rcases hx with (he|hlt),
    { obtain ⟨_|⟨a, w⟩, h⟩ := exists_walk_of_edist_eq_nat he,
      { simp, },
      { simp only [walk.length_cons, add_left_inj] at h,
        rw ←h,
        refine or.inr ⟨_, edist_le _, a.symm⟩, } },
    { rw enat.lt_add_one_iff_le (with_top.nat_ne_top n) at hlt,
      exact or.inl hlt, }  },
  { rintro (hx|⟨u, hu, a⟩),
    { exact hx.trans (enat.le_add _ _), },
    { apply (@edist_triangle _ G x u v).trans _,
      rw add_comm _ (1 : ℕ∞),
      apply enat.add_le_add (eq.le _) hu,
      simpa using a.symm, }, }
end

instance fintype_closed_ball [lf : locally_finite G] [decidable_eq V] (v : V) (n : ℕ) :
  fintype (G.closed_ball v n) :=
begin
  induction n,
  { rw closed_ball_zero_eq,
    apply set.fintype_singleton, },
  { rw closed_ball_succ_eq,
    haveI := n_ih,
    apply set.fintype_union, },
end

@[reducible]
def open_ball (G : simple_graph V) (v : V) (n : ℕ∞) := {u | G.edist u v < n}

lemma open_ball_zero_eq_empty (v : V) : G.open_ball v 0 = ∅ :=
by { sorry }

lemma open_ball_succ_eq  (v : V) (n : ℕ∞) :
  G.open_ball v (n+1) = G.open_ball v n ∪ (⋃ u ∈ G.open_ball v n, G.neighbor_set u) :=
    sorry

variables {G} {G'}

lemma hom.edist_le (φ : G →g G') (x y : V) : G'.edist (φ x) (φ y) ≤ G.edist x y :=
begin
  obtain (h|h) := eq_or_ne (G.edist x y) ⊤,
  { simp [h], },
  { obtain ⟨p, h⟩ := exists_walk_iff_edist_ne_top.mpr h,
    rw [←h, ←walk.length_map φ p],
    apply edist_le, },
end

lemma iso.edist_eq (φ : G ≃g G') (x y : V) : G'.edist (φ x) (φ y) = G.edist x y :=
begin
  refine le_antisymm (hom.edist_le φ.to_hom x y) _,
  convert (hom.edist_le φ.symm.to_hom (φ x) (φ y)),
  exacts [(φ.left_inv x).symm, (φ.left_inv y).symm],
end

variables (G) (G')

lemma closed_ball_ne_univ_of_infinite [lf : locally_finite G] [hV : infinite V]
  (v : V) (n : ℕ) : G.closed_ball v n ≠ set.univ :=
begin
  classical,
  rintro h,
  haveI : fintype (@set.univ V), by rw ←h; exact (@simple_graph.fintype_closed_ball _ G lf _ v n),
  apply hV.not_finite (finite.of_finite_univ (set.univ : set V).to_finite),
end

@[reducible]
def closed_neighborhood (s : set V) (n : ℕ) := ⋃ v ∈ s, G.closed_ball v n

lemma subset_closed_neighborhood  (s : set V) (n : ℕ) :
  s ⊆ G.closed_neighborhood s n :=
begin
  rintro u us,
  simp only [set.mem_Union, set.mem_set_of_eq, exists_prop],
  refine ⟨u, us, _⟩,
  -- simp only [edist_self, with_top.coe_nonneg, zero_le'],
  sorry,
end

lemma closed_neighborhood_finite [locally_finite G] {s : set V} (fs : s.finite) (n : ℕ) :
  (G.closed_neighborhood s n).finite :=
begin
  classical,
  apply set.finite.bUnion fs (λ u us, _),
  exact ⟨simple_graph.fintype_closed_ball u n⟩,
end

@[reducible]
def open_neighborhood (s : set V) (n : ℕ∞) :=
  ⋃ v ∈ s, G.open_ball v n

lemma subset_open_neighborhood (s : set V) (n : ℕ∞) :
  s ⊆ G.open_neighborhood s n := sorry

def path_metric (G : simple_graph V) := V

noncomputable instance (G : simple_graph V) : emetric_space (path_metric G) :=
{ edist := λ x y, (G.edist x y : ℝ≥0∞),
  edist_self := λ x, by simp only [←enat.coe_ennreal_zero, edist_self],
  edist_comm := λ x y, by simp only [edist_comm],
  edist_triangle := λ x y z, by
    { simp only [←enat.coe_ennreal_add, enat.coe_ennreal_le, edist_triangle], },
  eq_of_edist_eq_zero := λ x y, by
    { simp only [←enat.coe_ennreal_zero, edist_eq_zero_iff_eq, enat.coe_ennreal_inj, imp_self], } }

variables {G} {G'}

def hom.to_path_metric (φ : G →g G') : (path_metric G) → (path_metric G') := φ.to_fun

lemma hom.to_path_metric_nonexpanding (φ : G →g G') : lipschitz_with 1 (φ.to_path_metric) :=
begin
  intros x y,
  simp only [has_edist.edist, ennreal.coe_one, one_mul, enat.coe_ennreal_le],
  apply φ.edist_le,
end

lemma enough_space_of_transitive [lf : locally_finite G] [hV : infinite V] [decidable_eq V]
  (Gpc : G.preconnected) (ht : ∀ u v, ∃ φ : G ≃g G, φ u = v) (K : finset V) :
  ∃ φ : G ≃g G, disjoint (K.image φ) K :=
begin
  obtain (rfl|⟨u, uK⟩) := finset.eq_empty_or_nonempty K,
  { simp, },
  { let m := (K.image (λ y, Gpc.dist u y)).max' (finset.nonempty.image ⟨u, uK⟩ _),
    have Km : ∀ ⦃y⦄, y ∈ K → G.edist u y ≤ m := λ y yK, by
    { simp only [←Gpc.dist_eq, nat.cast_le],
      refine finset.le_max' _ _ (finset.mem_image_of_mem _ yK), },
    obtain ⟨v, hv⟩ := set.nonempty_compl.mpr (G.closed_ball_ne_univ_of_infinite u (m + m)),
    obtain ⟨φ, rfl⟩ := ht u v,
    have φKm : ∀ ⦃y⦄, y ∈ K.image φ →  G.edist (φ u) y ≤ m,
    { simp only [finset.mem_image],
      rintro _ ⟨y, yK, rfl⟩,
      exact (iso.edist_eq φ u y).symm ▸ (Km yK), },
    simp only [finset.disjoint_left, set.mem_compl_iff, set.mem_set_of_eq, enat.coe_add] at hv ⊢,
    exact ⟨φ, λ x xφK xK, hv (edist_triangle.trans $ enat.add_le_add
                             (φKm xφK) (by { rw edist_comm, exact Km xK, }))⟩, }
end

end simple_graph


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

import algebra.category.Module.projective
import algebraic_topology.extra_degeneracy
import category_theory.abelian.ext
import representation_theory.Rep

/-!
# The structure of the `k[G]`-module `k[Gⁿ]`

This file contains facts about an important `k[G]`-module structure on `k[Gⁿ]`, where `k` is a
commutative ring and `G` is a group. The module structure arises from the representation
`G →* End(k[Gⁿ])` induced by the diagonal action of `G` on `Gⁿ.`

In particular, we define an isomorphism of `k`-linear `G`-representations between `k[Gⁿ⁺¹]` and
`k[G] ⊗ₖ k[Gⁿ]` (on which `G` acts by `ρ(g₁)(g₂ ⊗ x) = (g₁ * g₂) ⊗ x`).

This allows us to define a `k[G]`-basis on `k[Gⁿ⁺¹]`, by mapping the natural `k[G]`-basis of
`k[G] ⊗ₖ k[Gⁿ]` along the isomorphism.

We then define the standard resolution of `k` as a trivial representation, by
taking the alternating face map complex associated to an appropriate simplicial `k`-linear
`G`-representation. This simplicial object is the `linearization` of the simplicial `G`-set given
by the universal cover of the classifying space of `G`, `EG`. We prove this simplicial `G`-set `EG`
is isomorphic to the Čech nerve of the natural arrow of `G`-sets `G ⟶ {pt}`.

We then use this isomorphism to deduce that as a complex of `k`-modules, the standard resolution
of `k` as a trivial `G`-representation is homotopy equivalent to the complex with `k` at 0 and 0
elsewhere.

Putting this material together allows us to define `group_cohomology.ProjectiveResolution`, the
standard projective resolution of `k` as a trivial `k`-linear `G`-representation.

## Main definitions

 * `group_cohomology.resolution.Action_diagonal_succ`
 * `group_cohomology.resolution.diagonal_succ`
 * `group_cohomology.resolution.of_mul_action_basis`
 * `classifying_space_universal_cover`
 * `group_cohomology.resolution.forget₂_to_Module_homotopy_equiv`
 * `group_cohomology.ProjectiveResolution`

## Implementation notes

We express `k[G]`-module structures on a module `k`-module `V` using the `representation`
definition. We avoid using instances `module (G →₀ k) V` so that we do not run into possible
scalar action diamonds.

We also use the category theory library to bundle the type `k[Gⁿ]` - or more generally `k[H]` when
`H` has `G`-action - and the representation together, as a term of type `Rep k G`, and call it
`Rep.of_mul_action k G H.` This enables us to express the fact that certain maps are
`G`-equivariant by constructing morphisms in the category `Rep k G`, i.e., representations of `G`
over `k`.
-/

noncomputable theory
universes u v w

variables {k G : Type u} [comm_ring k] {n : ℕ}

open category_theory

local notation `Gⁿ` := fin n → G
local notation `Gⁿ⁺¹` := fin (n + 1) → G

namespace group_cohomology.resolution

open finsupp (hiding lift) fin (partial_prod)

section basis
variables (k G n) [group G]

section Action
open Action

/-- An isomorphism of `G`-sets `Gⁿ⁺¹ ≅ G × Gⁿ`, where `G` acts by left multiplication on `Gⁿ⁺¹` and
`G` but trivially on `Gⁿ`. The map sends `(g₀, ..., gₙ) ↦ (g₀, (g₀⁻¹g₁, g₁⁻¹g₂, ..., gₙ₋₁⁻¹gₙ))`,
and the inverse is `(g₀, (g₁, ..., gₙ)) ↦ (g₀, g₀g₁, g₀g₁g₂, ..., g₀g₁...gₙ).` -/
def Action_diagonal_succ (G : Type u) [group G] : Π (n : ℕ),
  diagonal G (n + 1) ≅ left_regular G ⊗ Action.mk (fin n → G) 1
| 0 := diagonal_one_iso_left_regular G ≪≫ (ρ_ _).symm ≪≫ tensor_iso (iso.refl _)
  (tensor_unit_iso (equiv.equiv_of_unique punit _).to_iso)
| (n+1) := diagonal_succ _ _ ≪≫ tensor_iso (iso.refl _) (Action_diagonal_succ n)
  ≪≫ left_regular_tensor_iso _ _ ≪≫ tensor_iso (iso.refl _) (mk_iso
  (equiv.pi_fin_succ_above_equiv (λ j, G) 0).symm.to_iso (λ g, rfl))

lemma Action_diagonal_succ_hom_apply {G : Type u} [group G] {n : ℕ} (f : fin (n + 1) → G) :
  (Action_diagonal_succ G n).hom.hom f = (f 0, λ i, (f i)⁻¹ * f i.succ) :=
begin
  induction n with n hn,
  { exact prod.ext rfl (funext $ λ x, fin.elim0 x) },
  { ext,
    { refl },
    { dunfold Action_diagonal_succ,
      simp only [iso.trans_hom, comp_hom, types_comp_apply, diagonal_succ_hom_hom,
        left_regular_tensor_iso_hom_hom, tensor_iso_hom, mk_iso_hom_hom, equiv.to_iso_hom,
        tensor_hom, equiv.pi_fin_succ_above_equiv_symm_apply, tensor_apply, types_id_apply,
        tensor_rho, monoid_hom.one_apply, End.one_def, hn (λ (j : fin (n + 1)), f j.succ),
        fin.coe_eq_cast_succ, fin.insert_nth_zero'],
      refine fin.cases (fin.cons_zero _ _) (λ i, _) x,
      { simp only [fin.cons_succ, mul_left_inj, inv_inj, fin.cast_succ_fin_succ], }}}
end

lemma Action_diagonal_succ_inv_apply {G : Type u} [group G] {n : ℕ} (g : G) (f : fin n → G) :
  (Action_diagonal_succ G n).inv.hom (g, f) = (g • fin.partial_prod f : fin (n + 1) → G) :=
begin
  revert g,
  induction n with n hn,
  { intros g,
    ext,
    simpa only [subsingleton.elim x 0, pi.smul_apply, fin.partial_prod_zero,
      smul_eq_mul, mul_one] },
  { intro g,
    ext,
    dunfold Action_diagonal_succ,
    simp only [iso.trans_inv, comp_hom, hn, diagonal_succ_inv_hom, types_comp_apply,
      tensor_iso_inv, iso.refl_inv, tensor_hom, id_hom, tensor_apply, types_id_apply,
      left_regular_tensor_iso_inv_hom, tensor_rho, left_regular_ρ_apply, pi.smul_apply,
      smul_eq_mul],
    refine fin.cases _ _ x,
    { simp only [fin.cons_zero, fin.partial_prod_zero, mul_one], },
    { intro i,
      simpa only [fin.cons_succ, pi.smul_apply, smul_eq_mul, fin.partial_prod_succ', mul_assoc], }}
end

end Action
section Rep
open Rep

/-- An isomorphism of `k`-linear representations of `G` from `k[Gⁿ⁺¹]` to `k[G] ⊗ₖ k[Gⁿ]` (on
which `G` acts by `ρ(g₁)(g₂ ⊗ x) = (g₁ * g₂) ⊗ x`) sending `(g₀, ..., gₙ)` to
`g₀ ⊗ (g₀⁻¹g₁, g₁⁻¹g₂, ..., gₙ₋₁⁻¹gₙ)`. The inverse sends `g₀ ⊗ (g₁, ..., gₙ)` to
`(g₀, g₀g₁, ..., g₀g₁...gₙ)`. -/
def diagonal_succ (n : ℕ) :
  diagonal k G (n + 1) ≅ left_regular k G ⊗ trivial k G ((fin n → G) →₀ k) :=
(linearization k G).map_iso (Action_diagonal_succ G n)
  ≪≫ (as_iso ((linearization k G).μ (Action.left_regular G) _)).symm
  ≪≫ tensor_iso (iso.refl _) (linearization_trivial_iso k G (fin n → G))

variables {k G n}

lemma diagonal_succ_hom_single (f : Gⁿ⁺¹) (a : k) :
  (diagonal_succ k G n).hom.hom (single f a) =
  single (f 0) 1 ⊗ₜ single (λ i, (f i)⁻¹ * f i.succ) a :=
begin
  dunfold diagonal_succ,
  simpa only [iso.trans_hom, iso.symm_hom, Action.comp_hom, Module.comp_def, linear_map.comp_apply,
    functor.map_iso_hom, linearization_map_hom_single (Action_diagonal_succ G n).hom f a,
    as_iso_inv, linearization_μ_inv_hom, Action_diagonal_succ_hom_apply, finsupp_tensor_finsupp',
    linear_equiv.trans_symm, lcongr_symm, linear_equiv.trans_apply, lcongr_single,
    tensor_product.lid_symm_apply, finsupp_tensor_finsupp_symm_single,
    linear_equiv.coe_to_linear_map],
end

lemma diagonal_succ_inv_single_single (g : G) (f : Gⁿ) (a b : k) :
  (diagonal_succ k G n).inv.hom (finsupp.single g a ⊗ₜ finsupp.single f b) =
  single (g • partial_prod f) (a * b) :=
begin
  dunfold diagonal_succ,
  simp only [iso.trans_inv, iso.symm_inv, iso.refl_inv, tensor_iso_inv, Action.tensor_hom,
    Action.comp_hom, Module.comp_def, linear_map.comp_apply, as_iso_hom, functor.map_iso_inv,
    Module.monoidal_category.hom_apply, linearization_trivial_iso_inv_hom_apply,
    linearization_μ_hom, Action.id_hom ((linearization k G).obj _), Action_diagonal_succ_inv_apply,
    Module.id_apply, linear_equiv.coe_to_linear_map,
    finsupp_tensor_finsupp'_single_tmul_single k (Action.left_regular G).V,
    linearization_map_hom_single (Action_diagonal_succ G n).inv (g, f) (a * b)],
end

lemma diagonal_succ_inv_single_left (g : G) (f : Gⁿ →₀ k) (r : k) :
  (diagonal_succ k G n).inv.hom (finsupp.single g r ⊗ₜ f) =
  finsupp.lift (Gⁿ⁺¹ →₀ k) k Gⁿ (λ f, single (g • partial_prod f) r) f :=
begin
  refine f.induction _ _,
  { simp only [tensor_product.tmul_zero, map_zero] },
  { intros a b x ha hb hx,
    simp only [lift_apply, smul_single', mul_one, tensor_product.tmul_add, map_add,
      diagonal_succ_inv_single_single, hx, finsupp.sum_single_index,
      mul_comm b, zero_mul, single_zero] },
end

lemma diagonal_succ_inv_single_right (g : G →₀ k) (f : Gⁿ) (r : k) :
  (diagonal_succ k G n).inv.hom (g ⊗ₜ finsupp.single f r) =
  finsupp.lift _ k G (λ a, single (a • partial_prod f) r) g :=
begin
  refine g.induction _ _,
  { simp only [tensor_product.zero_tmul, map_zero], },
  { intros a b x ha hb hx,
    simp only [lift_apply, smul_single', map_add, hx, diagonal_succ_inv_single_single,
      tensor_product.add_tmul, finsupp.sum_single_index, zero_mul, single_zero] }
end

end Rep
variables (k G n)
open_locale tensor_product
open representation

/-- The `k[G]`-linear isomorphism `k[G] ⊗ₖ k[Gⁿ] ≃ k[Gⁿ⁺¹]`, where the `k[G]`-module structure on
the lefthand side is `tensor_product.left_module`, whilst that of the righthand side comes from
`representation.as_module`. Allows us to use `basis.algebra_tensor_product` to get a `k[G]`-basis
of the righthand side. -/
def of_mul_action_basis_aux : (monoid_algebra k G ⊗[k] ((fin n → G) →₀ k)) ≃ₗ[monoid_algebra k G]
  (of_mul_action k G (fin (n + 1) → G)).as_module :=
{ map_smul' := λ r x,
  begin
    rw [ring_hom.id_apply, linear_equiv.to_fun_eq_coe, ←linear_equiv.map_smul],
    congr' 1,
    refine x.induction_on _ (λ x y, _) (λ y z hy hz, _),
    { simp only [smul_zero] },
    { simp only [tensor_product.smul_tmul'],
      show (r * x) ⊗ₜ y = _,
      rw [←of_mul_action_self_smul_eq_mul, smul_tprod_one_as_module] },
    { rw [smul_add, hz, hy, smul_add], }
  end, .. ((Rep.equivalence_Module_monoid_algebra.1).map_iso
    (diagonal_succ k G n).symm).to_linear_equiv }

/-- A `k[G]`-basis of `k[Gⁿ⁺¹]`, coming from the `k[G]`-linear isomorphism
`k[G] ⊗ₖ k[Gⁿ] ≃ k[Gⁿ⁺¹].` -/
def of_mul_action_basis  :
  basis (fin n → G) (monoid_algebra k G) (of_mul_action k G (fin (n + 1) → G)).as_module :=
@basis.map _ (monoid_algebra k G) (monoid_algebra k G ⊗[k] ((fin n → G) →₀ k))
  _ _ _ _ _ _ (@algebra.tensor_product.basis k _ (monoid_algebra k G) _ _ ((fin n → G) →₀ k) _ _
  (fin n → G) ⟨linear_equiv.refl k _⟩) (of_mul_action_basis_aux k G n)

lemma of_mul_action_free :
  module.free (monoid_algebra k G) (of_mul_action k G (fin (n + 1) → G)).as_module :=
module.free.of_basis (of_mul_action_basis k G n)

end basis
end group_cohomology.resolution
namespace Rep
variables (n) [group G]
open group_cohomology.resolution

/-- Given a `k`-linear `G`-representation `A`, the set of representation morphisms
`Hom(k[Gⁿ⁺¹], A)` is `k`-linearly isomorphic to the set of functions `Gⁿ → A`. -/
noncomputable def diagonal_hom_equiv (A : Rep k G) :
  (Rep.of_mul_action k G (fin (n + 1) → G) ⟶ A) ≃ₗ[k] ((fin n → G) → A) :=
linear.hom_congr k ((diagonal_succ k G n).trans
  ((representation.of_mul_action k G G).Rep_of_tprod_iso 1)) (iso.refl _) ≪≫ₗ
  ((Rep.monoidal_closed.linear_hom_equiv_comm _ _ _) ≪≫ₗ (Rep.left_regular_hom_equiv _))
  ≪≫ₗ (finsupp.llift A k k (fin n → G)).symm

variables {n}

/-- Given a `k`-linear `G`-representation `A`, `diagonal_hom_equiv` is a `k`-linear isomorphism of
the set of representation morphisms `Hom(k[Gⁿ⁺¹], A)` with `Fun(Gⁿ, A)`. This lemma says that this
sends a morphism of representations `f : k[Gⁿ⁺¹] ⟶ A` to the function
`(g₁, ..., gₙ) ↦ f(1, g₁, g₁g₂, ..., g₁g₂...gₙ).` -/
lemma diagonal_hom_equiv_apply {A : Rep k G} (f : Rep.of_mul_action k G (fin (n + 1) → G) ⟶ A)
  (x : fin n → G) : diagonal_hom_equiv n A f x = f.hom (finsupp.single (fin.partial_prod x) 1) :=
begin
  unfold diagonal_hom_equiv,
  simpa only [linear_equiv.trans_apply, Rep.left_regular_hom_equiv_apply,
    monoidal_closed.linear_hom_equiv_comm_hom, finsupp.llift_symm_apply, tensor_product.curry_apply,
    linear.hom_congr_apply, iso.refl_hom, iso.trans_inv, Action.comp_hom, Module.comp_def,
    linear_map.comp_apply, representation.Rep_of_tprod_iso_inv_apply,
    diagonal_succ_inv_single_single (1 : G) x, one_smul, one_mul],
end

/-- Given a `k`-linear `G`-representation `A`, `diagonal_hom_equiv` is a `k`-linear isomorphism of
the set of representation morphisms `Hom(k[Gⁿ⁺¹], A)` with `Fun(Gⁿ, A)`. This lemma says that the
inverse map sends a function `f : Gⁿ → A` to the representation morphism sending
`(g₀, ... gₙ) ↦ ρ(g₀)(f(g₀⁻¹g₁, g₁⁻¹g₂, ..., gₙ₋₁⁻¹gₙ))`, where `ρ` is the representation attached
to `A`. -/
lemma diagonal_hom_equiv_symm_apply {A : Rep k G} (f : (fin n → G) → A) (x : fin (n + 1) → G) :
  ((diagonal_hom_equiv n A).symm f).hom (finsupp.single x 1)
    = A.ρ (x 0) (f (λ (i : fin n), (x ↑i)⁻¹ * x i.succ)) :=
begin
  unfold diagonal_hom_equiv,
  simp only [linear_equiv.trans_symm, linear_equiv.symm_symm, linear_equiv.trans_apply,
    Rep.left_regular_hom_equiv_symm_apply, linear.hom_congr_symm_apply, Action.comp_hom,
    iso.refl_inv, category.comp_id, Rep.monoidal_closed.linear_hom_equiv_comm_symm_hom,
    iso.trans_hom, Module.comp_def, linear_map.comp_apply, representation.Rep_of_tprod_iso_apply,
    diagonal_succ_hom_single x (1 : k), tensor_product.uncurry_apply, Rep.left_regular_hom_hom,
    finsupp.lift_apply, Rep.ihom_obj_ρ, representation.lin_hom_apply, finsupp.sum_single_index,
    zero_smul, one_smul, Rep.of_ρ, Rep.Action_ρ_eq_ρ, Rep.trivial_def (x 0)⁻¹,
    finsupp.llift_apply A k k],
end

end Rep
variables (G)

/-- The simplicial `G`-set sending `[n]` to `Gⁿ⁺¹` equipped with the diagonal action of `G`. -/
def classifying_space_universal_cover [monoid G] :
  simplicial_object (Action (Type u) $ Mon.of G) :=
{ obj := λ n, Action.of_mul_action G (fin (n.unop.len + 1) → G),
  map := λ m n f,
  { hom := λ x, x ∘ f.unop.to_order_hom,
    comm' := λ g, rfl },
  map_id' := λ n, rfl,
  map_comp' := λ i j k f g, rfl }

namespace classifying_space_universal_cover
open category_theory category_theory.limits
variables [monoid G]

/-- When the category is `G`-Set, `cech_nerve_terminal_from` of `G` with the left regular action is
isomorphic to `EG`, the universal cover of the classifying space of `G` as a simplicial `G`-set. -/
def cech_nerve_terminal_from_iso :
  cech_nerve_terminal_from (Action.of_mul_action G G) ≅ classifying_space_universal_cover G :=
nat_iso.of_components (λ n, limit.iso_limit_cone (Action.of_mul_action_limit_cone _ _)) $ λ m n f,
begin
  refine is_limit.hom_ext (Action.of_mul_action_limit_cone.{u 0} _ _).2 (λ j, _),
  dunfold cech_nerve_terminal_from pi.lift,
  dsimp,
  rw [category.assoc, limit.iso_limit_cone_hom_π, limit.lift_π, category.assoc],
  exact (limit.iso_limit_cone_hom_π _ _).symm,
end

/-- As a simplicial set, `cech_nerve_terminal_from` of a monoid `G` is isomorphic to the universal
cover of the classifying space of `G` as a simplicial set. -/
def cech_nerve_terminal_from_iso_comp_forget :
  cech_nerve_terminal_from G ≅ classifying_space_universal_cover G ⋙ forget _ :=
nat_iso.of_components (λ n, types.product_iso _) $ λ m n f, matrix.ext $ λ i j,
  types.limit.lift_π_apply _ _ _ _

variables (k G)
open algebraic_topology simplicial_object.augmented simplicial_object category_theory.arrow

/-- The universal cover of the classifying space of `G` as a simplicial set, augmented by the map
from `fin 1 → G` to the terminal object in `Type u`. -/
def comp_forget_augmented : simplicial_object.augmented (Type u) :=
simplicial_object.augment (classifying_space_universal_cover G ⋙ forget _) (terminal _)
(terminal.from _) $ λ i g h, subsingleton.elim _ _

/-- The augmented Čech nerve of the map from `fin 1 → G` to the terminal object in `Type u` has an
extra degeneracy. -/
def extra_degeneracy_augmented_cech_nerve :
  extra_degeneracy (arrow.mk $ terminal.from G).augmented_cech_nerve :=
augmented_cech_nerve.extra_degeneracy (arrow.mk $ terminal.from G)
  ⟨λ x, (1 : G), @subsingleton.elim _ (@unique.subsingleton _ (limits.unique_to_terminal _)) _ _⟩

/-- The universal cover of the classifying space of `G` as a simplicial set, augmented by the map
from `fin 1 → G` to the terminal object in `Type u`, has an extra degeneracy. -/
def extra_degeneracy_comp_forget_augmented :
  extra_degeneracy (comp_forget_augmented G) :=
begin
  refine extra_degeneracy.of_iso (_ : (arrow.mk $ terminal.from G).augmented_cech_nerve ≅ _)
    (extra_degeneracy_augmented_cech_nerve G),
  exact comma.iso_mk (cech_nerve_terminal_from.iso G ≪≫
    cech_nerve_terminal_from_iso_comp_forget G) (iso.refl _)
    (by ext : 2; apply is_terminal.hom_ext terminal_is_terminal),
end

/-- The free functor `Type u ⥤ Module.{u} k` applied to the universal cover of the classifying
space of `G` as a simplicial set, augmented by the map from `fin 1 → G` to the terminal object
in `Type u`. -/
def comp_forget_augmented.to_Module : simplicial_object.augmented (Module.{u} k) :=
((simplicial_object.augmented.whiskering _ _).obj (Module.free k)).obj (comp_forget_augmented G)

/-- If we augment the universal cover of the classifying space of `G` as a simplicial set by the
map from `fin 1 → G` to the terminal object in `Type u`, then apply the free functor
`Type u ⥤ Module.{u} k`, the resulting augmented simplicial `k`-module has an extra degeneracy. -/
def extra_degeneracy_comp_forget_augmented_to_Module :
  extra_degeneracy (comp_forget_augmented.to_Module k G) :=
extra_degeneracy.map (extra_degeneracy_comp_forget_augmented G) (Module.free k)

end classifying_space_universal_cover

variables (k)

/-- The standard resolution of `k` as a trivial representation, defined as the alternating
face map complex of a simplicial `k`-linear `G`-representation. -/
def group_cohomology.resolution [monoid G] :=
(algebraic_topology.alternating_face_map_complex (Rep k G)).obj
  (classifying_space_universal_cover G ⋙ (Rep.linearization k G).1.1)

namespace group_cohomology.resolution
open classifying_space_universal_cover algebraic_topology category_theory category_theory.limits

variables (k G) [monoid G]

/-- The `k`-linear map underlying the differential in the standard resolution of `k` as a trivial
`k`-linear `G`-representation. It sends `(g₀, ..., gₙ) ↦ ∑ (-1)ⁱ • (g₀, ..., ĝᵢ, ..., gₙ)`. -/
def d (G : Type u) (n : ℕ) : ((fin (n + 1) → G) →₀ k) →ₗ[k] ((fin n → G) →₀ k) :=
finsupp.lift ((fin n → G) →₀ k) k (fin (n + 1) → G) (λ g, (@finset.univ (fin (n + 1)) _).sum
  (λ p, finsupp.single (g ∘ p.succ_above) ((-1 : k) ^ (p : ℕ))))

variables {k G}

@[simp] lemma d_of {G : Type u} {n : ℕ} (c : fin (n + 1) → G) :
  d k G n (finsupp.single c 1) = finset.univ.sum (λ p : fin (n + 1), finsupp.single
    (c ∘ p.succ_above) ((-1 : k) ^ (p : ℕ))) :=
by simp [d]

variables (k G)

/-- The `n`th object of the standard resolution of `k` is definitionally isomorphic to `k[Gⁿ⁺¹]`
equipped with the representation induced by the diagonal action of `G`. -/
def X_iso (n : ℕ) :
  (group_cohomology.resolution k G).X n ≅ Rep.of_mul_action k G (fin (n + 1) → G) := iso.refl _

lemma X_projective (G : Type u) [group G] (n : ℕ) :
  projective ((group_cohomology.resolution k G).X n) :=
Rep.equivalence_Module_monoid_algebra.to_adjunction.projective_of_map_projective _ $
  @Module.projective_of_free.{u} _ _ (Module.of (monoid_algebra k G)
  (representation.of_mul_action k G (fin (n + 1) → G)).as_module) _ (of_mul_action_basis k G n)

/-- Simpler expression for the differential in the standard resolution of `k` as a
`G`-representation. It sends `(g₀, ..., gₙ₊₁) ↦ ∑ (-1)ⁱ • (g₀, ..., ĝᵢ, ..., gₙ₊₁)`. -/
theorem d_eq (n : ℕ) :
  ((group_cohomology.resolution k G).d (n + 1) n).hom = d k G (n + 1) :=
begin
  ext x y,
  dsimp [group_cohomology.resolution],
  simpa [←@int_cast_smul k, simplicial_object.δ],
end

section exactness

/-- The standard resolution of `k` as a trivial representation as a complex of `k`-modules. -/
def forget₂_to_Module := ((forget₂ (Rep k G) (Module.{u} k)).map_homological_complex _).obj
(group_cohomology.resolution k G)

/-- If we apply the free functor `Type u ⥤ Module.{u} k` to the universal cover of the classifying
space of `G` as a simplicial set, then take the alternating face map complex, the result is
isomorphic to the standard resolution of the trivial `G`-representation `k` as a complex of
`k`-modules. -/
def comp_forget_augmented_iso : (alternating_face_map_complex.obj
  (simplicial_object.augmented.drop.obj (comp_forget_augmented.to_Module k G))) ≅
  group_cohomology.resolution.forget₂_to_Module k G :=
eq_to_iso (functor.congr_obj (map_alternating_face_map_complex (forget₂ (Rep k G)
  (Module.{u} k))).symm (classifying_space_universal_cover G ⋙ (Rep.linearization k G).1.1))

/-- As a complex of `k`-modules, the standard resolution of the trivial `G`-representation `k` is
homotopy equivalent to the complex which is `k` at 0 and 0 elsewhere. -/
def forget₂_to_Module_homotopy_equiv : homotopy_equiv
  (group_cohomology.resolution.forget₂_to_Module k G)
  ((chain_complex.single₀ (Module k)).obj
  ((forget₂ (Rep k G) _).obj $ Rep.trivial k G k)) :=
(homotopy_equiv.of_iso (comp_forget_augmented_iso k G).symm).trans $
  (simplicial_object.augmented.extra_degeneracy.homotopy_equiv
    (extra_degeneracy_comp_forget_augmented_to_Module k G)).trans
  (homotopy_equiv.of_iso $ (chain_complex.single₀ (Module.{u} k)).map_iso
    (@finsupp.linear_equiv.finsupp_unique k k _ _ _ (⊤_ (Type u))
      types.terminal_iso.to_equiv.unique).to_Module_iso)

/-- The hom of `k`-linear `G`-representations `k[G¹] → k` sending `∑ nᵢgᵢ ↦ ∑ nᵢ`. -/
def ε : Rep.of_mul_action k G (fin 1 → G) ⟶ Rep.trivial k G k :=
{ hom := finsupp.total _ _ _ (λ f, (1 : k)),
  comm' := λ g,
  begin
    ext,
    show finsupp.total (fin 1 → G) k k (λ f, (1 : k))
      (finsupp.map_domain _ (finsupp.single _ _)) = finsupp.total _ _ _ _ (finsupp.single _ _),
    simp only [finsupp.map_domain_single, finsupp.total_single],
  end }

/-- The homotopy equivalence of complexes of `k`-modules between the standard resolution of `k` as
a trivial `G`-representation, and the complex which is `k` at 0 and 0 everywhere else, acts as
`∑ nᵢgᵢ ↦ ∑ nᵢ : k[G¹] → k` at 0. -/
lemma forget₂_to_Module_homotopy_equiv_f_0_eq :
  (forget₂_to_Module_homotopy_equiv k G).1.f 0 =
  (forget₂ (Rep k G) _).map (ε k G) :=
begin
  show (homotopy_equiv.hom _ ≫ (homotopy_equiv.hom _ ≫ homotopy_equiv.hom _)).f 0 = _,
  simp only [homological_complex.comp_f],
  convert category.id_comp _,
  { dunfold homotopy_equiv.of_iso comp_forget_augmented_iso map_alternating_face_map_complex,
    simp only [iso.symm_hom, eq_to_iso.inv, homological_complex.eq_to_hom_f, eq_to_hom_refl] },
  transitivity ((finsupp.total _ _ _ (λ f, (1 : k))).comp
    ((Module.free k).map (terminal.from _))),
  { dsimp,
    rw [@finsupp.lmap_domain_total (fin 1 → G) k k _ _ _ (⊤_ (Type u)) k _ _ (λ i, (1 : k))
      (λ i, (1 : k)) (terminal.from ((classifying_space_universal_cover G).obj
      (opposite.op (simplex_category.mk 0))).V) linear_map.id (λ i, rfl), linear_map.id_comp],
    refl },
  { congr,
    { ext,
      dsimp [homotopy_equiv.of_iso],
      rw [finsupp.total_single, one_smul, @unique.eq_default _
        types.terminal_iso.to_equiv.unique a, finsupp.single_eq_same] },
    { exact (@subsingleton.elim _ (@unique.subsingleton _ (limits.unique_to_terminal _)) _ _) }}
end

lemma d_comp_ε : (group_cohomology.resolution k G).d 1 0 ≫ ε k G = 0 :=
begin
  ext1,
  refine linear_map.ext (λ x, _),
  have : (forget₂_to_Module k G).d 1 0 ≫ (forget₂ (Rep k G) (Module.{u} k)).map (ε k G) = 0,
  by rw [←forget₂_to_Module_homotopy_equiv_f_0_eq,
    ←(forget₂_to_Module_homotopy_equiv k G).1.2 1 0 rfl]; exact comp_zero,
  exact linear_map.ext_iff.1 this _,
end

/-- The chain map from the standard resolution of `k` to `k[0]` given by `∑ nᵢgᵢ ↦ ∑ nᵢ` in
degree zero. -/
def ε_to_single₀ : group_cohomology.resolution k G ⟶ (chain_complex.single₀ _).obj
  (Rep.trivial k G k) :=
((group_cohomology.resolution k G).to_single₀_equiv _).symm ⟨ε k G, d_comp_ε k G⟩

lemma ε_to_single₀_comp_eq : ((forget₂ _ (Module.{u} k)).map_homological_complex _).map
  (ε_to_single₀ k G) ≫ ((chain_complex.single₀_map_homological_complex _).hom.app _) =
  (forget₂_to_Module_homotopy_equiv k G).hom :=
begin
  refine chain_complex.to_single₀_ext _ _ _,
  dsimp,
  rw category.comp_id,
  exact (forget₂_to_Module_homotopy_equiv_f_0_eq k G).symm,
end

lemma quasi_iso_of_forget₂_ε_to_single₀ :
  quasi_iso (((forget₂ _ (Module.{u} k)).map_homological_complex _).map (ε_to_single₀ k G)) :=
begin
  have h : quasi_iso (forget₂_to_Module_homotopy_equiv k G).hom := homotopy_equiv.to_quasi_iso _,
  rw ← ε_to_single₀_comp_eq k G at h,
  haveI := h,
  exact quasi_iso_of_comp_right _ (((chain_complex.single₀_map_homological_complex _).hom.app _)),
end

instance : quasi_iso (ε_to_single₀ k G) :=
(forget₂ _ (Module.{u} k)).quasi_iso_of_map_quasi_iso _ (quasi_iso_of_forget₂_ε_to_single₀ k G)

end exactness
end group_cohomology.resolution
open group_cohomology.resolution

variables [group G]

/-- The standard projective resolution of `k` as a trivial `k`-linear `G`-representation. -/
def group_cohomology.ProjectiveResolution :
  ProjectiveResolution (Rep.trivial k G k) :=
(ε_to_single₀ k G).to_single₀_ProjectiveResolution (X_projective k G)

instance : enough_projectives (Rep k G) :=
Rep.equivalence_Module_monoid_algebra.enough_projectives_iff.2
  (Module.Module_enough_projectives.{u})

/-- Given a `k`-linear `G`-representation `V`, `Extⁿ(k, V)` (where `k` is a trivial `k`-linear
`G`-representation) is isomorphic to the `n`th cohomology group of `Hom(P, V)`, where `P` is the
standard resolution of `k` called `group_cohomology.resolution k G`. -/
def group_cohomology.Ext_iso (V : Rep k G) (n : ℕ) :
  ((Ext k (Rep k G) n).obj (opposite.op $ Rep.trivial k G k)).obj V ≅
    (((((linear_yoneda k (Rep k G)).obj V).right_op.map_homological_complex _).obj
      (group_cohomology.resolution k G)).homology n).unop :=
by let := (((linear_yoneda k (Rep k G)).obj V).right_op.left_derived_obj_iso
  n (group_cohomology.ProjectiveResolution k G)).unop.symm; exact this


-- Propiedad: Si divide a los sumandos divide a la suma (con condicionales)
-- ========================================================================

import tactic

variables (a b c : ℤ)

-- ----------------------------------------------------
-- Ejercicio. Demostrar que
--    a ∣ b → a ∣ c → a ∣ b+c
-- ----------------------------------------------------

#print notation (∣)

-- 1ª demostración
example :
  a ∣ b → a ∣ c → a ∣ b+c :=
begin
  intros hab hac,
  -- unfold has_dvd.dvd at hab,
  cases hab with k hk,
  rw hk,
  cases hac with l hl,
  rw hl,
  use k+l,
  ring,
end

-- 2ª demostración
example :
  a ∣ b → a ∣ c → a ∣ b+c :=
begin
  intros hab hac,
  -- unfold has_dvd.dvd at hab,
  rcases hab with ⟨k, rfl⟩,
  rcases hac with ⟨l, rfl⟩,
  use k+l,
  ring,
end

-- 3ª demostración
example :
  a ∣ b → a ∣ c → a ∣ b+c :=
begin
  rintros ⟨k, rfl⟩ ⟨l, rfl⟩,
  use k+l,
  ring,
end


/-
Copyright (c) 2022 Praneeth Kolichala. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Praneeth Kolichala
-/
import algebraic_topology.fundamental_groupoid.induced_maps
import topology.homotopy.contractible
import category_theory.punit
import algebraic_topology.fundamental_groupoid.punit

/-!
# Simply connected spaces
This file defines simply connected spaces.
A topological space is simply connected if its fundamental groupoid is equivalent to `unit`.

## Main theorems
  - `simply_connected_iff_unique_homotopic` - A space is simply connected if and only if it is
    nonempty and there is a unique path up to homotopy between any two points

  - `simply_connected_space.of_contractible` - A contractible space is simply connected
-/
noncomputable theory

open category_theory
open continuous_map
open_locale continuous_map

/-- A simply connected space is one whose fundamental groupoid is equivalent to `discrete unit` -/
class simply_connected_space (X : Type*) [topological_space X] : Prop :=
(equiv_unit [] : nonempty (fundamental_groupoid X ≌ discrete unit))

lemma simply_connected_def (X : Type*) [topological_space X] :
  simply_connected_space X ↔ nonempty (fundamental_groupoid X ≌ discrete unit) :=
⟨λ h, @simply_connected_space.equiv_unit X _ h, λ h, ⟨h⟩⟩

lemma simply_connected_iff_unique_homotopic (X : Type*) [topological_space X] :
  simply_connected_space X ↔ (nonempty X) ∧
  ∀ (x y : X), nonempty (unique (path.homotopic.quotient x y)) :=
by { rw [simply_connected_def, equiv_punit_iff_unique], refl, }

namespace simply_connected_space
variables {X : Type*} [topological_space X] [simply_connected_space X]

instance (x y : X) : subsingleton (path.homotopic.quotient x y) :=
@unique.subsingleton _ (nonempty.some (by { rw simply_connected_iff_unique_homotopic at *, tauto }))

local attribute [instance] path.homotopic.setoid

@[priority 100]
instance : path_connected_space X :=
let unique_homotopic := (simply_connected_iff_unique_homotopic X).mp infer_instance in
{ nonempty := unique_homotopic.1, joined := λ x y, ⟨(unique_homotopic.2 x y).some.default.out⟩, }

/-- In a simply connected space, any two paths are homotopic -/
lemma paths_homotopic {x y : X} (p₁ p₂ : path x y) : path.homotopic p₁ p₂ :=
by simpa using @subsingleton.elim (path.homotopic.quotient x y) _ ⟦p₁⟧ ⟦p₂⟧

@[priority 100]
instance of_contractible (Y : Type*) [topological_space Y] [contractible_space Y] :
  simply_connected_space Y :=
{ equiv_unit :=
  let H : Top.of Y ≃ₕ Top.of unit := (contractible_space.hequiv_unit Y).some in
  ⟨(fundamental_groupoid_functor.equiv_of_homotopy_equiv H).trans
    fundamental_groupoid.punit_equiv_discrete_punit⟩, }

end simply_connected_space

local attribute [instance] path.homotopic.setoid

/-- A space is simply connected iff it is path connected, and there is at most one path
  up to homotopy between any two points. -/
lemma simply_connected_iff_paths_homotopic {Y : Type*} [topological_space Y] :
  simply_connected_space Y ↔ (path_connected_space Y) ∧
  (∀ x y : Y, subsingleton (path.homotopic.quotient x y)) :=
⟨by { introI, split; apply_instance, },
λ h, begin
  casesI h, rw simply_connected_iff_unique_homotopic,
  exact ⟨infer_instance, λ x y, ⟨unique_of_subsingleton ⟦path_connected_space.some_path x y⟧⟩⟩,
end⟩

/-- Another version of `simply_connected_iff_paths_homotopic` -/
lemma simply_connected_iff_paths_homotopic' {Y : Type*} [topological_space Y] :
  simply_connected_space Y ↔ (path_connected_space Y) ∧
  (∀ {x y : Y} (p₁ p₂ : path x y), path.homotopic p₁ p₂) :=
begin
  convert simply_connected_iff_paths_homotopic,
  simp [path.homotopic.quotient, setoid.eq_top_iff], refl,
end


import analysis.special_functions.exp_log

lemma real.log_ne_zero_of_ne_one (x: ℝ) (hx_pos: 0 < x) (hx: x ≠ 1): real.log x ≠ 0 :=
begin
  by_cases (1 < x),
  exact ne_of_gt (real.log_pos h),
  push_neg at h,
  exact ne_of_lt (real.log_neg hx_pos (lt_of_le_of_ne h hx)),
end

lemma log_inj_pos {x y: ℝ} (x_pos: 0 < x) (y_pos: 0 < y):
  real.log x = real.log y → x = y :=
λ h, le_antisymm
  ((real.log_le_log x_pos y_pos).1 $ le_of_eq h)
  ((real.log_le_log y_pos x_pos).1 $ le_of_eq $ eq.symm h)


/-
Copyright (c) 2021 Justus Springer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Justus Springer
-/
import algebra.category.Mon.basic
import category_theory.limits.preserves.filtered
import category_theory.concrete_category.elementwise
import category_theory.limits.types

/-!
# The forgetful functor from (commutative) (additive) monoids preserves filtered colimits.

Forgetful functors from algebraic categories usually don't preserve colimits. However, they tend
to preserve _filtered_ colimits.

In this file, we start with a small filtered category `J` and a functor `F : J ⥤ Mon`.
We then construct a monoid structure on the colimit of `F ⋙ forget Mon` (in `Type`), thereby
showing that the forgetful functor `forget Mon` preserves filtered colimits. Similarly for `AddMon`,
`CommMon` and `AddCommMon`.

-/

universes v u

noncomputable theory
open_locale classical

open category_theory
open category_theory.limits
open category_theory.is_filtered (renaming max → max') -- avoid name collision with `_root_.max`.

namespace Mon.filtered_colimits

section

-- We use parameters here, mainly so we can have the abbreviations `M` and `M.mk` below, without
-- passing around `F` all the time.
parameters {J : Type v} [small_category J] (F : J ⥤ Mon.{max v u})

/--
The colimit of `F ⋙ forget Mon` in the category of types.
In the following, we will construct a monoid structure on `M`.
-/
@[to_additive "The colimit of `F ⋙ forget AddMon` in the category of types.
In the following, we will construct an additive monoid structure on `M`."]
abbreviation M : Type (max v u) := types.quot (F ⋙ forget Mon)

/-- The canonical projection into the colimit, as a quotient type. -/
@[to_additive "The canonical projection into the colimit, as a quotient type."]
abbreviation M.mk : (Σ j, F.obj j) → M := quot.mk (types.quot.rel (F ⋙ forget Mon))

@[to_additive]
lemma M.mk_eq (x y : Σ j, F.obj j)
  (h : ∃ (k : J) (f : x.1 ⟶ k) (g : y.1 ⟶ k), F.map f x.2 = F.map g y.2) :
  M.mk x = M.mk y :=
quot.eqv_gen_sound (types.filtered_colimit.eqv_gen_quot_rel_of_rel (F ⋙ forget Mon) x y h)

variables [is_filtered J]

/--
As `J` is nonempty, we can pick an arbitrary object `j₀ : J`. We use this object to define the
"one" in the colimit as the equivalence class of `⟨j₀, 1 : F.obj j₀⟩`.
-/
@[to_additive "As `J` is nonempty, we can pick an arbitrary object `j₀ : J`. We use this object to
define the \"zero\" in the colimit as the equivalence class of `⟨j₀, 0 : F.obj j₀⟩`."]
instance colimit_has_one : has_one M :=
{ one := M.mk ⟨is_filtered.nonempty.some, 1⟩ }

/--
The definition of the "one" in the colimit is independent of the chosen object of `J`.
In particular, this lemma allows us to "unfold" the definition of `colimit_one` at a custom chosen
object `j`.
-/
@[to_additive "The definition of the \"zero\" in the colimit is independent of the chosen object
of `J`. In particular, this lemma allows us to \"unfold\" the definition of `colimit_zero` at a
custom chosen object `j`."]
lemma colimit_one_eq (j : J) : (1 : M) = M.mk ⟨j, 1⟩ :=
begin
  apply M.mk_eq,
  refine ⟨max' _ j, left_to_max _ j, right_to_max _ j, _⟩,
  simp,
end

/--
The "unlifted" version of multiplication in the colimit. To multiply two dependent pairs
`⟨j₁, x⟩` and `⟨j₂, y⟩`, we pass to a common successor of `j₁` and `j₂` (given by `is_filtered.max`)
and multiply them there.
-/
@[to_additive "The \"unlifted\" version of addition in the colimit. To add two dependent pairs
`⟨j₁, x⟩` and `⟨j₂, y⟩`, we pass to a common successor of `j₁` and `j₂` (given by `is_filtered.max`)
and add them there."]
def colimit_mul_aux (x y : Σ j, F.obj j) : M :=
M.mk ⟨max' x.1 y.1, F.map (left_to_max x.1 y.1) x.2 * F.map (right_to_max x.1 y.1) y.2⟩

/-- Multiplication in the colimit is well-defined in the left argument. -/
@[to_additive "Addition in the colimit is well-defined in the left argument."]
lemma colimit_mul_aux_eq_of_rel_left {x x' y : Σ j, F.obj j}
  (hxx' : types.filtered_colimit.rel (F ⋙ forget Mon) x x') :
  colimit_mul_aux x y = colimit_mul_aux x' y :=
begin
  cases x with j₁ x, cases y with j₂ y, cases x' with j₃ x',
  obtain ⟨l, f, g, hfg⟩ := hxx',
  simp at hfg,
  obtain ⟨s, α, β, γ, h₁, h₂, h₃⟩ := tulip (left_to_max j₁ j₂) (right_to_max j₁ j₂)
    (right_to_max j₃ j₂) (left_to_max j₃ j₂) f g,
  apply M.mk_eq,
  use [s, α, γ],
  dsimp,
  simp_rw [monoid_hom.map_mul, ← comp_apply, ← F.map_comp, h₁, h₂, h₃, F.map_comp, comp_apply, hfg]
end

/-- Multiplication in the colimit is well-defined in the right argument. -/
@[to_additive "Addition in the colimit is well-defined in the right argument."]
lemma colimit_mul_aux_eq_of_rel_right {x y y' : Σ j, F.obj j}
  (hyy' : types.filtered_colimit.rel (F ⋙ forget Mon) y y') :
  colimit_mul_aux x y = colimit_mul_aux x y' :=
begin
  cases y with j₁ y, cases x with j₂ x, cases y' with j₃ y',
  obtain ⟨l, f, g, hfg⟩ := hyy',
  simp at hfg,
  obtain ⟨s, α, β, γ, h₁, h₂, h₃⟩ := tulip (right_to_max j₂ j₁) (left_to_max j₂ j₁)
    (left_to_max j₂ j₃) (right_to_max j₂ j₃) f g,
  apply M.mk_eq,
  use [s, α, γ],
  dsimp,
  simp_rw [monoid_hom.map_mul, ← comp_apply, ← F.map_comp, h₁, h₂, h₃, F.map_comp, comp_apply, hfg]
end

/-- Multiplication in the colimit. See also `colimit_mul_aux`. -/
@[to_additive "Addition in the colimit. See also `colimit_add_aux`."]
instance colimit_has_mul : has_mul M :=
{ mul := λ x y, begin
    refine quot.lift₂ (colimit_mul_aux F) _ _ x y,
  { intros x y y' h,
    apply colimit_mul_aux_eq_of_rel_right,
    apply types.filtered_colimit.rel_of_quot_rel,
    exact h },
  { intros x x' y h,
    apply colimit_mul_aux_eq_of_rel_left,
    apply types.filtered_colimit.rel_of_quot_rel,
    exact h },
  end }

/--
Multiplication in the colimit is independent of the chosen "maximum" in the filtered category.
In particular, this lemma allows us to "unfold" the definition of the multiplication of `x` and `y`,
using a custom object `k` and morphisms `f : x.1 ⟶ k` and `g : y.1 ⟶ k`.
-/
@[to_additive "Addition in the colimit is independent of the chosen \"maximum\" in the filtered
category. In particular, this lemma allows us to \"unfold\" the definition of the addition of `x`
and `y`, using a custom object `k` and morphisms `f : x.1 ⟶ k` and `g : y.1 ⟶ k`."]
lemma colimit_mul_mk_eq (x y : Σ j, F.obj j) (k : J) (f : x.1 ⟶ k) (g : y.1 ⟶ k) :
  (M.mk x) * (M.mk y) = M.mk ⟨k, F.map f x.2 * F.map g y.2⟩ :=
begin
  cases x with j₁ x, cases y with j₂ y,
  obtain ⟨s, α, β, h₁, h₂⟩ := bowtie (left_to_max j₁ j₂) f (right_to_max j₁ j₂) g,
  apply M.mk_eq,
  use [s, α, β],
  dsimp,
  simp_rw [monoid_hom.map_mul, ← comp_apply, ← F.map_comp, h₁, h₂],
end

@[to_additive]
instance colimit_monoid : monoid M :=
{ one_mul := λ x, begin
    apply quot.induction_on x, clear x, intro x, cases x with j x,
    rw [colimit_one_eq F j, colimit_mul_mk_eq F ⟨j, 1⟩ ⟨j, x⟩ j (𝟙 j) (𝟙 j),
      monoid_hom.map_one, one_mul, F.map_id, id_apply],
  end,
  mul_one := λ x, begin
    apply quot.induction_on x, clear x, intro x, cases x with j x,
    rw [colimit_one_eq F j, colimit_mul_mk_eq F ⟨j, x⟩ ⟨j, 1⟩ j (𝟙 j) (𝟙 j),
      monoid_hom.map_one, mul_one, F.map_id, id_apply],
  end,
  mul_assoc := λ x y z, begin
    apply quot.induction_on₃ x y z, clear x y z, intros x y z,
    cases x with j₁ x, cases y with j₂ y, cases z with j₃ z,
    rw [colimit_mul_mk_eq F ⟨j₁, x⟩ ⟨j₂, y⟩ _ (first_to_max₃ j₁ j₂ j₃) (second_to_max₃ j₁ j₂ j₃),
      colimit_mul_mk_eq F ⟨max₃ j₁ j₂ j₃, _⟩ ⟨j₃, z⟩ _ (𝟙 _) (third_to_max₃ j₁ j₂ j₃),
      colimit_mul_mk_eq F ⟨j₂, y⟩ ⟨j₃, z⟩ _ (second_to_max₃ j₁ j₂ j₃) (third_to_max₃ j₁ j₂ j₃),
      colimit_mul_mk_eq F ⟨j₁, x⟩ ⟨max₃ j₁ j₂ j₃, _⟩ _ (first_to_max₃ j₁ j₂ j₃) (𝟙 _)],
    simp only [F.map_id, id_apply, mul_assoc],
  end,
  ..colimit_has_one,
  ..colimit_has_mul }

/-- The bundled monoid giving the filtered colimit of a diagram. -/
@[to_additive "The bundled additive monoid giving the filtered colimit of a diagram."]
def colimit : Mon := Mon.of M

/-- The monoid homomorphism from a given monoid in the diagram to the colimit monoid. -/
@[to_additive "The additive monoid homomorphism from a given additive monoid in the diagram to the
colimit additive monoid."]
def cocone_morphism (j : J) : F.obj j ⟶ colimit :=
{ to_fun := (types.colimit_cocone (F ⋙ forget Mon)).ι.app j,
  map_one' := (colimit_one_eq j).symm,
  map_mul' := λ x y, begin
    convert (colimit_mul_mk_eq F ⟨j, x⟩ ⟨j, y⟩ j (𝟙 j) (𝟙 j)).symm,
    rw [F.map_id, id_apply, id_apply], refl,
  end }

@[simp, to_additive]
lemma cocone_naturality {j j' : J} (f : j ⟶ j') :
  F.map f ≫ (cocone_morphism j') = cocone_morphism j :=
monoid_hom.coe_inj ((types.colimit_cocone (F ⋙ forget Mon)).ι.naturality f)

/-- The cocone over the proposed colimit monoid. -/
@[to_additive "The cocone over the proposed colimit additive monoid."]
def colimit_cocone : cocone F :=
{ X := colimit,
  ι := { app := cocone_morphism } }.

/--
Given a cocone `t` of `F`, the induced monoid homomorphism from the colimit to the cocone point.
As a function, this is simply given by the induced map of the corresponding cocone in `Type`.
The only thing left to see is that it is a monoid homomorphism.
-/
@[to_additive "Given a cocone `t` of `F`, the induced additive monoid homomorphism from the colimit
to the cocone point. As a function, this is simply given by the induced map of the corresponding
cocone in `Type`. The only thing left to see is that it is an additive monoid homomorphism."]
def colimit_desc (t : cocone F) : colimit ⟶ t.X :=
{ to_fun := (types.colimit_cocone_is_colimit (F ⋙ forget Mon)).desc ((forget Mon).map_cocone t),
  map_one' := begin
    rw colimit_one_eq F is_filtered.nonempty.some,
    exact monoid_hom.map_one _,
  end,
  map_mul' := λ x y, begin
    apply quot.induction_on₂ x y, clear x y, intros x y,
    cases x with i x, cases y with j y,
    rw colimit_mul_mk_eq F ⟨i, x⟩ ⟨j, y⟩ (max' i j) (left_to_max i j) (right_to_max i j),
    dsimp [types.colimit_cocone_is_colimit],
    rw [monoid_hom.map_mul, t.w_apply, t.w_apply],
  end }

/-- The proposed colimit cocone is a colimit in `Mon`. -/
@[to_additive "The proposed colimit cocone is a colimit in `AddMon`."]
def colimit_cocone_is_colimit : is_colimit colimit_cocone :=
{ desc := colimit_desc,
  fac' := λ t j, monoid_hom.coe_inj
    ((types.colimit_cocone_is_colimit (F ⋙ forget Mon)).fac ((forget Mon).map_cocone t) j),
  uniq' := λ t m h, monoid_hom.coe_inj $
    (types.colimit_cocone_is_colimit (F ⋙ forget Mon)).uniq ((forget Mon).map_cocone t) m
      (λ j, funext $ λ x, monoid_hom.congr_fun (h j) x) }

@[to_additive]
instance forget_preserves_filtered_colimits : preserves_filtered_colimits (forget Mon.{u}) :=
{ preserves_filtered_colimits := λ J _ _, by exactI
  { preserves_colimit := λ F, preserves_colimit_of_preserves_colimit_cocone
      (colimit_cocone_is_colimit.{u u} F) (types.colimit_cocone_is_colimit (F ⋙ forget Mon.{u})) } }

end

end Mon.filtered_colimits

namespace CommMon.filtered_colimits

open Mon.filtered_colimits (colimit_mul_mk_eq)

section

-- We use parameters here, mainly so we can have the abbreviation `M` below, without
-- passing around `F` all the time.
parameters {J : Type v} [small_category J] [is_filtered J] (F : J ⥤ CommMon.{max v u})

/--
The colimit of `F ⋙ forget₂ CommMon Mon` in the category `Mon`.
In the following, we will show that this has the structure of a _commutative_ monoid.
-/
@[to_additive "The colimit of `F ⋙ forget₂ AddCommMon AddMon` in the category `AddMon`. In the
following, we will show that this has the structure of a _commutative_ additive monoid."]
abbreviation M : Mon := Mon.filtered_colimits.colimit (F ⋙ forget₂ CommMon Mon.{max v u})

@[to_additive]
instance colimit_comm_monoid : comm_monoid M :=
{ mul_comm := λ x y, begin
    apply quot.induction_on₂ x y, clear x y, intros x y,
    let k := max' x.1 y.1,
    let f := left_to_max x.1 y.1,
    let g := right_to_max x.1 y.1,
    rw [colimit_mul_mk_eq _ x y k f g, colimit_mul_mk_eq _ y x k g f],
    dsimp,
    rw mul_comm,
 end
  ..M.monoid }

/-- The bundled commutative monoid giving the filtered colimit of a diagram. -/
@[to_additive "The bundled additive commutative monoid giving the filtered colimit of a diagram."]
def colimit : CommMon := CommMon.of M

/-- The cocone over the proposed colimit commutative monoid. -/
@[to_additive "The cocone over the proposed colimit additive commutative monoid."]
def colimit_cocone : cocone F :=
{ X := colimit,
  ι := { ..(Mon.filtered_colimits.colimit_cocone (F ⋙ forget₂ CommMon Mon.{max v u})).ι } }

/-- The proposed colimit cocone is a colimit in `CommMon`. -/
@[to_additive "The proposed colimit cocone is a colimit in `AddCommMon`."]
def colimit_cocone_is_colimit : is_colimit colimit_cocone :=
{ desc := λ t, Mon.filtered_colimits.colimit_desc (F ⋙ forget₂ CommMon Mon.{max v u})
    ((forget₂ CommMon Mon.{max v u}).map_cocone t),
  fac' := λ t j, monoid_hom.coe_inj $
    (types.colimit_cocone_is_colimit (F ⋙ forget CommMon)).fac ((forget CommMon).map_cocone t) j,
  uniq' := λ t m h, monoid_hom.coe_inj $
    (types.colimit_cocone_is_colimit (F ⋙ forget CommMon)).uniq ((forget CommMon).map_cocone t) m
    ((λ j, funext $ λ x, monoid_hom.congr_fun (h j) x)) }

@[to_additive forget₂_AddMon_preserves_filtered_colimits]
instance forget₂_Mon_preserves_filtered_colimits :
  preserves_filtered_colimits (forget₂ CommMon Mon.{u}) :=
{ preserves_filtered_colimits := λ J _ _, by exactI
  { preserves_colimit := λ F, preserves_colimit_of_preserves_colimit_cocone
      (colimit_cocone_is_colimit.{u u} F)
      (Mon.filtered_colimits.colimit_cocone_is_colimit (F ⋙ forget₂ CommMon Mon.{u})) } }

@[to_additive]
instance forget_preserves_filtered_colimits :
  preserves_filtered_colimits (forget CommMon.{u}) :=
limits.comp_preserves_filtered_colimits (forget₂ CommMon Mon) (forget Mon)

end

end CommMon.filtered_colimits