import category_theory.limits.concrete_category
import topology.category.Profinite.as_limit
import for_mathlib.Profinite.compat_discrete_quotient
import for_mathlib.Cech.split

noncomputable theory

open category_theory

universe u

namespace Profinite

variables (F : arrow Profinite.{u}) (surj : function.surjective F.hom)

open discrete_quotient

/-- A diagram of arrows construction from discrete quotients of F.left. -/
@[simps]
def fintype_arrow_diagram : discrete_quotient F.left ⥤ arrow Fintype.{u} :=
{ obj := λ S,
  { left := Fintype.of S,
    right := Fintype.of $ S.make F.hom surj,
    hom := discrete_quotient.map (S.make_le_comap _ _) },
  map := λ S T f,
  { left := of_le $ le_of_hom f,
    right := of_le $ make_right_mono F.hom surj S T $ le_of_hom f } }.

/-- A diagram of arrows construction from discrete quotients of F.left. -/
@[simps]
def arrow_diagram : discrete_quotient F.left ⥤ arrow Profinite.{u} :=
fintype_arrow_diagram F surj ⋙ Fintype.to_Profinite.map_arrow

/-- The left diagram associated to arrow_diagram. -/
abbreviation left_arrow_diagram : discrete_quotient F.left ⥤ Profinite.{u} :=
arrow_diagram F surj ⋙ arrow.left_func

/-- The right diagram associated to arrow_diagram. -/
abbreviation right_arrow_diagram : discrete_quotient F.left ⥤ Profinite.{u} :=
arrow_diagram F surj ⋙ arrow.right_func

lemma arrow_diagram_surjective (S : discrete_quotient F.left) :
  function.surjective ((arrow_diagram F surj).obj S).hom :=
begin
  rintro ⟨x⟩,
  obtain ⟨x,rfl⟩ := surj x,
  exact ⟨S.proj x,rfl⟩,
end

instance (S : discrete_quotient F.left) : arrow.split ((arrow_diagram F surj).obj S) :=
{ σ := ⟨λ x, classical.some (arrow_diagram_surjective F surj S x),
    continuous_of_discrete_topology⟩,
  is_splitting' := begin
    ext x,
    erw classical.some_spec (arrow_diagram_surjective F surj S x),
    refl,
  end }

/-- A cone which is a limit expressing an arrow as a limit. -/
@[simps]
def arrow_cone : limits.cone (arrow_diagram F surj) :=
{ X := F,
  π :=
  { app := λ S,
    { left := ⟨S.proj, S.proj_continuous⟩,
      right := ⟨(S.make _ surj).proj,
        (S.make _ surj).proj_continuous⟩ } } }

/-- A helper definition used for `arrow_limit_cone`. -/
def arrow_diagram_snd_preserves :
  limits.preserves_limit (arrow_diagram F surj ⋙ comma.snd _ _) (𝟭 _) :=
begin
  have h := limits.id_preserves_limits.preserves_limits_of_shape,
  have hh := h.preserves_limit,
  exact hh,
end

/-- the limit cone assocciated to arrow_diagram -/
@[simps]
def arrow_limit_cone : limits.limit_cone (arrow_diagram F surj) :=
{ cone := @comma.cone_of_preserves _ _ _ _ _ _ _ _ _ _ _
  (arrow_diagram_snd_preserves _ _) (limit_cone _) _ (limit_cone_is_limit _),
  is_limit := @comma.cone_of_preserves_is_limit _ _ _ _ _ _ _ _ _ _ _
    (arrow_diagram_snd_preserves _ _) _ (limit_cone_is_limit _) _ _ }

/-- lifing arrow_cone gives an isomorphism on the left -/
instance arrow_is_iso_lift_left : is_iso ((arrow_limit_cone F surj).is_limit.lift
  (arrow_cone F surj)).left := Profinite.is_iso_as_limit_cone_lift _

/-- lifing arrow_cone gives an isomorphism on the right -/
instance arrow_is_iso_lift_right : is_iso ((arrow_limit_cone F surj).is_limit.lift
  (arrow_cone F surj)).right := is_iso_of_bijective _
begin
  split,
  { intros x y h,
    apply discrete_quotient.eq_of_proj_eq,
    intros S,
    apply_fun subtype.val at h,
    let T : discrete_quotient F.left := S.comap F.hom.continuous,
    let R : discrete_quotient F.right := T.make F.hom surj,
    have hR : R ≤ S,
    { apply discrete_quotient.make_right_le,
      tauto },
    apply_fun (λ e, e T) at h,
    have := discrete_quotient.of_le_proj_apply hR,
    rw [← this, ← this],
    congr' 1 },
  { intros x,
    cases x with x hx,
    dsimp at x hx,
    let Us : Π (I : discrete_quotient F.right), I := λ I,
      of_le (make_right_le _ _ _ _ (by tauto)) (x $ I.comap F.hom.continuous),
    rcases discrete_quotient.exists_of_compat Us _ with ⟨y,hy⟩,
    { refine ⟨y,_⟩,
      ext I : 2,
      dsimp at *,
      let J : discrete_quotient F.right := (I.make F.hom surj),
      let II : discrete_quotient F.left := J.comap F.hom.continuous ⊓ I,
      have h1 : II ≤ I := inf_le_right,
      have h2 : II ≤ J.comap F.hom.continuous := inf_le_left,
      rw ← hx (hom_of_le h1),
      dsimp [comma.cone_of_preserves_is_limit,
        limit_cone_is_limit, CompHaus.limit_cone_is_limit,
        Top.limit_cone_is_limit],
      rw hy,
      dsimp [Us],
      rw ← hx (hom_of_le h2),
      rw ← of_le_comp_apply },
    { intros A B h,
      dsimp [Us],
      have := comap_mono F.hom.continuous h,
      rw ← hx (hom_of_le this),
      rw [← of_le_comp_apply, ← of_le_comp_apply] } },
end

@[simps]
def left_arrow_cone : limits.cone (left_arrow_diagram F surj) :=
functor.map_cone _ (arrow_cone F surj)

@[simps]
def right_arrow_cone : limits.cone (right_arrow_diagram F surj) :=
functor.map_cone _ (arrow_cone F surj)

instance left_arrow_cone_lift_is_iso : is_iso $
  (limit_cone_is_limit $ left_arrow_diagram F surj).lift (left_arrow_cone F surj) :=
Profinite.arrow_is_iso_lift_left _ _

instance right_arrow_cone_lift_is_iso : is_iso $
  (limit_cone_is_limit $ right_arrow_diagram F surj).lift (right_arrow_cone F surj) :=
Profinite.arrow_is_iso_lift_right _ _

@[simps]
def left_arrow_cone_iso : left_arrow_cone F surj ≅
  (limit_cone $ left_arrow_diagram F surj) :=
limits.cones.ext (as_iso $ (limit_cone_is_limit $ left_arrow_diagram F surj).lift _)
  (λ _ , rfl)

@[simps]
def right_arrow_cone_iso : right_arrow_cone F surj ≅
  (limit_cone $ right_arrow_diagram F surj) :=
limits.cones.ext (as_iso $ (limit_cone_is_limit $ right_arrow_diagram F surj).lift _)
  (λ _ , rfl)

/-- The isomorphism of cones showing that arrow_cone is a limit cone. -/
@[simps]
def arrow_cone_iso : arrow_cone F surj ≅ (arrow_limit_cone F surj).cone :=
begin
  haveI := arrow.is_iso_of_iso_left_of_is_iso_right
    ((arrow_limit_cone F surj).is_limit.lift (arrow_cone F surj)),
  exact limits.cones.ext
    (as_iso $ (arrow_limit_cone F surj).is_limit.lift (arrow_cone F surj))
    (λ _, rfl)
end

/-- arrow_cone is a limit cone. -/
@[simps]
def is_limit_arrow_cone : limits.is_limit (arrow_cone F surj) :=
limits.is_limit.of_iso_limit (arrow_limit_cone F surj).is_limit
  (arrow_cone_iso F surj).symm

@[simps]
def is_limit_left_arrow_cone : limits.is_limit (left_arrow_cone F surj) :=
limits.is_limit.of_iso_limit (limit_cone_is_limit $ left_arrow_diagram F surj)
  (left_arrow_cone_iso _ _).symm

@[simps]
def is_limit_right_arrow_cone : limits.is_limit (right_arrow_cone F surj) :=
limits.is_limit.of_iso_limit (limit_cone_is_limit $ right_arrow_diagram F surj)
  (right_arrow_cone_iso _ _).symm

open opposite

open_locale simplicial

@[simps]
def Cech_cone_diagram (n : ℕ) : discrete_quotient F.left ⥤ Profinite.{u} :=
arrow_diagram F surj ⋙ simplicial_object.cech_nerve ⋙
  (evaluation _ _).obj (op [n])

def Cech_cone_diagram_proj (n : ℕ) (S : discrete_quotient F.left) (i : fin (n+1)) :
  (Cech_cone_diagram F surj n).obj S ⟶ Profinite.of S :=
limits.wide_pullback.π _ i

def Cech_cone_diagram_inclusion (n : ℕ) (S : discrete_quotient F.left) :
  (Cech_cone_diagram F surj n).obj S → fin (n+1) → S :=
λ a i, Cech_cone_diagram_proj F surj n S i a

set_option pp.universes true
lemma Cech_cone_diagram_inclusion_injective (n : ℕ) (S : discrete_quotient F.left) :
  function.injective (Cech_cone_diagram_inclusion F surj n S) :=
begin
  intros a b h,
  dsimp [Cech_cone_diagram] at a b,
  haveI : limits.preserves_limits_of_size.{0 0} (forget Profinite.{u}) :=
    limits.preserves_limits_of_size_shrink.{0 u 0 u u u u+1 u+1} (forget.{u+1 u u} Profinite.{u}),
  apply category_theory.limits.concrete.wide_pullback_ext',
  rintros j,
  apply_fun (λ e, e j) at h,
  exact h,
end

instance Cech_cone_diagram_fintype (n : ℕ) (S : discrete_quotient F.left) :
  fintype ((Cech_cone_diagram F surj n).obj S) :=
fintype.of_injective (Cech_cone_diagram_inclusion F surj n S)
  (Cech_cone_diagram_inclusion_injective F surj n S)

@[simps]
def Cech_cone (n : ℕ) : limits.cone (Cech_cone_diagram F surj n) :=
functor.map_cone _ (arrow_cone F surj)

@[simps]
def swap_cone_right (n : ℕ) (S : limits.cone (Cech_cone_diagram F surj n)) :
  limits.cone (right_arrow_diagram F surj) :=
{ X := S.X,
  π := { app := λ T, S.π.app T ≫ limits.wide_pullback.base _,
  naturality' := begin
    intros X Y f,
    dsimp,
    simp [← S.w f],
  end } }

@[simps]
def swap_cone_left (n : ℕ) (i : (fin (n+1)))
  (S : limits.cone (Cech_cone_diagram F surj n)) :
  limits.cone (left_arrow_diagram F surj) :=
{ X := S.X,
  π :=
  { app := λ T, S.π.app T ≫ limits.wide_pullback.π _ i,
    naturality' := begin
      intros X Y f,
      dsimp,
      simp [← S.w f],
    end } }

@[simps]
def Cech_cone_is_limit (n : ℕ) : limits.is_limit (Cech_cone F surj n) :=
{ lift := λ S, limits.wide_pullback.lift
    ((is_limit_right_arrow_cone F surj).lift $ swap_cone_right _ _ _ _)
    (λ i, (is_limit_left_arrow_cone F surj).lift $ swap_cone_left _ _ _ i _)
    begin
      intros i,
      apply (is_limit_right_arrow_cone F surj).hom_ext,
      intros T,
      simp,
      have : (arrow_cone F surj).X.hom ≫ (right_arrow_cone F surj).π.app T =
        (left_arrow_cone F surj).π.app T ≫
        (whisker_left (arrow_diagram F surj) arrow.left_to_right).app T, by refl,
      erw [this, ← category.assoc,
        (is_limit_left_arrow_cone F surj).fac (swap_cone_left F surj n i S) T],
      simp,
    end,
  fac' := begin
    intros S T,
    apply limits.wide_pullback.hom_ext,
    { intro i,
      dsimp,
      simp,
      have := (is_limit_left_arrow_cone F surj).fac,
      erw this,
      refl },
    { dsimp,
      simp,
      erw (is_limit_right_arrow_cone F surj).fac,
      refl }
  end,
  uniq' := begin
    intros S f h,
    apply limits.wide_pullback.hom_ext,
    { dsimp, simp,
      intros i,
      apply (is_limit_left_arrow_cone F surj).hom_ext,
      intros T,
      simp,
      erw [← h T, category.assoc, limits.wide_pullback.lift_π],
      refl },
    { dsimp, simp,
      apply (is_limit_right_arrow_cone F surj).hom_ext,
      intros T,
      simp,
      erw [← h T, category.assoc, limits.wide_pullback.lift_base],
      refl }
  end }.

end Profinite


-- import summary

-- The Undecidability of the Continuum Hypothesis

-- theorem t022 : independent ZFC' CH_f := independence_of_CH


import Hw9
import Sets.Basic
import Lean.Elab.Print
import Lean.Elab.Command

open Set

variable (α β : Type)
variable (X Y Z : Set α)
variable (W : Set β)

theorem desiredType1 : ∅ ∈ 𝒫  X := sorry

theorem desiredType2 (U : β → Set α) : ∀ b, U b ⊆ BigUnion U := sorry

theorem desiredType3 (h : X ⊆ Y) : (X ×ˢ W) ⊆ (Y ×ˢ W) := sorry

theorem desiredType4 (h : Y ∩ Z = ∅) : Yᶜ ∪ Zᶜ = Univ := sorry

theorem desiredType5 : (X \ Y) ∪ (Y \ X) = (X ∪ Y) \ (X ∩ Y) := sorry

open Lean
open Lean.Meta
open Lean.Elab.Command

def n : String := "1"

def problem : String := "problem"++n

def desired : String := "desiredType"++n

def collectAxiomsOf (constName : Name) : MetaM (List String) := do
  let env ← getEnv
  let (_, s) := ((CollectAxioms.collect constName).run env).run {}
  let a := s.axioms.toList.map toString
  return a

#eval isDefEq (Expr.const desired []) (Expr.const problem [])
#eval collectAxiomsOf problem


import morphisms.surjective

/-!
# Radicial morphisms

A morphism of schemes `f : X ⟶ Y` is radicial if the underlying map is injective,
and it induces radicial (purely inseparable) extensions on residue fields.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

open_locale algebraic_geometry

namespace algebraic_geometry

variables {X Y Z : Scheme.{u}} (f : X ⟶ Y) (g : Y ⟶ Z)

/--
A field extension is radicial if it is an epi in the category of fields.

TODO: Replace this with purely inseparable extensions once we have those.
-/
def _root_.ring_hom.is_radicial {K L : Type u} [field K] [field L] (f : K →+* L) : Prop :=
∀ (L' : Type u) [field L'],
  by exactI function.injective (flip ring_hom.comp f : (L →+* L') → (K →+* L'))

/--
A morphism of schemes `f : X ⟶ Y` is radicial if the underlying map is injective,
and it induces radicial (purely inseparable) extensions on residue fields.

We show that this is equivalent to universally injective and equivalent to the diagonal map being
surjective below.
-/
@[mk_iff]
class radicial (f : X ⟶ Y) : Prop :=
(base_injective [] : function.injective f.1.base)
(residue_radicial [] : ∀ x, ring_hom.is_radicial (f.map_residue_field x))

section tfae

lemma radicial.epi_of_field [radicial f] {K : Type*} [field K] :
  function.injective (λ g : Scheme.Spec.obj (op $ CommRing.of K) ⟶ X, g ≫ f) :=
begin
  intros g₁ g₂ e,
  dsimp only at e,
  apply (Spec_to_equiv_of_field K _).injective,
  refine Spec_to_equiv_of_field_eq_iff.mpr ⟨_, _⟩,
  { apply radicial.base_injective f,
    simp only [Spec_to_equiv_of_field_apply_fst, ← Scheme.comp_val_base_apply, e] },
  { simp only [Spec_to_equiv_of_field_apply_snd],
    apply radicial.residue_radicial f,
    convert_to f.map_residue_field _ ≫ _ = f.map_residue_field _ ≫ _,
    rw [← cancel_epi (Y.to_residue_field _)], swap, { apply_instance },
    simp only [Top.presheaf.stalk_congr_hom, stalk_closed_point_to,
      Scheme.to_residue_field_of_eq_assoc, Scheme.to_residue_field_map_residue_field_assoc,
      Scheme.to_desc_residue_field,
      ← PresheafedSpace.stalk_map.stalk_specializes_stalk_map_assoc],
    slice_lhs 1 2 { rw [← PresheafedSpace.stalk_map.comp] },
    erw PresheafedSpace.stalk_map.congr_hom' _ _
      (show g₁.1 ≫ f.1 = g₂.1 ≫ f.1, by injection e),
    slice_rhs 2 3 { erw ← PresheafedSpace.stalk_map.comp },
    simp_rw category.assoc, refl }
end

lemma _root_.field.exists_common_extension {K L M : Type u} [field K] [field L] [field M]
  (f : K →+* L) (g : K →+* M) :
  ∃ (N : Type u) [field N], by exactI ∃ (h : L →+* N) (k : M →+* N), h.comp f = k.comp g :=
begin
  letI := f.to_algebra,
  letI := g.to_algebra,
  obtain ⟨m, hm⟩ := ideal.exists_maximal (tensor_product K L M),
  rw ideal.quotient.maximal_ideal_iff_is_field_quotient at hm,
  refine ⟨tensor_product K L M ⧸ m, hm.to_field,
    m^.quotient.mk^.comp algebra.tensor_product.include_left.to_ring_hom,
    m^.quotient.mk^.comp algebra.tensor_product.include_right.to_ring_hom, _⟩,
  rw [ring_hom.comp_assoc, ring_hom.comp_assoc],
  congr' 1,
  exact algebra.tensor_product.include_right.comp_algebra_map.symm,
end

lemma universally_injective_of_epi_of_field
  (H : ∀ {K : Type u} [field K],
    by exactI function.injective (λ (g : Scheme.Spec.obj (op (CommRing.of K)) ⟶ X), g ≫ f)) :
  morphism_property.universally (λ X Y (f : Scheme.hom X Y), function.injective f.1.base) f :=
begin
  intros X' Y' i₁ i₂ f' h x₁ x₂ e,
  obtain ⟨K, hK, g₁, g₂, e'⟩ := field.exists_common_extension
    (Y'.residue_field_of_eq e ≫ f'.map_residue_field x₁ : _) (f'.map_residue_field x₂),
  resetI,
  change X'.residue_field x₁ ⟶ CommRing.of K at g₁,
  change X'.residue_field x₂ ⟶ CommRing.of K at g₂,
  replace e' : (Y'.residue_field_of_eq e ≫ f'.map_residue_field x₁) ≫ g₁ =
    f'.map_residue_field x₂ ≫ g₂ := by convert e',
  suffices : (Spec_to_equiv_of_field K X').symm ⟨x₁, g₁⟩ =
    (Spec_to_equiv_of_field K X').symm ⟨x₂, g₂⟩,
  { injection (Spec_to_equiv_of_field K X').symm.injective this },
  have : (Spec_to_equiv_of_field K X').symm ⟨x₁, g₁⟩ ≫ f' =
    (Spec_to_equiv_of_field K X').symm ⟨x₂, g₂⟩ ≫ f',
  { dsimp only [Spec_to_equiv_of_field_symm_apply, is_pullback.cone_fst],
    simp_rw [category.assoc, ← Scheme.hom.map_residue_field_from_Spec_residue_field f',
      ← functor.map_comp_assoc, ← op_comp, ← e', op_comp, functor.map_comp_assoc,
      Scheme.residue_field_of_eq_from_Spec] },
  apply pullback_cone.is_limit.hom_ext h.is_limit,
  { exact this },
  { apply H, simp only [category.assoc, is_pullback.cone_snd, ← h.w, reassoc_of this], }
end

lemma _root_.category_theory.is_iso_of_comp_mono {C} [category C] {X Y Z : C}
  (f : X ⟶ Y) (g : Y ⟶ Z) [is_iso (f ≫ g)] [mono g] : is_iso f :=
begin
  haveI : is_split_epi g := ⟨⟨⟨inv (f ≫ g) ≫ f, by simp⟩⟩⟩,
  haveI : is_iso g := is_iso_of_mono_of_is_split_epi g,
  rw (show f = (f ≫ g) ≫ inv g, by simp),
  apply_instance
end

lemma Spec_to_eq_of_injective {K : Type*} [field K] {X : Scheme}
  {f₁ f₂ : Scheme.Spec.obj (op $ CommRing.of K) ⟶ X}
  {g} (hf₁ : f₁ ≫ g = 𝟙 _) (hf₂ : f₂ ≫ g = 𝟙 _) (hg : function.injective g.1.base) : f₁ = f₂ :=
begin
  haveI : subsingleton X.carrier := @@function.injective.subsingleton _ hg
    (show subsingleton (prime_spectrum K), by apply_instance),
  apply (Spec_to_equiv_of_field _ _).injective,
  refine Spec_to_equiv_of_field_eq_iff.mpr ⟨subsingleton.elim _ _, _⟩,
  simp only [Spec_to_equiv_of_field_apply_snd],
  haveI : is_iso (g.map_residue_field (f₁.1.base (local_ring.closed_point K))),
  { refine category_theory.is_iso_of_comp_mono _ _,
    swap, { exact f₁.map_residue_field (local_ring.closed_point K) },
    { rw [← Scheme.hom.map_residue_field_comp],
      let f := f₁ ≫ g, change is_iso (f.map_residue_field _), rw (show f = 𝟙 _, from hf₁),
      apply_instance },
    { rw concrete_category.mono_iff_injective_of_preserves_pullback,
      exact ring_hom.injective _ } },
  rw ← cancel_epi (g.map_residue_field (f₁.1.base (local_ring.closed_point K))),
  rw ← cancel_epi (Scheme.to_residue_field _ _), swap, { apply_instance },
  simp only [Top.presheaf.stalk_congr_hom, stalk_closed_point_to,
    Scheme.to_residue_field_of_eq_assoc, Scheme.to_residue_field_map_residue_field_assoc,
    Scheme.to_desc_residue_field, ← PresheafedSpace.stalk_map.stalk_specializes_stalk_map_assoc],
  slice_lhs 1 2 { erw [← PresheafedSpace.stalk_map.comp] },
  slice_rhs 2 3 { erw [← PresheafedSpace.stalk_map.comp] },
  erw PresheafedSpace.stalk_map.congr_hom' _ _
    (show f₁.1 ≫ g.1 = f₂.1 ≫ g.1, by injection hf₁.trans hf₂.symm),
  simp only [category.assoc],
  refl,
end

def morphism_property.injective : morphism_property Scheme :=
λ X Y f, function.injective f.1.base

lemma radicial_tfae :
  tfae [radicial f,
    ∀ {K : Type*} [field K], by exactI function.injective
      (λ g : Scheme.Spec.obj (op $ CommRing.of K) ⟶ X, g ≫ f),
    morphism_property.universally morphism_property.injective f,
    surjective (pullback.diagonal f)] :=
begin
  tfae_have : 1 → 2,
  { introsI _ K _, exact radicial.epi_of_field f },
  tfae_have : 2 → 3,
  { exact universally_injective_of_epi_of_field f },
  tfae_have : 3 → 2,
  { introsI H K hK g₁ g₂ e,
    let f' := g₁ ≫ f,
    rw [← pullback.lift_snd (𝟙 _) g₁ (category.id_comp f'),
      ← pullback.lift_snd (𝟙 _) g₂ ((category.id_comp f').trans e)],
    congr' 1,
    apply Spec_to_eq_of_injective (pullback.lift_fst _ _ _) (pullback.lift_fst _ _ _)
      (H _ _ _ (is_pullback.of_has_pullback f' f)) },
  tfae_have : 3 → 1,
  { intro H,
    refine ⟨(morphism_property.universally_le _ _ _ f H : _), _⟩,
    introsI x K _ f₁ f₂ e,
    change X.residue_field x ⟶ CommRing.of K at f₁,
    change X.residue_field x ⟶ CommRing.of K at f₂,
    replace e : f.map_residue_field x ≫ f₁ = f.map_residue_field x ≫ f₂ := by convert e,
    suffices : (Spec_to_equiv_of_field K X).symm ⟨x, f₁⟩ =
      (Spec_to_equiv_of_field K X).symm ⟨x, f₂⟩,
    { injection (Spec_to_equiv_of_field K X).symm.injective this, exact eq_of_heq ‹_› },
    apply tfae_3_to_2 H,
    dsimp only [Spec_to_equiv_of_field_symm_apply],
    simp only [category.assoc, ← Scheme.hom.map_residue_field_from_Spec_residue_field,
      ← functor.map_comp_assoc, ← op_comp, e] },
  tfae_have : 3 → 4,
  { rw surjective_iff,
    intros H x,
    refine ⟨(pullback.fst : pullback f f ⟶ _).1.base x,
      H _ _ _ (is_pullback.of_has_pullback f f) _⟩,
    simp only [← Scheme.comp_val_base_apply, category.assoc,
      pullback.diagonal_fst, category.comp_id] },
  tfae_have : 4 → 3,
  { suffices : morphism_property.diagonal @surjective ≤ morphism_property.injective.universally,
    { apply this },
    rw ← (surjective_stable_under_base_change.diagonal surjective_respects_iso).universally_eq,
    refine morphism_property.universally_mono _,
    intros X Y f h x y e,
    let T : pullback.triplet f f := ⟨x, y, _, e, rfl⟩,
    obtain ⟨z, hz, hz'⟩ := T.exists_preimage,
    obtain ⟨z', rfl⟩ := h.1 z,
    simp only [← Scheme.comp_val_base_apply,
      pullback.diagonal_fst, pullback.diagonal_snd] at hz hz',
    exact hz.symm.trans hz' },
  tfae_finish
end

lemma radicial_eq_univerally_injective :
  @radicial = morphism_property.universally morphism_property.injective :=
by { ext X Y f, exact (radicial_tfae f).out 0 2 }

lemma radicial_eq_diagonal_surjective :
  @radicial = morphism_property.diagonal @surjective :=
by { ext X Y f, exact (radicial_tfae f).out 0 3 }

end tfae

lemma radicial_respects_iso :
  morphism_property.respects_iso @radicial :=
radicial_eq_univerally_injective.symm ▸
  morphism_property.injective.universally_respects_iso

lemma radicial_stable_under_composition :
  morphism_property.stable_under_composition @radicial :=
radicial_eq_diagonal_surjective.symm ▸
  surjective_stable_under_composition.diagonal
    surjective_respects_iso
    surjective_stable_under_base_change

lemma radicial_stable_under_base_change :
  morphism_property.stable_under_base_change @radicial :=
radicial_eq_univerally_injective.symm ▸
  morphism_property.universally_stable_under_base_change _

lemma radicial_is_local_at_target :
  property_is_local_at_target @radicial :=
radicial_eq_diagonal_surjective.symm ▸
  surjective_is_local_at_target.diagonal

instance radicial_of_mono [mono f] : radicial f :=
by { rw radicial_eq_diagonal_surjective, show surjective _, apply_instance }

end algebraic_geometry


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

import category_theory.category
import category_theory.abelian.basic
import abelian_SEMF

open category_theory
open category_theory.limits

universes v u

namespace category_theory.abelian

section
variables {C : Type u} [𝒞 : category.{v} C] [abelian.{v} C]
include 𝒞

def exact {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) : Prop :=
f ≫ g = 0 ∧ kernel.ι g ≫ cokernel.π f = 0

def exact_fork {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (e : exact f g) : kernel_fork g :=
kernel_fork.of_ι (kernel.ι (cokernel.π f)) $
  zero_of_epi_comp (abelian.factor_thru_image f) $ by rw [←category.assoc, image.fac f, e.1]

def exact_ker {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (e : exact f g) : is_limit $ exact_fork f g e :=
fork.is_limit.mk _
  (λ s, kernel.lift _ (fork.ι s)
  begin
    let t : s.X ⟶ kernel g := kernel.lift g (fork.ι s) (kernel_fork.condition _),
    have : t ≫ kernel.ι g = fork.ι s := by erw limit.lift_π; refl,
    rw [←this, category.assoc, e.2, has_zero_morphisms.comp_zero]
  end)
  (λ s, by erw limit.lift_π; refl)
  (λ s m h, by ext; erw [h walking_parallel_pair.zero, limit.lift_π]; refl)

def exact_cofork {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (e : exact f g) : cokernel_cofork f :=
cokernel_cofork.of_π (cokernel.π (kernel.ι g)) $
  zero_of_comp_mono (abelian.factor_thru_coimage g) $ by rw [category.assoc, coimage.fac g, e.1]

def exact_coker {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (e : exact f g) :
  is_colimit $ exact_cofork f g e :=
cofork.is_colimit.mk _
  (λ s, cokernel.desc _ (cofork.π s)
  begin
    let t : cokernel f ⟶ s.X := cokernel.desc f (cofork.π s) (cokernel_cofork.condition _),
    have : cokernel.π f ≫ t = cofork.π s := by erw colimit.ι_desc; refl,
    rw [←this, ←category.assoc, e.2, has_zero_morphisms.zero_comp]
  end)
  (λ s, by erw colimit.ι_desc; refl)
  (λ s m h, by ext; erw [h walking_parallel_pair.one, colimit.ι_desc]; refl)

lemma exact_zero_of_mono (P : C) {Q R : C} (f : Q ⟶ R) [mono f] : exact (0 : P ⟶ Q) f :=
⟨has_zero_morphisms.zero_comp _ _,
begin
  rw (preadditive.cancel_zero_iff_mono f).1 (by apply_instance) _ (kernel.ι f) (kernel.condition _),
  exact has_zero_morphisms.zero_comp _ _
end⟩

lemma mono_of_exact_zero (P : C) {Q R : C} (f : Q ⟶ R) (h : exact (0 : P ⟶ Q) f) : mono f :=
(preadditive.cancel_zero_iff_mono f).2 $ λ Z g h₀,
begin
  obtain ⟨k, hk⟩ := kernel_fork.is_limit.lift' (exact_ker _ _ h) g h₀,
  have := (preadditive.cancel_zero_iff_epi (factor_thru_image (0 : P ⟶ Q))).1
    (by apply_instance) _ _ (image.fac (0 : P ⟶ Q)),
  change k ≫ kernel.ι (cokernel.π (0 : P ⟶ Q)) = g at hk,
  rw ←hk,
  conv_lhs { congr, skip, rw this },
  exact has_zero_morphisms.comp_zero _ _
end

lemma exact_zero_of_epi {P Q : C} (f : P ⟶ Q) (R : C) [epi f] : exact f (0 : Q ⟶ R) :=
⟨has_zero_morphisms.comp_zero _ _,
begin
  rw (preadditive.cancel_zero_iff_epi f).1 (by apply_instance) _ (cokernel.π f) (cokernel.condition _),
  exact has_zero_morphisms.comp_zero _ _
end⟩

lemma exact_zero_of_epi' {P Q : C} (f : P ⟶ Q) [epi f] : exact f (0 : Q ⟶ Q) :=
exact_zero_of_epi _ _

lemma epi_of_exact_zero {P Q : C} (f : P ⟶ Q) (R : C) (h : exact f (0 : Q ⟶ R)) : epi f :=
(preadditive.cancel_zero_iff_epi f).2 $ λ Z g h₀,
begin
  obtain ⟨k, hk⟩ := cokernel.desc' f g h₀,
  haveI : is_iso (kernel.ι (0 : Q ⟶ R)) := kernel.ι_of_zero _ _,
  apply (preadditive.cancel_zero_iff_epi (kernel.ι (0 : Q ⟶ R))).1 (by apply_instance) _ _,
  rw [←hk, ←category.assoc, h.2],
  exact has_zero_morphisms.zero_comp _ _
end

lemma kernel_exact {P Q : C} (f : P ⟶ Q) : exact (kernel.ι f) f :=
⟨kernel.condition _, cokernel.condition _⟩

lemma cokernel_exact {P Q : C} (f : P ⟶ Q) : exact f (cokernel.π f) :=
⟨cokernel.condition _, kernel.condition _⟩

def kernel_of_mono_exact {P Q R : C} (f : P ⟶ Q) [mono f] (g : Q ⟶ R) (h : exact f g) :
  is_limit $ kernel_fork.of_ι f h.1 :=
begin
  let I := kernel (cokernel.π f),
  let i : kernel g ≅ I := functor.map_iso (cones.forget _)
    (is_limit.unique_up_to_iso (limit.is_limit _) (exact_ker f g h)),
  have h₀ : i.hom ≫ kernel.ι (cokernel.π f) = kernel.ι g :=
    cone_morphism.w (is_limit.unique_up_to_iso (limit.is_limit _) (exact_ker f g h)).hom
      walking_parallel_pair.zero,
  haveI : mono (factor_thru_image f) := mono_of_mono_fac (image.fac f),
  haveI : is_iso (factor_thru_image f) := mono_epi_iso _,
  let j : P ≅ I := as_iso (factor_thru_image f),
  apply kernel.transport _ _ (j ≪≫ i.symm),
  erw [category.assoc, ←(iso.eq_inv_comp i).2 h₀, image.fac],
end

def cokernel_of_epi_exact {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) [epi g] (h : exact f g) :
  is_colimit $ cokernel_cofork.of_π g h.1 :=
begin
  let I := cokernel (kernel.ι g),
  let i : cokernel f ≅ I := functor.map_iso (cocones.forget _)
    (is_colimit.unique_up_to_iso (colimit.is_colimit _) (exact_coker f g h)),
  have h₀ : cokernel.π f ≫ i.hom = cokernel.π (kernel.ι g) :=
    cocone_morphism.w (is_colimit.unique_up_to_iso (colimit.is_colimit _) (exact_coker f g h)).hom
      walking_parallel_pair.one,
  haveI : epi (factor_thru_coimage g) := epi_of_epi_fac (coimage.fac g),
  haveI : is_iso (factor_thru_coimage g) := mono_epi_iso _,
  let j : I ≅ R := as_iso (factor_thru_coimage g),
  apply cokernel.transport _ _ (i ≪≫ j),
  erw [←category.assoc, h₀, coimage.fac],
end

lemma image_exact {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (h : exact f g) :
  exact (kernel.ι (cokernel.π f)) g :=
⟨begin
  apply (preadditive.cancel_zero_iff_epi (factor_thru_image f)).1 (by apply_instance),
  rw ←category.assoc,
  rw image.fac f,
  exact h.1,
end,
begin
  obtain ⟨l, hl⟩ := cokernel.desc' f (cokernel.π (kernel.ι (cokernel.π f)))
    begin conv_lhs { congr, rw ←image.fac f, }, rw category.assoc, rw cokernel.condition,
      rw has_zero_morphisms.comp_zero, end,
  rw ←hl,
  rw ←category.assoc,
  rw h.2,
  rw has_zero_morphisms.zero_comp,
end⟩

lemma exact_image {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (h : exact f g) :
  exact f (factor_thru_image g) :=
⟨begin
  apply (preadditive.cancel_zero_iff_mono (kernel.ι (cokernel.π g))).1 (by apply_instance),
  rw category.assoc,
  rw image.fac g,
  exact h.1,
end,
begin
  obtain ⟨l, hl⟩ := kernel.lift' g (kernel.ι (factor_thru_image g))
    begin conv_lhs { congr, skip, rw ←image.fac g, }, rw ←category.assoc, rw kernel.condition,
      rw has_zero_morphisms.zero_comp, end,
  rw ←hl,
  rw category.assoc,
  rw h.2,
  rw has_zero_morphisms.comp_zero,
end⟩

lemma exact_iso {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) {Q' : C} (i : Q ≅ Q') (h : exact f g) :
  exact (f ≫ i.hom) (i.inv ≫ g) :=
⟨by simpa using h.1,
begin
  obtain ⟨l, hl⟩ := kernel.lift' g (kernel.ι (i.inv ≫ g) ≫ i.inv)
    (by rw [category.assoc, kernel.condition]),
  obtain ⟨m, hm⟩ := cokernel.desc' f (i.hom ≫ cokernel.π (f ≫ i.hom))
    (by rw [←category.assoc, cokernel.condition]),
  calc kernel.ι (i.inv ≫ g) ≫ cokernel.π (f ≫ i.hom)
        = kernel.ι (i.inv ≫ g) ≫ (i.inv ≫ i.hom) ≫ cokernel.π (f ≫ i.hom) : by rw [iso.inv_hom_id, category.id_comp]
    ... = (kernel.ι (i.inv ≫ g) ≫ i.inv) ≫ i.hom ≫ cokernel.π (f ≫ i.hom) : by simp only [category.assoc]
    ... = (l ≫ kernel.ι g) ≫ cokernel.π f ≫ m : by rw [←hl, ←hm]
    ... = l ≫ (kernel.ι g ≫ cokernel.π f) ≫ m : by simp only [category.assoc]
    ... = l ≫ 0 ≫ m : by rw h.2
    ... = 0 : by rw [has_zero_morphisms.zero_comp, has_zero_morphisms.comp_zero]
end⟩

lemma exact_iso_right {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) {R' : C} (i : R ≅ R') (h : exact f g) :
  exact f (g ≫ i.hom) :=
⟨by rw [←category.assoc, h.1, has_zero_morphisms.zero_comp],
begin
  obtain ⟨l, hl⟩ := kernel.lift' g (kernel.ι (g ≫ i.hom))
    (calc kernel.ι (g ≫ i.hom) ≫ g
          = kernel.ι (g ≫ i.hom) ≫ g ≫ i.hom ≫ i.inv : by simp
      ... = (kernel.ι (g ≫ i.hom) ≫ g ≫ i.hom) ≫ i.inv : by simp only [category.assoc]
      ... = 0 ≫ i.inv : by rw kernel.condition
      ... = 0 : by rw has_zero_morphisms.zero_comp),

  rw [←hl, category.assoc, h.2, has_zero_morphisms.comp_zero],
end⟩

lemma exact_iso_left {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) {P' : C} (i : P' ≅ P) (h : exact f g) :
  exact (i.hom ≫ f) g :=
⟨by rw [category.assoc, h.1, has_zero_morphisms.comp_zero],
begin
  obtain ⟨l, hl⟩ := cokernel.desc' f (cokernel.π (i.hom ≫ f))
    (calc f ≫ cokernel.π (i.hom ≫ f)
          = (i.inv ≫ i.hom) ≫ f ≫ cokernel.π (i.hom ≫ f) : by simp
      ... = i.inv ≫ (i.hom ≫ f) ≫ cokernel.π (i.hom ≫ f) : by simp only [category.assoc]
      ... = i.inv ≫ 0 : by rw cokernel.condition
      ... = 0 : by rw has_zero_morphisms.comp_zero),

  rw [←hl, ←category.assoc, h.2, has_zero_morphisms.zero_comp],
end⟩

lemma epi_mono_exact_left {P Q R S : C} (f : P ⟶ Q) (g : Q ⟶ R) (h : R ⟶ S)
  (e : exact (f ≫ g) h) [epi f] [mono g] : exact g h :=
begin
  let upper : strong_epi_mono_factorisation (f ≫ g) :=
  { I := _, e := f, m := g, fac' := rfl,
    m_mono := by apply_instance, e_strong_epi := strong_epi_of_epi _ },
  let lower := image_SEMF (f ≫ g),
  let s : Q ≅ kernel (cokernel.π (f ≫ g)) := is_image.iso_ext upper.to_mono_is_image
    lower.to_mono_is_image,
  have : s.hom ≫ kernel.ι (cokernel.π (f ≫ g)) = g,
  { erw is_image.lift_fac },
  rw ←this,
  apply exact_iso_left _ _ s,
  exact image_exact _ _ e,
end

lemma epi_mono_exact_right {P Q R S : C} (f : P ⟶ Q) (g : Q ⟶ R) (h : R ⟶ S)
  (e : exact f (g ≫ h)) [epi g] [mono h] : exact f g :=
begin
  let upper : strong_epi_mono_factorisation (g ≫ h) :=
  { I := _, e := g, m := h, fac' := rfl,
  m_mono := by apply_instance, e_strong_epi := strong_epi_of_epi _ },
  let lower := image_SEMF (g ≫ h),
  let s : kernel (cokernel.π (g ≫ h)) ≅ R := is_image.iso_ext lower.to_mono_is_image
    upper.to_mono_is_image,
  have : factor_thru_image (g ≫ h) ≫ s.hom = g,
  { erw is_image.fac_lift lower.to_mono_is_image upper.to_mono_factorisation },
  rw ←this,
  apply exact_iso_right _ _ s,
  exact exact_image _ _ e,
end

lemma exact_left_epi {P Q R S : C} (f : P ⟶ Q) (g : Q ⟶ R) (h : R ⟶ S) (e : exact g h) [epi f] :
  exact (f ≫ g) h :=
⟨by rw [category.assoc, e.1, has_zero_morphisms.comp_zero],
begin
  obtain ⟨l, hl⟩ := cokernel.desc' g (cokernel.π (f ≫ g))
    begin
      apply (preadditive.cancel_zero_iff_epi f).1 (by apply_instance),
      rw [←category.assoc, cokernel.condition],
    end,
  rw [←hl, ←category.assoc, e.2, has_zero_morphisms.zero_comp],
end⟩

end

end category_theory.abelian


import QL.FOL.Tait.calculus logic

universes u v

namespace fol
open_locale logic_symbol aclogic
variables {L : language.{u}} {μ : Type v} {μ₁ : Type*} {μ₂ : Type*} {m n : ℕ} {S : Structure L}

namespace Tait
namespace subformula

variables (S) {n} {Φ : μ → S} {e : fin n → S}

@[simp] def subval' (Φ : μ → S) : ∀ {n} (e : fin n → S), subformula L μ n → Prop
| n _ verum              := true
| n _ falsum             := false
| n e (relation p v)     := S.pr p (λ i, subterm.val S Φ e (v i))
| n e (neg_relation p v) := ¬S.pr p (λ i, subterm.val S Φ e (v i))
| n e (and p q)          := p.subval' e ∧ q.subval' e
| n e (or p q)           := p.subval' e ∨ q.subval' e
| n e (fal p)            := ∀ x : S, (p.subval' (x *> e))
| n e (ex p)             := ∃ x : S, (p.subval' (x *> e))

@[simp] lemma subval'_neg (p : subformula L μ n) : subval' S Φ e (∼p) = ¬subval' S Φ e p :=
by induction p generalizing Φ e; simp[mlift, ←verum_eq, ←falsum_eq, ←and_eq, ←or_eq, ←not_eq, ←fal_eq, ←ex_eq, or_iff_not_imp_left, *] at*

@[irreducible] def subval (Φ : μ → S) (e : fin n → S) : subformula L μ n →ₗ Prop :=
{ to_fun := subval' S Φ e,
  map_neg' := λ _, by simp,
  map_imply' := λ _ _, by simp[has_arrow.arrow, imply, or_iff_not_imp_left, not_eq],
  map_and' := λ p q, by unfold has_inf.inf; simp; refl,
  map_or' := λ p q, by unfold has_sup.sup; simp; refl,
  map_top' := by refl,
  map_bot' := by refl }

@[reducible] def val (Φ : μ → S) : formula L μ →ₗ Prop := subformula.subval S Φ fin.nil

@[simp] lemma subval_relation {p} {r : L.pr p} {v} :
  subval S Φ e (relation r v) ↔ S.pr r (subterm.val S Φ e ∘ v) :=  by simp[subval]; refl

@[simp] lemma subval_neg_relation {p} {r : L.pr p} {v} :
  subval S Φ e (neg_relation r v) ↔ ¬S.pr r (subterm.val S Φ e ∘ v) := by simp[subval]; refl

@[simp] lemma subval_fal {p : subformula L μ (n + 1)} :
  subval S Φ e (∀'p) ↔ ∀ x : S, subval S Φ (x *> e) p := by simp[subval]; refl

@[simp] lemma subval_ex {p : subformula L μ (n + 1)} :
  subval S Φ e (∃'p) ↔ ∃ x : S, subval S Φ (x *> e) p := by simp[subval]; refl

variables {μ₁ μ₂}

lemma subval_map {f : μ₁ → μ₂} {Φ : μ₂ → S} {p : subformula L μ₁ n} :
  subval S Φ e (map f p) ↔ subval S (Φ ∘ f) e p :=
by induction p using fol.Tait.subformula.ind_on; simp[*, (∘), subterm.val_map]

lemma subval_subst {p : subformula L μ (n + 1)} : ∀ {e} {u : subterm L μ n},
  subval S Φ e (subst u p) ↔ subval S Φ (e <* subterm.val S Φ e u) p :=
by apply ind_succ_on p; intros; simp[*, (∘), subterm.val_subst, subterm.val_lift, fin.left_right_concat_assoc]

end subformula

namespace subformula
variables (S) {Φ : μ → S}

notation S` ⊧ᵀ[`:80 e`] `p :50 := val S e p

variables {S} {p q : formula L μ}

@[simp] lemma models_relation {k} {r : L.pr k} {v} :
  S ⊧ᵀ[Φ] relation r v ↔ S.pr r (λ i, subterm.val S Φ fin.nil (v i)) := by simp[val]

end subformula

def models (S : Structure L) (p : formula L μ) : Prop := ∀ e, S ⊧ᵀ[e] p

instance : logic.semantics (formula L μ) (Structure L) := ⟨models⟩

lemma models_def {S : Structure L} {p : formula L μ} : S ⊧ p ↔ (∀ e, S ⊧ᵀ[e] p) := by refl

lemma sentence_models_def {S : Structure L} {σ : sentence L} : S ⊧ σ ↔ S ⊧ᵀ[fin.nil] σ := by simp[models_def, fin.nil]

--@[simp] lemma models_neg {σ : sentence L} :
--  S ⊧ ∼σ ↔ ¬S ⊧ σ := by simp[sentence_models_def]

@[simp] lemma models_coe {S : Structure L} {σ : sentence L} {e : μ → S} : S ⊧ᵀ[e] ↑σ ↔ S ⊧ σ :=
by { rw [subformula.sentence_coe_def],
     simp[sentence_models_def, -subformula.map_sentence_coe, subformula.val, subformula.subval_map,
       show e ∘ fin.nil = fin.nil, by ext x; exact fin.nil x] }

instance : has_double_turnstile (Tait.preTheory L μ) (formula L μ) := ⟨logic.semantics.consequence (Structure L)⟩

lemma consequence_def {T : preTheory L μ} {p : formula L μ} :
  T ⊧ p ↔ (∀ S : Structure L, S ⊧ T → S ⊧ p) := by refl

namespace subformula
variables (S) {Φ : μ → S} {e : fin n → S}

@[simp] lemma subval_to_tait {p : fol.subformula L μ n} : subval S Φ e p.to_tait ↔ fol.subformula.subval S Φ e p :=
by induction p using fol.subformula.ind_on; simp*

@[simp] lemma subval_of_tait {p : Tait.subformula L μ n} : fol.subformula.subval S Φ e p.of_tait ↔ subval S Φ e p :=
by induction p using fol.Tait.subformula.ind_on; simp*

end subformula

@[simp] lemma models_to_tait {p : fol.formula L μ} : S ⊧ p.to_tait ↔ S ⊧ p :=
by simp[models_def, fol.Structure.models_def]

@[simp] lemma models_of_tait {p : Tait.formula L μ} : S ⊧ p.of_tait ↔ S ⊧ p :=
by simp[models_def, fol.Structure.models_def]

end Tait

end fol


import data.fintype data.equiv.basic group_theory.subgroup

namespace list

@[simp] lemma length_attach {α} (L : list α) :
  L.attach.length = L.length :=
length_pmap

@[simp] lemma nth_le_attach {α} (L : list α) (i) (H : i < L.attach.length) :
  (L.attach.nth_le i H).1 = L.nth_le i (length_attach L ▸ H) :=
calc  (L.attach.nth_le i H).1
    = (L.attach.map subtype.val).nth_le i (by simpa using H) : by rw nth_le_map'
... = L.nth_le i _ : by congr; apply attach_map_val

@[simp] lemma nth_le_range {n} (i) (H : i < (range n).length) :
  nth_le (range n) i H = i :=
option.some.inj $ by rw [← nth_le_nth _, nth_range (by simpa using H)]

attribute [simp] length_of_fn
attribute [simp] nth_le_of_fn

-- Congratulations, I proved that two things which have
-- equally few lemmas are equal.
theorem of_fn_eq_pmap {α n} {f : fin n → α} :
  of_fn f = pmap (λ i hi, f ⟨i, hi⟩) (range n) (λ _, mem_range.1) :=
by rw [pmap_eq_map_attach]; from ext_le (by simp)
  (λ i hi1 hi2, by simp at hi1; simp [nth_le_of_fn f ⟨i, hi1⟩])

theorem nodup_of_fn {α n} {f : fin n → α} (hf : function.injective f) :
  nodup (of_fn f) :=
by rw of_fn_eq_pmap; from nodup_pmap
  (λ _ _ _ _ H, fin.veq_of_eq $ hf H) (nodup_range n)

end list

section fin

variables {m n : ℕ}

def fin_zero_elim {C : Sort*} : fin 0 → C :=
λ x, false.elim $ nat.not_lt_zero x.1 x.2

def fin_sum : (fin m ⊕ fin n) ≃ fin (m + n) :=
{ to_fun := λ x, sum.rec_on x
    (λ y, ⟨y.1, nat.lt_of_lt_of_le y.2 $ nat.le_add_right m n⟩)
    (λ y, ⟨m + y.1, nat.add_lt_add_left y.2 m⟩),
  inv_fun := λ x, if H : x.1 < m
    then sum.inl ⟨x.1, H⟩
    else sum.inr ⟨x.1 - m, nat.lt_of_add_lt_add_left $
      show m + (x.1 - m) < m + n,
      from (nat.add_sub_of_le $ le_of_not_gt H).symm ▸ x.2⟩,
  left_inv := λ x, sum.cases_on x
    (λ y, by simp [y.2]; from fin.eq_of_veq rfl)
    (λ y, have H : ¬m + y.val < m, by simp [nat.zero_le],
       by simp [H, nat.add_sub_cancel_left];
       from fin.eq_of_veq rfl),
  right_inv := λ x, begin
    by_cases H : x.1 < m,
    { dsimp; rw [dif_pos H]; simp,
      exact fin.eq_of_veq rfl },
    { dsimp; rw [dif_neg H]; simp,
      apply fin.eq_of_veq; simp,
      rw [nat.add_sub_of_le (le_of_not_gt H)] }
  end }

def fin_prod : (fin m × fin n) ≃ fin (m * n) :=
{ to_fun := λ x, ⟨x.2.1 + n * x.1.1, calc
          x.2.1 + n * x.1.1 + 1
        = x.1.1 * n + x.2.1 + 1 : by ac_refl
    ... ≤ x.1.1 * n + n : nat.add_le_add_left x.2.2 _
    ... = (x.1.1 + 1) * n : eq.symm $ nat.succ_mul _ _
    ... ≤ m * n : nat.mul_le_mul_right _ x.1.2⟩,
  inv_fun := λ x, have H : n > 0,
      from nat.pos_of_ne_zero $ λ H,
        nat.not_lt_zero x.1 $ by subst H; from x.2,
    (⟨x.1 / n, (nat.div_lt_iff_lt_mul _ _ H).2 x.2⟩,
     ⟨x.1 % n, nat.mod_lt _ H⟩),
  left_inv := λ ⟨x, y⟩, have H : n > 0,
      from nat.pos_of_ne_zero $ λ H,
        nat.not_lt_zero y.1 $ H ▸ y.2,
    prod.ext
    (fin.eq_of_veq $ calc
            (y.1 + n * x.1) / n
          = y.1 / n + x.1 : nat.add_mul_div_left _ _ H
      ... = 0 + x.1 : by rw nat.div_eq_of_lt y.2
      ... = x.1 : nat.zero_add x.1)
    (fin.eq_of_veq $ calc
            (y.1 + n * x.1) % n
          = y.1 % n : nat.add_mul_mod_self_left _ _ _
      ... = y.1 : nat.mod_eq_of_lt y.2),
    right_inv := λ x, fin.eq_of_veq $ nat.mod_add_div _ _ }

@[simp] lemma fin.raise_val (k : fin n) :
  k.raise.val = k.val :=
rfl

def fin.fall : Π i : fin (n+1), i.1 < n → fin n :=
λ i h, ⟨i.1, h⟩

@[simp] lemma fin.fall_val (k : fin (n+1)) (H : k.1 < n) :
  (k.fall H).val = k.val :=
rfl

def fin.descend (pivot : fin (n+1)) : Π i : fin (n+1), i ≠ pivot → fin n :=
λ i H, if h : i.1 < pivot.1
  then i.fall (lt_of_lt_of_le h $ nat.le_of_lt_succ pivot.2)
  else i.pred (λ H1, H $ by subst H1;
    replace h := nat.eq_zero_of_le_zero (le_of_not_gt h);
    from fin.eq_of_veq h.symm)

def fin.ascend (pivot : fin (n+1)) : Π i : fin n, fin (n+1) :=
λ i, if i.1 < pivot.1 then i.raise else i.succ

theorem fin.ascend_ne (pivot : fin (n+1)) (i : fin n) :
  pivot.ascend i ≠ pivot :=
λ H, begin
  unfold fin.ascend at H,
  split_ifs at H;
  rw ← H at h;
  simp [lt_irrefl, nat.lt_succ_self] at h;
  cc
end

@[simp] lemma fin.ascend_descend (pivot i : fin (n+1))
  (H : i ≠ pivot) : pivot.ascend (pivot.descend i H) = i :=
begin
  unfold fin.descend fin.ascend,
  split_ifs with H1 H2 H3; apply fin.eq_of_veq; simp at *,
  { cases pivot with p hp,
    cases i with i hi,
    cases i with i, { simp at * },
    exfalso, apply H, apply fin.eq_of_veq,
    apply le_antisymm, { apply nat.succ_le_of_lt H2 },
    simpa using H1 },
  { cases pivot with p hp,
    cases i with i hi,
    cases i with i,
    { exfalso, apply H, apply fin.eq_of_veq, symmetry,
      apply nat.eq_zero_of_le_zero H2 },
    refl }
end

@[simp] lemma fin.descend_ascend (pivot : fin (n+1))
  (i : fin n) (H : pivot.ascend i ≠ pivot) :
  pivot.descend (pivot.ascend i) H = i :=
begin
  unfold fin.descend fin.ascend,
  apply fin.eq_of_veq,
  by_cases h : i.val < pivot.val,
  { simp [h] },
  { unfold ite dite,
    cases nat.decidable_lt ((ite (i.val < pivot.val) (fin.raise i) (fin.succ i)).val) (pivot.val) with h1 h1,
    { simp,
      cases nat.decidable_lt (i.val) (pivot.val),
      { simp },
      { cc } },
    { simp,
      cases nat.decidable_lt (i.val) (pivot.val) with h2 h2,
      { simp [h2] at h1,
        simp at *,
        exfalso, apply lt_asymm (nat.lt_succ_self i.1),
        apply lt_of_lt_of_le h1 h },
      { simp } } }
end

@[simp] lemma fin.succ_pred (i : fin (n+1)) (H : i ≠ 0) :
  (i.pred H).succ = i :=
begin
  apply fin.eq_of_veq,
  cases i with i hi,
  cases i,
  { exfalso, apply H, apply fin.eq_of_veq, refl },
  refl
end

@[simp] lemma fin.pred_succ (i : fin n) (H : i.succ ≠ 0) :
  i.succ.pred H = i :=
by cases i; refl

instance : decidable_linear_order (fin n) :=
{ lt_iff_le_not_le := λ i j, nat.lt_iff_le_not_le,
  le_refl := λ ⟨i, hi⟩, nat.le_refl i,
  le_trans := λ ⟨i, hi⟩ ⟨j, hj⟩ ⟨k, hk⟩ hij hjk, nat.le_trans hij hjk,
  le_antisymm := λ ⟨i, hi⟩ ⟨j, hj⟩ hij hji, fin.eq_of_veq $ nat.le_antisymm hij hji,
  le_total := λ ⟨i, hi⟩ ⟨j, hj⟩, or.cases_on (@nat.le_total i j) or.inl or.inr,
  decidable_le := fin.decidable_le,
  .. fin.has_le, .. fin.has_lt }

instance : preorder (fin n) :=
by apply_instance

end fin

section miscellaneous

theorem nat.pred_eq_of_eq_succ {m n : ℕ}
  (H : m = n.succ) : m.pred = n :=
by simp [H]

@[simp] lemma equiv.symm_apply_eq {α β} {e : α ≃ β} {x y} :
  e.symm x = y ↔ x = e y :=
⟨λ H, by simp [H.symm], λ H, by simp [H]⟩

theorem finset.lt_wf {α} [decidable_eq α] :
  well_founded (@has_lt.lt (finset α) _) :=
have H : subrelation (@has_lt.lt (finset α) _)
    (inv_image (<) finset.card),
  from λ x y hxy, finset.card_lt_card hxy,
subrelation.wf H $ inv_image.wf _ $ nat.lt_wf

def finset.min' {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅) : α :=
@option.get _ S.min $
  let ⟨k, hk⟩ := finset.exists_mem_of_ne_empty H in
  let ⟨b, hb⟩ := finset.min_of_mem hk in by simp at hb; simp [hb]

theorem finset.min'_mem {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅) : S.min' H ∈ S :=
finset.mem_of_min $ by simp [finset.min']

theorem finset.min'_le {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅)
  (x) (H2 : x ∈ S) : S.min' H ≤ x :=
finset.le_min_of_mem H2 $ option.get_mem _

theorem finset.le_min' {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅)
  (x) (H2 : ∀ y ∈ S, x ≤ y) : x ≤ S.min' H :=
H2 _ $ finset.min'_mem _ _

def finset.max' {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅) : α :=
@option.get _ S.max $
  let ⟨k, hk⟩ := finset.exists_mem_of_ne_empty H in
  let ⟨b, hb⟩ := finset.max_of_mem hk in by simp at hb; simp [hb]

theorem finset.max'_mem {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅) : S.max' H ∈ S :=
finset.mem_of_max $ by simp [finset.max']

theorem finset.le_max' {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅)
  (x) (H2 : x ∈ S) : x ≤ S.max' H :=
finset.le_max_of_mem H2 $ option.get_mem _

theorem finset.max'_le {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅)
  (x) (H2 : ∀ y ∈ S, y ≤ x) : S.max' H ≤ x :=
H2 _ $ finset.max'_mem _ _

theorem finset.min'_lt_max' {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅) {i j}
  (H1 : i ∈ S) (H2 : j ∈ S) (H3 : i ≠ j) :
  S.min' H < S.max' H :=
begin
  rcases lt_trichotomy i j with H4 | H4 | H4,
  { have H5 := finset.min'_le S H i H1,
    have H6 := finset.le_max' S H j H2,
    apply lt_of_le_of_lt H5,
    apply lt_of_lt_of_le H4 H6 },
  { cc },
  { have H5 := finset.min'_le S H j H2,
    have H6 := finset.le_max' S H i H1,
    apply lt_of_le_of_lt H5,
    apply lt_of_lt_of_le H4 H6 }
end

end miscellaneous

variable (n : ℕ)

def Sym : Type :=
equiv.perm (fin n)

instance : has_coe_to_fun (Sym n) :=
equiv.has_coe_to_fun

@[extensionality] theorem Sym.ext (σ τ : Sym n)
  (H : ∀ i, σ i = τ i) : σ = τ :=
equiv.ext _ _ H

theorem Sym.ext_iff (σ τ : Sym n) :
  σ = τ ↔ ∀ i, σ i = τ i :=
⟨λ H i, H ▸ rfl, Sym.ext _ _ _⟩

instance : decidable_eq (Sym n) :=
λ σ τ, decidable_of_iff' _ (Sym.ext_iff _ _ _)

instance : group (Sym n) :=
equiv.perm_group

variable {n}

section perm

def Sym.to_list (σ : Sym n) : list (fin n) :=
list.of_fn σ

theorem Sym.to_list_perm (σ : Sym n) :
  σ.to_list ~ list.of_fn (1 : Sym n) :=
(list.perm_ext
  (list.nodup_of_fn $ σ.bijective.1)
  (list.nodup_of_fn $ (1 : Sym n).bijective.1)).2 $ λ f,
by rw [list.of_fn_eq_pmap, list.of_fn_eq_pmap, list.mem_pmap, list.mem_pmap]; from
⟨λ _, ⟨f.1, by simp [f.2], fin.eq_of_veq rfl⟩,
λ _, ⟨(σ⁻¹ f).1, by simp [(σ⁻¹ f).2], by convert equiv.apply_inverse_apply σ f;
  from congr_arg _ (fin.eq_of_veq rfl)⟩⟩

def list.to_sym (L : list (fin n))
  (HL : L ~ list.of_fn (1 : Sym n)) : Sym n :=
{ to_fun := λ f, list.nth_le L f.1 $
    by rw [list.perm_length HL, list.length_of_fn]; from f.2,
  inv_fun := λ f, ⟨list.index_of f L,
    begin
      convert list.index_of_lt_length.2 _,
      { rw [list.perm_length HL, list.length_of_fn] },
      { rw [list.mem_of_perm HL, list.mem_iff_nth_le],
        refine ⟨f.1, _, _⟩,
        { rw list.length_of_fn,
          exact f.2 },
        { apply list.nth_le_of_fn } }
    end⟩,
  left_inv := λ f, fin.eq_of_veq $ list.nth_le_index_of
    ((list.perm_nodup HL).2 $ list.nodup_of_fn $ λ _ _, id) _ _,
  right_inv := λ f, list.index_of_nth_le $ list.index_of_lt_length.2 $
    (list.mem_of_perm HL).2 $ list.mem_iff_nth_le.2 $
    ⟨f.1, by rw list.length_of_fn; from f.2,
      list.nth_le_of_fn _ _⟩ }

@[simp] lemma list.to_sym_apply (L : list (fin n))
  (HL : L ~ list.of_fn (1 : Sym n)) (i) :
  (L.to_sym HL) i = L.nth_le i.1 (by simp [list.perm_length HL, i.2]) :=
rfl

@[simp] lemma Sym.to_list_to_sym (σ : Sym n) :
  σ.to_list.to_sym σ.to_list_perm = σ :=
Sym.ext _ _ _ $ λ i, fin.eq_of_veq $ by simp [Sym.to_list]

end perm

namespace Sym

def equiv_0 : Sym 0 ≃ fin (0:ℕ).fact :=
{ to_fun    := λ _, ⟨0, dec_trivial⟩,
  inv_fun   := λ _, 1,
  left_inv  := λ _, ext _ _ _ $ λ ⟨n, H⟩, by cases H,
  right_inv := λ ⟨n, H⟩, fin.eq_of_veq $
    by cases H with H1 H1; [refl, cases H1] }

def descend (σ : Sym (n+1)) : Sym n :=
{ to_fun    := λ i, (σ 0).descend (σ i.succ)
    (λ H, by cases i; from nat.no_confusion
      (fin.veq_of_eq (σ.bijective.1 H))),
  inv_fun   := λ i, (σ.symm ((σ 0).ascend i)).pred $ λ H,
    fin.ascend_ne (σ 0) i $ by simpa using H,
  left_inv  := λ i, fin.eq_of_veq $ by dsimp; rw [fin.pred_val];
    apply nat.pred_eq_of_eq_succ; rw [← fin.succ_val];
    apply fin.veq_of_eq; simp,
  right_inv := λ i, fin.eq_of_veq $ by simp }

def ascend (σ : Sym n) (k : fin (n+1)) : Sym (n+1) :=
{ to_fun    := λ i, if H : i = 0 then k
    else k.ascend $ σ $ i.pred H,
  inv_fun   := λ i, if H : i = k then 0
    else (σ.symm $ k.descend i H).succ,
  left_inv  := λ i, fin.eq_of_veq $ begin
      dsimp,
      by_cases h1 : i = 0,
      { simp [h1] },
      { rw [dif_neg h1],
        rw [dif_neg (fin.ascend_ne k (σ (i.pred h1)))],
        simp }
    end,
  right_inv := λ i, fin.eq_of_veq $ begin
      dsimp,
      by_cases h1 : i = k,
      { simp [h1] },
      { rw [dif_neg h1, dif_neg], { simp },
        intro H,
        replace H := fin.veq_of_eq H,
        simp at H,
        exact nat.no_confusion H }
    end }

@[simp] lemma descend_ascend (σ : Sym n) (k : fin (n+1)) :
  descend (ascend σ k) = σ :=
begin
  ext i,
  dsimp [ascend, descend],
  have H : i.succ ≠ 0,
  { intro H,
    replace H := fin.veq_of_eq H,
    simp at H, injections },
  simp [H]
end

def equiv_succ (ih : Sym n ≃ fin n.fact) :
  Sym (n+1) ≃ (fin (n+1) × fin n.fact) :=
{ to_fun    := λ σ, (σ 0, ih $ descend σ),
  inv_fun   := λ F, ascend (ih.symm F.2) F.1,
  left_inv  := λ σ, ext _ _ _ $ λ i, begin
    dsimp, rw [equiv.inverse_apply_apply ih],
    dsimp [descend, ascend],
    split_ifs, {subst h},
    simp
  end,
  right_inv := λ F, prod.ext
      (fin.eq_of_veq $ by dsimp [ascend]; simp) $
    fin.eq_of_veq $ by simp }

protected def equiv : Sym n ≃ fin n.fact :=
nat.rec_on n equiv_0 $ λ n ih,
calc  Sym (n+1)
    ≃ (fin (n+1) × fin n.fact) : equiv_succ ih
... ≃ fin (n+1).fact : fin_prod

instance : fintype (Sym n) :=
fintype.of_equiv _ Sym.equiv.symm

theorem card : fintype.card (Sym n) = nat.fact n :=
(fintype.of_equiv_card Sym.equiv.symm).trans $
fintype.card_fin _

theorem Cayley (α : Type*) [group α] [fintype α] :
  ∃ f : α → Sym (fintype.card α), function.injective f ∧ is_group_hom f :=
nonempty.rec_on (fintype.card_eq.1 $ fintype.card_fin $ fintype.card α) $ λ φ,
⟨λ x, ⟨λ i, φ.symm (x * φ i), λ i, φ.symm (x⁻¹ * φ i),
  λ i, by simp, λ i, by simp⟩,
λ x y H, have H1 : _ := congr_fun (equiv.mk.inj H).1 (φ.symm 1), by simpa using H1,
⟨λ x y, ext _ _ _ $ λ i, by simp [mul_assoc]⟩⟩

@[simp] lemma mul_apply (σ τ : Sym n) (i : fin n) :
  (σ * τ) i = σ (τ i) :=
rfl

@[simp] lemma one_apply (i : fin n) :
  (1 : Sym n) i = i :=
rfl

@[simp] lemma inv_apply (σ : Sym n) (i : fin n) :
  σ⁻¹ i = σ.symm i :=
rfl

def swap (i j : fin n) : Sym n :=
{ to_fun    := λ k, if k = i then j
    else if k = j then i else k,
  inv_fun   := λ k, if k = i then j
    else if k = j then i else k,
  left_inv  := λ k, by dsimp; split_ifs; cc,
  right_inv := λ k, by dsimp; split_ifs; cc }

@[simp] lemma swap_left (i j : fin n) :
  swap i j i = j :=
by dsimp [swap]; cc

@[simp] lemma swap_right (i j : fin n) :
  swap i j j = i :=
by dsimp [swap]; split_ifs; cc

@[simp] lemma swap_mul_self (i j : fin n) :
  swap i j * swap i j = 1 :=
ext _ _ _ $ λ k, by dsimp [swap]; split_ifs; cc

theorem swap_comm (i j : fin n) :
  swap i j = swap j i :=
ext _ _ _ $ λ k, by dsimp [swap]; split_ifs; cc

theorem swap_canonical (i j : fin n)
  (H1 H2 : ({i, j} : finset (fin n)) ≠ ∅) :
  swap (finset.min' _ H1) (finset.max' _ H2) = swap i j :=
begin
  have H3 := finset.min'_mem _ H1,
  have H4 : finset.min' _ H1 = j ∨ finset.min' _ H1 = i,
  { simpa using H3 },
  have H5 := finset.max'_mem _ H2,
  have H6 : finset.max' _ H2 = j ∨ finset.max' _ H2 = i,
  { simpa using H5 },
  cases H4; cases H6,
  { rw [H4, H6],
    have H7 := finset.min'_le _ H1 i (by simp),
    have H8 := finset.le_max' _ H2 i (by simp),
    rw H4 at H7, rw H6 at H8,
    have H9 := le_antisymm H7 H8,
    subst H9 },
  { rw [H4, H6, swap_comm] },
  { rw [H4, H6] },
  { rw [H4, H6],
    have H7 := finset.min'_le _ H1 j (by simp),
    have H8 := finset.le_max' _ H2 j (by simp),
    rw H4 at H7, rw H6 at H8,
    have H9 := le_antisymm H7 H8,
    subst H9 }
end

@[simp] theorem swap_self (i : fin n) :
  swap i i = 1 :=
ext _ _ _ $ λ k, by dsimp [swap]; split_ifs; cc

def support (σ : Sym n) : finset (fin n) :=
finset.filter (λ i, σ i ≠ i) finset.univ

theorem support_def {σ : Sym n} {i : fin n} :
  i ∈ σ.support ↔ σ i ≠ i :=
⟨λ H, (finset.mem_filter.1 H).2, λ H, finset.mem_filter.2 ⟨finset.mem_univ _, H⟩⟩

def support_choice (σ : Sym n) (H : σ.support ≠ ∅) :
  { i // i ∈ σ.support } :=
⟨σ.support.min' H, finset.min'_mem _ _⟩

theorem support_swap {i j : fin n} (H : i ≠ j) :
  (swap i j).support = {i, j} :=
begin
  ext k, split,
  { intro H1,
    simp [support_def, swap] at H1,
    split_ifs at H1 with h1 h2 h3 h4,
    { subst h1, simp },
    { subst h2, simp },
    cc },
  { intro H1,
    simp at H1,
    cases H1 with H1 H1;
    subst H1;
    simp [support_def, swap, H.symm, H] }
end

theorem support_swap_mul {σ : Sym n} {i : fin n}
  (H : i ∈ σ.support) : (swap (σ i) i * σ).support < σ.support :=
begin
  split,
  { intros j h1,
    simp [support_def, swap] at *,
    split_ifs at h1,
    { intro h2, rw ← h2 at h, subst h, cc },
    { cc },
    { cc } },
  intro H1,
  specialize H1 H,
  simp [support_def, swap] at H1,
  apply H1
end

@[simp] lemma support_one : support (1 : Sym n) = ∅ :=
finset.eq_empty_of_forall_not_mem $ λ i H,
support_def.1 H rfl

variable (n)
@[derive decidable_eq]
structure step : Type :=
(fst : fin n)
(snd : fin n)
(lt  : fst < snd)
variable {n}

instance step.fintype : fintype (step n) :=
@fintype.of_surjective { i : fin n × fin n // i.1 < i.2 } _ _ _
  (λ i, (⟨i.1.1, i.1.2, i.2⟩ : step n)) $ λ s,
⟨⟨(s.1, s.2), s.3⟩, by cases s; refl⟩

instance : has_mem (fin n) (step n) :=
⟨λ i s, i = s.1 ∨ i = s.2⟩

@[extensionality] theorem step.ext (s t : step n)
  (H1 : s.1 = t.1) (H2 : s.2 = t.2) : s = t :=
by cases s; cases t; congr; assumption

def step.mk' (i j : fin n) (H : i ≠ j) : step n :=
if h : i < j then ⟨i, j, h⟩ else
⟨j, i, (eq_or_lt_of_not_lt h).resolve_left H⟩

def step.eval (s : step n) : Sym n :=
swap s.1 s.2

@[simp] lemma step.eval_mul_self (s : step n) :
  s.eval * s.eval = 1 :=
by simp [step.eval]

@[simp] lemma step.eval_mk' (i j : fin n) (H : i ≠ j) :
  (step.mk' i j H).eval = swap i j :=
by unfold step.mk'; split_ifs; simp [step.eval, swap_comm]

theorem choice.aux (σ : Sym n)
  (H : ∃ i j, i ≠ j ∧ σ = swap i j) :
  σ.support ≠ ∅ :=
let ⟨i, j, h1, h2⟩ := H in by
  refine finset.ne_empty_of_mem (_ : j ∈ σ.support);
  rw [h2, support_swap h1];
  apply finset.mem_insert_self

def choice (σ : Sym n)
  (H : ∃ i j, i ≠ j ∧ σ = swap i j) : step n :=
{ fst := σ.support.min' $ choice.aux _ H,
  snd := σ.support.max' $ choice.aux _ H,
  lt  := by rcases H with ⟨i, j, h1, h2⟩; subst h2; dsimp;
    refine finset.min'_lt_max' _ _ _ _ h1;
    simp [support_swap h1] }

theorem eval_choice (σ : Sym n)
  (H : ∃ i j, i ≠ j ∧ σ = swap i j) :
  (σ.choice H).eval = σ :=
begin
  rcases H with ⟨i, j, h1, h2⟩,
  subst h2, unfold step.eval choice, dsimp,
  convert swap_canonical i j _ _;
  simp [support_swap h1]
end

theorem choice_eval (s : step n)
  (H : ∃ i j, i ≠ j ∧ s.eval = swap i j) :
  s.eval.choice H = s :=
begin
  ext; dsimp [step.eval, choice],
  { apply le_antisymm,
    { apply finset.min'_le,
      simp [support_swap (ne_of_lt s.3)] },
    { apply finset.le_min',
      intros y h1,
      simp [support_swap (ne_of_lt s.3)] at h1,
      cases h1; subst h1,
      apply le_of_lt s.3 } },
  { apply le_antisymm,
    { apply finset.max'_le,
      intros y h1,
      simp [support_swap (ne_of_lt s.3)] at h1,
      cases h1; subst h1,
      apply le_of_lt s.3 },
    { apply finset.le_max',
      simp [support_swap (ne_of_lt s.3)] } }
end

def list_step.aux : has_well_founded (Sym n) :=
{ r := inv_image (<) support,
  wf := inv_image.wf _ finset.lt_wf }

local attribute [instance] list_step.aux
attribute [elab_as_eliminator] well_founded.fix
attribute [elab_as_eliminator] well_founded.induction

def list_step (σ : Sym n) : list (step n) :=
by refine well_founded.fix list_step.aux.wf _ σ; from
λ σ ih, if H : σ.support = ∅ then []
  else let ⟨i, hi⟩ := σ.support_choice H in
    step.mk' (σ i) i (support_def.1 hi)
    :: ih (swap (σ i) i * σ) (support_swap_mul hi)

@[simp] lemma list_step_prod (σ : Sym n) :
  (σ.list_step.map step.eval).prod = σ :=
well_founded.induction list_step.aux.wf σ $ λ σ ih,
begin
  dsimp [list_step],
  rw [well_founded.fix_eq],
  split_ifs,
  { ext, by_contra H,
    suffices : i ∈ (∅ : finset (fin n)),
    { simp at this, cc },
    rw [← h, support_def],
    exact mt eq.symm H },
  cases support_choice σ h with i hi,
  unfold list_step._match_1,
  specialize ih _ (support_swap_mul hi),
  dsimp [list_step] at ih,
  rw [list.map_cons, list.prod_cons, ih, ← mul_assoc],
  rw [step.eval_mk', swap_mul_self, one_mul]
end

theorem mem_step_iff_mem_support (s : step n) (i : fin n) :
  i ∈ s ↔ i ∈ s.eval.support :=
begin
  unfold step.eval,
  simp [support_swap (ne_of_lt s.3)],
  rw [or_comm], refl
end

theorem support_eq_of_mul_eq_one {σ τ : Sym n} (H : σ * τ = 1) :
  σ.support = τ.support :=
begin
  ext i, simp [support_def, not_iff_not],
  rw [eq_comm, iff.comm],
  convert equiv.symm_apply_eq,
  symmetry,
  rw [equiv.symm_apply_eq, ← mul_apply, H, one_apply],
end

theorem of_mem_mul_support {σ τ : Sym n} {i}
  (H : i ∈ (σ * τ).support) :
  i ∈ σ.support ∨ i ∈ τ.support :=
by_contradiction $ λ H2,
by simp [support_def, not_or_distrib] at H H2;
simp [H2] at H; cc

theorem of_not_mem_mul_support {σ τ : Sym n} {i}
  (H : i ∉ (σ * τ).support) :
  i ∈ σ.support ↔ i ∈ τ.support :=
begin
  simp [support_def] at H ⊢,
  split,
  { intros H2 H3, rw H3 at H, cc },
  { intros H2 H3, rw ← H3 at H,
    replace H := σ.bijective.1 H,
    rw H3 at H, cc }
end

theorem not_mem_mul_support {σ τ : Sym n} {i}
  (H1 : i ∉ σ.support) (H2 : i ∉ τ.support) :
  i ∉ (σ * τ).support :=
begin
  simp [support_def] at H1 H2 ⊢,
  rw [H2, H1]
end

@[simp] lemma mem_mk' {i j k : fin n} (H : i ≠ j) :
  k ∈ step.mk' i j H ↔ k = i ∨ k = j :=
begin
  unfold step.mk',
  split_ifs,
  { refl },
  { apply or_comm }
end

-- (ab)(cd) = (cd)(ab)
theorem sgn_aux5 (s t : step n)
  (H1 : s.1 ≠ t.1) (H2 : s.1 ≠ t.2)
  (H3 : s.2 ≠ t.1) (H4 : s.2 ≠ t.2) :
  s.eval * t.eval = t.eval * s.eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  dsimp [step.eval, swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(ac) = (bc)(ab)
theorem sgn_aux4a (s t : step n)
  (H1 : s.1 = t.1) (H4 : s.2 ≠ t.2) :
  s.eval * t.eval = (step.mk' s.2 t.2 H4).eval * s.eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  unfold step.eval step.mk',
  simp [swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(ca) = (cb)(ab)
theorem sgn_aux4b (s t : step n) (H1 : s.1 = t.2)
  (H2 : t.1 < s.2) :
  s.eval * t.eval = (⟨t.1, s.2, H2⟩ : step n).eval * s.eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  have := ne_of_lt H2,
  dsimp [step.eval, swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(ac) = (ac)(bc)
theorem sgn_aux4c (s t : step n)
  (H1 : s.1 = t.1) (H4 : s.2 ≠ t.2) :
  s.eval * t.eval = t.eval * (step.mk' s.2 t.2 H4).eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  unfold step.eval step.mk',
  simp [swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(ca) = (ca)(cb)
theorem sgn_aux4d (s t : step n)
  (H1 : s.1 = t.2) (H4 : t.1 < s.2) :
  s.eval * t.eval = t.eval * (⟨t.1, s.2, H4⟩ : step n).eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  have := ne_of_lt H4,
  simp [step.eval, swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(bc) = (bc)(ac)
theorem sgn_aux3a (s t : step n) (H1 : s.2 = t.1)
  (H2 : s.1 < t.2) :
  s.eval * t.eval = t.eval * (⟨s.1, t.2, H2⟩ : step n).eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  have := ne_of_lt H2,
  dsimp [step.eval, swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(cb) = (cb)(ac)
theorem sgn_aux3b (s t : step n) (H1 : s.2 = t.2)
  (H2 : s.1 ≠ t.1) :
  s.eval * t.eval = t.eval * (step.mk' s.1 t.1 H2).eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  unfold step.eval step.mk',
  simp [swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(bc) = (ac)(ab)
theorem sgn_aux3c (s t : step n) (H1 : s.2 = t.1)
  (H2 : s.1 < t.2) :
  s.eval * t.eval = (⟨s.1, t.2, H2⟩ : step n).eval * s.eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  have := ne_of_lt H2,
  dsimp [step.eval, swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(cb) = (ac)(ab)
theorem sgn_aux3d (s t : step n) (H1 : s.2 = t.2)
  (H2 : s.1 ≠ t.1) :
  s.eval * t.eval = (step.mk' s.1 t.1 H2).eval * s.eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  unfold step.eval step.mk',
  simp [swap], ext k,
  dsimp at *,
  split_ifs; cc
end

theorem sgn_aux2 (s t : step n) (i) (H : i ∈ s) :
  s = t ∨ ∃ s' t' : step n, s.eval * t.eval = s'.eval * t'.eval
    ∧ i ∉ s' ∧ i ∈ t' :=
begin
  cases H with H H; subst H,
  { by_cases H2 : s.1 = t.1,
    { by_cases H3 : s.2 = t.2,
      { left, ext; assumption },
      right, -- (ab)(ac) = (bc)(ab)
      refine ⟨step.mk' s.2 t.2 H3, s, _, _⟩,
      { exact sgn_aux4a _ _ H2 _ },
      rw [mem_mk'],
      exact ⟨λ H, or.cases_on H
        (ne_of_lt s.3) (H2.symm ▸ (ne_of_lt t.3)),
      or.inl rfl⟩ },
    right,
    by_cases H3 : s.1 = t.2,
    { -- (ab)(ca) = (cb)(ab)
      have H4 : t.1 < s.2 := lt_trans t.3 (H3 ▸ s.3),
      refine ⟨⟨t.1, s.2, H4⟩, s, _, _⟩,
      { exact sgn_aux4b _ _ H3 _ },
      exact ⟨λ H, or.cases_on H
        H2 (ne_of_lt s.3),
      or.inl rfl⟩ },
    by_cases H4 : s.2 = t.1,
    { -- (ab)(bc) = (bc)(ac)
      have H5 : s.1 < t.2 := lt_trans s.3 (H4.symm ▸ t.3),
      refine ⟨t, ⟨s.1, t.2, H5⟩, _, _⟩,
      { exact sgn_aux3a _ _ H4 _ },
      exact ⟨λ H, or.cases_on H
        H2 (ne_of_lt H5),
      or.inl rfl⟩ },
    by_cases H5 : s.2 = t.2,
    { -- (ab)(cb) = (cb)(ac)
      refine ⟨t, step.mk' s.1 t.1 H2, _, _⟩,
      { exact sgn_aux3b _ _ H5 _ },
      exact ⟨λ H, or.cases_on H
        H2 H3,
      by simp⟩ },
    -- (ab)(cd) = (cd)(ab)
    refine ⟨t, s, _, _⟩,
    { exact sgn_aux5 _ _ H2 H3 H4 H5 },
    exact ⟨λ H, or.cases_on H
      H2 H3,
    or.inl rfl⟩ },
  by_cases H2 : s.1 = t.1,
  { by_cases H3 : s.2 = t.2,
    { left, ext; assumption },
    right, -- (ab)(ac) = (ac)(bc)
    refine ⟨t, step.mk' s.2 t.2 H3, _, _⟩,
    { exact sgn_aux4c _ _ H2 _ },
    rw [mem_mk'],
    exact ⟨λ H, or.cases_on H
      (H2 ▸ ne_of_gt s.3) H3,
    or.inl rfl⟩ },
  right,
  by_cases H3 : s.1 = t.2,
  { -- (ab)(ca) = (ca)(cb)
    have H4 : t.1 < s.2 := lt_trans t.3 (H3 ▸ s.3),
    refine ⟨t, ⟨t.1, s.2, H4⟩, _, _⟩,
    { exact sgn_aux4d _ _ H3 _ },
    exact ⟨λ H, or.cases_on H
      (ne_of_gt H4) (H3 ▸ ne_of_gt s.3),
    or.inr rfl⟩ },
  by_cases H4 : s.2 = t.1,
  { -- (ab)(bc) = (ac)(ab)
    have H5 : s.1 < t.2 := lt_trans s.3 (H4.symm ▸ t.3),
    refine ⟨⟨s.1, t.2, H5⟩, s, _, _⟩,
    { exact sgn_aux3c _ _ H4 _ },
    exact ⟨λ H, or.cases_on H
      (ne_of_gt s.3) (H4.symm ▸ ne_of_lt t.3),
    or.inr rfl⟩ },
  by_cases H5 : s.2 = t.2,
  { -- (ab)(cb) = (ac)(ab)
    refine ⟨step.mk' s.1 t.1 H2, s, _, _⟩,
    { exact sgn_aux3d _ _ H5 _ },
    rw [mem_mk'],
    exact ⟨λ H, or.cases_on H
      (ne_of_gt s.3) (H5.symm ▸ ne_of_gt t.3),
    or.inr rfl⟩ },
  refine ⟨t, s, _, _⟩,
  { exact sgn_aux5 _ _ H2 H3 H4 H5 },
  exact ⟨λ H, or.cases_on H
    H4 H5,
  or.inr rfl⟩
end

theorem sgn_aux (L1 : list (step n)) (s : step n) (L2 : list (step n)) (i : fin n)
  (H1 : (L1.map step.eval).prod * s.eval * (L2.map step.eval).prod = 1)
  (H2 : i ∈ s) (H3 : i ∉ (L1.map step.eval).prod.support) :
  ∃ (L : list (step n)),
    (L.map step.eval).prod = 1
    ∧ L.length + 2 = L1.length + 1 + L2.length :=
begin
  induction L2 with hd tl ih generalizing L1 s,
  { simp at H1,
    simp [mem_step_iff_mem_support] at H2,
    rw support_eq_of_mul_eq_one H1 at H3,
    cc },
  simp [mul_assoc] at H1,
  simp [mem_step_iff_mem_support] at H2,
  have H4 := H3,
  rw [support_eq_of_mul_eq_one H1] at H4,
  replace H4 := of_not_mem_mul_support H4,
  replace H4 := H4.1 H2,
  rw [← mem_step_iff_mem_support] at H2,
  rcases sgn_aux2 s hd i H2 with H5 | ⟨s', t', H5, H6, H7⟩,
  { subst H5,
    rw [← mul_assoc s.eval, step.eval_mul_self, one_mul] at H1,
    rw [← list.prod_append, ← list.map_append] at H1,
    refine ⟨_, H1, _⟩,
    simp, unfold bit0, ac_refl },
  specialize ih (L1 ++ [s']) t' _ H7 _,
  rcases ih with ⟨L, H8, H9⟩,
  refine ⟨L, H8, _⟩,
  { simp [H9] },
  { simp at H5 ⊢,
    rw [mul_assoc (L1.map step.eval).prod, ← H5],
    simpa [mul_assoc] using H1 },
  simpa using not_mem_mul_support H3 _,
  simpa [mem_step_iff_mem_support] using H6
end

theorem length_even_of_prod_one (L : list (step n))
  (H : (L.map step.eval).prod = 1) :
  L.length % 2 = 0 :=
begin
  generalize H1 : L.length = k,
  revert L,
  apply nat.strong_induction_on k,
  intros k ih L H H1,
  cases k with k, { refl },
  cases k with k,
  { exfalso,
    rw list.length_eq_one at H1,
    cases H1 with s H2,
    subst H2,
    replace H := congr_arg support H,
    simp [step.eval, support_swap (ne_of_lt s.3)] at H,
    exact H },
  cases L with hd tl, { simp at H1, injections },
  rcases sgn_aux [] hd tl hd.1 _ (or.inl rfl) _ with ⟨L, H2, H3⟩,
  specialize ih k _ L H2 _,
  change (k + 2) % 2 = 0,
  { rw [nat.add_mod_right, ih] },
  { constructor, constructor },
  { simp at H1 H3,
    rw ← H3 at H1,
    exact nat.succ_inj (nat.succ_inj H1) },
  { simpa using H },
  simp
end

theorem length_mod_two_eq (L1 L2 : list (step n))
  (H : (L1.map step.eval).prod = (L2.map step.eval).prod) :
  L1.length % 2 = L2.length % 2 :=
have H1 : (L2.map step.eval).reverse.prod = (L2.map step.eval).prod⁻¹,
  from list.rec_on L2 (by simp) $ λ hd tl ih,
    by simp [ih, eq_inv_iff_mul_eq_one],
have H2 : _,
  from length_even_of_prod_one (L1 ++ L2.reverse) $
    by simp [H1, H],
have H3 : 2 ∣ L1.length + L2.length,
  by simpa [nat.dvd_iff_mod_eq_zero] using H2,
calc  L1.length % 2
    = (L1.length + L2.length + L2.length) % 2 :
  by rw [add_assoc, ← mul_two, nat.add_mul_mod_self_right]
... = L2.length % 2 :
  by cases H3 with k H4; rw [H4, add_comm, nat.add_mul_mod_self_left]

end Sym

@[derive decidable_eq]
inductive mu2 : Type
| plus_one : mu2
| minus_one : mu2

namespace mu2

definition neg : mu2 → mu2
| plus_one := minus_one
| minus_one := plus_one

instance : has_one mu2 := ⟨plus_one⟩
instance : has_neg mu2 := ⟨neg⟩

instance : comm_group mu2 :=
{ mul := λ x y, mu2.rec_on x (mu2.rec_on y 1 (-1)) (mu2.rec_on y (-1) 1),
  mul_assoc := λ x y z, by cases x; cases y; cases z; refl,
  mul_one := λ x, by cases x; refl,
  one_mul := λ x, by cases x; refl,
  inv := id,
  mul_left_inv := λ x, by cases x; refl,
  mul_comm := λ x y, by cases x; cases y; refl,
  .. mu2.has_one }

instance : fintype mu2 :=
{ elems := {1, -1},
  complete := λ x, mu2.cases_on x (or.inr $ or.inl rfl) (or.inl rfl) }

theorem card : fintype.card mu2 = 2 :=
rfl

theorem neg_one_pow {n} : (-1 : mu2) ^ n = (-1 : mu2) ^ (n%2) :=
have H : (-1 : mu2) ^ 2 = 1, from rfl,
by rw [← nat.mod_add_div n 2, pow_add, pow_mul, H, one_pow, mul_one, nat.mod_add_div n 2]

@[simp] lemma mul_self_eq_one (x : mu2) : x * x = 1 :=
by cases x; refl

@[simp] lemma inv_eq_self (x : mu2) : x⁻¹ = x :=
rfl

@[simp] protected lemma mul_neg_one (x : mu2) : x * -1 = -x :=
by cases x; refl

@[simp] protected lemma neg_one_mul (x : mu2) : -1 * x = -x :=
by cases x; refl

@[simp] lemma neg_mul_self (x : mu2) : -x * x = -1 :=
by cases x; refl

@[simp] lemma mul_neg (x y : mu2) : x * -y = -x * y :=
by cases x; cases y; refl

end mu2

namespace Sym

def sgn (σ : Sym n) : mu2 :=
(-1) ^ σ.list_step.length

instance sgn.is_group_hom : is_group_hom (@sgn n) :=
begin
  constructor,
  intros σ τ,
  unfold sgn,
  rw [← pow_add, ← list.length_append],
  rw [mu2.neg_one_pow, eq_comm, mu2.neg_one_pow],
  refine congr_arg _ _,
  apply length_mod_two_eq,
  simp
end

@[simp] lemma sgn_step (s : step n) :
  sgn s.eval = -1 :=
suffices s.eval.list_step.length % 2 = [s].length % 2,
  by unfold sgn; rw [mu2.neg_one_pow, this]; refl,
length_mod_two_eq _ _ $ by simp

@[simp] lemma sgn_mul (σ τ : Sym n) :
  sgn (σ * τ) = sgn σ * sgn τ :=
is_group_hom.mul sgn _ _

@[simp] lemma sgn_one :
  sgn (1 : Sym n) = 1 :=
is_group_hom.one sgn

@[simp] lemma sgn_inv (σ : Sym n) :
  sgn σ⁻¹ = sgn σ :=
is_group_hom.inv sgn _

def eq_sgn_aux4 (s t : step n) : Sym n :=
swap (swap s.1 t.1 s.2) t.2 * swap s.1 t.1

theorem eq_sgn_aux3 (s t : step n) :
  eq_sgn_aux4 s t s.1 = t.1 :=
begin
  dsimp [eq_sgn_aux4, swap],
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  simp, split_ifs; cc
end

theorem eq_sgn_aux2 (s t : step n) :
  eq_sgn_aux4 s t s.2 = t.2 :=
begin
  dsimp [eq_sgn_aux4, swap],
  simp
end

theorem eq_sgn_aux (s t : step n) :
  eq_sgn_aux4 s t * s.eval * (eq_sgn_aux4 s t)⁻¹ = t.eval :=
begin
  ext k,
  by_cases H1 : k = t.1,
  { subst H1,
    dsimp [step.eval],
    simp [equiv.symm_apply_eq.2 (eq_sgn_aux3 s t).symm, eq_sgn_aux2] },
  by_cases H2 : k = t.2,
  { subst H2,
    dsimp [step.eval],
    simp [equiv.symm_apply_eq.2 (eq_sgn_aux2 s t).symm, eq_sgn_aux3] },
  dsimp [step.eval, swap],
  simp [H1, H2, eq_sgn_aux2, eq_sgn_aux3]
end

theorem eq_sgn (f : Sym n → mu2) [is_group_hom f]
  (s : step n) (H1 : f s.eval = -1) (σ : Sym n) :
  f σ = sgn σ :=
begin
  have H2 : ∀ t : step n, f t.eval = -1,
  { intro t,
    rw [← eq_sgn_aux s t],
    simp [is_group_hom.mul f, is_group_hom.inv f, H1] },
  have H3 := list_step_prod σ,
  revert H3, generalize : list_step σ = L, intro H3, subst H3,
  induction L with hd tl ih, { simp [is_group_hom.one f] },
  simp [is_group_hom.mul f, ih, H2]
end

section inversions

def step.map (s : step n) (σ : Sym n) : step n :=
step.mk' (σ s.1) (σ s.2) $ λ H, ne_of_lt s.3 $
σ.bijective.1 H

@[simp] lemma step.map_map_inv (s : step n) (σ : Sym n) :
  (s.map σ).map σ⁻¹ = s :=
begin
  unfold step.map step.mk',
  by_cases H1 : σ s.1 < σ s.2,
  { rw [dif_pos H1], dsimp,
    rw dif_pos, ext; simp,
    simp [s.3] },
  rw [dif_neg H1], dsimp,
  rw dif_neg, ext; simp,
  simp [le_of_lt s.3]
end

@[simp] lemma step.map_inv_map (s : step n) (σ : Sym n) :
  (s.map σ⁻¹).map σ = s :=
by simpa using step.map_map_inv s σ⁻¹

def inversion (σ : Sym n) (s : step n) : mu2 :=
if σ s.1 > σ s.2 then -1 else 1

def inversions (σ : Sym n) : mu2 :=
finset.prod finset.univ $ inversion σ

theorem inversion_mul (σ τ : Sym n) (s : step n) :
  inversion (σ * τ) s = inversion σ (s.map τ) * inversion τ s :=
begin
  unfold inversion step.map step.mk',
  split_ifs with h1 h2 h3 h3 h4 h4 h2 h3 h3 h4 h4; try { refl },
  { exfalso, apply lt_asymm h2 h3 },
  { exfalso, apply lt_asymm h1 h3 },
  { simp at *, exfalso,
    exact ne_of_lt s.3 (τ.bijective.1 $ le_antisymm h4 h2) },
  { exfalso, apply lt_asymm h2 h3 },
  { simp at *, exfalso,
    exact ne_of_lt s.3 (τ.bijective.1 $ le_antisymm h4 h2) },
  { simp at *, exfalso,
    exact ne_of_lt s.3 (τ.bijective.1 $ σ.bijective.1 $ le_antisymm h1 h3) }
end

instance : is_group_hom (@inversions n) :=
⟨λ σ τ, calc
      inversions (σ * τ)
    = finset.prod finset.univ (inversion (σ * τ)) : rfl
... = finset.prod finset.univ (λ s : step n,
        inversion σ (s.map τ) * inversion τ s) :
  congr_arg _ $ funext $ inversion_mul σ τ
... = finset.prod finset.univ (λ s : step n,
        inversion σ (s.map τ)) * inversions τ :
  finset.prod_mul_distrib
... = finset.prod finset.univ (inversion σ) * inversions τ :
  congr_arg (λ z, z * inversions τ) $ finset.prod_bij
    (λ s _, step.map s τ) (λ _ _, finset.mem_univ _) (λ _ _, rfl)
    (λ s t _ _ H, by simpa using congr_arg (λ z, step.map z τ⁻¹) H)
    (λ s _, ⟨s.map τ⁻¹, finset.mem_univ _, by simp⟩)⟩

variable (n)
def step01 : step (n+2) :=
⟨⟨0, nat.zero_lt_succ _⟩, ⟨1, nat.succ_lt_succ $ nat.zero_lt_succ _⟩, dec_trivial⟩
variable {n}

theorem inversions_step01 : inversions (step01 n).eval = -1 :=
show _ = finset.prod {step01 n} (inversion (step01 n).eval), from
eq.symm $ finset.prod_subset (finset.subset_univ _) $ λ s _ H1, begin
  unfold inversion step.eval swap step01; dsimp at *, rw if_neg,
  by_cases H2 : s.1.1 = 0,
  { rw [if_pos, if_neg, if_neg],
    { intro H3,
      replace H3 := nat.le_of_lt_succ H3,
      replace H3 := nat.eq_zero_of_le_zero H3,
      exact ne_of_lt s.3 (fin.eq_of_veq $ H2.trans H3.symm) },
    { intro H3, apply H1, simp, ext, exact fin.eq_of_veq H2, exact H3 },
    { exact ne_of_gt (H2 ▸ s.3 : s.2.1 > 0), },
    { exact fin.eq_of_veq H2 } },
  by_cases H3 : s.1.1 = 1,
  { rw [if_neg, if_pos], exact nat.not_lt_zero _,
    exact fin.eq_of_veq H3, exact mt fin.veq_of_eq H2 },
  rw [if_neg, if_neg, if_neg, if_neg],
  { exact lt_asymm s.3 },
  { intro H4, have H5 := s.3, rw H4 at H5,
    replace H5 := nat.le_of_lt_succ H5,
    replace H5 := nat.eq_zero_of_le_zero H5,
    cc },
  { intro H4, have H5 := s.3, rw H4 at H5,
    cases H5 },
  { exact mt fin.veq_of_eq H3 },
  { exact mt fin.veq_of_eq H2 }
end

theorem inversions_eq_sgn : ∀ σ : Sym n, inversions σ = sgn σ :=
nat.cases_on n dec_trivial $ λ n,
nat.cases_on n dec_trivial $ λ n σ,
eq_sgn inversions (step01 n) inversions_step01 σ

end inversions

end Sym

variable (n)
def Alt : Type :=
is_group_hom.ker (@Sym.sgn n)

instance : group (Alt n) :=
by unfold Alt; apply_instance


import data.sigma.basic
import tactic.ext

namespace sigma
universes u v

section
variables {α : Type u} {β β' : α → Type v}

theorem eq_fst {s₁ s₂ : sigma β} : s₁ = s₂ → s₁.1 = s₂.1 :=
by cases s₁; cases s₂; cc

theorem eq_snd {s₁ s₂ : sigma β} : s₁ = s₂ → s₁.2 == s₂.2 :=
by cases s₁; cases s₂; cc

end

section
variables {α₁ α₂ : Type u} {β₁ : α₁ → Type v} {β₂ : α₂ → Type v}

/-- A function on `sigma`s that is functional on `fst`s (preserves equality from
argument to result). -/
def fst_functional (f : sigma β₁ → sigma β₂) : Prop :=
∀ ⦃s t : sigma β₁⦄, s.1 = t.1 → (f s).1 = (f t).1

/-- A function on `sigma`s that is injective on `fst`s (preserves equality from
result to argument). -/
def fst_injective (f : sigma β₁ → sigma β₂) : Prop :=
∀ ⦃s t : sigma β₁⦄, (f s).1 = (f t).1 → s.1 = t.1

end

/-- A function on `sigma`s bundled with its `fst`-injectivity property. -/
structure embedding {α₁ α₂ : Type u} (β₁ : α₁ → Type v) (β₂ : α₂ → Type v) :=
(to_fun  : sigma β₁ → sigma β₂)
(fst_inj : fst_injective to_fun)

infixr ` s↪ `:25 := embedding

namespace embedding
variables {α₁ α₂ : Type u} {β₁ : α₁ → Type v} {β₂ : α₂ → Type v}

instance : has_coe_to_fun (β₁ s↪ β₂) :=
⟨_, embedding.to_fun⟩

@[simp] theorem to_fun_eq_coe (f : β₁ s↪ β₂) : f.to_fun = f :=
rfl

@[simp] theorem coe_fn_mk (f : sigma β₁ → sigma β₂) (i : fst_injective f) :
  (mk f i : sigma β₁ → sigma β₂) = f :=
rfl

theorem fst_inj' : ∀ (f : β₁ s↪ β₂), fst_injective f
| ⟨_, h⟩ := h

end embedding

section map_id
variables {α : Type u} {β₁ β₂ : α → Type v}

@[simp] theorem map_id_eq_fst {s : sigma β₁} (f : ∀ a, β₁ a → β₂ a) :
  (s.map id f).1 = s.1 :=
by cases s; refl

theorem map_id_fst_functional (f : ∀ a, β₁ a → β₂ a) :
  fst_functional (map id f) :=
λ _ _, by simp only [map_id_eq_fst]; exact id

theorem map_id_fst_injective (f : ∀ a, β₁ a → β₂ a) :
  fst_injective (map id f) :=
λ _ _, by simp only [map_id_eq_fst]; exact id

/-- Construct an `embedding` with `id` on `fst`. -/
def embedding.mk₂ (f : ∀ a, β₁ a → β₂ a) : embedding β₁ β₂ :=
⟨_, map_id_fst_injective f⟩

end map_id

section
variables {α : Type u} {β : α → Type v} {R : α → α → Prop}

/-- A relation `R` on `fst` values lifted to the `sigma`. This is useful where
you might otherwise use the term `λ s₁ s₂, R s₁.1 s₂.1`. -/
def fst_rel (R : α → α → Prop) (s₁ s₂ : sigma β) : Prop :=
R s₁.1 s₂.1

@[simp] theorem fst_rel_def {s₁ s₂ : sigma β} : fst_rel R s₁ s₂ = R s₁.1 s₂.1 :=
rfl

instance fst_rel_decidable [d : decidable_rel R] : decidable_rel (@fst_rel _ β R)
| s₁ s₂ := @d s₁.1 s₂.1

theorem fst_rel.refl (h : reflexive R) : reflexive (@fst_rel _ β R) :=
λ s, h s.1

theorem fst_rel.symm (h : symmetric R) : symmetric (@fst_rel _ β R) :=
λ s₁ s₂ (p : R s₁.1 s₂.1), h p

theorem fst_rel.trans (h : transitive R) : transitive (@fst_rel _ β R) :=
λ s₁ s₂ s₃ (p : R s₁.1 s₂.1) (q : R s₂.1 s₃.1), h p q

end

section
variables {α : Type u} {β : α → Type v}

theorem fst_functional_id : fst_functional (@id (sigma β)) :=
λ s t h, h

theorem fst_injective_id : fst_injective (@id (sigma β)) :=
λ s t h, h

@[refl] protected def embedding.refl (β : α → Type v) : β s↪ β :=
⟨_, fst_injective_id⟩

@[simp] theorem embedding.refl_apply (s : sigma β) : embedding.refl β s = s :=
rfl

end

section
variables {α₁ α₂ α₃ : Type u}
variables {β₁ : α₁ → Type v} {β₂ : α₂ → Type v} {β₃ : α₃ → Type v}
variables {g : sigma β₂ → sigma β₃} {f : sigma β₁ → sigma β₂}

theorem fst_functional_comp (gf : fst_functional g) (ff : fst_functional f) :
  fst_functional (g ∘ f) :=
λ s t h, gf (ff h)

theorem fst_injective_comp (gi : fst_injective g) (fi : fst_injective f) :
  fst_injective (g ∘ f) :=
λ s t h, fi (gi h)

@[trans] protected def embedding.trans (f : β₁ s↪ β₂) (g : β₂ s↪ β₃) : β₁ s↪ β₃ :=
⟨_, fst_injective_comp g.fst_inj f.fst_inj⟩

@[simp] theorem embedding.trans_apply (f : β₁ s↪ β₂) (g : β₂ s↪ β₃) (s : sigma β₁) :
  (f.trans g) s = g (f s) :=
rfl

@[extensionality]
lemma ext {x₀ x₁ : sigma β₁}
  (h₀ : x₀.1 = x₁.1)
  (h₁ : x₀.1 = x₁.1 → x₀.2 == x₁.2) :
  x₀ = x₁ :=
by casesm* sigma _; cases h₀; cases h₁ h₀; refl

lemma eta (x : sigma β₁) : sigma.mk x.1 x.2 = x :=
by cases x; refl

end

end sigma


import Qpf

-- set_option trace.Meta.debug true
-- set_option trace.Elab.inductive true
sudo set_option trace.QPF true
set_option pp.rawOnError true

#print List.noConfusionType
#check List.noConfusion
#check List.recOn
#check List.casesOn

-- #print prefix List

theorem nil_neq_cons (a : α) (as : List α) : List.nil ≠ List.cons a as :=
  by simp

#print nil_neq_cons

data QpfList α where
  | nil : QpfList α
  | cons : α → QpfList α → QpfList α

#check QpfList

#check @MvQPF.Fix.drec _ QpfList.Uncurried _

namespace QpfList
  #print QpfList.nil
  #print QpfList.cons

  def rec {α : Type _} {motive : QpfList α → Sort _} :
    motive QpfList.nil
    → ((head : α) → (tail : QpfList α) → motive tail → motive (QpfList.cons head tail))
    → (t : QpfList α)
    → motive t
  :=
    fun nil cons => MvQPF.Fix.drec (fun x =>
      match x with
      | .nil            => nil
      | .cons head tail => cons head tail.fst tail.snd
    )

  @[reducible] protected def recOn {α : Type _} {motive : QpfList α → Sort _} :
      (t : QpfList α)
      → motive QpfList.nil
      → ((head : α) → (tail : QpfList α) → motive tail → motive (QpfList.cons head tail))
      → motive t
    :=
      fun t nil cons => QpfList.rec nil cons t

  #print List.recOn

  #check @List.rec
  #check @QpfList.rec

  theorem nil_neq_cons (a : α) (as : QpfList α) : @QpfList.nil α ≠ QpfList.cons a as :=
    by
      sorry

  #print nil_neq_cons
end QpfList

data QpfTree α where
  | node : α → List (QpfTree α) → QpfTree α

codata QpfCoTree α where
  | node : α → List (QpfCoTree α) → QpfCoTree α

/-- If `a ∈ as`, return `as` with (a single occurrence of) `a` removed.
    Otherwise, if `a ∉ as`, return `none` -/
def List.is_rem (a : α) : List α → List α → Prop
  | b::bs, c::cs  =>    (a = c  ∧ bs = c::cs)
                      ∨ (b = c  ∧ bs.is_rem a cs)
  | _, _          => false

/-- Equates lists up-to permutation -/
def List.perm ⦃α⦄ : QpfList.Uncurried α → QpfList.Uncurried α → Prop
  -- body omitted
  := by sorry
  -- | [],    []  =>  true
  -- | a::as, bs  =>  ∃cs : List α, cs.is_rem a bs ∧ as.perm cs
  -- | _, _       =>  false

abbrev MultiSet.Uncurried := MvQPF.Quot1 List.perm
abbrev MultiSet := TypeFun.curried MultiSet.Uncurried

noncomputable instance : MvQPF MultiSet.Uncurried := MvQPF.relQuot List.perm (by sorry)

#check (inferInstance : MvQPF MultiSet.Uncurried)

-- data UnorderedTree α where
--   | node : α → MultiSet (UnorderedTree α) → UnorderedTree α

#print QpfList

def QpfList.isNil : QpfList α → Bool :=
  MvQPF.Fix.rec fun as => match as with
    | .nil => true
    | _    => false

def QpfList.isCons : QpfList α → Bool :=
  fun as => match as.dest with
    | .cons .. => true
    | _        => false

def QpfList.length : QpfList α → Nat :=
  MvQPF.Fix.rec fun as => match as with
    | .nil                => 0
    | .cons a (as : Nat)  => as + 1

inductive QpfListInd α
  | nil
  | cons : α → QpfListInd α → QpfListInd α

 #check @QpfListInd.casesOn
 #check @QpfListInd.recOn
 #check @QpfListInd.rec
 #check QpfListInd.noConfusion (α:=Nat)

codata QpfStream α where
  | mk : α → QpfStream α → QpfStream α

#print QpfStream.mk

/-- The stream `0,0,0,...` -/
def QpfStream.zeroes : QpfStream Nat :=
  MvQPF.Cofix.corec (fun _ =>
    Shape.mk (0 : Nat) ()
  ) ()

/-- The stream `0,1,2,3,4,...` -/
def QpfStream.naturals : QpfStream Nat :=
  MvQPF.Cofix.corec (fun (i : Nat) =>
    Shape.mk (i : Nat) (i + 1 : Nat)
  ) 0

/-- Add two streams together -/
def QpfStream.add (as bs : QpfStream Nat) : QpfStream Nat :=
    MvQPF.Cofix.corec (fun ⟨as, bs⟩ =>
      let ⟨(a : Nat), as⟩ := MvQPF.Cofix.dest as;
      let ⟨(b : Nat), bs⟩ := MvQPF.Cofix.dest bs;
      Shape.mk (a + b : Nat) (as, bs)
    ) (as, bs)

-- data QpfListPair α β where
--   | nil_nil
--   | cons_nil  : α → QpfListPair α β
--   | nil_cons  : β → QpfListPair α β
--   | cons_cons : α → β → QpfListPair α β

-- def QpfListPair.of (as : QpfList α) (bs : QpfList β) : QpfListPair α β

#print QpfList.Uncurried
#print QpfList.Shape
#print QpfList.Shape.P

data QpfList₂ α where
  | My.nil : QpfList₂ α
  | My2.nil : α → QpfList₂ α

#check QpfList₂

data QpfList₃ α where
  | My.nil : QpfList₃ α
  | My2.nil : α → QpfList₃ α → QpfList₃ α

#check QpfList

namespace Quotient
  data List' α
  | nil
  | cons : α → List' α → List' α

  #print List'

  def List'.perm ⦃α⦄: Quotient.List'.Uncurried α → Quotient.List'.Uncurried α → Prop
    := by sorry

  abbrev Multiset' : TypeFun 1 := MvQPF.Quot1 List'.perm
  abbrev Multiset  := Multiset'.curried

  noncomputable instance : MvQPF Multiset' :=
    MvQPF.relQuot _ (
      by
        intros
        sorry
    )

  -- noncomputable data Foo α where
  --   | node : α → Multiset (Foo α) → Foo α

  -- #print Foo
  -- #print Quotient.Foo.node

  def List.perm : List α → List α → Prop
    := by sorry

  def NativeMultiset α := Quot.mk (@List.perm α)
end Quotient

/-
  # Composition pipeline
-/

qpf P₁ α β := α
qpf P₂ α β := β

qpf C₁ α β := Nat
qpf C₂ (n : Nat) α β := PFin2 n

qpf G₄ α β ρ := QpfList ρ

/-
  # Dead variables
-/

data Arrow (α : Type _) β
  | mk : (α → β) → Arrow α β

codata FinAlt {n : Nat} β
  | mk : PFin2 n → FinAlt β

#print FinAlt.mk

data QpfList₄ (dead : Type) β γ where
  | nil   : QpfList₄ dead β γ
  | cons  : QpfList₄ dead β γ → QpfList₄ dead β γ

/-
  # Regression tests

  These cases failed at some point, include them here as a regression test
-/

data PairOf α β
  | mk : α → β → β → PairOf α β

data QpfTest α β where
  | A : α → α → β → QpfTest α β → QpfTree β → QpfCoTree (QpfTree (QpfTest α β)) → QpfTest α β

data RepAfterConst β
  | mk : Nat →  β → β → RepAfterConst β

codata NatList α where
  | nil : NatList α
  | cons : Nat → NatList α → NatList α

data QpfList₅ (A : Type) (dead : Type) β where
  | nil   : QpfList₅ A dead β
  | cons  : A → (dead → β) → QpfList₅ A dead β → QpfList₅ A dead β


/-
Copyright (c) 2018 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.algebra.category.Mon.basic
import Mathlib.category_theory.endomorphism
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# Category instances for group, add_group, comm_group, and add_comm_group.

We introduce the bundled categories:
* `Group`
* `AddGroup`
* `CommGroup`
* `AddCommGroup`
along with the relevant forgetful functors between them, and to the bundled monoid categories.
-/

/-- The category of groups and group morphisms. -/
def AddGroup := category_theory.bundled add_group

/-- The category of additive groups and group morphisms -/
namespace Group

protected instance Mathlib.AddGroup.group.to_monoid.category_theory.bundled_hom.parent_projection :
    category_theory.bundled_hom.parent_projection add_group.to_add_monoid :=
  category_theory.bundled_hom.parent_projection.mk

protected instance has_coe_to_sort : has_coe_to_sort Group :=
  category_theory.bundled.has_coe_to_sort

/-- Construct a bundled `Group` from the underlying type and typeclass. -/
def of (X : Type u) [group X] : Group := category_theory.bundled.of X

/-- Construct a bundled `AddGroup` from the underlying type and typeclass. -/
protected instance group (G : Group) : group ↥G := category_theory.bundled.str G

@[simp] theorem coe_of (R : Type u) [group R] : ↥(of R) = R := rfl

protected instance Mathlib.AddGroup.has_zero : HasZero AddGroup := { zero := AddGroup.of PUnit }

protected instance inhabited : Inhabited Group := { default := 1 }

protected instance one.unique : unique ↥1 := unique.mk { default := 1 } sorry

@[simp] theorem one_apply (G : Group) (H : Group) (g : ↥G) : coe_fn 1 g = 1 := rfl

theorem ext (G : Group) (H : Group) (f₁ : G ⟶ H) (f₂ : G ⟶ H)
    (w : ∀ (x : ↥G), coe_fn f₁ x = coe_fn f₂ x) : f₁ = f₂ :=
  monoid_hom.ext fun (x : ↥G) => w x

-- should to_additive do this automatically?

protected instance Mathlib.AddGroup.has_forget_to_AddMon :
    category_theory.has_forget₂ AddGroup AddMon :=
  category_theory.bundled_hom.forget₂ add_monoid_hom add_group.to_add_monoid

end Group

/-- The category of commutative groups and group morphisms. -/
def AddCommGroup := category_theory.bundled add_comm_group

/-- The category of additive commutative groups and group morphisms. -/
/-- `Ab` is an abbreviation for `AddCommGroup`, for the sake of mathematicians' sanity. -/
def Ab := AddCommGroup

namespace CommGroup

protected instance comm_group.to_group.category_theory.bundled_hom.parent_projection :
    category_theory.bundled_hom.parent_projection comm_group.to_group :=
  category_theory.bundled_hom.parent_projection.mk

protected instance large_category : category_theory.large_category CommGroup :=
  category_theory.bundled_hom.category
    (category_theory.bundled_hom.map_hom
      (category_theory.bundled_hom.map_hom monoid_hom group.to_monoid) comm_group.to_group)

/-- Construct a bundled `CommGroup` from the underlying type and typeclass. -/
def of (G : Type u) [comm_group G] : CommGroup := category_theory.bundled.of G

/-- Construct a bundled `AddCommGroup` from the underlying type and typeclass. -/
protected instance Mathlib.AddCommGroup.add_comm_group_instance (G : AddCommGroup) :
    add_comm_group ↥G :=
  category_theory.bundled.str G

@[simp] theorem coe_of (R : Type u) [comm_group R] : ↥(of R) = R := rfl

protected instance Mathlib.AddCommGroup.has_zero : HasZero AddCommGroup :=
  { zero := AddCommGroup.of PUnit }

protected instance inhabited : Inhabited CommGroup := { default := 1 }

protected instance one.unique : unique ↥1 := unique.mk { default := 1 } sorry

@[simp] theorem one_apply (G : CommGroup) (H : CommGroup) (g : ↥G) : coe_fn 1 g = 1 := rfl

theorem ext (G : CommGroup) (H : CommGroup) (f₁ : G ⟶ H) (f₂ : G ⟶ H)
    (w : ∀ (x : ↥G), coe_fn f₁ x = coe_fn f₂ x) : f₁ = f₂ :=
  monoid_hom.ext fun (x : ↥G) => w x

protected instance Mathlib.AddCommGroup.has_forget_to_AddGroup :
    category_theory.has_forget₂ AddCommGroup AddGroup :=
  category_theory.bundled_hom.forget₂
    (category_theory.bundled_hom.map_hom add_monoid_hom add_group.to_add_monoid)
    add_comm_group.to_add_group

protected instance Mathlib.AddCommGroup.has_forget_to_AddCommMon :
    category_theory.has_forget₂ AddCommGroup AddCommMon :=
  category_theory.induced_category.has_forget₂ fun (G : AddCommGroup) => AddCommMon.of ↥G

end CommGroup

-- This example verifies an improvement possible in Lean 3.8.

-- Before that, to have `monoid_hom.map_map` usable by `simp` here,

-- we had to mark all the concrete category `has_coe_to_sort` instances reducible.

-- Now, it just works.

namespace AddCommGroup

/-- Any element of an abelian group gives a unique morphism from `ℤ` sending
`1` to that element. -/
-- Note that because `ℤ : Type 0`, this forces `G : AddCommGroup.{0}`,

-- so we write this explicitly to be clear.

-- TODO generalize this, requiring a `ulift_instances.lean` file

def as_hom {G : AddCommGroup} (g : ↥G) : of ℤ ⟶ G := coe_fn (gmultiples_hom ↥G) g

@[simp] theorem as_hom_apply {G : AddCommGroup} (g : ↥G) (i : ℤ) : coe_fn (as_hom g) i = i • g :=
  rfl

theorem as_hom_injective {G : AddCommGroup} : function.injective as_hom := sorry

theorem int_hom_ext {G : AddCommGroup} (f : of ℤ ⟶ G) (g : of ℤ ⟶ G) (w : coe_fn f 1 = coe_fn g 1) :
    f = g :=
  add_monoid_hom.ext_int w

-- TODO: this argument should be generalised to the situation where

-- the forgetful functor is representable.

theorem injective_of_mono {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H)
    [category_theory.mono f] : function.injective ⇑f :=
  sorry

end AddCommGroup

/-- Build an isomorphism in the category `Group` from a `mul_equiv` between `group`s. -/
def mul_equiv.to_Group_iso {X : Type u} {Y : Type u} [group X] [group Y] (e : X ≃* Y) :
    Group.of X ≅ Group.of Y :=
  category_theory.iso.mk (mul_equiv.to_monoid_hom e) (mul_equiv.to_monoid_hom (mul_equiv.symm e))

/-- Build an isomorphism in the category `AddGroup` from an `add_equiv` between `add_group`s. -/
/-- Build an isomorphism in the category `CommGroup` from a `mul_equiv` between `comm_group`s. -/
def add_equiv.to_AddCommGroup_iso {X : Type u} {Y : Type u} [add_comm_group X] [add_comm_group Y]
    (e : X ≃+ Y) : AddCommGroup.of X ≅ AddCommGroup.of Y :=
  category_theory.iso.mk (add_equiv.to_add_monoid_hom e)
    (add_equiv.to_add_monoid_hom (add_equiv.symm e))

/-- Build an isomorphism in the category `AddCommGroup` from a `add_equiv` between
`add_comm_group`s. -/
namespace category_theory.iso

/-- Build a `mul_equiv` from an isomorphism in the category `Group`. -/
@[simp] theorem Group_iso_to_add_equiv_apply {X : AddGroup} {Y : AddGroup} (i : X ≅ Y) :
    ∀ (ᾰ : ↥X), coe_fn (AddGroup_iso_to_add_equiv i) ᾰ = coe_fn (hom i) ᾰ :=
  fun (ᾰ : ↥X) => Eq.refl (coe_fn (hom i) ᾰ)

/-- Build a `mul_equiv` from an isomorphism in the category `CommGroup`. -/
@[simp] theorem CommGroup_iso_to_add_equiv_apply {X : AddCommGroup} {Y : AddCommGroup} (i : X ≅ Y) :
    ∀ (ᾰ : ↥X), coe_fn (AddCommGroup_iso_to_add_equiv i) ᾰ = coe_fn (hom i) ᾰ :=
  fun (ᾰ : ↥X) => Eq.refl (coe_fn (hom i) ᾰ)

end category_theory.iso

/-- multiplicative equivalences between `group`s are the same as (isomorphic to) isomorphisms
in `Group` -/
def add_equiv_iso_AddGroup_iso {X : Type u} {Y : Type u} [add_group X] [add_group Y] :
    X ≃+ Y ≅ AddGroup.of X ≅ AddGroup.of Y :=
  category_theory.iso.mk (fun (e : X ≃+ Y) => add_equiv.to_AddGroup_iso e)
    fun (i : AddGroup.of X ≅ AddGroup.of Y) => category_theory.iso.AddGroup_iso_to_add_equiv i

/-- multiplicative equivalences between `comm_group`s are the same as (isomorphic to) isomorphisms
in `CommGroup` -/
def mul_equiv_iso_CommGroup_iso {X : Type u} {Y : Type u} [comm_group X] [comm_group Y] :
    X ≃* Y ≅ CommGroup.of X ≅ CommGroup.of Y :=
  category_theory.iso.mk (fun (e : X ≃* Y) => mul_equiv.to_CommGroup_iso e)
    fun (i : CommGroup.of X ≅ CommGroup.of Y) => category_theory.iso.CommGroup_iso_to_mul_equiv i

namespace category_theory.Aut

/-- The (bundled) group of automorphisms of a type is isomorphic to the (bundled) group
of permutations. -/
def iso_perm {α : Type u} : Group.of (Aut α) ≅ Group.of (equiv.perm α) :=
  iso.mk (monoid_hom.mk (fun (g : ↥(Group.of (Aut α))) => iso.to_equiv g) sorry sorry)
    (monoid_hom.mk (fun (g : ↥(Group.of (equiv.perm α))) => equiv.to_iso g) sorry sorry)

/-- The (unbundled) group of automorphisms of a type is `mul_equiv` to the (unbundled) group
of permutations. -/
def mul_equiv_perm {α : Type u} : Aut α ≃* equiv.perm α := iso.Group_iso_to_mul_equiv iso_perm

end category_theory.Aut

protected instance Group.forget_reflects_isos :
    category_theory.reflects_isomorphisms (category_theory.forget Group) :=
  category_theory.reflects_isomorphisms.mk
    fun (X Y : Group) (f : X ⟶ Y)
      (_x :
      category_theory.is_iso (category_theory.functor.map (category_theory.forget Group) f)) =>
      let i :
        category_theory.functor.obj (category_theory.forget Group) X ≅
          category_theory.functor.obj (category_theory.forget Group) Y :=
        category_theory.as_iso (category_theory.functor.map (category_theory.forget Group) f);
      let e : ↥X ≃* ↥Y :=
        mul_equiv.mk (monoid_hom.to_fun f) (equiv.inv_fun (category_theory.iso.to_equiv i)) sorry
          sorry sorry;
      category_theory.is_iso.mk (category_theory.iso.inv (mul_equiv.to_Group_iso e))

protected instance CommGroup.forget_reflects_isos :
    category_theory.reflects_isomorphisms (category_theory.forget CommGroup) :=
  category_theory.reflects_isomorphisms.mk
    fun (X Y : CommGroup) (f : X ⟶ Y)
      (_x :
      category_theory.is_iso (category_theory.functor.map (category_theory.forget CommGroup) f)) =>
      let i :
        category_theory.functor.obj (category_theory.forget CommGroup) X ≅
          category_theory.functor.obj (category_theory.forget CommGroup) Y :=
        category_theory.as_iso (category_theory.functor.map (category_theory.forget CommGroup) f);
      let e : ↥X ≃* ↥Y :=
        mul_equiv.mk (monoid_hom.to_fun f) (equiv.inv_fun (category_theory.iso.to_equiv i)) sorry
          sorry sorry;
      category_theory.is_iso.mk (category_theory.iso.inv (mul_equiv.to_CommGroup_iso e))

end Mathlib