/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.measure_theory.integration
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Measures on Groups

We develop some properties of measures on (topological) groups

* We define properties on measures: left and right invariant measures.
* We define the measure `μ.inv : A ↦ μ(A⁻¹)` and show that it is right invariant iff
  `μ` is left invariant.
-/

namespace measure_theory

/-- A measure `μ` on a topological group is left invariant
  if the measure of left translations of a set are equal to the measure of the set itself.
  To left translate sets we use preimage under left multiplication,
  since preimages are nicer to work with than images. -/
def is_add_left_invariant {G : Type u_1} [measurable_space G] [Add G] (μ : set G → ennreal) :=
  ∀ (g : G) {A : set G} (h : is_measurable A), μ ((fun (h : G) => g + h) ⁻¹' A) = μ A

/-- A measure `μ` on a topological group is right invariant
  if the measure of right translations of a set are equal to the measure of the set itself.
  To right translate sets we use preimage under right multiplication,
  since preimages are nicer to work with than images. -/
def is_add_right_invariant {G : Type u_1} [measurable_space G] [Add G] (μ : set G → ennreal) :=
  ∀ (g : G) {A : set G} (h : is_measurable A), μ ((fun (h : G) => h + g) ⁻¹' A) = μ A

namespace measure

theorem map_mul_left_eq_self {G : Type u_1} [measurable_space G] [topological_space G] [Mul G] [has_continuous_mul G] [borel_space G] {μ : measure G} : (∀ (g : G), coe_fn (map (Mul.mul g)) μ = μ) ↔ is_mul_left_invariant ⇑μ := sorry

theorem map_mul_right_eq_self {G : Type u_1} [measurable_space G] [topological_space G] [Mul G] [has_continuous_mul G] [borel_space G] {μ : measure G} : (∀ (g : G), coe_fn (map fun (h : G) => h * g) μ = μ) ↔ is_mul_right_invariant ⇑μ := sorry

/-- The measure `A ↦ μ (A⁻¹)`, where `A⁻¹` is the pointwise inverse of `A`. -/
protected def neg {G : Type u_1} [measurable_space G] [Neg G] (μ : measure G) : measure G :=
  coe_fn (map Neg.neg) μ

theorem neg_apply {G : Type u_1} [measurable_space G] [add_group G] [topological_space G] [topological_add_group G] [borel_space G] (μ : measure G) {s : set G} (hs : is_measurable s) : coe_fn (measure.neg μ) s = coe_fn μ (-s) := sorry

@[simp] protected theorem neg_neg {G : Type u_1} [measurable_space G] [add_group G] [topological_space G] [topological_add_group G] [borel_space G] (μ : measure G) : measure.neg (measure.neg μ) = μ := sorry

theorem regular.neg {G : Type u_1} [measurable_space G] [add_group G] [topological_space G] [topological_add_group G] [borel_space G] {μ : measure G} [t2_space G] (hμ : regular μ) : regular (measure.neg μ) :=
  regular.map hμ (homeomorph.neg G)

end measure

@[simp] theorem regular_inv_iff {G : Type u_1} [measurable_space G] [group G] [topological_space G] [topological_group G] [borel_space G] {μ : measure G} [t2_space G] : measure.regular (measure.inv μ) ↔ measure.regular μ := sorry

theorem is_add_left_invariant.neg {G : Type u_1} [measurable_space G] [add_group G] [topological_space G] [topological_add_group G] [borel_space G] {μ : measure G} (h : is_add_left_invariant ⇑μ) : is_add_right_invariant ⇑(measure.neg μ) := sorry

theorem is_mul_right_invariant.inv {G : Type u_1} [measurable_space G] [group G] [topological_space G] [topological_group G] [borel_space G] {μ : measure G} (h : is_mul_right_invariant ⇑μ) : is_mul_left_invariant ⇑(measure.inv μ) := sorry

@[simp] theorem is_mul_right_invariant_inv {G : Type u_1} [measurable_space G] [group G] [topological_space G] [topological_group G] [borel_space G] {μ : measure G} : is_mul_right_invariant ⇑(measure.inv μ) ↔ is_mul_left_invariant ⇑μ := sorry

@[simp] theorem is_add_left_invariant_neg {G : Type u_1} [measurable_space G] [add_group G] [topological_space G] [topological_add_group G] [borel_space G] {μ : measure G} : is_add_left_invariant ⇑(measure.neg μ) ↔ is_add_right_invariant ⇑μ := sorry

/-! Properties of regular left invariant measures -/

theorem is_mul_left_invariant.null_iff_empty {G : Type u_1} [measurable_space G] [topological_space G] [borel_space G] {μ : measure G} [group G] [topological_group G] (hμ : measure.regular μ) (h2μ : is_mul_left_invariant ⇑μ) (h3μ : μ ≠ 0) {s : set G} (hs : is_open s) : coe_fn μ s = 0 ↔ s = ∅ := sorry

theorem is_mul_left_invariant.null_iff {G : Type u_1} [measurable_space G] [topological_space G] [borel_space G] {μ : measure G} [group G] [topological_group G] (hμ : measure.regular μ) (h2μ : is_mul_left_invariant ⇑μ) {s : set G} (hs : is_open s) : coe_fn μ s = 0 ↔ s = ∅ ∨ μ = 0 := sorry

theorem is_mul_left_invariant.measure_ne_zero_iff_nonempty {G : Type u_1} [measurable_space G] [topological_space G] [borel_space G] {μ : measure G} [group G] [topological_group G] (hμ : measure.regular μ) (h2μ : is_mul_left_invariant ⇑μ) (h3μ : μ ≠ 0) {s : set G} (hs : is_open s) : coe_fn μ s ≠ 0 ↔ set.nonempty s := sorry

/-- For nonzero regular left invariant measures, the integral of a continuous nonnegative function
  `f` is 0 iff `f` is 0. -/
-- @[to_additive] (fails for now)

theorem lintegral_eq_zero_of_is_mul_left_invariant {G : Type u_1} [measurable_space G] [topological_space G] [borel_space G] {μ : measure G} [group G] [topological_group G] (hμ : measure.regular μ) (h2μ : is_mul_left_invariant ⇑μ) (h3μ : μ ≠ 0) {f : G → ennreal} (hf : continuous f) : (lintegral μ fun (x : G) => f x) = 0 ↔ f = 0 := sorry


-- 5.8 Exercises
-- #2
-- Use tactic combinators to obtain a one line proof of the following:

example (p q r : Prop) (hp : p) :
(p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) :=
begin
  split, left, assumption,
  split, right, left, assumption,
  right, right, assumption,
end

example (p q r : Prop) (hp : p) :
(p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) :=
by {split, left, assumption, split; {right, {left, assumption} <|> {right, assumption}}}


/-
Copyright (c) 2015 Nathaniel Thomas. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nathaniel Thomas, Jeremy Avigad, Johannes Hölzl, Mario Carneiro
-/
import algebra.big_operators.basic
import algebra.group.hom
import group_theory.group_action.group
import algebra.smul_with_zero

/-!
# Modules over a ring

In this file we define

* `module R M` : an additive commutative monoid `M` is a `module` over a
  `semiring R` if for `r : R` and `x : M` their "scalar multiplication `r • x : M` is defined, and
  the operation `•` satisfies some natural associativity and distributivity axioms similar to those
  on a ring.

  ## Implementation notes
  In typical mathematical usage, our definition of `module` corresponds to "semimodule", and the
  word "module" is reserved for `module R M` where `R` is a `ring` and `M` an `add_comm_group`.
  If `R` is a `field` and `M` an `add_comm_group`, `M` would be called an `R`-vector space.
  Since those assumptions can be made by changing the typeclasses applied to `R` and `M`,
  without changing the axioms in `module`, mathlib calls everything a `module`.

  In older versions of mathlib, we had separate `semimodule` and `vector_space` abbreviations.
  This caused inference issues in some cases, while not providing any real advantages, so we decided
  to use a canonical `module` typeclass throughout.

## Tags

semimodule, module, vector space
-/

open function
open_locale big_operators

universes u u' v w x y z
variables {R : Type u} {k : Type u'} {S : Type v} {M : Type w} {M₂ : Type x} {M₃ : Type y}
  {ι : Type z}

/-- A module is a generalization of vector spaces to a scalar semiring.
  It consists of a scalar semiring `R` and an additive monoid of "vectors" `M`,
  connected by a "scalar multiplication" operation `r • x : M`
  (where `r : R` and `x : M`) with some natural associativity and
  distributivity axioms similar to those on a ring. -/
@[protect_proj] class module (R : Type u) (M : Type v) [semiring R]
  [add_comm_monoid M] extends distrib_mul_action R M :=
(add_smul : ∀(r s : R) (x : M), (r + s) • x = r • x + s • x)
(zero_smul : ∀x : M, (0 : R) • x = 0)

section add_comm_monoid
variables [semiring R] [add_comm_monoid M] [module R M] (r s : R) (x y : M)

/-- A module over a semiring automatically inherits a `mul_action_with_zero` structure. -/
@[priority 100] -- see Note [lower instance priority]
instance module.to_mul_action_with_zero :
  mul_action_with_zero R M :=
{ smul_zero := smul_zero,
  zero_smul := module.zero_smul,
  ..(infer_instance : mul_action R M) }

instance add_comm_monoid.nat_module : module ℕ M :=
{ one_smul := one_nsmul,
  mul_smul := λ m n a, mul_nsmul a m n,
  smul_add := λ n a b, nsmul_add a b n,
  smul_zero := nsmul_zero,
  zero_smul := zero_nsmul,
  add_smul := λ r s x, add_nsmul x r s }

theorem add_smul : (r + s) • x = r • x + s • x := module.add_smul r s x
variables (R)

theorem two_smul : (2 : R) • x = x + x := by rw [bit0, add_smul, one_smul]

theorem two_smul' : (2 : R) • x = bit0 x := two_smul R x

/-- Pullback a `module` structure along an injective additive monoid homomorphism. -/
protected def function.injective.module [add_comm_monoid M₂] [has_scalar R M₂] (f : M₂ →+ M)
  (hf : injective f) (smul : ∀ (c : R) x, f (c • x) = c • f x) :
  module R M₂ :=
{ smul := (•),
  add_smul := λ c₁ c₂ x, hf $ by simp only [smul, f.map_add, add_smul],
  zero_smul := λ x, hf $ by simp only [smul, zero_smul, f.map_zero],
  .. hf.distrib_mul_action f smul }

/-- Pushforward a `module` structure along a surjective additive monoid homomorphism. -/
protected def function.surjective.module [add_comm_monoid M₂] [has_scalar R M₂] (f : M →+ M₂)
  (hf : surjective f) (smul : ∀ (c : R) x, f (c • x) = c • f x) :
  module R M₂ :=
{ smul := (•),
  add_smul := λ c₁ c₂ x, by { rcases hf x with ⟨x, rfl⟩,
    simp only [add_smul, ← smul, ← f.map_add] },
  zero_smul := λ x, by { rcases hf x with ⟨x, rfl⟩, simp only [← f.map_zero, ← smul, zero_smul] },
  .. hf.distrib_mul_action f smul }

variables {R} (M)

/-- Compose a `module` with a `ring_hom`, with action `f s • m` -/
def module.comp_hom [semiring S] (f : S →+* R) :
  module S M :=
{ smul := (•) ∘ f,
  add_smul := λ r s x, by simp [add_smul],
  .. mul_action_with_zero.comp_hom M f.to_monoid_with_zero_hom,
  .. distrib_mul_action.comp_hom M (f : S →* R) }

variables (R) (M)

/-- `(•)` as an `add_monoid_hom`. -/
def smul_add_hom : R →+ M →+ M :=
{ to_fun := const_smul_hom M,
  map_zero' := add_monoid_hom.ext $ λ r, by simp,
  map_add' := λ x y, add_monoid_hom.ext $ λ r, by simp [add_smul] }

variables {R M}

@[simp] lemma smul_add_hom_apply (r : R) (x : M) :
  smul_add_hom R M r x = r • x := rfl

lemma module.eq_zero_of_zero_eq_one (zero_eq_one : (0 : R) = 1) : x = 0 :=
by rw [←one_smul R x, ←zero_eq_one, zero_smul]

lemma list.sum_smul {l : list R} {x : M} : l.sum • x = (l.map (λ r, r • x)).sum :=
((smul_add_hom R M).flip x).map_list_sum l

lemma multiset.sum_smul {l : multiset R} {x : M} : l.sum • x = (l.map (λ r, r • x)).sum :=
((smul_add_hom R M).flip x).map_multiset_sum l

lemma finset.sum_smul {f : ι → R} {s : finset ι} {x : M} :
  (∑ i in s, f i) • x = (∑ i in s, (f i) • x) :=
((smul_add_hom R M).flip x).map_sum f s

end add_comm_monoid

variables (R)

/-- An `add_comm_monoid` that is a `module` over a `ring` carries a natural `add_comm_group`
structure. -/
def module.add_comm_monoid_to_add_comm_group [ring R] [add_comm_monoid M] [module R M] :
  add_comm_group M :=
{ neg          := λ a, (-1 : R) • a,
  add_left_neg := λ a, show (-1 : R) • a + a = 0, by {
    nth_rewrite 1 ← one_smul _ a,
    rw [← add_smul, add_left_neg, zero_smul] },
  ..(infer_instance : add_comm_monoid M), }

variables {R}

section add_comm_group

variables (R M) [semiring R] [add_comm_group M]

instance add_comm_group.int_module : module ℤ M :=
{ one_smul := one_gsmul,
  mul_smul := λ m n a, mul_gsmul a m n,
  smul_add := λ n a b, gsmul_add a b n,
  smul_zero := gsmul_zero,
  zero_smul := zero_gsmul,
  add_smul := λ r s x, add_gsmul x r s }

/-- A structure containing most informations as in a module, except the fields `zero_smul`
and `smul_zero`. As these fields can be deduced from the other ones when `M` is an `add_comm_group`,
this provides a way to construct a module structure by checking less properties, in
`module.of_core`. -/
@[nolint has_inhabited_instance]
structure module.core extends has_scalar R M :=
(smul_add : ∀(r : R) (x y : M), r • (x + y) = r • x + r • y)
(add_smul : ∀(r s : R) (x : M), (r + s) • x = r • x + s • x)
(mul_smul : ∀(r s : R) (x : M), (r * s) • x = r • s • x)
(one_smul : ∀x : M, (1 : R) • x = x)

variables {R M}

/-- Define `module` without proving `zero_smul` and `smul_zero` by using an auxiliary
structure `module.core`, when the underlying space is an `add_comm_group`. -/
def module.of_core (H : module.core R M) : module R M :=
by letI := H.to_has_scalar; exact
{ zero_smul := λ x, (add_monoid_hom.mk' (λ r : R, r • x) (λ r s, H.add_smul r s x)).map_zero,
  smul_zero := λ r, (add_monoid_hom.mk' ((•) r) (H.smul_add r)).map_zero,
  ..H }

end add_comm_group

/--
To prove two module structures on a fixed `add_comm_monoid` agree,
it suffices to check the scalar multiplications agree.
-/
-- We'll later use this to show `module ℕ M` and `module ℤ M` are subsingletons.
@[ext]
lemma module_ext {R : Type*} [semiring R] {M : Type*} [add_comm_monoid M] (P Q : module R M)
  (w : ∀ (r : R) (m : M), by { haveI := P, exact r • m } = by { haveI := Q, exact r • m }) :
  P = Q :=
begin
  unfreezingI { rcases P with ⟨⟨⟨⟨P⟩⟩⟩⟩, rcases Q with ⟨⟨⟨⟨Q⟩⟩⟩⟩ },
  congr,
  funext r m,
  exact w r m,
  all_goals { apply proof_irrel_heq },
end

section module
variables [ring R] [add_comm_group M] [module R M] (r s : R) (x y : M)

@[simp] theorem neg_smul : -r • x = - (r • x) :=
eq_neg_of_add_eq_zero (by rw [← add_smul, add_left_neg, zero_smul])

variables (R)
theorem neg_one_smul (x : M) : (-1 : R) • x = -x := by simp
variables {R}

theorem sub_smul (r s : R) (y : M) : (r - s) • y = r • y - s • y :=
by simp [add_smul, sub_eq_add_neg]

end module

/-- A module over a `subsingleton` semiring is a `subsingleton`. We cannot register this
as an instance because Lean has no way to guess `R`. -/
protected
theorem module.subsingleton (R M : Type*) [semiring R] [subsingleton R] [add_comm_monoid M]
  [module R M] :
  subsingleton M :=
⟨λ x y, by rw [← one_smul R x, ← one_smul R y, subsingleton.elim (1:R) 0, zero_smul, zero_smul]⟩

@[priority 910] -- see Note [lower instance priority]
instance semiring.to_module [semiring R] : module R R :=
{ smul_add := mul_add,
  add_smul := add_mul,
  zero_smul := zero_mul,
  smul_zero := mul_zero }

/-- A ring homomorphism `f : R →+* M` defines a module structure by `r • x = f r * x`. -/
def ring_hom.to_module [semiring R] [semiring S] (f : R →+* S) : module R S :=
{ smul := λ r x, f r * x,
  smul_add := λ r x y, by unfold has_scalar.smul; rw [mul_add],
  add_smul := λ r s x, by unfold has_scalar.smul; rw [f.map_add, add_mul],
  mul_smul := λ r s x, by unfold has_scalar.smul; rw [f.map_mul, mul_assoc],
  one_smul := λ x, show f 1 * x = _, by rw [f.map_one, one_mul],
  zero_smul := λ x, show f 0 * x = 0, by rw [f.map_zero, zero_mul],
  smul_zero := λ r, mul_zero (f r) }

section add_comm_monoid

variables [semiring R] [add_comm_monoid M] [module R M]

section
variables (R)
/-- `nsmul` is equal to any other module structure via a cast. -/
lemma nsmul_eq_smul_cast (n : ℕ) (b : M) :
  n • b = (n : R) • b :=
begin
  induction n with n ih,
  { rw [nat.cast_zero, zero_smul, zero_smul] },
  { rw [nat.succ_eq_add_one, nat.cast_succ, add_smul, add_smul, one_smul, ih, one_smul], }
end
end

/-- Convert back any exotic `ℕ`-smul to the canonical instance. This should not be needed since in
mathlib all `add_comm_monoid`s should normally have exactly one `ℕ`-module structure by design.
-/
lemma nat_smul_eq_nsmul (h : module ℕ M) (n : ℕ) (x : M) :
  @has_scalar.smul ℕ M h.to_has_scalar n x = n • x :=
by rw [nsmul_eq_smul_cast ℕ n x, nat.cast_id]

/-- All `ℕ`-module structures are equal. Not an instance since in mathlib all `add_comm_monoid`
should normally have exactly one `ℕ`-module structure by design. -/
def add_comm_monoid.nat_module.unique : unique (module ℕ M) :=
{ default := by apply_instance,
  uniq := λ P, module_ext P _ $ λ n, nat_smul_eq_nsmul P n }

instance add_comm_monoid.nat_is_scalar_tower :
  is_scalar_tower ℕ R M :=
{ smul_assoc := λ n x y, nat.rec_on n
    (by simp only [zero_smul])
    (λ n ih, by simp only [nat.succ_eq_add_one, add_smul, one_smul, ih]) }

instance add_comm_monoid.nat_smul_comm_class : smul_comm_class ℕ R M :=
{ smul_comm := λ n r m, nat.rec_on n
    (by simp only [zero_smul, smul_zero])
    (λ n ih, by simp only [nat.succ_eq_add_one, add_smul, one_smul, ←ih, smul_add]) }

-- `smul_comm_class.symm` is not registered as an instance, as it would cause a loop
instance add_comm_monoid.nat_smul_comm_class' : smul_comm_class R ℕ M :=
smul_comm_class.symm _ _ _

end add_comm_monoid

section add_comm_group

variables [semiring S] [ring R] [add_comm_group M] [module S M] [module R M]

section
variables (R)
/-- `gsmul` is equal to any other module structure via a cast. -/
lemma gsmul_eq_smul_cast (n : ℤ) (b : M) : n • b = (n : R) • b :=
begin
  induction n using int.induction_on with p hp n hn,
  { rw [int.cast_zero, zero_smul, zero_smul] },
  { rw [int.cast_add, int.cast_one, add_smul, add_smul, one_smul, one_smul, hp] },
  { rw [int.cast_sub, int.cast_one, sub_smul, sub_smul, one_smul, one_smul, hn] },
end
end

/-- Convert back any exotic `ℤ`-smul to the canonical instance. This should not be needed since in
mathlib all `add_comm_group`s should normally have exactly one `ℤ`-module structure by design. -/
lemma int_smul_eq_gsmul (h : module ℤ M) (n : ℤ) (x : M) :
  @has_scalar.smul ℤ M h.to_has_scalar n x = n • x :=
by rw [gsmul_eq_smul_cast ℤ n x, int.cast_id]

/-- All `ℤ`-module structures are equal. Not an instance since in mathlib all `add_comm_group`
should normally have exactly one `ℤ`-module structure by design. -/
def add_comm_group.int_module.unique : unique (module ℤ M) :=
{ default := by apply_instance,
  uniq := λ P, module_ext P _ $ λ n, int_smul_eq_gsmul P n }

instance add_comm_group.int_is_scalar_tower : is_scalar_tower ℤ R M :=
{ smul_assoc := λ n x y, int.induction_on n
    (by simp only [zero_smul])
    (λ n ih, by simp only [one_smul, add_smul, ih])
    (λ n ih, by simp only [one_smul, sub_smul, ih]) }

instance add_comm_group.int_smul_comm_class : smul_comm_class ℤ S M :=
{ smul_comm := λ n x y, int.induction_on n
    (by simp only [zero_smul, smul_zero])
    (λ n ih, by simp only [one_smul, add_smul, smul_add, ih])
    (λ n ih, by simp only [one_smul, sub_smul, smul_sub, ih]) }

-- `smul_comm_class.symm` is not registered as an instance, as it would cause a loop
instance add_comm_group.int_smul_comm_class' : smul_comm_class S ℤ M :=
smul_comm_class.symm _ _ _

end add_comm_group

namespace add_monoid_hom

lemma map_int_module_smul [add_comm_group M] [add_comm_group M₂]
  (f : M →+ M₂) (x : ℤ) (a : M) : f (x • a) = x • f a :=
by simp only [f.map_gsmul]

lemma map_int_cast_smul
  [ring R] [add_comm_group M] [add_comm_group M₂] [module R M] [module R M₂]
  (f : M →+ M₂) (x : ℤ) (a : M) : f ((x : R) • a) = (x : R) • f a :=
by simp only [←gsmul_eq_smul_cast, f.map_gsmul]

lemma map_nat_cast_smul
  [semiring R] [add_comm_monoid M] [add_comm_monoid M₂]
  [module R M] [module R M₂] (f : M →+ M₂) (x : ℕ) (a : M) :
  f ((x : R) • a) = (x : R) • f a :=
by simp only [←nsmul_eq_smul_cast, f.map_nsmul]

lemma map_rat_cast_smul {R : Type*} [division_ring R] [char_zero R]
  {E : Type*} [add_comm_group E] [module R E] {F : Type*} [add_comm_group F] [module R F]
  (f : E →+ F) (c : ℚ) (x : E) :
  f ((c : R) • x) = (c : R) • f x :=
begin
  have : ∀ (x : E) (n : ℕ), 0 < n → f (((n⁻¹ : ℚ) : R) • x) = ((n⁻¹ : ℚ) : R) • f x,
  { intros x n hn,
    replace hn : (n : R) ≠ 0 := nat.cast_ne_zero.2 (ne_of_gt hn),
    conv_rhs { congr, skip, rw [← one_smul R x, ← mul_inv_cancel hn, mul_smul] },
    rw [f.map_nat_cast_smul, smul_smul, rat.cast_inv, rat.cast_coe_nat,
      inv_mul_cancel hn, one_smul] },
  refine c.num_denom_cases_on (λ m n hn hmn, _),
  rw [rat.mk_eq_div, div_eq_mul_inv, rat.cast_mul, int.cast_coe_nat, mul_smul, mul_smul,
    rat.cast_coe_int, f.map_int_cast_smul, this _ n hn]
end

lemma map_rat_module_smul {E : Type*} [add_comm_group E] [module ℚ E]
  {F : Type*} [add_comm_group F] [module ℚ F] (f : E →+ F) (c : ℚ) (x : E) :
  f (c • x) = c • f x :=
rat.cast_id c ▸ f.map_rat_cast_smul c x

end add_monoid_hom

section no_zero_smul_divisors
/-! ### `no_zero_smul_divisors`

This section defines the `no_zero_smul_divisors` class, and includes some tests
for the vanishing of elements (especially in modules over division rings).
-/

/-- `no_zero_smul_divisors R M` states that a scalar multiple is `0` only if either argument is `0`.
This a version of saying that `M` is torsion free, without assuming `R` is zero-divisor free.

The main application of `no_zero_smul_divisors R M`, when `M` is a module,
is the result `smul_eq_zero`: a scalar multiple is `0` iff either argument is `0`.

It is a generalization of the `no_zero_divisors` class to heterogeneous multiplication.
-/
class no_zero_smul_divisors (R M : Type*) [has_zero R] [has_zero M] [has_scalar R M] : Prop :=
(eq_zero_or_eq_zero_of_smul_eq_zero : ∀ {c : R} {x : M}, c • x = 0 → c = 0 ∨ x = 0)

export no_zero_smul_divisors (eq_zero_or_eq_zero_of_smul_eq_zero)

section module

variables [semiring R] [add_comm_monoid M] [module R M]

instance no_zero_smul_divisors.of_no_zero_divisors [no_zero_divisors R] :
  no_zero_smul_divisors R R :=
⟨λ c x, no_zero_divisors.eq_zero_or_eq_zero_of_mul_eq_zero⟩

@[simp]
theorem smul_eq_zero [no_zero_smul_divisors R M] {c : R} {x : M} :
  c • x = 0 ↔ c = 0 ∨ x = 0 :=
⟨eq_zero_or_eq_zero_of_smul_eq_zero,
 λ h, h.elim (λ h, h.symm ▸ zero_smul R x) (λ h, h.symm ▸ smul_zero c)⟩

theorem smul_ne_zero [no_zero_smul_divisors R M] {c : R} {x : M} :
  c • x ≠ 0 ↔ c ≠ 0 ∧ x ≠ 0 :=
by simp only [ne.def, smul_eq_zero, not_or_distrib]

section nat

variables (R) (M) [no_zero_smul_divisors R M] [char_zero R]
include R

lemma nat.no_zero_smul_divisors : no_zero_smul_divisors ℕ M :=
⟨by { intros c x, rw [nsmul_eq_smul_cast R, smul_eq_zero], simp }⟩

variables {M}

lemma eq_zero_of_smul_two_eq_zero {v : M} (hv : 2 • v = 0) : v = 0 :=
by haveI := nat.no_zero_smul_divisors R M;
exact (smul_eq_zero.mp hv).resolve_left (by norm_num)

end nat

end module

section add_comm_group -- `R` can still be a semiring here

variables [semiring R] [add_comm_group M] [module R M]

lemma smul_injective [no_zero_smul_divisors R M] {c : R} (hc : c ≠ 0) :
  function.injective (λ (x : M), c • x) :=
λ x y h, sub_eq_zero.mp ((smul_eq_zero.mp
  (calc c • (x - y) = c • x - c • y : smul_sub c x y
                ... = 0 : sub_eq_zero.mpr h)).resolve_left hc)

section nat

variables (R) [no_zero_smul_divisors R M] [char_zero R]
include R

lemma eq_zero_of_eq_neg {v : M} (hv : v = - v) : v = 0 :=
begin
  haveI := nat.no_zero_smul_divisors R M,
  refine eq_zero_of_smul_two_eq_zero R _,
  rw two_smul,
  exact add_eq_zero_iff_eq_neg.mpr hv
end

end nat

end add_comm_group

section module

section nat

variables {R} [ring R] [add_comm_group M] [module R M] [no_zero_smul_divisors R M] [char_zero R]

lemma ne_neg_of_ne_zero [no_zero_divisors R] {v : R} (hv : v ≠ 0) : v ≠ -v :=
λ h, hv (eq_zero_of_eq_neg R h)

end nat

end module

section division_ring

variables [division_ring R] [add_comm_group M] [module R M]

@[priority 100] -- see note [lower instance priority]
instance no_zero_smul_divisors.of_division_ring : no_zero_smul_divisors R M :=
⟨λ c x h, or_iff_not_imp_left.2 $ λ hc, (units.mk0 c hc).smul_eq_zero.1 h⟩

end division_ring

end no_zero_smul_divisors

@[simp] lemma nat.smul_one_eq_coe {R : Type*} [semiring R] (m : ℕ) :
  m • (1 : R) = ↑m :=
by rw [nsmul_eq_mul, mul_one]

@[simp] lemma int.smul_one_eq_coe {R : Type*} [ring R] (m : ℤ) :
  m • (1 : R) = ↑m :=
by rw [gsmul_eq_mul, mul_one]


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Callum Sutton, Yury Kudryashov
-/
import group_theory.perm.basic

/-!
# Multiplicative and additive group automorphisms

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

This file defines the automorphism group structure on `add_aut R := add_equiv R R` and
`mul_aut R := mul_equiv R R`.

## Implementation notes

The definition of multiplication in the automorphism groups agrees with function composition,
multiplication in `equiv.perm`, and multiplication in `category_theory.End`, but not with
`category_theory.comp`.

This file is kept separate from `data/equiv/mul_add` so that `group_theory.perm` is free to use
equivalences (and other files that use them) before the group structure is defined.

## Tags

mul_aut, add_aut
-/
variables {A : Type*} {M : Type*} {G : Type*}

/-- The group of multiplicative automorphisms. -/
@[reducible, to_additive "The group of additive automorphisms."]
def mul_aut (M : Type*) [has_mul M] := M ≃* M

namespace mul_aut

variables (M) [has_mul M]

/--
The group operation on multiplicative automorphisms is defined by
`λ g h, mul_equiv.trans h g`.
This means that multiplication agrees with composition, `(g*h)(x) = g (h x)`.
-/
instance : group (mul_aut M) :=
by refine_struct
{ mul := λ g h, mul_equiv.trans h g,
  one := mul_equiv.refl M,
  inv := mul_equiv.symm,
  div := _,
  npow := @npow_rec _ ⟨mul_equiv.refl M⟩ ⟨λ g h, mul_equiv.trans h g⟩,
  zpow := @zpow_rec _ ⟨mul_equiv.refl M⟩ ⟨λ g h, mul_equiv.trans h g⟩ ⟨mul_equiv.symm⟩ };
intros; ext; try { refl }; apply equiv.left_inv

instance : inhabited (mul_aut M) := ⟨1⟩

@[simp] lemma coe_mul (e₁ e₂ : mul_aut M) : ⇑(e₁ * e₂) = e₁ ∘ e₂ := rfl
@[simp] lemma coe_one : ⇑(1 : mul_aut M) = id := rfl

lemma mul_def (e₁ e₂ : mul_aut M) : e₁ * e₂ = e₂.trans e₁ := rfl
lemma one_def : (1 : mul_aut M) = mul_equiv.refl _ := rfl
lemma inv_def (e₁ : mul_aut M) : e₁⁻¹ = e₁.symm := rfl
@[simp] lemma mul_apply (e₁ e₂ : mul_aut M) (m : M) : (e₁ * e₂) m = e₁ (e₂ m) := rfl
@[simp] lemma one_apply (m : M) : (1 : mul_aut M) m = m := rfl

@[simp] lemma apply_inv_self (e : mul_aut M) (m : M) : e (e⁻¹ m) = m :=
mul_equiv.apply_symm_apply _ _

@[simp] lemma inv_apply_self (e : mul_aut M) (m : M) : e⁻¹ (e m) = m :=
mul_equiv.apply_symm_apply _ _

/-- Monoid hom from the group of multiplicative automorphisms to the group of permutations. -/
def to_perm : mul_aut M →* equiv.perm M :=
by refine_struct { to_fun := mul_equiv.to_equiv }; intros; refl

/-- The tautological action by `mul_aut M` on `M`.

This generalizes `function.End.apply_mul_action`. -/
instance apply_mul_distrib_mul_action {M} [monoid M] : mul_distrib_mul_action (mul_aut M) M :=
{ smul := ($),
  one_smul := λ _, rfl,
  mul_smul := λ _ _ _, rfl,
  smul_one := mul_equiv.map_one,
  smul_mul := mul_equiv.map_mul }

@[simp] protected lemma smul_def {M} [monoid M] (f : mul_aut M) (a : M) : f • a = f a := rfl

/-- `mul_aut.apply_mul_action` is faithful. -/
instance apply_has_faithful_smul {M} [monoid M] : has_faithful_smul (mul_aut M) M :=
⟨λ _ _, mul_equiv.ext⟩

/-- Group conjugation, `mul_aut.conj g h = g * h * g⁻¹`, as a monoid homomorphism
mapping multiplication in `G` into multiplication in the automorphism group `mul_aut G`.
See also the type `conj_act G` for any group `G`, which has a `mul_action (conj_act G) G` instance
where `conj G` acts on `G` by conjugation. -/
def conj [group G] : G →* mul_aut G :=
{ to_fun := λ g,
  { to_fun := λ h, g * h * g⁻¹,
    inv_fun := λ h, g⁻¹ * h * g,
    left_inv := λ _, by simp [mul_assoc],
    right_inv := λ _, by simp [mul_assoc],
    map_mul' := by simp [mul_assoc] },
  map_mul' := λ _ _, by ext; simp [mul_assoc],
  map_one' := by ext; simp [mul_assoc] }

@[simp] lemma conj_apply [group G] (g h : G) : conj g h = g * h * g⁻¹ := rfl
@[simp] lemma conj_symm_apply [group G] (g h : G) : (conj g).symm h = g⁻¹ * h * g := rfl
@[simp]

end mul_aut

namespace add_aut

variables (A) [has_add A]

/--
The group operation on additive automorphisms is defined by
`λ g h, add_equiv.trans h g`.
This means that multiplication agrees with composition, `(g*h)(x) = g (h x)`.
-/
instance group : group (add_aut A) :=
by refine_struct
{ mul := λ g h, add_equiv.trans h g,
  one := add_equiv.refl A,
  inv := add_equiv.symm,
  div := _,
  npow := @npow_rec _ ⟨add_equiv.refl A⟩ ⟨λ g h, add_equiv.trans h g⟩,
  zpow := @zpow_rec _ ⟨add_equiv.refl A⟩ ⟨λ g h, add_equiv.trans h g⟩ ⟨add_equiv.symm⟩ };
intros; ext; try { refl }; apply equiv.left_inv

instance : inhabited (add_aut A) := ⟨1⟩

@[simp] lemma coe_mul (e₁ e₂ : add_aut A) : ⇑(e₁ * e₂) = e₁ ∘ e₂ := rfl
@[simp] lemma coe_one : ⇑(1 : add_aut A) = id := rfl

lemma mul_def (e₁ e₂ : add_aut A) : e₁ * e₂ = e₂.trans e₁ := rfl
lemma one_def : (1 : add_aut A) = add_equiv.refl _ := rfl
lemma inv_def (e₁ : add_aut A) : e₁⁻¹ = e₁.symm := rfl
@[simp] lemma mul_apply (e₁ e₂ : add_aut A) (a : A) : (e₁ * e₂) a = e₁ (e₂ a) := rfl
@[simp] lemma one_apply (a : A) : (1 : add_aut A) a = a := rfl

@[simp] lemma apply_inv_self (e : add_aut A) (a : A) : e⁻¹ (e a) = a :=
add_equiv.apply_symm_apply _ _

@[simp] lemma inv_apply_self (e : add_aut A) (a : A) : e (e⁻¹ a) = a :=
add_equiv.apply_symm_apply _ _

/-- Monoid hom from the group of multiplicative automorphisms to the group of permutations. -/
def to_perm : add_aut A →* equiv.perm A :=
by refine_struct { to_fun := add_equiv.to_equiv }; intros; refl

/-- The tautological action by `add_aut A` on `A`.

This generalizes `function.End.apply_mul_action`. -/
instance apply_distrib_mul_action {A} [add_monoid A] : distrib_mul_action (add_aut A) A :=
{ smul := ($),
  smul_zero := add_equiv.map_zero,
  smul_add := add_equiv.map_add,
  one_smul := λ _, rfl,
  mul_smul := λ _ _ _, rfl }

@[simp] protected lemma smul_def {A} [add_monoid A] (f : add_aut A) (a : A) : f • a = f a := rfl

/-- `add_aut.apply_distrib_mul_action` is faithful. -/
instance apply_has_faithful_smul {A} [add_monoid A] : has_faithful_smul (add_aut A) A :=
⟨λ _ _, add_equiv.ext⟩

/-- Additive group conjugation, `add_aut.conj g h = g + h - g`, as an additive monoid
homomorphism mapping addition in `G` into multiplication in the automorphism group `add_aut G`
(written additively in order to define the map). -/
def conj [add_group G] : G →+ additive (add_aut G) :=
{ to_fun := λ g, @additive.of_mul (add_aut G)
  { to_fun := λ h, g + h + -g, -- this definition is chosen to match `mul_aut.conj`
    inv_fun := λ h, -g + h + g,
    left_inv := λ _, by simp [add_assoc],
    right_inv := λ _, by simp [add_assoc],
    map_add' := by simp [add_assoc] },
  map_add' := λ _ _, by apply additive.to_mul.injective; ext; simp [add_assoc],
  map_zero' := by ext; simpa }

@[simp] lemma conj_apply [add_group G] (g h : G) : conj g h = g + h + -g := rfl
@[simp] lemma conj_symm_apply [add_group G] (g h : G) : (conj g).symm h = -g + h + g := rfl
@[simp] lemma conj_inv_apply [add_group G] (g h : G) : (-(conj g)) h = -g + h + g := rfl

end add_aut


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import topology.subset_properties
import topology.connected
import topology.algebra.monoid
import tactic.tfae

/-!
# Locally constant functions

This file sets up the theory of locally constant function from a topological space to a type.

## Main definitions and constructions

* `is_locally_constant f` : a map `f : X → Y` where `X` is a topological space is locally
                            constant if every set in `Y` has an open preimage.
* `locally_constant X Y` : the type of locally constant maps from `X` to `Y`
* `locally_constant.map` : push-forward of locally constant maps
* `locally_constant.comap` : pull-back of locally constant maps

-/

variables {X Y Z α : Type*} [topological_space X]

open set filter
open_locale topological_space

/-- A function between topological spaces is locally constant if the preimage of any set is open. -/
def is_locally_constant (f : X → Y) : Prop := ∀ s : set Y, is_open (f ⁻¹' s)

namespace is_locally_constant

protected lemma tfae (f : X → Y) :
  tfae [is_locally_constant f,
    ∀ x, ∀ᶠ x' in 𝓝 x, f x' = f x,
    ∀ x, is_open {x' | f x' = f x},
    ∀ y, is_open (f ⁻¹' {y}),
    ∀ x, ∃ (U : set X) (hU : is_open U) (hx : x ∈ U), ∀ x' ∈ U, f x' = f x] :=
begin
  tfae_have : 1 → 4, from λ h y, h {y},
  tfae_have : 4 → 3, from λ h x, h (f x),
  tfae_have : 3 → 2, from λ h x, mem_nhds_sets (h x) rfl,
  tfae_have : 2 → 5,
  { intros h x,
    rcases mem_nhds_sets_iff.1 (h x) with ⟨U, eq, hU, hx⟩,
    exact ⟨U, hU, hx, eq⟩ },
  tfae_have : 5 → 1,
  { intros h s,
    refine is_open_iff_forall_mem_open.2 (λ x hx, _),
    rcases h x with ⟨U, hU, hxU, eq⟩,
    exact ⟨U, λ x' hx', mem_preimage.2 $ (eq x' hx').symm ▸ hx, hU, hxU⟩ },
  tfae_finish
end

@[nontriviality] lemma of_discrete [discrete_topology X] (f : X → Y) :
  is_locally_constant f :=
λ s, is_open_discrete _

lemma is_open_fiber {f : X → Y} (hf : is_locally_constant f) (y : Y) :
  is_open {x | f x = y} :=
hf {y}

lemma iff_exists_open (f : X → Y) :
  is_locally_constant f ↔ ∀ x, ∃ (U : set X) (hU : is_open U) (hx : x ∈ U), ∀ x' ∈ U, f x' = f x :=
(is_locally_constant.tfae f).out 0 4

lemma iff_eventually_eq (f : X → Y) :
  is_locally_constant f ↔ ∀ x, ∀ᶠ y in 𝓝 x, f y = f x :=
(is_locally_constant.tfae f).out 0 1

lemma exists_open {f : X → Y} (hf : is_locally_constant f) (x : X) :
  ∃ (U : set X) (hU : is_open U) (hx : x ∈ U), ∀ x' ∈ U, f x' = f x :=
(iff_exists_open f).1 hf x

protected lemma eventually_eq {f : X → Y} (hf : is_locally_constant f) (x : X) :
  ∀ᶠ y in 𝓝 x, f y = f x :=
(iff_eventually_eq f).1 hf x

protected lemma continuous [topological_space Y] {f : X → Y} (hf : is_locally_constant f) :
  continuous f :=
⟨λ U hU, hf _⟩

lemma iff_continuous {_ : topological_space Y} [discrete_topology Y] (f : X → Y) :
  is_locally_constant f ↔ continuous f :=
⟨is_locally_constant.continuous, λ h s, h.is_open_preimage s (is_open_discrete _)⟩

lemma iff_continuous_bot (f : X → Y) :
  is_locally_constant f ↔ @continuous X Y _ ⊥ f :=
iff_continuous f

lemma of_constant (f : X → Y) (h : ∀ x y, f x = f y) :
  is_locally_constant f :=
(iff_eventually_eq f).2 $ λ x, eventually_of_forall $ λ x', h _ _

lemma const (y : Y) : is_locally_constant (function.const X y) :=
of_constant _ $ λ _ _, rfl

lemma comp {f : X → Y} (hf : is_locally_constant f) (g : Y → Z) :
  is_locally_constant (g ∘ f) :=
λ s, by { rw set.preimage_comp, exact hf _ }

lemma prod_mk {Y'} {f : X → Y} {f' : X → Y'} (hf : is_locally_constant f)
  (hf' : is_locally_constant f') :
  is_locally_constant (λ x, (f x, f' x)) :=
(iff_eventually_eq _).2 $ λ x, (hf.eventually_eq x).mp $ (hf'.eventually_eq x).mono $
  λ x' hf' hf, prod.ext hf hf'

lemma comp₂ {Y₁ Y₂ Z : Type*} {f : X → Y₁} {g : X → Y₂}
  (hf : is_locally_constant f) (hg : is_locally_constant g) (h : Y₁ → Y₂ → Z) :
  is_locally_constant (λ x, h (f x) (g x)) :=
(hf.prod_mk hg).comp (λ x : Y₁ × Y₂, h x.1 x.2)

lemma comp_continuous [topological_space Y] {g : Y → Z} {f : X → Y}
  (hg : is_locally_constant g) (hf : continuous f) :
  is_locally_constant (g ∘ f) :=
λ s, by { rw set.preimage_comp, exact hf.is_open_preimage _ (hg _) }

/-- A locally constant function is constant on any preconnected set. -/
lemma apply_eq_of_is_preconnected {f : X → Y} (hf : is_locally_constant f)
  {s : set X} (hs : is_preconnected s) {x y : X} (hx : x ∈ s) (hy : y ∈ s) :
  f x = f y :=
begin
  let U := f ⁻¹' {f y},
  suffices : x ∉ Uᶜ, from not_not.1 this,
  intro hxV,
  specialize hs U Uᶜ (hf {f y}) (hf {f y}ᶜ) _ ⟨y, ⟨hy, rfl⟩⟩ ⟨x, ⟨hx, hxV⟩⟩,
  { simp only [union_compl_self, subset_univ] },
  { simpa only [inter_empty, not_nonempty_empty, inter_compl_self] using hs }
end

lemma iff_is_const [preconnected_space X] {f : X → Y} :
  is_locally_constant f ↔ ∀ x y, f x = f y :=
⟨λ h x y, h.apply_eq_of_is_preconnected is_preconnected_univ trivial trivial, of_constant _⟩

lemma range_finite [compact_space X] {f : X → Y} (hf : is_locally_constant f) :
  (set.range f).finite :=
begin
  letI : topological_space Y := ⊥,
  haveI : discrete_topology Y := ⟨rfl⟩,
  rw @iff_continuous X Y ‹_› ‹_› at hf,
  exact finite_of_is_compact_of_discrete _ (compact_range hf)
end

@[to_additive] lemma one [has_one Y] : is_locally_constant (1 : X → Y) := const 1

@[to_additive] lemma inv [has_inv Y] ⦃f : X → Y⦄ (hf : is_locally_constant f) :
  is_locally_constant f⁻¹ :=
hf.comp (λ x, x⁻¹)

@[to_additive]
lemma mul [has_mul Y] ⦃f g : X → Y⦄ (hf : is_locally_constant f) (hg : is_locally_constant g) :
  is_locally_constant (f * g) :=
hf.comp₂ hg (*)

@[to_additive]
lemma div [has_div Y] ⦃f g : X → Y⦄ (hf : is_locally_constant f) (hg : is_locally_constant g) :
  is_locally_constant (f / g) :=
hf.comp₂ hg (/)

end is_locally_constant

/-- A (bundled) locally constant function from a topological space `X` to a type `Y`. -/
structure locally_constant (X Y : Type*) [topological_space X] :=
(to_fun : X → Y)
(is_locally_constant : is_locally_constant to_fun)

namespace locally_constant

instance [inhabited Y] : inhabited (locally_constant X Y) :=
⟨⟨_, is_locally_constant.const (default Y)⟩⟩

instance : has_coe_to_fun (locally_constant X Y) := ⟨_, locally_constant.to_fun⟩

initialize_simps_projections locally_constant (to_fun → apply)

@[simp] lemma to_fun_eq_coe (f : locally_constant X Y) : f.to_fun = f := rfl

@[simp] lemma coe_mk (f : X → Y) (h) : ⇑(⟨f, h⟩ : locally_constant X Y) = f := rfl

theorem congr_fun {f g : locally_constant X Y} (h : f = g) (x : X) : f x = g x :=
congr_arg (λ h : locally_constant X Y, h x) h

theorem congr_arg (f : locally_constant X Y) {x y : X} (h : x = y) : f x = f y :=
congr_arg (λ x : X, f x) h

theorem coe_injective : function.injective (λ (f : locally_constant X Y) (x : X), f x)
| ⟨f, hf⟩ ⟨g, hg⟩ h := have f = g, from h, by subst f

@[simp, norm_cast] theorem coe_inj {f g : locally_constant X Y} : (f : X → Y) = g ↔ f = g :=
coe_injective.eq_iff

@[ext] theorem ext ⦃f g : locally_constant X Y⦄ (h : ∀ x, f x = g x) : f = g :=
coe_injective (funext h)

theorem ext_iff {f g : locally_constant X Y} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

protected lemma continuous [topological_space Y] (f : locally_constant X Y) : continuous f :=
f.is_locally_constant.continuous

/-- The constant locally constant function on `X` with value `y : Y`. -/
def const (X : Type*) {Y : Type*} [topological_space X] (y : Y) :
  locally_constant X Y :=
⟨function.const X y, is_locally_constant.const _⟩

lemma range_finite [compact_space X] (f : locally_constant X Y) :
  (set.range f).finite :=
f.is_locally_constant.range_finite

lemma apply_eq_of_is_preconnected (f : locally_constant X Y) {s : set X} (hs : is_preconnected s)
  {x y : X} (hx : x ∈ s) (hy : y ∈ s) :
  f x = f y :=
f.is_locally_constant.apply_eq_of_is_preconnected hs hx hy

lemma apply_eq_of_preconnected_space [preconnected_space X] (f : locally_constant X Y) (x y : X) :
  f x = f y :=
f.is_locally_constant.apply_eq_of_is_preconnected is_preconnected_univ trivial trivial

lemma eq_const [preconnected_space X] (f : locally_constant X Y) (x : X) :
  f = const X (f x) :=
ext $ λ y, apply_eq_of_preconnected_space f _ _

lemma exists_eq_const [preconnected_space X] [nonempty Y] (f : locally_constant X Y) :
  ∃ y, f = const X y :=
begin
  rcases classical.em (nonempty X) with ⟨⟨x⟩⟩|hX,
  { exact ⟨f x, f.eq_const x⟩ },
  { exact ⟨classical.arbitrary Y, ext $ λ x, (hX ⟨x⟩).elim⟩ }
end

/-- Push forward of locally constant maps under any map, by post-composition. -/
def map (f : Y → Z) : locally_constant X Y → locally_constant X Z :=
λ g, ⟨f ∘ g, λ s, by { rw set.preimage_comp, apply g.is_locally_constant }⟩

@[simp] lemma map_apply (f : Y → Z) (g : locally_constant X Y) : ⇑(map f g) = f ∘ g := rfl

@[simp] lemma map_id : @map X Y Y _ id = id := by { ext, refl }

@[simp] lemma map_comp {Y₁ Y₂ Y₃ : Type*} (g : Y₂ → Y₃) (f : Y₁ → Y₂) :
  @map X _ _ _ g ∘ map f = map (g ∘ f) := by { ext, refl }

section comap

open_locale classical

variables [topological_space Y]

/-- Pull back of locally constant maps under any map, by pre-composition.

This definition only makes sense if `f` is continuous,
in which case it sends locally constant functions to their precomposition with `f`.
See also `locally_constant.coe_comap`. -/
noncomputable
def comap (f : X → Y) :
  locally_constant Y Z → locally_constant X Z :=
if hf : continuous f
then λ g, ⟨g ∘ f, g.is_locally_constant.comp_continuous hf⟩
else
begin
  by_cases H : nonempty X,
  { introsI g, exact const X (g $ f $ classical.arbitrary X) },
  { intro g, refine ⟨λ x, (H ⟨x⟩).elim, _⟩,
    intro s, rw is_open_iff_nhds, intro x, exact (H ⟨x⟩).elim }
end

@[simp] lemma coe_comap (f : X → Y) (g : locally_constant Y Z) (hf : continuous f) :
  ⇑(comap f g) = g ∘ f :=
by { rw [comap, dif_pos hf], refl }

@[simp] lemma comap_id : @comap X X Z _ _ id = id :=
by { ext, simp only [continuous_id, id.def, function.comp.right_id, coe_comap] }

lemma comap_comp [topological_space Z]
  (f : X → Y) (g : Y → Z) (hf : continuous f) (hg : continuous g) :
  @comap _ _ α _ _ f ∘ comap g = comap (g ∘ f) :=
by { ext, simp only [hf, hg, hg.comp hf, coe_comap] }

lemma comap_const (f : X → Y) (y : Y) (h : ∀ x, f x = y) :
  (comap f : locally_constant Y Z → locally_constant X Z) =
  λ g, ⟨λ x, g y, is_locally_constant.const _⟩ :=
begin
  ext, rw coe_comap,
  { simp only [h, coe_mk, function.comp_app] },
  { rw show f = λ x, y, by ext; apply h,
    exact continuous_const }
end

end comap

end locally_constant


namespace prop_logic
-- I had to look at the answer key.
/-
This assignment has five problems. The first
is to extend our propositional logic syntax
and semantics to support the three additional
connectives, exclusive or (⊕), implies (which
we will write as ⇒), and if and only iff (↔).
We first give you the definitions developed
in class. You are to extend/modify them to
support expressions with the new connectives.
The remaining problems use this definition of
our language of expressions in propositional
logic.
-/

/-
1. Extend our syntax and semantics
for propositional logic to support
the xor, implies, and iff and only
iff connectives/operators.

A. Add support for the exclusive or
connective/operator. Define the symbol,
⊕, as an infix notation.

Here are specific steps to take for the
exclusive or connective, as an example.

1. Add new binary connective, xorOp -- done
2. Add pXor as shorthand for binOpExp xorOp -- done
3. Add ⊕ as an infix notation for pXor -- done
4. Specify the interpretation of ⊕ to be bxor -- done
5. Extend interpBinOp to handle the new case -- done

Then add support for the implies connective,
using the symbol, ⇒, as an infix operator.
We can't use → because it's reserved by Lean
and cannot be overloaded. Lean does not have
a Boolean implies operator (analogous to bor),
so you will have to define one. Call it bimpl.

Finally add support for if and only iff. Use
the symbol ↔ as an infix notation. You will
have to define a Boolean function as Lean
does not provide one for iff. Call it biff.

Here is the code as developed in class.
Now review the step-by-step instructions,
and proceed to read and midify this logic
as required. We've bracketed areas where
new material will have to be added.
-/

/-    *** SYNTAX ***    -/

inductive var : Type
| mkVar : ℕ → var

inductive unOp : Type
| notOp

inductive binOp : Type
| andOp
| orOp
| xorOp
| implOp
| iffOp

/-HW-/
-- add new binOps here

/-HW-/

inductive pExp : Type
| litExp : bool → pExp
| varExp : var → pExp
| unOpExp : unOp → pExp → pExp
| binOpExp : binOp → pExp → pExp → pExp

open var
open pExp
open unOp
open binOp

-- Shorthand notations
def pTrue := litExp tt
def pFalse := litExp ff
def pNot := unOpExp notOp
def pAnd := binOpExp andOp
def pOr := binOpExp orOp
def pXor := binOpExp xorOp
def pImpl := binOpExp implOp
def pIff := binOpExp iffOp
/-HW-/
-- Add new operator application
-- shorthands here.
/-HW-/

-- conventional notation

notation e1 ∧ e2 :=  pAnd e1 e2
notation e1 ∨ e2 :=  pOr e1 e2
notation ¬ e := pNot e
notation e1 ⊕ e2 := pXor e1 e2
notation e1 ⇒ e2 := pImpl e1 e2
notation e1 ↔ e2 := pIff e1 e2

/-HW-/
-- Add new notations here
/-HW-/

/-
    *****************
    *** SEMANTICS ***
    *****************
-/

def interpUnOp : unOp → (bool → bool)
| notOp := bnot

/-HW-/
-- Add Boolean function definitions here
/-HW-/

def bimpl : bool → bool → bool
| tt tt := tt
| tt ff := tt
| ff tt := ff
| ff ff := tt

def biff : bool → bool → bool
| tt tt := tt
| tt ff := ff
| ff tt := ff
| ff ff := tt

def interpBinOp : binOp → (bool → bool → bool)
| andOp := band
| xorOp := bxor
| orOp := bor
| implOp := bimpl
| iffOp := biff
/-HW-/
-- Add cases for new binOps here
/-HW-/

/-  *** SEMANTICS ***   -/

/-
Given a pExp and an interpretation
for the variables, compute and return
the Boolean value of the expression.
-/
def pEval : pExp → (var → bool) → bool
| (litExp b) i := b
| (varExp v) i := i v
| (unOpExp op e) i :=
    (interpUnOp op) (pEval e i)
| (binOpExp op e1 e2) i :=
     (interpBinOp op)
        (pEval e1 i)
        (pEval e2 i)

--#reduce pEval binOpExp pTrue tt
/-
Note: You are free to use pEval, if you
wish to, to check answers to some of the
questions below. It is not mandatory and
you will not be marked down for not doing
this.
-/

/-
#2. Define X, Y, and Z to be variable
expressions bound to a different variable
expression terms. Hint: Look at the
prop_logic_test.lean file to remind
yourself how we did this in class.
-/

def X : pExp := varExp (mkVar 0) -- the streets are wet
def Y : pExp := varExp (mkVar 1)
def Z : pExp := varExp (mkVar 2)

/-
#3. Here are some English language
sentences that you are to re-express
in propositional logic. Here's one
example.
-/

/-
EXAMPLE:

Formalize the following proposition,
as a formula in propositional logic:
If it's raining then it's raining.
-/

-- Use R to represent "it's raining"
def R : pExp := varExp (mkVar 4)

-- Solution here

/-
Explanation: We first choose to represent
the smaller proposition, "it's raining",
by the variable expression, R. We then
formalize the overall natural language
expression, if R then R, as the formula,
R ⇒ R.

Note: R ⇒ R can be pronounced as any of:
- if R is true then R is true
- if R then R
- the truth of R implies the truth of R
- R implies R

The second and fourth pronounciations
are the two that we prefer to use.
-/

/-
For the remaining problems, use the
variables expressions, X, Y, and Z,
as already defined. Use parentheses
if needed to group sub-expressions.
-/

/-
A.

If it's raining and the streets are
wet then it's raining.
-/

def p2 : pExp := (R ∧ X) ⇒ R

/-
B. If it's raining and the streets
are wet, then the streets are wet
and it's raining.
-/

def p3 := (R ∧ X) ⇒ (X ∧ R)

/-
C. If it's raining then if the
streets are wet then it's raining
and the streets are wet.
-/
def p4 := (R ⇒ (X ⇒ (R ∧ X)))

/-
D. If it's raining then it's
raining or the moon is made of
green cheese.
-/
def p5 := R ⇒ (R ∨ Y)

/-
E. If it's raining, then if it's
raining implies that the streets
are wet, then the streets are wet.
-/
def p6 := R ⇒ (R ⇒ X) ⇒ X

/-
#4. For each of the propositional
logic expressions below, write a truth
table and based on your result, state
whether the expression is unsatisfiable,
satisfiable but not valid, or valid.

Here's an example solution for the
expression, (X ∧ Y) ⇒ Y.

X   Y   X ∧ Y   (X ∧ Y) ⇒ Y
-   -   -----   -----------
T   T   T       T
T   F   F       T
F   T   F       T
F   F   F       T
The proposition is valid.
-/

/-
A. After each "#check" give your
answer for the specified proposition.
That is, write a truth table in a
comment and then say whether given the
proposition is valid, satisfiable but
not valid, or unsatisifiable.

Note: This expression reqires that
you  have properly specified ¬ and
⇒ as notations in our pExp language.
The errors indicated in many of the
following lines will go away once
you have these notations properly
defined.
-/

#check (X ⇒ Y) ⇒ (¬ X ⇒ ¬ Y)

/-
-- Answer here
X   Y  ¬ X ¬ Y (X ⇒ Y)     (¬ X ⇒ ¬ Y)     (X ⇒ Y) ⇒ (¬ X ⇒ ¬ Y)
____________________________________________________________
T   T   F   F     T               T               T
T   F   F   T     T               F               T
F   T   T   F     F               T               F
F   F   T   T     T               T               T

Satisfiable but not valid
-/

/-
B.
-/

#check ((X ⇒ Y) ∧ (Y ⇒ X)) ⇒ (X ⇒ Z)

/-
-- Answer here
X   Y   Z   (X ⇒ Y)  (Y ⇒ X)    ((X ⇒ Y) ∧ (Y ⇒ X))   (X ⇒ Z)   ((X ⇒ Y) ∧ (Y ⇒ X)) ⇒ (X ⇒ Z)
___________________________________________________________________________________________________
T   T   T    T          T           T                       T           T
T   T   F    T          T           T                       T           T
T   F   F    F          T           F                       F           T
F   F   F    T          T           T                       T           T
F   F   T    T          T           T                       T           T
F   T   T    T          F           F                       T           T
F   T   F    T          F           F                       T           T
T   F   T    F          T           F                       T           T

Valid
-/

/-
C.
-/

#check pFalse ⇒ (X ∧ ¬ X)

/-
-- Answer here
pFalse  X  ¬ X  (X ∧ ¬ X) pFalse ⇒ (X ∧ ¬ X)
_____________________________________________
F       T   F       F       T
F       F   T       F       T

Valid
-/

/-
D.
-/

#check pTrue ⇒ (X ∧ ¬ X)
/-
-- Answer here
pTrue   X    ¬ X    (X ∧ ¬ X)   pTrue ⇒ (X ∧ ¬ X)
__________________________________________________
T       T       F       F       F
T       F       T       F       F

Unsatisfiable
-/

/-
E.
-/

#check (X ∨ Y) ∧ X ⇒ ¬ Y

/-
-- Answer here
X   Y   ¬ Y     (X ∨ Y)     (X ∨ Y) ∧ X     (X ∨ Y) ∧ X ⇒ ¬ Y
_______________________________________________________________
T   T     F     T               T           F
T   F     T     T               T           T
F   T     T     T               F           T
F   F     T     F               T           T

Satisfiable, but not valid
-/
/-
#5.

A. Find and present an interpretation
that causes the following proposition
to be satisfied (to evaluate to true).

(X ∨ Y) ∧ (¬ Y ∨ Z)

Answer:
-/
def X: True
def Y: False
def Z: False
/-
B. Count and state how many of the
possible interpretations satisfy the
formula.

Answer: 5
-/

end prop_logic


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

universes u v
open equiv function finset fintype
variables {α : Type u} {β : Type v}

def subtype_perm (f : perm α) {p : α → Prop} (h : ∀ x, p x ↔ p (f x)) : perm {x // p x} :=
⟨λ x, ⟨f x, (h _).1 x.2⟩, λ x, ⟨f⁻¹ x, (h (f⁻¹ x)).2 $ by simpa using x.2⟩,
  λ _, by simp, λ _, by simp⟩

def of_subtype {p : α → Prop} [decidable_pred p] (f : perm (subtype p)) : perm α :=
⟨λ x, if h : p x then f ⟨x, h⟩ else x, λ x, if h : p x then f⁻¹ ⟨x, h⟩ else x,
  λ x, have h : ∀ h : p x, p (f ⟨x, h⟩), from λ h, (f ⟨x, h⟩).2,
    by simp; split_ifs at *; simp * at *,
  λ x, have h : ∀ h : p x, p (f⁻¹ ⟨x, h⟩), from λ h, (f⁻¹ ⟨x, h⟩).2,
    by simp; split_ifs at *; simp * at *⟩

instance of_subtype.is_group_hom {p : α → Prop} [decidable_pred p] : is_group_hom (@of_subtype α p _) :=
⟨λ f g, equiv.ext _ _ $ λ x, begin
  rw [of_subtype, of_subtype, of_subtype],
  by_cases h : p x,
  { have h₁ : p (f (g ⟨x, h⟩)), from (f (g ⟨x, h⟩)).2,
    have h₂ : p (g ⟨x, h⟩), from (g ⟨x, h⟩).2,
    simp [h, h₁, h₂] },
  { simp [h] }
end⟩

def is_cycle (f : perm α) := ∃ x, f x ≠ x ∧ ∀ y, f y ≠ y → ∃ i : ℤ, (f ^ i) x = y

lemma of_subtype_subtype_perm {f : perm α} {p : α → Prop} [decidable_pred p] (h₁ : ∀ x, p x ↔ p (f x))
  (h₂ : ∀ x, f x ≠ x → p x) : of_subtype (subtype_perm f h₁) = f :=
equiv.ext _ _ $ λ x, begin
  rw [of_subtype, subtype_perm],
  by_cases hx : p x,
  { simp [hx] },
  { haveI := classical.prop_decidable,
    simp [hx, not_not.1 (mt (h₂ x) hx)] }
end

namespace equiv.perm
section sign
variable [decidable_eq α]

def is_swap (f : perm α) := ∃ x y, x ≠ y ∧ f = swap x y

def support [fintype α] (f : perm α) := univ.filter (λ x, f x ≠ x)

@[simp] lemma mem_support [fintype α] {f : perm α} {x : α} : x ∈ f.support ↔ f x ≠ x :=
by simp [support]

lemma support_swap_mul {f : perm α} {x : α}
  {y : α} (hy : (swap x (f x) * f) y ≠ y) : f y ≠ y ∧ y ≠ x :=
begin
  simp only [swap_apply_def, mul_apply, injective.eq_iff f.bijective.1] at *,
  by_cases h : f y = x,
  { split; intro; simp * at * },
  { split_ifs at hy; cc }
end

def swap_factors_aux : Π (l : list α) (f : perm α), (∀ {x}, f x ≠ x → x ∈ l) →
  {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g}
| []       := λ f h, ⟨[], equiv.ext _ _ $ λ x, by rw [list.prod_nil];
    exact eq.symm (not_not.1 (mt h (list.not_mem_nil _))), by simp⟩
| (x :: l) := λ f h,
if hfx : x = f x
then swap_factors_aux l f
  (λ y hy, list.mem_of_ne_of_mem (λ h : y = x, by simpa [h, hfx.symm] using hy) (h hy))
else let m := swap_factors_aux l (swap x (f x) * f)
      (λ y hy, have f y ≠ y ∧ y ≠ x, from support_swap_mul hy,
        list.mem_of_ne_of_mem this.2 (h this.1)) in
  ⟨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],
  λ g hg, ((list.mem_cons_iff _ _ _).1 hg).elim (λ h, ⟨x, f x, hfx, h⟩) (m.2.2 _)⟩

/-- `swap_factors` 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 `trunc_swap_factors` can be used -/
def swap_factors [fintype α] [decidable_linear_order α] (f : perm α) :
  {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g} :=
swap_factors_aux ((@univ α _).sort (≤)) f (λ _ _, (mem_sort _).2 (mem_univ _))

def trunc_swap_factors [fintype α] (f : perm α) :
  trunc {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g} :=
quotient.rec_on_subsingleton (@univ α _).1
(λ l h, trunc.mk (swap_factors_aux l f h))
(show ∀ x, f x ≠ x → x ∈ (@univ α _).1, from λ _ _, mem_univ _)

lemma swap_mul_swap_mul_swap {x y z : α} (hwz: x ≠ y) (hxz : x ≠ z) :
  swap y z * swap x y * swap y z = swap z x :=
equiv.ext _ _ $ λ n, by simp only [swap_apply_def, mul_apply]; split_ifs; cc

lemma is_conj_swap {w x y z : α} (hwx : w ≠ x) (hyz : y ≠ z) : is_conj (swap w x) (swap y z) :=
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 :=
  λ 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 cc,
  ⟨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⟩

section sign_aux
variables [fintype α] [decidable_linear_order α]

/-- set of all pairs (⟨a, b⟩ : Σ a : α, α) such that b < a -/
def pairs_lt (α : Type*) [fintype α] [decidable_linear_order α] : finset (α × α) :=
(univ : finset (α × α)).filter (λ a, a.2 < a.1)

lemma mem_fin_pairs_lt {a : α × α} :
  a ∈ pairs_lt α ↔ a.2 < a.1 :=
by simp [pairs_lt]

def sign_aux (a : perm α) : units ℤ :=
(pairs_lt α).prod (λ x, if a x.1 ≤ a x.2 then -1 else 1)

@[simp] lemma sign_aux_one : sign_aux (1 : perm α) = 1 :=
begin
  unfold sign_aux,
  conv { to_rhs, rw ← @finset.prod_const_one _ (units ℤ)
    (pairs_lt α) },
  exact finset.prod_congr rfl (λ a ha, if_neg
    (not_le_of_gt (mem_fin_pairs_lt.1 ha)))
end

def sign_bij_aux (f : perm α) (a : α × α) : α × α :=
if hxa : f a.2 < f a.1 then ⟨f a.1, f a.2⟩ else ⟨f a.2, f a.1⟩

lemma sign_bij_aux_inj {f : perm α} : ∀ a b : α × α,
   a ∈ pairs_lt α → b ∈ pairs_lt α →
   sign_bij_aux f a = sign_bij_aux f b → a = b :=
λ ⟨a₁, a₂⟩ ⟨b₁, b₂⟩ ha hb h, begin
  unfold sign_bij_aux at h,
  rw mem_fin_pairs_lt at *,
  have : ¬b₁ < b₂ := not_lt_of_ge (le_of_lt hb),
  split_ifs at h;
  simp [*, injective.eq_iff f.bijective.1, sigma.mk.inj_eq] at *
end

lemma sign_bij_aux_surj {f : perm α} : ∀ a ∈ pairs_lt α,
  ∃ b ∈ pairs_lt α, a = sign_bij_aux f b :=
λ ⟨a₁, a₂⟩ ha,
if hxa : f⁻¹ a₂ < f⁻¹ a₁
then ⟨⟨f⁻¹ a₁, f⁻¹ a₂⟩, mem_fin_pairs_lt.2 hxa,
  by dsimp [sign_bij_aux];
    rw [apply_inv_self, apply_inv_self, dif_pos (mem_fin_pairs_lt.1 ha)]⟩
else ⟨⟨f⁻¹ a₂, f⁻¹ a₁⟩, mem_fin_pairs_lt.2 $ lt_of_le_of_ne
  (le_of_not_gt hxa) $ λ h,
    by simpa [mem_fin_pairs_lt, (f⁻¹).bijective.1 h, lt_irrefl] using ha,
  by dsimp [sign_bij_aux];
    rw [apply_inv_self, apply_inv_self,
      dif_neg (not_lt_of_ge (le_of_lt (mem_fin_pairs_lt.1 ha)))]⟩

lemma sign_bij_aux_mem {f : perm α} : ∀ a : α × α,
  a ∈ pairs_lt α → sign_bij_aux f a ∈ pairs_lt α :=
λ ⟨a₁, a₂⟩ ha, begin
  unfold sign_bij_aux,
  split_ifs with h,
  { exact mem_fin_pairs_lt.2 h },
  { exact mem_fin_pairs_lt.2
    (lt_of_le_of_ne (le_of_not_gt h)
      (λ h, ne_of_lt (mem_fin_pairs_lt.1 ha) (f.bijective.1 h.symm))) }
end

@[simp] lemma sign_aux_inv (f : perm α) : sign_aux f⁻¹ = sign_aux f :=
prod_bij (λ a ha, sign_bij_aux f⁻¹ a)
sign_bij_aux_mem
(λ ⟨a, b⟩ hab, if h : f⁻¹ b < f⁻¹ a
  then by rw [sign_bij_aux, dif_pos h, if_neg (not_le_of_gt h), apply_inv_self,
    apply_inv_self, if_neg (not_le_of_gt $ mem_fin_pairs_lt.1 hab)]
  else by rw [sign_bij_aux, if_pos (le_of_not_gt h), dif_neg h, apply_inv_self,
    apply_inv_self, if_pos (le_of_lt $ mem_fin_pairs_lt.1 hab)])
sign_bij_aux_inj
sign_bij_aux_surj

lemma sign_aux_mul (f g : perm α) : sign_aux (f * g) = sign_aux f * sign_aux g :=
begin
  rw ← sign_aux_inv g,
  unfold sign_aux,
  rw  ← prod_mul_distrib,
  refine prod_bij (λ a ha, sign_bij_aux g a) sign_bij_aux_mem _
    sign_bij_aux_inj sign_bij_aux_surj,
  rintros ⟨a, b⟩ hab,
  rw [sign_bij_aux, mul_apply, mul_apply],
  rw mem_fin_pairs_lt at hab,
  by_cases h : g b < g a,
  { rw dif_pos h,
    simp [not_le_of_gt hab]; congr },
  { rw [dif_neg h, inv_apply_self, inv_apply_self, if_pos (le_of_lt hab)],
    by_cases h₁ : f (g b) ≤ f (g a),
    { have : f (g b) ≠ f (g a),
      { rw [ne.def, injective.eq_iff f.bijective.1,
          injective.eq_iff g.bijective.1];
        exact ne_of_lt hab },
      rw [if_pos h₁, if_neg (not_le_of_gt  (lt_of_le_of_ne h₁ this))],
      refl },
    { rw [if_neg h₁, if_pos (le_of_lt (lt_of_not_ge h₁))],
      refl } }
end

instance sign_aux.is_group_hom : is_group_hom (@sign_aux α _ _ _) := ⟨sign_aux_mul⟩

private lemma sign_aux_swap_zero_one {n : ℕ} (hn : 2 ≤ n) :
  sign_aux (swap (⟨0, lt_of_lt_of_le dec_trivial hn⟩ : fin n)
  ⟨1, lt_of_lt_of_le dec_trivial hn⟩) = -1 :=
let zero : fin n := ⟨0, lt_of_lt_of_le dec_trivial hn⟩ in
let one : fin n := ⟨1, lt_of_lt_of_le dec_trivial hn⟩ in
have hzo : zero < one := dec_trivial,
show _ = (finset.singleton (⟨one, zero⟩ : fin n × fin n)).prod
  (λ x : fin n × fin n, if (equiv.swap zero one) x.1
  ≤ swap zero one x.2 then (-1 : units ℤ) else 1),
begin
  refine eq.symm (prod_subset (λ ⟨x₁, x₂⟩, by simp [mem_fin_pairs_lt, hzo] {contextual := tt})
    (λ a ha₁ ha₂, _)),
  rcases a with ⟨⟨a₁, ha₁⟩, ⟨a₂, ha₂⟩⟩,
  replace ha₁ : a₂ < a₁ := mem_fin_pairs_lt.1 ha₁,
  simp only [swap_apply_def],
  have : ¬ 1 ≤ a₂ → a₂ = 0, from λ h, nat.le_zero_iff.1 (nat.le_of_lt_succ (lt_of_not_ge h)),
  have : a₁ ≤ 1 → a₁ = 0 ∨ a₁ = 1, from nat.cases_on a₁ (λ _, or.inl rfl)
    (λ a₁, nat.cases_on a₁ (λ _, or.inr rfl) (λ _ h, absurd h dec_trivial)),
  split_ifs;
  simp [*, lt_irrefl, -not_lt, not_le.symm, -not_le, le_refl, fin.lt_def, fin.le_def, nat.zero_le,
    zero, one, iff.intro fin.veq_of_eq fin.eq_of_veq, nat.le_zero_iff] at *,
end

lemma sign_aux_swap : ∀ {n : ℕ} {x y : fin n} (hxy : x ≠ y), sign_aux (swap x y) = -1
| 0 := dec_trivial
| 1 := dec_trivial
| (n+2) := λ x y hxy,
have h2n : 2 ≤ n + 2 := dec_trivial,
by rw [← is_conj_iff_eq, ← sign_aux_swap_zero_one h2n];
  exact is_group_hom.is_conj _ (is_conj_swap hxy dec_trivial)

end sign_aux

def sign_aux2 : list α → perm α → units ℤ
| []     f := 1
| (x::l) f := if x = f x then sign_aux2 l f else -sign_aux2 l (swap x (f x) * f)

lemma sign_aux_eq_sign_aux2 {n : ℕ} : ∀ (l : list α) (f : perm α) (e : α ≃ fin n)
  (h : ∀ x, f x ≠ x → x ∈ l), sign_aux ((e.symm.trans f).trans e) = sign_aux2 l f
| []     f e h := have f = 1, from equiv.ext _ _ $
  λ y, not_not.1 (mt (h y) (list.not_mem_nil _)),
by rw [this, one_def, equiv.trans_refl, equiv.symm_trans, ← one_def,
  sign_aux_one, sign_aux2]
| (x::l) f e h := begin
  rw sign_aux2,
  by_cases hfx : x = f x,
  { rw if_pos hfx,
    exact sign_aux_eq_sign_aux2 l f _ (λ y (hy : f y ≠ y), list.mem_of_ne_of_mem
      (λ h : y = x, by simpa [h, hfx.symm] using hy) (h y hy) ) },
  { have hy : ∀ y : α, (swap x (f x) * f) y ≠ y → y ∈ l,
      from λ y hy, have f y ≠ y ∧ y ≠ x, from support_swap_mul 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,
      from equiv.ext _ _ (λ z, by rw ← equiv.symm_trans_swap_trans; simp [mul_def]),
    have hefx : e x ≠ e (f x), from mt (injective.eq_iff e.bijective.1).1 hfx,
    rw [if_neg hfx, ← sign_aux_eq_sign_aux2 _ _ e hy, this, sign_aux_mul, sign_aux_swap hefx],
    simp }
end

def sign_aux3 [fintype α] (f : perm α) {s : multiset α} : (∀ x, x ∈ s) → units ℤ :=
quotient.hrec_on s (λ l h, sign_aux2 l f)
  (trunc.induction_on (equiv_fin α)
    (λ e l₁ l₂ h, function.hfunext
      (show (∀ x, x ∈ l₁) = ∀ x, x ∈ l₂, by simp [list.mem_of_perm h])
      (λ h₁ h₂ _, by rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, h₁ _),
        ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, h₂ _)])))

lemma sign_aux3_mul_and_swap [fintype α] (f g : perm α) (s : multiset α) (hs : ∀ x, x ∈ s) :
  sign_aux3 (f * g) hs = sign_aux3 f hs * sign_aux3 g hs ∧ ∀ x y, x ≠ y →
  sign_aux3 (swap x y) hs = -1 :=
let ⟨l, hl⟩ := quotient.exists_rep s in
let ⟨e, _⟩ := trunc.exists_rep (equiv_fin α) in
begin
  clear _let_match _let_match,
  subst hl,
  show sign_aux2 l (f * g) = sign_aux2 l f * sign_aux2 l g ∧
    ∀ x y, x ≠ y → sign_aux2 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,
    from equiv.ext _ _ (λ h, by simp [mul_apply]),
  split,
  { rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _),
      ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), hfg, sign_aux_mul] },
  { assume x y hxy,
    have hexy : e x ≠ e y, from mt (injective.eq_iff e.bijective.1).1 hxy,
    rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), equiv.symm_trans_swap_trans, sign_aux_swap hexy] }
end

/-- `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 α] (f : perm α) := sign_aux3 f mem_univ

instance sign.is_group_hom [fintype α] : is_group_hom (@sign α _ _) :=
⟨λ f g, (sign_aux3_mul_and_swap f g _ mem_univ).1⟩

lemma sign_swap [fintype α] {x y : α} (h : x ≠ y) : sign (swap x y) = -1 :=
(sign_aux3_mul_and_swap 1 1 _ mem_univ).2 x y h

@[simp] lemma sign_mul [fintype α] (f g : perm α) : sign (f * g) = sign f * sign g :=
is_group_hom.mul sign _ _

lemma units_int_inv_eq_self : ∀ u : units ℤ, u⁻¹ = u := dec_trivial

@[simp] lemma sign_inv [fintype α] (f : perm α) : sign f⁻¹ = sign f :=
(is_group_hom.inv sign f).symm ▸ units_int_inv_eq_self _

@[simp] lemma sign_one [fintype α] : sign (1 : perm α) = 1 :=
is_group_hom.one _

lemma sign_eq_of_is_swap [fintype α] {f : perm α} (h : is_swap f) : sign f = -1 :=
let ⟨x, y, hxy⟩ := h in hxy.2.symm ▸ sign_swap hxy.1

lemma sign_eq_pow_length_swap_factors [fintype α] {f : perm α} {l : list (perm α)}
  (h : l.prod = f) (hl : ∀ g ∈ l, is_swap g) : sign f = -1 ^ l.length :=
have h₁ : l.map sign = list.repeat (-1) l.length :=
  list.eq_repeat.2 ⟨by simp, λ u hu,
  let ⟨g, hg⟩ := list.mem_map.1 hu in
  hg.2 ▸ sign_eq_of_is_swap (hl _ hg.1)⟩,
by rw [← list.prod_repeat, ← h₁, ← is_group_hom.prod (@sign α _ _), h]

lemma sign_symm_trans_trans [fintype α] [decidable_eq β] [fintype β] (f : perm α)
  (e : α ≃ β) : sign ((e.symm.trans f).trans e) = sign f :=
show sign_aux3 ((e.symm.trans f).trans e) (show ∀ x : β, x ∈ univ.1, from mem_univ) =
  sign_aux3 f (show ∀ x : α, x ∈ univ.1, from mem_univ),
from quotient.induction_on₂ (@univ β _).1 (@univ α _).1
  (λ l₁ l₂ h₁ h₂, show sign_aux2 _ _ = sign_aux2 _ _,
    from let n := trunc.out (equiv_fin β) in
    by rw [← sign_aux_eq_sign_aux2 _ _ n (λ _ _, h₁ _),
        ← sign_aux_eq_sign_aux2 _ _ (e.trans n) (λ _ _, h₂ _)];
      exact congr_arg sign_aux (equiv.ext _ _ (λ x, by simp)))
(show ∀ x : β, x ∈ univ.1, from mem_univ)
(show ∀ x : α, x ∈ univ.1, from mem_univ)

lemma eq_sign_of_surjective_hom [fintype α] {s : perm α → units ℤ}
  [is_group_hom s] (hs : surjective s) : s = sign :=
have ∀ {f}, is_swap f → s f = -1 :=
  λ f ⟨x, y, hxy, hxy'⟩, hxy'.symm ▸ by_contradiction (λ h,
    have ∀ f, is_swap f → s f = 1 := λ f ⟨a, b, hab, hab'⟩,
      by rw [← is_conj_iff_eq, ← or.resolve_right (int.units_eq_one_or _) h, hab'];
        exact is_group_hom.is_conj _ (is_conj_swap hab hxy),
  let ⟨g, hg⟩ := hs (-1) in
  let ⟨l, hl⟩ := trunc.out (trunc_swap_factors g) in
  have ∀ a ∈ l.map s, a = (1 : units ℤ) := λ a ha,
    let ⟨g, hg⟩ := list.mem_map.1 ha in hg.2 ▸ this _ (hl.2 _ hg.1),
  have s l.prod = 1,
    by rw [is_group_hom.prod s, list.eq_repeat'.2 this, list.prod_repeat, one_pow],
  by rw [hl.1, hg] at this;
    exact absurd this dec_trivial),
funext $ λ f,
let ⟨l, hl₁, hl₂⟩ := trunc.out (trunc_swap_factors f) in
have hsl : ∀ a ∈ l.map s, a = (-1 : units ℤ) := λ a ha,
  let ⟨g, hg⟩ := list.mem_map.1 ha in hg.2 ▸  this (hl₂ _ hg.1),
by rw [← hl₁, is_group_hom.prod s, list.eq_repeat'.2 hsl, list.length_map,
     list.prod_repeat, hl₁, sign_eq_pow_length_swap_factors hl₁ hl₂]

lemma prod_units_eq_pow_card_neg_one {s : finset α} (f : α → units ℤ) :
  s.prod f = -1 ^ (s.filter (λ a, f a = -1)).card :=
by rw [← finset.prod_const];
  exact eq.symm (prod_bij_ne_one (λ a _ _, a) (by finish) (by simp)
    (λ b _ h, ⟨b, by simp [or.resolve_left (int.units_eq_one_or (f b)) h, *,
      show (-1 : units ℤ) ≠ 1, from dec_trivial]⟩) (by simp {contextual := tt}))

instance [subsingleton α] : subsingleton (perm α) :=
⟨λ _ _, equiv.ext _ _ $ λ _, subsingleton.elim _ _⟩

lemma sign_eq_pow_card_inversions [decidable_linear_order α] [fintype α] (f : perm α) :
  sign f = -1 ^ ((pairs_lt α).filter (λ a : α × α, a.1 ≤ a.2)).card := sorry

lemma is_swap_of_subtype [decidable_eq α] {p : α → Prop} [decidable_pred p]
  {f : perm (subtype p)} (h : is_swap f) : is_swap (of_subtype f) :=
let ⟨⟨x, hx⟩, ⟨y, hy⟩, hxy⟩ := h in
⟨x, y, by simp at hxy; tauto,
  equiv.ext _ _ $ λ z, begin
    rw [hxy.2, of_subtype],
    simp [swap_apply_def],
    split_ifs;
    cc <|> simp * at *
  end⟩

lemma int.units_pow_eq_pow_mod_two (u : units ℤ) (n : ℕ) : u ^ n = u ^ (n % 2) :=
(int.units_eq_one_or u).elim (λ h, by simp *)
  (λ h, by conv {to_lhs, rw [← nat.mod_add_div n 2, pow_add, pow_mul, h, pow_two]};
          simp [h])

lemma sign_subtype_perm [fintype α] [decidable_eq α] (f : perm α) {p : α → Prop} [decidable_pred p]
  (h₁ : ∀ x, p x ↔ p (f x)) (h₂ : ∀ x, f x ≠ x → p x) : sign (subtype_perm f h₁) = sign f :=
let l := trunc.out (trunc_swap_factors (subtype_perm f h₁)) in
have hl' : ∀ g' ∈ l.1.map of_subtype, is_swap g' :=
  λ g' hg',
  let ⟨g, hg⟩ := list.mem_map.1 hg' in
  hg.2 ▸ is_swap_of_subtype (l.2.2 _ hg.1),
have hl'₂ : (l.1.map of_subtype).prod = f,
  by rw [← is_group_hom.prod of_subtype l.1, l.2.1, of_subtype_subtype_perm _ h₂],
by rw [sign_eq_pow_length_swap_factors l.2.1 l.2.2, sign_eq_pow_length_swap_factors hl'₂ hl'];
  simp

lemma is_cycle_swap {x y : α} (hxy : x ≠ y) : is_cycle (swap x y) :=
⟨y, by rwa swap_apply_right,
λ a (ha : ite (a = x) y (ite (a = y) x a) ≠ a),
if hya : y = a then ⟨0, hya⟩
  else ⟨1, by rw [gpow_one, swap_apply_def]; split_ifs at *; cc⟩⟩

lemma eq_inv_iff_eq {f : perm α} {x y : α} : x = f⁻¹ y ↔ f x = y :=
by conv {to_lhs, rw [← injective.eq_iff f.bijective.1, apply_inv_self]}

lemma inv_eq_iff_eq {f : perm α} {x y : α} : f⁻¹ x =  y ↔ x = f y :=
by rw [eq_comm, eq_inv_iff_eq, eq_comm]

lemma is_cycle_inv {f : perm α} (hf : is_cycle f) : is_cycle (f⁻¹) :=
let ⟨x, hx⟩ := hf in
⟨x, by simp [eq_inv_iff_eq, inv_eq_iff_eq, *] at *; cc,
  λ y hy, let ⟨i, hi⟩ := hx.2 y (by simp [eq_inv_iff_eq, inv_eq_iff_eq, *] at *; cc) in
  ⟨-i, by rwa [gpow_neg, inv_gpow, inv_inv]⟩⟩

lemma swap_mul (f : perm α) (x y : α) : swap x y * f = f * swap (f⁻¹ x) (f⁻¹ y) :=
equiv.ext _ _ $ λ z, begin
  simp [mul_apply, swap_apply_def],
  split_ifs;
  simp [*, eq_inv_iff_eq] at * <|> cc
end

lemma mul_swap (f : perm α) (x y : α) : f * swap x y = swap (f x) (f y) * f :=
by rw [swap_mul, inv_apply_self, inv_apply_self]

lemma swap_mul_pow : ∀ (n : ℤ) {b x : α} {f : perm α} (hf : is_cycle f)
  (hb : (swap x (f x) * f) b ≠ b)
  (h : (f ^ n) (f x) = b), ∃ i : ℤ, ((swap x (f x) * f) ^ i) (f x) = b
| 0         := λ b x f hf hb h, ⟨0, h⟩
| (n+1 : ℕ) := λ b x f hf hb h,
  if hfbx : f x = b then ⟨0, hfbx⟩ else
  have f b ≠ b ∧ b ≠ x := support_swap_mul hb,
  have hb : (swap x (f x) * f) (f⁻¹ b) ≠ f⁻¹ b,
    by rw [mul_apply, apply_inv_self, swap_apply_of_ne_of_ne this.2 (ne.symm hfbx),
        ne.def, ← injective.eq_iff f.bijective.1, apply_inv_self];
      exact this.1,
  have wf : n < int.nat_abs (1 + ↑n),
    by rw [add_comm, ← int.coe_nat_one, ← int.coe_nat_add, int.nat_abs_of_nat];
    exact nat.lt_succ_self n,
  let ⟨i, hi⟩ := swap_mul_pow n hf hb
    (f.bijective.1 $ by
      rw [apply_inv_self];
      rwa [gpow_coe_nat, pow_succ, mul_apply] at h) in
  ⟨i + 1, by rw [add_comm, gpow_add, mul_apply, hi, gpow_one, mul_apply, apply_inv_self,
      swap_apply_of_ne_of_ne this.2 (ne.symm hfbx)]⟩
| -[1+ n] := λ b x f hf hb h,
  if hfbx : f⁻¹ x = b then ⟨-1, by rwa [gpow_neg, gpow_one, mul_inv_rev, mul_apply, swap_inv, swap_apply_right]⟩
  else if hfbx' : f x = b then ⟨0, hfbx'⟩
  else
  have f b ≠ b ∧ b ≠ x := support_swap_mul hb,
  have hb : (swap x (f⁻¹ x) * f⁻¹) (f⁻¹ b) ≠ f⁻¹ b,
    by rw [mul_apply, swap_apply_def];
      split_ifs;
      simp [inv_eq_iff_eq, eq_inv_iff_eq] at *; cc,
  have wf : n < n.succ, from nat.lt_succ_self n,
  let ⟨i, hi⟩ := swap_mul_pow n (is_cycle_inv hf) hb
    (show (f⁻¹ ^ ↑n) (f⁻¹ x) = f⁻¹ b, by
      rw [← h, ← mul_apply, ← mul_apply, ← mul_apply, gpow_neg_succ, ← inv_pow, pow_succ', mul_assoc,
        mul_assoc, inv_mul_self, mul_one, gpow_coe_nat, ← pow_succ', ← pow_succ]) in
  have h : (swap x (f⁻¹ x) * f⁻¹) (f x) = f⁻¹ x, by rw [mul_apply, inv_apply_self, swap_apply_left],
  ⟨-i, by rw [← add_sub_cancel i 1, neg_sub, sub_eq_add_neg, gpow_add, gpow_one, gpow_neg, ← inv_gpow,
      mul_inv_rev, swap_inv, mul_swap, inv_apply_self, swap_comm _ x, gpow_add, gpow_one,
      mul_apply, mul_apply (_ ^ i), h, hi, mul_apply, apply_inv_self, swap_apply_of_ne_of_ne this.2 (ne.symm hfbx')]⟩
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf int.nat_abs⟩]}

lemma eq_swap_of_is_cycle_of_apply_apply_eq_self {f : perm α} (hf : is_cycle f) {x : α}
  (hfx : f x ≠ x) (hffx : f (f x) = x) : f = swap x (f x) :=
equiv.ext _ _ $ λ y,
have ∀ n : ℕ, (f ^ n) x = x ∨ (f ^ n) x = f x :=
  λ n, nat.rec_on n (or.inl rfl)
    (λ n ih, ih.elim (λ h, or.inr (by rw [pow_succ, mul_apply, h]))
      (λ h, or.inl (by rw [pow_succ, mul_apply, h, hffx]))),
have ∀ i : ℤ, (f ^ i) x = x ∨ (f ^ i) x = f x :=
  λ i, int.rec_on i this (λ n, by
  by rw [gpow_neg_succ, inv_eq_iff_eq, ← injective.eq_iff f.bijective.1, ← mul_apply, ← pow_succ,
    eq_comm, inv_eq_iff_eq, ← mul_apply, ← pow_succ', @eq_comm _ x, or.comm];
    exact this _),
let ⟨z, hz⟩ := hf in
let ⟨i, hi⟩ := hz.2 x hfx in
if hyx : y = x then by simp [hyx]
else if hfyx : y = f x then by simp [hfyx, hffx]
else begin
  rw [swap_apply_of_ne_of_ne hyx hfyx],
  refine by_contradiction (λ hy, _),
  cases hz.2 y hy with j hj,
  rw [← sub_add_cancel j i, gpow_add, mul_apply, hi] at hj,
  cases this (j - i) with hji hji,
  { rw [← hj, hji] at hyx, cc },
  { rw [← hj, hji] at hfyx, cc }
end

lemma is_cycle_swap_mul {f : perm α} (hf : is_cycle f) {x : α}
  (hx : f x ≠ x ∧ ∀ y, f y ≠ y → ∃ i : ℤ, (f ^ i) x = y) :
  is_cycle (swap x (f x) * f) ∨ swap x (f x) * f = 1 :=
if hffx : f (f x) = x
then or.inr $ calc
  swap x (f x) * f = swap x (f x) * swap x (f x) :
    by rw ← eq_swap_of_is_cycle_of_apply_apply_eq_self hf hx.1 hffx
  ... = 1 : swap_swap _ _
else or.inl
  ⟨f x, by simp only [swap_apply_def, mul_apply];
          split_ifs; simp [injective.eq_iff f.bijective.1] at *; cc,
    λ y hy,
    let ⟨i, hi⟩ := hx.2 _ (support_swap_mul hy).1 in
    have hi : (f ^ (i - 1)) (f x) = y, from
      calc (f ^ (i - 1)) (f x) = (f ^ (i - 1) * f ^ (1 : ℤ)) x : by rw [gpow_one, mul_apply]
      ... =  y : by rwa [← gpow_add, sub_add_cancel],
    swap_mul_pow (i-1) hf hy hi⟩

lemma support_swap_mul_cycle [fintype α] {f : perm α} (hf : is_cycle f) {x : α}
  (hx : f x ≠ x ∧ ∀ y, f y ≠ y → ∃ i : ℤ, (f ^ i) x = y) :
  (swap x (f x) * f).support = f.support.erase x ∨ swap x (f x) * f = 1 :=
or_iff_not_imp_right.2 (λ h1, finset.ext.2 $ λ y, begin
  have hfyxor : f y ≠ x ∨ f x ≠ y :=
    not_and_distrib.1 (λ h, h1 $
      by have := eq_swap_of_is_cycle_of_apply_apply_eq_self hf hx.1 (by rw [h.2, h.1]);
      rw [← this, this, mul_def, swap_swap, one_def]),
  rw [mem_support, mem_erase, mem_support],
  split,
  { assume h,
    refine not_or_distrib.1 (λ h₁, h₁.elim
      (λ hyx, by simpa [hyx, mul_apply] using h) _),
    assume hfy,
    have hyx : x ≠ y := λ h, by rw h at hx; tauto,
    have hfyx : f x ≠ y := by rwa [← hfy, ne.def, injective.eq_iff f.bijective.1],
    simpa [mul_apply, hfy, swap_apply_of_ne_of_ne hyx.symm hfyx.symm] using h },
  { assume h,
    simp [swap_apply_def],
    split_ifs; cc }
end)

lemma support_swap [fintype α] {x y : α} (hxy : x ≠ y) : (swap x y).support = {x, y} :=
finset.ext.2 $ λ a, by simp [swap_apply_def]; split_ifs; cc

@[simp] lemma card_support_swap [fintype α] {x y : α} (hxy : x ≠ y) : (swap x y).support.card = 2 :=
show (swap x y).support.card = finset.card ⟨x::y::0, by simp [hxy]⟩,
from congr_arg card $ by rw [support_swap hxy]; simp [*, finset.ext]; cc

lemma sign_cycle [fintype α] : ∀ {f : perm α} (hf : is_cycle f),
  sign f = -1 ^ (f.support.card + 1)
| f := λ hf,
let ⟨x, hx⟩ := hf in
calc sign f = sign (swap x (f x) * (swap x (f x) * f)) :
by rw [← mul_assoc, mul_def, mul_def, swap_swap, trans_refl]
... = -1 ^ (f.support.card + 1) :
if h1 : (swap x (f x) * f) = 1 then
have h : f = swap x (f x),
  by rwa [mul_eq_one_iff_inv_eq, swap_inv, eq_comm] at h1,
by rw [sign_mul, sign_swap hx.1.symm, h1, sign_one, h, card_support_swap hx.1.symm]; refl
else
  have h : card (support (swap x (f x) * f)) + 1 = card (support f),
    by rw [← insert_erase (mem_support.2 hx.1), or.resolve_right (support_swap_mul_cycle hf hx) h1,
      card_insert_of_not_mem (not_mem_erase _ _)],
  have wf : card (support (swap x (f x) * f)) < card (support f),
    from h ▸ nat.lt_succ_self _,
  by rw [sign_mul, sign_swap hx.1.symm, sign_cycle (or.resolve_right (is_cycle_swap_mul hf hx) h1), h];
    simp [pow_add]
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ f, f.support.card)⟩]}

end sign

end equiv.perm


/-
Copyright © 2021 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri, Heather Macbeth
-/

import geometry.manifold.smooth_manifold_with_corners
import analysis.normed_space.units

/-!
# Units of a normed algebra

This file is a stub, containing a construction of the charted space structure on the group of units
of a complete normed ring `R`, and of the smooth manifold structure on the group of units of a
complete normed `𝕜`-algebra `R`.

This manifold is actually a Lie group, which eventually should be the main result of this file.

An important special case of this construction is the general linear group.  For a normed space `V`
over a field `𝕜`, the `𝕜`-linear endomorphisms of `V` are a normed `𝕜`-algebra (see
`continuous_linear_map.to_normed_algebra`), so this construction provides a Lie group structure on
its group of units, the general linear group GL(`𝕜`, `V`).

## TODO

The Lie group instance requires the following fields:
```
instance : lie_group 𝓘(𝕜, R) (units R) :=
{ smooth_mul := sorry,
  smooth_inv := sorry,
  ..units.smooth_manifold_with_corners }
```

The ingredients needed for the construction are
* smoothness of multiplication and inversion in the charts, i.e. as functions on the normed
  `𝕜`-space `R`:  see `times_cont_diff_at_ring_inverse` for the inversion result, and
  `times_cont_diff_mul` (needs to be generalized from field to algebra) for the multiplication
  result
* for an open embedding `f`, whose domain is equipped with the induced manifold structure
  `f.singleton_smooth_manifold_with_corners`, characterization of smoothness of functions to/from
  this manifold in terms of smoothness in the target space.  See the pair of lemmas
  `times_cont_mdiff_coe_sphere` and `times_cont_mdiff.cod_restrict_sphere` for a model.
None of this should be particularly difficult.

-/

noncomputable theory

open_locale manifold

namespace units

variables {R : Type*} [normed_ring R] [complete_space R]

instance : charted_space R (units R) := open_embedding_coe.singleton_charted_space

lemma chart_at_apply {a : units R} {b : units R} : chart_at R a b = b := rfl
lemma chart_at_source {a : units R} : (chart_at R a).source = set.univ := rfl

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜] [normed_algebra 𝕜 R]

instance : smooth_manifold_with_corners 𝓘(𝕜, R) (units R) :=
open_embedding_coe.singleton_smooth_manifold_with_corners 𝓘(𝕜, R)

end units


import classes.context_sensitive.basics.toolbox
import classes.unrestricted.basics.toolbox

variables {T : Type}

def grammar_of_csg (g : CS_grammar T) : grammar T :=
grammar.mk g.nt g.initial (list.map
  (λ r : csrule T g.nt, grule.mk
    r.context_left r.input_nonterminal r.context_right
    (r.context_left ++ r.output_string ++ r.context_right)
  ) g.rules)

lemma CS_language_eq_grammar_language (g : CS_grammar T) :
  CS_language g = grammar_language (grammar_of_csg g) :=
begin
  unfold CS_language,
  unfold grammar_language,
  ext1 w,
  rw set.mem_set_of_eq,
  split,
  {
    have indu :
      ∀ v : list (symbol T g.nt),
        CS_derives g [symbol.nonterminal g.initial] v →
          grammar_derives (grammar_of_csg g) [symbol.nonterminal (grammar_of_csg g).initial] v,
    {
      clear w,
      intros v h,
      induction h with x y trash hyp ih,
      {
        apply grammar_deri_self,
      },
      apply grammar_deri_of_deri_tran,
      {
        exact ih,
      },
      unfold CS_transforms at hyp,
      unfold grammar_transforms,
      delta grammar_of_csg,
      dsimp only,
      rcases hyp with ⟨r, rin, u, w, bef, aft⟩,
      use grule.mk
        r.context_left r.input_nonterminal r.context_right
        (r.context_left ++ r.output_string ++ r.context_right),
      split,
      {
        rw list.mem_map,
        use r,
        split,
        {
          exact rin,
        },
        {
          refl,
        },
      },
      use u,
      use w,
      split,
      {
        exact bef,
      },
      simpa [list.append_assoc] using aft,
    },
    exact indu (list.map symbol.terminal w),
  },
  {
    have indu :
      ∀ v : list (symbol T g.nt),
        grammar_derives (grammar_of_csg g) [symbol.nonterminal (grammar_of_csg g).initial] v →
          CS_derives g [symbol.nonterminal g.initial] v,
    {
      clear w,
      intros v h,
      induction h with x y trash hyp ih,
      {
        apply CS_deri_self,
      },
      apply CS_deri_of_deri_tran,
      {
        exact ih,
      },
      unfold grammar_transforms at hyp,
      unfold CS_transforms,
      delta grammar_of_csg at hyp,
      dsimp only at hyp,
      rcases hyp with ⟨r, rin, u, w, bef, aft⟩,
      rw list.mem_map at rin,
      rcases rin with ⟨r', new_rule_in, new_rule_def⟩,
      use r',
      split,
      {
        exact new_rule_in,
      },
      use u,
      use w,
      split,
      {
        rw ←new_rule_def at bef,
        exact bef,
      },
      {
        rw ←new_rule_def at aft,
        simpa [list.append_assoc] using aft,
      },
    },
    exact indu (list.map symbol.terminal w),
  },
end

theorem CS_subclass_RE {L : language T} :
  is_CS L → is_RE L :=
begin
  rintro ⟨g, eq_L⟩,
  use grammar_of_csg g,
  rw ←eq_L,
  rw CS_language_eq_grammar_language,
end


/-
Chapter 2: Connectives: And & If
Author: Billy Price
-/
import definitions

namespace nat_deduction

variables {p q r : ℕ}
variable {X : set Form}

example : {p ⟹ q, r ⟹ p, r} ≻ q :=
begin
  apply ⟹E p, assump,
  apply ⟹E r, assump,
  assump
end

example : {p ⟹ q, r ⟹ p} ≻ r ⟹ q :=
begin
  apply ⟹I,
  apply ⟹E p, assump,
  apply ⟹E r, assump,
  assump
end

example : {p ⟹ q} ≻ (r ⟹ p) ⟹ (r ⟹ q) :=
begin
  apply_rules [⟹I],
  apply ⟹E p, assump,
  apply ⟹E r, assump,
  assump
end

example : {p} ≻ q ⟹ (p ⋀ q) :=
begin
  apply ⟹I,
  apply ⋀I; assump
end

example : {p ⋀ (q ⟹ r)} ≻ q ⟹ (p ⋀ r) :=
begin
  apply ⟹I,
  apply ⋀I,
  apply ⋀E₁, assump,
  apply ⟹E q,
  apply ⋀E₂, assump,
  assump
end

variables {A B C : Form}

def and_comm : X ≻ (A ⋀ B ) → X ≻ (B ⋀ A) :=
λ dAB, ⋀I (⋀E₂ _ _ dAB) (⋀E₁ _ _ dAB)

def imp_and : X ≻ A ⟹ B → X ≻ A ⟹ C → X ≻ A ⟹ (B ⋀ C) :=
begin
  intros dAB dAC,
  apply ⟹I,
  apply ⋀I; apply ⟹E A,
  exact weaken_union_right dAB,
  assump,
  exact weaken_union_right dAC,
  assump
end

def imp_trans : X ≻ A ⟹ B → X ≻ B ⟹ C → X ≻ A ⟹ C :=
begin
  intros dAB dBC,
  apply ⟹I,
  apply ⟹E B,
  exact weaken_union_right dBC,
  apply ⟹E A,
  apply weaken_union_right dAB,
  assump
end

def imp_import : X ≻ A ⟹ (B ⟹ C) → X ≻ (A ⋀ B) ⟹ C :=
begin
  intro dABC,
  apply ⟹I,
  apply ⟹E B,
  apply ⟹E A,
  exact weaken_union_right dABC,
  apply ⋀E₁ A B, assump,
  apply ⋀E₂ A B, assump
end

def imp_export : X ≻ (A ⋀ B) ⟹ C → X ≻ A ⟹ (B ⟹ C) :=
begin
  intro dAB_C,
  apply_rules [⟹I],
  apply ⟹E (A ⋀ B),
  rw set.union_assoc,
  exact weaken_union_right dAB_C,
  apply ⋀I; assump
end

def contraction : X ≻ A ⟹ (A ⟹ B) → X ≻ A ⟹ B :=
begin
  intro dAAB,
  apply ⟹I,
  apply ⟹E A,
  apply ⟹E A,
  exact weaken_union_right dAAB,
  all_goals {assump}
end

end nat_deduction


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

Zorn's lemmas.

Ported from Isabelle/HOL (written by Jacques D. Fleuriot, Tobias Nipkow, and Christian Sternagel).
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.lattice
import Mathlib.PostPort

universes u u_1 u_2

namespace Mathlib

namespace zorn

/-- A chain is a subset `c` satisfying
  `x ≺ y ∨ x = y ∨ y ≺ x` for all `x y ∈ c`. -/
def chain {α : Type u} (r : α → α → Prop) (c : set α) :=
  set.pairwise_on c fun (x y : α) => r x y ∨ r y x

theorem chain.total_of_refl {α : Type u} {r : α → α → Prop} [is_refl α r] {c : set α} (H : chain r c) {x : α} {y : α} (hx : x ∈ c) (hy : y ∈ c) : r x y ∨ r y x :=
  dite (x = y) (fun (e : x = y) => Or.inl (e ▸ refl x)) fun (e : ¬x = y) => H x hx y hy e

theorem chain.mono {α : Type u} {r : α → α → Prop} {c : set α} {c' : set α} : c' ⊆ c → chain r c → chain r c' :=
  set.pairwise_on.mono

theorem chain.directed_on {α : Type u} {r : α → α → Prop} [is_refl α r] {c : set α} (H : chain r c) : directed_on r c := sorry

theorem chain_insert {α : Type u} {r : α → α → Prop} {c : set α} {a : α} (hc : chain r c) (ha : ∀ (b : α), b ∈ c → b ≠ a → r a b ∨ r b a) : chain r (insert a c) := sorry

/-- `super_chain c₁ c₂` means that `c₂ is a chain that strictly includes `c₁`. -/
def super_chain {α : Type u} {r : α → α → Prop} (c₁ : set α) (c₂ : set α) :=
  chain r c₂ ∧ c₁ ⊂ c₂

/-- A chain `c` is a maximal chain if there does not exists a chain strictly including `c`. -/
def is_max_chain {α : Type u} {r : α → α → Prop} (c : set α) :=
  chain r c ∧ ¬∃ (c' : set α), super_chain c c'

/-- Given a set `c`, if there exists a chain `c'` strictly including `c`, then `succ_chain c`
is one of these chains. Otherwise it is `c`. -/
def succ_chain {α : Type u} {r : α → α → Prop} (c : set α) : set α :=
  dite (∃ (c' : set α), chain r c ∧ super_chain c c')
    (fun (h : ∃ (c' : set α), chain r c ∧ super_chain c c') => classical.some h)
    fun (h : ¬∃ (c' : set α), chain r c ∧ super_chain c c') => c

theorem succ_spec {α : Type u} {r : α → α → Prop} {c : set α} (h : ∃ (c' : set α), chain r c ∧ super_chain c c') : super_chain c (succ_chain c) := sorry

theorem chain_succ {α : Type u} {r : α → α → Prop} {c : set α} (hc : chain r c) : chain r (succ_chain c) := sorry

theorem super_of_not_max {α : Type u} {r : α → α → Prop} {c : set α} (hc₁ : chain r c) (hc₂ : ¬is_max_chain c) : super_chain c (succ_chain c) := sorry

theorem succ_increasing {α : Type u} {r : α → α → Prop} {c : set α} : c ⊆ succ_chain c := sorry

/-- Set of sets reachable from `∅` using `succ_chain` and `⋃₀`. -/
inductive chain_closure {α : Type u} {r : α → α → Prop} : set α → Prop
where
| succ : ∀ {s : set α}, chain_closure s → chain_closure (succ_chain s)
| union : ∀ {s : set (set α)}, (∀ (a : set α), a ∈ s → chain_closure a) → chain_closure (⋃₀s)

theorem chain_closure_empty {α : Type u} {r : α → α → Prop} : chain_closure ∅ := sorry

theorem chain_closure_closure {α : Type u} {r : α → α → Prop} : chain_closure (⋃₀chain_closure) :=
  chain_closure.union fun (s : set α) (hs : s ∈ chain_closure) => hs

theorem chain_closure_total {α : Type u} {r : α → α → Prop} {c₁ : set α} {c₂ : set α} (hc₁ : chain_closure c₁) (hc₂ : chain_closure c₂) : c₁ ⊆ c₂ ∨ c₂ ⊆ c₁ :=
  (fun (this : c₁ ⊆ c₂ ∨ succ_chain c₂ ⊆ c₁) =>
      or.imp_right (fun (this : succ_chain c₂ ⊆ c₁) => set.subset.trans succ_increasing this) this)
    (chain_closure_succ_total_aux hc₁ hc₂ fun (c₃ : set α) (hc₃ : chain_closure c₃) => chain_closure_succ_total hc₃ hc₂)

theorem chain_closure_succ_fixpoint {α : Type u} {r : α → α → Prop} {c₁ : set α} {c₂ : set α} (hc₁ : chain_closure c₁) (hc₂ : chain_closure c₂) (h_eq : succ_chain c₂ = c₂) : c₁ ⊆ c₂ := sorry

theorem chain_closure_succ_fixpoint_iff {α : Type u} {r : α → α → Prop} {c : set α} (hc : chain_closure c) : succ_chain c = c ↔ c = ⋃₀chain_closure := sorry

theorem chain_chain_closure {α : Type u} {r : α → α → Prop} {c : set α} (hc : chain_closure c) : chain r c := sorry

/-- `max_chain` is the union of all sets in the chain closure. -/
def max_chain {α : Type u} {r : α → α → Prop} : set α :=
  ⋃₀chain_closure

/-- Hausdorff's maximality principle

There exists a maximal totally ordered subset of `α`.
Note that we do not require `α` to be partially ordered by `r`. -/
theorem max_chain_spec {α : Type u} {r : α → α → Prop} : is_max_chain max_chain := sorry

/-- Zorn's lemma

If every chain has an upper bound, then there is a maximal element -/
theorem exists_maximal_of_chains_bounded {α : Type u} {r : α → α → Prop} (h : ∀ (c : set α), chain r c → ∃ (ub : α), ∀ (a : α), a ∈ c → r a ub) (trans : ∀ {a b c : α}, r a b → r b c → r a c) : ∃ (m : α), ∀ (a : α), r m a → r a m := sorry

theorem zorn_partial_order {α : Type u} [partial_order α] (h : ∀ (c : set α), chain LessEq c → ∃ (ub : α), ∀ (a : α), a ∈ c → a ≤ ub) : ∃ (m : α), ∀ (a : α), m ≤ a → a = m := sorry

theorem zorn_partial_order₀ {α : Type u} [partial_order α] (s : set α) (ih : ∀ (c : set α) (H : c ⊆ s), chain LessEq c → ∀ (y : α) (H : y ∈ c), ∃ (ub : α), ∃ (H : ub ∈ s), ∀ (z : α), z ∈ c → z ≤ ub) (x : α) (hxs : x ∈ s) : ∃ (m : α), ∃ (H : m ∈ s), x ≤ m ∧ ∀ (z : α), z ∈ s → m ≤ z → z = m := sorry

theorem zorn_subset {α : Type u} (S : set (set α)) (h : ∀ (c : set (set α)) (H : c ⊆ S),
  chain has_subset.subset c → ∃ (ub : set α), ∃ (H : ub ∈ S), ∀ (s : set α), s ∈ c → s ⊆ ub) : ∃ (m : set α), ∃ (H : m ∈ S), ∀ (a : set α), a ∈ S → m ⊆ a → a = m := sorry

theorem zorn_subset₀ {α : Type u} (S : set (set α)) (H : ∀ (c : set (set α)) (H : c ⊆ S),
  chain has_subset.subset c → set.nonempty c → ∃ (ub : set α), ∃ (H : ub ∈ S), ∀ (s : set α), s ∈ c → s ⊆ ub) (x : set α) (hx : x ∈ S) : ∃ (m : set α), ∃ (H : m ∈ S), x ⊆ m ∧ ∀ (a : set α), a ∈ S → m ⊆ a → a = m := sorry

theorem chain.total {α : Type u} [preorder α] {c : set α} (H : chain LessEq c) {x : α} {y : α} : x ∈ c → y ∈ c → x ≤ y ∨ y ≤ x :=
  chain.total_of_refl H

theorem chain.image {α : Type u_1} {β : Type u_2} (r : α → α → Prop) (s : β → β → Prop) (f : α → β) (h : ∀ (x y : α), r x y → s (f x) (f y)) {c : set α} (hrc : chain r c) : chain s (f '' c) := sorry

end zorn

theorem directed_of_chain {α : Type u_1} {β : Type u_2} {r : β → β → Prop} [is_refl β r] {f : α → β} {c : set α} (h : zorn.chain (f ⁻¹'o r) c) : directed r fun (x : Subtype fun (a : α) => a ∈ c) => f ↑x := sorry