/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Morenikeji Neri
-/
import algebra.euclidean_domain.instances
import ring_theory.unique_factorization_domain

/-!
# Principal ideal rings and principal ideal domains

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

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

# Main definitions

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

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

# Main results

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

-/
universes u v
variables {R : Type u} {M : Type v}

open set function
open submodule
open_locale classical

section
variables [ring R] [add_comm_group M] [module R M]

/-- An `R`-submodule of `M` is principal if it is generated by one element. -/
@[mk_iff]
class submodule.is_principal (S : submodule R M) : Prop :=
(principal [] : ∃ a, S = span R {a})

instance bot_is_principal : (⊥ : submodule R M).is_principal :=
⟨⟨0, by simp⟩⟩

instance top_is_principal : (⊤ : submodule R R).is_principal :=
⟨⟨1, ideal.span_singleton_one.symm⟩⟩

variables (R)

/-- A ring is a principal ideal ring if all (left) ideals are principal. -/
@[mk_iff] class is_principal_ideal_ring (R : Type u) [ring R] : Prop :=
(principal : ∀ (S : ideal R), S.is_principal)

attribute [instance] is_principal_ideal_ring.principal

@[priority 100]
instance division_ring.is_principal_ideal_ring (K : Type u) [division_ring K] :
  is_principal_ideal_ring K :=
{ principal := λ S, by rcases ideal.eq_bot_or_top S with (rfl|rfl); apply_instance }

end

namespace submodule.is_principal
variables [add_comm_group M]

section ring
variables [ring R] [module R M]

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

lemma span_singleton_generator (S : submodule R M) [S.is_principal] : span R {generator S} = S :=
eq.symm (classical.some_spec (principal S))

lemma _root_.ideal.span_singleton_generator (I : ideal R) [I.is_principal] :
  ideal.span ({generator I} : set R) = I :=
eq.symm (classical.some_spec (principal I))

@[simp] lemma generator_mem (S : submodule R M) [S.is_principal] : generator S ∈ S :=
by { conv_rhs { rw ← span_singleton_generator S }, exact subset_span (mem_singleton _) }

lemma mem_iff_eq_smul_generator (S : submodule R M) [S.is_principal] {x : M} :
  x ∈ S ↔ ∃ s : R, x = s • generator S :=
by simp_rw [@eq_comm _ x, ← mem_span_singleton, span_singleton_generator]

lemma eq_bot_iff_generator_eq_zero (S : submodule R M) [S.is_principal] :
  S = ⊥ ↔ generator S = 0 :=
by rw [← @span_singleton_eq_bot R M, span_singleton_generator]

end ring

section comm_ring
variables [comm_ring R] [module R M]

lemma mem_iff_generator_dvd (S : ideal R) [S.is_principal] {x : R} : x ∈ S ↔ generator S ∣ x :=
(mem_iff_eq_smul_generator S).trans (exists_congr (λ a, by simp only [mul_comm, smul_eq_mul]))

lemma prime_generator_of_is_prime (S : ideal R) [submodule.is_principal S] [is_prime : S.is_prime]
  (ne_bot : S ≠ ⊥) :
  prime (generator S) :=
⟨λ h, ne_bot ((eq_bot_iff_generator_eq_zero S).2 h),
 λ h, is_prime.ne_top (S.eq_top_of_is_unit_mem (generator_mem S) h),
 λ _ _, by simpa only [← mem_iff_generator_dvd S] using is_prime.2⟩

-- Note that the converse may not hold if `ϕ` is not injective.
lemma generator_map_dvd_of_mem {N : submodule R M}
  (ϕ : M →ₗ[R] R) [(N.map ϕ).is_principal] {x : M} (hx : x ∈ N) :
  generator (N.map ϕ) ∣ ϕ x :=
by { rw [← mem_iff_generator_dvd, submodule.mem_map], exact ⟨x, hx, rfl⟩ }

-- Note that the converse may not hold if `ϕ` is not injective.
lemma generator_submodule_image_dvd_of_mem {N O : submodule R M} (hNO : N ≤ O)
  (ϕ : O →ₗ[R] R) [(ϕ.submodule_image N).is_principal] {x : M} (hx : x ∈ N) :
  generator (ϕ.submodule_image N) ∣ ϕ ⟨x, hNO hx⟩ :=
by { rw [← mem_iff_generator_dvd, linear_map.mem_submodule_image_of_le hNO], exact ⟨x, hx, rfl⟩ }

end comm_ring

end submodule.is_principal

namespace is_prime
open submodule.is_principal ideal

-- TODO -- for a non-ID one could perhaps prove that if p < q are prime then q maximal;
-- 0 isn't prime in a non-ID PIR but the Krull dimension is still <= 1.
-- The below result follows from this, but we could also use the below result to
-- prove this (quotient out by p).
lemma to_maximal_ideal [comm_ring R] [is_domain R] [is_principal_ideal_ring R] {S : ideal R}
  [hpi : is_prime S] (hS : S ≠ ⊥) : is_maximal S :=
is_maximal_iff.2 ⟨(ne_top_iff_one S).1 hpi.1, begin
  assume T x hST hxS hxT,
  cases (mem_iff_generator_dvd _).1 (hST $ generator_mem S) with z hz,
  cases hpi.mem_or_mem (show generator T * z ∈ S, from hz ▸ generator_mem S),
  { have hTS : T ≤ S, rwa [← T.span_singleton_generator, ideal.span_le, singleton_subset_iff],
    exact (hxS $ hTS hxT).elim },
  cases (mem_iff_generator_dvd _).1 h with y hy,
  have : generator S ≠ 0 := mt (eq_bot_iff_generator_eq_zero _).2 hS,
  rw [← mul_one (generator S), hy, mul_left_comm, mul_right_inj' this] at hz,
  exact hz.symm ▸ T.mul_mem_right _ (generator_mem T)
end⟩

end is_prime

section
open euclidean_domain
variable [euclidean_domain R]

lemma mod_mem_iff {S : ideal R} {x y : R} (hy : y ∈ S) : x % y ∈ S ↔ x ∈ S :=
⟨λ hxy, div_add_mod x y ▸ S.add_mem (S.mul_mem_right _ hy) hxy,
  λ hx, (mod_eq_sub_mul_div x y).symm ▸ S.sub_mem hx (S.mul_mem_right _ hy)⟩

@[priority 100] -- see Note [lower instance priority]
instance euclidean_domain.to_principal_ideal_domain : is_principal_ideal_ring R :=
{ principal := λ S, by exactI
    ⟨if h : {x : R | x ∈ S ∧ x ≠ 0}.nonempty
    then
    have wf : well_founded (euclidean_domain.r : R → R → Prop) := euclidean_domain.r_well_founded,
    have hmin : well_founded.min wf {x : R | x ∈ S ∧ x ≠ 0} h ∈ S ∧
        well_founded.min wf {x : R | x ∈ S ∧ x ≠ 0} h ≠ 0,
      from well_founded.min_mem wf {x : R | x ∈ S ∧ x ≠ 0} h,
    ⟨well_founded.min wf {x : R | x ∈ S ∧ x ≠ 0} h,
      submodule.ext $ λ x,
      ⟨λ hx, div_add_mod x (well_founded.min wf {x : R | x ∈ S ∧ x ≠ 0} h) ▸
        (ideal.mem_span_singleton.2 $ dvd_add (dvd_mul_right _ _) $
        have (x % (well_founded.min wf {x : R | x ∈ S ∧ x ≠ 0} h) ∉ {x : R | x ∈ S ∧ x ≠ 0}),
          from λ h₁, well_founded.not_lt_min wf _ h h₁ (mod_lt x hmin.2),
        have x % well_founded.min wf {x : R | x ∈ S ∧ x ≠ 0} h = 0,
          by { simp only [not_and_distrib, set.mem_set_of_eq, not_ne_iff] at this,
               cases this, cases this ((mod_mem_iff hmin.1).2 hx), exact this },
        by simp *),
      λ hx, let ⟨y, hy⟩ := ideal.mem_span_singleton.1 hx in hy.symm ▸ S.mul_mem_right _ hmin.1⟩⟩
    else ⟨0, submodule.ext $ λ a,
           by rw [← @submodule.bot_coe R R _ _ _, span_eq, submodule.mem_bot];
      exact ⟨λ haS, by_contradiction $ λ ha0, h ⟨a, ⟨haS, ha0⟩⟩, λ h₁, h₁.symm ▸ S.zero_mem⟩⟩⟩ }
end

lemma is_field.is_principal_ideal_ring
  {R : Type*} [comm_ring R] (h : is_field R) :
  is_principal_ideal_ring R :=
@euclidean_domain.to_principal_ideal_domain R (@field.to_euclidean_domain R h.to_field)

namespace principal_ideal_ring
open is_principal_ideal_ring

@[priority 100] -- see Note [lower instance priority]
instance is_noetherian_ring [ring R] [is_principal_ideal_ring R] :
  is_noetherian_ring R :=
is_noetherian_ring_iff.2 ⟨assume s : ideal R,
begin
  rcases (is_principal_ideal_ring.principal s).principal with ⟨a, rfl⟩,
  rw [← finset.coe_singleton],
  exact ⟨{a}, set_like.coe_injective rfl⟩
end⟩

lemma is_maximal_of_irreducible [comm_ring R] [is_principal_ideal_ring R]
  {p : R} (hp : irreducible p) :
  ideal.is_maximal (span R ({p} : set R)) :=
⟨⟨mt ideal.span_singleton_eq_top.1 hp.1, λ I hI, begin
  rcases principal I with ⟨a, rfl⟩,
  erw ideal.span_singleton_eq_top,
  unfreezingI { rcases ideal.span_singleton_le_span_singleton.1 (le_of_lt hI) with ⟨b, rfl⟩ },
  refine (of_irreducible_mul hp).resolve_right (mt (λ hb, _) (not_le_of_lt hI)),
  erw [ideal.span_singleton_le_span_singleton, is_unit.mul_right_dvd hb]
end⟩⟩

variables [comm_ring R] [is_domain R] [is_principal_ideal_ring R]

lemma irreducible_iff_prime {p : R} : irreducible p ↔ prime p :=
⟨λ hp, (ideal.span_singleton_prime hp.ne_zero).1 $
    (is_maximal_of_irreducible hp).is_prime,
  prime.irreducible⟩

lemma associates_irreducible_iff_prime : ∀{p : associates R}, irreducible p ↔ prime p :=
associates.irreducible_iff_prime_iff.1 (λ _, irreducible_iff_prime)

section
open_locale classical

/-- `factors a` is a multiset of irreducible elements whose product is `a`, up to units -/
noncomputable def factors (a : R) : multiset R :=
if h : a = 0 then ∅ else classical.some (wf_dvd_monoid.exists_factors a h)

lemma factors_spec (a : R) (h : a ≠ 0) :
  (∀b∈factors a, irreducible b) ∧ associated (factors a).prod a :=
begin
  unfold factors, rw [dif_neg h],
  exact classical.some_spec (wf_dvd_monoid.exists_factors a h)
end

lemma ne_zero_of_mem_factors
  {R : Type v} [comm_ring R] [is_domain R] [is_principal_ideal_ring R] {a b : R}
  (ha : a ≠ 0) (hb : b ∈ factors a) : b ≠ 0 := irreducible.ne_zero ((factors_spec a ha).1 b hb)

lemma mem_submonoid_of_factors_subset_of_units_subset (s : submonoid R)
  {a : R} (ha : a ≠ 0) (hfac : ∀ b ∈ factors a, b ∈ s) (hunit : ∀ c : Rˣ, (c : R) ∈ s) :
  a ∈ s :=
begin
  rcases ((factors_spec a ha).2) with ⟨c, hc⟩,
  rw [← hc],
  exact mul_mem (multiset_prod_mem _ hfac) (hunit _)
end

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

/-- A principal ideal domain has unique factorization -/
@[priority 100] -- see Note [lower instance priority]
instance to_unique_factorization_monoid : unique_factorization_monoid R :=
{ irreducible_iff_prime := λ _, principal_ideal_ring.irreducible_iff_prime
  .. (is_noetherian_ring.wf_dvd_monoid : wf_dvd_monoid R) }

end

end principal_ideal_ring

section surjective

open submodule

variables {S N : Type*} [ring R] [add_comm_group M] [add_comm_group N] [ring S]
variables [module R M] [module R N]

lemma submodule.is_principal.of_comap (f : M →ₗ[R] N) (hf : function.surjective f)
  (S : submodule R N) [hI : is_principal (S.comap f)] :
  is_principal S :=
⟨⟨f (is_principal.generator (S.comap f)),
  by rw [← set.image_singleton, ← submodule.map_span,
      is_principal.span_singleton_generator, submodule.map_comap_eq_of_surjective hf]⟩⟩

lemma ideal.is_principal.of_comap (f : R →+* S) (hf : function.surjective f)
  (I : ideal S) [hI : is_principal (I.comap f)] :
  is_principal I :=
⟨⟨f (is_principal.generator (I.comap f)),
  by rw [ideal.submodule_span_eq, ← set.image_singleton, ← ideal.map_span,
    ideal.span_singleton_generator, ideal.map_comap_of_surjective f hf]⟩⟩

/-- The surjective image of a principal ideal ring is again a principal ideal ring. -/
lemma is_principal_ideal_ring.of_surjective [is_principal_ideal_ring R]
  (f : R →+* S) (hf : function.surjective f) :
  is_principal_ideal_ring S :=
⟨λ I, ideal.is_principal.of_comap f hf I⟩

end surjective

section
open ideal
variables [comm_ring R] [is_domain R] [is_principal_ideal_ring R] [gcd_monoid R]

theorem span_gcd (x y : R) : span ({gcd x y} : set R) = span ({x, y} : set R) :=
begin
  obtain ⟨d, hd⟩ := is_principal_ideal_ring.principal (span ({x, y} : set R)),
  rw submodule_span_eq at hd,
  rw [hd],
  suffices : associated d (gcd x y),
  { obtain ⟨D, HD⟩ := this,
    rw ←HD,
    exact (span_singleton_mul_right_unit D.is_unit _) },
  apply associated_of_dvd_dvd,
  { rw dvd_gcd_iff,
    split; rw [←ideal.mem_span_singleton, ←hd, ideal.mem_span_pair],
    { use [1, 0],
      rw [one_mul, zero_mul, add_zero] },
    { use [0, 1],
      rw [one_mul, zero_mul, zero_add] } },
  { obtain ⟨r, s, rfl⟩ : ∃ r s, r * x + s * y = d,
    { rw [←ideal.mem_span_pair, hd, ideal.mem_span_singleton] },
    apply dvd_add; apply dvd_mul_of_dvd_right,
    exacts [gcd_dvd_left x y, gcd_dvd_right x y] },
end

theorem gcd_dvd_iff_exists (a b : R) {z} : gcd a b ∣ z ↔ ∃ x y, z = a * x + b * y :=
by simp_rw [mul_comm a, mul_comm b, @eq_comm _ z, ←ideal.mem_span_pair, ←span_gcd,
  ideal.mem_span_singleton]

/-- **Bézout's lemma** -/
theorem exists_gcd_eq_mul_add_mul (a b : R) : ∃ x y, gcd a b = a * x + b * y :=
by rw [←gcd_dvd_iff_exists]

theorem gcd_is_unit_iff (x y : R) : is_unit (gcd x y) ↔ is_coprime x y :=
by rw [is_coprime, ←ideal.mem_span_pair, ←span_gcd, ←span_singleton_eq_top, eq_top_iff_one]

-- this should be proved for UFDs surely?
theorem is_coprime_of_dvd (x y : R)
  (nonzero : ¬ (x = 0 ∧ y = 0)) (H : ∀ z ∈ nonunits R, z ≠ 0 → z ∣ x → ¬ z ∣ y) :
  is_coprime x y :=
begin
  rw [← gcd_is_unit_iff],
  by_contra h,
  refine H _ h _ (gcd_dvd_left _ _) (gcd_dvd_right _ _),
  rwa [ne, gcd_eq_zero_iff]
end

-- this should be proved for UFDs surely?
theorem dvd_or_coprime (x y : R) (h : irreducible x) : x ∣ y ∨ is_coprime x y :=
begin
  refine or_iff_not_imp_left.2 (λ h', _),
  apply is_coprime_of_dvd,
  { unfreezingI { rintro ⟨rfl, rfl⟩ }, simpa using h },
  { unfreezingI { rintro z nu nz ⟨w, rfl⟩ dy },
    refine h' (dvd_trans _ dy),
    simpa using mul_dvd_mul_left z (is_unit_iff_dvd_one.1 $
      (of_irreducible_mul h).resolve_left nu) }
end

theorem is_coprime_of_irreducible_dvd {x y : R}
  (nonzero : ¬ (x = 0 ∧ y = 0))
  (H : ∀ z : R, irreducible z → z ∣ x → ¬ z ∣ y) :
  is_coprime x y :=
begin
  apply is_coprime_of_dvd x y nonzero,
  intros z znu znz zx zy,
  obtain ⟨i, h1, h2⟩ := wf_dvd_monoid.exists_irreducible_factor znu znz,
  apply H i h1;
  { apply dvd_trans h2, assumption },
end

theorem is_coprime_of_prime_dvd {x y : R}
  (nonzero : ¬ (x = 0 ∧ y = 0))
  (H : ∀ z : R, prime z → z ∣ x → ¬ z ∣ y) :
  is_coprime x y :=
is_coprime_of_irreducible_dvd nonzero $ λ z zi, H z $ gcd_monoid.prime_of_irreducible zi

theorem irreducible.coprime_iff_not_dvd {p n : R} (pp : irreducible p) : is_coprime p n ↔ ¬ p ∣ n :=
begin
  split,
  { intros co H,
    apply pp.not_unit,
    rw is_unit_iff_dvd_one,
    apply is_coprime.dvd_of_dvd_mul_left co,
    rw mul_one n,
    exact H },
  { intro nd,
    apply is_coprime_of_irreducible_dvd,
    { rintro ⟨hp, -⟩,
      exact pp.ne_zero hp },
    rintro z zi zp zn,
    exact nd (((zi.associated_of_dvd pp zp).symm.dvd).trans zn) },
end

theorem prime.coprime_iff_not_dvd {p n : R} (pp : prime p) : is_coprime p n ↔ ¬ p ∣ n :=
pp.irreducible.coprime_iff_not_dvd

theorem irreducible.dvd_iff_not_coprime {p n : R} (hp : irreducible p) : p ∣ n ↔ ¬ is_coprime p n :=
iff_not_comm.2 hp.coprime_iff_not_dvd

theorem irreducible.coprime_pow_of_not_dvd {p a : R} (m : ℕ) (hp : irreducible p) (h : ¬ p ∣ a) :
  is_coprime a (p ^ m) :=
(hp.coprime_iff_not_dvd.2 h).symm.pow_right

theorem irreducible.coprime_or_dvd {p : R} (hp : irreducible p) (i : R) :
  is_coprime p i ∨ p ∣ i :=
(em _).imp_right hp.dvd_iff_not_coprime.2

theorem exists_associated_pow_of_mul_eq_pow' {a b c : R}
  (hab : is_coprime a b) {k : ℕ} (h : a * b = c ^ k) : ∃ d, associated (d ^ k) a :=
exists_associated_pow_of_mul_eq_pow ((gcd_is_unit_iff _ _).mpr hab) h

end

section principal_of_prime

open set ideal

variables (R) [comm_ring R]

/-- `non_principals R` is the set of all ideals of `R` that are not principal ideals. -/
def non_principals := {I : ideal R | ¬ I.is_principal}

lemma non_principals_def {I : ideal R} : I ∈ non_principals R ↔ ¬ I.is_principal :=
iff.rfl

variables {R}
lemma non_principals_eq_empty_iff : non_principals R = ∅ ↔ is_principal_ideal_ring R :=
by simp [set.eq_empty_iff_forall_not_mem, is_principal_ideal_ring_iff, non_principals_def]

/-- Any chain in the set of non-principal ideals has an upper bound which is non-principal.
(Namely, the union of the chain is such an upper bound.)
-/
lemma non_principals_zorn (c : set (ideal R)) (hs : c ⊆ non_principals R) (hchain : is_chain (≤) c)
  {K : ideal R} (hKmem : K ∈ c) :
  ∃ I ∈ non_principals R, ∀ J ∈ c, J ≤ I :=
begin
  refine ⟨Sup c, _, λ J hJ, le_Sup hJ⟩,
  rintro ⟨x, hx⟩,
  have hxmem : x ∈ Sup c := (hx.symm ▸ submodule.mem_span_singleton_self x),
  obtain ⟨J, hJc, hxJ⟩ := (submodule.mem_Sup_of_directed ⟨K, hKmem⟩ hchain.directed_on).1 hxmem,
  have hSupJ : Sup c = J := le_antisymm (by simp [hx, ideal.span_le, hxJ]) (le_Sup hJc),
  specialize hs hJc,
  rw [← hSupJ, hx, non_principals_def] at hs,
  exact hs ⟨⟨x, rfl⟩⟩
end

/-- If all prime ideals in a commutative ring are principal, so are all other ideals. -/
theorem is_principal_ideal_ring.of_prime (H : ∀ (P : ideal R), P.is_prime → P.is_principal) :
  is_principal_ideal_ring R :=
begin
  -- Suppose the set of `non_principals` is not empty.
  rw [← non_principals_eq_empty_iff, set.eq_empty_iff_forall_not_mem],
  intros J hJ,
  -- We will show a maximal element `I ∈ non_principals R` (which exists by Zorn) is prime.
  obtain ⟨I, Ibad, -, Imax⟩ := zorn_nonempty_partial_order₀
    (non_principals R) non_principals_zorn _ hJ,
  have Imax' : ∀ {J}, I < J → J.is_principal,
  { intros J hJ,
    by_contra He,
    exact hJ.ne (Imax _ ((non_principals_def R).2 He) hJ.le).symm },
  by_cases hI1 : I = ⊤,
  { subst hI1,
    exact Ibad top_is_principal },
  -- Let `x y : R` with `x * y ∈ I` and suppose WLOG `y ∉ I`.
  refine Ibad (H I ⟨hI1, λ x y hxy, or_iff_not_imp_right.mpr (λ hy, _)⟩),
  obtain ⟨a, ha⟩ : (I ⊔ span {y}).is_principal :=
    Imax' (left_lt_sup.mpr (mt I.span_singleton_le_iff_mem.mp hy)),
  -- Then `x ∈ I.colon (span {y})`, which is equal to `I` if it's not principal.
  suffices He : ¬ ((I.colon (span {y})).is_principal),
  { rw ← Imax _ ((non_principals_def R).2 He)
        (λ a ha, ideal.mem_colon_singleton.2 (mul_mem_right _ _ ha)),
    exact ideal.mem_colon_singleton.2 hxy },
  -- So suppose for the sake of contradiction that both `I ⊔ span {y}` and `I.colon (span {y})`
  -- are principal.
  rintros ⟨b, hb⟩,
  -- We will show `I` is generated by `a * b`.
  refine (non_principals_def _).1 Ibad ⟨⟨a * b, le_antisymm (λ i hi, _) $
    (span_singleton_mul_span_singleton a b).ge.trans _⟩⟩,
  { have hisup : i ∈ I ⊔ span {y} := ideal.mem_sup_left hi,
    have : y ∈ I ⊔ span {y} := ideal.mem_sup_right (ideal.mem_span_singleton_self y),
    erw [ha, mem_span_singleton'] at hisup this,
    obtain ⟨v, rfl⟩ := this,
    obtain ⟨u, rfl⟩ := hisup,
    have hucolon : u ∈ I.colon (span {v * a}),
    { rw [ideal.mem_colon_singleton, mul_comm v, ← mul_assoc],
      exact mul_mem_right _ _ hi },
    erw [hb, mem_span_singleton'] at hucolon,
    obtain ⟨z, rfl⟩ := hucolon,
    exact mem_span_singleton'.2 ⟨z, by ring⟩ },
  { rw [← ideal.submodule_span_eq, ← ha, ideal.sup_mul, sup_le_iff,
        span_singleton_mul_span_singleton, mul_comm y, ideal.span_singleton_le_iff_mem],
    exact ⟨mul_le_right, ideal.mem_colon_singleton.1 $ hb.symm ▸ ideal.mem_span_singleton_self b⟩ },
end

end principal_of_prime


import tactic.linarith
import .src_17_even_odd_further

open function
open int

namespace mth1001

/-
We define a functions `p₁` and `p₂` so that `p₁ x = x + 3` and  `p₂ x = 2 * x`,
for every `x : ℤ`.
-/
def p₁ (x : ℤ) : ℤ := x + 3
def p₂ (x : ℤ) : ℤ := 2 * x

#eval p₁ 10 -- `p₁ 10` evaluates to `13`.
#eval p₂ 7  -- `p₂ 7` evaluates to `14`.

section surjective

/-
Let `α` and `β` be types. For a function `f : α → β` to be *surjective* means
`∀ b : β, ∃ a : α, f a = b`
-/
#print surjective

-- We'll show that `p₁` is surjective.
lemma sur_p1 : surjective p₁ :=
begin
  intro b, -- Assume `b : ℤ`. We must show `∃ a, p₁ a = b`.
  unfold p₁, -- By definition of `p₁`, the goal is `∃ a, a + 3 = b`.
  use (b-3), -- By `∃` intro. on `b-3`, it suffices to show `(b-3) + 3 = b`.
  linarith, -- This is true by linear arithmetic.
end

-- We'll show `p₂` is not surjective.
example : ¬(surjective p₂) :=
begin
  unfold surjective, -- By definition, we must show `¬(∀ b, ∃ a, p₂ a = b)`.
  push_neg, -- Pushing in the negation, the goal is `∃ b, ∀ a, p₂ a ≠ b`.
  unfold p₂, -- By defition of `p₂`, this is `∃ b, ∀ a, 2 * a ≠ b`.
  use 1, -- By `∃` intro. on `1`, it suffices to show `∀ a, 2 * a ≠ 1`.
  intros a h, -- For a contradiction, assume `a : ℤ` and `h : 2 * a = 1`.
  -- For the remainder of the proof, we'll get a contradiction by
  -- showing `1` is both odd and not odd.
  have h₂ : odd 1,       -- `h₂ : odd 1` as
  { use 0, norm_num, },  -- `1 = 2 * 0 + 1`.
  have h₃ : even 1,      -- `h₃ : even 1` as
  { use a, rw h, },      -- `1 = 2 * a`, using `h`.
  have h₄ : ¬(odd 1),    -- So `h₄ : ¬(odd 1)` as a number is even iff
  { rw ←even_iff_not_odd, exact h₃, }, -- it is not odd.
  exact h₄ h₂, -- We have `⊥` by false intro. on `h₄` and `h₂`.
end

end surjective

section injective

/-
Let `α` and `β` be types. For a function `f : α → β` to be *injective* means
`∀ a₁ a₂ : α, f a₁ = f a₂ → a₁ = a₂`
-/
#print injective

-- We'll show `p₂` is injective.
example : injective p₂ :=
begin
  unfold injective, -- By definions of injective and `p₂`, it suffices to prove
  unfold p₂,        -- `∀ a₁ a₂ : ℤ, 2 * a₁ = 2 * a₂ → a₁ = a₂`.
  intros a₁ a₂ h, -- Assume `a₁ a₂ : ℤ`. Assume `h : 2 * a₁ = 2 * a₂`.
  linarith, -- By linear arithmetic, we have `a₁ = a₂`.
end

-- Now we'll show `p₁` is injective.
lemma inj_p1 : injective p₁ :=
begin
  unfold injective, -- By definions of injective and `p₂`, it suffices to prove
  unfold p₁,        -- `∀ a₁ a₂ : ℤ, a₁ + 3 = a₂ + 3 → a₁ = a₂`.
  intros a₁ a₂ h, -- Assume `a₁ a₂ : ℤ`. Assume `h : a₁ + 3 = a₂ + 3`.
  linarith, -- By linear arithmetic, we have `a₁ = a₂`.
end

end injective

section bijective

-- A function is bijective if it is both injective and surjective.
#print bijective

example : bijective p₁ :=
begin
  unfold bijective, -- It suffices to prove `injective p₁ ∧ sujective p₁`.
  exact and.intro inj_p1 sur_p1, -- This follows by and intro. on `inj_p1` and `sur_p1`.
end

end bijective

end mth1001


/-
Copyright (c) 2020 Jean Lo. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jean Lo
-/
import dynamics.flow

/-!
# ω-limits

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

For a function `ϕ : τ → α → β` where `β` is a topological space, we
define the ω-limit under `ϕ` of a set `s` in `α` with respect to
filter `f` on `τ`: an element `y : β` is in the ω-limit of `s` if the
forward images of `s` intersect arbitrarily small neighbourhoods of
`y` frequently "in the direction of `f`".

In practice `ϕ` is often a continuous monoid-act, but the definition
requires only that `ϕ` has a coercion to the appropriate function
type. In the case where `τ` is `ℕ` or `ℝ` and `f` is `at_top`, we
recover the usual definition of the ω-limit set as the set of all `y`
such that there exist sequences `(tₙ)`, `(xₙ)` such that `ϕ tₙ xₙ ⟶ y`
as `n ⟶ ∞`.

## Notations

The `omega_limit` locale provides the localised notation `ω` for
`omega_limit`, as well as `ω⁺` and `ω⁻` for `omega_limit at_top` and
`omega_limit at_bot` respectively for when the acting monoid is
endowed with an order.
-/

open set function filter
open_locale topology

/-!
### Definition and notation
-/

section omega_limit

variables {τ : Type*} {α : Type*} {β : Type*} {ι : Type*}

/-- The ω-limit of a set `s` under `ϕ` with respect to a filter `f` is
    ⋂ u ∈ f, cl (ϕ u s). -/
def omega_limit [topological_space β] (f : filter τ) (ϕ : τ → α → β) (s : set α) : set β :=
⋂ u ∈ f, closure (image2 ϕ u s)

localized "notation (name := omega_limit) `ω` := omega_limit" in omega_limit

localized "notation (name := omega_limit.at_top) `ω⁺` := omega_limit filter.at_top" in omega_limit
localized "notation (name := omega_limit.at_bot) `ω⁻` := omega_limit filter.at_bot" in omega_limit

variables [topological_space β]
variables (f : filter τ) (ϕ : τ → α → β) (s s₁ s₂: set α)

/-!
### Elementary properties
-/

lemma omega_limit_def : ω f ϕ s = ⋂ u ∈ f, closure (image2 ϕ u s) := rfl

lemma omega_limit_subset_of_tendsto {m : τ → τ} {f₁ f₂ : filter τ} (hf : tendsto m f₁ f₂) :
  ω f₁ (λ t x, ϕ (m t) x) s ⊆ ω f₂ ϕ s :=
begin
  refine Inter₂_mono' (λ u hu, ⟨m ⁻¹' u, tendsto_def.mp hf _ hu, _⟩),
  rw ←image2_image_left,
  exact closure_mono (image2_subset (image_preimage_subset _ _) subset.rfl),
end

lemma omega_limit_mono_left {f₁ f₂ : filter τ} (hf : f₁ ≤ f₂) : ω f₁ ϕ s ⊆ ω f₂ ϕ s :=
omega_limit_subset_of_tendsto ϕ s (tendsto_id'.2 hf)

lemma omega_limit_mono_right {s₁ s₂ : set α} (hs : s₁ ⊆ s₂) : ω f ϕ s₁ ⊆ ω f ϕ s₂ :=
Inter₂_mono $ λ u hu, closure_mono (image2_subset subset.rfl hs)

lemma is_closed_omega_limit : is_closed (ω f ϕ s) :=
is_closed_Inter $ λ u, is_closed_Inter $ λ hu, is_closed_closure

lemma maps_to_omega_limit' {α' β' : Type*} [topological_space β'] {f : filter τ} {ϕ : τ → α → β}
  {ϕ' : τ → α' → β'} {ga : α → α'} {s' : set α'} (hs : maps_to ga s s')
  {gb : β → β'} (hg : ∀ᶠ t in f, eq_on (gb ∘ (ϕ t)) (ϕ' t ∘ ga) s)
  (hgc : continuous gb) :
  maps_to gb (ω f ϕ s) (ω f ϕ' s') :=
begin
  simp only [omega_limit_def, mem_Inter, maps_to],
  intros y hy u hu,
  refine map_mem_closure hgc (hy _ (inter_mem hu hg)) (forall_image2_iff.2 $ λ t ht x hx, _),
  calc gb (ϕ t x) = ϕ' t (ga x) : ht.2 hx
  ... ∈ image2 ϕ' u s' : mem_image2_of_mem ht.1 (hs hx)
end

lemma maps_to_omega_limit {α' β' : Type*} [topological_space β'] {f : filter τ} {ϕ : τ → α → β}
  {ϕ' : τ → α' → β'} {ga : α → α'} {s' : set α'} (hs : maps_to ga s s')
  {gb : β → β'} (hg : ∀ t x, gb (ϕ t x) = ϕ' t (ga x))
  (hgc : continuous gb) :
  maps_to gb (ω f ϕ s) (ω f ϕ' s') :=
maps_to_omega_limit' _ hs (eventually_of_forall $ λ t x hx, hg t x) hgc

lemma omega_limit_image_eq {α' : Type*} (ϕ : τ → α' → β) (f : filter τ) (g : α → α') :
  ω f ϕ (g '' s) = ω f (λ t x, ϕ t (g x)) s :=
by simp only [omega_limit, image2_image_right]

lemma omega_limit_preimage_subset {α' : Type*} (ϕ : τ → α' → β) (s : set α') (f : filter τ)
  (g : α → α') :
  ω f (λ t x, ϕ t (g x)) (g ⁻¹' s) ⊆ ω f ϕ s :=
maps_to_omega_limit _ (maps_to_preimage _ _) (λ t x, rfl) continuous_id

/-!
### Equivalent definitions of the omega limit

The next few lemmas are various versions of the property
characterising ω-limits:
-/

/-- An element `y` is in the ω-limit set of `s` w.r.t. `f` if the
    preimages of an arbitrary neighbourhood of `y` frequently
    (w.r.t. `f`) intersects of `s`. -/
lemma mem_omega_limit_iff_frequently (y : β) : y ∈ ω f ϕ s ↔
  ∀ n ∈ 𝓝 y, ∃ᶠ t in f, (s ∩ ϕ t ⁻¹' n).nonempty :=
begin
  simp_rw [frequently_iff, omega_limit_def, mem_Inter, mem_closure_iff_nhds],
  split,
  { intros h _ hn _ hu,
    rcases h _ hu _ hn with ⟨_, _, _, _, ht, hx, hϕtx⟩,
    exact ⟨_, ht, _, hx, by rwa [mem_preimage, hϕtx]⟩, },
  { intros h _ hu _ hn,
    rcases h _ hn hu with ⟨_, ht, _, hx, hϕtx⟩,
    exact  ⟨_, hϕtx, _, _, ht, hx, rfl⟩ }
end

/-- An element `y` is in the ω-limit set of `s` w.r.t. `f` if the
    forward images of `s` frequently (w.r.t. `f`) intersect arbitrary
    neighbourhoods of `y`. -/
lemma mem_omega_limit_iff_frequently₂ (y : β) : y ∈ ω f ϕ s ↔
  ∀ n ∈ 𝓝 y, ∃ᶠ t in f, (ϕ t '' s ∩ n).nonempty :=
by simp_rw [mem_omega_limit_iff_frequently, image_inter_nonempty_iff]

/-- An element `y` is in the ω-limit of `x` w.r.t. `f` if the forward
    images of `x` frequently (w.r.t. `f`) falls within an arbitrary
    neighbourhood of `y`. -/
lemma mem_omega_limit_singleton_iff_map_cluster_point (x : α) (y : β) :
  y ∈ ω f ϕ {x} ↔ map_cluster_pt y f (λ t, ϕ t x) :=
by simp_rw [mem_omega_limit_iff_frequently, map_cluster_pt_iff, singleton_inter_nonempty,
  mem_preimage]

/-!
### Set operations and omega limits
-/

lemma omega_limit_inter : ω f ϕ (s₁ ∩ s₂) ⊆ ω f ϕ s₁ ∩ ω f ϕ s₂ :=
subset_inter (omega_limit_mono_right _ _ (inter_subset_left _ _))
  (omega_limit_mono_right _ _(inter_subset_right _ _))

lemma omega_limit_Inter (p : ι → set α) : ω f ϕ (⋂ i, p i) ⊆ ⋂ i, ω f ϕ (p i) :=
subset_Inter $ λ i, omega_limit_mono_right _ _ (Inter_subset _ _)

lemma omega_limit_union : ω f ϕ (s₁ ∪ s₂) = ω f ϕ s₁ ∪ ω f ϕ s₂ :=
begin
  ext y, split,
  { simp only [mem_union, mem_omega_limit_iff_frequently, union_inter_distrib_right,
      union_nonempty, frequently_or_distrib],
    contrapose!,
    simp only [not_frequently, not_nonempty_iff_eq_empty, ← subset_empty_iff],
    rintro ⟨⟨n₁, hn₁, h₁⟩, ⟨n₂, hn₂, h₂⟩⟩,
    refine ⟨n₁ ∩ n₂, inter_mem hn₁ hn₂, h₁.mono $ λ t, _, h₂.mono $ λ t, _⟩,
    exacts [subset.trans $ inter_subset_inter_right _ $ preimage_mono $ inter_subset_left _ _,
      subset.trans $ inter_subset_inter_right _ $ preimage_mono $ inter_subset_right _ _] },
  { rintros (hy|hy),
    exacts [omega_limit_mono_right _ _ (subset_union_left  _ _) hy,
      omega_limit_mono_right _ _ (subset_union_right _ _) hy] },
end

lemma omega_limit_Union (p : ι → set α) : (⋃ i, ω f ϕ (p i)) ⊆ ω f ϕ ⋃ i, p i :=
by { rw Union_subset_iff,
     exact λ i, omega_limit_mono_right _ _ (subset_Union _ _)}

/-!
Different expressions for omega limits, useful for rewrites. In
particular, one may restrict the intersection to sets in `f` which are
subsets of some set `v` also in `f`.
-/

lemma omega_limit_eq_Inter : ω f ϕ s = ⋂ u : ↥f.sets, closure (image2 ϕ u s) :=
bInter_eq_Inter _ _

lemma omega_limit_eq_bInter_inter {v : set τ} (hv : v ∈ f) :
  ω f ϕ s = ⋂ u ∈ f, closure (image2 ϕ (u ∩ v) s) :=
subset.antisymm
  (Inter₂_mono' $ λ u hu, ⟨u ∩ v, inter_mem hu hv, subset.rfl⟩)
  (Inter₂_mono $ λ u hu, closure_mono $ image2_subset (inter_subset_left _ _) subset.rfl)

lemma omega_limit_eq_Inter_inter {v : set τ} (hv : v ∈ f) :
  ω f ϕ s = ⋂ (u : ↥f.sets), closure (image2 ϕ (u ∩ v) s) :=
by { rw omega_limit_eq_bInter_inter _ _ _ hv, apply bInter_eq_Inter }

lemma omega_limit_subset_closure_fw_image {u : set τ} (hu : u ∈ f) :
  ω f ϕ s ⊆ closure (image2 ϕ u s) :=
begin
  rw omega_limit_eq_Inter,
  intros _ hx,
  rw mem_Inter at hx,
  exact hx ⟨u, hu⟩,
end

/-!
### `ω-limits and compactness
-/

/-- A set is eventually carried into any open neighbourhood of its ω-limit:
if `c` is a compact set such that `closure {ϕ t x | t ∈ v, x ∈ s} ⊆ c` for some `v ∈ f`
and `n` is an open neighbourhood of `ω f ϕ s`, then for some `u ∈ f` we have
`closure {ϕ t x | t ∈ u, x ∈ s} ⊆ n`. -/
lemma eventually_closure_subset_of_is_compact_absorbing_of_is_open_of_omega_limit_subset'
  {c : set β} (hc₁ : is_compact c) (hc₂ : ∃ v ∈ f, closure (image2 ϕ v s) ⊆ c)
  {n : set β} (hn₁ : is_open n) (hn₂ : ω f ϕ s ⊆ n) :
  ∃ u ∈ f, closure (image2 ϕ u s) ⊆ n :=
begin
  rcases hc₂ with ⟨v, hv₁, hv₂⟩,
  let k := closure (image2 ϕ v s),
  have hk : is_compact (k \ n) :=
    is_compact.diff (is_compact_of_is_closed_subset hc₁ is_closed_closure hv₂) hn₁,
  let j := λ u, (closure (image2 ϕ (u ∩ v) s))ᶜ,
  have hj₁ : ∀ u ∈ f, is_open (j u), from
    λ _ _, (is_open_compl_iff.mpr is_closed_closure),
  have hj₂ : k \ n ⊆ ⋃ u ∈ f, j u, begin
    have : (⋃ u ∈ f, j u) = ⋃ (u : ↥f.sets), j u, from bUnion_eq_Union _ _,
    rw [this, diff_subset_comm, diff_Union],
    rw omega_limit_eq_Inter_inter _ _ _ hv₁ at hn₂,
    simp_rw diff_compl,
    rw ←inter_Inter,
    exact subset.trans (inter_subset_right _ _) hn₂,
  end,
  rcases hk.elim_finite_subcover_image hj₁ hj₂ with ⟨g, hg₁ : ∀ u ∈ g, u ∈ f, hg₂, hg₃⟩,
  let w := (⋂ u ∈ g, u) ∩ v,
  have hw₂ : w ∈ f, by simpa *,
  have hw₃ : k \ n ⊆ (closure (image2 ϕ w s))ᶜ, from
    calc k \ n ⊆ ⋃ u ∈ g, j u : hg₃
    ... ⊆ (closure (image2 ϕ w s))ᶜ :
    begin
      simp only [Union_subset_iff, compl_subset_compl],
      intros u hu,
      mono* using [w],
      exact Inter_subset_of_subset u (Inter_subset_of_subset hu subset.rfl),
    end,
  have hw₄ : kᶜ ⊆ (closure (image2 ϕ w s))ᶜ, begin
    rw compl_subset_compl,
    calc closure (image2 ϕ w s)
        ⊆ _ : closure_mono (image2_subset (inter_subset_right _ _) subset.rfl)
  end,
  have hnc : nᶜ ⊆ (k \ n) ∪ kᶜ, by rw [union_comm, ←inter_subset, diff_eq, inter_comm],
  have hw : closure (image2 ϕ w s) ⊆ n, from
    compl_subset_compl.mp (subset.trans hnc (union_subset hw₃ hw₄)),
  exact ⟨_, hw₂, hw⟩
end

/-- A set is eventually carried into any open neighbourhood of its ω-limit:
if `c` is a compact set such that `closure {ϕ t x | t ∈ v, x ∈ s} ⊆ c` for some `v ∈ f`
and `n` is an open neighbourhood of `ω f ϕ s`, then for some `u ∈ f` we have
`closure {ϕ t x | t ∈ u, x ∈ s} ⊆ n`. -/
lemma eventually_closure_subset_of_is_compact_absorbing_of_is_open_of_omega_limit_subset
  [t2_space β] {c : set β} (hc₁ : is_compact c) (hc₂ : ∀ᶠ t in f, maps_to (ϕ t) s c)
  {n : set β} (hn₁ : is_open n) (hn₂ : ω f ϕ s ⊆ n) :
  ∃ u ∈ f, closure (image2 ϕ u s) ⊆ n :=
eventually_closure_subset_of_is_compact_absorbing_of_is_open_of_omega_limit_subset'
  f ϕ _ hc₁ ⟨_, hc₂, closure_minimal (image2_subset_iff.2 (λ t, id)) hc₁.is_closed⟩ hn₁ hn₂

lemma eventually_maps_to_of_is_compact_absorbing_of_is_open_of_omega_limit_subset
  [t2_space β] {c : set β} (hc₁ : is_compact c) (hc₂ : ∀ᶠ t in f, maps_to (ϕ t) s c)
  {n : set β} (hn₁ : is_open n) (hn₂ : ω f ϕ s ⊆ n) :
  ∀ᶠ t in f, maps_to (ϕ t) s n :=
begin
  rcases eventually_closure_subset_of_is_compact_absorbing_of_is_open_of_omega_limit_subset
    f ϕ s hc₁ hc₂ hn₁ hn₂ with ⟨u, hu_mem, hu⟩,
  refine mem_of_superset hu_mem (λ t ht x hx, _),
  exact hu (subset_closure $ mem_image2_of_mem ht hx)
end

lemma eventually_closure_subset_of_is_open_of_omega_limit_subset [compact_space β]
  {v : set β} (hv₁ : is_open v) (hv₂ : ω f ϕ s ⊆ v) :
  ∃ u ∈ f, closure (image2 ϕ u s) ⊆ v :=
eventually_closure_subset_of_is_compact_absorbing_of_is_open_of_omega_limit_subset'
  _ _ _ is_compact_univ ⟨univ, univ_mem, subset_univ _⟩ hv₁ hv₂

lemma eventually_maps_to_of_is_open_of_omega_limit_subset [compact_space β]
  {v : set β} (hv₁ : is_open v) (hv₂ : ω f ϕ s ⊆ v) :
  ∀ᶠ t in f, maps_to (ϕ t) s v :=
begin
  rcases eventually_closure_subset_of_is_open_of_omega_limit_subset f ϕ s hv₁ hv₂
    with ⟨u, hu_mem, hu⟩,
  refine mem_of_superset hu_mem (λ t ht x hx, _),
  exact hu (subset_closure $ mem_image2_of_mem ht hx)
end

/-- The ω-limit of a nonempty set w.r.t. a nontrivial filter is nonempty. -/
lemma nonempty_omega_limit_of_is_compact_absorbing [ne_bot f] {c : set β} (hc₁ : is_compact c)
  (hc₂ : ∃ v ∈ f, closure (image2 ϕ v s) ⊆ c) (hs : s.nonempty) :
  (ω f ϕ s).nonempty :=
begin
  rcases hc₂ with ⟨v, hv₁, hv₂⟩,
  rw omega_limit_eq_Inter_inter _ _ _ hv₁,
  apply is_compact.nonempty_Inter_of_directed_nonempty_compact_closed,
  { rintro ⟨u₁, hu₁⟩ ⟨u₂, hu₂⟩,
    use ⟨u₁ ∩ u₂, inter_mem hu₁ hu₂⟩, split,
   all_goals { exact closure_mono (image2_subset
        (inter_subset_inter_left _ (by simp)) subset.rfl) }},
  { intro u,
    have hn : (image2 ϕ (u ∩ v) s).nonempty, from
      nonempty.image2 (nonempty_of_mem (inter_mem u.prop hv₁)) hs,
    exact hn.mono subset_closure },
  { intro _,
    apply is_compact_of_is_closed_subset hc₁ is_closed_closure,
    calc _ ⊆ closure (image2 ϕ v s) : closure_mono (image2_subset
                                        (inter_subset_right _ _) subset.rfl)
    ...    ⊆ c : hv₂ },
  { exact λ _, is_closed_closure },
end

lemma nonempty_omega_limit [compact_space β] [ne_bot f] (hs : s.nonempty) :
  (ω f ϕ s).nonempty :=
nonempty_omega_limit_of_is_compact_absorbing _ _ _
  is_compact_univ ⟨univ, univ_mem, subset_univ _⟩ hs

end omega_limit

/-!
### ω-limits of Flows by a Monoid
-/

namespace flow

variables
{τ : Type*} [topological_space τ] [add_monoid τ] [has_continuous_add τ]
{α : Type*} [topological_space α]
(f : filter τ) (ϕ : flow τ α) (s : set α)

open_locale omega_limit

lemma is_invariant_omega_limit (hf : ∀ t, tendsto ((+) t) f f) :
  is_invariant ϕ (ω f ϕ s) :=
begin
  refine λ t, maps_to.mono_right _ (omega_limit_subset_of_tendsto ϕ s (hf t)),
  exact maps_to_omega_limit _ (maps_to_id _) (λ t' x, (ϕ.map_add _ _ _).symm)
    (continuous_const.flow ϕ continuous_id)
end

lemma omega_limit_image_subset (t : τ) (ht : tendsto (+ t) f f) :
  ω f ϕ (ϕ t '' s) ⊆ ω f ϕ s :=
begin
  simp only [omega_limit_image_eq, ← map_add],
  exact omega_limit_subset_of_tendsto ϕ s ht
end

end flow

/-!
### ω-limits of Flows by a Group
-/

namespace flow

variables
{τ : Type*} [topological_space τ] [add_comm_group τ] [topological_add_group τ]
{α : Type*} [topological_space α]
(f : filter τ) (ϕ : flow τ α) (s : set α)

open_locale omega_limit

/-- the ω-limit of a forward image of `s` is the same as the ω-limit of `s`. -/
@[simp] lemma omega_limit_image_eq (hf : ∀ t, tendsto (+ t) f f) (t : τ) :
  ω f ϕ (ϕ t '' s) = ω f ϕ s :=
subset.antisymm (omega_limit_image_subset _ _ _ _ (hf t)) $
calc ω f ϕ s = ω f ϕ (ϕ (-t) '' (ϕ t '' s)) : by simp [image_image, ← map_add]
... ⊆ ω f ϕ (ϕ t '' s) : omega_limit_image_subset _ _ _ _ (hf _)

lemma omega_limit_omega_limit (hf : ∀ t, tendsto ((+) t) f f) :
  ω f ϕ (ω f ϕ s) ⊆ ω f ϕ s :=
begin
  simp only [subset_def, mem_omega_limit_iff_frequently₂, frequently_iff],
  intros _ h,
  rintro n hn u hu,
  rcases mem_nhds_iff.mp hn with ⟨o, ho₁, ho₂, ho₃⟩,
  rcases h o (is_open.mem_nhds ho₂ ho₃) hu with ⟨t, ht₁, ht₂⟩,
  have l₁ : (ω f ϕ s ∩ o).nonempty, from
    ht₂.mono (inter_subset_inter_left _
      ((is_invariant_iff_image _ _).mp (is_invariant_omega_limit _ _ _ hf) _)),
  have l₂ : ((closure (image2 ϕ u s)) ∩ o).nonempty :=
    l₁.mono (λ b hb, ⟨omega_limit_subset_closure_fw_image _ _ _ hu hb.1, hb.2⟩),
  have l₃ : (o ∩ image2 ϕ u s).nonempty,
  begin
    rcases l₂ with ⟨b, hb₁, hb₂⟩,
    exact mem_closure_iff_nhds.mp hb₁ o (is_open.mem_nhds ho₂ hb₂)
  end,
  rcases l₃ with ⟨ϕra, ho, ⟨_, _, hr, ha, hϕra⟩⟩,
  exact ⟨_, hr, ϕra, ⟨_, ha, hϕra⟩, ho₁ ho⟩,
end

end flow


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.tensor_algebra.basic
import ring_theory.graded_algebra.basic

/-!
# Results about the grading structure of the tensor algebra

The main result is `tensor_algebra.graded_algebra`, which says that the tensor algebra is a
ℕ-graded algebra.
-/

namespace tensor_algebra
variables {R M : Type*} [comm_semiring R] [add_comm_monoid M] [module R M]

open_locale direct_sum

variables (R M)

/-- A version of `tensor_algebra.ι` that maps directly into the graded structure. This is
primarily an auxiliary construction used to provide `tensor_algebra.graded_algebra`. -/
def graded_algebra.ι : M →ₗ[R] ⨁ i : ℕ, ↥((ι R : M →ₗ[_] _).range ^ i) :=
direct_sum.lof R ℕ (λ i, ↥((ι R : M →ₗ[_] _).range ^ i)) 1
  ∘ₗ (ι R).cod_restrict _ (λ m, by simpa only [pow_one] using linear_map.mem_range_self _ m)

lemma graded_algebra.ι_apply (m : M) :
  graded_algebra.ι R M m =
    direct_sum.of (λ i, ↥((ι R : M →ₗ[_] _).range ^ i)) 1
      (⟨ι R m, by simpa only [pow_one] using linear_map.mem_range_self _ m⟩) := rfl

variables {R M}

/-- The tensor algebra is graded by the powers of the submodule `(tensor_algebra.ι R).range`. -/
instance graded_algebra :
  graded_algebra ((^) (ι R : M →ₗ[R] tensor_algebra R M).range : ℕ → submodule R _) :=
graded_algebra.of_alg_hom _
  (lift _ $ graded_algebra.ι R M)
  (begin
    ext m,
    dsimp only [linear_map.comp_apply, alg_hom.to_linear_map_apply, alg_hom.comp_apply,
      alg_hom.id_apply],
    rw [lift_ι_apply, graded_algebra.ι_apply, direct_sum.submodule_coe_alg_hom_of, subtype.coe_mk],
  end)
  (λ i x, begin
    cases x with x hx,
    dsimp only [subtype.coe_mk, direct_sum.lof_eq_of],
    apply submodule.pow_induction_on' _
      (λ r, _) (λ x y i hx hy ihx ihy, _) (λ m hm i x hx ih, _) hx,
    { rw [alg_hom.commutes, direct_sum.algebra_map_apply], refl },
    { rw [alg_hom.map_add, ihx, ihy, ←map_add], refl },
    { obtain ⟨_, rfl⟩ := hm,
      rw [alg_hom.map_mul, ih, lift_ι_apply, graded_algebra.ι_apply, direct_sum.of_mul_of],
      exact direct_sum.of_eq_of_graded_monoid_eq (sigma.subtype_ext (add_comm _ _) rfl) }
  end)

end tensor_algebra


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

! This file was ported from Lean 3 source module linear_algebra.matrix.is_diag
! leanprover-community/mathlib commit 55e2dfde0cff928ce5c70926a3f2c7dee3e2dd99
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.Matrix.Symmetric
import Mathbin.LinearAlgebra.Matrix.Orthogonal
import Mathbin.Data.Matrix.Kronecker

/-!
# Diagonal matrices

This file contains the definition and basic results about diagonal matrices.

## Main results

- `matrix.is_diag`: a proposition that states a given square matrix `A` is diagonal.

## Tags

diag, diagonal, matrix
-/

namespace Matrix

variable {α β R n m : Type _}

open Function

open Matrix Kronecker

/-- `A.is_diag` means square matrix `A` is a diagonal matrix. -/
def IsDiag [Zero α] (A : Matrix n n α) : Prop :=
  ∀ ⦃i j⦄, i ≠ j → A i j = 0
#align matrix.is_diag Matrix.IsDiag

@[simp]
theorem isDiag_diagonal [Zero α] [DecidableEq n] (d : n → α) : (diagonal d).IsDiag := fun i j =>
  Matrix.diagonal_apply_ne _
#align matrix.is_diag_diagonal Matrix.isDiag_diagonal

/-- Diagonal matrices are generated by the `matrix.diagonal` of their `matrix.diag`. -/
theorem IsDiag.diagonal_diag [Zero α] [DecidableEq n] {A : Matrix n n α} (h : A.IsDiag) :
    diagonal (diag A) = A :=
  ext fun i j => by
    obtain rfl | hij := Decidable.eq_or_ne i j
    · rw [diagonal_apply_eq, diag]
    · rw [diagonal_apply_ne _ hij, h hij]
#align matrix.is_diag.diagonal_diag Matrix.IsDiag.diagonal_diag

/-- `matrix.is_diag.diagonal_diag` as an iff. -/
theorem isDiag_iff_diagonal_diag [Zero α] [DecidableEq n] (A : Matrix n n α) :
    A.IsDiag ↔ diagonal (diag A) = A :=
  ⟨IsDiag.diagonal_diag, fun hd => hd ▸ isDiag_diagonal (diag A)⟩
#align matrix.is_diag_iff_diagonal_diag Matrix.isDiag_iff_diagonal_diag

/-- Every matrix indexed by a subsingleton is diagonal. -/
theorem isDiag_of_subsingleton [Zero α] [Subsingleton n] (A : Matrix n n α) : A.IsDiag :=
  fun i j h => (h <| Subsingleton.elim i j).elim
#align matrix.is_diag_of_subsingleton Matrix.isDiag_of_subsingleton

/-- Every zero matrix is diagonal. -/
@[simp]
theorem isDiag_zero [Zero α] : (0 : Matrix n n α).IsDiag := fun i j h => rfl
#align matrix.is_diag_zero Matrix.isDiag_zero

/-- Every identity matrix is diagonal. -/
@[simp]
theorem isDiag_one [DecidableEq n] [Zero α] [One α] : (1 : Matrix n n α).IsDiag := fun i j =>
  one_apply_ne
#align matrix.is_diag_one Matrix.isDiag_one

theorem IsDiag.map [Zero α] [Zero β] {A : Matrix n n α} (ha : A.IsDiag) {f : α → β} (hf : f 0 = 0) :
    (A.map f).IsDiag := by
  intro i j h
  simp [ha h, hf]
#align matrix.is_diag.map Matrix.IsDiag.map

theorem IsDiag.neg [AddGroup α] {A : Matrix n n α} (ha : A.IsDiag) : (-A).IsDiag :=
  by
  intro i j h
  simp [ha h]
#align matrix.is_diag.neg Matrix.IsDiag.neg

@[simp]
theorem isDiag_neg_iff [AddGroup α] {A : Matrix n n α} : (-A).IsDiag ↔ A.IsDiag :=
  ⟨fun ha i j h => neg_eq_zero.1 (ha h), IsDiag.neg⟩
#align matrix.is_diag_neg_iff Matrix.isDiag_neg_iff

theorem IsDiag.add [AddZeroClass α] {A B : Matrix n n α} (ha : A.IsDiag) (hb : B.IsDiag) :
    (A + B).IsDiag := by
  intro i j h
  simp [ha h, hb h]
#align matrix.is_diag.add Matrix.IsDiag.add

theorem IsDiag.sub [AddGroup α] {A B : Matrix n n α} (ha : A.IsDiag) (hb : B.IsDiag) :
    (A - B).IsDiag := by
  intro i j h
  simp [ha h, hb h]
#align matrix.is_diag.sub Matrix.IsDiag.sub

theorem IsDiag.smul [Monoid R] [AddMonoid α] [DistribMulAction R α] (k : R) {A : Matrix n n α}
    (ha : A.IsDiag) : (k • A).IsDiag := by
  intro i j h
  simp [ha h]
#align matrix.is_diag.smul Matrix.IsDiag.smul

@[simp]
theorem isDiag_smul_one (n) [Semiring α] [DecidableEq n] (k : α) :
    (k • (1 : Matrix n n α)).IsDiag :=
  isDiag_one.smul k
#align matrix.is_diag_smul_one Matrix.isDiag_smul_one

theorem IsDiag.transpose [Zero α] {A : Matrix n n α} (ha : A.IsDiag) : Aᵀ.IsDiag := fun i j h =>
  ha h.symm
#align matrix.is_diag.transpose Matrix.IsDiag.transpose

@[simp]
theorem isDiag_transpose_iff [Zero α] {A : Matrix n n α} : Aᵀ.IsDiag ↔ A.IsDiag :=
  ⟨IsDiag.transpose, IsDiag.transpose⟩
#align matrix.is_diag_transpose_iff Matrix.isDiag_transpose_iff

theorem IsDiag.conjTranspose [Semiring α] [StarRing α] {A : Matrix n n α} (ha : A.IsDiag) :
    Aᴴ.IsDiag :=
  ha.transpose.map (star_zero _)
#align matrix.is_diag.conj_transpose Matrix.IsDiag.conjTranspose

@[simp]
theorem isDiag_conjTranspose_iff [Semiring α] [StarRing α] {A : Matrix n n α} :
    Aᴴ.IsDiag ↔ A.IsDiag :=
  ⟨fun ha => by
    convert ha.conj_transpose
    simp, IsDiag.conjTranspose⟩
#align matrix.is_diag_conj_transpose_iff Matrix.isDiag_conjTranspose_iff

theorem IsDiag.submatrix [Zero α] {A : Matrix n n α} (ha : A.IsDiag) {f : m → n}
    (hf : Injective f) : (A.submatrix f f).IsDiag := fun i j h => ha (hf.Ne h)
#align matrix.is_diag.submatrix Matrix.IsDiag.submatrix

/-- `(A ⊗ B).is_diag` if both `A` and `B` are diagonal. -/
theorem IsDiag.kronecker [MulZeroClass α] {A : Matrix m m α} {B : Matrix n n α} (hA : A.IsDiag)
    (hB : B.IsDiag) : (A ⊗ₖ B).IsDiag :=
  by
  rintro ⟨a, b⟩ ⟨c, d⟩ h
  simp only [Prod.mk.inj_iff, Ne.def, not_and_or] at h
  cases' h with hac hbd
  · simp [hA hac]
  · simp [hB hbd]
#align matrix.is_diag.kronecker Matrix.IsDiag.kronecker

theorem IsDiag.isSymm [Zero α] {A : Matrix n n α} (h : A.IsDiag) : A.IsSymm :=
  by
  ext (i j)
  by_cases g : i = j; · rw [g]
  simp [h g, h (Ne.symm g)]
#align matrix.is_diag.is_symm Matrix.IsDiag.isSymm

/-- The block matrix `A.from_blocks 0 0 D` is diagonal if `A` and `D` are diagonal. -/
theorem IsDiag.fromBlocks [Zero α] {A : Matrix m m α} {D : Matrix n n α} (ha : A.IsDiag)
    (hd : D.IsDiag) : (A.fromBlocks 0 0 D).IsDiag :=
  by
  rintro (i | i) (j | j) hij
  · exact ha (ne_of_apply_ne _ hij)
  · rfl
  · rfl
  · exact hd (ne_of_apply_ne _ hij)
#align matrix.is_diag.from_blocks Matrix.IsDiag.fromBlocks

/-- This is the `iff` version of `matrix.is_diag.from_blocks`. -/
theorem isDiag_fromBlocks_iff [Zero α] {A : Matrix m m α} {B : Matrix m n α} {C : Matrix n m α}
    {D : Matrix n n α} : (A.fromBlocks B C D).IsDiag ↔ A.IsDiag ∧ B = 0 ∧ C = 0 ∧ D.IsDiag :=
  by
  constructor
  · intro h
    refine' ⟨fun i j hij => _, ext fun i j => _, ext fun i j => _, fun i j hij => _⟩
    · exact h (sum.inl_injective.ne hij)
    · exact h Sum.inl_ne_inr
    · exact h Sum.inr_ne_inl
    · exact h (sum.inr_injective.ne hij)
  · rintro ⟨ha, hb, hc, hd⟩
    convert is_diag.from_blocks ha hd
#align matrix.is_diag_from_blocks_iff Matrix.isDiag_fromBlocks_iff

/-- A symmetric block matrix `A.from_blocks B C D` is diagonal
    if  `A` and `D` are diagonal and `B` is `0`. -/
theorem IsDiag.fromBlocks_of_isSymm [Zero α] {A : Matrix m m α} {C : Matrix n m α}
    {D : Matrix n n α} (h : (A.fromBlocks 0 C D).IsSymm) (ha : A.IsDiag) (hd : D.IsDiag) :
    (A.fromBlocks 0 C D).IsDiag :=
  by
  rw [← (is_symm_from_blocks_iff.1 h).2.1]
  exact ha.from_blocks hd
#align matrix.is_diag.from_blocks_of_is_symm Matrix.IsDiag.fromBlocks_of_isSymm

theorem mul_transpose_self_isDiag_iff_hasOrthogonalRows [Fintype n] [Mul α] [AddCommMonoid α]
    {A : Matrix m n α} : (A ⬝ Aᵀ).IsDiag ↔ A.HasOrthogonalRows :=
  Iff.rfl
#align matrix.mul_transpose_self_is_diag_iff_has_orthogonal_rows Matrix.mul_transpose_self_isDiag_iff_hasOrthogonalRows

theorem transpose_mul_self_isDiag_iff_hasOrthogonalCols [Fintype m] [Mul α] [AddCommMonoid α]
    {A : Matrix m n α} : (Aᵀ ⬝ A).IsDiag ↔ A.HasOrthogonalCols :=
  Iff.rfl
#align matrix.transpose_mul_self_is_diag_iff_has_orthogonal_cols Matrix.transpose_mul_self_isDiag_iff_hasOrthogonalCols

end Matrix


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

! This file was ported from Lean 3 source module data.finite.defs
! leanprover-community/mathlib commit a148d797a1094ab554ad4183a4ad6f130358ef64
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Logic.Equiv.Basic

/-!
# Definition of the `Finite` typeclass

This file defines a typeclass `Finite` saying that `α : Sort*` is finite. A type is `Finite` if it
is equivalent to `Fin n` for some `n`. We also define `Infinite α` as a typeclass equivalent to
`¬Finite α`.

The `Finite` predicate has no computational relevance and, being `Prop`-valued, gets to enjoy proof
irrelevance -- it represents the mere fact that the type is finite.  While the `Finite` class also
represents finiteness of a type, a key difference is that a `Fintype` instance represents finiteness
in a computable way: it gives a concrete algorithm to produce a `Finset` whose elements enumerate
the terms of the given type. As such, one generally relies on congruence lemmas when rewriting
expressions involving `Fintype` instances.

Every `Fintype` instance automatically gives a `Finite` instance, see `Fintype.finite`, but not vice
versa. Every `Fintype` instance should be computable since they are meant for computation. If it's
not possible to write a computable `Fintype` instance, one should prefer writing a `Finite` instance
instead.

## Main definitions

* `Finite α` denotes that `α` is a finite type.
* `Infinite α` denotes that `α` is an infinite type.

## Implementation notes

The definition of `Finite α` is not just `NonEmpty (Fintype α)` since `Fintype` requires
that `α : Type _`, and the definition in this module allows for `α : Sort*`. This means
we can write the instance `Finite.prop`.

## Tags

finite, fintype
-/

universe u v

open Function

variable {α β : Sort _}

/-- A type is `Finite` if it is in bijective correspondence to some
`Fin n`.

While this could be defined as `NonEmpty (Fintype α)`, it is defined
in this way to allow there to be `Finite` instances for propositions.
-/
class inductive Finite (α : Sort _) : Prop
  | intro {n : ℕ} : α ≃ Fin n → Finite _
#align finite Finite

theorem finite_iff_exists_equiv_fin {α : Sort _} : Finite α ↔ ∃ n, Nonempty (α ≃ Fin n) :=
  ⟨fun ⟨e⟩ => ⟨_, ⟨e⟩⟩, fun ⟨_, ⟨e⟩⟩ => ⟨e⟩⟩
#align finite_iff_exists_equiv_fin finite_iff_exists_equiv_fin

theorem Finite.exists_equiv_fin (α : Sort _) [h : Finite α] : ∃ n : ℕ, Nonempty (α ≃ Fin n) :=
  finite_iff_exists_equiv_fin.mp h
#align finite.exists_equiv_fin Finite.exists_equiv_fin

theorem Finite.of_equiv (α : Sort _) [h : Finite α] (f : α ≃ β) : Finite β := by
  cases' h with n e
  exact Finite.intro (f.symm.trans e)
#align finite.of_equiv Finite.of_equiv

theorem Equiv.finite_iff (f : α ≃ β) : Finite α ↔ Finite β :=
  ⟨fun _ => Finite.of_equiv _ f, fun _ => Finite.of_equiv _ f.symm⟩
#align equiv.finite_iff Equiv.finite_iff

theorem Function.Bijective.finite_iff {f : α → β} (h : Bijective f) : Finite α ↔ Finite β :=
  (Equiv.ofBijective f h).finite_iff
#align function.bijective.finite_iff Function.Bijective.finite_iff

theorem Finite.ofBijective [Finite α] {f : α → β} (h : Bijective f) : Finite β :=
  h.finite_iff.mp ‹_›
#align finite.of_bijective Finite.ofBijective

instance [Finite α] : Finite (PLift α) :=
  Finite.of_equiv α Equiv.plift.symm

instance {α : Type v} [Finite α] : Finite (ULift.{u} α) :=
  Finite.of_equiv α Equiv.ulift.symm

/-- A type is said to be infinite if it is not finite. Note that `Infinite α` is equivalent to
`IsEmpty (Fintype α)` or `IsEmpty (Finite α)`. -/
class Infinite (α : Sort _) : Prop where
  /-- assertion that `α` is `¬Finite`-/
  not_finite : ¬Finite α
#align infinite Infinite

@[simp]
theorem not_finite_iff_infinite : ¬Finite α ↔ Infinite α :=
  ⟨Infinite.mk, fun h => h.1⟩
#align not_finite_iff_infinite not_finite_iff_infinite

@[simp]
theorem not_infinite_iff_finite : ¬Infinite α ↔ Finite α :=
  not_finite_iff_infinite.not_right.symm
#align not_infinite_iff_finite not_infinite_iff_finite

theorem Equiv.infinite_iff (e : α ≃ β) : Infinite α ↔ Infinite β :=
  not_finite_iff_infinite.symm.trans <| e.finite_iff.not.trans not_finite_iff_infinite
#align equiv.infinite_iff Equiv.infinite_iff

instance [Infinite α] : Infinite (PLift α) :=
  Equiv.plift.infinite_iff.2 ‹_›

instance {α : Type v} [Infinite α] : Infinite (ULift.{u} α) :=
  Equiv.ulift.infinite_iff.2 ‹_›

theorem finite_or_infinite (α : Sort _) : Finite α ∨ Infinite α :=
  or_iff_not_imp_left.2 not_finite_iff_infinite.1
#align finite_or_infinite finite_or_infinite

/-- `Infinite α` is not `Finite`-/
theorem not_finite (α : Sort _) [Infinite α] [Finite α] : False :=
  @Infinite.not_finite α ‹_› ‹_›
#align not_finite not_finite

protected theorem Finite.false [Infinite α] (_ : Finite α) : False :=
  not_finite α
#align finite.false Finite.false

protected theorem Infinite.false [Finite α] (_ : Infinite α) : False :=
  @Infinite.not_finite α ‹_› ‹_›
#align infinite.false Infinite.false

alias not_infinite_iff_finite ↔ Finite.of_not_infinite Finite.not_infinite
#align finite.of_not_infinite Finite.of_not_infinite
#align finite.not_infinite Finite.not_infinite


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes

! This file was ported from Lean 3 source module group_theory.perm.sign
! leanprover-community/mathlib commit f694c7dead66f5d4c80f446c796a5aad14707f0e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.GroupTheory.Perm.Support
import Mathlib.GroupTheory.OrderOfElement
import Mathlib.Data.Finset.Fin
import Mathlib.Data.Int.Order.Units

/-!
# Sign of a permutation

The main definition of this file is `Equiv.Perm.sign`, associating a `ℤˣ` sign with a
permutation.

This file also contains miscellaneous lemmas about `Equiv.Perm` and `Equiv.swap`, building on top
of those in `Data/Equiv/Basic` and other files in `GroupTheory/Perm/*`.

-/

universe u v

open Equiv Function Fintype Finset

open BigOperators

variable {α : Type u} {β : Type v}

-- An example on how to determine the order of an element of a finite group.
example : orderOf (-1 : ℤˣ) = 2 :=
  orderOf_eq_prime (Int.units_sq _) (by decide)

namespace Equiv.Perm

/-- `modSwap i j` contains permutations up to swapping `i` and `j`.

We use this to partition permutations in `Matrix.det_zero_of_row_eq`, such that each partition
sums up to `0`.
-/
def modSwap [DecidableEq α] (i j : α) : Setoid (Perm α) :=
  ⟨fun σ τ => σ = τ ∨ σ = swap i j * τ, fun σ => Or.inl (refl σ), fun {σ τ} h =>
    Or.casesOn h (fun h => Or.inl h.symm) fun h => Or.inr (by rw [h, swap_mul_self_mul]),
    fun {σ τ υ} hστ hτυ => by
    cases' hστ with hστ hστ <;> cases' hτυ with hτυ hτυ <;> try rw [hστ, hτυ, swap_mul_self_mul] <;>
    simp [hστ, hτυ] -- porting note: should close goals, but doesn't
    . simp [hστ, hτυ]
    . simp [hστ, hτυ]
    . simp [hστ, hτυ]⟩
#align equiv.perm.mod_swap Equiv.Perm.modSwap

noncomputable instance {α : Type _} [Fintype α] [DecidableEq α] (i j : α) :
    DecidableRel (modSwap i j).r :=
  fun _ _ => Or.decidable

theorem perm_inv_on_of_perm_on_finset {s : Finset α} {f : Perm α} (h : ∀ x ∈ s, f x ∈ s) {y : α}
    (hy : y ∈ s) : f⁻¹ y ∈ s := by
  have h0 : ∀ y ∈ s, ∃ (x : _)(hx : x ∈ s), y = (fun i (_ : i ∈ s) => f i) x hx :=
    Finset.surj_on_of_inj_on_of_card_le (fun x hx => (fun i _ => f i) x hx) (fun a ha => h a ha)
      (fun a₁ a₂ ha₁ ha₂ heq => (Equiv.apply_eq_iff_eq f).mp heq) rfl.ge
  obtain ⟨y2, hy2, heq⟩ := h0 y hy
  convert hy2
  rw [heq]
  simp only [inv_apply_self]
#align equiv.perm.perm_inv_on_of_perm_on_finset Equiv.Perm.perm_inv_on_of_perm_on_finset

theorem perm_inv_mapsTo_of_mapsTo (f : Perm α) {s : Set α} [Finite s] (h : Set.MapsTo f s s) :
    Set.MapsTo (f⁻¹ : _) s s := by
  cases nonempty_fintype s;
    exact fun x hx =>
      Set.mem_toFinset.mp <|
        perm_inv_on_of_perm_on_finset
          (fun a ha => Set.mem_toFinset.mpr (h (Set.mem_toFinset.mp ha)))
          (Set.mem_toFinset.mpr hx)
#align equiv.perm.perm_inv_maps_to_of_maps_to Equiv.Perm.perm_inv_mapsTo_of_mapsTo

@[simp]
theorem perm_inv_mapsTo_iff_mapsTo {f : Perm α} {s : Set α} [Finite s] :
    Set.MapsTo (f⁻¹ : _) s s ↔ Set.MapsTo f s s :=
  ⟨perm_inv_mapsTo_of_mapsTo f⁻¹, perm_inv_mapsTo_of_mapsTo f⟩
#align equiv.perm.perm_inv_maps_to_iff_maps_to Equiv.Perm.perm_inv_mapsTo_iff_mapsTo

theorem perm_inv_on_of_perm_on_finite {f : Perm α} {p : α → Prop} [Finite { x // p x }]
    (h : ∀ x, p x → p (f x)) {x : α} (hx : p x) : p (f⁻¹ x) :=
  -- Porting note: relies heavily on the definitions of `Subtype` and `setOf` unfolding to their
  -- underlying predicate.
  have : Finite { x | p x } := ‹_›
  perm_inv_mapsTo_of_mapsTo (s := {x | p x}) f h hx
#align equiv.perm.perm_inv_on_of_perm_on_finite Equiv.Perm.perm_inv_on_of_perm_on_finite

/-- If the permutation `f` maps `{x // p x}` into itself, then this returns the permutation
  on `{x // p x}` induced by `f`. Note that the `h` hypothesis is weaker than for
  `Equiv.Perm.subtypePerm`. -/
abbrev subtypePermOfFintype (f : Perm α) {p : α → Prop} [Fintype { x // p x }]
    (h : ∀ x, p x → p (f x)) : Perm { x // p x } :=
  f.subtypePerm fun x => ⟨h x, fun h₂ => f.inv_apply_self x ▸ perm_inv_on_of_perm_on_finite h h₂⟩
#align equiv.perm.subtype_perm_of_fintype Equiv.Perm.subtypePermOfFintype

@[simp]
theorem subtypePermOfFintype_apply (f : Perm α) {p : α → Prop} [Fintype { x // p x }]
    (h : ∀ x, p x → p (f x)) (x : { x // p x }) : subtypePermOfFintype f h x = ⟨f x, h x x.2⟩ :=
  rfl
#align equiv.perm.subtype_perm_of_fintype_apply Equiv.Perm.subtypePermOfFintype_apply

theorem subtypePermOfFintype_one (p : α → Prop) [Fintype { x // p x }]
    (h : ∀ x, p x → p ((1 : Perm α) x)) : @subtypePermOfFintype α 1 p _ h = 1 :=
  rfl
#align equiv.perm.subtype_perm_of_fintype_one Equiv.Perm.subtypePermOfFintype_one

theorem perm_mapsTo_inl_iff_mapsTo_inr {m n : Type _} [Finite m] [Finite n] (σ : Perm (Sum m n)) :
    Set.MapsTo σ (Set.range Sum.inl) (Set.range Sum.inl) ↔
      Set.MapsTo σ (Set.range Sum.inr) (Set.range Sum.inr) := by
  cases nonempty_fintype m
  cases nonempty_fintype n
  constructor <;>
    ( intro h
      classical
        rw [← perm_inv_mapsTo_iff_mapsTo] at h
        intro x
        cases' hx : σ x with l r)
  · rintro ⟨a, rfl⟩
    obtain ⟨y, hy⟩ := h ⟨l, rfl⟩
    rw [← hx, σ.inv_apply_self] at hy
    exact absurd hy Sum.inl_ne_inr
  · rintro _; exact ⟨r, rfl⟩
  · rintro _; exact ⟨l, rfl⟩
  · rintro ⟨a, rfl⟩
    obtain ⟨y, hy⟩ := h ⟨r, rfl⟩
    rw [← hx, σ.inv_apply_self] at hy
    exact absurd hy Sum.inr_ne_inl
#align equiv.perm.perm_maps_to_inl_iff_maps_to_inr Equiv.Perm.perm_mapsTo_inl_iff_mapsTo_inr

theorem mem_sumCongrHom_range_of_perm_mapsTo_inl {m n : Type _} [Finite m] [Finite n]
    {σ : Perm (Sum m n)} (h : Set.MapsTo σ (Set.range Sum.inl) (Set.range Sum.inl)) :
    σ ∈ (sumCongrHom m n).range := by
  cases nonempty_fintype m
  cases nonempty_fintype n
  classical
    have h1 : ∀ x : Sum m n, (∃ a : m, Sum.inl a = x) → ∃ a : m, Sum.inl a = σ x :=
      by
      rintro x ⟨a, ha⟩
      apply h
      rw [← ha]
      exact ⟨a, rfl⟩
    have h3 : ∀ x : Sum m n, (∃ b : n, Sum.inr b = x) → ∃ b : n, Sum.inr b = σ x :=
      by
      rintro x ⟨b, hb⟩
      apply (perm_mapsTo_inl_iff_mapsTo_inr σ).mp h
      rw [← hb]
      exact ⟨b, rfl⟩
    let σ₁' := subtypePermOfFintype σ h1
    let σ₂' := subtypePermOfFintype σ h3
    let σ₁ := permCongr (Equiv.ofInjective _ Sum.inl_injective).symm σ₁'
    let σ₂ := permCongr (Equiv.ofInjective _ Sum.inr_injective).symm σ₂'
    rw [MonoidHom.mem_range, Prod.exists]
    use σ₁, σ₂
    rw [Perm.sumCongrHom_apply]
    ext x
    cases' x with a b
    · rw [Equiv.sumCongr_apply, Sum.map_inl, permCongr_apply, Equiv.symm_symm,
        apply_ofInjective_symm Sum.inl_injective]
      rw [ofInjective_apply, Subtype.coe_mk, Subtype.coe_mk, subtypePerm_apply]
    · rw [Equiv.sumCongr_apply, Sum.map_inr, permCongr_apply, Equiv.symm_symm,
        apply_ofInjective_symm Sum.inr_injective]
      erw [subtypePerm_apply]
      rw [ofInjective_apply, Subtype.coe_mk, Subtype.coe_mk]
#align equiv.perm.mem_sum_congr_hom_range_of_perm_maps_to_inl Equiv.Perm.mem_sumCongrHom_range_of_perm_mapsTo_inl

nonrec theorem Disjoint.orderOf {σ τ : Perm α} (hστ : Disjoint σ τ) :
    orderOf (σ * τ) = Nat.lcm (orderOf σ) (orderOf τ) :=
  haveI h : ∀ n : ℕ, (σ * τ) ^ n = 1 ↔ σ ^ n = 1 ∧ τ ^ n = 1 := fun n => by
    rw [hστ.commute.mul_pow, Disjoint.mul_eq_one_iff (hστ.pow_disjoint_pow n n)]
  Nat.dvd_antisymm hστ.commute.orderOf_mul_dvd_lcm
    (Nat.lcm_dvd
      (orderOf_dvd_of_pow_eq_one ((h (orderOf (σ * τ))).mp (pow_orderOf_eq_one (σ * τ))).1)
      (orderOf_dvd_of_pow_eq_one ((h (orderOf (σ * τ))).mp (pow_orderOf_eq_one (σ * τ))).2))
#align equiv.perm.disjoint.order_of Equiv.Perm.Disjoint.orderOf

theorem Disjoint.extendDomain {α : Type _} {p : β → Prop} [DecidablePred p] (f : α ≃ Subtype p)
    {σ τ : Perm α} (h : Disjoint σ τ) : Disjoint (σ.extendDomain f) (τ.extendDomain f) := by
  intro b
  by_cases pb : p b
  ·
    refine' (h (f.symm ⟨b, pb⟩)).imp _ _ <;>
      · intro h
        rw [extendDomain_apply_subtype _ _ pb, h, apply_symm_apply, Subtype.coe_mk]
  · left
    rw [extendDomain_apply_not_subtype _ _ pb]
#align equiv.perm.disjoint.extend_domain Equiv.Perm.Disjoint.extendDomain

variable [DecidableEq α]

section Fintype

variable [Fintype α]

theorem support_pow_coprime {σ : Perm α} {n : ℕ} (h : Nat.coprime n (orderOf σ)) :
    (σ ^ n).support = σ.support := by
  obtain ⟨m, hm⟩ := exists_pow_eq_self_of_coprime h
  exact
    le_antisymm (support_pow_le σ n)
      (le_trans (ge_of_eq (congr_arg support hm)) (support_pow_le (σ ^ n) m))
#align equiv.perm.support_pow_coprime Equiv.Perm.support_pow_coprime

end Fintype

/-- Given a list `l : List α` and a permutation `f : Perm α` such that the nonfixed points of `f`
  are in `l`, recursively factors `f` as a product of transpositions. -/
def swapFactorsAux :
    ∀ (l : List α) (f : Perm α),
      (∀ {x}, f x ≠ x → x ∈ l) → { l : List (Perm α) // l.prod = f ∧ ∀ g ∈ l, IsSwap g }
  | [] => fun f h =>
    ⟨[],
      Equiv.ext fun x => by
        rw [List.prod_nil]
        exact (Classical.not_not.1 (mt h (List.not_mem_nil _))).symm,
      by simp⟩
  | x::l => fun f h =>
    if hfx : x = f x then
      swapFactorsAux l f fun {y} hy =>
        List.mem_of_ne_of_mem (fun h : y = x => by simp [h, hfx.symm] at hy) (h hy)
    else
      let m :=
        swapFactorsAux l (swap x (f x) * f) fun {y} hy =>
          have : f y ≠ y ∧ y ≠ x := ne_and_ne_of_swap_mul_apply_ne_self hy
          List.mem_of_ne_of_mem this.2 (h this.1)
      ⟨swap x (f x)::m.1, by
        rw [List.prod_cons, m.2.1, ← mul_assoc, mul_def (swap x (f x)), swap_swap, ← one_def,
          one_mul],
        fun {g} hg => ((List.mem_cons).1 hg).elim (fun h => ⟨x, f x, hfx, h⟩) (m.2.2 _)⟩
#align equiv.perm.swap_factors_aux Equiv.Perm.swapFactorsAux

/-- `swapFactors` represents a permutation as a product of a list of transpositions.
The representation is non unique and depends on the linear order structure.
For types without linear order `truncSwapFactors` can be used. -/
def swapFactors [Fintype α] [LinearOrder α] (f : Perm α) :
    { l : List (Perm α) // l.prod = f ∧ ∀ g ∈ l, IsSwap g } :=
  swapFactorsAux ((@univ α _).sort (· ≤ ·)) f fun {_ _} => (mem_sort _).2 (mem_univ _)
#align equiv.perm.swap_factors Equiv.Perm.swapFactors

/-- This computably represents the fact that any permutation can be represented as the product of
  a list of transpositions. -/
def truncSwapFactors [Fintype α] (f : Perm α) :
    Trunc { l : List (Perm α) // l.prod = f ∧ ∀ g ∈ l, IsSwap g } :=
  Quotient.recOnSubsingleton (@univ α _).1 (fun l h => Trunc.mk (swapFactorsAux l f (h _)))
    (show ∀ x, f x ≠ x → x ∈ (@univ α _).1 from fun _ _ => mem_univ _)
#align equiv.perm.trunc_swap_factors Equiv.Perm.truncSwapFactors

/-- An induction principle for permutations. If `P` holds for the identity permutation, and
is preserved under composition with a non-trivial swap, then `P` holds for all permutations. -/
@[elab_as_elim]
theorem swap_induction_on [Finite α] {P : Perm α → Prop} (f : Perm α) :
    P 1 → (∀ f x y, x ≠ y → P f → P (swap x y * f)) → P f := by
  cases nonempty_fintype α
  cases' (truncSwapFactors f).out with l hl
  induction' l with g l ih generalizing f
  · simp (config := { contextual := true }) only [hl.left.symm, List.prod_nil, forall_true_iff]
  · intro h1 hmul_swap
    rcases hl.2 g (by simp) with ⟨x, y, hxy⟩
    rw [← hl.1, List.prod_cons, hxy.2]
    exact
      hmul_swap _ _ _ hxy.1
        (ih _ ⟨rfl, fun v hv => hl.2 _ (List.mem_cons_of_mem _ hv)⟩ h1 hmul_swap)
#align equiv.perm.swap_induction_on Equiv.Perm.swap_induction_on

theorem closure_isSwap [Finite α] : Subgroup.closure { σ : Perm α | IsSwap σ } = ⊤ := by
  cases nonempty_fintype α
  refine' eq_top_iff.mpr fun x _ => _
  obtain ⟨h1, h2⟩ := Subtype.mem (truncSwapFactors x).out
  rw [← h1]
  exact Subgroup.list_prod_mem _ fun y hy => Subgroup.subset_closure (h2 y hy)
#align equiv.perm.closure_is_swap Equiv.Perm.closure_isSwap

/-- Like `swap_induction_on`, but with the composition on the right of `f`.

An induction principle for permutations. If `P` holds for the identity permutation, and
is preserved under composition with a non-trivial swap, then `P` holds for all permutations. -/
@[elab_as_elim]
theorem swap_induction_on' [Finite α] {P : Perm α → Prop} (f : Perm α) :
    P 1 → (∀ f x y, x ≠ y → P f → P (f * swap x y)) → P f := fun h1 IH =>
  inv_inv f ▸ swap_induction_on f⁻¹ h1 fun f => IH f⁻¹
#align equiv.perm.swap_induction_on' Equiv.Perm.swap_induction_on'

theorem isConj_swap {w x y z : α} (hwx : w ≠ x) (hyz : y ≠ z) : IsConj (swap w x) (swap y z) :=
  isConj_iff.2
    (have h :
      ∀ {y z : α},
        y ≠ z → w ≠ z → swap w y * swap x z * swap w x * (swap w y * swap x z)⁻¹ = swap y z :=
      fun {y z} hyz hwz => by
      rw [mul_inv_rev, swap_inv, swap_inv, mul_assoc (swap w y), mul_assoc (swap w y), ←
        mul_assoc _ (swap x z), swap_mul_swap_mul_swap hwx hwz, ← mul_assoc,
        swap_mul_swap_mul_swap hwz.symm hyz.symm]
    if hwz : w = z then
      have hwy : w ≠ y := by rw [hwz]; exact hyz.symm
      ⟨swap w z * swap x y, by rw [swap_comm y z, h hyz.symm hwy]⟩
    else ⟨swap w y * swap x z, h hyz hwz⟩)
#align equiv.perm.is_conj_swap Equiv.Perm.isConj_swap

/-- set of all pairs (⟨a, b⟩ : Σ a : fin n, fin n) such that b < a -/
def finPairsLT (n : ℕ) : Finset (Σ_ : Fin n, Fin n) :=
  (univ : Finset (Fin n)).sigma fun a => (range a).attachFin fun _ hm => (mem_range.1 hm).trans a.2
#align equiv.perm.fin_pairs_lt Equiv.Perm.finPairsLT

theorem mem_finPairsLT {n : ℕ} {a : Σ_ : Fin n, Fin n} : a ∈ finPairsLT n ↔ a.2 < a.1 := by
  simp only [finPairsLT, Fin.lt_iff_val_lt_val, true_and_iff, mem_attachFin, mem_range, mem_univ,
    mem_sigma]
#align equiv.perm.mem_fin_pairs_lt Equiv.Perm.mem_finPairsLT

/-- `signAux σ` is the sign of a permutation on `Fin n`, defined as the parity of the number of
  pairs `(x₁, x₂)` such that `x₂ < x₁` but `σ x₁ ≤ σ x₂` -/
def signAux {n : ℕ} (a : Perm (Fin n)) : ℤˣ :=
  ∏ x in finPairsLT n, if a x.1 ≤ a x.2 then -1 else 1
#align equiv.perm.sign_aux Equiv.Perm.signAux

@[simp]
theorem signAux_one (n : ℕ) : signAux (1 : Perm (Fin n)) = 1 := by
  unfold signAux
  conv => rhs; rw [← @Finset.prod_const_one ℤˣ _ (finPairsLT n)]
  exact Finset.prod_congr rfl fun a ha => if_neg (mem_finPairsLT.1 ha).not_le
#align equiv.perm.sign_aux_one Equiv.Perm.signAux_one

/-- `signBijAux f ⟨a, b⟩` returns the pair consisting of `f a` and `f b` in decreasing order. -/
def signBijAux {n : ℕ} (f : Perm (Fin n)) (a : Σ_ : Fin n, Fin n) : Σ_ : Fin n, Fin n :=
  if _ : f a.2 < f a.1 then ⟨f a.1, f a.2⟩ else ⟨f a.2, f a.1⟩
#align equiv.perm.sign_bij_aux Equiv.Perm.signBijAux

-- porting note: Lean insists `ha` and `hb` are unused despite obvious uses
set_option linter.unusedVariables false in
theorem signBijAux_inj {n : ℕ} {f : Perm (Fin n)} :
    ∀ a b : Σ_a : Fin n, Fin n,
      a ∈ finPairsLT n → b ∈ finPairsLT n → signBijAux f a = signBijAux f b → a = b :=
  fun ⟨a₁, a₂⟩ ⟨b₁, b₂⟩ ha hb h => by
    unfold signBijAux at h
    rw [mem_finPairsLT] at *
    have : ¬b₁ < b₂ := hb.le.not_lt
    split_ifs at h <;>
    simp_all [(Equiv.injective f).eq_iff, eq_self_iff_true, and_self_iff, heq_iff_eq]
    . exact absurd this (not_le.mpr ha)
    . exact absurd this (not_le.mpr ha)
#align equiv.perm.sign_bij_aux_inj Equiv.Perm.signBijAux_inj

theorem signBijAux_surj {n : ℕ} {f : Perm (Fin n)} :
    ∀ a ∈ finPairsLT n, ∃ (b: Σ (_: Fin n), Fin n) (_H: b ∈ finPairsLT n), a = signBijAux f b :=
  fun ⟨a₁, a₂⟩ ha =>
    if hxa : f⁻¹ a₂ < f⁻¹ a₁ then
      ⟨⟨f⁻¹ a₁, f⁻¹ a₂⟩, mem_finPairsLT.2 hxa, by
        dsimp [signBijAux]
        rw [apply_inv_self, apply_inv_self, if_pos (mem_finPairsLT.1 ha)]⟩
    else
      ⟨⟨f⁻¹ a₂, f⁻¹ a₁⟩,
        mem_finPairsLT.2 <|
          (le_of_not_gt hxa).lt_of_ne fun h => by
            simp [mem_finPairsLT, f⁻¹.injective h, lt_irrefl] at ha, by
              dsimp [signBijAux]
              rw [apply_inv_self, apply_inv_self, if_neg (mem_finPairsLT.1 ha).le.not_lt]⟩
#align equiv.perm.sign_bij_aux_surj Equiv.Perm.signBijAux_surj

theorem signBijAux_mem {n : ℕ} {f : Perm (Fin n)} :
    ∀ a : Σ_ : Fin n, Fin n, a ∈ finPairsLT n → signBijAux f a ∈ finPairsLT n :=
  fun ⟨a₁, a₂⟩ ha => by
    unfold signBijAux
    split_ifs with h
    · exact mem_finPairsLT.2 h
    · exact mem_finPairsLT.2
        ((le_of_not_gt h).lt_of_ne fun h => (mem_finPairsLT.1 ha).ne (f.injective h.symm))
#align equiv.perm.sign_bij_aux_mem Equiv.Perm.signBijAux_mem

@[simp]
theorem signAux_inv {n : ℕ} (f : Perm (Fin n)) : signAux f⁻¹ = signAux f :=
  prod_bij (fun a _ => signBijAux f⁻¹ a) signBijAux_mem
    (fun ⟨a, b⟩ hab =>
      if h : f⁻¹ b < f⁻¹ a then by
        simp_all [signBijAux, dif_pos h, if_neg h.not_le, apply_inv_self, apply_inv_self,
          if_neg (mem_finPairsLT.1 hab).not_le]
        split_ifs with h₁
        . dsimp [finPairsLT] at hab
          simp at hab
          exact absurd h₁ (not_le_of_gt hab)
        . rfl
      else by
        simp_all [signBijAux, if_pos (le_of_not_gt h), dif_neg h, apply_inv_self, apply_inv_self,
          if_pos (mem_finPairsLT.1 hab).le]
        split_ifs with h₁ h₂ h₃
        . rfl
        . exact absurd h (not_le_of_gt h₁)
        . rfl
        . dsimp at *
          dsimp [finPairsLT] at hab
          simp at *
          exact absurd h₃ (asymm_of LT.lt hab))
    signBijAux_inj signBijAux_surj
#align equiv.perm.sign_aux_inv Equiv.Perm.signAux_inv

theorem signAux_mul {n : ℕ} (f g : Perm (Fin n)) : signAux (f * g) = signAux f * signAux g := by
  rw [← signAux_inv g]
  unfold signAux
  rw [← prod_mul_distrib]
  refine'
    prod_bij (fun a _ => signBijAux g a) signBijAux_mem _ signBijAux_inj
    (by simpa using signBijAux_surj)
  rintro ⟨a, b⟩ hab
  dsimp only [signBijAux]
  rw [mul_apply, mul_apply]
  rw [mem_finPairsLT] at hab
  by_cases h : g b < g a
  · rw [dif_pos h]
    simp only [not_le_of_gt hab, mul_one, mul_ite, mul_neg, Perm.inv_apply_self, if_false]
    split_ifs with h₁ h₂ h₃ <;> dsimp at *
    . exact absurd hab (not_lt_of_ge h₂)
    . exact absurd hab (not_lt_of_ge h₃)
  · rw [dif_neg h, inv_apply_self, inv_apply_self, if_pos hab.le]
    by_cases h₁ : f (g b) ≤ f (g a)
    · have : f (g b) ≠ f (g a) :=
        by
        rw [Ne.def, f.injective.eq_iff, g.injective.eq_iff]
        exact ne_of_lt hab
      rw [if_pos h₁, if_neg (h₁.lt_of_ne this).not_le]
      rfl
    · rw [if_neg h₁, if_pos (lt_of_not_ge h₁).le]
      rfl
#align equiv.perm.sign_aux_mul Equiv.Perm.signAux_mul

private theorem signAux_swap_zero_one' (n : ℕ) : signAux (swap (0 : Fin (n + 2)) 1) = -1 :=
  show
    _ =
      ∏ x : Σ_a : Fin (n + 2), Fin (n + 2) in {(⟨1, 0⟩ : Σa : Fin (n + 2), Fin (n + 2))},
        if (Equiv.swap 0 1) x.1 ≤ swap 0 1 x.2 then (-1 : ℤˣ) else 1
    by
    refine'
      Eq.symm
        (prod_subset
          (fun ⟨x₁, x₂⟩ => by
            simp (config := { contextual := true }) [mem_finPairsLT, Fin.one_pos])
          fun a ha₁ ha₂ => _)
    rcases a with ⟨a₁, a₂⟩
    replace ha₁ : a₂ < a₁ := mem_finPairsLT.1 ha₁
    dsimp only
    rcases a₁.zero_le.eq_or_lt with (rfl | H)
    · exact absurd a₂.zero_le ha₁.not_le
    rcases a₂.zero_le.eq_or_lt with (rfl | H')
    · simp only [and_true_iff, eq_self_iff_true, heq_iff_eq, mem_singleton, Sigma.mk.inj_iff] at ha₂
      have : 1 < a₁ := lt_of_le_of_ne (Nat.succ_le_of_lt ha₁)
        (Ne.symm (by intro h; apply ha₂; simp [h]))
      have h01 : Equiv.swap (0 : Fin (n + 2)) 1 0 = 1 := by simp
      -- Porting note: replaced `norm_num` by `rw`
      rw [swap_apply_of_ne_of_ne (ne_of_gt H) ha₂, h01, if_neg this.not_le]
    · have le : 1 ≤ a₂ := Nat.succ_le_of_lt H'
      have lt : 1 < a₁ := le.trans_lt ha₁
      have h01 : Equiv.swap (0 : Fin (n + 2)) 1 1 = 0 := by simp only [swap_apply_right]
      rcases le.eq_or_lt with (rfl | lt')
      · rw [swap_apply_of_ne_of_ne H.ne' lt.ne', h01, if_neg H.not_le]
      · rw [swap_apply_of_ne_of_ne (ne_of_gt H) (ne_of_gt lt),
          swap_apply_of_ne_of_ne (ne_of_gt H') (ne_of_gt lt'), if_neg ha₁.not_le]

private theorem signAux_swap_zero_one {n : ℕ} (hn : 2 ≤ n) :
    signAux (swap (⟨0, lt_of_lt_of_le (by decide) hn⟩ : Fin n) ⟨1, lt_of_lt_of_le (by decide) hn⟩) =
      -1 := by
  rcases n with (_ | _ | n)
  · norm_num at hn
  · norm_num at hn
  · exact signAux_swap_zero_one' n

theorem signAux_swap : ∀ {n : ℕ} {x y : Fin n} (_hxy : x ≠ y), signAux (swap x y) = -1
  | 0, x, y => by intro; exact Fin.elim0 x
  | 1, x, y => by
    dsimp [signAux, swap, swapCore]
    simp only [eq_iff_true_of_subsingleton, not_true, ite_true, le_refl, prod_const,
               IsEmpty.forall_iff]
  | n + 2, x, y => fun hxy => by
    have h2n : 2 ≤ n + 2 := by exact le_add_self
    rw [← isConj_iff_eq, ← signAux_swap_zero_one h2n]
    exact (MonoidHom.mk' signAux signAux_mul).map_isConj
      (isConj_swap hxy (by exact of_decide_eq_true rfl))
#align equiv.perm.sign_aux_swap Equiv.Perm.signAux_swap

/-- When the list `l : List α` contains all nonfixed points of the permutation `f : Perm α`,
  `signAux2 l f` recursively calculates the sign of `f`. -/
def signAux2 : List α → Perm α → ℤˣ
  | [], _ => 1
  | x::l, f => if x = f x then signAux2 l f else -signAux2 l (swap x (f x) * f)
#align equiv.perm.sign_aux2 Equiv.Perm.signAux2

theorem signAux_eq_signAux2 {n : ℕ} :
    ∀ (l : List α) (f : Perm α) (e : α ≃ Fin n) (_h : ∀ x, f x ≠ x → x ∈ l),
      signAux ((e.symm.trans f).trans e) = signAux2 l f
  | [], f, e, h =>
    by
    have : f = 1 := Equiv.ext fun y => Classical.not_not.1 (mt (h y) (List.not_mem_nil _))
    rw [this, one_def, Equiv.trans_refl, Equiv.symm_trans_self, ← one_def, signAux_one, signAux2]
  | x::l, f, e, h => by
    rw [signAux2]
    by_cases hfx : x = f x
    · rw [if_pos hfx]
      exact
        signAux_eq_signAux2 l f _ fun y (hy : f y ≠ y) =>
          List.mem_of_ne_of_mem (fun h : y = x => by simp [h, hfx.symm] at hy) (h y hy)
    · have hy : ∀ y : α, (swap x (f x) * f) y ≠ y → y ∈ l := fun y hy =>
        have : f y ≠ y ∧ y ≠ x := ne_and_ne_of_swap_mul_apply_ne_self hy
        List.mem_of_ne_of_mem this.2 (h _ this.1)
      have :
        (e.symm.trans (swap x (f x) * f)).trans e =
          swap (e x) (e (f x)) * (e.symm.trans f).trans e :=
        by
          ext
          rw [← Equiv.symm_trans_swap_trans, mul_def, Equiv.symm_trans_swap_trans, mul_def]
          repeat (rw [trans_apply])
          simp [swap, swapCore]
          split_ifs <;> rfl
      have hefx : e x ≠ e (f x) := mt e.injective.eq_iff.1 hfx
      rw [if_neg hfx, ← signAux_eq_signAux2 _ _ e hy, this, signAux_mul, signAux_swap hefx]
      simp only [neg_neg, one_mul, neg_mul]
#align equiv.perm.sign_aux_eq_sign_aux2 Equiv.Perm.signAux_eq_signAux2

/-- When the multiset `s : Multiset α` contains all nonfixed points of the permutation `f : Perm α`,
  `signAux2 f _` recursively calculates the sign of `f`. -/
def signAux3 [Fintype α] (f : Perm α) {s : Multiset α} : (∀ x, x ∈ s) → ℤˣ :=
  Quotient.hrecOn s (fun l _ => signAux2 l f)
    (Trunc.induction_on (Fintype.truncEquivFin α) fun e l₁ l₂ h =>
      Function.hfunext (show (∀ x, x ∈ l₁) = ∀ x, x ∈ l₂ by simp only [h.mem_iff]) fun h₁ h₂ _ => by
        rw [← signAux_eq_signAux2 _ _ e fun _ _ => h₁ _,
            ← signAux_eq_signAux2 _ _ e fun _ _ => h₂ _])
#align equiv.perm.sign_aux3 Equiv.Perm.signAux3

theorem signAux3_mul_and_swap [Fintype α] (f g : Perm α) (s : Multiset α) (hs : ∀ x, x ∈ s) :
    signAux3 (f * g) hs = signAux3 f hs * signAux3 g hs ∧
      ∀ x y, x ≠ y → signAux3 (swap x y) hs = -1 := by
  let ⟨l, hl⟩ := Quotient.exists_rep s
  let e := equivFin α
  --clear _let_match
  subst hl
  show
    signAux2 l (f * g) = signAux2 l f * signAux2 l g ∧ ∀ x y, x ≠ y → signAux2 l (swap x y) = -1
  have hfg : (e.symm.trans (f * g)).trans e = (e.symm.trans f).trans e * (e.symm.trans g).trans e :=
    Equiv.ext fun h => by simp [mul_apply]
  constructor
  · rw [← signAux_eq_signAux2 _ _ e fun _ _ => hs _, ←
      signAux_eq_signAux2 _ _ e fun _ _ => hs _, ← signAux_eq_signAux2 _ _ e fun _ _ => hs _,
      hfg, signAux_mul]
  · intro x y hxy
    have hexy : e x ≠ e y := mt e.injective.eq_iff.1 hxy
    rw [← signAux_eq_signAux2 _ _ e fun _ _ => hs _, symm_trans_swap_trans, signAux_swap hexy]
#align equiv.perm.sign_aux3_mul_and_swap Equiv.Perm.signAux3_mul_and_swap

/-- `SignType.sign` of a permutation returns the signature or parity of a permutation, `1` for even
permutations, `-1` for odd permutations. It is the unique surjective group homomorphism from
`Perm α` to the group with two elements.-/
def sign [Fintype α] : Perm α →* ℤˣ :=
  MonoidHom.mk' (fun f => signAux3 f mem_univ) fun f g => (signAux3_mul_and_swap f g _ mem_univ).1
#align equiv.perm.sign Equiv.Perm.sign

section SignType.sign

variable [Fintype α]

--@[simp] porting note: simp can prove
theorem sign_mul (f g : Perm α) : sign (f * g) = sign f * sign g :=
  MonoidHom.map_mul sign f g
#align equiv.perm.sign_mul Equiv.Perm.sign_mul

@[simp]
theorem sign_trans (f g : Perm α) : sign (f.trans g) = sign g * sign f := by
  rw [← mul_def, sign_mul]
#align equiv.perm.sign_trans Equiv.Perm.sign_trans

--@[simp] porting note: simp can prove
theorem sign_one : sign (1 : Perm α) = 1 :=
  MonoidHom.map_one sign
#align equiv.perm.sign_one Equiv.Perm.sign_one

@[simp]
theorem sign_refl : sign (Equiv.refl α) = 1 :=
  MonoidHom.map_one sign
#align equiv.perm.sign_refl Equiv.Perm.sign_refl

--@[simp] porting note: simp can prove
theorem sign_inv (f : Perm α) : sign f⁻¹ = sign f := by
  rw [MonoidHom.map_inv sign f, Int.units_inv_eq_self]
#align equiv.perm.sign_inv Equiv.Perm.sign_inv

@[simp]
theorem sign_symm (e : Perm α) : sign e.symm = sign e :=
  sign_inv e
#align equiv.perm.sign_symm Equiv.Perm.sign_symm

theorem sign_swap {x y : α} (h : x ≠ y) : sign (swap x y) = -1 :=
  (signAux3_mul_and_swap 1 1 _ mem_univ).2 x y h
#align equiv.perm.sign_swap Equiv.Perm.sign_swap

@[simp]
theorem sign_swap' {x y : α} : sign (swap x y) = if x = y then 1 else -1 :=
  if H : x = y then by simp [H, swap_self] else by simp [sign_swap H, H]
#align equiv.perm.sign_swap' Equiv.Perm.sign_swap'

theorem IsSwap.sign_eq {f : Perm α} (h : f.IsSwap) : sign f = -1 :=
  let ⟨_, _, hxy⟩ := h
  hxy.2.symm ▸ sign_swap hxy.1
#align equiv.perm.is_swap.sign_eq Equiv.Perm.IsSwap.sign_eq

theorem signAux3_symm_trans_trans [DecidableEq β] [Fintype β] (f : Perm α) (e : α ≃ β)
    {s : Multiset α} {t : Multiset β} (hs : ∀ x, x ∈ s) (ht : ∀ x, x ∈ t) :
    signAux3 ((e.symm.trans f).trans e) ht = signAux3 f hs := by
  -- porting note: switched from term mode to tactic mode
  induction' t, s using Quotient.inductionOn₂ with t s ht hs
  show signAux2 _ _ = signAux2 _ _
  let n := equivFin β
  rw [← signAux_eq_signAux2 _ _ n fun _ _ => ht _,
    ← signAux_eq_signAux2 _ _ (e.trans n) fun _ _ => hs _]
  exact congr_arg signAux
    (Equiv.ext fun x => by simp [Equiv.coe_trans, apply_eq_iff_eq, symm_trans_apply])
#align equiv.perm.sign_aux3_symm_trans_trans Equiv.Perm.signAux3_symm_trans_trans

@[simp]
theorem sign_symm_trans_trans [DecidableEq β] [Fintype β] (f : Perm α) (e : α ≃ β) :
    sign ((e.symm.trans f).trans e) = sign f :=
  signAux3_symm_trans_trans f e mem_univ mem_univ
#align equiv.perm.sign_symm_trans_trans Equiv.Perm.sign_symm_trans_trans

@[simp]
theorem sign_trans_trans_symm [DecidableEq β] [Fintype β] (f : Perm β) (e : α ≃ β) :
    sign ((e.trans f).trans e.symm) = sign f :=
  sign_symm_trans_trans f e.symm
#align equiv.perm.sign_trans_trans_symm Equiv.Perm.sign_trans_trans_symm

variable (α)

theorem sign_surjective [Nontrivial α] : Function.Surjective (sign : Perm α → ℤˣ) := fun a =>
  (Int.units_eq_one_or a).elim (fun h => ⟨1, by simp [h]⟩) fun h =>
    let ⟨x, y, hxy⟩ := exists_pair_ne α
    ⟨swap x y, by rw [sign_swap hxy, h]⟩
#align equiv.perm.sign_surjective Equiv.Perm.sign_surjective

variable {α}

theorem eq_sign_of_surjective_hom {s : Perm α →* ℤˣ} (hs : Surjective s) : s = sign :=
  have : ∀ {f}, IsSwap f → s f = -1 := fun {f} ⟨x, y, hxy, hxy'⟩ =>
    hxy'.symm ▸
      by_contradiction fun h =>
        by
        have : ∀ f, IsSwap f → s f = 1 := fun f ⟨a, b, hab, hab'⟩ =>
          by
          rw [← isConj_iff_eq, ← Or.resolve_right (Int.units_eq_one_or _) h, hab']
          exact s.map_isConj (isConj_swap hab hxy)
        let ⟨g, hg⟩ := hs (-1)
        let ⟨l, hl⟩ := (truncSwapFactors g).out
        have : ∀ a ∈ l.map s, a = (1 : ℤˣ) := fun a ha =>
          let ⟨g, hg⟩ := List.mem_map.1 ha
          hg.2 ▸ this _ (hl.2 _ hg.1)
        have : s l.prod = 1 := by
          rw [← l.prod_hom s, List.eq_replicate_length.2 this, List.prod_replicate, one_pow]
        rw [hl.1, hg] at this
        exact absurd this (by simp_all)
  MonoidHom.ext fun f => by
    let ⟨l, hl₁, hl₂⟩ := (truncSwapFactors f).out
    have hsl : ∀ a ∈ l.map s, a = (-1 : ℤˣ) := fun a ha =>
      let ⟨g, hg⟩ := List.mem_map.1 ha
      hg.2 ▸ this (hl₂ _ hg.1)
    rw [← hl₁, ← l.prod_hom s, List.eq_replicate_length.2 hsl, List.length_map, List.prod_replicate,
      sign_prod_list_swap hl₂]
#align equiv.perm.eq_sign_of_surjective_hom Equiv.Perm.eq_sign_of_surjective_hom

theorem sign_subtypePerm (f : Perm α) {p : α → Prop} [DecidablePred p] (h₁ : ∀ x, p x ↔ p (f x))
    (h₂ : ∀ x, f x ≠ x → p x) : sign (subtypePerm f h₁) = sign f := by
  let l := (truncSwapFactors (subtypePerm f h₁)).out
  have hl' : ∀ g' ∈ l.1.map ofSubtype, IsSwap g' := fun g' hg' =>
    let ⟨g, hg⟩ := List.mem_map.1 hg'
    hg.2 ▸ (l.2.2 _ hg.1).of_subtype_isSwap
  have hl'₂ : (l.1.map ofSubtype).prod = f := by
    rw [l.1.prod_hom ofSubtype, l.2.1, ofSubtype_subtypePerm _ h₂]
  conv =>
    congr
    rw [← l.2.1]
    skip
  simp_rw [← hl'₂]
  rw [sign_prod_list_swap l.2.2, sign_prod_list_swap hl', List.length_map]
#align equiv.perm.sign_subtype_perm Equiv.Perm.sign_subtypePerm

theorem sign_eq_sign_of_equiv [DecidableEq β] [Fintype β] (f : Perm α) (g : Perm β) (e : α ≃ β)
    (h : ∀ x, e (f x) = g (e x)) : sign f = sign g := by
  have hg : g = (e.symm.trans f).trans e := Equiv.ext <| by simp [h]
  rw [hg, sign_symm_trans_trans]
#align equiv.perm.sign_eq_sign_of_equiv Equiv.Perm.sign_eq_sign_of_equiv

theorem sign_bij [DecidableEq β] [Fintype β] {f : Perm α} {g : Perm β} (i : ∀ x : α, f x ≠ x → β)
    (h : ∀ x hx hx', i (f x) hx' = g (i x hx)) (hi : ∀ x₁ x₂ hx₁ hx₂, i x₁ hx₁ = i x₂ hx₂ → x₁ = x₂)
    (hg : ∀ y, g y ≠ y → ∃ x hx, i x hx = y) : sign f = sign g :=
  calc
    sign f = sign (subtypePerm f <| by simp : Perm { x // f x ≠ x }) :=
      (sign_subtypePerm _ _ fun _ => id).symm
    _ = sign (subtypePerm g <| by simp : Perm { x // g x ≠ x }) :=
      sign_eq_sign_of_equiv _ _
        (Equiv.ofBijective
          (fun x : { x // f x ≠ x } =>
            (⟨i x.1 x.2, by
                have : f (f x) ≠ f x := mt (fun h => f.injective h) x.2
                rw [← h _ x.2 this]
                exact mt (hi _ _ this x.2) x.2⟩ :
              { y // g y ≠ y }))
          ⟨fun ⟨x, hx⟩ ⟨y, hy⟩ h => Subtype.eq (hi _ _ _ _ (Subtype.mk.inj h)), fun ⟨y, hy⟩ =>
            let ⟨x, hfx, hx⟩ := hg y hy
            ⟨⟨x, hfx⟩, Subtype.eq hx⟩⟩)
        fun ⟨x, _⟩ => Subtype.eq (h x _ _)
    _ = sign g := sign_subtypePerm _ _ fun _ => id

#align equiv.perm.sign_bij Equiv.Perm.sign_bij

/-- If we apply `prod_extendRight a (σ a)` for all `a : α` in turn,
we get `prod_congrRight σ`. -/
theorem prod_prodExtendRight {α : Type _} [DecidableEq α] (σ : α → Perm β) {l : List α}
    (hl : l.Nodup) (mem_l : ∀ a, a ∈ l) :
    (l.map fun a => prodExtendRight a (σ a)).prod = prodCongrRight σ := by
  ext ⟨a, b⟩ : 1
  -- We'll use induction on the list of elements,
  -- but we have to keep track of whether we already passed `a` in the list.
  suffices
    a ∈ l ∧ (l.map fun a => prodExtendRight a (σ a)).prod (a, b) = (a, σ a b) ∨
      a ∉ l ∧ (l.map fun a => prodExtendRight a (σ a)).prod (a, b) = (a, b)
    by
    obtain ⟨_, prod_eq⟩ := Or.resolve_right this (not_and.mpr fun h _ => h (mem_l a))
    rw [prod_eq, prodCongrRight_apply]
  clear mem_l
  induction' l with a' l ih
  · refine' Or.inr ⟨List.not_mem_nil _, _⟩
    rw [List.map_nil, List.prod_nil, one_apply]
  rw [List.map_cons, List.prod_cons, mul_apply]
  rcases ih (List.nodup_cons.mp hl).2 with (⟨mem_l, prod_eq⟩ | ⟨not_mem_l, prod_eq⟩) <;>
    rw [prod_eq]
  · refine' Or.inl ⟨List.mem_cons_of_mem _ mem_l, _⟩
    rw [prodExtendRight_apply_ne _ fun h : a = a' => (List.nodup_cons.mp hl).1 (h ▸ mem_l)]
  by_cases ha' : a = a'
  · rw [← ha'] at *
    refine' Or.inl ⟨l.mem_cons_self a, _⟩
    rw [prodExtendRight_apply_eq]
  · refine' Or.inr ⟨fun h => not_or_of_not ha' not_mem_l ((List.mem_cons).mp h), _⟩
    rw [prodExtendRight_apply_ne _ ha']
#align equiv.perm.prod_prod_extend_right Equiv.Perm.prod_prodExtendRight

section congr

variable [DecidableEq β] [Fintype β]

@[simp]
theorem sign_prodExtendRight (a : α) (σ : Perm β) : sign (prodExtendRight a σ) = sign σ :=
  sign_bij (fun (ab : α × β) _ => ab.snd)
    (fun ⟨a', b⟩ hab _ => by simp [eq_of_prodExtendRight_ne hab])
    (fun ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ hab₁ hab₂ h => by
      simpa [eq_of_prodExtendRight_ne hab₁, eq_of_prodExtendRight_ne hab₂] using h)
    fun y hy => ⟨(a, y), by simpa, by simp⟩
#align equiv.perm.sign_prod_extend_right Equiv.Perm.sign_prodExtendRight

theorem sign_prodCongrRight (σ : α → Perm β) : sign (prodCongrRight σ) = ∏ k, sign (σ k) := by
  obtain ⟨l, hl, mem_l⟩ := Finite.exists_univ_list α
  have l_to_finset : l.toFinset = Finset.univ :=
    by
    apply eq_top_iff.mpr
    intro b _
    exact List.mem_toFinset.mpr (mem_l b)
  rw [← prod_prodExtendRight σ hl mem_l, sign.map_list_prod, List.map_map, ← l_to_finset,
    List.prod_toFinset _ hl]
  simp_rw [← fun a => sign_prodExtendRight a (σ a), Function.comp]
#align equiv.perm.sign_prod_congr_right Equiv.Perm.sign_prodCongrRight

theorem sign_prodCongrLeft (σ : α → Perm β) : sign (prodCongrLeft σ) = ∏ k, sign (σ k) := by
  refine' (sign_eq_sign_of_equiv _ _ (prodComm β α) _).trans (sign_prodCongrRight σ)
  rintro ⟨b, α⟩
  rfl
#align equiv.perm.sign_prod_congr_left Equiv.Perm.sign_prodCongrLeft

@[simp]
theorem sign_permCongr (e : α ≃ β) (p : Perm α) : sign (e.permCongr p) = sign p :=
  sign_eq_sign_of_equiv _ _ e.symm (by simp)
#align equiv.perm.sign_perm_congr Equiv.Perm.sign_permCongr

@[simp]
theorem sign_sumCongr (σa : Perm α) (σb : Perm β) : sign (sumCongr σa σb) = sign σa * sign σb := by
  suffices sign (sumCongr σa (1 : Perm β)) = sign σa ∧ sign (sumCongr (1 : Perm α) σb) = sign σb
    by rw [← this.1, ← this.2, ← sign_mul, sumCongr_mul, one_mul, mul_one]
  constructor
  · refine' σa.swap_induction_on ?_ fun σa' a₁ a₂ ha ih => ?_
    · simp
    · rw [← one_mul (1 : Perm β), ← sumCongr_mul, sign_mul, sign_mul, ih, sumCongr_swap_one,
        sign_swap ha, sign_swap (Sum.inl_injective.ne_iff.mpr ha)]
  · refine' σb.swap_induction_on ?_ fun σb' b₁ b₂ hb ih => ?_
    · simp
    · rw [← one_mul (1 : Perm α), ← sumCongr_mul, sign_mul, sign_mul, ih, sumCongr_one_swap,
        sign_swap hb, sign_swap (Sum.inr_injective.ne_iff.mpr hb)]
#align equiv.perm.sign_sum_congr Equiv.Perm.sign_sumCongr

@[simp]
theorem sign_subtypeCongr {p : α → Prop} [DecidablePred p] (ep : Perm { a // p a })
    (en : Perm { a // ¬p a }) : sign (ep.subtypeCongr en) = sign ep * sign en := by
  simp [subtypeCongr]
#align equiv.perm.sign_subtype_congr Equiv.Perm.sign_subtypeCongr

@[simp]
theorem sign_extendDomain (e : Perm α) {p : β → Prop} [DecidablePred p] (f : α ≃ Subtype p) :
    Equiv.Perm.sign (e.extendDomain f) = Equiv.Perm.sign e := by
  simp only [Equiv.Perm.extendDomain, sign_subtypeCongr, sign_permCongr, sign_refl, mul_one]
#align equiv.perm.sign_extend_domain Equiv.Perm.sign_extendDomain

@[simp]
theorem sign_ofSubtype {p : α → Prop} [DecidablePred p] (f : Equiv.Perm (Subtype p)) :
    sign (ofSubtype f) = sign f :=
  sign_extendDomain f (Equiv.refl (Subtype p))
#align equiv.perm.sign_of_subtype Equiv.Perm.sign_ofSubtype

end congr

end SignType.sign

end Equiv.Perm