/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.sums.basic
import Mathlib.PostPort

universes u v

namespace Mathlib

/-#
The associator functor `((C ⊕ D) ⊕ E) ⥤ (C ⊕ (D ⊕ E))` and its inverse form an equivalence.
-/

namespace category_theory.sum

/--
The associator functor `(C ⊕ D) ⊕ E ⥤ C ⊕ (D ⊕ E)` for sums of categories.
-/
def associator (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] :
    (C ⊕ D) ⊕ E ⥤ C ⊕ D ⊕ E :=
  functor.mk (fun (X : (C ⊕ D) ⊕ E) => sorry) fun (X Y : (C ⊕ D) ⊕ E) (f : X ⟶ Y) => sorry

@[simp] theorem associator_obj_inl_inl (C : Type u) [category C] (D : Type u) [category D]
    (E : Type u) [category E] (X : C) :
    functor.obj (associator C D E) (sum.inl (sum.inl X)) = sum.inl X :=
  rfl

@[simp] theorem associator_obj_inl_inr (C : Type u) [category C] (D : Type u) [category D]
    (E : Type u) [category E] (X : D) :
    functor.obj (associator C D E) (sum.inl (sum.inr X)) = sum.inr (sum.inl X) :=
  rfl

@[simp] theorem associator_obj_inr (C : Type u) [category C] (D : Type u) [category D] (E : Type u)
    [category E] (X : E) : functor.obj (associator C D E) (sum.inr X) = sum.inr (sum.inr X) :=
  rfl

@[simp] theorem associator_map_inl_inl (C : Type u) [category C] (D : Type u) [category D]
    (E : Type u) [category E] {X : C} {Y : C} (f : sum.inl (sum.inl X) ⟶ sum.inl (sum.inl Y)) :
    functor.map (associator C D E) f = f :=
  rfl

@[simp] theorem associator_map_inl_inr (C : Type u) [category C] (D : Type u) [category D]
    (E : Type u) [category E] {X : D} {Y : D} (f : sum.inl (sum.inr X) ⟶ sum.inl (sum.inr Y)) :
    functor.map (associator C D E) f = f :=
  rfl

@[simp] theorem associator_map_inr (C : Type u) [category C] (D : Type u) [category D] (E : Type u)
    [category E] {X : E} {Y : E} (f : sum.inr X ⟶ sum.inr Y) :
    functor.map (associator C D E) f = f :=
  rfl

/--
The inverse associator functor `C ⊕ (D ⊕ E) ⥤ (C ⊕ D) ⊕ E` for sums of categories.
-/
def inverse_associator (C : Type u) [category C] (D : Type u) [category D] (E : Type u)
    [category E] : C ⊕ D ⊕ E ⥤ (C ⊕ D) ⊕ E :=
  functor.mk (fun (X : C ⊕ D ⊕ E) => sorry) fun (X Y : C ⊕ D ⊕ E) (f : X ⟶ Y) => sorry

@[simp] theorem inverse_associator_obj_inl (C : Type u) [category C] (D : Type u) [category D]
    (E : Type u) [category E] (X : C) :
    functor.obj (inverse_associator C D E) (sum.inl X) = sum.inl (sum.inl X) :=
  rfl

@[simp] theorem inverse_associator_obj_inr_inl (C : Type u) [category C] (D : Type u) [category D]
    (E : Type u) [category E] (X : D) :
    functor.obj (inverse_associator C D E) (sum.inr (sum.inl X)) = sum.inl (sum.inr X) :=
  rfl

@[simp] theorem inverse_associator_obj_inr_inr (C : Type u) [category C] (D : Type u) [category D]
    (E : Type u) [category E] (X : E) :
    functor.obj (inverse_associator C D E) (sum.inr (sum.inr X)) = sum.inr X :=
  rfl

@[simp] theorem inverse_associator_map_inl (C : Type u) [category C] (D : Type u) [category D]
    (E : Type u) [category E] {X : C} {Y : C} (f : sum.inl X ⟶ sum.inl Y) :
    functor.map (inverse_associator C D E) f = f :=
  rfl

@[simp] theorem inverse_associator_map_inr_inl (C : Type u) [category C] (D : Type u) [category D]
    (E : Type u) [category E] {X : D} {Y : D} (f : sum.inr (sum.inl X) ⟶ sum.inr (sum.inl Y)) :
    functor.map (inverse_associator C D E) f = f :=
  rfl

@[simp] theorem inverse_associator_map_inr_inr (C : Type u) [category C] (D : Type u) [category D]
    (E : Type u) [category E] {X : E} {Y : E} (f : sum.inr (sum.inr X) ⟶ sum.inr (sum.inr Y)) :
    functor.map (inverse_associator C D E) f = f :=
  rfl

/--
The equivalence of categories expressing associativity of sums of categories.
-/
def associativity (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] :
    (C ⊕ D) ⊕ E ≌ C ⊕ D ⊕ E :=
  equivalence.mk (associator C D E) (inverse_associator C D E)
    (nat_iso.of_components (fun (X : (C ⊕ D) ⊕ E) => eq_to_iso sorry) sorry)
    (nat_iso.of_components (fun (X : C ⊕ D ⊕ E) => eq_to_iso sorry) sorry)

protected instance associator_is_equivalence (C : Type u) [category C] (D : Type u) [category D]
    (E : Type u) [category E] : is_equivalence (associator C D E) :=
  is_equivalence.of_equivalence (associativity C D E)

protected instance inverse_associator_is_equivalence (C : Type u) [category C] (D : Type u)
    [category D] (E : Type u) [category E] : is_equivalence (inverse_associator C D E) :=
  is_equivalence.of_equivalence_inverse (associativity C D E)

end Mathlib


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import linear_algebra.affine_space.affine_map
import algebra.invertible

/-!
# Affine equivalences

In this file we define `affine_equiv k P₁ P₂` (notation: `P₁ ≃ᵃ[k] P₂`) to be the type of affine
equivalences between `P₁` and `P₂, i.e., equivalences such that both forward and inverse maps are
affine maps.

We define the following equivalences:

* `affine_equiv.refl k P`: the identity map as an `affine_equiv`;

* `e.symm`: the inverse map of an `affine_equiv` as an `affine_equiv`;

* `e.trans e'`: composition of two `affine_equiv`s; note that the order follows `mathlib`'s
  `category_theory` convention (apply `e`, then `e'`), not the convention used in function
  composition and compositions of bundled morphisms.

## Tags

affine space, affine equivalence
-/

open function set
open_locale affine

/-- An affine equivalence is an equivalence between affine spaces such that both forward
and inverse maps are affine.

We define it using an `equiv` for the map and a `linear_equiv` for the linear part in order
to allow affine equivalences with good definitional equalities. -/
@[nolint has_inhabited_instance]
structure affine_equiv (k P₁ P₂ : Type*) {V₁ V₂ : Type*} [ring k]
  [add_comm_group V₁] [module k V₁] [add_torsor V₁ P₁]
  [add_comm_group V₂] [module k V₂] [add_torsor V₂ P₂] extends P₁ ≃ P₂ :=
(linear : V₁ ≃ₗ[k] V₂)
(map_vadd' : ∀ (p : P₁) (v : V₁), to_equiv (v +ᵥ p) = linear v +ᵥ to_equiv p)

notation P₁ ` ≃ᵃ[`:25 k:25 `] `:0 P₂:0 := affine_equiv k P₁ P₂

instance (k : Type*) {V1 : Type*} (P1 : Type*) {V2 : Type*} (P2 : Type*)
  [ring k]
  [add_comm_group V1] [module k V1] [affine_space V1 P1]
  [add_comm_group V2] [module k V2] [affine_space V2 P2] :
  has_coe_to_fun (P1 ≃ᵃ[k] P2) :=
⟨_, λ e, e.to_fun⟩

variables {k V₁ V₂ V₃ V₄ P₁ P₂ P₃ P₄ : Type*} [ring k]
  [add_comm_group V₁] [module k V₁] [add_torsor V₁ P₁]
  [add_comm_group V₂] [module k V₂] [add_torsor V₂ P₂]
  [add_comm_group V₃] [module k V₃] [add_torsor V₃ P₃]
  [add_comm_group V₄] [module k V₄] [add_torsor V₄ P₄]

namespace linear_equiv

/-- Interpret a linear equivalence between modules as an affine equivalence. -/
def to_affine_equiv (e : V₁ ≃ₗ[k] V₂) : V₁ ≃ᵃ[k] V₂ :=
{ to_equiv := e.to_equiv,
  linear := e,
  map_vadd' := λ p v, e.map_add v p }

@[simp] lemma coe_to_affine_equiv (e : V₁ ≃ₗ[k] V₂) : ⇑e.to_affine_equiv = e := rfl

end linear_equiv

namespace affine_equiv

variables (k P₁)

include V₁

/-- Identity map as an `affine_equiv`. -/
@[refl] def refl : P₁ ≃ᵃ[k] P₁ :=
{ to_equiv := equiv.refl P₁,
  linear := linear_equiv.refl k V₁,
  map_vadd' := λ _ _, rfl }

@[simp] lemma coe_refl : ⇑(refl k P₁) = id := rfl

lemma refl_apply (x : P₁) : refl k P₁ x = x := rfl

@[simp] lemma to_equiv_refl : (refl k P₁).to_equiv = equiv.refl P₁ := rfl

@[simp] lemma linear_refl : (refl k P₁).linear = linear_equiv.refl k V₁ := rfl

variables {k P₁}

include V₂

@[simp] lemma map_vadd (e : P₁ ≃ᵃ[k] P₂) (p : P₁) (v : V₁) : e (v +ᵥ p) = e.linear v +ᵥ e p :=
e.map_vadd' p v

@[simp] lemma coe_to_equiv (e : P₁ ≃ᵃ[k] P₂) : ⇑e.to_equiv = e := rfl

/-- Reinterpret an `affine_equiv` as an `affine_map`. -/
def to_affine_map (e : P₁ ≃ᵃ[k] P₂) : P₁ →ᵃ[k] P₂ := { to_fun := e, .. e }

@[simp] lemma coe_to_affine_map (e : P₁ ≃ᵃ[k] P₂) :
  (e.to_affine_map : P₁ → P₂) = (e : P₁ → P₂) :=
rfl

@[simp] lemma to_affine_map_mk (f : P₁ ≃ P₂) (f' : V₁ ≃ₗ[k] V₂) (h) :
  to_affine_map (mk f f' h) = ⟨f, f', h⟩ :=
rfl

@[simp] lemma linear_to_affine_map (e : P₁ ≃ᵃ[k] P₂) : e.to_affine_map.linear = e.linear := rfl

lemma to_affine_map_injective : injective (to_affine_map : (P₁ ≃ᵃ[k] P₂) → (P₁ →ᵃ[k] P₂)) :=
begin
  rintros ⟨e, el, h⟩ ⟨e', el', h'⟩ H,
  simp only [to_affine_map_mk, equiv.coe_inj, linear_equiv.to_linear_map_inj] at H,
  congr,
  exacts [H.1, H.2]
end

@[simp] lemma to_affine_map_inj {e e' : P₁ ≃ᵃ[k] P₂} :
  e.to_affine_map = e'.to_affine_map ↔ e = e' :=
to_affine_map_injective.eq_iff

@[ext] lemma ext {e e' : P₁ ≃ᵃ[k] P₂} (h : ∀ x, e x = e' x) : e = e' :=
to_affine_map_injective $ affine_map.ext h

lemma coe_fn_injective : injective (λ (e : P₁ ≃ᵃ[k] P₂) (x : P₁), e x) :=
λ e e' H, ext $ congr_fun H

@[simp, norm_cast] lemma coe_fn_inj {e e' : P₁ ≃ᵃ[k] P₂} : ⇑e = e' ↔ e = e' :=
coe_fn_injective.eq_iff

lemma to_equiv_injective : injective (to_equiv : (P₁ ≃ᵃ[k] P₂) → (P₁ ≃ P₂)) :=
λ e e' H, ext $ equiv.ext_iff.1 H

@[simp] lemma to_equiv_inj {e e' : P₁ ≃ᵃ[k] P₂} : e.to_equiv = e'.to_equiv ↔ e = e' :=
to_equiv_injective.eq_iff

/-- Construct an affine equivalence by verifying the relation between the map and its linear part at
one base point. Namely, this function takes an equivalence `e : P₁ ≃ P₂`, a linear equivalece
`e' : V₁ ≃ₗ[k] V₂`, and a point `p` such that for any other point `p'` we have
`e p' = e' (p' -ᵥ p) +ᵥ e p`. -/
def mk' (e : P₁ ≃ P₂) (e' : V₁ ≃ₗ[k] V₂) (p : P₁) (h : ∀ p' : P₁, e p' = e' (p' -ᵥ p) +ᵥ e p) :
  P₁ ≃ᵃ[k] P₂ :=
{ to_equiv := e,
  linear := e',
  .. affine_map.mk' e (e' : V₁ →ₗ[k] V₂) p h }

@[simp] lemma coe_mk' (e : P₁ ≃ P₂) (e' : V₁ ≃ₗ[k] V₂) (p h) : ⇑(mk' e e' p h) = e := rfl
@[simp] lemma to_equiv_mk' (e : P₁ ≃ P₂) (e' : V₁ ≃ₗ[k] V₂) (p h) :
  (mk' e e' p h).to_equiv = e := rfl
@[simp] lemma linear_mk' (e : P₁ ≃ P₂) (e' : V₁ ≃ₗ[k] V₂) (p h) :
  (mk' e e' p h).linear = e' := rfl

/-- Inverse of an affine equivalence as an affine equivalence. -/
@[symm] def symm (e : P₁ ≃ᵃ[k] P₂) : P₂ ≃ᵃ[k] P₁ :=
{ to_equiv := e.to_equiv.symm,
  linear := e.linear.symm,
  map_vadd' := λ v p, e.to_equiv.symm.apply_eq_iff_eq_symm_apply.2 $
    by simpa using (e.to_equiv.apply_symm_apply v).symm }

@[simp] lemma symm_to_equiv (e : P₁ ≃ᵃ[k] P₂) : e.to_equiv.symm = e.symm.to_equiv := rfl

@[simp] lemma symm_linear (e : P₁ ≃ᵃ[k] P₂) : e.linear.symm = e.symm.linear := rfl

protected lemma bijective (e : P₁ ≃ᵃ[k] P₂) : bijective e := e.to_equiv.bijective
protected lemma surjective (e : P₁ ≃ᵃ[k] P₂) : surjective e := e.to_equiv.surjective
protected lemma injective (e : P₁ ≃ᵃ[k] P₂) : injective e := e.to_equiv.injective

@[simp] lemma range_eq (e : P₁ ≃ᵃ[k] P₂) : range e = univ := e.surjective.range_eq

@[simp] lemma apply_symm_apply (e : P₁ ≃ᵃ[k] P₂) (p : P₂) : e (e.symm p) = p :=
e.to_equiv.apply_symm_apply p

@[simp] lemma symm_apply_apply (e : P₁ ≃ᵃ[k] P₂) (p : P₁) : e.symm (e p) = p :=
e.to_equiv.symm_apply_apply p

lemma apply_eq_iff_eq_symm_apply (e : P₁ ≃ᵃ[k] P₂) {p₁ p₂} : e p₁ = p₂ ↔ p₁ = e.symm p₂ :=
e.to_equiv.apply_eq_iff_eq_symm_apply

@[simp] lemma apply_eq_iff_eq (e : P₁ ≃ᵃ[k] P₂) {p₁ p₂ : P₁} : e p₁ = e p₂ ↔ p₁ = p₂ :=
e.to_equiv.apply_eq_iff_eq

omit V₂

@[simp] lemma symm_refl : (refl k P₁).symm = refl k P₁ := rfl

include V₂ V₃

/-- Composition of two `affine_equiv`alences, applied left to right. -/
@[trans] def trans (e : P₁ ≃ᵃ[k] P₂) (e' : P₂ ≃ᵃ[k] P₃) : P₁ ≃ᵃ[k] P₃ :=
{ to_equiv := e.to_equiv.trans e'.to_equiv,
  linear := e.linear.trans e'.linear,
  map_vadd' := λ p v, by simp only [linear_equiv.trans_apply, coe_to_equiv, (∘),
    equiv.coe_trans, map_vadd] }

@[simp] lemma coe_trans (e : P₁ ≃ᵃ[k] P₂) (e' : P₂ ≃ᵃ[k] P₃) : ⇑(e.trans e') = e' ∘ e := rfl

lemma trans_apply (e : P₁ ≃ᵃ[k] P₂) (e' : P₂ ≃ᵃ[k] P₃) (p : P₁) : e.trans e' p = e' (e p) := rfl

include V₄

lemma trans_assoc (e₁ : P₁ ≃ᵃ[k] P₂) (e₂ : P₂ ≃ᵃ[k] P₃) (e₃ : P₃ ≃ᵃ[k] P₄) :
  (e₁.trans e₂).trans e₃ = e₁.trans (e₂.trans e₃) :=
ext $ λ _, rfl

omit V₃ V₄

@[simp] lemma trans_refl (e : P₁ ≃ᵃ[k] P₂) : e.trans (refl k P₂) = e :=
ext $ λ _, rfl

@[simp] lemma refl_trans (e : P₁ ≃ᵃ[k] P₂) : (refl k P₁).trans e = e :=
ext $ λ _, rfl

@[simp] lemma trans_symm (e : P₁ ≃ᵃ[k] P₂) : e.trans e.symm = refl k P₁ :=
ext e.symm_apply_apply

@[simp] lemma symm_trans (e : P₁ ≃ᵃ[k] P₂) : e.symm.trans e = refl k P₂ :=
ext e.apply_symm_apply

@[simp] lemma apply_line_map (e : P₁ ≃ᵃ[k] P₂) (a b : P₁) (c : k) :
  e (affine_map.line_map a b c) = affine_map.line_map (e a) (e b) c :=
e.to_affine_map.apply_line_map a b c

omit V₂

instance : group (P₁ ≃ᵃ[k] P₁) :=
{ one := refl k P₁,
  mul := λ e e', e'.trans e,
  inv := symm,
  mul_assoc := λ e₁ e₂ e₃, trans_assoc _ _ _,
  one_mul := trans_refl,
  mul_one := refl_trans,
  mul_left_inv := trans_symm }

lemma one_def : (1 : P₁ ≃ᵃ[k] P₁) = refl k P₁ := rfl

@[simp] lemma coe_one : ⇑(1 : P₁ ≃ᵃ[k] P₁) = id := rfl

lemma mul_def (e e' : P₁ ≃ᵃ[k] P₁) : e * e' = e'.trans e := rfl

@[simp] lemma coe_mul (e e' : P₁ ≃ᵃ[k] P₁) : ⇑(e * e') = e ∘ e' := rfl

lemma inv_def (e : P₁ ≃ᵃ[k] P₁) : e⁻¹ = e.symm := rfl

variable (k)

/-- The map `v ↦ v +ᵥ b` as an affine equivalence between a module `V` and an affine space `P` with
tangent space `V`. -/
def vadd_const (b : P₁) : V₁ ≃ᵃ[k] P₁ :=
{ to_equiv := equiv.vadd_const b,
  linear := linear_equiv.refl _ _,
  map_vadd' := λ p v, add_vadd _ _ _  }

@[simp] lemma linear_vadd_const (b : P₁) : (vadd_const k b).linear = linear_equiv.refl k V₁ := rfl

@[simp] lemma vadd_const_apply (b : P₁) (v : V₁) : vadd_const k b v = v +ᵥ b := rfl

@[simp] lemma vadd_const_symm_apply (b p : P₁) : (vadd_const k b).symm p = p -ᵥ b := rfl

/-- `p' ↦ p -ᵥ p'` as an equivalence. -/
def const_vsub (p : P₁) : P₁ ≃ᵃ[k] V₁ :=
{ to_equiv := equiv.const_vsub p,
  linear := linear_equiv.neg k,
  map_vadd' := λ p' v, by simp [vsub_vadd_eq_vsub_sub, neg_add_eq_sub] }

@[simp] lemma coe_const_vsub (p : P₁) : ⇑(const_vsub k p) = (-ᵥ) p := rfl

@[simp] lemma coe_const_vsub_symm (p : P₁) : ⇑(const_vsub k p).symm = λ v, -v +ᵥ p := rfl

variable (P₁)

/-- The map `p ↦ v +ᵥ p` as an affine automorphism of an affine space. -/
def const_vadd (v : V₁) : P₁ ≃ᵃ[k] P₁ :=
{ to_equiv := equiv.const_vadd P₁ v,
  linear := linear_equiv.refl _ _,
  map_vadd' := λ p w, vadd_comm _ _ _ }

@[simp] lemma linear_const_vadd (v : V₁) : (const_vadd k P₁ v).linear = linear_equiv.refl _ _ := rfl

@[simp] lemma const_vadd_apply (v : V₁) (p : P₁) : const_vadd k P₁ v p = v +ᵥ p := rfl

@[simp] lemma const_vadd_symm_apply (v : V₁) (p : P₁) : (const_vadd k P₁ v).symm p = -v +ᵥ p := rfl

variable {P₁}
open function

/-- Point reflection in `x` as a permutation. -/
def point_reflection (x : P₁) : P₁ ≃ᵃ[k] P₁ := (const_vsub k x).trans (vadd_const k x)

lemma point_reflection_apply (x y : P₁) : point_reflection k x y = x -ᵥ y +ᵥ x := rfl

@[simp] lemma point_reflection_symm (x : P₁) : (point_reflection k x).symm = point_reflection k x :=
to_equiv_injective $ equiv.point_reflection_symm x

@[simp] lemma to_equiv_point_reflection (x : P₁) :
  (point_reflection k x).to_equiv = equiv.point_reflection x :=
rfl

@[simp] lemma point_reflection_self (x : P₁) : point_reflection k x x = x := vsub_vadd _ _

lemma point_reflection_involutive (x : P₁) : involutive (point_reflection k x : P₁ → P₁) :=
equiv.point_reflection_involutive x

/-- `x` is the only fixed point of `point_reflection x`. This lemma requires
`x + x = y + y ↔ x = y`. There is no typeclass to use here, so we add it as an explicit argument. -/
lemma point_reflection_fixed_iff_of_injective_bit0 {x y : P₁} (h : injective (bit0 : V₁ → V₁)) :
  point_reflection k x y = y ↔ y = x :=
equiv.point_reflection_fixed_iff_of_injective_bit0 h

lemma injective_point_reflection_left_of_injective_bit0 (h : injective (bit0 : V₁ → V₁)) (y : P₁) :
  injective (λ x : P₁, point_reflection k x y) :=
equiv.injective_point_reflection_left_of_injective_bit0 h y

lemma injective_point_reflection_left_of_module [invertible (2:k)]:
  ∀ y, injective (λ x : P₁, point_reflection k x y) :=
injective_point_reflection_left_of_injective_bit0 k $ λ x y h,
  by rwa [bit0, bit0, ← two_smul k x, ← two_smul k y,
    (is_unit_of_invertible (2:k)).smul_left_cancel] at h

lemma point_reflection_fixed_iff_of_module [invertible (2:k)] {x y : P₁} :
  point_reflection k x y = y ↔ y = x :=
((injective_point_reflection_left_of_module k y).eq_iff' (point_reflection_self k y)).trans eq_comm

end affine_equiv

namespace affine_map

open affine_equiv

include V₁

lemma line_map_vadd (v v' : V₁) (p : P₁) (c : k) :
  line_map v v' c +ᵥ p = line_map (v +ᵥ p) (v' +ᵥ p) c :=
(vadd_const k p).apply_line_map v v' c

lemma line_map_vsub (p₁ p₂ p₃ : P₁) (c : k) :
  line_map p₁ p₂ c -ᵥ p₃ = line_map (p₁ -ᵥ p₃) (p₂ -ᵥ p₃) c :=
(vadd_const k p₃).symm.apply_line_map p₁ p₂ c

lemma vsub_line_map (p₁ p₂ p₃ : P₁) (c : k) :
  p₁ -ᵥ line_map p₂ p₃ c = line_map (p₁ -ᵥ p₂) (p₁ -ᵥ p₃) c :=
(const_vsub k p₁).apply_line_map p₂ p₃ c

lemma vadd_line_map (v : V₁) (p₁ p₂ : P₁) (c : k) :
  v +ᵥ line_map p₁ p₂ c = line_map (v +ᵥ p₁) (v +ᵥ p₂) c :=
(const_vadd k P₁ v).apply_line_map p₁ p₂ c

variables {R' : Type*} [comm_ring R'] [module R' V₁]

lemma homothety_neg_one_apply (c p : P₁) :
  homothety c (-1:R') p = point_reflection R' c p :=
by simp [homothety_apply, point_reflection_apply]

end affine_map


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Moncalc.Data.List.Misc
import Moncalc.Data.DVect2.Defs

namespace DVect2

universe u u₁ u₂ v v₁ v₂ w₁ w₂

variable {α : Type u₁} {β : Type u₂} {γ : α → β → Type v}

-- Since we are discussing a dependent type, we need the "parameter-heterogeneous" equality instead of the ordinary one.
protected
inductive Eq : {as₁ as₂ : List α} → {bs₁ bs₂ : List β} → DVect2 γ as₁ bs₁ → DVect2 γ as₂ bs₂ → Prop
| nil_rfl : DVect2.Eq DVect2.nil DVect2.nil
| descend : {a : α} → {b : β} → {f₁ f₂ : γ a b} → {as₁ as₂ : List α} → {bs₁ bs₂ : List β} → {fs₁ : DVect2 γ as₁ bs₁} → {fs₂ : DVect2 γ as₂ bs₂} → f₁ = f₂ → DVect2.Eq fs₁ fs₂ → DVect2.Eq (cons f₁ fs₁) (cons f₂ fs₂)

local infix:50 " ≡ " => DVect2.Eq

namespace Eq

--- `DVect2.Eq` implies `Eq` provided that the dependent parameters are (definitionally) same.
protected
theorem eq_of : ∀ {as : List α} {bs : List β} {fs gs : DVect2 γ as bs}, fs ≡ gs → fs = gs
| [], [], DVect2.nil, DVect2.nil, DVect2.Eq.nil_rfl => rfl
| (_::_), (_::_), DVect2.cons _ _, DVect2.cons _ _, DVect2.Eq.descend rfl hfsgs =>
  DVect2.Eq.eq_of hfsgs ▸ rfl

--- `DVect2.Eq` from `Eq`
protected
theorem of : ∀ {as : List α} {bs : List β} {fs gs : DVect2 γ as bs}, fs = gs → fs ≡ gs
| [], [], DVect2.nil, _, rfl => DVect2.Eq.nil_rfl
| (_::_), (_::_), DVect2.cons _ _, _, rfl =>
  DVect2.Eq.descend rfl (Eq.of rfl)

--- `DVect2.Eq` is transitive.
protected
theorem trans : ∀ {as₁ as₂ as₃ : List α} {bs₁ bs₂ bs₃ : List β} {fs₁ : DVect2 γ as₁ bs₁} {fs₂ : DVect2 γ as₂ bs₂} {fs₃ : DVect2 γ as₃ bs₃}, fs₁ ≡ fs₂ → fs₂ ≡ fs₃ → fs₁ ≡ fs₃
| [], [], [], [], [], [], DVect2.nil, DVect2.nil, DVect2.nil, DVect2.Eq.nil_rfl, DVect2.Eq.nil_rfl => DVect2.Eq.nil_rfl
| (_::_), (_::_), (_::_), (_::_), (_::_), (_::_), DVect2.cons _ _, DVect2.cons _ _, DVect2.cons _ _, DVect2.Eq.descend rfl h₁, DVect2.Eq.descend rfl h₂ =>
  DVect2.Eq.descend rfl (DVect2.Eq.trans h₁ h₂)

instance instDVect2EqTrans (as₁ as₂ as₃ : List α) (bs₁ bs₂ bs₃ : List β) : Trans (DVect2.Eq (γ:=γ) (as₁:=as₁) (as₂:=as₂) (bs₁:=bs₁) (bs₂:=bs₂)) (DVect2.Eq (as₁:=as₂) (as₂:=as₃) (bs₁:=bs₂) (bs₂:=bs₃)) (DVect2.Eq (as₁:=as₁) (as₂:=as₃) (bs₁:=bs₁) (bs₂:=bs₃)) :=
  Trans.mk DVect2.Eq.trans

--- `DVect2.Eq` is symmetric
protected
theorem symm : ∀ {as₁ as₂ : List α} {bs₁ bs₂ : List β} {fs₁ : DVect2 γ as₁ bs₁} {fs₂ : DVect2 γ as₂ bs₂}, fs₁ ≡ fs₂ → fs₂ ≡ fs₁
| [], [], [], [], DVect2.nil, DVect2.nil, DVect2.Eq.nil_rfl => DVect2.Eq.nil_rfl
| (_::_), (_::_), (_::_), (_::_), DVect2.cons _ _, DVect2.cons _ _ , DVect2.Eq.descend rfl h =>
  DVect2.Eq.descend rfl h.symm

end Eq

--- `DVect2.map` preserves the identity map
theorem map_id : ∀ {as : List α} {bs : List β} {xs : DVect2 γ as bs}, DVect2.map id id id xs ≡ xs
| [], [], DVect2.nil => DVect2.Eq.nil_rfl
| (_::_), (_::_), DVect2.cons _ xs => DVect2.Eq.descend rfl (map_id (xs:=xs))

--- `DVect2.map` respects function composition
theorem map_comp {α₁ α₂ : Type _} {β₁ β₂: Type _} {γ₁ : α₁ → β₁ → Type _} {γ₂ : α₂ → β₂ → Type _} {f₁ : α₁ → α₂} {f : α → α₁} {g₁ : β₁ → β₂} {g : β → β₁} {h₁ : {a₁ : α₁} → {b₁ : β₁} → γ₁ a₁ b₁ → γ₂ (f₁ a₁) (g₁ b₁)} {h : {a : α} → {b : β} → γ a b → γ₁ (f a) (g b)} : ∀ {as : List α} {bs : List β} {xs : DVect2 γ as bs}, DVect2.map (f₁∘ f) (g₁∘ g) (h₁∘ h) xs ≡ DVect2.map f₁ g₁ h₁ (DVect2.map f g h xs)
| [], [], DVect2.nil => DVect2.Eq.nil_rfl
| (_::_), (_::_), DVect2.cons _ xs => DVect2.Eq.descend rfl (map_comp (xs:=xs))

--- `DVect2.append` is left unital with respect to `nil`.
@[simp]
theorem nil_append {as : List α} {bs : List β} (fs : DVect2 γ as bs) : DVect2.nil (γ:=γ) ++ fs = fs :=
  rfl

@[simp]
theorem cons_append {a : α} {b : β} (f : γ a b) {as₁ as₂ : List α} {bs₁ bs₂ : List β} (fs₁ : DVect2 γ as₁ bs₁) (fs₂ : DVect2 γ as₂ bs₂) : DVect2.cons f fs₁ ++ fs₂ = DVect2.cons f (fs₁ ++ fs₂) :=
  rfl

--- `DVect2.append` is right unital with respect to `nil`.
theorem append_nil : ∀ {as : List α} {bs : List β} (fs : DVect2 γ as bs), fs ++ DVect2.nil (γ:=γ) ≡ fs
| [], [], DVect2.nil => DVect2.Eq.nil_rfl
| (_::_), (_::_), DVect2.cons f fs => by
  rw [cons_append]
  exact DVect2.Eq.descend rfl (append_nil fs)

theorem append_assoc : ∀ {as₁ as₂ as₃ : List α} {bs₁ bs₂ bs₃ : List β} (fs₁ : DVect2 γ as₁ bs₁) (fs₂ : DVect2 γ as₂ bs₂) (fs₃ : DVect2 γ as₃ bs₃), fs₁ ++ fs₂ ++ fs₃ ≡ fs₁ ++ (fs₂ ++ fs₃)
| [], _, _, [], _, _, DVect2.nil, fs₂, fs₃ => Eq.of rfl
| (_::_), _, _, (_::_), _, _, DVect2.cons f fs₁, fs₂, fs₃ => by
  have h_ind := append_assoc fs₁ fs₂ fs₃
  dsimp [HAppend.hAppend, DVect2.append] at *
  exact DVect2.Eq.descend rfl h_ind

--- congruence of `DVect2.append` with respect to `DVect2.Eq`.
theorem eq_of_eq_append_eq : ∀ {as₁ as₂ as₁' as₂': List α} {bs₁ bs₂ bs₁' bs₂' : List β} {fs₁ : DVect2 γ as₁ bs₁} {fs₂ : DVect2 γ as₂ bs₂} {fs₁' : DVect2 γ as₁' bs₁'} {fs₂' : DVect2 γ as₂' bs₂'}, fs₁ ≡ fs₁' → fs₂ ≡ fs₂' → fs₁ ++ fs₂ ≡ fs₁' ++ fs₂'
| [], _, [], _, [], _, [], _, DVect2.nil, _, DVect2.nil, _, DVect2.Eq.nil_rfl, hfs₂ =>
  hfs₂
| (_::_), _, (_::_), _, (_::_), _, (_::_), _, DVect2.cons _ _, _, DVect2.cons _ _, _, DVect2.Eq.descend hf hfs₁, hfs₂ =>
  DVect2.Eq.descend hf (eq_of_eq_append_eq hfs₁ hfs₂)

theorem map_append {α₁ β₁: Type _} {γ₁ : α₁ → β₁ → Type _} (f : α → α₁) (g : β → β₁) (h : {a : α} → {b : β} → γ a b → γ₁ (f a) (g b)) : ∀ {as₁ as₂ : List α} {bs₁ bs₂ : List β} {xs₁ : DVect2 γ as₁ bs₁} {xs₂ : DVect2 γ as₂ bs₂}, DVect2.map f g h (xs₁ ++ xs₂) ≡ DVect2.map f g h xs₁ ++ DVect2.map f g h xs₂
| [], _, [], _, DVect2.nil, _ => DVect2.Eq.of rfl
| (_::_), _, (_::_), _, DVect2.cons _ xs₁, xs₂ => by
  dsimp [map]
  apply DVect2.Eq.descend rfl
  exact map_append f g h (xs₁:=xs₁) (xs₂:=xs₂)

--- `DVect2.join` distributes to `DVect2.append`
theorem join_append : ∀ {ass₁ ass₂ : List (List α)} {bss₁ bss₂ : List (List β)} (fss₁ : DVect2 (DVect2 γ) ass₁ bss₁) (fss₂ : DVect2 (DVect2 γ) ass₂ bss₂), (fss₁ ++ fss₂).join ≡ fss₁.join ++ fss₂.join
| [], ass₂, [], bss₂, DVect2.nil, fss₂ => DVect2.Eq.of rfl
| (_::_), ass₂, (_::_), bss₂, DVect2.cons fs₁ fss₁, fss₂ => by
  have h_ind := join_append fss₁ fss₂
  dsimp [DVect2.join, HAppend.hAppend] at *
  apply DVect2.Eq.trans _ (append_assoc fs₁ fss₁.join fss₂.join).symm
  induction fs₁
  case nil => exact h_ind
  case cons _ _ hfs =>
    exact DVect2.Eq.descend rfl hfs

--- Two different ways to flatten `DVect2 (DVect2 (DVect2 γ))` results in the same.
theorem join_join : ∀ {asss : List (List (List α))} {bsss : List (List (List β))} (fsss : DVect2 (DVect2 (DVect2 γ)) asss bsss), fsss.join.join ≡ (fsss.map List.join List.join DVect2.join).join
| [], [], DVect2.nil => DVect2.Eq.nil_rfl
| (_::_), (_::_), DVect2.cons fs fsss => by
  dsimp [DVect2.join, DVect2.map]
  apply DVect2.Eq.trans (DVect2.join_append fs _) _
  apply eq_of_eq_append_eq (DVect2.Eq.of rfl)
  exact join_join fsss

--- `DVect2.fromList` preserves `append` (or `HAppend.hAppend` more precisely).
theorem fromList_append {α : Type u} (γ : α → α → Type v) (f : (a : α) → γ a a) : ∀ {as bs : List α}, fromList γ f (as++bs) = fromList γ f as ++ fromList γ f bs
| [], _ => rfl
| (_::as), bs => by
  dsimp [fromList]
  rw [cons_append]
  rw [fromList_append γ f (as:=as) (bs:=bs)]

--- `DVect2.dfromList` preserves `append` (or `HAppend.hAppend` more precisely).
theorem dfromList_append {α : Type u} {β₁ : Type u₁} {β₂ : Type u₂} {γ : β₁ → β₂ → Type v} (f₁ : α → β₁) (f₂ : α → β₂) (g : (a : α) → γ (f₁ a) (f₂ a)) : ∀ {as bs : List α}, dfromList f₁ f₂ g (as++bs) ≡ dfromList f₁ f₂ g as ++ dfromList f₁ f₂ g bs
| [], bs => DVect2.Eq.of rfl
| (a::as), bs => by
  dsimp [dfromList]
  rw [cons_append]
  apply DVect2.Eq.descend rfl
  exact dfromList_append f₁ f₂ g (as:=as) (bs:=bs)

end DVect2


import algebraic_topology.simplicial_object
import algebraic_topology.simplicial_set
import category_theory.functor.basic
import combinatorics.quiver.basic
import combinatorics.quiver.path

open sSet quiver category_theory
open category_theory.simplicial_object
open category_theory.functor

variable {X : sSet}

notation (name := simplicial_object.at) X ` _[`:1000 n `]` :=
  (X : category_theory.simplicial_object hole!).obj (opposite.op (simplex_category.mk n))

instance underlying : quiver (X _[0]) := by refine {
  hom := λ A B, {edge : X _[1] // X.δ 1 edge = A ∧ X.δ 0 edge = B}
}

def edge_to_qedge (edge : X _[1]) (A B : X _[0]) (σ : X.δ 1 edge = A) (τ : X.δ 0 edge = B) :
A ⟶ B := subtype.mk edge (by split; assumption)

def edge_to_path (edge : X _[1]) (A B : X _[0]) (σ : X.δ 1 edge = A) (τ : X.δ 0 edge = B) :
path A B := path.nil.cons (edge_to_qedge edge A B σ τ)

infix `**`:50 := path.comp

@[simp] lemma edge_to_qedge_inv_coe
  {edge : X _[1]} {A B : X _[0]} {σ : X.δ 1 edge = A} {τ : X.δ 0 edge = B} :
  ↑(edge_to_qedge edge A B σ τ) = edge := begin
  rw ← subtype.val_eq_coe, dsimp [edge_to_qedge], refl,
end

-- witnesses 0-simplices a, b as the boundary of 1-simplex ab
def ends (ab : X _[1]) (a b : X _[0]) := (X.δ 1 ab = a) ∧ (X.δ 0 ab = b)

def ends.default (ab : X _[1]) : ends ab (X.δ 1 ab) (X.δ 0 ab) :=
and.intro (eq.refl _) (eq.refl _)

def ends.degen (A : X _[0]) : ends (X.σ 0 A) A A := begin
  split, have : X.δ 1 (X.σ 0 A) = (X.σ 0 ≫ X.δ 1) A, refl, rw this,
  have H := @δ_comp_σ_succ _ _  X 0 0, simp at H,
  rw H, simp,
  have : X.δ 0 (X.σ 0 A) = (X.σ 0 ≫ X.δ 0) A, refl, rw this,
  have H := @δ_comp_σ_self _ _ X 0 0, simp at H, rw H, simp,
end

-- produces a path a -> b given a proof that a, b are the boundary of a 1-simplex
def to_path {ab : X _[1]} {a b : X _[0]} (ε : ends ab a b) :=
  edge_to_path ab a b ε.1 ε.2

lemma comp_of_app {n} {v : X _[n+2]} {i : fin(n+2)} {j : fin(n+3)} : X.δ i (X.δ j v) = (X.δ j ≫ X.δ i) v := by simp

lemma simplicial_11 (h : X _[2]) : X.δ 1 (X.δ 1 h) = X.δ 1 (X.δ 2 h) := begin
  repeat {rw comp_of_app},

  have H := @δ_comp_δ_self _ _ X 0 1,
  simp at H, rw H,
end

lemma simplicial_10 (h : X _[2]) : X.δ 1 (X.δ 0 h) = X.δ 0 (X.δ 2 h) := begin
  repeat {rw comp_of_app},

  have H := @δ_comp_δ _ _ X 0 0 1, simp at H, rw ← H,
end

lemma simplicial_00 (h : X _[2]) : X.δ 0 (X.δ 0 h) = X.δ 0 (X.δ 1 h) := begin
  repeat {rw comp_of_app},

  have H := @δ_comp_δ_self _ _ X 0 0,
  simp at H, rw H,
end

inductive homotopic'' (A B : X _[0]) : path A B → path A B → Prop
| homotopy (h : X _[2]) {C : X _[0]}
            (σ : X.δ 1 (X.δ 1 h) = A)
            (τ : X.δ 0 (X.δ 1 h) = B)
            (ρ : X.δ 0 (X.δ 2 h) = C) :
        homotopic'' (edge_to_path (X.δ 1 h) A B σ τ)
                  (path.comp
                    (edge_to_path (X.δ 2 h) A C ((simplicial_11 h).symm.trans σ)  ρ)
                    (edge_to_path (X.δ 0 h) C B ((simplicial_10 h).trans ρ) ((simplicial_00 h).trans τ)))

def degen_edge (A : X _[0]) : A ⟶ A := subtype.mk (X.σ 0 A) (ends.degen A)

inductive homotopic : Π (A B : X _[0]), path A B → path A B → Prop
| lift (A B : X _[0]) (p q : path A B) (h : homotopic'' A B p q) : homotopic A B p q
| degen (A : X _[0]) : homotopic A A (path.nil.cons $ degen_edge A) (path.nil)
| refl (A B : X _[0]) (p : path A B) : homotopic A B p p
| symm (A B : X _[0]) (p q : path A B) (h : homotopic A B p q) : homotopic A B q p
| trans (A B : X _[0]) (p q r : path A B) (h1 : homotopic A B p q) (h2 : homotopic A B q r) : homotopic A B p r
| comp_l (A B : X _[0]) {C : X _[0]} (p : path A C) (q r : path C B) (h : homotopic C B q r) : homotopic A B (p.comp q) (p.comp r)
| comp_r (A B : X _[0]) {C : X _[0]} (p q : path A C) (r : path C B) (h : homotopic A C p q) : homotopic A B (p.comp r) (q.comp r)

@[refl] lemma htpy_refl (A B : X _[0]) (p : path A B) :
homotopic A B p p := (homotopic.refl A B p)

@[symm] lemma htpy_symm (A B : X _[0]) (p q : path A B) :
homotopic A B p q → homotopic A B q p :=
λ h, (homotopic.symm A B p q h)

@[trans] lemma htpy_trans (A B : X _[0]) (p q r : path A B) :
homotopic A B p q → homotopic A B q r → homotopic A B p r :=
λ h1, λ h2, (homotopic.trans A B p q r h1 h2)

theorem htpy_is_equiv (A B : X _[0]) : equivalence (homotopic A B) :=
mk_equivalence (homotopic A B) (htpy_refl A B) (htpy_symm A B) (htpy_trans A B)


/-
Copyright (c) 2019 Bruno Bentzen. All rights reserved.
Released under the Apache License 2.0 (see "License");
Author: Bruno Bentzen
-/

import .meet

open interval

-- the join connection

def join.horn {A : Type} (kan : has_hcom2 A)
  (p : I → A) : horn2 A :=
let u := horn1.mk (λ _, p i0) (λ _, p i0) p rfl rfl in
horn2.mk (λ _ _, p i0)
(meet kan p) (λ i _, p i)
(meet kan p) (λ i _, p i)
((kan.eq0j (meet.horn kan p)).symm) rfl
((kan.eq0j (meet.horn kan p)).symm) rfl rfl
begin transitivity, apply kan.eq1i (meet.horn kan p), apply (kan.has1.t1 u) end
begin symmetry, transitivity, apply kan.eq1i (meet.horn kan p), apply (kan.has1.t1 u) end
rfl

def join.filler {A : Type} (kan : has_hcom2 A)
  (p : I → A) : I → I → I → A :=
kan.hcom2 (join.horn kan p)

def join {A : Type} (kan : has_hcom2 A)
  (p : I → A) : I → I → A :=
(join.filler kan p) i1

--notation p `[` j `∨` i `]` kan := join kan p j i

namespace join

lemma face0i {A : Type} (kan : has_hcom2 A)
  (p : I → A) : join kan p i0 = p :=
begin
  transitivity, apply kan.eq0j (join.horn kan p),
  transitivity, apply kan.eq1j (meet.horn kan p),
  apply (kan.has1.t1 (horn1.mk (λ _, p i0) (λ _, p i0) p rfl rfl))
end

lemma face1i {A : Type} (kan : has_hcom2 A)
  (p : I → A) : join kan p i1 = λ _, p i1 :=
kan.eq1j (join.horn kan p)

lemma face1j {A : Type} (kan : has_hcom2 A)
  (p : I → A) : (λ i, join kan p i i1) = λ _, p i1 :=
kan.eq1i (join.horn kan p)

lemma face0j {A : Type} (kan : has_hcom2 A)
  (p : I → A) : (λ i, join kan p i i0) = p :=
begin
  transitivity, apply kan.eq0i, -- (join.horn kan p)
  transitivity, apply kan.eq1j, -- (meet.horn kan p)
  apply (kan.has1.t1) -- (horn1.mk (λ _, p i0) (λ _, p i0) p rfl rfl)
end

end join

/-                   p                          --> i
        p i0 -----------------> p i1         j |
         |                     ||              v
         |                     ||
         |                     ||
       p |      join p j i     || λ _, p i1
         |                     ||
         |                     ||
         v                     ||
        p i1 ================== p i1
                  λ _, p i1
-/

/-def test2 {A : Type} {a b : A} (kan : has_hcom2 A) (p : path A a b) :
join kan (λ (i : I), p @@ i) i0 i0 = eq.mp rfl (p@@i0) :=
begin
  rw join.face0i, refl --apply path.app0
end

def test3 {A : Type} {a b : A} (kan : has_hcom2 A) (p : path A a b) :
join kan (λ (i : I), p @@ i) i0 i1 = eq.mp rfl (p@@i1) :=
begin
  rw join.face0i, refl
end

def test31 {A : Type} {a b : A} (kan : has_hcom2 A) (p : path A a b) :
  (λ i, p @@ i) i1 = eq.mp rfl (p @@ i1) :=
begin
  refl
end

variables {A : Type} {a b : A} (kan : has_hcom2 A) (p : path A a b)

#check join kan (λ i, p@@i) i0
#check (λ i, p@@i)
#check @pathdp.abs
#check pathdp.abs (λ i, p@@i) rfl rfl
#check pathdp.abs (join kan (λ (i : I), p @@ i) i0) rfl rfl

def joinsquare22 {A : Type} {a b : A} (kan : has_hcom2 A) (p : path A a b) :
  pathdp.abs (join kan (λ i, p@@i) i0) rfl rfl (test2 kan p) (test3 kan p) =
  eq.mp (path.tyeq p) p :=
begin
  transitivity, apply pathdp.abseq, apply join.face0i, --rw pathdp.eta,
  --have h : pathdp.abs (λ (i : I), p @@ i) rfl rfl _ _ =
  --         pathdp.abs (λ (i : I), p @@ i) rfl rfl (pathdp.app0 p) (pathdp.app1 p) :=
  --         pathdp.abs_irrel,
  apply pathdp.abs_irrel',
  --apply eq.mp, apply pathdp.abs_irrel,
  transitivity, exact pathdp.eta p rfl rfl (pathdp.app0 p) (pathdp.app1 p),
end

def joinsquare {A : Type} {a b : A} (kan : has_hcom2 A) (p : path A a b) :
  pathdp.abs (join kan (λ i, p@@i) i0) rfl rfl (test2 kan p) (test3 kan p) =
  eq.mp (path.tyeq p) p :=
begin
  --induction ((join.face0i kan (λ i, p@@i)).symm),
  transitivity, apply pathdp.eta.eq,
end

def tyeq_refl {A : I → Type} {A0 A1 : Type} {a : A i0} {b : A i1} (p : Π i, A i)
         {ha : A i0 = A i0} {hb : A i1 = A i1}
         (p0 : p i0 = eq.mp ha a) (p1 : p i1 = eq.mp hb b) :
(pathd.tyeq (pathdp.abs p ha hb p0 p1)) = refl :=
sorry

def joinsquare'' {A : Type} {a b : A} (p : path A a b) :
  pathdp.abs (pathdp.app p) rfl rfl rfl rfl = eq.mp (pathd.tyeq p) p :=
begin
  induction p, --induction p_ha,
  --induction (path.tyeq p),--induction p,
  --induction ((join.face0i kan (λ i, p@@i)).symm),
end

def joinsquare' {A : Type} {a b : A} (p : path A a b) (q : I → A)
  (h0 : q i0 = eq.mp rfl (p @@ i0)) (h1 : q i1 = eq.mp rfl (p @@ i1)) :
  pathdp.abs q rfl rfl h0 h1 =
  eq.mp (path.tyeq p) p :=
begin
  --induction ((join.face0i kan (λ i, p@@i)).symm),
end
--calc
--  pathdp.abs (join kan (λ i, p@@i) i0) rfl rfl (test2 kan p) (test3 kan p) =
--  pathdp.abs (λ i, p @@ i) rfl rfl rfl rfl : eq.rec _ (join.face0i kan (λ i, p@@i)).symm
--  ...                                                   = eq.mp (path.tyeq p) p : sorry

--eq.rec _ (join.face0i kan (λ i, p@@i)).symm
-- eq.rec (eq.rec _ (pathdp.eta p (pathdp.app0 p) (pathdp.app1 p))) (join.face0i kan (λ i, p@@i)).symm
-- (eq.rec _ (pathdp.eta (app p) (test2 kan p) (test3 kan p)))

--(eq.rec rfl (pathd.app0 p).symm) (eq.rec rfl (pathd.app1 p).symm)

def join0 {A : Type} {a b : A} (p : path A a b) : Type :=
pathdp (λ j, pathd (λ _, A) (p @@ j) b) p (path.refl b)

--set_option pp.implicit true

lemma pathjoin {A : Type} {a b : A} (kan : has_hcom2 A) (p : path A a b) :
  pathdp (λ j, pathd (λ _, A) (p @@ j) b) p (path.refl b) :=
begin
  fapply pathdp.abs,
    intro j, fapply pathdp.abs,
    intro i, apply join kan,
      apply (λ i, p @@ i), apply j, apply i,
      repeat {refl},
      apply (calc
        join kan (λ i, p@@i) j i0 = (λ i, join kan (λ i, p@@i) i i0) j : rfl
        ...                       = p@@j : by rw join.face0j kan ),
      apply (calc
        join kan (λ i, p@@i) j i1 = (λ i, join kan (λ i, p@@i) i i1) j : rfl
        ...                       = p@@i1 : by rw join.face1j kan
        ...                       = b : by apply path.app1 ),
      --rw pathd.app0, refl,
      --rw pathd.app1, refl,
      exact (eq.rec rfl (pathd.app0 p).symm),
      exact (eq.rec rfl (pathd.app1 p).symm),
      --simp, simp, transitivity, --rw join.face0i, -- (join.face0i kan (app p)),
      simp, simp,
      --rw join.face01 kan,
      --exact (eq.rec (λ x, pathdp.abs x _ _ _ _ = eq.rec p (eq.rec rfl (pathd.app0 p).symm)) (join.face0i kan (app p)) )

      --rw join.face01 kan (@app (λ (_x : I), A) ((λ (_x : I), A) i0) ((λ (_x : I), A) i1) a b _ _ p),
      -- (@join A kan (@app (λ (_x : I), A) ((λ (_x : I), A) i0) ((λ (_x : I), A) i1) a b _ _ p)
      --apply pathdp.eta,

-- join kan (λ (i : I), p@@i) j i0 = p@@j
end
-/


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.noetherian
import Mathlib.ring_theory.ideal.operations
import Mathlib.ring_theory.algebra_tower
import Mathlib.PostPort

universes u_1 u_4 u_2 u_5 u_3

namespace Mathlib

/-!
# Finiteness conditions in commutative algebra

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

## Main declarations

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

-/

/-- A module over a commutative ring is `finite` if it is finitely generated as a module. -/
def module.finite (R : Type u_1) (M : Type u_4) [comm_ring R] [add_comm_group M] [module R M] :=
  submodule.fg ⊤

/-- An algebra over a commutative ring is of `finite_type` if it is finitely generated
over the base ring as algebra. -/
def algebra.finite_type (R : Type u_1) (A : Type u_2) [comm_ring R] [comm_ring A] [algebra R A] :=
  subalgebra.fg ⊤

/-- An algebra over a commutative ring is `finitely_presented` if it is the quotient of a
polynomial ring in `n` variables by a finitely generated ideal. -/
def algebra.finitely_presented (R : Type u_1) (A : Type u_2) [comm_ring R] [comm_ring A] [algebra R A] :=
  ∃ (n : ℕ),
    ∃ (f : alg_hom R (mv_polynomial (fin n) R) A),
      function.surjective ⇑f ∧ submodule.fg (ring_hom.ker (alg_hom.to_ring_hom f))

namespace module

theorem finite_def {R : Type u_1} {M : Type u_4} [comm_ring R] [add_comm_group M] [module R M] : finite R M ↔ submodule.fg ⊤ :=
  iff.rfl

protected instance is_noetherian.finite (R : Type u_1) (M : Type u_4) [comm_ring R] [add_comm_group M] [module R M] [is_noetherian R M] : finite R M :=
  is_noetherian.noetherian ⊤

namespace finite

theorem of_surjective {R : Type u_1} {M : Type u_4} {N : Type u_5} [comm_ring R] [add_comm_group M] [module R M] [add_comm_group N] [module R N] [hM : finite R M] (f : linear_map R M N) (hf : function.surjective ⇑f) : finite R N := sorry

theorem of_injective {R : Type u_1} {M : Type u_4} {N : Type u_5} [comm_ring R] [add_comm_group M] [module R M] [add_comm_group N] [module R N] [is_noetherian R N] (f : linear_map R M N) (hf : function.injective ⇑f) : finite R M :=
  fg_of_injective f (iff.mpr linear_map.ker_eq_bot hf)

protected instance self (R : Type u_1) [comm_ring R] : finite R R :=
  Exists.intro (singleton 1)
    (eq.mpr
      (id
        ((fun (a a_1 : submodule R R) (e_1 : a = a_1) (ᾰ ᾰ_1 : submodule R R) (e_2 : ᾰ = ᾰ_1) =>
            congr (congr_arg Eq e_1) e_2)
          (submodule.span R ↑(singleton 1)) (submodule.span R (singleton 1))
          ((fun (s s_1 : set R) (e_2 : s = s_1) => congr_arg (submodule.span R) e_2) (↑(singleton 1)) (singleton 1)
            (finset.coe_singleton 1))
          ⊤ ⊤ (Eq.refl ⊤)))
      (eq.mp (Eq.refl (ideal.span 1 = ⊤)) ideal.span_singleton_one))

protected instance prod {R : Type u_1} {M : Type u_4} {N : Type u_5} [comm_ring R] [add_comm_group M] [module R M] [add_comm_group N] [module R N] [hM : finite R M] [hN : finite R N] : finite R (M × N) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (finite R (M × N))) (equations._eqn_1 R (M × N))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (submodule.fg ⊤)) (Eq.symm submodule.prod_top))) (submodule.fg_prod hM hN))

theorem equiv {R : Type u_1} {M : Type u_4} {N : Type u_5} [comm_ring R] [add_comm_group M] [module R M] [add_comm_group N] [module R N] [hM : finite R M] (e : linear_equiv R M N) : finite R N :=
  of_surjective (↑e) (linear_equiv.surjective e)

theorem trans {R : Type u_1} (A : Type u_2) (B : Type u_3) [comm_ring R] [comm_ring A] [algebra R A] [comm_ring B] [algebra R B] [algebra A B] [is_scalar_tower R A B] [hRA : finite R A] [hAB : finite A B] : finite R B := sorry

protected instance finite_type {R : Type u_1} (A : Type u_2) [comm_ring R] [comm_ring A] [algebra R A] [hRA : finite R A] : algebra.finite_type R A :=
  subalgebra.fg_of_submodule_fg hRA

end finite

end module

namespace algebra

namespace finite_type

theorem self (R : Type u_1) [comm_ring R] : finite_type R R :=
  Exists.intro (singleton 1) (subsingleton.elim (adjoin R ↑(singleton 1)) ⊤)

protected theorem mv_polynomial (R : Type u_1) [comm_ring R] (ι : Type u_2) [fintype ι] : finite_type R (mv_polynomial ι R) := sorry

theorem of_surjective {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A] [algebra R A] [comm_ring B] [algebra R B] (hRA : finite_type R A) (f : alg_hom R A B) (hf : function.surjective ⇑f) : finite_type R B := sorry

theorem equiv {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A] [algebra R A] [comm_ring B] [algebra R B] (hRA : finite_type R A) (e : alg_equiv R A B) : finite_type R B :=
  of_surjective hRA (↑e) (alg_equiv.surjective e)

theorem trans {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A] [algebra R A] [comm_ring B] [algebra R B] [algebra A B] [is_scalar_tower R A B] (hRA : finite_type R A) (hAB : finite_type A B) : finite_type R B :=
  fg_trans' hRA hAB

/-- An algebra is finitely generated if and only if it is a quotient
of a polynomial ring whose variables are indexed by a finset. -/
theorem iff_quotient_mv_polynomial {R : Type u_1} {A : Type u_2} [comm_ring R] [comm_ring A] [algebra R A] : finite_type R A ↔
  ∃ (s : finset A), ∃ (f : alg_hom R (mv_polynomial (Subtype fun (x : A) => x ∈ s) R) A), function.surjective ⇑f := sorry

/-- An algebra is finitely generated if and only if it is a quotient
of a polynomial ring whose variables are indexed by a fintype. -/
theorem iff_quotient_mv_polynomial' {R : Type u_1} {A : Type u_2} [comm_ring R] [comm_ring A] [algebra R A] : finite_type R A ↔ ∃ (ι : Type u_2), Exists (∃ (f : alg_hom R (mv_polynomial ι R) A), function.surjective ⇑f) := sorry

/-- An algebra is finitely generated if and only if it is a quotient of a polynomial ring in `n`
variables. -/
theorem iff_quotient_mv_polynomial'' {R : Type u_1} {A : Type u_2} [comm_ring R] [comm_ring A] [algebra R A] : finite_type R A ↔ ∃ (n : ℕ), ∃ (f : alg_hom R (mv_polynomial (fin n) R) A), function.surjective ⇑f := sorry

/-- A finitely presented algebra is of finite type. -/
theorem of_finitely_presented {R : Type u_1} {A : Type u_2} [comm_ring R] [comm_ring A] [algebra R A] : finitely_presented R A → finite_type R A := sorry

end finite_type

namespace finitely_presented

/-- If `e : A ≃ₐ[R] B` and `A` is finitely presented, then so is `B`. -/
theorem equiv (R : Type u_1) (A : Type u_2) (B : Type u_3) [comm_ring R] [comm_ring A] [algebra R A] [comm_ring B] [algebra R B] (hfp : finitely_presented R A) (e : alg_equiv R A B) : finitely_presented R B := sorry

/-- The ring of polynomials in finitely many variables is finitely presented. -/
theorem mv_polynomial (R : Type u_1) [comm_ring R] (ι : Type u_2) [fintype ι] : finitely_presented R (mv_polynomial ι R) := sorry

/-- `R` is finitely presented as `R`-algebra. -/
theorem self (R : Type u_1) [comm_ring R] : finitely_presented R R :=
  let hempty : finitely_presented R (mv_polynomial pempty R) := mv_polynomial R pempty;
  equiv R (mv_polynomial pempty R) R hempty (mv_polynomial.pempty_alg_equiv R)

end finitely_presented

end algebra

namespace ring_hom

/-- A ring morphism `A →+* B` is `finite` if `B` is finitely generated as `A`-module. -/
def finite {A : Type u_1} {B : Type u_2} [comm_ring A] [comm_ring B] (f : A →+* B) :=
  let _inst : algebra A B := to_algebra f;
  module.finite A B

/-- A ring morphism `A →+* B` is of `finite_type` if `B` is finitely generated as `A`-algebra. -/
def finite_type {A : Type u_1} {B : Type u_2} [comm_ring A] [comm_ring B] (f : A →+* B) :=
  algebra.finite_type A B

namespace finite

theorem id (A : Type u_1) [comm_ring A] : finite (id A) :=
  module.finite.self A

theorem of_surjective {A : Type u_1} {B : Type u_2} [comm_ring A] [comm_ring B] (f : A →+* B) (hf : function.surjective ⇑f) : finite f :=
  let _inst : algebra A B := to_algebra f;
  module.finite.of_surjective (alg_hom.to_linear_map (algebra.of_id A B)) hf

theorem comp {A : Type u_1} {B : Type u_2} {C : Type u_3} [comm_ring A] [comm_ring B] [comm_ring C] {g : B →+* C} {f : A →+* B} (hg : finite g) (hf : finite f) : finite (comp g f) :=
  module.finite.trans B C

theorem finite_type {A : Type u_1} {B : Type u_2} [comm_ring A] [comm_ring B] {f : A →+* B} (hf : finite f) : finite_type f :=
  module.finite.finite_type B

end finite

namespace finite_type

theorem id (A : Type u_1) [comm_ring A] : finite_type (id A) :=
  algebra.finite_type.self A

theorem comp_surjective {A : Type u_1} {B : Type u_2} {C : Type u_3} [comm_ring A] [comm_ring B] [comm_ring C] {f : A →+* B} {g : B →+* C} (hf : finite_type f) (hg : function.surjective ⇑g) : finite_type (comp g f) :=
  algebra.finite_type.of_surjective hf
    (alg_hom.mk (⇑g) (map_one' g) (map_mul' g) (map_zero' g) (map_add' g) fun (a : A) => rfl) hg

theorem of_surjective {A : Type u_1} {B : Type u_2} [comm_ring A] [comm_ring B] (f : A →+* B) (hf : function.surjective ⇑f) : finite_type f :=
  eq.mpr (id (Eq._oldrec (Eq.refl (finite_type f)) (Eq.symm (comp_id f)))) (comp_surjective (id A) hf)

theorem comp {A : Type u_1} {B : Type u_2} {C : Type u_3} [comm_ring A] [comm_ring B] [comm_ring C] {g : B →+* C} {f : A →+* B} (hg : finite_type g) (hf : finite_type f) : finite_type (comp g f) :=
  algebra.finite_type.trans hf hg

end finite_type

end ring_hom

namespace alg_hom

/-- An algebra morphism `A →ₐ[R] B` is finite if it is finite as ring morphism.
In other words, if `B` is finitely generated as `A`-module. -/
def finite {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A] [comm_ring B] [algebra R A] [algebra R B] (f : alg_hom R A B) :=
  ring_hom.finite (to_ring_hom f)

/-- An algebra morphism `A →ₐ[R] B` is of `finite_type` if it is of finite type as ring morphism.
In other words, if `B` is finitely generated as `A`-algebra. -/
def finite_type {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A] [comm_ring B] [algebra R A] [algebra R B] (f : alg_hom R A B) :=
  ring_hom.finite_type (to_ring_hom f)

namespace finite

theorem id (R : Type u_1) (A : Type u_2) [comm_ring R] [comm_ring A] [algebra R A] : finite (alg_hom.id R A) :=
  ring_hom.finite.id A

theorem comp {R : Type u_1} {A : Type u_2} {B : Type u_3} {C : Type u_4} [comm_ring R] [comm_ring A] [comm_ring B] [comm_ring C] [algebra R A] [algebra R B] [algebra R C] {g : alg_hom R B C} {f : alg_hom R A B} (hg : finite g) (hf : finite f) : finite (comp g f) :=
  ring_hom.finite.comp hg hf

theorem of_surjective {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A] [comm_ring B] [algebra R A] [algebra R B] (f : alg_hom R A B) (hf : function.surjective ⇑f) : finite f :=
  ring_hom.finite.of_surjective (↑f) hf

theorem finite_type {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A] [comm_ring B] [algebra R A] [algebra R B] {f : alg_hom R A B} (hf : finite f) : finite_type f :=
  ring_hom.finite.finite_type hf

end finite

namespace finite_type

theorem id (R : Type u_1) (A : Type u_2) [comm_ring R] [comm_ring A] [algebra R A] : finite_type (alg_hom.id R A) :=
  ring_hom.finite_type.id A

theorem comp {R : Type u_1} {A : Type u_2} {B : Type u_3} {C : Type u_4} [comm_ring R] [comm_ring A] [comm_ring B] [comm_ring C] [algebra R A] [algebra R B] [algebra R C] {g : alg_hom R B C} {f : alg_hom R A B} (hg : finite_type g) (hf : finite_type f) : finite_type (comp g f) :=
  ring_hom.finite_type.comp hg hf

theorem comp_surjective {R : Type u_1} {A : Type u_2} {B : Type u_3} {C : Type u_4} [comm_ring R] [comm_ring A] [comm_ring B] [comm_ring C] [algebra R A] [algebra R B] [algebra R C] {f : alg_hom R A B} {g : alg_hom R B C} (hf : finite_type f) (hg : function.surjective ⇑g) : finite_type (comp g f) :=
  ring_hom.finite_type.comp_surjective hf hg

theorem of_surjective {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A] [comm_ring B] [algebra R A] [algebra R B] (f : alg_hom R A B) (hf : function.surjective ⇑f) : finite_type f :=
  ring_hom.finite_type.of_surjective (↑f) hf


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Chris Hughes, Morenikeji Neri
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.noetherian
import Mathlib.ring_theory.unique_factorization_domain
import Mathlib.PostPort

universes u v l u_1 u_2

namespace Mathlib

/-!
# Principal ideal rings and principal ideal domains

A principal ideal ring (PIR) is a commutative ring in which all ideals are principal. A
principal ideal domain (PID) is an integral domain which is a principal ideal ring.

# Main definitions

Note that for principal ideal domains, one should use
`[integral domain R] [is_principal_ideal_ring R]`. There is no explicit definition of a PID.
Theorems about PID's are in the `principal_ideal_ring` namespace.

- `is_principal_ideal_ring`: a predicate on commutative rings, saying that every
  ideal is principal.
- `generator`: a generator of a principal ideal (or more generally submodule)
- `to_unique_factorization_monoid`: a PID is a unique factorization domain

# Main results

- `to_maximal_ideal`: a non-zero prime ideal in a PID is maximal.
- `euclidean_domain.to_principal_ideal_domain` : a Euclidean domain is a PID.

-/

/-- An `R`-submodule of `M` is principal if it is generated by one element. -/
class submodule.is_principal {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    (S : submodule R M)
    where
  principal : ∃ (a : M), S = submodule.span R (singleton a)

/-- A commutative ring is a principal ideal ring if all ideals are principal. -/
class is_principal_ideal_ring (R : Type u) [comm_ring R] where
  principal : ∀ (S : ideal R), submodule.is_principal S

namespace submodule.is_principal

/-- `generator I`, if `I` is a principal submodule, is an `x ∈ M` such that `span R {x} = I` -/
def generator {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M] [module R M]
    (S : submodule R M) [is_principal S] : M :=
  classical.some sorry

theorem span_singleton_generator {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M]
    [module R M] (S : submodule R M) [is_principal S] : span R (singleton (generator S)) = S :=
  Eq.symm (classical.some_spec (principal S))

@[simp] theorem generator_mem {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M]
    [module R M] (S : submodule R M) [is_principal S] : generator S ∈ S :=
  sorry

theorem mem_iff_eq_smul_generator {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M]
    [module R M] (S : submodule R M) [is_principal S] {x : M} :
    x ∈ S ↔ ∃ (s : R), x = s • generator S :=
  sorry

theorem mem_iff_generator_dvd {R : Type u} [comm_ring R] (S : ideal R) [is_principal S] {x : R} :
    x ∈ S ↔ generator S ∣ x :=
  sorry

theorem eq_bot_iff_generator_eq_zero {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M]
    [module R M] (S : submodule R M) [is_principal S] : S = ⊥ ↔ generator S = 0 :=
  eq.mpr
    (id (Eq._oldrec (Eq.refl (S = ⊥ ↔ generator S = 0)) (Eq.symm (propext span_singleton_eq_bot))))
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (S = ⊥ ↔ span R (singleton (generator S)) = ⊥))
          (span_singleton_generator S)))
      (iff.refl (S = ⊥)))

end submodule.is_principal

namespace is_prime

-- TODO -- for a non-ID one could perhaps prove that if p < q are prime then q maximal;

-- 0 isn't prime in a non-ID PIR but the Krull dimension is still <= 1.

-- The below result follows from this, but we could also use the below result to

-- prove this (quotient out by p).

theorem to_maximal_ideal {R : Type u} [integral_domain R] [is_principal_ideal_ring R] {S : ideal R}
    [hpi : ideal.is_prime S] (hS : S ≠ ⊥) : ideal.is_maximal S :=
  sorry

end is_prime

theorem mod_mem_iff {R : Type u} [euclidean_domain R] {S : ideal R} {x : R} {y : R} (hy : y ∈ S) :
    x % y ∈ S ↔ x ∈ S :=
  sorry

protected instance euclidean_domain.to_principal_ideal_domain {R : Type u} [euclidean_domain R] :
    is_principal_ideal_ring R :=
  sorry

namespace principal_ideal_ring

protected instance is_noetherian_ring {R : Type u} [integral_domain R] [is_principal_ideal_ring R] :
    is_noetherian_ring R :=
  is_noetherian.mk
    fun (s : ideal R) =>
      Exists.dcases_on (submodule.is_principal.principal s)
        fun (a : R) (h : s = submodule.span R (singleton a)) =>
          Eq._oldrec
            (eq.mpr
              (id
                (Eq._oldrec (Eq.refl (submodule.fg (submodule.span R (singleton a))))
                  (Eq.symm (finset.coe_singleton a))))
              (Exists.intro (singleton a) (submodule.coe_injective rfl)))
            (Eq.symm h)

theorem is_maximal_of_irreducible {R : Type u} [integral_domain R] [is_principal_ideal_ring R]
    {p : R} (hp : irreducible p) : ideal.is_maximal (submodule.span R (singleton p)) :=
  sorry

theorem irreducible_iff_prime {R : Type u} [integral_domain R] [is_principal_ideal_ring R] {p : R} :
    irreducible p ↔ prime p :=
  sorry

theorem associates_irreducible_iff_prime {R : Type u} [integral_domain R]
    [is_principal_ideal_ring R] {p : associates R} : irreducible p ↔ prime p :=
  iff.mp associates.irreducible_iff_prime_iff fun (_x : R) => irreducible_iff_prime

/-- `factors a` is a multiset of irreducible elements whose product is `a`, up to units -/
def factors {R : Type u} [integral_domain R] [is_principal_ideal_ring R] (a : R) : multiset R :=
  dite (a = 0) (fun (h : a = 0) => ∅) fun (h : ¬a = 0) => classical.some sorry

theorem factors_spec {R : Type u} [integral_domain R] [is_principal_ideal_ring R] (a : R)
    (h : a ≠ 0) :
    (∀ (b : R), b ∈ factors a → irreducible b) ∧ associated (multiset.prod (factors a)) a :=
  sorry

theorem ne_zero_of_mem_factors {R : Type v} [integral_domain R] [is_principal_ideal_ring R] {a : R}
    {b : R} (ha : a ≠ 0) (hb : b ∈ factors a) : b ≠ 0 :=
  irreducible.ne_zero (and.left (factors_spec a ha) b hb)

theorem mem_submonoid_of_factors_subset_of_units_subset {R : Type u} [integral_domain R]
    [is_principal_ideal_ring R] (s : submonoid R) {a : R} (ha : a ≠ 0)
    (hfac : ∀ (b : R), b ∈ factors a → b ∈ s) (hunit : ∀ (c : units R), ↑c ∈ s) : a ∈ s :=
  sorry

/-- If a `ring_hom` maps all units and all factors of an element `a` into a submonoid `s`, then it
also maps `a` into that submonoid. -/
theorem ring_hom_mem_submonoid_of_factors_subset_of_units_subset {R : Type u_1} {S : Type u_2}
    [integral_domain R] [is_principal_ideal_ring R] [semiring S] (f : R →+* S) (s : submonoid S)
    (a : R) (ha : a ≠ 0) (h : ∀ (b : R), b ∈ factors a → coe_fn f b ∈ s)
    (hf : ∀ (c : units R), coe_fn f ↑c ∈ s) : coe_fn f a ∈ s :=
  mem_submonoid_of_factors_subset_of_units_subset (submonoid.comap (ring_hom.to_monoid_hom f) s) ha
    h hf

/-- A principal ideal domain has unique factorization -/
protected instance to_unique_factorization_monoid {R : Type u} [integral_domain R]
    [is_principal_ideal_ring R] : unique_factorization_monoid R :=
  unique_factorization_monoid.mk fun (_x : R) => irreducible_iff_prime

end Mathlib