/-
Copyright (c) 2021 Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Damiano Testa
-/
import group_theory.group_action.defs
import algebra.group_power.basic

/-!
# Introduce `smul_with_zero`

In analogy with the usual monoid action on a Type `M`, we introduce an action of a
`monoid_with_zero` on a Type with `0`.

In particular, for Types `R` and `M`, both containing `0`, we define `smul_with_zero R M` to
be the typeclass where the products `r • 0` and `0 • m` vanish for all `r : R` and all `m : M`.

Moreover, in the case in which `R` is a `monoid_with_zero`, we introduce the typeclass
`mul_action_with_zero R M`, mimicking group actions and having an absorbing `0` in `R`.
Thus, the action is required to be compatible with

* the unit of the monoid, acting as the identity;
* the zero of the monoid_with_zero, acting as zero;
* associativity of the monoid.

We also add an `instance`:

* any `monoid_with_zero` has a `mul_action_with_zero R R` acting on itself.
-/

variables {R R' M M' : Type*}

section has_zero

variables (R M)
/--  `smul_with_zero` is a class consisting of a Type `R` with `0 ∈ R` and a scalar multiplication
of `R` on a Type `M` with `0`, such that the equality `r • m = 0` holds if at least one among `r`
or `m` equals `0`. -/
class smul_with_zero [has_zero R] [has_zero M] extends has_scalar R M :=
(smul_zero : ∀ r : R, r • (0 : M) = 0)
(zero_smul : ∀ m : M, (0 : R) • m = 0)

instance mul_zero_class.to_smul_with_zero [mul_zero_class R] : smul_with_zero R R :=
{ smul := (*),
  smul_zero := mul_zero,
  zero_smul := zero_mul }

instance add_monoid.to_smul_with_zero [add_monoid M] : smul_with_zero ℕ M :=
{ smul_zero := nsmul_zero,
  zero_smul := zero_nsmul }

variables (R) {M} [has_zero R] [has_zero M] [smul_with_zero R M]

@[simp] lemma zero_smul (m : M) : (0 : R) • m = 0 := smul_with_zero.zero_smul m

variables {R} (M)
/-- Note that this lemma has different typeclass assumptions to `smul_zero`. -/
@[simp] lemma smul_zero' (r : R) : r • (0 : M) = 0 := smul_with_zero.smul_zero r

variables {R M} [has_zero R'] [has_zero M'] [has_scalar R M']

/-- Pullback a `smul_with_zero` structure along an injective zero-preserving homomorphism. -/
protected def function.injective.smul_with_zero
  (f : zero_hom M' M) (hf : function.injective f) (smul : ∀ (a : R) b, f (a • b) = a • f b) :
  smul_with_zero R M' :=
{ smul := (•),
  zero_smul := λ a, hf $ by simp [smul],
  smul_zero := λ a, hf $ by simp [smul]}

/-- Pushforward a `smul_with_zero` structure along a surjective zero-preserving homomorphism. -/
protected def function.surjective.smul_with_zero
  (f : zero_hom M M') (hf : function.surjective f) (smul : ∀ (a : R) b, f (a • b) = a • f b) :
  smul_with_zero R M' :=
{ smul := (•),
  zero_smul := λ m, by { rcases hf m with ⟨x, rfl⟩, simp [←smul] },
  smul_zero := λ c, by simp only [← f.map_zero, ← smul, smul_zero'] }

variables (M)

/-- Compose a `smul_with_zero` with a `zero_hom`, with action `f r' • m` -/
def smul_with_zero.comp_hom (f : zero_hom R' R) : smul_with_zero R' M :=
{ smul := (•) ∘ f,
  smul_zero := λ m, by simp,
  zero_smul := λ m, by simp }

end has_zero

section monoid_with_zero

variables [monoid_with_zero R] [monoid_with_zero R'] [has_zero M]

variables (R M)
/--  An action of a monoid with zero `R` on a Type `M`, also with `0`, extends `mul_action` and
is compatible with `0` (both in `R` and in `M`), with `1 ∈ R`, and with associativity of
multiplication on the monoid `M`. -/
class mul_action_with_zero extends mul_action R M :=
-- these fields are copied from `smul_with_zero`, as `extends` behaves poorly
(smul_zero : ∀ r : R, r • (0 : M) = 0)
(zero_smul : ∀ m : M, (0 : R) • m = 0)

@[priority 100] -- see Note [lower instance priority]
instance mul_action_with_zero.to_smul_with_zero [m : mul_action_with_zero R M] :
  smul_with_zero R M :=
{..m}

instance monoid_with_zero.to_mul_action_with_zero : mul_action_with_zero R R :=
{ ..mul_zero_class.to_smul_with_zero R,
  ..monoid.to_mul_action R }

variables {R M} [mul_action_with_zero R M] [has_zero M'] [has_scalar R M']

/-- Pullback a `mul_action_with_zero` structure along an injective zero-preserving homomorphism. -/
protected def function.injective.mul_action_with_zero
  (f : zero_hom M' M) (hf : function.injective f) (smul : ∀ (a : R) b, f (a • b) = a • f b) :
  mul_action_with_zero R M' :=
{ ..hf.mul_action f smul, ..hf.smul_with_zero f smul }

/-- Pushforward a `mul_action_with_zero` structure along a surjective zero-preserving homomorphism.
-/
protected def function.surjective.mul_action_with_zero
  (f : zero_hom M M') (hf : function.surjective f) (smul : ∀ (a : R) b, f (a • b) = a • f b) :
  mul_action_with_zero R M' :=
{ ..hf.mul_action f smul, ..hf.smul_with_zero f smul }

variables (M)

/-- Compose a `mul_action_with_zero` with a `monoid_with_zero_hom`, with action `f r' • m` -/
def mul_action_with_zero.comp_hom (f : monoid_with_zero_hom R' R) :
  mul_action_with_zero R' M :=
{ smul := (•) ∘ f,
  mul_smul := λ r s m, by simp [mul_smul],
  one_smul := λ m, by simp,
  .. smul_with_zero.comp_hom M f.to_zero_hom}

end monoid_with_zero


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Init.WF
import Init.Data.Nat.Basic
namespace Nat

private def div_rec_lemma {x y : Nat} : 0 < y ∧ y ≤ x → x - y < x :=
  fun ⟨ypos, ylex⟩ => subLt (Nat.ltOfLtOfLe ypos ylex) ypos

private def div.F (x : Nat) (f : ∀ x₁, x₁ < x → Nat → Nat) (y : Nat) : Nat :=
  if h : 0 < y ∧ y ≤ x then f (x - y) (div_rec_lemma h) y + 1 else zero

@[extern "lean_nat_div"]
protected def div (a b : @& Nat) : Nat :=
  WellFounded.fix ltWf div.F a b

instance : Div Nat := ⟨Nat.div⟩

private theorem div_eq_aux (x y : Nat) : x / y = if h : 0 < y ∧ y ≤ x then (x - y) / y + 1 else 0 :=
  congrFun (WellFounded.fixEq ltWf div.F x) y

theorem div_eq (x y : Nat) : x / y = if 0 < y ∧ y ≤ x then (x - y) / y + 1 else 0 :=
  difEqIf (0 < y ∧ y ≤ x) ((x - y) / y + 1) 0 ▸ div_eq_aux x y

private theorem div.induction.F.{u}
        (C : Nat → Nat → Sort u)
        (ind  : ∀ x y, 0 < y ∧ y ≤ x → C (x - y) y → C x y)
        (base : ∀ x y, ¬(0 < y ∧ y ≤ x) → C x y)
        (x : Nat) (f : ∀ (x₁ : Nat), x₁ < x → ∀ (y : Nat), C x₁ y) (y : Nat) : C x y :=
  if h : 0 < y ∧ y ≤ x then ind x y h (f (x - y) (div_rec_lemma h) y) else base x y h

theorem div.inductionOn.{u}
      {motive : Nat → Nat → Sort u}
      (x y : Nat)
      (ind  : ∀ x y, 0 < y ∧ y ≤ x → motive (x - y) y → motive x y)
      (base : ∀ x y, ¬(0 < y ∧ y ≤ x) → motive x y)
      : motive x y :=
  WellFounded.fix Nat.ltWf (div.induction.F motive ind base) x y

private def mod.F (x : Nat) (f : ∀ x₁, x₁ < x → Nat → Nat) (y : Nat) : Nat :=
  if h : 0 < y ∧ y ≤ x then f (x - y) (div_rec_lemma h) y else x

@[extern "lean_nat_mod"]
protected def mod (a b : @& Nat) : Nat :=
  WellFounded.fix ltWf mod.F a b

instance : Mod Nat := ⟨Nat.mod⟩

private theorem mod_eq_aux (x y : Nat) : x % y = if h : 0 < y ∧ y ≤ x then (x - y) % y else x :=
  congrFun (WellFounded.fixEq ltWf mod.F x) y

theorem mod_eq (x y : Nat) : x % y = if 0 < y ∧ y ≤ x then (x - y) % y else x :=
  difEqIf (0 < y ∧ y ≤ x) ((x - y) % y) x ▸ mod_eq_aux x y

theorem mod.inductionOn.{u}
      {motive : Nat → Nat → Sort u}
      (x y  : Nat)
      (ind  : ∀ x y, 0 < y ∧ y ≤ x → motive (x - y) y → motive x y)
      (base : ∀ x y, ¬(0 < y ∧ y ≤ x) → motive x y)
      : motive x y :=
  div.inductionOn x y ind base

theorem mod_zero (a : Nat) : a % 0 = a :=
  have : (if 0 < 0 ∧ 0 ≤ a then (a - 0) % 0 else a) = a :=
    have h : ¬ (0 < 0 ∧ 0 ≤ a) := fun ⟨h₁, _⟩ => absurd h₁ (Nat.ltIrrefl _)
    ifNeg h
  (mod_eq a 0).symm ▸ this

theorem mod_eq_of_lt {a b : Nat} (h : a < b) : a % b = a :=
  have : (if 0 < b ∧ b ≤ a then (a - b) % b else a) = a :=
    have h' : ¬(0 < b ∧ b ≤ a) := fun ⟨_, h₁⟩ => absurd h₁ (Nat.notLeOfGt h)
    ifNeg h'
  (mod_eq a b).symm ▸ this

theorem mod_eq_sub_mod {a b : Nat} (h : a ≥ b) : a % b = (a - b) % b :=
  match eqZeroOrPos b with
  | Or.inl h₁ => h₁.symm ▸ (Nat.sub_zero a).symm ▸ rfl
  | Or.inr h₁ => (mod_eq a b).symm ▸ ifPos ⟨h₁, h⟩

theorem mod_lt (x : Nat) {y : Nat} : y > 0 → x % y < y := by
  induction x, y using mod.inductionOn with
  | base x y h₁ =>
    intro h₂
    have h₁ : ¬ 0 < y ∨ ¬ y ≤ x := Iff.mp (Decidable.notAndIffOrNot _ _) h₁
    match h₁ with
    | Or.inl h₁ => exact absurd h₂ h₁
    | Or.inr h₁ =>
      have hgt : y > x := gtOfNotLe h₁
      have heq : x % y = x := mod_eq_of_lt hgt
      rw [← heq] at hgt
      exact hgt
  | ind x y h h₂ =>
    intro h₃
    have ⟨_, h₁⟩ := h
    rw [mod_eq_sub_mod h₁]
    exact h₂ h₃

theorem mod_le (x y : Nat) : x % y ≤ x := by
  match Nat.ltOrGe x y with
  | Or.inl h₁ => rw [mod_eq_of_lt h₁]; apply Nat.leRefl
  | Or.inr h₁ => match eqZeroOrPos y with
    | Or.inl h₂ => rw [h₂, Nat.mod_zero x]; apply Nat.leRefl
    | Or.inr h₂ => exact Nat.leTrans (Nat.leOfLt (mod_lt _ h₂)) h₁

@[simp] theorem zero_mod (b : Nat) : 0 % b = 0 := by
  rw [mod_eq]
  have : ¬ (0 < b ∧ b ≤ 0) := by
    intro ⟨h₁, h₂⟩
    exact absurd (Nat.ltOfLtOfLe h₁ h₂) (Nat.ltIrrefl 0)
  simp [this]

@[simp] theorem mod_self (n : Nat) : n % n = 0 := by
  rw [mod_eq_sub_mod (Nat.leRefl _), Nat.sub_self, zero_mod]

theorem mod_one (x : Nat) : x % 1 = 0 := by
  have h : x % 1 < 1 := mod_lt x (by decide)
  have : (y : Nat) → y < 1 → y = 0 := by
    intro y
    cases y with
    | zero   => intro h; rfl
    | succ y => intro h; apply absurd (Nat.lt_of_succ_lt_succ h) (Nat.notLtZero y)
  exact this _ h

end Nat


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

! This file was ported from Lean 3 source module topology.homotopy.product
! leanprover-community/mathlib commit 6a51706df6baee825ace37c94dc9f75b64d7f035
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Constructions
import Mathbin.Topology.Homotopy.Path

/-!
# Product of homotopies

In this file, we introduce definitions for the product of
homotopies. We show that the products of relative homotopies
are still relative homotopies. Finally, we specialize to the case
of path homotopies, and provide the definition for the product of path classes.
We show various lemmas associated with these products, such as the fact that
path products commute with path composition, and that projection is the inverse
of products.

## Definitions
### General homotopies
- `continuous_map.homotopy.pi homotopies`: Let f and g be a family of functions
  indexed on I, such that for each i ∈ I, fᵢ and gᵢ are maps from A to Xᵢ.
  Let `homotopies` be a family of homotopies from fᵢ to gᵢ for each i.
  Then `homotopy.pi homotopies` is the canonical homotopy
  from ∏ f to ∏ g, where ∏ f is the product map from A to Πi, Xᵢ,
  and similarly for ∏ g.

- `continuous_map.homotopy_rel.pi homotopies`: Same as `continuous_map.homotopy.pi`, but
  all homotopies are done relative to some set S ⊆ A.

- `continuous_map.homotopy.prod F G` is the product of homotopies F and G,
   where F is a homotopy between f₀ and f₁, G is a homotopy between g₀ and g₁.
   The result F × G is a homotopy between (f₀ × g₀) and (f₁ × g₁).
   Again, all homotopies are done relative to S.

- `continuous_map.homotopy_rel.prod F G`: Same as `continuous_map.homotopy.prod`, but
  all homotopies are done relative to some set S ⊆ A.

### Path products
- `path.homotopic.pi` The product of a family of path classes, where a path class is an equivalence
  class of paths up to path homotopy.

- `path.homotopic.prod` The product of two path classes.
-/

noncomputable section

namespace ContinuousMap

open ContinuousMap

section Pi

variable {I A : Type _} {X : I → Type _} [∀ i, TopologicalSpace (X i)] [TopologicalSpace A]
  {f g : ∀ i, C(A, X i)} {S : Set A}

/-- The product homotopy of `homotopies` between functions `f` and `g` -/
@[simps]
def Homotopy.pi (homotopies : ∀ i, Homotopy (f i) (g i)) : Homotopy (pi f) (pi g)
    where
  toFun t i := homotopies i t
  map_zero_left' t := by
    ext i
    simp only [pi_eval, homotopy.apply_zero]
  map_one_left' t := by
    ext i
    simp only [pi_eval, homotopy.apply_one]
#align continuous_map.homotopy.pi ContinuousMap.Homotopy.pi

/-- The relative product homotopy of `homotopies` between functions `f` and `g` -/
@[simps]
def HomotopyRel.pi (homotopies : ∀ i : I, HomotopyRel (f i) (g i) S) :
    HomotopyRel (pi f) (pi g) S :=
  { Homotopy.pi fun i => (homotopies i).toHomotopy with
    prop' := by
      intro t x hx
      dsimp only [coe_mk, pi_eval, to_fun_eq_coe, homotopy_with.coe_to_continuous_map]
      simp only [Function.funext_iff, ← forall_and]
      intro i
      exact (homotopies i).prop' t x hx }
#align continuous_map.homotopy_rel.pi ContinuousMap.HomotopyRel.pi

end Pi

section Prod

variable {α β : Type _} [TopologicalSpace α] [TopologicalSpace β] {A : Type _} [TopologicalSpace A]
  {f₀ f₁ : C(A, α)} {g₀ g₁ : C(A, β)} {S : Set A}

/-- The product of homotopies `F` and `G`,
  where `F` takes `f₀` to `f₁`  and `G` takes `g₀` to `g₁` -/
@[simps]
def Homotopy.prod (F : Homotopy f₀ f₁) (G : Homotopy g₀ g₁) : Homotopy (prodMk f₀ g₀) (prodMk f₁ g₁)
    where
  toFun t := (F t, G t)
  map_zero_left' x := by simp only [prod_eval, homotopy.apply_zero]
  map_one_left' x := by simp only [prod_eval, homotopy.apply_one]
#align continuous_map.homotopy.prod ContinuousMap.Homotopy.prod

/-- The relative product of homotopies `F` and `G`,
  where `F` takes `f₀` to `f₁`  and `G` takes `g₀` to `g₁` -/
@[simps]
def HomotopyRel.prod (F : HomotopyRel f₀ f₁ S) (G : HomotopyRel g₀ g₁ S) :
    HomotopyRel (prodMk f₀ g₀) (prodMk f₁ g₁) S :=
  { Homotopy.prod F.toHomotopy G.toHomotopy with
    prop' := by
      intro t x hx
      have hF := F.prop' t x hx
      have hG := G.prop' t x hx
      simp only [coe_mk, prod_eval, Prod.mk.inj_iff, homotopy.prod] at hF hG⊢
      exact ⟨⟨hF.1, hG.1⟩, ⟨hF.2, hG.2⟩⟩ }
#align continuous_map.homotopy_rel.prod ContinuousMap.HomotopyRel.prod

end Prod

end ContinuousMap

namespace Path.Homotopic

attribute [local instance] Path.Homotopic.setoid

-- mathport name: «expr ⬝ »
local infixl:70 " ⬝ " => Quotient.comp

section Pi

variable {ι : Type _} {X : ι → Type _} [∀ i, TopologicalSpace (X i)] {as bs cs : ∀ i, X i}

/-- The product of a family of path homotopies. This is just a specialization of `homotopy_rel` -/
def piHomotopy (γ₀ γ₁ : ∀ i, Path (as i) (bs i)) (H : ∀ i, Path.Homotopy (γ₀ i) (γ₁ i)) :
    Path.Homotopy (Path.pi γ₀) (Path.pi γ₁) :=
  ContinuousMap.HomotopyRel.pi H
#align path.homotopic.pi_homotopy Path.Homotopic.piHomotopy

/-- The product of a family of path homotopy classes -/
def pi (γ : ∀ i, Path.Homotopic.Quotient (as i) (bs i)) : Path.Homotopic.Quotient as bs :=
  (Quotient.map Path.pi fun x y hxy =>
      Nonempty.map (piHomotopy x y) (Classical.nonempty_pi.mpr hxy))
    (Quotient.choice γ)
#align path.homotopic.pi Path.Homotopic.pi

theorem pi_lift (γ : ∀ i, Path (as i) (bs i)) : (Path.Homotopic.pi fun i => ⟦γ i⟧) = ⟦Path.pi γ⟧ :=
  by
  unfold pi
  simp
#align path.homotopic.pi_lift Path.Homotopic.pi_lift

/-- Composition and products commute.
  This is `path.trans_pi_eq_pi_trans` descended to path homotopy classes -/
theorem comp_pi_eq_pi_comp (γ₀ : ∀ i, Path.Homotopic.Quotient (as i) (bs i))
    (γ₁ : ∀ i, Path.Homotopic.Quotient (bs i) (cs i)) : pi γ₀ ⬝ pi γ₁ = pi fun i => γ₀ i ⬝ γ₁ i :=
  by
  apply Quotient.induction_on_pi γ₁
  apply Quotient.induction_on_pi γ₀
  intros
  simp only [pi_lift]
  rw [← Path.Homotopic.comp_lift, Path.trans_pi_eq_pi_trans, ← pi_lift]
  rfl
#align path.homotopic.comp_pi_eq_pi_comp Path.Homotopic.comp_pi_eq_pi_comp

/-- Abbreviation for projection onto the ith coordinate -/
@[reducible]
def proj (i : ι) (p : Path.Homotopic.Quotient as bs) : Path.Homotopic.Quotient (as i) (bs i) :=
  p.mapFn ⟨_, continuous_apply i⟩
#align path.homotopic.proj Path.Homotopic.proj

/-- Lemmas showing projection is the inverse of pi -/
@[simp]
theorem proj_pi (i : ι) (paths : ∀ i, Path.Homotopic.Quotient (as i) (bs i)) :
    proj i (pi paths) = paths i :=
  by
  apply Quotient.induction_on_pi paths
  intro ; unfold proj
  rw [pi_lift, ← Path.Homotopic.map_lift]
  congr ; ext; rfl
#align path.homotopic.proj_pi Path.Homotopic.proj_pi

@[simp]
theorem pi_proj (p : Path.Homotopic.Quotient as bs) : (pi fun i => proj i p) = p :=
  by
  apply Quotient.inductionOn p
  intro ; unfold proj
  simp_rw [← Path.Homotopic.map_lift]
  rw [pi_lift]
  congr ; ext; rfl
#align path.homotopic.pi_proj Path.Homotopic.pi_proj

end Pi

section Prod

variable {α β : Type _} [TopologicalSpace α] [TopologicalSpace β] {a₁ a₂ a₃ : α} {b₁ b₂ b₃ : β}
  {p₁ p₁' : Path a₁ a₂} {p₂ p₂' : Path b₁ b₂} (q₁ : Path.Homotopic.Quotient a₁ a₂)
  (q₂ : Path.Homotopic.Quotient b₁ b₂)

/-- The product of homotopies h₁ and h₂.
    This is `homotopy_rel.prod` specialized for path homotopies. -/
def prodHomotopy (h₁ : Path.Homotopy p₁ p₁') (h₂ : Path.Homotopy p₂ p₂') :
    Path.Homotopy (p₁.Prod p₂) (p₁'.Prod p₂') :=
  ContinuousMap.HomotopyRel.prod h₁ h₂
#align path.homotopic.prod_homotopy Path.Homotopic.prodHomotopy

/-- The product of path classes q₁ and q₂. This is `path.prod` descended to the quotient -/
def prod (q₁ : Path.Homotopic.Quotient a₁ a₂) (q₂ : Path.Homotopic.Quotient b₁ b₂) :
    Path.Homotopic.Quotient (a₁, b₁) (a₂, b₂) :=
  Quotient.map₂ Path.prod (fun p₁ p₁' h₁ p₂ p₂' h₂ => Nonempty.map2 prodHomotopy h₁ h₂) q₁ q₂
#align path.homotopic.prod Path.Homotopic.prod

variable (p₁ p₁' p₂ p₂')

theorem prod_lift : prod ⟦p₁⟧ ⟦p₂⟧ = ⟦p₁.Prod p₂⟧ :=
  rfl
#align path.homotopic.prod_lift Path.Homotopic.prod_lift

variable (r₁ : Path.Homotopic.Quotient a₂ a₃) (r₂ : Path.Homotopic.Quotient b₂ b₃)

/-- Products commute with path composition.
    This is `trans_prod_eq_prod_trans` descended to the quotient.-/
theorem comp_prod_eq_prod_comp : prod q₁ q₂ ⬝ prod r₁ r₂ = prod (q₁ ⬝ r₁) (q₂ ⬝ r₂) :=
  by
  apply Quotient.induction_on₂ q₁ q₂
  apply Quotient.induction_on₂ r₁ r₂
  intros
  simp only [prod_lift, ← Path.Homotopic.comp_lift, Path.trans_prod_eq_prod_trans]
#align path.homotopic.comp_prod_eq_prod_comp Path.Homotopic.comp_prod_eq_prod_comp

variable {c₁ c₂ : α × β}

/-- Abbreviation for projection onto the left coordinate of a path class -/
@[reducible]
def projLeft (p : Path.Homotopic.Quotient c₁ c₂) : Path.Homotopic.Quotient c₁.1 c₂.1 :=
  p.mapFn ⟨_, continuous_fst⟩
#align path.homotopic.proj_left Path.Homotopic.projLeft

/-- Abbreviation for projection onto the right coordinate of a path class -/
@[reducible]
def projRight (p : Path.Homotopic.Quotient c₁ c₂) : Path.Homotopic.Quotient c₁.2 c₂.2 :=
  p.mapFn ⟨_, continuous_snd⟩
#align path.homotopic.proj_right Path.Homotopic.projRight

/-- Lemmas showing projection is the inverse of product -/
@[simp]
theorem projLeft_prod : projLeft (prod q₁ q₂) = q₁ :=
  by
  apply Quotient.induction_on₂ q₁ q₂
  intro p₁ p₂
  unfold proj_left
  rw [prod_lift, ← Path.Homotopic.map_lift]
  congr ; ext; rfl
#align path.homotopic.proj_left_prod Path.Homotopic.projLeft_prod

@[simp]
theorem projRight_prod : projRight (prod q₁ q₂) = q₂ :=
  by
  apply Quotient.induction_on₂ q₁ q₂
  intro p₁ p₂
  unfold proj_right
  rw [prod_lift, ← Path.Homotopic.map_lift]
  congr ; ext; rfl
#align path.homotopic.proj_right_prod Path.Homotopic.projRight_prod

@[simp]
theorem prod_projLeft_projRight (p : Path.Homotopic.Quotient (a₁, b₁) (a₂, b₂)) :
    prod (projLeft p) (projRight p) = p :=
  by
  apply Quotient.inductionOn p
  intro p'
  unfold proj_left; unfold proj_right
  simp only [← Path.Homotopic.map_lift, prod_lift]
  congr ; ext <;> rfl
#align path.homotopic.prod_proj_left_proj_right Path.Homotopic.prod_projLeft_projRight

end Prod

end Path.Homotopic


/-
Copyright (c) 2015 Jacob Gross. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jacob Gross, Jeremy Avigad

Open and closed sets, seperation axioms and generated topologies.
-/
import data.set data.nat
open algebra eq.ops set nat

structure topology [class] (X : Type) :=
  (opens : set (set X))
  (univ_mem_opens : univ ∈ opens)
  (sUnion_mem_opens : ∀ {S : set (set X)}, S ⊆ opens → ⋃₀ S ∈ opens)
  (inter_mem_opens : ∀₀ s ∈ opens, ∀₀ t ∈ opens, s ∩ t ∈ opens)

-- the bundled version
structure TopologicalSpace : Type :=
(carrier : Type) (struct : topology carrier)

attribute TopologicalSpace.carrier [coercion]
attribute TopologicalSpace.struct [instance]

namespace topology

variables {X : Type} [topology X]

/- open sets -/

definition Open (s : set X) : Prop := s ∈ opens X

theorem Open_empty : Open (∅ : set X) :=
have ∅ ⊆ opens X, from empty_subset _,
have ⋃₀ ∅ ∈ opens X, from sUnion_mem_opens this,
show ∅ ∈ opens X, by rewrite -sUnion_empty; apply this

theorem Open_univ : Open (univ : set X) :=
univ_mem_opens X

theorem Open_sUnion {S : set (set X)} (H : ∀₀ t ∈ S, Open t) : Open (⋃₀ S) :=
sUnion_mem_opens H

theorem Open_Union {I : Type} {s : I → set X} (H : ∀ i, Open (s i)) : Open (⋃ i, s i) :=
have ∀₀ t ∈ s ' univ, Open t,
  from take t, suppose t ∈ s ' univ,
    obtain i [univi (Hi : s i = t)], from this,
    show Open t, by rewrite -Hi; exact H i,
using this, by rewrite Union_eq_sUnion_image; apply Open_sUnion this

theorem Open_union {s t : set X} (Hs : Open s) (Ht : Open t) : Open (s ∪ t) :=
have ∀ i, Open (bin_ext s t i), by intro i; cases i; exact Hs; exact Ht,
show Open (s ∪ t), by rewrite -Union_bin_ext; exact Open_Union this

theorem Open_inter {s t : set X} (Hs : Open s) (Ht : Open t) : Open (s ∩ t) :=
inter_mem_opens X Hs Ht

theorem Open_sInter_of_finite {s : set (set X)} [fins : finite s] (H : ∀₀ t ∈ s, Open t) :
  Open (⋂₀ s) :=
begin
  induction fins with a s fins anins ih,
    {rewrite sInter_empty, exact Open_univ},
  rewrite sInter_insert,
  apply Open_inter,
    show Open a, from H (mem_insert a s),
  apply ih, intros t ts,
  show Open t, from H (mem_insert_of_mem a ts)
end

/- closed sets -/

definition closed [reducible] (s : set X) : Prop := Open (-s)

theorem closed_iff_Open_compl (s : set X) : closed s ↔ Open (-s) := !iff.refl

theorem Open_iff_closed_compl (s : set X) : Open s ↔ closed (-s) :=
by rewrite [closed_iff_Open_compl, compl_compl]

theorem closed_compl {s : set X} (H : Open s) : closed (-s) :=
by rewrite [-Open_iff_closed_compl]; apply H

theorem closed_empty : closed (∅ : set X) :=
by rewrite [↑closed, compl_empty]; exact Open_univ

theorem closed_univ : closed (univ : set X) :=
by rewrite [↑closed, compl_univ]; exact Open_empty

theorem closed_sInter {S : set (set X)} (H : ∀₀ t ∈ S, closed t) : closed (⋂₀ S) :=
begin
  rewrite [↑closed, compl_sInter],
  apply Open_sUnion,
  intro t,
  rewrite [mem_image_compl, Open_iff_closed_compl],
  apply H
end

theorem closed_Inter {I : Type} {s : I → set X} (H : ∀ i, closed (s i : set X)) :
  closed (⋂ i, s i) :=
by rewrite [↑closed, compl_Inter]; apply Open_Union; apply H

theorem closed_inter {s t : set X} (Hs : closed s) (Ht : closed t) : closed (s ∩ t) :=
by rewrite [↑closed, compl_inter]; apply Open_union; apply Hs; apply Ht

theorem closed_union {s t : set X} (Hs : closed s) (Ht : closed t) : closed (s ∪ t) :=
by rewrite [↑closed, compl_union]; apply Open_inter; apply Hs; apply Ht

theorem closed_sUnion_of_finite {s : set (set X)} [fins : finite s] (H : ∀₀ t ∈ s, closed t) :
  closed (⋂₀ s) :=
begin
  rewrite [↑closed, compl_sInter],
  apply Open_sUnion,
  intro t,
  rewrite [mem_image_compl, Open_iff_closed_compl],
  apply H
end

theorem open_diff {s t : set X} (Hs : Open s) (Ht : closed t) : Open (s \ t) :=
Open_inter Hs Ht

theorem closed_diff {s t : set X} (Hs : closed s) (Ht : Open t) : closed (s \ t) :=
closed_inter Hs (closed_compl Ht)

section
open classical

theorem Open_of_forall_exists_Open_nbhd {s : set X} (H : ∀₀ x ∈ s, ∃ tx : set X, Open tx ∧ x ∈ tx ∧ tx ⊆ s) :
        Open s :=
  let Hset : X → set X := λ x, if Hxs : x ∈ s then some (H Hxs) else univ in
  let sFam := image (λ x, Hset x) s in
  have H_union_open : Open (⋃₀ sFam), from Open_sUnion
    (take t : set X, suppose t ∈ sFam,
     have H_preim : ∃ t', t' ∈ s ∧ Hset t' = t, from this,
     obtain t' (Ht' : t' ∈ s)  (Ht't : Hset t' = t), from H_preim,
     have HHsett : t = some (H Ht'), from Ht't ▸ dif_pos Ht',
     show Open t, from and.left (HHsett⁻¹ ▸ some_spec (H Ht'))),
  have H_subset_union : s ⊆ ⋃₀ sFam, from
    (take x : X, suppose x ∈ s,
     have HxHset : x ∈ Hset x, from (dif_pos this)⁻¹ ▸ (and.left (and.right (some_spec (H this)))),
     show x ∈ ⋃₀ sFam, from mem_sUnion HxHset (mem_image this rfl)),
  have H_union_subset : ⋃₀ sFam ⊆ s, from
    (take x : X, suppose x ∈ ⋃₀ sFam,
     obtain (t : set X) (Ht : t ∈ sFam) (Hxt : x ∈ t), from this,
     have H_preim : ∃ t', t' ∈ s ∧ Hset t' = t, from Ht,
     obtain t' (Ht' : t' ∈ s)  (Ht't : Hset t' = t), from H_preim,
     have HHsett : t = some (H Ht'), from Ht't ▸ dif_pos Ht',
     have t ⊆ s, from and.right (and.right (HHsett⁻¹ ▸ some_spec (H Ht'))),
     show x ∈ s, from this Hxt),
  have H_union_eq : ⋃₀ sFam = s, from eq_of_subset_of_subset H_union_subset H_subset_union,
  show Open s, from  H_union_eq ▸ H_union_open

end

end topology

/- separation -/

structure T0_space [class] (X : Type) extends topology X :=
 (T0 : ∀ {x y}, x ≠ y → ∃ U, U ∈ opens ∧ ¬(x ∈ U ↔ y ∈ U))

namespace topology
  variables {X : Type} [T0_space X]

  theorem separation_T0 {x y : X} : x ≠ y ↔ ∃ U, Open U ∧ ¬(x ∈ U ↔ y ∈ U) :=
  iff.intro
    (T0_space.T0)
    (assume H, obtain U [OpU xyU], from H,
     suppose x = y,
     have x ∈ U ↔ y ∈ U, from iff.intro
       (assume xU, this ▸ xU)
       (assume yU, this⁻¹ ▸ yU),
     absurd this xyU)
end topology

structure T1_space [class] (X : Type) extends topology X :=
  (T1 : ∀ {x y}, x ≠ y → ∃ U, U ∈ opens ∧ x ∈ U ∧ y ∉ U)

protected definition T0_space.of_T1 [trans_instance] {X : Type} [T : T1_space X] :
  T0_space X :=
⦃T0_space, T,
  T0 := abstract
          take x y, assume H,
          obtain U [Uopens [xU ynU]], from T1_space.T1 H,
          exists.intro U (and.intro Uopens
            (show ¬ (x ∈ U ↔ y ∈ U), from assume H, ynU (iff.mp H xU)))
        end ⦄

namespace topology
  variables {X : Type} [T1_space X]

  theorem separation_T1 {x y : X} : x ≠ y ↔ (∃ U, Open U ∧ x ∈ U ∧ y ∉ U) :=
  iff.intro
    (T1_space.T1)
    (suppose ∃ U, Open U ∧ x ∈ U ∧ y ∉ U,
     obtain U [OpU xU nyU], from this,
     suppose x = y,
     absurd xU (this⁻¹ ▸ nyU))

  theorem closed_singleton {a : X} : closed '{a} :=
  let T := ⋃₀ {S| Open S ∧ a ∉ S} in
  have Open T, from Open_sUnion (λS HS, and.elim_left HS),
  have T = -'{a}, from ext(take x, iff.intro
    (assume xT, assume xa,
     obtain S [[OpS aS] xS], from xT,
     have ∃ U, Open U ∧ x ∈ U ∧ a ∉ U, from
       exists.intro S (and.intro OpS (and.intro xS aS)),
     have x ≠ a, from (iff.elim_right separation_T1) this,
     absurd ((iff.elim_left !mem_singleton_iff) xa) this)
    (assume xa,
     have x ≠ a, from not.intro(
       assume H, absurd ((iff.elim_right !mem_singleton_iff) H) xa),
     obtain U [OpU xU aU], from (iff.elim_left separation_T1) this,
     show _, from exists.intro U (and.intro (and.intro OpU aU) xU))),
  show _, from this ▸ `Open T`
end topology

structure T2_space [class] (X : Type) extends topology X :=
  (T2 : ∀ {x y}, x ≠ y → ∃ U V, U ∈ opens ∧ V ∈ opens ∧ x ∈ U ∧ y ∈ V ∧ U ∩ V = ∅)

protected definition T1_space.of_T2 [trans_instance] {X : Type} [T : T2_space X] :
  T1_space X :=
⦃T1_space, T,
  T1 := abstract
          take x y, assume H,
          obtain U [V [Uopens [Vopens [xU [yV UVempty]]]]], from T2_space.T2 H,
          exists.intro U (and.intro Uopens (and.intro xU
            (show y ∉ U, from assume yU,
              have y ∈ U ∩ V, from and.intro yU yV,
              show y ∈ ∅, from UVempty ▸ this)))
        end ⦄

namespace topology
  variables {X : Type} [T2_space X]

  theorem seperation_T2 {x y : X} : x ≠ y ↔ ∃ U V, Open U ∧ Open V ∧ x ∈ U ∧ y ∈ V ∧ U ∩ V = ∅ :=
  iff.intro
    (T2_space.T2)
    (assume H, obtain U V [OpU OpV xU yV UV], from H,
     suppose x = y,
     have ¬(x ∈ U ∩ V), from not.intro(
       assume xUV, absurd (UV ▸ xUV) !not_mem_empty),
     absurd (and.intro xU (`x = y`⁻¹ ▸ yV)) this)
end topology

structure perfect_space [class] (X : Type) extends topology X :=
  (perfect : ∀ x, '{x} ∉ opens)

/- topology generated by a set -/

namespace topology

inductive opens_generated_by {X : Type} (B : set (set X)) : set X → Prop :=
| generators_mem : ∀ ⦃s : set X⦄, s ∈ B → opens_generated_by B s
| univ_mem       : opens_generated_by B univ
| inter_mem      : ∀ ⦃s t⦄, opens_generated_by B s → opens_generated_by B t →
                    opens_generated_by B (s ∩ t)
| sUnion_mem     : ∀ ⦃S : set (set X)⦄, S ⊆ opens_generated_by B → opens_generated_by B (⋃₀ S)

protected definition generated_by [instance] {X : Type} (B : set (set X)) : topology X :=
⦃topology,
  opens            := opens_generated_by B,
  univ_mem_opens   := opens_generated_by.univ_mem B,
  inter_mem_opens  := λ s Hs t Ht, opens_generated_by.inter_mem Hs Ht,
  sUnion_mem_opens := opens_generated_by.sUnion_mem
⦄

theorem generators_mem_topology_generated_by {X : Type} (B : set (set X)) :
  let T := topology.generated_by B in
  ∀₀ s ∈ B, @Open _ T s :=
λ s H, opens_generated_by.generators_mem H

theorem opens_generated_by_initial {X : Type} {B : set (set X)} {T : topology X} (H : B ⊆ @opens _ T) :
  opens_generated_by B ⊆ @opens _ T :=
begin
  intro s Hs,
  induction Hs with s sB s t os ot soX toX S SB SOX,
    {exact H sB},
    {exact univ_mem_opens X},
    {exact inter_mem_opens X soX toX},
  exact sUnion_mem_opens SOX
end

theorem topology_generated_by_initial {X : Type} {B : set (set X)} {T : topology X}
    (H : ∀₀ s ∈ B, @Open _ T s) {s : set X} (H1 : @Open _ (topology.generated_by B) s) :
  @Open _ T s :=
opens_generated_by_initial H H1

section boundary
variables {X : Type} [TX : topology X]
include TX

definition on_boundary (x : X) (u : set X) := ∀ v : set X, Open v → x ∈ v → u ∩ v ≠ ∅ ∧ ¬ v ⊆ u

theorem not_open_of_on_boundary {x : X} {u : set X} (Hxu : x ∈ u) (Hob : on_boundary x u) : ¬ Open u :=
  begin
    intro Hop,
    note Hbxu := Hob _ Hop Hxu,
    apply and.right Hbxu,
    apply subset.refl
  end

end boundary

end topology


/-
Copyright (c) 2020 Zhouhang Zhou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Zhouhang Zhou, Yury Kudryashov
-/
import data.indicator_function
import order.filter.at_top_bot

/-!
# Indicator function and filters

Properties of indicator functions involving `=ᶠ` and `≤ᶠ`.

## Tags
indicator, characteristic, filter
-/

variables {α β M E : Type*}

open set filter classical
open_locale filter classical

section has_zero
variables [has_zero M] {s t : set α} {f g : α → M} {a : α} {l : filter α}

lemma indicator_eventually_eq (hf : f =ᶠ[l ⊓ 𝓟 s] g) (hs : s =ᶠ[l] t) :
  indicator s f =ᶠ[l] indicator t g :=
(eventually_inf_principal.1 hf).mp $ hs.mem_iff.mono $ λ x hst hfg,
by_cases (λ hxs : x ∈ s, by simp only [*, hst.1 hxs, indicator_of_mem])
  (λ hxs, by simp only [indicator_of_not_mem hxs, indicator_of_not_mem (mt hst.2 hxs)])

end has_zero

section add_monoid
variables [add_monoid M] {s t : set α} {f g : α → M} {a : α} {l : filter α}

lemma indicator_union_eventually_eq (h : ∀ᶠ a in l, a ∉ s ∩ t) :
  indicator (s ∪ t) f =ᶠ[l] indicator s f + indicator t f :=
h.mono $ λ a ha, indicator_union_of_not_mem_inter ha _

end add_monoid

section order
variables [has_zero β] [preorder β] {s t : set α} {f g : α → β} {a : α} {l : filter α}

lemma indicator_eventually_le_indicator (h : f ≤ᶠ[l ⊓ 𝓟 s] g) :
  indicator s f ≤ᶠ[l] indicator s g :=
(eventually_inf_principal.1 h).mono $ assume a h,
indicator_rel_indicator (le_refl _) h

end order

lemma tendsto_indicator_of_monotone {ι} [preorder ι] [has_zero β]
  (s : ι → set α) (hs : monotone s) (f : α → β) (a : α) :
  tendsto (λi, indicator (s i) f a) at_top (pure $ indicator (⋃ i, s i) f a) :=
begin
  by_cases h : ∃i, a ∈ s i,
  { rcases h with ⟨i, hi⟩,
    refine tendsto_pure.2 ((eventually_ge_at_top i).mono $ assume n hn, _),
    rw [indicator_of_mem (hs hn hi) _, indicator_of_mem ((subset_Union _ _) hi) _] },
  { rw [not_exists] at h,
    simp only [indicator_of_not_mem (h _)],
    convert tendsto_const_pure,
    apply indicator_of_not_mem, simpa only [not_exists, mem_Union] }
end

lemma tendsto_indicator_of_antimono {ι} [preorder ι] [has_zero β]
  (s : ι → set α) (hs : ∀⦃i j⦄, i ≤ j → s j ⊆ s i) (f : α → β) (a : α) :
  tendsto (λi, indicator (s i) f a) at_top (pure $ indicator (⋂ i, s i) f a) :=
begin
  by_cases h : ∃i, a ∉ s i,
  { rcases h with ⟨i, hi⟩,
    refine tendsto_pure.2 ((eventually_ge_at_top i).mono $ assume n hn, _),
    rw [indicator_of_not_mem _ _, indicator_of_not_mem _ _],
    { simp only [mem_Inter, not_forall], exact ⟨i, hi⟩ },
    { assume h, have := hs hn h, contradiction } },
  { push_neg at h,
    simp only [indicator_of_mem, h, (mem_Inter.2 h), tendsto_const_pure] }
end

lemma tendsto_indicator_bUnion_finset {ι} [has_zero β] (s : ι → set α) (f : α → β) (a : α) :
  tendsto (λ (n : finset ι), indicator (⋃i∈n, s i) f a) at_top (pure $ indicator (Union s) f a) :=
begin
  rw Union_eq_Union_finset s,
  refine tendsto_indicator_of_monotone (λ n : finset ι, ⋃ i ∈ n, s i) _ f a,
  exact λ t₁ t₂, bUnion_subset_bUnion_left
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Scott Morrison, Adam Topaz
-/

import order.category.NonemptyFinLinOrd
import category_theory.skeletal
import data.finset.sort
import tactic.linarith

/-! # The simplex category

We construct a skeletal model of the simplex category, with objects `ℕ` and the
morphism `n ⟶ m` being the monotone maps from `fin (n+1)` to `fin (m+1)`.

We show that this category is equivalent to `NonemptyFinLinOrd`.

## Remarks

The definitions `simplex_category` and `simplex_category.hom` are marked as irreducible.

We provide the following functions to work with these objects:
1. `simplex_category.mk` creates an object of `simplex_category` out of a natural number.
  Use the notation `[n]` in the `simplicial` locale.
2. `simplex_category.len` gives the "length" of an object of `simplex_category`, as a natural.
3. `simplex_category.hom.mk` makes a morphism out of a monotone map between `fin`'s.
4. `simplex_category.hom.to_preorder_hom` gives the underlying monotone map associated to a
  term of `simplex_category.hom`.

-/

universe variables u

open category_theory

/-- The simplex category:
* objects are natural numbers `n : ℕ`
* morphisms from `n` to `m` are monotone functions `fin (n+1) → fin (m+1)`
-/
@[derive inhabited, irreducible]
def simplex_category := ulift.{u} ℕ

namespace simplex_category

section
local attribute [semireducible] simplex_category

-- TODO: Make `mk` irreducible.
/-- Interpet a natural number as an object of the simplex category. -/
def mk (n : ℕ) : simplex_category := ulift.up n

localized "notation `[`n`]` := simplex_category.mk n" in simplicial

-- TODO: Make `len` irreducible.
/-- The length of an object of `simplex_category`. -/
def len (n : simplex_category) : ℕ := n.down

@[ext] lemma ext (a b : simplex_category) : a.len = b.len → a = b := ulift.ext a b
@[simp] lemma len_mk (n : ℕ) : [n].len = n := rfl
@[simp] lemma mk_len (n : simplex_category) : [n.len] = n := by {cases n, refl}

/-- Morphisms in the simplex_category. -/
@[irreducible, nolint has_inhabited_instance]
protected def hom (a b : simplex_category.{u}) : Type u :=
ulift (fin (a.len + 1) →ₘ fin (b.len + 1))

namespace hom

local attribute [semireducible] simplex_category.hom

/-- Make a moprhism in `simplex_category` from a monotone map of fin's. -/
def mk {a b : simplex_category.{u}} (f : fin (a.len + 1) →ₘ fin (b.len + 1)) :
  simplex_category.hom a b :=
ulift.up f

/-- Recover the monotone map from a morphism in the simplex category. -/
def to_preorder_hom {a b : simplex_category.{u}} (f : simplex_category.hom a b) :
  fin (a.len + 1) →ₘ fin (b.len + 1) :=
ulift.down f

@[ext] lemma ext {a b : simplex_category.{u}} (f g : simplex_category.hom a b) :
  f.to_preorder_hom = g.to_preorder_hom → f = g := ulift.ext _ _

@[simp] lemma mk_to_preorder_hom {a b : simplex_category.{u}}
  (f : simplex_category.hom a b) : mk (f.to_preorder_hom) = f :=
by {cases f, refl}

@[simp] lemma to_preorder_hom_mk {a b : simplex_category.{u}}
  (f : fin (a.len + 1) →ₘ fin (b.len + 1)) : (mk f).to_preorder_hom = f :=
by simp [to_preorder_hom, mk]

lemma mk_to_preorder_hom_apply {a b : simplex_category.{u}}
  (f : fin (a.len + 1) →ₘ fin (b.len + 1)) (i : fin (a.len + 1)) :
  (mk f).to_preorder_hom i = f i := rfl

/-- Identity morphisms of `simplex_category`. -/
@[simp]
def id (a : simplex_category.{u}) :
  simplex_category.hom a a :=
mk preorder_hom.id

/-- Composition of morphisms of `simplex_category`. -/
@[simp]
def comp {a b c : simplex_category.{u}} (f : simplex_category.hom b c)
  (g : simplex_category.hom a b) : simplex_category.hom a c :=
mk $ f.to_preorder_hom.comp g.to_preorder_hom

end hom

@[simps]
instance small_category : small_category.{u} simplex_category :=
{ hom := λ n m, simplex_category.hom n m,
  id := λ m, simplex_category.hom.id _,
  comp := λ _ _ _ f g, simplex_category.hom.comp g f, }

/--
Make a morphism `[n] ⟶ [m]` from a monotone map between fin's.
This is useful for constructing morphisms beetween `[n]` directly
without identifying `n` with `[n].len`.
-/
@[simp]
def mk_hom {n m : ℕ} (f : (fin (n+1)) →ₘ (fin (m+1))) : [n] ⟶ [m] :=
simplex_category.hom.mk f

end

open_locale simplicial

section generators
/-!
## Generating maps for the simplex category

TODO: prove that the simplex category is equivalent to
one given by the following generators and relations.
-/

/-- The `i`-th face map from `[n]` to `[n+1]` -/
def δ {n} (i : fin (n+2)) : [n] ⟶ [n+1] :=
mk_hom (fin.succ_above i).to_preorder_hom

/-- The `i`-th degeneracy map from `[n+1]` to `[n]` -/
def σ {n} (i : fin (n+1)) : [n+1] ⟶ [n] := mk_hom
{ to_fun := fin.pred_above i,
  monotone' := fin.pred_above_right_monotone i }

/-- The generic case of the first simplicial identity -/
lemma δ_comp_δ {n} {i j : fin (n+2)} (H : i ≤ j) :
  δ i ≫ δ j.succ = δ j ≫ δ i.cast_succ :=
begin
  ext k,
  dsimp [δ, fin.succ_above],
  simp only [order_embedding.to_preorder_hom_coe,
    order_embedding.coe_of_strict_mono,
    function.comp_app,
    simplex_category.hom.to_preorder_hom_mk,
    preorder_hom.comp_to_fun],
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  rcases k with ⟨k, _⟩,
  split_ifs; { simp at *; linarith },
end

/-- The special case of the first simplicial identity -/
lemma δ_comp_δ_self {n} {i : fin (n+2)} : δ i ≫ δ i.cast_succ = δ i ≫ δ i.succ :=
begin
  ext j,
  dsimp [δ, fin.succ_above],
  simp only [order_embedding.to_preorder_hom_coe,
    order_embedding.coe_of_strict_mono,
    function.comp_app,
    simplex_category.hom.to_preorder_hom_mk,
    preorder_hom.comp_to_fun],
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  split_ifs; { simp at *; linarith },
end

/-- The second simplicial identity -/
lemma δ_comp_σ_of_le {n} {i : fin (n+2)} {j : fin (n+1)} (H : i ≤ j.cast_succ) :
  δ i.cast_succ ≫ σ j.succ = σ j ≫ δ i :=
begin
  ext k,
  suffices : ite (j.succ.cast_succ < ite (k < i) k.cast_succ k.succ)
    (ite (k < i) (k:ℕ) (k + 1) - 1) (ite (k < i) k (k + 1)) =
      ite ((if h : (j:ℕ) < k
        then k.pred (by { rintro rfl, exact nat.not_lt_zero _ h })
        else k.cast_lt (by { cases j, cases k, simp only [len_mk], linarith })).cast_succ < i)
          (ite (j.cast_succ < k) (k - 1) k) (ite (j.cast_succ < k) (k - 1) k + 1),
  { dsimp [δ, σ, fin.succ_above, fin.pred_above],
    simpa [fin.pred_above] with push_cast },
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  rcases k with ⟨k, _⟩,
  simp only [subtype.mk_le_mk, fin.cast_succ_mk] at H,
  dsimp, simp only [if_congr, subtype.mk_lt_mk, dif_ctx_congr],
  split_ifs,
  -- Most of the goals can now be handled by `linarith`,
  -- but we have to deal with two of them by hand.
  swap 8,
  { exact (nat.succ_pred_eq_of_pos (lt_of_le_of_lt (zero_le _) ‹_›)).symm, },
  swap 7,
  { have : k ≤ i := nat.le_of_pred_lt ‹_›, linarith, },
  -- Hope for the best from `linarith`:
  all_goals { try { refl <|> simp at * }; linarith, },
end

/-- The first part of the third simplicial identity -/
lemma δ_comp_σ_self {n} {i : fin (n+1)} :
  δ i.cast_succ ≫ σ i = 𝟙 [n] :=
begin
  ext j,
  suffices : ite (fin.cast_succ i < ite (j < i) (fin.cast_succ j) j.succ)
    (ite (j < i) (j:ℕ) (j + 1) - 1) (ite (j < i) j (j + 1)) = j,
  { dsimp [δ, σ, fin.succ_above, fin.pred_above], simpa [fin.pred_above] with push_cast },
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  dsimp, simp only [if_congr, subtype.mk_lt_mk],
  split_ifs; { simp at *; linarith, },
end

/-- The second part of the third simplicial identity -/
lemma δ_comp_σ_succ {n} {i : fin (n+1)} :
  δ i.succ ≫ σ i = 𝟙 [n] :=
begin
  ext j,
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  dsimp [δ, σ, fin.succ_above, fin.pred_above],
  simp [fin.pred_above] with push_cast,
  split_ifs; { simp at *; linarith, },
end

/-- The fourth simplicial identity -/
lemma δ_comp_σ_of_gt {n} {i : fin (n+2)} {j : fin (n+1)} (H : j.cast_succ < i) :
  δ i.succ ≫ σ j.cast_succ = σ j ≫ δ i :=
begin
  ext k,
  dsimp [δ, σ, fin.succ_above, fin.pred_above],
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  rcases k with ⟨k, _⟩,
  simp only [subtype.mk_lt_mk, fin.cast_succ_mk] at H,
  suffices : ite (_ < ite (k < i + 1) _ _) _ _ =
    ite _ (ite (j < k) (k - 1) k) (ite (j < k) (k - 1) k + 1),
  { simpa [apply_dite fin.cast_succ, fin.pred_above] with push_cast, },
  split_ifs,
  -- Most of the goals can now be handled by `linarith`,
  -- but we have to deal with three of them by hand.
  swap 2,
  { simp only [subtype.mk_lt_mk] at h_1,
    simp only [not_lt] at h_2,
    simp only [self_eq_add_right, one_ne_zero],
    exact lt_irrefl (k - 1) (lt_of_lt_of_le
      (nat.pred_lt (ne_of_lt (lt_of_le_of_lt (zero_le _) h_1)).symm)
      (le_trans (nat.le_of_lt_succ h) h_2)) },
  swap 4,
  { simp only [subtype.mk_lt_mk] at h_1,
    simp only [not_lt] at h,
    simp only [nat.add_succ_sub_one, add_zero],
    exfalso,
    exact lt_irrefl _ (lt_of_le_of_lt (nat.le_pred_of_lt (nat.lt_of_succ_le h)) h_3), },
  swap 4,
  { simp only [subtype.mk_lt_mk] at h_1,
    simp only [not_lt] at h_3,
    simp only [nat.add_succ_sub_one, add_zero],
    exact (nat.succ_pred_eq_of_pos (lt_of_le_of_lt (zero_le _) h_2)).symm, },
  -- Hope for the best from `linarith`:
  all_goals { simp at h_1 h_2 ⊢; linarith, },
end

local attribute [simp] fin.pred_mk

/-- The fifth simplicial identity -/
lemma σ_comp_σ {n} {i j : fin (n+1)} (H : i ≤ j) :
  σ i.cast_succ ≫ σ j = σ j.succ ≫ σ i :=
begin
  ext k,
  dsimp [σ, fin.pred_above],
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  rcases k with ⟨k, _⟩,
  simp only [subtype.mk_le_mk] at H,
  -- At this point `simp with push_cast` makes good progress, but neither `simp?` nor `squeeze_simp`
  -- return usable sets of lemmas.
  -- To avoid using a non-terminal simp, we make a `suffices` statement indicating the shape
  -- of the goal we're looking for, and then use `simpa with push_cast`.
  -- I'm not sure this is actually much more robust that a non-terminal simp.
  suffices : ite (_ < dite (i < k) _ _) _ _ =
    ite (_ < dite (j + 1 < k) _ _) _ _,
  { simpa [fin.pred_above] with push_cast, },
  split_ifs,
  -- `split_ifs` created 12 goals.
  -- Most of them are dealt with `by simp at *; linarith`,
  -- but we pull out two harder ones to do by hand.
  swap 3,
  { simp only [not_lt] at h_2,
    exact false.elim
    (lt_irrefl (k - 1)
      (lt_of_lt_of_le (nat.pred_lt (id (ne_of_lt (lt_of_le_of_lt (zero_le i) h)).symm))
        (le_trans h_2 (nat.succ_le_of_lt h_1)))) },
  swap 3,
  { simp only [subtype.mk_lt_mk, not_lt] at h_1,
    exact false.elim
    (lt_irrefl j (lt_of_lt_of_le (nat.pred_lt_pred (nat.succ_ne_zero j) h_2) h_1)) },
  -- Deal with the rest automatically.
  all_goals { simp at *; linarith, },
end

end generators

section skeleton

/-- The functor that exhibits `simplex_category` as skeleton
of `NonemptyFinLinOrd` -/
def skeletal_functor : simplex_category ⥤ NonemptyFinLinOrd :=
{ obj := λ a, NonemptyFinLinOrd.of $ ulift (fin (a.len + 1)),
  map := λ a b f,
    ⟨λ i, ulift.up (f.to_preorder_hom i.down), λ i j h, f.to_preorder_hom.monotone h⟩ }

lemma skeletal : skeletal simplex_category :=
λ X Y ⟨I⟩,
begin
  suffices : fintype.card (fin (X.len+1)) = fintype.card (fin (Y.len+1)),
  { ext, simpa },
  { apply fintype.card_congr,
    refine equiv.ulift.symm.trans (((skeletal_functor ⋙ forget _).map_iso I).to_equiv.trans _),
    apply equiv.ulift }
end

namespace skeletal_functor

instance : full skeletal_functor :=
{ preimage := λ a b f, simplex_category.hom.mk ⟨λ i, (f (ulift.up i)).down, λ i j h, f.monotone h⟩,
  witness' := by { intros m n f, dsimp at *, ext1 ⟨i⟩, ext1, refl } }

instance : faithful skeletal_functor :=
{ map_injective' := λ m n f g h,
  begin
    ext1, ext1 i, apply ulift.up.inj,
    change (skeletal_functor.map f) ⟨i⟩ = (skeletal_functor.map g) ⟨i⟩,
    rw h,
  end }

instance : ess_surj skeletal_functor :=
{ mem_ess_image := λ X, ⟨mk (fintype.card X - 1 : ℕ), ⟨begin
    have aux : fintype.card X = fintype.card X - 1 + 1,
    { exact (nat.succ_pred_eq_of_pos $ fintype.card_pos_iff.mpr ⟨⊥⟩).symm, },
    let f := mono_equiv_of_fin X aux,
    have hf := (finset.univ.order_emb_of_fin aux).strict_mono,
    refine
    { hom := ⟨λ i, f i.down, _⟩,
      inv := ⟨λ i, ⟨f.symm i⟩, _⟩,
      hom_inv_id' := _,
      inv_hom_id' := _ },
    { rintro ⟨i⟩ ⟨j⟩ h, show f i ≤ f j, exact hf.monotone h, },
    { intros i j h, show f.symm i ≤ f.symm j, rw ← hf.le_iff_le,
      show f (f.symm i) ≤ f (f.symm j), simpa only [order_iso.apply_symm_apply], },
    { ext1 ⟨i⟩, ext1, exact f.symm_apply_apply i },
    { ext1 i, exact f.apply_symm_apply i },
  end⟩⟩,}

noncomputable instance is_equivalence : is_equivalence skeletal_functor :=
equivalence.equivalence_of_fully_faithfully_ess_surj skeletal_functor

end skeletal_functor

/-- The equivalence that exhibits `simplex_category` as skeleton
of `NonemptyFinLinOrd` -/
noncomputable def skeletal_equivalence : simplex_category ≌ NonemptyFinLinOrd :=
functor.as_equivalence skeletal_functor

end skeleton

/--
`simplex_category` is a skeleton of `NonemptyFinLinOrd`.
-/
noncomputable
def is_skeleton_of : is_skeleton_of NonemptyFinLinOrd simplex_category skeletal_functor :=
{ skel := skeletal,
  eqv := skeletal_functor.is_equivalence }

/-- The truncated simplex category. -/
@[derive small_category]
def truncated (n : ℕ) := {a : simplex_category // a.len ≤ n}

namespace truncated

instance {n} : inhabited (truncated n) := ⟨⟨[0],by simp⟩⟩

/--
The fully faithful inclusion of the truncated simplex category into the usual
simplex category.
-/
@[derive [full, faithful]]
def inclusion {n : ℕ} : simplex_category.truncated n ⥤ simplex_category :=
full_subcategory_inclusion _

end truncated

end simplex_category


/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura, Mario Carneiro, Johannes Hölzl
-/
import order.bounded_order
import order.min_max
import algebra.ne_zero
import algebra.order.monoid.defs

/-!
# Canonically ordered monoids

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

universe u
variables {α : Type u}

set_option old_structure_cmd true

/-- An `ordered_comm_monoid` with one-sided 'division' in the sense that
if `a ≤ b`, there is some `c` for which `a * c = b`. This is a weaker version
of the condition on canonical orderings defined by `canonically_ordered_monoid`. -/
class has_exists_mul_of_le (α : Type u) [has_mul α] [has_le α] : Prop :=
(exists_mul_of_le : ∀ {a b : α}, a ≤ b → ∃ (c : α), b = a * c)

/-- An `ordered_add_comm_monoid` with one-sided 'subtraction' in the sense that
if `a ≤ b`, then there is some `c` for which `a + c = b`. This is a weaker version
of the condition on canonical orderings defined by `canonically_ordered_add_monoid`. -/
class has_exists_add_of_le (α : Type u) [has_add α] [has_le α] : Prop :=
(exists_add_of_le : ∀ {a b : α}, a ≤ b → ∃ (c : α), b = a + c)

attribute [to_additive] has_exists_mul_of_le

export has_exists_mul_of_le (exists_mul_of_le)

export has_exists_add_of_le (exists_add_of_le)

@[priority 100, to_additive] -- See note [lower instance priority]
instance group.has_exists_mul_of_le (α : Type u) [group α] [has_le α] : has_exists_mul_of_le α :=
⟨λ a b hab, ⟨a⁻¹ * b, (mul_inv_cancel_left _ _).symm⟩⟩

section mul_one_class
variables [mul_one_class α] [preorder α] [contravariant_class α α (*) (<)] [has_exists_mul_of_le α]
  {a b : α}

@[to_additive] lemma exists_one_lt_mul_of_lt' (h : a < b) : ∃ c, 1 < c ∧ a * c = b :=
by { obtain ⟨c, rfl⟩ := exists_mul_of_le h.le, exact ⟨c, one_lt_of_lt_mul_right h, rfl⟩ }

end mul_one_class

section has_exists_mul_of_le
variables [linear_order α] [densely_ordered α] [monoid α] [has_exists_mul_of_le α]
  [covariant_class α α (*) (<)] [contravariant_class α α (*) (<)] {a b : α}

@[to_additive]
lemma le_of_forall_one_lt_le_mul (h : ∀ ε : α, 1 < ε → a ≤ b * ε) : a ≤ b :=
le_of_forall_le_of_dense $ λ x hxb, by { obtain ⟨ε, rfl⟩ := exists_mul_of_le hxb.le,
  exact h _ ((lt_mul_iff_one_lt_right' b).1 hxb) }

@[to_additive]
lemma le_of_forall_one_lt_lt_mul' (h : ∀ ε : α, 1 < ε → a < b * ε) : a ≤ b :=
le_of_forall_one_lt_le_mul $ λ ε hε, (h _ hε).le

@[to_additive]
lemma le_iff_forall_one_lt_lt_mul' : a ≤ b ↔ ∀ ε, 1 < ε → a < b * ε :=
⟨λ h ε, lt_mul_of_le_of_one_lt h, le_of_forall_one_lt_lt_mul'⟩

end has_exists_mul_of_le

/-- A canonically ordered additive monoid is an ordered commutative additive monoid
  in which the ordering coincides with the subtractibility relation,
  which is to say, `a ≤ b` iff there exists `c` with `b = a + c`.
  This is satisfied by the natural numbers, for example, but not
  the integers or other nontrivial `ordered_add_comm_group`s. -/
@[protect_proj, ancestor ordered_add_comm_monoid has_bot]
class canonically_ordered_add_monoid (α : Type*) extends ordered_add_comm_monoid α, has_bot α :=
(bot_le : ∀ x : α, ⊥ ≤ x)
(exists_add_of_le : ∀ {a b : α}, a ≤ b → ∃ c, b = a + c)
(le_self_add : ∀ a b : α, a ≤ a + b)

@[priority 100]  -- see Note [lower instance priority]
instance canonically_ordered_add_monoid.to_order_bot (α : Type u)
  [h : canonically_ordered_add_monoid α] : order_bot α :=
{ ..h }

/-- A canonically ordered monoid is an ordered commutative monoid
  in which the ordering coincides with the divisibility relation,
  which is to say, `a ≤ b` iff there exists `c` with `b = a * c`.
  Examples seem rare; it seems more likely that the `order_dual`
  of a naturally-occurring lattice satisfies this than the lattice
  itself (for example, dual of the lattice of ideals of a PID or
  Dedekind domain satisfy this; collections of all things ≤ 1 seem to
  be more natural that collections of all things ≥ 1).
-/
@[protect_proj, ancestor ordered_comm_monoid has_bot, to_additive]
class canonically_ordered_monoid (α : Type*) extends ordered_comm_monoid α, has_bot α :=
(bot_le : ∀ x : α, ⊥ ≤ x)
(exists_mul_of_le : ∀ {a b : α}, a ≤ b → ∃ c, b = a * c)
(le_self_mul : ∀ a b : α, a ≤ a * b)

@[priority 100, to_additive]  -- see Note [lower instance priority]
instance canonically_ordered_monoid.to_order_bot (α : Type u)
  [h : canonically_ordered_monoid α] : order_bot α :=
{ ..h }

@[priority 100, to_additive]  -- see Note [lower instance priority]
instance canonically_ordered_monoid.has_exists_mul_of_le (α : Type u)
  [h : canonically_ordered_monoid α] : has_exists_mul_of_le α :=
{ ..h }

section canonically_ordered_monoid

variables [canonically_ordered_monoid α] {a b c d : α}

@[to_additive] lemma le_self_mul : a ≤ a * c := canonically_ordered_monoid.le_self_mul _ _
@[to_additive] lemma le_mul_self : a ≤ b * a := by { rw mul_comm, exact le_self_mul }

@[to_additive] lemma self_le_mul_right (a b : α) : a ≤ a * b := le_self_mul
@[to_additive] lemma self_le_mul_left (a b : α) : a ≤ b * a := le_mul_self

@[to_additive] lemma le_of_mul_le_left : a * b ≤ c → a ≤ c := le_self_mul.trans
@[to_additive] lemma le_of_mul_le_right : a * b ≤ c → b ≤ c := le_mul_self.trans
@[to_additive] lemma le_mul_of_le_left : a ≤ b → a ≤ b * c := le_self_mul.trans'
@[to_additive] lemma le_mul_of_le_right : a ≤ c → a ≤ b * c := le_mul_self.trans'

@[to_additive]
lemma le_iff_exists_mul : a ≤ b ↔ ∃ c, b = a * c :=
⟨exists_mul_of_le, by { rintro ⟨c, rfl⟩, exact le_self_mul }⟩

@[to_additive]
lemma le_iff_exists_mul' : a ≤ b ↔ ∃ c, b = c * a :=
by simpa only [mul_comm _ a] using le_iff_exists_mul

@[simp, to_additive zero_le] lemma one_le (a : α) : 1 ≤ a :=
le_iff_exists_mul.mpr ⟨a, (one_mul _).symm⟩

@[to_additive] lemma bot_eq_one : (⊥ : α) = 1 :=
le_antisymm bot_le (one_le ⊥)

@[simp, to_additive] lemma mul_eq_one_iff : a * b = 1 ↔ a = 1 ∧ b = 1 :=
mul_eq_one_iff' (one_le _) (one_le _)

@[simp, to_additive] lemma le_one_iff_eq_one : a ≤ 1 ↔ a = 1 :=
(one_le a).le_iff_eq

@[to_additive] lemma one_lt_iff_ne_one : 1 < a ↔ a ≠ 1 :=
(one_le a).lt_iff_ne.trans ne_comm

@[to_additive] lemma eq_one_or_one_lt : a = 1 ∨ 1 < a :=
(one_le a).eq_or_lt.imp_left eq.symm

@[simp, to_additive add_pos_iff] lemma one_lt_mul_iff : 1 < a * b ↔ 1 < a ∨ 1 < b :=
by simp only [one_lt_iff_ne_one, ne.def, mul_eq_one_iff, not_and_distrib]

@[to_additive] lemma exists_one_lt_mul_of_lt (h : a < b) : ∃ c (hc : 1 < c), a * c = b :=
begin
  obtain ⟨c, hc⟩ := le_iff_exists_mul.1 h.le,
  refine ⟨c, one_lt_iff_ne_one.2 _, hc.symm⟩,
  rintro rfl,
  simpa [hc, lt_irrefl] using h
end

@[to_additive] lemma le_mul_left (h : a ≤ c) : a ≤ b * c :=
calc a = 1 * a : by simp
  ... ≤ b * c : mul_le_mul' (one_le _) h

@[to_additive] lemma le_mul_right (h : a ≤ b) : a ≤ b * c :=
calc a = a * 1 : by simp
  ... ≤ b * c : mul_le_mul' h (one_le _)

@[to_additive]
lemma lt_iff_exists_mul [covariant_class α α (*) (<)] : a < b ↔ ∃ c > 1, b = a * c :=
begin
  simp_rw [lt_iff_le_and_ne, and_comm, le_iff_exists_mul, ← exists_and_distrib_left, exists_prop],
  apply exists_congr, intro c,
  rw [and.congr_left_iff, gt_iff_lt], rintro rfl,
  split,
  { rw [one_lt_iff_ne_one], apply mt, rintro rfl, rw [mul_one] },
  { rw [← (self_le_mul_right a c).lt_iff_ne], apply lt_mul_of_one_lt_right' }
end

end canonically_ordered_monoid

lemma pos_of_gt {M : Type*} [canonically_ordered_add_monoid M] {n m : M} (h : n < m) : 0 < m :=
lt_of_le_of_lt (zero_le _) h

namespace ne_zero

lemma pos {M} (a : M) [canonically_ordered_add_monoid M] [ne_zero a] : 0 < a :=
(zero_le a).lt_of_ne $ ne_zero.out.symm

lemma of_gt {M} [canonically_ordered_add_monoid M] {x y : M} (h : x < y) : ne_zero y :=
of_pos $ pos_of_gt h

-- 1 < p is still an often-used `fact`, due to `nat.prime` implying it, and it implying `nontrivial`
-- on `zmod`'s ring structure. We cannot just set this to be any `x < y`, else that becomes a
-- metavariable and it will hugely slow down typeclass inference.
@[priority 10]
instance of_gt' {M} [canonically_ordered_add_monoid M] [has_one M] {y : M}
  [fact (1 < y)] : ne_zero y :=
of_gt $ fact.out $ 1 < y

instance bit0 {M} [canonically_ordered_add_monoid M] {x : M} [ne_zero x] : ne_zero (bit0 x) :=
of_pos $ bit0_pos $ ne_zero.pos x

end ne_zero

/-- A canonically linear-ordered additive monoid is a canonically ordered additive monoid
    whose ordering is a linear order. -/
@[protect_proj, ancestor canonically_ordered_add_monoid linear_order]
class canonically_linear_ordered_add_monoid (α : Type*)
      extends canonically_ordered_add_monoid α, linear_order α

/-- A canonically linear-ordered monoid is a canonically ordered monoid
    whose ordering is a linear order. -/
@[protect_proj, ancestor canonically_ordered_monoid linear_order, to_additive]
class canonically_linear_ordered_monoid (α : Type*)
      extends canonically_ordered_monoid α, linear_order α

section canonically_linear_ordered_monoid
variables [canonically_linear_ordered_monoid α]

@[priority 100, to_additive]  -- see Note [lower instance priority]
instance canonically_linear_ordered_monoid.semilattice_sup : semilattice_sup α :=
{ ..linear_order.to_lattice }

@[to_additive]
lemma min_mul_distrib (a b c : α) : min a (b * c) = min a (min a b * min a c) :=
begin
  cases le_total a b with hb hb,
  { simp [hb, le_mul_right] },
  { cases le_total a c with hc hc,
    { simp [hc, le_mul_left] },
    { simp [hb, hc] } }
end

@[to_additive]
lemma min_mul_distrib' (a b c : α) : min (a * b) c = min (min a c * min b c) c :=
by simpa [min_comm _ c] using min_mul_distrib c a b

@[simp, to_additive]
lemma one_min (a : α) : min 1 a = 1 :=
min_eq_left (one_le a)

@[simp, to_additive]
lemma min_one (a : α) : min a 1 = 1 :=
min_eq_right (one_le a)

/-- In a linearly ordered monoid, we are happy for `bot_eq_one` to be a `@[simp]` lemma. -/
@[simp, to_additive
  "In a linearly ordered monoid, we are happy for `bot_eq_zero` to be a `@[simp]` lemma"]
lemma bot_eq_one' : (⊥ : α) = 1 :=
bot_eq_one

end canonically_linear_ordered_monoid


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

! This file was ported from Lean 3 source module topology.perfect
! leanprover-community/mathlib commit 4c19a16e4b705bf135cf9a80ac18fcc99c438514
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.Separation
import Mathlib.Topology.Bases

/-!
# Perfect Sets

In this file we define perfect subsets of a topological space, and prove some basic properties,
including a version of the Cantor-Bendixson Theorem.

## Main Definitions

* `Perfect C`: A set `C` is perfect, meaning it is closed and every point of it
  is an accumulation point of itself.

## Main Statements

* `Perfect.splitting`: A perfect nonempty set contains two disjoint perfect nonempty subsets.
  The main inductive step in the construction of an embedding from the Cantor space to a
  perfect nonempty complete metric space.
* `exists_countable_union_perfect_of_isClosed`: One version of the **Cantor-Bendixson Theorem**:
  A closed set in a second countable space can be written as the union of a countable set and a
  perfect set.

## Implementation Notes

We do not require perfect sets to be nonempty.

We define a nonstandard predicate, `Preperfect`, which drops the closed-ness requirement
from the definition of perfect. In T1 spaces, this is equivalent to having a perfect closure,
see `preperfect_iff_perfect_closure`.

## References

* [kechris1995] (Chapter 6)

## Tags

accumulation point, perfect set, Cantor-Bendixson.

-/

open Topology Filter

open TopologicalSpace Filter Set

variable {α : Type _} [TopologicalSpace α] {C : Set α}

/-- If `x` is an accumulation point of a set `C` and `U` is a neighborhood of `x`,
then `x` is an accumulation point of `U ∩ C`. -/
theorem AccPt.nhds_inter {x : α} {U : Set α} (h_acc : AccPt x (𝓟 C)) (hU : U ∈ 𝓝 x) :
    AccPt x (𝓟 (U ∩ C)) := by
  have : 𝓝[≠] x ≤ 𝓟 U := by
    rw [le_principal_iff]
    exact mem_nhdsWithin_of_mem_nhds hU
  rw [AccPt, ← inf_principal, ← inf_assoc, inf_of_le_left this]
  exact h_acc
#align acc_pt.nhds_inter AccPt.nhds_inter

/-- A set `C` is preperfect if all of its points are accumulation points of itself.
If `C` is nonempty and `α` is a T1 space, this is equivalent to the closure of `C` being perfect.
See `preperfect_iff_perfect_closure`.-/
def Preperfect (C : Set α) : Prop :=
  ∀ x ∈ C, AccPt x (𝓟 C)
#align preperfect Preperfect

/-- A set `C` is called perfect if it is closed and all of its
points are accumulation points of itself.
Note that we do not require `C` to be nonempty.-/
structure Perfect (C : Set α) : Prop where
  closed : IsClosed C
  acc : Preperfect C
#align perfect Perfect

theorem preperfect_iff_nhds : Preperfect C ↔ ∀ x ∈ C, ∀ U ∈ 𝓝 x, ∃ y ∈ U ∩ C, y ≠ x := by
  simp only [Preperfect, accPt_iff_nhds]
#align preperfect_iff_nhds preperfect_iff_nhds

/-- The intersection of a preperfect set and an open set is preperfect. -/
theorem Preperfect.open_inter {U : Set α} (hC : Preperfect C) (hU : IsOpen U) :
    Preperfect (U ∩ C) := by
  rintro x ⟨xU, xC⟩
  apply (hC _ xC).nhds_inter
  exact hU.mem_nhds xU
#align preperfect.open_inter Preperfect.open_inter

/-- The closure of a preperfect set is perfect.
For a converse, see `preperfect_iff_perfect_closure`. -/
theorem Preperfect.perfect_closure (hC : Preperfect C) : Perfect (closure C) := by
  constructor; · exact isClosed_closure
  intro x hx
  by_cases h : x ∈ C <;> apply AccPt.mono _ (principal_mono.mpr subset_closure)
  · exact hC _ h
  have : {x}ᶜ ∩ C = C := by simp [h]
  rw [AccPt, nhdsWithin, inf_assoc, inf_principal, this]
  rw [closure_eq_cluster_pts] at hx
  exact hx
#align preperfect.perfect_closure Preperfect.perfect_closure

/-- In a T1 space, being preperfect is equivalent to having perfect closure.-/
theorem preperfect_iff_perfect_closure [T1Space α] : Preperfect C ↔ Perfect (closure C) := by
  constructor <;> intro h
  · exact h.perfect_closure
  intro x xC
  have H : AccPt x (𝓟 (closure C)) := h.acc _ (subset_closure xC)
  rw [accPt_iff_frequently] at *
  have : ∀ y, y ≠ x ∧ y ∈ closure C → ∃ᶠ z in 𝓝 y, z ≠ x ∧ z ∈ C := by
    rintro y ⟨hyx, yC⟩
    simp only [← mem_compl_singleton_iff, and_comm, ← frequently_nhdsWithin_iff,
      hyx.nhdsWithin_compl_singleton, ← mem_closure_iff_frequently]
    exact yC
  rw [← frequently_frequently_nhds]
  exact H.mono this
#align preperfect_iff_perfect_closure preperfect_iff_perfect_closure

theorem Perfect.closure_nhds_inter {U : Set α} (hC : Perfect C) (x : α) (xC : x ∈ C) (xU : x ∈ U)
    (Uop : IsOpen U) : Perfect (closure (U ∩ C)) ∧ (closure (U ∩ C)).Nonempty := by
  constructor
  · apply Preperfect.perfect_closure
    exact hC.acc.open_inter Uop
  apply Nonempty.closure
  exact ⟨x, ⟨xU, xC⟩⟩
#align perfect.closure_nhds_inter Perfect.closure_nhds_inter

/-- Given a perfect nonempty set in a T2.5 space, we can find two disjoint perfect subsets.
This is the main inductive step in the proof of the Cantor-Bendixson Theorem. -/
theorem Perfect.splitting [T25Space α] (hC : Perfect C) (hnonempty : C.Nonempty) :
    ∃ C₀ C₁ : Set α,
    (Perfect C₀ ∧ C₀.Nonempty ∧ C₀ ⊆ C) ∧ (Perfect C₁ ∧ C₁.Nonempty ∧ C₁ ⊆ C) ∧ Disjoint C₀ C₁ := by
  cases' hnonempty with y yC
  obtain ⟨x, xC, hxy⟩ : ∃ x ∈ C, x ≠ y := by
    have := hC.acc _ yC
    rw [accPt_iff_nhds] at this
    rcases this univ univ_mem with ⟨x, xC, hxy⟩
    exact ⟨x, xC.2, hxy⟩
  obtain ⟨U, xU, Uop, V, yV, Vop, hUV⟩ := exists_open_nhds_disjoint_closure hxy
  use closure (U ∩ C), closure (V ∩ C)
  constructor <;> rw [← and_assoc]
  · refine' ⟨hC.closure_nhds_inter x xC xU Uop, _⟩
    rw [hC.closed.closure_subset_iff]
    exact inter_subset_right _ _
  constructor
  · refine' ⟨hC.closure_nhds_inter y yC yV Vop, _⟩
    rw [hC.closed.closure_subset_iff]
    exact inter_subset_right _ _
  apply Disjoint.mono _ _ hUV <;> apply closure_mono <;> exact inter_subset_left _ _
#align perfect.splitting Perfect.splitting

section Kernel

/-- The **Cantor-Bendixson Theorem**: Any closed subset of a second countable space
can be written as the union of a countable set and a perfect set.-/
theorem exists_countable_union_perfect_of_isClosed [SecondCountableTopology α]
    (hclosed : IsClosed C) : ∃ V D : Set α, V.Countable ∧ Perfect D ∧ C = V ∪ D := by
  obtain ⟨b, bct, _, bbasis⟩ := TopologicalSpace.exists_countable_basis α
  let v := { U ∈ b | (U ∩ C).Countable }
  let V := ⋃ U ∈ v, U
  let D := C \ V
  have Vct : (V ∩ C).Countable := by
    simp only [unionᵢ_inter, mem_sep_iff]
    apply Countable.bunionᵢ
    · exact Countable.mono (inter_subset_left _ _) bct
    · exact inter_subset_right _ _
  refine' ⟨V ∩ C, D, Vct, ⟨_, _⟩, _⟩
  · refine' hclosed.sdiff (isOpen_bunionᵢ fun _ ↦ _)
    exact fun ⟨Ub, _⟩ ↦ IsTopologicalBasis.isOpen bbasis Ub
  · rw [preperfect_iff_nhds]
    intro x xD E xE
    have : ¬(E ∩ D).Countable := by
      intro h
      obtain ⟨U, hUb, xU, hU⟩ : ∃ U ∈ b, x ∈ U ∧ U ⊆ E :=
        (IsTopologicalBasis.mem_nhds_iff bbasis).mp xE
      have hU_cnt : (U ∩ C).Countable := by
        apply @Countable.mono _ _ (E ∩ D ∪ V ∩ C)
        · rintro y ⟨yU, yC⟩
          by_cases h : y ∈ V
          · exact mem_union_right _ (mem_inter h yC)
          · exact mem_union_left _ (mem_inter (hU yU) ⟨yC, h⟩)
        exact Countable.union h Vct
      have : U ∈ v := ⟨hUb, hU_cnt⟩
      apply xD.2
      exact mem_bunionᵢ this xU
    by_contra h
    -- Porting note: `push_neg` somehow didn't work. Add a `rw` to make `push_neg` work.
    rw [not_exists] at h
    push_neg at h
    exact absurd (Countable.mono h (Set.countable_singleton _)) this
  · rw [inter_comm, inter_union_diff]
#align exists_countable_union_perfect_of_is_closed exists_countable_union_perfect_of_isClosed

/-- Any uncountable closed set in a second countable space contains a nonempty perfect subset.-/
theorem exists_perfect_nonempty_of_isClosed_of_not_countable [SecondCountableTopology α]
    (hclosed : IsClosed C) (hunc : ¬C.Countable) : ∃ D : Set α, Perfect D ∧ D.Nonempty ∧ D ⊆ C := by
  rcases exists_countable_union_perfect_of_isClosed hclosed with ⟨V, D, Vct, Dperf, VD⟩
  refine' ⟨D, ⟨Dperf, _⟩⟩
  constructor
  · rw [nonempty_iff_ne_empty]
    by_contra h
    rw [h, union_empty] at VD
    rw [VD] at hunc
    contradiction
  rw [VD]
  exact subset_union_right _ _
#align exists_perfect_nonempty_of_is_closed_of_not_countable exists_perfect_nonempty_of_isClosed_of_not_countable

end Kernel


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Init.WF
import Init.WFTactics
import Init.Data.Nat.Basic
namespace Nat

theorem div_rec_lemma {x y : Nat} : 0 < y ∧ y ≤ x → x - y < x :=
  fun ⟨ypos, ylex⟩ => sub_lt (Nat.lt_of_lt_of_le ypos ylex) ypos

@[extern "lean_nat_div"]
protected def div (x y : @& Nat) : Nat :=
  if 0 < y ∧ y ≤ x then
    Nat.div (x - y) y + 1
  else
    0
decreasing_by apply div_rec_lemma; assumption

instance : Div Nat := ⟨Nat.div⟩

theorem div_eq (x y : Nat) : x / y = if 0 < y ∧ y ≤ x then (x - y) / y + 1 else 0 := by
  show Nat.div x y = _
  rw [Nat.div]
  rfl

theorem div.inductionOn.{u}
      {motive : Nat → Nat → Sort u}
      (x y : Nat)
      (ind  : ∀ x y, 0 < y ∧ y ≤ x → motive (x - y) y → motive x y)
      (base : ∀ x y, ¬(0 < y ∧ y ≤ x) → motive x y)
      : motive x y :=
  if h : 0 < y ∧ y ≤ x then
    ind x y h (inductionOn (x - y) y ind base)
  else
    base x y h
decreasing_by apply div_rec_lemma; assumption

theorem div_le_self (n k : Nat) : n / k ≤ n := by
  induction n using Nat.strongInductionOn with
  | ind n ih =>
    rw [div_eq]
    -- Note: manual split to avoid Classical.em which is not yet defined
    cases (inferInstance : Decidable (0 < k ∧ k ≤ n)) with
    | isFalse h => simp [h]
    | isTrue h =>
      suffices (n - k) / k + 1 ≤ n by simp [h, this]
      have ⟨hK, hKN⟩ := h
      have hSub : n - k < n := sub_lt (Nat.lt_of_lt_of_le hK hKN) hK
      have : (n - k) / k ≤ n - k := ih (n - k) hSub
      exact succ_le_of_lt (Nat.lt_of_le_of_lt this hSub)

theorem div_lt_self {n k : Nat} (hLtN : 0 < n) (hLtK : 1 < k) : n / k < n := by
  rw [div_eq]
  cases (inferInstance : Decidable (0 < k ∧ k ≤ n)) with
  | isFalse h => simp [hLtN, h]
  | isTrue h =>
    suffices (n - k) / k + 1 < n by simp [h, this]
    have ⟨_, hKN⟩ := h
    have : (n - k) / k ≤ n - k := div_le_self (n - k) k
    have := Nat.add_le_of_le_sub hKN this
    exact Nat.lt_of_lt_of_le (Nat.add_lt_add_left hLtK _) this

@[extern "lean_nat_mod"]
protected def modCore (x y : @& Nat) : Nat :=
  if 0 < y ∧ y ≤ x then
    Nat.modCore (x - y) y
  else
    x
decreasing_by apply div_rec_lemma; assumption

@[extern "lean_nat_mod"]
protected def mod : @& Nat → @& Nat → Nat
  /- This case is not needed mathematically as the case below is equal to it; however, it makes
  `0 % n = 0` true definitionally rather than just propositionally.
  This property is desirable for `Fin n`, as it means `(ofNat 0 : Fin n).val = 0` by definition.
  Primarily, this is valuable because mathlib in Lean3 assumed this was true definitionally, and so
  keeping this definitional equality makes mathlib easier to port to mathlib4. -/
  | 0, _ => 0
  | x@(_ + 1), y => Nat.modCore x y

instance : Mod Nat := ⟨Nat.mod⟩

protected theorem modCore_eq_mod (x y : Nat) : Nat.modCore x y = x % y := by
  cases x with
  | zero =>
    rw [Nat.modCore]
    exact if_neg fun ⟨hlt, hle⟩ => Nat.lt_irrefl _ (Nat.lt_of_lt_of_le hlt hle)
  | succ x => rfl

theorem mod_eq (x y : Nat) : x % y = if 0 < y ∧ y ≤ x then (x - y) % y else x := by
  rw [←Nat.modCore_eq_mod, ←Nat.modCore_eq_mod, Nat.modCore]

theorem mod.inductionOn.{u}
      {motive : Nat → Nat → Sort u}
      (x y  : Nat)
      (ind  : ∀ x y, 0 < y ∧ y ≤ x → motive (x - y) y → motive x y)
      (base : ∀ x y, ¬(0 < y ∧ y ≤ x) → motive x y)
      : motive x y :=
  div.inductionOn x y ind base

@[simp] theorem mod_zero (a : Nat) : a % 0 = a :=
  have : (if 0 < 0 ∧ 0 ≤ a then (a - 0) % 0 else a) = a :=
    have h : ¬ (0 < 0 ∧ 0 ≤ a) := fun ⟨h₁, _⟩ => absurd h₁ (Nat.lt_irrefl _)
    if_neg h
  (mod_eq a 0).symm ▸ this

theorem mod_eq_of_lt {a b : Nat} (h : a < b) : a % b = a :=
  have : (if 0 < b ∧ b ≤ a then (a - b) % b else a) = a :=
    have h' : ¬(0 < b ∧ b ≤ a) := fun ⟨_, h₁⟩ => absurd h₁ (Nat.not_le_of_gt h)
    if_neg h'
  (mod_eq a b).symm ▸ this

theorem mod_eq_sub_mod {a b : Nat} (h : a ≥ b) : a % b = (a - b) % b :=
  match eq_zero_or_pos b with
  | Or.inl h₁ => h₁.symm ▸ (Nat.sub_zero a).symm ▸ rfl
  | Or.inr h₁ => (mod_eq a b).symm ▸ if_pos ⟨h₁, h⟩

theorem mod_lt (x : Nat) {y : Nat} : y > 0 → x % y < y := by
  induction x, y using mod.inductionOn with
  | base x y h₁ =>
    intro h₂
    have h₁ : ¬ 0 < y ∨ ¬ y ≤ x := Iff.mp (Decidable.not_and_iff_or_not _ _) h₁
    match h₁ with
    | Or.inl h₁ => exact absurd h₂ h₁
    | Or.inr h₁ =>
      have hgt : y > x := gt_of_not_le h₁
      have heq : x % y = x := mod_eq_of_lt hgt
      rw [← heq] at hgt
      exact hgt
  | ind x y h h₂ =>
    intro h₃
    have ⟨_, h₁⟩ := h
    rw [mod_eq_sub_mod h₁]
    exact h₂ h₃

theorem mod_le (x y : Nat) : x % y ≤ x := by
  match Nat.lt_or_ge x y with
  | Or.inl h₁ => rw [mod_eq_of_lt h₁]; apply Nat.le_refl
  | Or.inr h₁ => match eq_zero_or_pos y with
    | Or.inl h₂ => rw [h₂, Nat.mod_zero x]; apply Nat.le_refl
    | Or.inr h₂ => exact Nat.le_trans (Nat.le_of_lt (mod_lt _ h₂)) h₁

@[simp] theorem zero_mod (b : Nat) : 0 % b = 0 := by
  rw [mod_eq]
  have : ¬ (0 < b ∧ b = 0) := by
    intro ⟨h₁, h₂⟩
    simp_all
  simp [this]

@[simp] theorem mod_self (n : Nat) : n % n = 0 := by
  rw [mod_eq_sub_mod (Nat.le_refl _), Nat.sub_self, zero_mod]

theorem mod_one (x : Nat) : x % 1 = 0 := by
  have h : x % 1 < 1 := mod_lt x (by decide)
  have : (y : Nat) → y < 1 → y = 0 := by
    intro y
    cases y with
    | zero   => intro _; rfl
    | succ y => intro h; apply absurd (Nat.lt_of_succ_lt_succ h) (Nat.not_lt_zero y)
  exact this _ h

theorem div_add_mod (m n : Nat) : n * (m / n) + m % n = m := by
  rw [div_eq, mod_eq]
  have h : Decidable (0 < n ∧ n ≤ m) := inferInstance
  cases h with
  | isFalse h => simp [h]
  | isTrue h =>
    simp [h]
    have ih := div_add_mod (m - n) n
    rw [Nat.left_distrib, Nat.mul_one, Nat.add_assoc, Nat.add_left_comm, ih, Nat.add_comm, Nat.sub_add_cancel h.2]
decreasing_by apply div_rec_lemma; assumption

end Nat


mutual
  def isEven : Nat → Bool
    | 0 => true
    | n+1 => isOdd n
  def isOdd : Nat → Bool
    | 0 => false
    | n+1 => isEven n
end
termination_by' measure fun | Sum.inl n => n | Sum.inr n => n
decreasing_by apply Nat.lt_succ_self

theorem isEven_double (x : Nat) : isEven (2 * x) = true := by
  induction x with
  | zero => simp
  | succ x ih =>
    unfold isEven
    trace_state
    rw [Nat.mul_succ, Nat.add_succ]
    simp
    unfold isOdd
    trace_state
    rw [Nat.add_succ]
    simp
    exact ih

theorem isEven_succ_succ (x : Nat) : isEven (x + 2) = isEven x := by
  conv => lhs; unfold isEven; rw [Nat.add_succ]; simp; unfold isOdd; rw [Nat.add_succ]; simp


/-
Copyright (c) 2022 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import algebra.big_operators.basic
import data.int.interval
import tactic.norm_num

/-! ### `norm_num` plugin for big operators

This `norm_num` plugin provides support for computing sums and products of
lists, multisets and finsets.

Example goals this plugin can solve:

 * `∑ i in finset.range 10, (i^2 : ℕ) = 285`
 * `Π i in {1, 4, 9, 16}, nat.sqrt i = 24`
 * `([1, 2, 1, 3]).sum = 7`

## Implementation notes

The tactic works by first converting the expression denoting the collection
(list, multiset, finset) to a list of expressions denoting each element. For
finsets, this involves erasing duplicate elements (the tactic fails if equality
or disequality cannot be determined).

After rewriting the big operator to a product/sum of lists, we evaluate this
using `norm_num` itself to handle multiplication/addition.

Finally, we package up the result using some congruence lemmas.

-/

open tactic

namespace tactic.norm_num

/-- Use `norm_num` to decide equality between two expressions.

If the decision procedure succeeds, the `bool` value indicates whether the expressions are equal,
and the `expr` is a proof of (dis)equality.
This procedure is partial: it will fail in cases where `norm_num` can't reduce either side
to a rational numeral.
-/
meta def decide_eq (l r : expr) : tactic (bool × expr) := do
  (l', l'_pf) ← or_refl_conv norm_num.derive l,
  (r', r'_pf) ← or_refl_conv norm_num.derive r,
  n₁ ← l'.to_rat, n₂ ← r'.to_rat,
  c ← infer_type l' >>= mk_instance_cache,
  if n₁ = n₂ then do
    pf ← i_to_expr ``(eq.trans %%l'_pf $ eq.symm %%r'_pf),
    pure (tt, pf)
  else do
    (_, p) ← norm_num.prove_ne c l' r' n₁ n₂,
    pure (ff, p)

lemma list.not_mem_cons {α : Type*} {x y : α} {ys : list α} (h₁ : x ≠ y) (h₂ : x ∉ ys) :
  x ∉ y :: ys :=
λ h, ((list.mem_cons_iff _ _ _).mp h).elim h₁ h₂

/-- Use a decision procedure for the equality of list elements to decide list membership.

If the decision procedure succeeds, the `bool` value indicates whether the expressions are equal,
and the `expr` is a proof of (dis)equality.
This procedure is partial iff its parameter `decide_eq` is partial.
-/
meta def list.decide_mem (decide_eq : expr → expr → tactic (bool × expr)) :
  expr → list expr → tactic (bool × expr)
| x [] := do
  pf ← i_to_expr ``(list.not_mem_nil %%x),
  pure (ff, pf)
| x (y :: ys) := do
  (is_head, head_pf) ← decide_eq x y,
  if is_head then do
    pf ← i_to_expr ``((list.mem_cons_iff %%x %%y _).mpr (or.inl %%head_pf)),
    pure (tt, pf)
  else do
    (mem_tail, tail_pf) ← list.decide_mem x ys,
    if mem_tail then do
      pf ← i_to_expr ``((list.mem_cons_iff %%x %%y _).mpr (or.inr %%tail_pf)),
      pure (tt, pf)
    else do
      pf ← i_to_expr ``(list.not_mem_cons %%head_pf %%tail_pf),
      pure (ff, pf)

lemma list.map_cons_congr {α β : Type*} (f : α → β) {x : α} {xs : list α} {fx : β} {fxs : list β}
  (h₁ : f x = fx) (h₂ : xs.map f = fxs) : (x :: xs).map f = fx :: fxs :=
by rw [list.map_cons, h₁, h₂]

/-- Apply `ef : α → β` to all elements of the list, constructing an equality proof. -/
meta def eval_list_map (ef : expr) : list expr → tactic (list expr × expr)
| [] := do
  eq ← i_to_expr ``(list.map_nil %%ef),
  pure ([], eq)
| (x :: xs) := do
  (fx, fx_eq) ← or_refl_conv norm_num.derive (expr.app ef x),
  (fxs, fxs_eq) ← eval_list_map xs,
  eq ← i_to_expr ``(list.map_cons_congr %%ef %%fx_eq %%fxs_eq),
  pure (fx :: fxs, eq)

lemma list.cons_congr {α : Type*} (x : α) {xs : list α} {xs' : list α} (xs_eq : xs' = xs) :
  x :: xs' = x :: xs :=
by rw xs_eq

lemma list.map_congr {α β : Type*} (f : α → β) {xs xs' : list α}
  {ys : list β} (xs_eq : xs = xs') (ys_eq : xs'.map f = ys) :
  xs.map f = ys :=
by rw [← ys_eq, xs_eq]

/-- Convert an expression denoting a list to a list of elements. -/
meta def eval_list : expr → tactic (list expr × expr)
| e@`(list.nil) := do
  eq ← mk_eq_refl e,
  pure ([], eq)
| e@`(list.cons %%x %%xs) := do
  (xs, xs_eq) ← eval_list xs,
  eq ← i_to_expr ``(list.cons_congr %%x %%xs_eq),
  pure (x :: xs, eq)
| e@`(list.range %%en) := do
  n ← expr.to_nat en,
  eis ← (list.range n).mmap (λ i, expr.of_nat `(ℕ) i),
  eq ← mk_eq_refl e,
  pure (eis, eq)
| `(@list.map %%α %%β %%ef %%exs) := do
  (xs, xs_eq) ← eval_list exs,
  (ys, ys_eq) ← eval_list_map ef xs,
  eq ← i_to_expr ``(list.map_congr %%ef %%xs_eq %%ys_eq),
  pure (ys, eq)
| e@`(@list.fin_range %%en) := do
  n ← expr.to_nat en,
  eis ← (list.fin_range n).mmap (λ i, expr.of_nat `(fin %%en) i),
  eq ← mk_eq_refl e,
  pure (eis, eq)
| e := fail (to_fmt "Unknown list expression" ++ format.line ++ to_fmt e)

lemma multiset.cons_congr {α : Type*} (x : α) {xs : multiset α} {xs' : list α}
  (xs_eq : (xs' : multiset α) = xs) : (list.cons x xs' : multiset α) = x ::ₘ xs :=
by rw [← xs_eq]; refl

lemma multiset.map_congr {α β : Type*} (f : α → β) {xs : multiset α}
  {xs' : list α} {ys : list β} (xs_eq : xs = (xs' : multiset α)) (ys_eq : xs'.map f = ys) :
  xs.map f = (ys : multiset β) :=
by rw [← ys_eq, ← multiset.coe_map, xs_eq]

/-- Convert an expression denoting a multiset to a list of elements.

We return a list rather than a finset, so we can more easily iterate over it
(without having to prove that our tactics are independent of the order of iteration,
which is in general not true).
-/
meta def eval_multiset : expr → tactic (list expr × expr)
| e@`(@has_zero.zero (multiset _) _) := do
  eq ← mk_eq_refl e,
  pure ([], eq)
| e@`(has_emptyc.emptyc) := do
  eq ← mk_eq_refl e,
  pure ([], eq)
| e@`(has_singleton.singleton %%x) := do
  eq ← mk_eq_refl e,
  pure ([x], eq)
| e@`(multiset.cons %%x %%xs) := do
  (xs, xs_eq) ← eval_multiset xs,
  eq ← i_to_expr ``(multiset.cons_congr %%x %%xs_eq),
  pure (x :: xs, eq)
| e@`(@@has_insert.insert multiset.has_insert %%x %%xs) := do
  (xs, xs_eq) ← eval_multiset xs,
  eq ← i_to_expr ``(multiset.cons_congr %%x %%xs_eq),
  pure (x :: xs, eq)
| e@`(multiset.range %%en) := do
  n ← expr.to_nat en,
  eis ← (list.range n).mmap (λ i, expr.of_nat `(ℕ) i),
  eq ← mk_eq_refl e,
  pure (eis, eq)
| `(@@coe (@@coe_to_lift (@@coe_base (multiset.has_coe))) %%exs) := do
  (xs, xs_eq) ← eval_list exs,
  eq ← i_to_expr ``(congr_arg coe %%xs_eq),
  pure (xs, eq)
| `(@multiset.map %%α %%β %%ef %%exs) := do
  (xs, xs_eq) ← eval_multiset exs,
  (ys, ys_eq) ← eval_list_map ef xs,
  eq ← i_to_expr ``(multiset.map_congr %%ef %%xs_eq %%ys_eq),
  pure (ys, eq)
| e := fail (to_fmt "Unknown multiset expression" ++ format.line ++ to_fmt e)

lemma finset.mk_congr {α : Type*} {xs xs' : multiset α} (h : xs = xs') (nd nd') :
  finset.mk xs nd = finset.mk xs' nd' :=
by congr; assumption

lemma finset.insert_eq_coe_list_of_mem {α : Type*} [decidable_eq α] (x : α) (xs : finset α)
  {xs' : list α} (h : x ∈ xs') (nd_xs : xs'.nodup)
  (hxs' : xs = finset.mk ↑xs' (multiset.coe_nodup.mpr nd_xs)) :
  insert x xs = finset.mk ↑xs' (multiset.coe_nodup.mpr nd_xs) :=
have h : x ∈ xs, by simpa [hxs'] using h,
by rw [finset.insert_eq_of_mem h, hxs']

lemma finset.insert_eq_coe_list_cons {α : Type*} [decidable_eq α] (x : α) (xs : finset α)
  {xs' : list α} (h : x ∉ xs') (nd_xs : xs'.nodup) (nd_xxs : (x :: xs').nodup)
  (hxs' : xs = finset.mk ↑xs' (multiset.coe_nodup.mpr nd_xs)) :
  insert x xs = finset.mk ↑(x :: xs') (multiset.coe_nodup.mpr nd_xxs) :=
have h : x ∉ xs, by simpa [hxs'] using h,
by { rw [← finset.val_inj, finset.insert_val_of_not_mem h, hxs'], simp only [multiset.cons_coe] }

/-- For now this only works on types that are contiguous subsets of the integers -/
meta def eval_finset_interval :
  expr → tactic (option (list expr × expr × expr))
| e@`(@finset.Icc %%α %%inst_1 %%inst_2 %%ea %%eb) := do
  a ← expr.to_int ea,
  b ← expr.to_int eb,
  eis ← (finset.Icc a b).val.unquot.mmap (λ i, expr.of_int α i),
  eq ← mk_eq_refl e,
  nd ← i_to_expr ``(finset.nodup %%e),
  pure (eis, eq, nd)
| e@`(@finset.Ico %%α %%inst_1 %%inst_2 %%ea %%eb) := do
  a ← expr.to_int ea,
  b ← expr.to_int eb,
  eis ← (finset.Ico a b).val.unquot.mmap (λ i, expr.of_int α i),
  eq ← mk_eq_refl e,
  nd ← i_to_expr ``(finset.nodup %%e),
  pure (eis, eq, nd)
| e@`(@finset.Ioc %%α %%inst_1 %%inst_2 %%ea %%eb) := do
  a ← expr.to_int ea,
  b ← expr.to_int eb,
  eis ← (finset.Ioc a b).val.unquot.mmap (λ i, expr.of_int α i),
  eq ← mk_eq_refl e,
  nd ← i_to_expr ``(finset.nodup %%e),
  pure (eis, eq, nd)
| e@`(@finset.Ioo %%α %%inst_1 %%inst_2 %%ea %%eb) := do
  a ← expr.to_int ea,
  b ← expr.to_int eb,
  eis ← (finset.Ioo a b).val.unquot.mmap (λ i, expr.of_int α i),
  eq ← mk_eq_refl e,
  nd ← i_to_expr ``(finset.nodup %%e),
  pure (eis, eq, nd)
| _ := pure none

/-- Convert an expression denoting a finset to a list of elements,
a proof that this list is equal to the original finset,
and a proof that the list contains no duplicates.

We return a list rather than a finset, so we can more easily iterate over it
(without having to prove that our tactics are independent of the order of iteration,
which is in general not true).

`decide_eq` is a (partial) decision procedure for determining whether two
elements of the finset are equal, for example to parse `{2, 1, 2}` into `[2, 1]`.
-/
meta def eval_finset (decide_eq : expr → expr → tactic (bool × expr)) :
  expr → tactic (list expr × expr × expr)
| e@`(finset.mk %%val %%nd) := do
  (val', eq) ← eval_multiset val,
  eq' ← i_to_expr ``(finset.mk_congr %%eq _ _),
  pure (val', eq', nd)
| e@`(has_emptyc.emptyc) := do
  eq ← mk_eq_refl e,
  nd ← i_to_expr ``(list.nodup_nil),
  pure ([], eq, nd)
| e@`(has_singleton.singleton %%x) := do
  eq ← mk_eq_refl e,
  nd ← i_to_expr ``(list.nodup_singleton %%x),
  pure ([x], eq, nd)
| `(@@has_insert.insert (@@finset.has_insert %%dec) %%x %%xs) := do
  (exs, xs_eq, xs_nd) ← eval_finset xs,
  (is_mem, mem_pf) ← list.decide_mem decide_eq x exs,
  if is_mem then do
    pf ← i_to_expr ``(finset.insert_eq_coe_list_of_mem %%x %%xs %%mem_pf %%xs_nd %%xs_eq),
    pure (exs, pf, xs_nd)
  else do
    nd ← i_to_expr ``(list.nodup_cons.mpr ⟨%%mem_pf, %%xs_nd⟩),
    pf ← i_to_expr ``(finset.insert_eq_coe_list_cons %%x %%xs %%mem_pf %%xs_nd %%nd %%xs_eq),
    pure (x :: exs, pf, nd)
| `(@@finset.univ %%ft) := do
  -- Convert the fintype instance expression `ft` to a list of its elements.
  -- Unfold it to the `fintype.mk` constructor and a list of arguments.
  `fintype.mk ← get_app_fn_const_whnf ft
    | fail (to_fmt "Unknown fintype expression" ++ format.line ++ to_fmt ft),
  [_, args, _] ← get_app_args_whnf ft | fail (to_fmt "Expected 3 arguments to `fintype.mk`"),
  eval_finset args
| e@`(finset.range %%en) := do
  n ← expr.to_nat en,
  eis ← (list.range n).mmap (λ i, expr.of_nat `(ℕ) i),
  eq ← mk_eq_refl e,
  nd ← i_to_expr ``(list.nodup_range %%en),
  pure (eis, eq, nd)
| e := do
  -- try some other parsers
  some v ← eval_finset_interval e |
    fail (to_fmt "Unknown finset expression" ++ format.line ++ to_fmt e),
  pure v

@[to_additive]
lemma list.prod_cons_congr {α : Type*} [monoid α] (xs : list α) (x y z : α)
  (his : xs.prod = y) (hi : x * y = z) : (x :: xs).prod = z :=
by rw [list.prod_cons, his, hi]

/-- Evaluate `list.prod %%xs`,
producing the evaluated expression and an equality proof. -/
meta def list.prove_prod (α : expr) : list expr → tactic (expr × expr)
| [] := do
  result ← expr.of_nat α 1,
  proof ← i_to_expr ``(@list.prod_nil %%α _),
  pure (result, proof)
| (x :: xs) := do
  eval_xs ← list.prove_prod xs,
  xxs ← i_to_expr ``(%%x * %%eval_xs.1),
  eval_xxs ← or_refl_conv norm_num.derive xxs,
  exs ← expr.of_list α xs,
  proof ← i_to_expr
    ``(list.prod_cons_congr %%exs%%x %%eval_xs.1 %%eval_xxs.1 %%eval_xs.2 %%eval_xxs.2),
  pure (eval_xxs.1, proof)

/-- Evaluate `list.sum %%xs`,
sumucing the evaluated expression and an equality proof. -/
meta def list.prove_sum (α : expr) : list expr → tactic (expr × expr)
| [] := do
  result ← expr.of_nat α 0,
  proof ← i_to_expr ``(@list.sum_nil %%α _),
  pure (result, proof)
| (x :: xs) := do
  eval_xs ← list.prove_sum xs,
  xxs ← i_to_expr ``(%%x + %%eval_xs.1),
  eval_xxs ← or_refl_conv norm_num.derive xxs,
  exs ← expr.of_list α xs,
  proof ← i_to_expr
    ``(list.sum_cons_congr %%exs%%x %%eval_xs.1 %%eval_xxs.1 %%eval_xs.2 %%eval_xxs.2),
  pure (eval_xxs.1, proof)

@[to_additive] lemma list.prod_congr {α : Type*} [monoid α] {xs xs' : list α} {z : α}
  (h₁ : xs = xs') (h₂ : xs'.prod = z) : xs.prod = z := by cc

@[to_additive] lemma multiset.prod_congr {α : Type*} [comm_monoid α]
  {xs : multiset α} {xs' : list α} {z : α}
  (h₁ : xs = (xs' : multiset α)) (h₂ : xs'.prod = z) : xs.prod = z :=
by rw [← h₂, ← multiset.coe_prod, h₁]

/-- Evaluate `(%%xs.map (%%ef : %%α → %%β)).prod`,
producing the evaluated expression and an equality proof. -/
meta def list.prove_prod_map (β ef : expr) (xs : list expr) : tactic (expr × expr) := do
  (fxs, fxs_eq) ← eval_list_map ef xs,
  (prod, prod_eq) ← list.prove_prod β fxs,
  eq ← i_to_expr ``(list.prod_congr %%fxs_eq %%prod_eq),
  pure (prod, eq)

/-- Evaluate `(%%xs.map (%%ef : %%α → %%β)).sum`,
producing the evaluated expression and an equality proof. -/
meta def list.prove_sum_map (β ef : expr) (xs : list expr) : tactic (expr × expr) := do
  (fxs, fxs_eq) ← eval_list_map ef xs,
  (sum, sum_eq) ← list.prove_sum β fxs,
  eq ← i_to_expr ``(list.sum_congr %%fxs_eq %%sum_eq),
  pure (sum, eq)

@[to_additive]
lemma finset.eval_prod_of_list {β α : Type*} [comm_monoid β]
  (s : finset α) (f : α → β) {is : list α} (his : is.nodup)
  (hs : finset.mk ↑is (multiset.coe_nodup.mpr his) = s)
  {x : β} (hx : (is.map f).prod = x) :
  s.prod f = x :=
by rw [← hs, finset.prod_mk, multiset.coe_map, multiset.coe_prod, hx]

/-- `norm_num` plugin for evaluating big operators:
 * `list.prod`
 * `list.sum`
 * `multiset.prod`
 * `multiset.sum`
 * `finset.prod`
 * `finset.sum`
-/
@[norm_num] meta def eval_big_operators : expr → tactic (expr × expr)
| `(@list.prod %%α %%inst1 %%inst2 %%exs) :=
tactic.trace_error "Internal error in `tactic.norm_num.eval_big_operators`:" $ do
  (xs, list_eq) ← eval_list exs,
  (result, sum_eq) ← list.prove_prod α xs,
  pf ← i_to_expr ``(list.prod_congr %%list_eq %%sum_eq),
  pure (result, pf)
| `(@list.sum %%α %%inst1 %%inst2 %%exs) :=
tactic.trace_error "Internal error in `tactic.norm_num.eval_big_operators`:" $ do
  (xs, list_eq) ← eval_list exs,
  (result, sum_eq) ← list.prove_sum α xs,
  pf ← i_to_expr ``(list.sum_congr %%list_eq %%sum_eq),
  pure (result, pf)
| `(@multiset.prod %%α %%inst %%exs) :=
tactic.trace_error "Internal error in `tactic.norm_num.eval_big_operators`:" $ do
  (xs, list_eq) ← eval_multiset exs,
  (result, sum_eq) ← list.prove_prod α xs,
  pf ← i_to_expr ``(multiset.prod_congr %%list_eq %%sum_eq),
  pure (result, pf)
| `(@multiset.sum %%α %%inst %%exs) :=
tactic.trace_error "Internal error in `tactic.norm_num.eval_big_operators`:" $ do
  (xs, list_eq) ← eval_multiset exs,
  (result, sum_eq) ← list.prove_sum α xs,
  pf ← i_to_expr ``(multiset.sum_congr %%list_eq %%sum_eq),
  pure (result, pf)
| `(@finset.prod %%β %%α %%inst %%es %%ef) :=
tactic.trace_error "Internal error in `tactic.norm_num.eval_big_operators`:" $ do
  (xs, list_eq, nodup) ← eval_finset decide_eq es,
  (result, sum_eq) ← list.prove_prod_map β ef xs,
  pf ← i_to_expr ``(finset.eval_prod_of_list %%es %%ef %%nodup %%list_eq %%sum_eq),
  pure (result, pf)
| `(@finset.sum %%β %%α %%inst %%es %%ef) :=
tactic.trace_error "Internal error in `tactic.norm_num.eval_big_operators`:" $ do
  (xs, list_eq, nodup) ← eval_finset decide_eq es,
  (result, sum_eq) ← list.prove_sum_map β ef xs,
  pf ← i_to_expr ``(finset.eval_sum_of_list %%es %%ef %%nodup %%list_eq %%sum_eq),
  pure (result, pf)
| _ := failed

end tactic.norm_num


/-
Copyright (c) 2021 Julian Kuelshammer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Julian Kuelshammer
-/
import data.zmod.basic
import data.nat.basic
import tactic.interval_cases
import group_theory.specific_groups.dihedral
import group_theory.specific_groups.cyclic

/-!
# Quaternion Groups

We define the (generalised) quaternion groups `quaternion_group n` of order `4n`, also known as
dicyclic groups, with elements `a i` and `xa i` for `i : zmod n`. The (generalised) quaternion
groups can be defined by the presentation
$\langle a, x | a^{2n} = 1, x^2 = a^n, x^{-1}ax=a^{-1}\rangle$. We write `a i` for
$a^i$ and `xa i` for $x * a^i$. For `n=2` the quaternion group `quaternion_group 2` is isomorphic to
the unit integral quaternions `(quaternion ℤ)ˣ`.

## Main definition

`quaternion_group n`: The (generalised) quaternion group of order `4n`.

## Implementation notes

This file is heavily based on `dihedral_group` by Shing Tak Lam.

In mathematics, the name "quaternion group" is reserved for the cases `n ≥ 2`. Since it would be
inconvenient to carry around this condition we define `quaternion_group` also for `n = 0` and
`n = 1`. `quaternion_group 0` is isomorphic to the infinite dihedral group, while
`quaternion_group 1` is isomorphic to a cyclic group of order `4`.

## References

* https://en.wikipedia.org/wiki/Dicyclic_group
* https://en.wikipedia.org/wiki/Quaternion_group

## TODO

Show that `quaternion_group 2 ≃* (quaternion ℤ)ˣ`.

-/

/--
The (generalised) quaternion group `quaternion_group n` of order `4n`. It can be defined by the
presentation $\langle a, x | a^{2n} = 1, x^2 = a^n, x^{-1}ax=a^{-1}\rangle$. We write `a i` for
$a^i$ and `xa i` for $x * a^i$.
-/
@[derive decidable_eq]
inductive quaternion_group (n : ℕ) : Type
| a : zmod (2 * n) → quaternion_group
| xa : zmod (2 * n) → quaternion_group

namespace quaternion_group

variables {n : ℕ}

/--
Multiplication of the dihedral group.
-/
private def mul : quaternion_group n → quaternion_group n → quaternion_group n
| (a i) (a j) := a (i + j)
| (a i) (xa j) := xa (j - i)
| (xa i) (a j) := xa (i + j)
| (xa i) (xa j) := a (n + j - i)

/--
The identity `1` is given by `aⁱ`.
-/
private def one : quaternion_group n := a 0

instance : inhabited (quaternion_group n) := ⟨one⟩

/--
The inverse of an element of the quaternion group.
-/
private def inv : quaternion_group n → quaternion_group n
| (a i) := a (-i)
| (xa i) := xa (n + i)

/--
The group structure on `quaternion_group n`.
-/
instance : group (quaternion_group n) :=
{ mul := mul,
  mul_assoc :=
    begin
      rintros (i | i) (j | j) (k | k);
      simp only [mul];
      abel,
      simp only [neg_mul, one_mul, int.cast_one, zsmul_eq_mul, int.cast_neg,
                 add_right_inj],
      calc -(n : zmod (2 * n)) = 0 - n : by rw zero_sub
        ... = 2 * n - n : by { norm_cast, simp, }
        ... = n : by ring
    end,
  one := one,
  one_mul :=
    begin
      rintros (i | i),
      { exact congr_arg a (zero_add i) },
      { exact congr_arg xa (sub_zero i) },
    end,
  mul_one := begin
      rintros (i | i),
      { exact congr_arg a (add_zero i) },
      { exact congr_arg xa (add_zero i) },
    end,
  inv := inv,
  mul_left_inv := begin
      rintros (i | i),
      { exact congr_arg a (neg_add_self i) },
      { exact congr_arg a (sub_self (n + i)) },
    end }

variable {n}

@[simp] lemma a_mul_a (i j : zmod (2 * n)) : a i * a j = a (i + j) := rfl
@[simp] lemma a_mul_xa (i j : zmod (2 * n)) : a i * xa j = xa (j - i) := rfl
@[simp]

lemma one_def : (1 : quaternion_group n) = a 0 := rfl

private def fintype_helper : (zmod (2 * n) ⊕ zmod (2 * n)) ≃ quaternion_group n :=
{ inv_fun := λ i, match i with
                 | (a j) := sum.inl j
                 | (xa j) := sum.inr j
                 end,
  to_fun := λ i, match i with
                 | (sum.inl j) := a j
                 | (sum.inr j) := xa j
                 end,
  left_inv := by rintro (x | x); refl,
  right_inv := by rintro (x | x); refl }

/-- The special case that more or less by definition `quaternion_group 0` is isomorphic to the
infinite dihedral group. -/
def quaternion_group_zero_equiv_dihedral_group_zero : quaternion_group 0 ≃* dihedral_group 0 :=
{ to_fun := λ i, quaternion_group.rec_on i dihedral_group.r dihedral_group.sr,
  inv_fun := λ i, match i with
                | (dihedral_group.r j) := a j
                | (dihedral_group.sr j) := xa j
                end,
  left_inv := by rintro (k | k); refl,
  right_inv := by rintro (k | k); refl,
  map_mul' := by { rintros (k | k) (l | l); { dsimp, simp, }, } }

/--
If `0 < n`, then `quaternion_group n` is a finite group.
-/
instance [ne_zero n] : fintype (quaternion_group n) := fintype.of_equiv _ fintype_helper

instance : nontrivial (quaternion_group n) := ⟨⟨a 0, xa 0, dec_trivial⟩⟩

/--
If `0 < n`, then `quaternion_group n` has `4n` elements.
-/
lemma card [ne_zero n] : fintype.card (quaternion_group n) = 4 * n :=
begin
  rw [← fintype.card_eq.mpr ⟨fintype_helper⟩, fintype.card_sum, zmod.card, two_mul],
  ring
end

@[simp] lemma a_one_pow (k : ℕ) : (a 1 : quaternion_group n) ^ k = a k :=
begin
  induction k with k IH,
  { rw nat.cast_zero, refl },
  { rw [pow_succ, IH, a_mul_a],
    congr' 1,
    norm_cast,
    rw nat.one_add }
end

@[simp] lemma a_one_pow_n : (a 1 : quaternion_group n)^(2 * n) = 1 :=
begin
  rw [a_one_pow, one_def],
  congr' 1,
  exact zmod.nat_cast_self _
end

@[simp] lemma xa_sq (i : zmod (2 * n)) : xa i ^ 2 = a n :=
begin
  simp [sq]
end

@[simp] lemma xa_pow_four (i : zmod (2 * n)) : xa i ^ 4 = 1 :=
begin
  simp only [pow_succ, sq, xa_mul_xa, xa_mul_a, add_sub_cancel, add_sub_assoc, add_sub_cancel',
             sub_self, add_zero],
  norm_cast,
  rw ← two_mul,
  simp [one_def],
end

/--
If `0 < n`, then `xa i` has order 4.
-/
@[simp] lemma order_of_xa [ne_zero n] (i : zmod (2 * n)) : order_of (xa i) = 4 :=
begin
  change _ = 2^2,
  haveI : fact(nat.prime 2) := fact.mk (nat.prime_two),
  apply order_of_eq_prime_pow,
  { intro h,
    simp only [pow_one, xa_sq] at h,
    injection h with h',
    apply_fun zmod.val at h',
    apply_fun ( / n) at h',
    simp only [zmod.val_nat_cast, zmod.val_zero, nat.zero_div, nat.mod_mul_left_div_self,
               nat.div_self (ne_zero.pos n)] at h',
    norm_num at h' },
  { norm_num }
end

/-- In the special case `n = 1`, `quaternion 1` is a cyclic group (of order `4`). -/
lemma quaternion_group_one_is_cyclic : is_cyclic (quaternion_group 1) :=
begin
  apply is_cyclic_of_order_of_eq_card,
  rw [card, mul_one],
  exact order_of_xa 0
end

/--
If `0 < n`, then `a 1` has order `2 * n`.
-/
@[simp] lemma order_of_a_one : order_of (a 1 : quaternion_group n) = 2 * n :=
begin
  casesI eq_zero_or_ne_zero n with hn hn,
  { subst hn,
    simp_rw [mul_zero, order_of_eq_zero_iff'],
    intros n h,
    rw [one_def, a_one_pow],
    apply mt a.inj,
    haveI : char_zero (zmod (2 * 0)) := zmod.char_zero,
    simpa using h.ne' },
  apply (nat.le_of_dvd (ne_zero.pos _)
                       (order_of_dvd_of_pow_eq_one (@a_one_pow_n n))).lt_or_eq.resolve_left,
  intro h,
  have h1 : (a 1 : quaternion_group n)^(order_of (a 1)) = 1 := pow_order_of_eq_one _,
  rw a_one_pow at h1,
  injection h1 with h2,
  rw [← zmod.val_eq_zero, zmod.val_nat_cast, nat.mod_eq_of_lt h] at h2,
  exact absurd h2.symm (order_of_pos _).ne
end

/--
If `0 < n`, then `a i` has order `(2 * n) / gcd (2 * n) i`.
-/
lemma order_of_a [ne_zero n] (i : zmod (2 * n)) :
  order_of (a i) = (2 * n) / nat.gcd (2 * n) i.val :=
begin
  conv_lhs { rw ← zmod.nat_cast_zmod_val i },
  rw [← a_one_pow, order_of_pow, order_of_a_one]
end

lemma exponent : monoid.exponent (quaternion_group n) = 2 * lcm n 2 :=
begin
  rw [←normalize_eq 2, ←lcm_mul_left, normalize_eq],
  norm_num,
  casesI eq_zero_or_ne_zero n with hn hn,
  { subst hn,
    simp only [lcm_zero_left, mul_zero],
    exact monoid.exponent_eq_zero_of_order_zero order_of_a_one },
  apply nat.dvd_antisymm,
  { apply monoid.exponent_dvd_of_forall_pow_eq_one,
    rintro (m | m),
    { rw [←order_of_dvd_iff_pow_eq_one, order_of_a],
      refine nat.dvd_trans ⟨gcd (2 * n) m.val, _⟩ (dvd_lcm_left (2 * n) 4),
      exact (nat.div_mul_cancel (nat.gcd_dvd_left (2 * n) (m.val))).symm },
    { rw [←order_of_dvd_iff_pow_eq_one, order_of_xa],
      exact dvd_lcm_right (2 * n) 4 } },
  { apply lcm_dvd,
    { convert monoid.order_dvd_exponent (a 1),
      exact order_of_a_one.symm },
    { convert monoid.order_dvd_exponent (xa 0),
      exact (order_of_xa 0).symm } }
end

end quaternion_group