/-
Copyright (c) 2021 Ashvni Narayanan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ashvni Narayanan, Anne Baanen
-/

import algebra.field.basic
import data.rat.basic
import ring_theory.algebraic
import ring_theory.dedekind_domain.integral_closure
import ring_theory.integral_closure
import ring_theory.polynomial.rational_root

/-!
# Number fields
This file defines a number field and the ring of integers corresponding to it.

## Main definitions
 - `number_field` defines a number field as a field which has characteristic zero and is finite
    dimensional over ℚ.
 - `ring_of_integers` defines the ring of integers (or number ring) corresponding to a number field
    as the integral closure of ℤ in the number field.

## Implementation notes
The definitions that involve a field of fractions choose a canonical field of fractions,
but are independent of that choice.

## References
* [D. Marcus, *Number Fields*][marcus1977number]
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]
* [P. Samuel, *Algebraic Theory of Numbers*][samuel1970algebraic]

## Tags
number field, ring of integers
-/

/-- A number field is a field which has characteristic zero and is finite
dimensional over ℚ. -/
class number_field (K : Type*) [field K] : Prop :=
[to_char_zero : char_zero K]
[to_finite_dimensional : finite_dimensional ℚ K]

open function
open_locale classical big_operators

/-- `ℤ` with its usual ring structure is not a field. -/
lemma int.not_is_field : ¬ is_field ℤ :=
λ h, int.not_even_one $ (h.mul_inv_cancel two_ne_zero).imp $ λ a, (by rw ← two_mul; exact eq.symm)

namespace number_field

variables (K L : Type*) [field K] [field L] [nf : number_field K]

include nf

-- See note [lower instance priority]
attribute [priority 100, instance] number_field.to_char_zero number_field.to_finite_dimensional

protected lemma is_algebraic : algebra.is_algebraic ℚ K := algebra.is_algebraic_of_finite _ _

omit nf

/-- The ring of integers (or number ring) corresponding to a number field
is the integral closure of ℤ in the number field. -/
def ring_of_integers := integral_closure ℤ K

localized "notation `𝓞` := number_field.ring_of_integers" in number_field

lemma mem_ring_of_integers (x : K) : x ∈ 𝓞 K ↔ is_integral ℤ x := iff.rfl

/-- Given an algebra between two fields, create an algebra between their two rings of integers.

For now, this is not an instance by default as it creates an equal-but-not-defeq diamond with
`algebra.id` when `K = L`. This is caused by `x = ⟨x, x.prop⟩` not being defeq on subtypes. This
will likely change in Lean 4. -/
def ring_of_integers_algebra [algebra K L] : algebra (𝓞 K) (𝓞 L) := ring_hom.to_algebra
{ to_fun := λ k, ⟨algebra_map K L k, is_integral.algebra_map k.2⟩,
  map_zero' := subtype.ext $ by simp only [subtype.coe_mk, subalgebra.coe_zero, map_zero],
  map_one'  := subtype.ext $ by simp only [subtype.coe_mk, subalgebra.coe_one, map_one],
  map_add' := λ x y, subtype.ext $ by simp only [map_add, subalgebra.coe_add, subtype.coe_mk],
  map_mul' := λ x y, subtype.ext $ by simp only [subalgebra.coe_mul, map_mul, subtype.coe_mk] }

namespace ring_of_integers

variables {K}

instance [number_field K] : is_fraction_ring (𝓞 K) K :=
integral_closure.is_fraction_ring_of_finite_extension ℚ _

instance : is_integral_closure (𝓞 K) ℤ K :=
integral_closure.is_integral_closure _ _

instance [number_field K] : is_integrally_closed (𝓞 K) :=
integral_closure.is_integrally_closed_of_finite_extension ℚ

lemma is_integral_coe (x : 𝓞 K) : is_integral ℤ (x : K) :=
x.2

/-- The ring of integers of `K` are equivalent to any integral closure of `ℤ` in `K` -/
protected noncomputable def equiv (R : Type*) [comm_ring R] [algebra R K]
  [is_integral_closure R ℤ K] : 𝓞 K ≃+* R :=
(is_integral_closure.equiv ℤ R K _).symm.to_ring_equiv

variables (K)

instance [number_field K] : char_zero (𝓞 K) := char_zero.of_module _ K

/-- The ring of integers of a number field is not a field. -/
lemma not_is_field [number_field K] : ¬ is_field (𝓞 K) :=
begin
  have h_inj : function.injective ⇑(algebra_map ℤ (𝓞 K)),
  { exact ring_hom.injective_int (algebra_map ℤ (𝓞 K)) },
  intro hf,
  exact int.not_is_field ((is_integral.is_field_iff_is_field
    (is_integral_closure.is_integral_algebra ℤ K) h_inj).mpr hf)
end

instance [number_field K] : is_dedekind_domain (𝓞 K) :=
is_integral_closure.is_dedekind_domain ℤ ℚ K _

end ring_of_integers

end number_field

namespace rat

open number_field

local attribute [instance] subsingleton_rat_module

instance rat.number_field : number_field ℚ :=
{ to_char_zero := infer_instance,
  to_finite_dimensional :=
    -- The vector space structure of `ℚ` over itself can arise in multiple ways:
    -- all fields are vector spaces over themselves (used in `rat.finite_dimensional`)
    -- all char 0 fields have a canonical embedding of `ℚ` (used in `number_field`).
    -- Show that these coincide:
    by convert (infer_instance : finite_dimensional ℚ ℚ), }

/-- The ring of integers of `ℚ` as a number field is just `ℤ`. -/
noncomputable def ring_of_integers_equiv : ring_of_integers ℚ ≃+* ℤ :=
ring_of_integers.equiv ℤ

end rat


/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Floris van Doorn
-/
import analysis.calculus.iterated_deriv
import analysis.inner_product_space.euclidean_dist
import measure_theory.function.locally_integrable
import measure_theory.integral.set_integral

/-!
# Infinitely smooth bump function

In this file we construct several infinitely smooth functions with properties that an analytic
function cannot have:

* `exp_neg_inv_glue` is equal to zero for `x ≤ 0` and is strictly positive otherwise; it is given by
  `x ↦ exp (-1/x)` for `x > 0`;

* `real.smooth_transition` is equal to zero for `x ≤ 0` and is equal to one for `x ≥ 1`; it is given
  by `exp_neg_inv_glue x / (exp_neg_inv_glue x + exp_neg_inv_glue (1 - x))`;

* `f : cont_diff_bump c`, where `c` is a point in a real vector space, is
  a bundled smooth function such that

  - `f` is equal to `1` in `metric.closed_ball c f.r`;
  - `support f = metric.ball c f.R`;
  - `0 ≤ f x ≤ 1` for all `x`.

  The structure `cont_diff_bump` contains the data required to construct the
  function: real numbers `r`, `R`, and proofs of `0 < r < R`. The function itself is available
  through `coe_fn`.

* If `f : cont_diff_bump c` and `μ` is a measure on the domain of `f`, then `f.normed μ`
  is a smooth bump function with integral `1` w.r.t. `μ`.
-/

noncomputable theory
open_locale classical topology

open polynomial real filter set function
open_locale polynomial

/-- `exp_neg_inv_glue` is the real function given by `x ↦ exp (-1/x)` for `x > 0` and `0`
for `x ≤ 0`. It is a basic building block to construct smooth partitions of unity. Its main property
is that it vanishes for `x ≤ 0`, it is positive for `x > 0`, and the junction between the two
behaviors is flat enough to retain smoothness. The fact that this function is `C^∞` is proved in
`exp_neg_inv_glue.smooth`. -/
def exp_neg_inv_glue (x : ℝ) : ℝ := if x ≤ 0 then 0 else exp (-x⁻¹)

namespace exp_neg_inv_glue

/-- Our goal is to prove that `exp_neg_inv_glue` is `C^∞`. For this, we compute its successive
derivatives for `x > 0`. The `n`-th derivative is of the form `P_aux n (x) exp(-1/x) / x^(2 n)`,
where `P_aux n` is computed inductively. -/
noncomputable def P_aux : ℕ → ℝ[X]
| 0 := 1
| (n+1) := X^2 * (P_aux n).derivative + (1 - C ↑(2 * n) * X) * (P_aux n)

/-- Formula for the `n`-th derivative of `exp_neg_inv_glue`, as an auxiliary function `f_aux`. -/
def f_aux (n : ℕ) (x : ℝ) : ℝ :=
if x ≤ 0 then 0 else (P_aux n).eval x * exp (-x⁻¹) / x^(2 * n)

/-- The `0`-th auxiliary function `f_aux 0` coincides with `exp_neg_inv_glue`, by definition. -/
lemma f_aux_zero_eq : f_aux 0 = exp_neg_inv_glue :=
begin
  ext x,
  by_cases h : x ≤ 0,
  { simp [exp_neg_inv_glue, f_aux, h] },
  { simp [h, exp_neg_inv_glue, f_aux, ne_of_gt (not_le.1 h), P_aux] }
end

/-- For positive values, the derivative of the `n`-th auxiliary function `f_aux n`
(given in this statement in unfolded form) is the `n+1`-th auxiliary function, since
the polynomial `P_aux (n+1)` was chosen precisely to ensure this. -/
lemma f_aux_deriv (n : ℕ) (x : ℝ) (hx : x ≠ 0) :
  has_deriv_at (λx, (P_aux n).eval x * exp (-x⁻¹) / x^(2 * n))
    ((P_aux (n+1)).eval x * exp (-x⁻¹) / x^(2 * (n + 1))) x :=
begin
  simp only [P_aux, eval_add, eval_sub, eval_mul, eval_pow, eval_X, eval_C, eval_one],
  convert (((P_aux n).has_deriv_at x).mul
               (((has_deriv_at_exp _).comp x (has_deriv_at_inv hx).neg))).div
            (has_deriv_at_pow (2 * n) x) (pow_ne_zero _ hx) using 1,
  rw div_eq_div_iff,
  { have := pow_ne_zero 2 hx, field_simp only,
    cases n,
    { simp only [mul_zero, nat.cast_zero, mul_one], ring },
    { rw (id rfl : 2 * n.succ - 1 = 2 * n + 1), ring_exp } },
  all_goals { apply_rules [pow_ne_zero] },
end

/-- For positive values, the derivative of the `n`-th auxiliary function `f_aux n`
is the `n+1`-th auxiliary function. -/
lemma f_aux_deriv_pos (n : ℕ) (x : ℝ) (hx : 0 < x) :
  has_deriv_at (f_aux n) ((P_aux (n+1)).eval x * exp (-x⁻¹) / x^(2 * (n + 1))) x :=
begin
  apply (f_aux_deriv n x (ne_of_gt hx)).congr_of_eventually_eq,
  filter_upwards [lt_mem_nhds hx] with _ hy,
  simp [f_aux, hy.not_le]
end

/-- To get differentiability at `0` of the auxiliary functions, we need to know that their limit
is `0`, to be able to apply general differentiability extension theorems. This limit is checked in
this lemma. -/
lemma f_aux_limit (n : ℕ) :
  tendsto (λx, (P_aux n).eval x * exp (-x⁻¹) / x^(2 * n)) (𝓝[>] 0) (𝓝 0) :=
begin
  have A : tendsto (λx, (P_aux n).eval x) (𝓝[>] 0) (𝓝 ((P_aux n).eval 0)) :=
  (P_aux n).continuous_within_at,
  have B : tendsto (λx, exp (-x⁻¹) / x^(2 * n)) (𝓝[>] 0) (𝓝 0),
  { convert (tendsto_pow_mul_exp_neg_at_top_nhds_0 (2 * n)).comp tendsto_inv_zero_at_top,
    ext x,
    field_simp },
  convert A.mul B;
  simp [mul_div_assoc]
end

/-- Deduce from the limiting behavior at `0` of its derivative and general differentiability
extension theorems that the auxiliary function `f_aux n` is differentiable at `0`,
with derivative `0`. -/
lemma f_aux_deriv_zero (n : ℕ) : has_deriv_at (f_aux n) 0 0 :=
begin
  -- we check separately differentiability on the left and on the right
  have A : has_deriv_within_at (f_aux n) (0 : ℝ) (Iic 0) 0,
  { apply (has_deriv_at_const (0 : ℝ) (0 : ℝ)).has_deriv_within_at.congr,
    { assume y hy,
      simp at hy,
      simp [f_aux, hy] },
    { simp [f_aux, le_refl] } },
  have B : has_deriv_within_at (f_aux n) (0 : ℝ) (Ici 0) 0,
  { have diff : differentiable_on ℝ (f_aux n) (Ioi 0) :=
      λx hx, (f_aux_deriv_pos n x hx).differentiable_at.differentiable_within_at,
    -- next line is the nontrivial bit of this proof, appealing to differentiability
    -- extension results.
    apply has_deriv_at_interval_left_endpoint_of_tendsto_deriv diff _ self_mem_nhds_within,
    { refine (f_aux_limit (n+1)).congr' _,
      apply mem_of_superset self_mem_nhds_within (λx hx, _),
      simp [(f_aux_deriv_pos n x hx).deriv] },
    { have : f_aux n 0 = 0, by simp [f_aux, le_refl],
      simp only [continuous_within_at, this],
      refine (f_aux_limit n).congr' _,
      apply mem_of_superset self_mem_nhds_within (λx hx, _),
      have : ¬(x ≤ 0), by simpa using hx,
      simp [f_aux, this] } },
  simpa using A.union B,
end

/-- At every point, the auxiliary function `f_aux n` has a derivative which is
equal to `f_aux (n+1)`. -/
lemma f_aux_has_deriv_at (n : ℕ) (x : ℝ) : has_deriv_at (f_aux n) (f_aux (n+1) x) x :=
begin
  -- check separately the result for `x < 0`, where it is trivial, for `x > 0`, where it is done
  -- in `f_aux_deriv_pos`, and for `x = 0`, done in
  -- `f_aux_deriv_zero`.
  rcases lt_trichotomy x 0 with hx|hx|hx,
  { have : f_aux (n+1) x = 0, by simp [f_aux, le_of_lt hx],
    rw this,
    apply (has_deriv_at_const x (0 : ℝ)).congr_of_eventually_eq,
    filter_upwards [gt_mem_nhds hx] with _ hy,
    simp [f_aux, hy.le] },
  { have : f_aux (n + 1) 0 = 0, by simp [f_aux, le_refl],
    rw [hx, this],
    exact f_aux_deriv_zero n },
  { have : f_aux (n+1) x = (P_aux (n+1)).eval x * exp (-x⁻¹) / x^(2 * (n+1)),
      by simp [f_aux, not_le_of_gt hx],
    rw this,
    exact f_aux_deriv_pos n x hx },
end

/-- The successive derivatives of the auxiliary function `f_aux 0` are the
functions `f_aux n`, by induction. -/
lemma f_aux_iterated_deriv (n : ℕ) : iterated_deriv n (f_aux 0) = f_aux n :=
begin
  induction n with n IH,
  { simp },
  { simp [iterated_deriv_succ, IH],
    ext x,
    exact (f_aux_has_deriv_at n x).deriv }
end

/-- The function `exp_neg_inv_glue` is smooth. -/
protected theorem cont_diff {n} : cont_diff ℝ n exp_neg_inv_glue :=
begin
  rw ← f_aux_zero_eq,
  apply cont_diff_of_differentiable_iterated_deriv (λ m hm, _),
  rw f_aux_iterated_deriv m,
  exact λ x, (f_aux_has_deriv_at m x).differentiable_at
end

/-- The function `exp_neg_inv_glue` vanishes on `(-∞, 0]`. -/
lemma zero_of_nonpos {x : ℝ} (hx : x ≤ 0) : exp_neg_inv_glue x = 0 :=
by simp [exp_neg_inv_glue, hx]

/-- The function `exp_neg_inv_glue` is positive on `(0, +∞)`. -/
lemma pos_of_pos {x : ℝ} (hx : 0 < x) : 0 < exp_neg_inv_glue x :=
by simp [exp_neg_inv_glue, not_le.2 hx, exp_pos]

/-- The function exp_neg_inv_glue` is nonnegative. -/
lemma nonneg (x : ℝ) : 0 ≤ exp_neg_inv_glue x :=
begin
  cases le_or_gt x 0,
  { exact ge_of_eq (zero_of_nonpos h) },
  { exact le_of_lt (pos_of_pos h) }
end

end exp_neg_inv_glue

/-- An infinitely smooth function `f : ℝ → ℝ` such that `f x = 0` for `x ≤ 0`,
`f x = 1` for `1 ≤ x`, and `0 < f x < 1` for `0 < x < 1`. -/
def real.smooth_transition (x : ℝ) : ℝ :=
exp_neg_inv_glue x / (exp_neg_inv_glue x + exp_neg_inv_glue (1 - x))

namespace real

namespace smooth_transition

variables {x : ℝ}

open exp_neg_inv_glue

lemma pos_denom (x) : 0 < exp_neg_inv_glue x + exp_neg_inv_glue (1 - x) :=
(zero_lt_one.lt_or_lt x).elim
  (λ hx, add_pos_of_pos_of_nonneg (pos_of_pos hx) (nonneg _))
  (λ hx, add_pos_of_nonneg_of_pos (nonneg _) (pos_of_pos $ sub_pos.2 hx))

lemma one_of_one_le (h : 1 ≤ x) : smooth_transition x = 1 :=
(div_eq_one_iff_eq $ (pos_denom x).ne').2 $ by rw [zero_of_nonpos (sub_nonpos.2 h), add_zero]

lemma zero_of_nonpos (h : x ≤ 0) : smooth_transition x = 0 :=
by rw [smooth_transition, zero_of_nonpos h, zero_div]

@[simp] protected lemma zero : smooth_transition 0 = 0 :=
zero_of_nonpos le_rfl

@[simp] protected lemma one : smooth_transition 1 = 1 :=
one_of_one_le le_rfl

lemma le_one (x : ℝ) : smooth_transition x ≤ 1 :=
(div_le_one (pos_denom x)).2 $ le_add_of_nonneg_right (nonneg _)

lemma nonneg (x : ℝ) : 0 ≤ smooth_transition x :=
div_nonneg (exp_neg_inv_glue.nonneg _) (pos_denom x).le

lemma lt_one_of_lt_one (h : x < 1) : smooth_transition x < 1 :=
(div_lt_one $ pos_denom x).2 $ lt_add_of_pos_right _ $ pos_of_pos $ sub_pos.2 h

lemma pos_of_pos (h : 0 < x) : 0 < smooth_transition x :=
div_pos (exp_neg_inv_glue.pos_of_pos h) (pos_denom x)

protected lemma cont_diff {n} : cont_diff ℝ n smooth_transition :=
exp_neg_inv_glue.cont_diff.div
  (exp_neg_inv_glue.cont_diff.add $ exp_neg_inv_glue.cont_diff.comp $
    cont_diff_const.sub cont_diff_id) $
  λ x, (pos_denom x).ne'

protected lemma cont_diff_at {x n} : cont_diff_at ℝ n smooth_transition x :=
smooth_transition.cont_diff.cont_diff_at

protected lemma continuous : continuous smooth_transition :=
(@smooth_transition.cont_diff 0).continuous

end smooth_transition

end real

variables {E X : Type*}

/-- `f : cont_diff_bump c`, where `c` is a point in a normed vector space, is a
bundled smooth function such that

- `f` is equal to `1` in `metric.closed_ball c f.r`;
- `support f = metric.ball c f.R`;
- `0 ≤ f x ≤ 1` for all `x`.

The structure `cont_diff_bump` contains the data required to construct the function:
real numbers `r`, `R`, and proofs of `0 < r < R`. The function itself is available through
`coe_fn` when the space is nice enough, i.e., satisfies the `has_cont_diff_bump` typeclass. -/
structure cont_diff_bump (c : E) :=
(r R : ℝ)
(r_pos : 0 < r)
(r_lt_R : r < R)

/-- The base function from which one will construct a family of bump functions. One could
add more properties if they are useful and satisfied in the examples of inner product spaces
and finite dimensional vector spaces, notably derivative norm control in terms of `R - 1`. -/
@[nolint has_nonempty_instance]
structure cont_diff_bump_base (E : Type*) [normed_add_comm_group E] [normed_space ℝ E] :=
(to_fun : ℝ → E → ℝ)
(mem_Icc   : ∀ (R : ℝ) (x : E), to_fun R x ∈ Icc (0 : ℝ) 1)
(symmetric : ∀ (R : ℝ) (x : E), to_fun R (-x) = to_fun R x)
(smooth    : cont_diff_on ℝ ⊤ (uncurry to_fun) ((Ioi (1 : ℝ)) ×ˢ (univ : set E)))
(eq_one    : ∀ (R : ℝ) (hR : 1 < R) (x : E) (hx : ‖x‖ ≤ 1), to_fun R x = 1)
(support   : ∀ (R : ℝ) (hR : 1 < R), support (to_fun R) = metric.ball (0 : E) R)

/-- A class registering that a real vector space admits bump functions. This will be instantiated
first for inner product spaces, and then for finite-dimensional normed spaces.
We use a specific class instead of `nonempty (cont_diff_bump_base E)` for performance reasons. -/
class has_cont_diff_bump (E : Type*) [normed_add_comm_group E] [normed_space ℝ E] : Prop :=
(out : nonempty (cont_diff_bump_base E))

/-- In a space with `C^∞` bump functions, register some function that will be used as a basis
to construct bump functions of arbitrary size around any point. -/
def some_cont_diff_bump_base (E : Type*) [normed_add_comm_group E] [normed_space ℝ E]
  [hb : has_cont_diff_bump E] : cont_diff_bump_base E :=
nonempty.some hb.out

/-- Any inner product space has smooth bump functions. -/
@[priority 100] instance has_cont_diff_bump_of_inner_product_space
  (E : Type*) [normed_add_comm_group E] [inner_product_space ℝ E] : has_cont_diff_bump E :=
let e : cont_diff_bump_base E :=
{ to_fun := λ R x, real.smooth_transition ((R - ‖x‖) / (R - 1)),
  mem_Icc := λ R x, ⟨real.smooth_transition.nonneg _, real.smooth_transition.le_one _⟩,
  symmetric := λ R x, by simp only [norm_neg],
  smooth := begin
    rintros ⟨R, x⟩ ⟨(hR : 1 < R), hx⟩,
    apply cont_diff_at.cont_diff_within_at,
    rcases eq_or_ne x 0 with rfl|hx,
    { have : (λ (p : ℝ × E), real.smooth_transition ((p.1 - ‖p.2‖) / (p.1 - 1)))
        =ᶠ[𝓝 (R, 0)] (λ p, 1),
      { have A : tendsto (λ (p : ℝ × E), (p.1 - ‖p.2‖) / (p.1 - 1))
          (𝓝 (R, 0)) (𝓝 ((R - ‖(0 : E)‖) / (R - 1))),
        { rw nhds_prod_eq,
          apply (tendsto_fst.sub tendsto_snd.norm).div (tendsto_fst.sub tendsto_const_nhds),
          exact (sub_pos.2 hR).ne' },
        have : ∀ᶠ (p : ℝ × E) in 𝓝 (R, 0), 1 < (p.1 - ‖p.2‖) / (p.1 - 1),
        { apply (tendsto_order.1 A).1,
          apply (one_lt_div (sub_pos.2 hR)).2,
          simp only [norm_zero, tsub_zero, sub_lt_self_iff, zero_lt_one] },
        filter_upwards [this] with q hq,
        exact real.smooth_transition.one_of_one_le hq.le },
      exact cont_diff_at_const.congr_of_eventually_eq this },
    { refine real.smooth_transition.cont_diff_at.comp _ _,
      refine cont_diff_at.div _ _ (sub_pos.2 hR).ne',
      { exact cont_diff_at_fst.sub (cont_diff_at_snd.norm ℝ hx) },
      { exact cont_diff_at_fst.sub cont_diff_at_const } }
  end,
  eq_one := λ R hR x hx, real.smooth_transition.one_of_one_le $
    (one_le_div (sub_pos.2 hR)).2 (sub_le_sub_left hx _),
  support := λ R hR, begin
    apply subset.antisymm,
    { assume x hx,
      simp only [mem_support] at hx,
      contrapose! hx,
      simp only [mem_ball_zero_iff, not_lt] at hx,
      apply real.smooth_transition.zero_of_nonpos,
      apply div_nonpos_of_nonpos_of_nonneg;
      linarith },
    { assume x hx,
      simp only [mem_ball_zero_iff] at hx,
      apply (real.smooth_transition.pos_of_pos _).ne',
      apply div_pos;
      linarith }
  end, }
in ⟨⟨e⟩⟩

namespace cont_diff_bump

lemma R_pos {c : E} (f : cont_diff_bump c) : 0 < f.R := f.r_pos.trans f.r_lt_R

lemma one_lt_R_div_r {c : E} (f : cont_diff_bump c) : 1 < f.R / f.r :=
begin
  rw one_lt_div f.r_pos,
  exact f.r_lt_R
end

instance (c : E) : inhabited (cont_diff_bump c) := ⟨⟨1, 2, zero_lt_one, one_lt_two⟩⟩

variables [normed_add_comm_group E] [normed_space ℝ E] [normed_add_comm_group X] [normed_space ℝ X]
[has_cont_diff_bump E] {c : E} (f : cont_diff_bump c) {x : E} {n : ℕ∞}

/-- The function defined by `f : cont_diff_bump c`. Use automatic coercion to
function instead. -/
def to_fun {c : E} (f : cont_diff_bump c) : E → ℝ :=
λ x, (some_cont_diff_bump_base E).to_fun (f.R / f.r) (f.r⁻¹ • (x - c))

instance : has_coe_to_fun (cont_diff_bump c) (λ _, E → ℝ) := ⟨to_fun⟩

protected lemma «def» (x : E) :
  f x = (some_cont_diff_bump_base E).to_fun (f.R / f.r) (f.r⁻¹ • (x - c)) :=
rfl

protected lemma sub (x : E) : f (c - x) = f (c + x) :=
by simp [f.def, cont_diff_bump_base.symmetric]

protected

open metric

lemma one_of_mem_closed_ball (hx : x ∈ closed_ball c f.r) :
  f x = 1 :=
begin
  apply cont_diff_bump_base.eq_one _ _ f.one_lt_R_div_r,
  simpa only [norm_smul, norm_eq_abs, abs_inv, abs_of_nonneg f.r_pos.le, ← div_eq_inv_mul,
    div_le_one f.r_pos] using mem_closed_ball_iff_norm.1 hx
end

lemma nonneg : 0 ≤ f x :=
(cont_diff_bump_base.mem_Icc ((some_cont_diff_bump_base E)) _ _).1

/-- A version of `cont_diff_bump.nonneg` with `x` explicit -/
lemma nonneg' (x : E) : 0 ≤ f x :=
f.nonneg

lemma le_one : f x ≤ 1 :=
(cont_diff_bump_base.mem_Icc ((some_cont_diff_bump_base E)) _ _).2

lemma pos_of_mem_ball (hx : x ∈ ball c f.R) : 0 < f x :=
begin
  refine lt_iff_le_and_ne.2 ⟨f.nonneg, ne.symm _⟩,
  change (f.r)⁻¹ • (x - c) ∈ support ((some_cont_diff_bump_base E).to_fun (f.R / f.r)),
  rw cont_diff_bump_base.support _ _ f.one_lt_R_div_r,
  simp only [dist_eq_norm, mem_ball] at hx,
  simpa only [norm_smul, mem_ball_zero_iff, norm_eq_abs, abs_inv, abs_of_nonneg f.r_pos.le,
    ← div_eq_inv_mul] using (div_lt_div_right f.r_pos).2 hx,
end

lemma zero_of_le_dist (hx : f.R ≤ dist x c) : f x = 0 :=
begin
  rw dist_eq_norm at hx,
  suffices H : (f.r)⁻¹ • (x - c) ∉ support ((some_cont_diff_bump_base E).to_fun (f.R / f.r)),
    by simpa only [mem_support, not_not] using H,
  rw cont_diff_bump_base.support _ _ f.one_lt_R_div_r,
  simp [norm_smul, norm_eq_abs, abs_inv, abs_of_nonneg f.r_pos.le, ← div_eq_inv_mul],
  exact div_le_div_of_le f.r_pos.le hx,
end

lemma support_eq : support (f : E → ℝ) = metric.ball c f.R :=
begin
  ext x,
  suffices : f x ≠ 0 ↔ dist x c < f.R, by simpa [mem_support],
  cases lt_or_le (dist x c) f.R with hx hx,
  { simp only [hx, (f.pos_of_mem_ball hx).ne', ne.def, not_false_iff]},
  { simp only [hx.not_lt, f.zero_of_le_dist hx, ne.def, eq_self_iff_true, not_true] }
end

lemma tsupport_eq : tsupport f = closed_ball c f.R :=
by simp_rw [tsupport, f.support_eq, closure_ball _ f.R_pos.ne']

protected lemma has_compact_support [finite_dimensional ℝ E] : has_compact_support f :=
by simp_rw [has_compact_support, f.tsupport_eq, is_compact_closed_ball]

lemma eventually_eq_one_of_mem_ball (h : x ∈ ball c f.r) :
  f =ᶠ[𝓝 x] 1 :=
((is_open_lt (continuous_id.dist continuous_const) continuous_const).eventually_mem h).mono $
  λ z hz, f.one_of_mem_closed_ball (le_of_lt hz)

lemma eventually_eq_one : f =ᶠ[𝓝 c] 1 :=
f.eventually_eq_one_of_mem_ball (mem_ball_self f.r_pos)

/-- `cont_diff_bump` is `𝒞ⁿ` in all its arguments. -/
protected lemma _root_.cont_diff_at.cont_diff_bump {c g : X → E}
  {f : ∀ x, cont_diff_bump (c x)} {x : X}
  (hc : cont_diff_at ℝ n c x) (hr : cont_diff_at ℝ n (λ x, (f x).r) x)
  (hR : cont_diff_at ℝ n (λ x, (f x).R) x)
  (hg : cont_diff_at ℝ n g x) : cont_diff_at ℝ n (λ x, f x (g x)) x :=
begin
  rcases eq_or_ne (g x) (c x) with hx|hx,
  { have : (λ x, f x (g x)) =ᶠ[𝓝 x] (λ x, 1),
    { have : dist (g x) (c x) < (f x).r, { simp_rw [hx, dist_self, (f x).r_pos] },
      have := continuous_at.eventually_lt (hg.continuous_at.dist hc.continuous_at) hr.continuous_at
        this,
      exact eventually_of_mem this
        (λ x hx, (f x).one_of_mem_closed_ball (mem_set_of_eq.mp hx).le) },
    exact cont_diff_at_const.congr_of_eventually_eq this },
  { change cont_diff_at ℝ n ((uncurry (some_cont_diff_bump_base E).to_fun) ∘
      (λ (x : X),  ((f x).R / (f x).r, ((f x).r)⁻¹ • (g x - c x)))) x,
    have A : ((f x).R / (f x).r, ((f x).r)⁻¹ • (g x - c x)) ∈ Ioi (1 : ℝ) ×ˢ (univ : set E),
      by simpa only [prod_mk_mem_set_prod_eq, mem_univ, and_true] using (f x).one_lt_R_div_r,
    have B : Ioi (1 : ℝ) ×ˢ (univ : set E) ∈ 𝓝 ((f x).R / (f x).r, (f x).r⁻¹ • (g x - c x)),
      from (is_open_Ioi.prod is_open_univ).mem_nhds A,
    apply ((((some_cont_diff_bump_base E).smooth.cont_diff_within_at A).cont_diff_at B)
      .of_le le_top).comp x _,
    exact (hR.div hr (f x).r_pos.ne').prod ((hr.inv (f x).r_pos.ne').smul (hg.sub hc)) }
end

lemma _root_.cont_diff.cont_diff_bump {c g : X → E} {f : ∀ x, cont_diff_bump (c x)}
  (hc : cont_diff ℝ n c) (hr : cont_diff ℝ n (λ x, (f x).r)) (hR : cont_diff ℝ n (λ x, (f x).R))
  (hg : cont_diff ℝ n g) : cont_diff ℝ n (λ x, f x (g x)) :=
by { rw [cont_diff_iff_cont_diff_at] at *, exact λ x, (hc x).cont_diff_bump (hr x) (hR x) (hg x) }

protected lemma cont_diff : cont_diff ℝ n f :=
cont_diff_const.cont_diff_bump cont_diff_const cont_diff_const cont_diff_id

protected lemma cont_diff_at : cont_diff_at ℝ n f x :=
f.cont_diff.cont_diff_at

protected lemma cont_diff_within_at {s : set E} : cont_diff_within_at ℝ n f s x :=
f.cont_diff_at.cont_diff_within_at

protected lemma continuous : continuous f :=
cont_diff_zero.mp f.cont_diff

open measure_theory
variables [measurable_space E] {μ : measure E}

/-- A bump function normed so that `∫ x, f.normed μ x ∂μ = 1`. -/
protected def normed (μ : measure E) : E → ℝ :=
λ x, f x / ∫ x, f x ∂μ

lemma normed_def {μ : measure E} (x : E) : f.normed μ x = f x / ∫ x, f x ∂μ :=
rfl

lemma nonneg_normed (x : E) : 0 ≤ f.normed μ x :=
div_nonneg f.nonneg $ integral_nonneg f.nonneg'

lemma cont_diff_normed {n : ℕ∞} : cont_diff ℝ n (f.normed μ) :=
f.cont_diff.div_const _

lemma continuous_normed : continuous (f.normed μ) :=
f.continuous.div_const _

lemma normed_sub (x : E) : f.normed μ (c - x) = f.normed μ (c + x) :=
by simp_rw [f.normed_def, f.sub]

lemma normed_neg (f : cont_diff_bump (0 : E)) (x : E) : f.normed μ (- x) = f.normed μ x :=
by simp_rw [f.normed_def, f.neg]

variables [borel_space E] [finite_dimensional ℝ E] [is_locally_finite_measure μ]

protected lemma integrable : integrable f μ :=
f.continuous.integrable_of_has_compact_support f.has_compact_support

protected lemma integrable_normed : integrable (f.normed μ) μ :=
f.integrable.div_const _

variables [μ .is_open_pos_measure]

lemma integral_pos : 0 < ∫ x, f x ∂μ :=
begin
  refine (integral_pos_iff_support_of_nonneg f.nonneg' f.integrable).mpr _,
  rw [f.support_eq],
  refine is_open_ball.measure_pos _ (nonempty_ball.mpr f.R_pos)
end

lemma integral_normed : ∫ x, f.normed μ x ∂μ = 1 :=
begin
  simp_rw [cont_diff_bump.normed, div_eq_mul_inv, mul_comm (f _), ← smul_eq_mul,
    integral_smul],
  exact inv_mul_cancel (f.integral_pos.ne')
end

lemma support_normed_eq : support (f.normed μ) = metric.ball c f.R :=
by simp_rw [cont_diff_bump.normed, support_div, f.support_eq,
  support_const f.integral_pos.ne', inter_univ]

lemma tsupport_normed_eq : tsupport (f.normed μ) = metric.closed_ball c f.R :=
by simp_rw [tsupport, f.support_normed_eq, closure_ball _ f.R_pos.ne']

lemma has_compact_support_normed : has_compact_support (f.normed μ) :=
by simp_rw [has_compact_support, f.tsupport_normed_eq, is_compact_closed_ball]

lemma tendsto_support_normed_small_sets {ι} {φ : ι → cont_diff_bump c} {l : filter ι}
  (hφ : tendsto (λ i, (φ i).R) l (𝓝 0)) :
  tendsto (λ i, support (λ x, (φ i).normed μ x)) l (𝓝 c).small_sets :=
begin
  simp_rw [normed_add_comm_group.tendsto_nhds_zero, real.norm_eq_abs,
    abs_eq_self.mpr (φ _).R_pos.le] at hφ,
  rw [tendsto_small_sets_iff],
  intros t ht,
  rcases metric.mem_nhds_iff.mp ht with ⟨ε, hε, ht⟩,
  refine (hφ ε hε).mono (λ i hi, subset_trans _ ht),
  simp_rw [(φ i).support_normed_eq],
  exact ball_subset_ball hi.le
end

variable (μ)
lemma integral_normed_smul [complete_space X] (z : X) :
  ∫ x, f.normed μ x • z ∂μ = z :=
by simp_rw [integral_smul_const, f.integral_normed, one_smul]

end cont_diff_bump


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Casper Putz, Anne Baanen
-/

import data.matrix.basic
import linear_algebra.std_basis

/-!
# Dot product of two vectors

This file contains some results on the map `matrix.dot_product`, which maps two
vectors `v w : n → R` to the sum of the entrywise products `v i * w i`.

## Main results

* `matrix.dot_product_std_basis_one`: the dot product of `v` with the `i`th
  standard basis vector is `v i`
* `matrix.dot_product_eq_zero_iff`: if `v`'s' dot product with all `w` is zero,
  then `v` is zero

## Tags

matrix, reindex

-/

universes v w

namespace matrix

variables {R : Type v} [semiring R] {n : Type w} [fintype n]

@[simp] lemma dot_product_std_basis_eq_mul [decidable_eq n] (v : n → R) (c : R) (i : n) :
  dot_product v (linear_map.std_basis R (λ _, R) i c) = v i * c :=
begin
  rw [dot_product, finset.sum_eq_single i, linear_map.std_basis_same],
  exact λ _ _ hb, by rw [linear_map.std_basis_ne _ _ _ _ hb, mul_zero],
  exact λ hi, false.elim (hi $ finset.mem_univ _)
end

@[simp] lemma dot_product_std_basis_one [decidable_eq n] (v : n → R) (i : n) :
  dot_product v (linear_map.std_basis R (λ _, R) i 1) = v i :=
by rw [dot_product_std_basis_eq_mul, mul_one]

lemma dot_product_eq
  (v w : n → R) (h : ∀ u, dot_product v u = dot_product w u) : v = w :=
begin
  funext x,
  classical,
  rw [← dot_product_std_basis_one v x, ← dot_product_std_basis_one w x, h],
end

lemma dot_product_eq_iff {v w : n → R} :
  (∀ u, dot_product v u = dot_product w u) ↔ v = w :=
⟨λ h, dot_product_eq v w h, λ h _, h ▸ rfl⟩

lemma dot_product_eq_zero (v : n → R) (h : ∀ w, dot_product v w = 0) : v = 0 :=
dot_product_eq _ _ $ λ u, (h u).symm ▸ (zero_dot_product u).symm

lemma dot_product_eq_zero_iff {v : n → R} : (∀ w, dot_product v w = 0) ↔ v = 0 :=
⟨λ h, dot_product_eq_zero v h, λ h w, h.symm ▸ zero_dot_product w⟩

end matrix


/-
Copyright © 2018 François G. Dorais. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import .basic .cons .conj .append

namespace tup
variable {α : Type*}

section folds
variable {β : Sort*}

definition foldr (y : β) (f : α → β → β) : Π {n : ℕ}, α ^ n → β
| 0 _ := y
| (n+1) xs := f xs.head (foldr xs.tail)

lemma foldr_nil {y : β} {f : α → β → β} :
foldr y f nil = y := rfl

lemma foldr_cons {y : β} {f : α → β → β} {n : ℕ} {xs : α ^ n} {x : α} :
foldr y f (x :: xs) = f x (foldr y f xs) :=
by simp [foldr]

definition foldl (y : β) (f : β → α → β) : Π {n : ℕ}, α ^ n → β
| 0 _ := y
| (n+1) xs := f (foldl xs.left) xs.last

lemma foldl_nil {y : β} {f : β → α → β} :
foldl y f nil = y := rfl

lemma foldl_conj {y : β} {f : β → α → β} {n : ℕ} {xs : α ^ n} {x : α} :
foldl y f (xs && x) = f (foldl y f xs) x :=
by simp [foldl]

end folds

section sum
variables [hzero : has_zero α] [hadd : has_add α]
include hzero hadd

@[reducible]
definition sum {n : ℕ} : α ^ n → α := foldl (0:α) (+)

@[simp]
lemma sum_nil : sum (@nil α) = 0 := foldl_nil

@[simp]
lemma sum_conj {n : ℕ} {xs : α ^ n} {x : α} :
sum (xs && x) = sum xs + x := foldl_conj

@[reducible]
definition sum' {n : ℕ} : α ^ n → α := foldr (0:α) (+)

@[simp]
lemma sum'_nil : sum' (@nil α) = 0 := foldr_nil

@[simp]
lemma sum'_cons {x : α} {n : ℕ} {xs : α ^ n} :
sum' (x :: xs) = x + sum' xs := foldr_cons

end sum

section prod
variables [hone : has_one α] [hmul : has_mul α]
include hone hmul

@[reducible]
definition prod {n : ℕ} : α ^ n → α := foldl (1:α) (*)

@[simp]
lemma prod_nil : prod nil = 1 := foldl_nil

@[simp]
lemma prod_conj {x : α} {n : ℕ} {xs : α ^ n} :
prod (xs && x) = prod xs * x := foldl_conj

@[reducible]
definition prod' {n : ℕ} : α ^ n → α := foldr (1:α) (*)

@[simp]
lemma prod'_nil : prod' nil = 1 := foldr_nil

@[simp]
lemma prod'_cons {x : α} {n : ℕ} {xs : α ^ n} :
prod' (x :: xs) = x * prod' xs := foldr_cons

end prod

section join
variables [hnil : has_emptyc α] [happ : has_append α]
include hnil happ

@[reducible]
definition join {n : ℕ} : α ^ n → α :=
foldr hnil.emptyc has_append.append

@[simp]
lemma join_nil : join nil = hnil.emptyc := foldr_nil

@[simp]
lemma join_cons {x : α} {n : ℕ} {xs : α ^ n} :
join (x :: xs) = has_append.append x (join xs) := foldr_cons

@[reducible]
definition join' {n : ℕ} : α ^ n → α :=
foldl hnil.emptyc has_append.append

@[simp]
lemma join'_nil : join' nil = hnil.emptyc := foldl_nil

@[simp]
lemma join'_conj {n : ℕ} {xs : α ^ n} {x : α} :
join' (xs && x) = has_append.append (join' xs) x := foldl_conj

end join

end tup


/-
Copyright (c) 2020 Aaron Anderson, Jalex Stark. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson, Jalex Stark
-/

import linear_algebra.matrix.charpoly.coeff
import linear_algebra.matrix.to_lin
import ring_theory.power_basis

/-!
# The minimal polynomial divides the characteristic polynomial of a matrix.
-/

noncomputable theory

universes u v

open polynomial matrix

variables {R : Type u} [comm_ring R]
variables {n : Type v} [decidable_eq n] [fintype n]

open finset

variable {M : matrix n n R}

namespace matrix

theorem is_integral : is_integral R M := ⟨M.charpoly, ⟨charpoly_monic M, aeval_self_charpoly M⟩⟩

theorem minpoly_dvd_charpoly {K : Type*} [field K] (M : matrix n n K) :
  (minpoly K M) ∣ M.charpoly :=
minpoly.dvd _ _ (aeval_self_charpoly M)

end matrix

section power_basis

open algebra

/-- The characteristic polynomial of the map `λ x, a * x` is the minimal polynomial of `a`.

In combination with `det_eq_sign_charpoly_coeff` or `trace_eq_neg_charpoly_coeff`
and a bit of rewriting, this will allow us to conclude the
field norm resp. trace of `x` is the product resp. sum of `x`'s conjugates.
-/
lemma charpoly_left_mul_matrix {K S : Type*} [field K] [comm_ring S] [algebra K S]
  (h : power_basis K S) :
  (left_mul_matrix h.basis h.gen).charpoly = minpoly K h.gen :=
begin
  apply minpoly.unique,
  { apply matrix.charpoly_monic },
  { apply (injective_iff_map_eq_zero (left_mul_matrix _)).mp (left_mul_matrix_injective h.basis),
    rw [← polynomial.aeval_alg_hom_apply, aeval_self_charpoly] },
  { intros q q_monic root_q,
    rw [matrix.charpoly_degree_eq_dim, fintype.card_fin, degree_eq_nat_degree q_monic.ne_zero],
    apply with_bot.some_le_some.mpr,
    exact h.dim_le_nat_degree_of_root q_monic.ne_zero root_q }
end

end power_basis


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta, Huỳnh Trần Khanh, Stuart Presnell

! This file was ported from Lean 3 source module data.sym.card
! leanprover-community/mathlib commit 0bd2ea37bcba5769e14866170f251c9bc64e35d7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.BigOperators.Basic
import Mathbin.Data.Finset.Sym
import Mathbin.Data.Fintype.Sum

/-!
# Stars and bars

In this file, we prove (in `sym.card_sym_eq_multichoose`) that the function `multichoose n k`
defined in `data/nat/choose/basic` counts the number of multisets of cardinality `k` over an
alphabet of cardinality `n`. In conjunction with `nat.multichoose_eq` proved in
`data/nat/choose/basic`, which shows that `multichoose n k = choose (n + k - 1) k`,
this is central to the "stars and bars" technique in combinatorics, where we switch between
counting multisets of size `k` over an alphabet of size `n` to counting strings of `k` elements
("stars") separated by `n-1` dividers ("bars").

## Informal statement

Many problems in mathematics are of the form of (or can be reduced to) putting `k` indistinguishable
objects into `n` distinguishable boxes; for example, the problem of finding natural numbers
`x1, ..., xn` whose sum is `k`. This is equivalent to forming a multiset of cardinality `k` from
an alphabet of cardinality `n` -- for each box `i ∈ [1, n]` the multiset contains as many copies
of `i` as there are items in the `i`th box.

The "stars and bars" technique arises from another way of presenting the same problem. Instead of
putting `k` items into `n` boxes, we take a row of `k` items (the "stars") and separate them by
inserting `n-1` dividers (the "bars").  For example, the pattern `*|||**|*|` exhibits 4 items
distributed into 6 boxes -- note that any box, including the first and last, may be empty.
Such arrangements of `k` stars and `n-1` bars are in 1-1 correspondence with multisets of size `k`
over an alphabet of size `n`, and are counted by `choose (n + k - 1) k`.

Note that this problem is one component of Gian-Carlo Rota's "Twelvefold Way"
https://en.wikipedia.org/wiki/Twelvefold_way

## Formal statement

Here we generalise the alphabet to an arbitrary fintype `α`, and we use `sym α k` as the type of
multisets of size `k` over `α`. Thus the statement that these are counted by `multichoose` is:
`sym.card_sym_eq_multichoose : card (sym α k) = multichoose (card α) k`
while the "stars and bars" technique gives
`sym.card_sym_eq_choose : card (sym α k) = choose (card α + k - 1) k`

## Tags

stars and bars, multichoose
-/

open Finset Fintype Function Sum Nat

variable {α β : Type _}

namespace Sym

section Sym

variable (α) (n : ℕ)

/-- Over `fin n+1`, the multisets of size `k+1` containing `0` are equivalent to those of size `k`,
as demonstrated by respectively erasing or appending `0`.
-/
protected def e1 {n k : ℕ} : { s : Sym (Fin n.succ) k.succ // ↑0 ∈ s } ≃ Sym (Fin n.succ) k
    where
  toFun s := s.1.eraseₓ 0 s.2
  invFun s := ⟨cons 0 s, mem_cons_self 0 s⟩
  left_inv s := by simp
  right_inv s := by simp
#align sym.E1 Sym.e1

/-- The multisets of size `k` over `fin n+2` not containing `0`
are equivalent to those of size `k` over `fin n+1`,
as demonstrated by respectively decrementing or incrementing every element of the multiset.
-/
protected def e2 {n k : ℕ} : { s : Sym (Fin n.succ.succ) k // ↑0 ∉ s } ≃ Sym (Fin n.succ) k
    where
  toFun s := map (Fin.predAbove 0) s.1
  invFun s :=
    ⟨map (Fin.succAbove 0) s,
      (mt mem_map.1) (not_exists.2 fun t => not_and.2 fun _ => Fin.succAbove_ne _ t)⟩
  left_inv s := by
    obtain ⟨s, hs⟩ := s
    simp only [map_map, comp_app]
    nth_rw_rhs 1 [← map_id' s]
    refine' Sym.map_congr fun v hv => _
    simp [Fin.predAbove_zero (ne_of_mem_of_not_mem hv hs)]
  right_inv s := by
    simp only [Fin.zero_succAbove, map_map, comp_app]
    nth_rw_rhs 1 [← map_id' s]
    refine' Sym.map_congr fun v hv => _
    rw [← Fin.zero_succAbove v, ← @Fin.castSucc_zero n.succ, Fin.predAbove_succAbove 0 v]
#align sym.E2 Sym.e2

theorem card_sym_fin_eq_multichoose (n k : ℕ) : card (Sym (Fin n) k) = multichoose n k :=
  by
  apply @pincer_recursion fun n k => card (Sym (Fin n) k) = multichoose n k
  · simp
  · intro b
    induction' b with b IHb
    · simp
    rw [multichoose_zero_succ, card_eq_zero_iff]
    infer_instance
  · intro x y h1 h2
    rw [multichoose_succ_succ, ← h1, ← h2, add_comm]
    cases x
    · simp only [card_eq_zero_iff, card_unique, self_eq_add_right]
      infer_instance
    rw [← card_sum]
    refine' Fintype.card_congr (Equiv.symm _)
    apply (Equiv.sumCongr sym.E1.symm sym.E2.symm).trans
    apply Equiv.sumCompl
#align sym.card_sym_fin_eq_multichoose Sym.card_sym_fin_eq_multichoose

/-- For any fintype `α` of cardinality `n`, `card (sym α k) = multichoose (card α) k` -/
theorem card_sym_eq_multichoose (α : Type _) (k : ℕ) [Fintype α] [Fintype (Sym α k)] :
    card (Sym α k) = multichoose (card α) k :=
  by
  rw [← card_sym_fin_eq_multichoose]
  exact card_congr (equiv_congr (equiv_fin α))
#align sym.card_sym_eq_multichoose Sym.card_sym_eq_multichoose

/-- The *stars and bars* lemma: the cardinality of `sym α k` is equal to
`nat.choose (card α + k - 1) k`. -/
theorem card_sym_eq_choose {α : Type _} [Fintype α] (k : ℕ) [Fintype (Sym α k)] :
    card (Sym α k) = (card α + k - 1).choose k := by
  rw [card_sym_eq_multichoose, Nat.multichoose_eq]
#align sym.card_sym_eq_choose Sym.card_sym_eq_choose

end Sym

end Sym

namespace Sym2

variable [DecidableEq α]

/-- The `diag` of `s : finset α` is sent on a finset of `sym2 α` of card `s.card`. -/
theorem card_image_diag (s : Finset α) : (s.diag.image Quotient.mk').card = s.card :=
  by
  rw [card_image_of_inj_on, diag_card]
  rintro ⟨x₀, x₁⟩ hx _ _ h
  cases Quotient.eq'.1 h
  · rfl
  · simp only [mem_coe, mem_diag] at hx
    rw [hx.2]
#align sym2.card_image_diag Sym2.card_image_diag

theorem two_mul_card_image_offDiag (s : Finset α) :
    2 * (s.offDiag.image Quotient.mk').card = s.offDiag.card :=
  by
  rw [card_eq_sum_card_fiberwise
      (fun x => mem_image_of_mem _ :
        ∀ x ∈ s.off_diag, Quotient.mk' x ∈ s.off_diag.image Quotient.mk'),
    sum_const_nat (Quotient.ind _), mul_comm]
  rintro ⟨x, y⟩ hxy
  simp_rw [mem_image, exists_prop, mem_off_diag, Quotient.eq'] at hxy
  obtain ⟨a, ⟨ha₁, ha₂, ha⟩, h⟩ := hxy
  obtain ⟨hx, hy, hxy⟩ : x ∈ s ∧ y ∈ s ∧ x ≠ y := by
    cases h <;> have := ha.symm <;> exact ⟨‹_›, ‹_›, ‹_›⟩
  have hxy' : y ≠ x := hxy.symm
  have : (s.off_diag.filter fun z => ⟦z⟧ = ⟦(x, y)⟧) = ({(x, y), (y, x)} : Finset _) :=
    by
    ext ⟨x₁, y₁⟩
    rw [mem_filter, mem_insert, mem_singleton, Sym2.eq_iff, Prod.mk.inj_iff, Prod.mk.inj_iff,
      and_iff_right_iff_imp]
    rintro (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩) <;> rw [mem_off_diag] <;> exact ⟨‹_›, ‹_›, ‹_›⟩
  -- hxy' is used here
  rw [this, card_insert_of_not_mem, card_singleton]
  simp only [not_and, Prod.mk.inj_iff, mem_singleton]
  exact fun _ => hxy'
#align sym2.two_mul_card_image_off_diag Sym2.two_mul_card_image_offDiag

/-- The `off_diag` of `s : finset α` is sent on a finset of `sym2 α` of card `s.off_diag.card / 2`.
This is because every element `⟦(x, y)⟧` of `sym2 α` not on the diagonal comes from exactly two
pairs: `(x, y)` and `(y, x)`. -/
theorem card_image_offDiag (s : Finset α) : (s.offDiag.image Quotient.mk').card = s.card.choose 2 :=
  by
  rw [Nat.choose_two_right, mul_tsub, mul_one, ← off_diag_card,
    Nat.div_eq_of_eq_mul_right zero_lt_two (two_mul_card_image_off_diag s).symm]
#align sym2.card_image_off_diag Sym2.card_image_offDiag

theorem card_subtype_diag [Fintype α] : card { a : Sym2 α // a.IsDiag } = card α :=
  by
  convert card_image_diag (univ : Finset α)
  rw [Fintype.card_of_subtype, ← filter_image_quotient_mk_is_diag]
  rintro x
  rw [mem_filter, univ_product_univ, mem_image]
  obtain ⟨a, ha⟩ := Quotient.exists_rep x
  exact and_iff_right ⟨a, mem_univ _, ha⟩
#align sym2.card_subtype_diag Sym2.card_subtype_diag

theorem card_subtype_not_diag [Fintype α] : card { a : Sym2 α // ¬a.IsDiag } = (card α).choose 2 :=
  by
  convert card_image_off_diag (univ : Finset α)
  rw [Fintype.card_of_subtype, ← filter_image_quotient_mk_not_is_diag]
  rintro x
  rw [mem_filter, univ_product_univ, mem_image]
  obtain ⟨a, ha⟩ := Quotient.exists_rep x
  exact and_iff_right ⟨a, mem_univ _, ha⟩
#align sym2.card_subtype_not_diag Sym2.card_subtype_not_diag

/-- Finset **stars and bars** for the case `n = 2`. -/
theorem Finset.card_sym2 (s : Finset α) : s.Sym2.card = s.card * (s.card + 1) / 2 :=
  by
  rw [← image_diag_union_image_off_diag, card_union_eq, Sym2.card_image_diag,
    Sym2.card_image_offDiag, Nat.choose_two_right, add_comm, ← Nat.triangle_succ, Nat.succ_sub_one,
    mul_comm]
  rw [disjoint_left]
  rintro m ha hb
  rw [mem_image] at ha hb
  obtain ⟨⟨a, ha, rfl⟩, ⟨b, hb, hab⟩⟩ := ha, hb
  refine' not_is_diag_mk_of_mem_off_diag hb _
  rw [hab]
  exact is_diag_mk_of_mem_diag ha
#align finset.card_sym2 Finset.card_sym2

/-- Type **stars and bars** for the case `n = 2`. -/
protected theorem card [Fintype α] : card (Sym2 α) = card α * (card α + 1) / 2 :=
  Finset.card_sym2 _
#align sym2.card Sym2.card

end Sym2


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

! This file was ported from Lean 3 source module linear_algebra.isomorphisms
! leanprover-community/mathlib commit 6d584f1709bedbed9175bd9350df46599bdd7213
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.Quotient

/-!
# Isomorphism theorems for modules.

* The Noether's first, second, and third isomorphism theorems for modules are proved as
  `linear_map.quot_ker_equiv_range`, `linear_map.quotient_inf_equiv_sup_quotient` and
  `submodule.quotient_quotient_equiv_quotient`.

-/

universe u v

variable {R M M₂ M₃ : Type _}

variable [Ring R] [AddCommGroup M] [AddCommGroup M₂] [AddCommGroup M₃]

variable [Module R M] [Module R M₂] [Module R M₃]

variable (f : M →ₗ[R] M₂)

/-! The first and second isomorphism theorems for modules. -/

namespace LinearMap

open Submodule

section IsomorphismLaws

/-- The first isomorphism law for modules. The quotient of `M` by the kernel of `f` is linearly
equivalent to the range of `f`. -/
noncomputable def quotKerEquivRange : (M ⧸ f.ker) ≃ₗ[R] f.range :=
  (LinearEquiv.ofInjective (f.ker.liftQ f <| le_rfl) <|
        ker_eq_bot.mp <| Submodule.ker_liftQ_eq_bot _ _ _ (le_refl f.ker)).trans
    (LinearEquiv.ofEq _ _ <| Submodule.range_liftQ _ _ _)
#align linear_map.quot_ker_equiv_range LinearMap.quotKerEquivRange

/-- The first isomorphism theorem for surjective linear maps. -/
noncomputable def quotKerEquivOfSurjective (f : M →ₗ[R] M₂) (hf : Function.Surjective f) :
    (M ⧸ f.ker) ≃ₗ[R] M₂ :=
  f.quotKerEquivRange.trans (LinearEquiv.ofTop f.range (LinearMap.range_eq_top.2 hf))
#align linear_map.quot_ker_equiv_of_surjective LinearMap.quotKerEquivOfSurjective

@[simp]
theorem quotKerEquivRange_apply_mk (x : M) :
    (f.quotKerEquivRange (Submodule.Quotient.mk x) : M₂) = f x :=
  rfl
#align linear_map.quot_ker_equiv_range_apply_mk LinearMap.quotKerEquivRange_apply_mk

@[simp]
theorem quotKerEquivRange_symm_apply_image (x : M) (h : f x ∈ f.range) :
    f.quotKerEquivRange.symm ⟨f x, h⟩ = f.ker.mkQ x :=
  f.quotKerEquivRange.symm_apply_apply (f.ker.mkQ x)
#align linear_map.quot_ker_equiv_range_symm_apply_image LinearMap.quotKerEquivRange_symm_apply_image

/-- Canonical linear map from the quotient `p/(p ∩ p')` to `(p+p')/p'`, mapping `x + (p ∩ p')`
to `x + p'`, where `p` and `p'` are submodules of an ambient module.
-/
def quotientInfToSupQuotient (p p' : Submodule R M) :
    p ⧸ comap p.Subtype (p ⊓ p') →ₗ[R] _ ⧸ comap (p ⊔ p').Subtype p' :=
  (comap p.subtype (p ⊓ p')).liftQ ((comap (p ⊔ p').Subtype p').mkQ.comp (of_le le_sup_left))
    (by
      rw [ker_comp, of_le, comap_cod_restrict, ker_mkq, map_comap_subtype]
      exact comap_mono (inf_le_inf_right _ le_sup_left))
#align linear_map.quotient_inf_to_sup_quotient LinearMap.quotientInfToSupQuotient

/--
Second Isomorphism Law : the canonical map from `p/(p ∩ p')` to `(p+p')/p'` as a linear isomorphism.
-/
noncomputable def quotientInfEquivSupQuotient (p p' : Submodule R M) :
    (p ⧸ comap p.Subtype (p ⊓ p')) ≃ₗ[R] _ ⧸ comap (p ⊔ p').Subtype p' :=
  LinearEquiv.ofBijective (quotient_inf_to_sup_quotient p p')
    ⟨by
      rw [← ker_eq_bot, quotient_inf_to_sup_quotient, ker_liftq_eq_bot]
      rw [ker_comp, ker_mkq]
      exact fun ⟨x, hx1⟩ hx2 => ⟨hx1, hx2⟩,
      by
      rw [← range_eq_top, quotient_inf_to_sup_quotient, range_liftq, eq_top_iff']
      rintro ⟨x, hx⟩; rcases mem_sup.1 hx with ⟨y, hy, z, hz, rfl⟩
      use ⟨y, hy⟩; apply (Submodule.Quotient.eq _).2
      change y - (y + z) ∈ p'
      rwa [sub_add_eq_sub_sub, sub_self, zero_sub, neg_mem_iff]⟩
#align linear_map.quotient_inf_equiv_sup_quotient LinearMap.quotientInfEquivSupQuotient

@[simp]
theorem coe_quotientInfToSupQuotient (p p' : Submodule R M) :
    ⇑(quotientInfToSupQuotient p p') = quotientInfEquivSupQuotient p p' :=
  rfl
#align linear_map.coe_quotient_inf_to_sup_quotient LinearMap.coe_quotientInfToSupQuotient

@[simp]
theorem quotientInfEquivSupQuotient_apply_mk (p p' : Submodule R M) (x : p) :
    quotientInfEquivSupQuotient p p' (Submodule.Quotient.mk x) =
      Submodule.Quotient.mk (ofLe (le_sup_left : p ≤ p ⊔ p') x) :=
  rfl
#align linear_map.quotient_inf_equiv_sup_quotient_apply_mk LinearMap.quotientInfEquivSupQuotient_apply_mk

theorem quotientInfEquivSupQuotient_symm_apply_left (p p' : Submodule R M) (x : p ⊔ p')
    (hx : (x : M) ∈ p) :
    (quotientInfEquivSupQuotient p p').symm (Submodule.Quotient.mk x) =
      Submodule.Quotient.mk ⟨x, hx⟩ :=
  (LinearEquiv.symm_apply_eq _).2 <| by simp [of_le_apply]
#align linear_map.quotient_inf_equiv_sup_quotient_symm_apply_left LinearMap.quotientInfEquivSupQuotient_symm_apply_left

@[simp]
theorem quotientInfEquivSupQuotient_symm_apply_eq_zero_iff {p p' : Submodule R M} {x : p ⊔ p'} :
    (quotientInfEquivSupQuotient p p').symm (Submodule.Quotient.mk x) = 0 ↔ (x : M) ∈ p' :=
  (LinearEquiv.symm_apply_eq _).trans <| by simp [of_le_apply]
#align linear_map.quotient_inf_equiv_sup_quotient_symm_apply_eq_zero_iff LinearMap.quotientInfEquivSupQuotient_symm_apply_eq_zero_iff

theorem quotientInfEquivSupQuotient_symm_apply_right (p p' : Submodule R M) {x : p ⊔ p'}
    (hx : (x : M) ∈ p') : (quotientInfEquivSupQuotient p p').symm (Submodule.Quotient.mk x) = 0 :=
  quotientInfEquivSupQuotient_symm_apply_eq_zero_iff.2 hx
#align linear_map.quotient_inf_equiv_sup_quotient_symm_apply_right LinearMap.quotientInfEquivSupQuotient_symm_apply_right

end IsomorphismLaws

end LinearMap

/-! The third isomorphism theorem for modules. -/

namespace Submodule

variable (S T : Submodule R M) (h : S ≤ T)

/-- The map from the third isomorphism theorem for modules: `(M / S) / (T / S) → M / T`. -/
def quotientQuotientEquivQuotientAux (h : S ≤ T) : (M ⧸ S) ⧸ T.map S.mkQ →ₗ[R] M ⧸ T :=
  liftq _ (mapq S T LinearMap.id h)
    (by
      rintro _ ⟨x, hx, rfl⟩
      rw [LinearMap.mem_ker, mkq_apply, mapq_apply]
      exact (quotient.mk_eq_zero _).mpr hx)
#align submodule.quotient_quotient_equiv_quotient_aux Submodule.quotientQuotientEquivQuotientAux

@[simp]
theorem quotientQuotientEquivQuotientAux_mk (x : M ⧸ S) :
    quotientQuotientEquivQuotientAux S T h (Quotient.mk x) = mapQ S T LinearMap.id h x :=
  liftQ_apply _ _ _
#align submodule.quotient_quotient_equiv_quotient_aux_mk Submodule.quotientQuotientEquivQuotientAux_mk

@[simp]
theorem quotientQuotientEquivQuotientAux_mk_mk (x : M) :
    quotientQuotientEquivQuotientAux S T h (Quotient.mk (Quotient.mk x)) = Quotient.mk x := by
  rw [quotient_quotient_equiv_quotient_aux_mk, mapq_apply, LinearMap.id_apply]
#align submodule.quotient_quotient_equiv_quotient_aux_mk_mk Submodule.quotientQuotientEquivQuotientAux_mk_mk

/-- **Noether's third isomorphism theorem** for modules: `(M / S) / (T / S) ≃ M / T`. -/
def quotientQuotientEquivQuotient : ((M ⧸ S) ⧸ T.map S.mkQ) ≃ₗ[R] M ⧸ T :=
  {
    quotientQuotientEquivQuotientAux S T
      h with
    toFun := quotientQuotientEquivQuotientAux S T h
    invFun := mapQ _ _ (mkQ S) (le_comap_map _ _)
    left_inv := fun x => Quotient.inductionOn' x fun x => Quotient.inductionOn' x fun x => by simp
    right_inv := fun x => Quotient.inductionOn' x fun x => by simp }
#align submodule.quotient_quotient_equiv_quotient Submodule.quotientQuotientEquivQuotient

/-- Corollary of the third isomorphism theorem: `[S : T] [M : S] = [M : T]` -/
theorem card_quotient_mul_card_quotient (S T : Submodule R M) (hST : T ≤ S)
    [DecidablePred fun x => x ∈ S.map T.mkQ] [Fintype (M ⧸ S)] [Fintype (M ⧸ T)] :
    Fintype.card (S.map T.mkQ) * Fintype.card (M ⧸ S) = Fintype.card (M ⧸ T) := by
  rw [Submodule.card_eq_card_quotient_mul_card (map T.mkq S),
    fintype.card_eq.mpr ⟨(quotient_quotient_equiv_quotient T S hST).toEquiv⟩]
#align submodule.card_quotient_mul_card_quotient Submodule.card_quotient_mul_card_quotient

end Submodule


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Jakob von Raumer, Floris van Doorn

Ported from Coq HoTT
-/
import .meta.support .meta.simp_attr .meta.induction .path0

universes u v w
hott_theory

namespace hott
open function

namespace eq
  variables {A : Type _} {A' : Type _} {B : Type _} {B' : Type _} {C : Type _} {P : A → Type _}
            {a a' a'' x y z t : A} {b b' b'' : B}

  notation x = y `:>`:50 A:49 := @eq A x y
  @[hott, refl, reducible, hsimp] def idp {a : A} := refl a
  @[hott, reducible, hsimp] def idpath (a : A) := refl a

  -- unbased path induction
  @[hott]
  def rec_unbased {P : Π (a b : A), (a = b) → Type v}
    (H : Π (a : A), P a a idp) {a b : A} (p : a = b) : P a b p :=
  eq.rec (H a) p

  @[hott]
  def rec_on_unbased {P : Π (a b : A), (a = b) → Type v}
    {a b : A} (p : a = b) (H : Π (a : A), P a a idp) : P a b p :=
  eq.rec (H a) p

  /- Concatenation and inverse -/
  @[trans, hott]
  def concat (p : x = y) (q : y = z) : x = z :=
  by hinduction q; exact p

  @[symm, hott]
  def inverse (p : x = y) : y = x :=
  by hinduction p; reflexivity

  infix   ⬝  := concat
  postfix ⁻¹ := inverse
  --a second notation for the inverse, which is not overloaded
  postfix [parsing_only] `⁻¹ᵖ`:std.prec.max_plus := inverse

  /- The 1-dimensional groupoid structure -/

  -- The identity path is a right unit.
  @[hott, hsimp] def con_idp (p : x = y) : p ⬝ idp = p :=
  idp

  -- The identity path is a left unit.
  @[hott, hsimp] def idp_con (p : x = y) : idp ⬝ p = p :=
  by hinduction p; reflexivity

  @[hott, hsimp] def idp_inv : (@idp _ x)⁻¹ = idp := idp

  -- Concatenation is associative.
  @[hott] def con.assoc (p : x = y) (q : y = z) (r : z = t) :
    (p ⬝ q) ⬝ r = p ⬝ (q ⬝ r) :=
  by hinduction r; reflexivity

  @[hott] def con.assoc' (p : x = y) (q : y = z) (r : z = t) :
    p ⬝ (q ⬝ r) = (p ⬝ q) ⬝ r :=
  (con.assoc p q r)⁻¹

  @[hott] def con.assoc5 {a₁ a₂ a₃ a₄ a₅ a₆ : A}
    (p₁ : a₁ = a₂) (p₂ : a₂ = a₃) (p₃ : a₃ = a₄) (p₄ : a₄ = a₅) (p₅ : a₅ = a₆) :
    p₁ ⬝ (p₂ ⬝ p₃ ⬝ p₄) ⬝ p₅ = (p₁ ⬝ p₂) ⬝ p₃ ⬝ (p₄ ⬝ p₅) :=
  by hinduction p₅; hinduction p₄; hinduction p₃; reflexivity

  -- The left inverse law.
  @[hott, hsimp] def con.right_inv (p : x = y) : p ⬝ p⁻¹ = idp :=
  by hinduction p; reflexivity

  -- The right inverse law.
  @[hott, hsimp] def con.left_inv (p : x = y) : p⁻¹ ⬝ p = idp :=
  by hinduction p; reflexivity

  /- Several auxiliary theorems about canceling inverses across associativity. These are somewhat
     redundant, following from earlier theorems. -/

  @[hott, hsimp] def inv_con_cancel_left (p : x = y) (q : y = z) : p⁻¹ ⬝ (p ⬝ q) = q :=
  by hinduction q; hinduction p; reflexivity

  @[hott, hsimp] def con_inv_cancel_left (p : x = y) (q : x = z) : p ⬝ (p⁻¹ ⬝ q) = q :=
  by hinduction q; hinduction p; reflexivity

  @[hott, hsimp] def con_inv_cancel_right (p : x = y) (q : y = z) : (p ⬝ q) ⬝ q⁻¹ = p :=
  by hinduction q; reflexivity

  @[hott, hsimp] def inv_con_cancel_right (p : x = z) (q : y = z) : (p ⬝ q⁻¹) ⬝ q = p :=
  by hinduction q; reflexivity

  -- Inverse distributes over concatenation
  @[hott]
  def con_inv (p : x = y) (q : y = z) : (p ⬝ q)⁻¹ = q⁻¹ ⬝ p⁻¹ :=
  by hinduction q; hinduction p; reflexivity

  @[hott]
  def inv_con_inv_left (p : y = x) (q : y = z) : (p⁻¹ ⬝ q)⁻¹ = q⁻¹ ⬝ p :=
  by hinduction q; hinduction p; reflexivity

  @[hott]
  def inv_con_inv_right (p : x = y) (q : z = y) : (p ⬝ q⁻¹)⁻¹ = q ⬝ p⁻¹ :=
  by hinduction q; hinduction p; reflexivity

  @[hott]
  def inv_con_inv_inv (p : y = x) (q : z = y) : (p⁻¹ ⬝ q⁻¹)⁻¹ = q ⬝ p :=
  by hinduction q; hinduction p; reflexivity

  -- Inverse is an involution.
  @[hott, hsimp] def inv_inv  (p : x = y) : p⁻¹⁻¹ = p :=
  by hinduction p; reflexivity

  -- auxiliary def used by 'cases' tactic
  @[hott]
  def elim_inv_inv  {A : Type u} {a b : A} {C : a = b → Type v}
    (H₁ : a = b) (H₂ : C (H₁⁻¹⁻¹)) : C H₁ :=
  @eq.rec_on _ _ (λ a h, C a) _ (inv_inv H₁) H₂

  @[hott, induction_using] def eq.rec_symm {A : Type u} {a₀ : A} {P : Π⦃a₁⦄, a₁ = a₀ → Type v}
    (H : P idp) ⦃a₁ : A⦄ (p : a₁ = a₀) : P p :=
  by hinduction p; exact H

  /- Theorems for moving things around in equations -/

  @[hott]
  def con_eq_of_eq_inv_con {p : x = z} {q : y = z} {r : y = x} :
    p = r⁻¹ ⬝ q → r ⬝ p = q :=
  begin
    hinduction r, intro h, exact idp_con _ ⬝ h ⬝ idp_con _
  end

  @[hott]
  def con_eq_of_eq_con_inv  {p : x = z} {q : y = z} {r : y = x} :
    r = q ⬝ p⁻¹ → r ⬝ p = q :=
  by hinduction p; exact id

  @[hott]
  def inv_con_eq_of_eq_con {p : x = z} {q : y = z} {r : x = y} :
    p = r ⬝ q → r⁻¹ ⬝ p = q :=
  by hinduction r; intro h; exact idp_con _ ⬝ h ⬝ idp_con _

  @[hott]
  def con_inv_eq_of_eq_con  {p : z = x} {q : y = z} {r : y = x} :
    r = q ⬝ p → r ⬝ p⁻¹ = q :=
  by hinduction p; exact id

  @[hott] def eq_con_of_inv_con_eq {p : x = z} {q : y = z} {r : y = x} :
    r⁻¹ ⬝ q = p → q = r ⬝ p :=
  by hinduction r; intro h; exact (idp_con _)⁻¹ ⬝ h ⬝ (idp_con _)⁻¹

  @[hott] def eq_con_of_con_inv_eq  {p : x = z} {q : y = z} {r : y = x} :
    q ⬝ p⁻¹ = r → q = r ⬝ p :=
  by hinduction p; exact id

  @[hott] def eq_inv_con_of_con_eq {p : x = z} {q : y = z} {r : x = y} :
    r ⬝ q = p → q = r⁻¹ ⬝ p :=
  by hinduction r; intro h; exact (idp_con _)⁻¹ ⬝ h ⬝ (idp_con _)⁻¹

  @[hott] def eq_con_inv_of_con_eq  {p : z = x} {q : y = z} {r : y = x} :
    q ⬝ p = r → q = r ⬝ p⁻¹ :=
  by hinduction p; exact id

  @[hott] def eq_of_con_inv_eq_idp  {p q : x = y} : p ⬝ q⁻¹ = idp → p = q :=
  by hinduction q; exact id

  @[hott] def eq_of_inv_con_eq_idp {p q : x = y} : q⁻¹ ⬝ p = idp → p = q :=
  by hinduction q; intro h; exact (idp_con _)⁻¹ ⬝ h

  @[hott] def eq_inv_of_con_eq_idp'  {p : x = y} {q : y = x} : p ⬝ q = idp → p = q⁻¹ :=
  by hinduction q; exact id

  @[hott] def eq_inv_of_con_eq_idp {p : x = y} {q : y = x} : q ⬝ p = idp → p = q⁻¹ :=
  by hinduction q; intro h; exact (idp_con _)⁻¹ ⬝ h

  @[hott] def eq_of_idp_eq_inv_con {p q : x = y} : idp = p⁻¹ ⬝ q → p = q :=
  by hinduction p; intro h; exact h ⬝ idp_con _

  @[hott] def eq_of_idp_eq_con_inv  {p q : x = y} : idp = q ⬝ p⁻¹ → p = q :=
  by hinduction p; exact id

  @[hott] def inv_eq_of_idp_eq_con  {p : x = y} {q : y = x} : idp = q ⬝ p → p⁻¹ = q :=
  by hinduction p; exact id

  @[hott] def inv_eq_of_idp_eq_con' {p : x = y} {q : y = x} : idp = p ⬝ q → p⁻¹ = q :=
  by hinduction p; intro h; exact h ⬝ idp_con _

  @[hott] def con_inv_eq_idp  {p q : x = y} (r : p = q) : p ⬝ q⁻¹ = idp :=
  by hinduction r; apply con.right_inv

  @[hott] def inv_con_eq_idp  {p q : x = y} (r : p = q) : q⁻¹ ⬝ p = idp :=
  by hinduction r; apply con.left_inv

  @[hott] def con_eq_idp {p : x = y} {q : y = x} (r : p = q⁻¹) : p ⬝ q = idp :=
  by hinduction q; exact r

  @[hott] def idp_eq_inv_con {p q : x = y} (r : p = q) : idp = p⁻¹ ⬝ q :=
  by hinduction r; exact (con.left_inv _)⁻¹

  @[hott] def idp_eq_con_inv {p q : x = y} (r : p = q) : idp = q ⬝ p⁻¹ :=
  by hinduction r; exact (con.right_inv _)⁻¹

  @[hott] def idp_eq_con {p : x = y} {q : y = x} (r : p⁻¹ = q) : idp = q ⬝ p :=
  by hinduction p; exact r

  @[hott] def eq_idp_of_con_right {p : x = x} {q : x = y} (r : p ⬝ q = q) : p = idp :=
  by hinduction q; exact r

  @[hott] def eq_idp_of_con_left {p : x = x} {q : y = x} (r : q ⬝ p = q) : p = idp :=
  by hinduction q; exact (idp_con p)⁻¹ ⬝ r

  @[hott] def idp_eq_of_con_right {p : x = x} {q : x = y} (r : q = p ⬝ q) : idp = p :=
  by hinduction q; exact r

  @[hott] def idp_eq_of_con_left {p : x = x} {q : y = x} (r : q = q ⬝ p) : idp = p :=
  by hinduction q; exact r ⬝ idp_con p

  /- Transport -/

  @[subst, hott, elab_simple]
  def transport (P : A → Type v) {x y : A} (p : x = y)
    (u : P x) : P y :=
  by hinduction p; exact u

  -- This idiom makes the operation right associative.
  hott_theory_cmd "local infixr ` ▸ ` := hott.eq.transport _"

  @[reducible, hott]
  def cast {A B : Type u} (p : A = B) (a : A) : B :=
  p ▸ a

  @[reducible, hott]
  def cast_def {A B : Type u} (p : A = B) (a : A)
    : cast p a = p ▸ a :=
  idp

  @[reducible, hott]
  def tr_rev (P : A → Type u) {x y : A} (p : x = y) (u : P y) : P x :=
  p⁻¹ ▸ u

  @[hott, elab_simple] def ap {{A : Type u}} {{B : Type v}} (f : A → B) {x y:A} (p : x = y) : f x = f y :=
  by hinduction p; reflexivity

  @[hott, hsimp] def eq_rec_ap {A B} (f : A → B) {x y : A} (p : x = y) :
    (eq.rec idp p : f x = f y) = ap f p := idp

  notation `ap01` [parsing_only] := ap

  @[reducible, hott]
  def homotopy (f g : Πx, P x) : Type _ :=
  Π x : A, f x = g x

  infix ~ := homotopy

  @[refl, reducible, hott, hsimp]
  protected def homotopy.refl (f : Πx, P x) : f ~ f :=
  λ x, idp

  @[hott] protected def homotopy.rfl {f : Πx, P x} : f ~ f :=
  by refl

  @[symm, reducible, hott, hsimp]
  protected def homotopy.symm  {f g : Πx, P x} (H : f ~ g)
    : g ~ f :=
  λ x, (H x)⁻¹

  @[trans, reducible, hott, hsimp]
  protected def homotopy.trans {f g h : Πx, P x}
    (H1 : f ~ g) (H2 : g ~ h) : f ~ h :=
  λ x, H1 x ⬝ H2 x

  infix ` ⬝hty `:75 := homotopy.trans
  postfix `⁻¹ʰᵗʸ`:(max+1) := homotopy.symm

  @[hott] def homotopy.refl_symm {f : Π x, P x} : (homotopy.refl f).symm = homotopy.refl f :=
  idp

  @[hott] def hwhisker_left  (g : B → C) {f f' : A → B} (H : f ~ f') :
    g ∘ f ~ g ∘ f' :=
  λa, ap g (H a)

  @[hott] def hwhisker_right  (f : A → B) {g g' : B → C} (H : g ~ g') :
    g ∘ f ~ g' ∘ f :=
  λa, H (f a)

  @[hott, hsimp] def compose_id (f : A → B) : f ∘ id ~ f :=
  by reflexivity

  @[hott, hsimp] def id_compose (f : A → B) : id ∘ f ~ f :=
  by reflexivity

  @[hott] def compose2 {A B C : Type _} {g g' : B → C} {f f' : A → B}
    (p : g ~ g') (q : f ~ f') : g ∘ f ~ g' ∘ f' :=
  hwhisker_right f p ⬝hty hwhisker_left g' q

  @[hott] def hassoc {A B C D : Type _} (h : C → D) (g : B → C) (f : A → B) : (h ∘ g) ∘ f ~ h ∘ (g ∘ f) :=
  λa, idp

  @[hott] def homotopy_of_eq {f g : Πx, P x} (H1 : f = g) : f ~ g :=
  transport (λ g, f ~ g) H1 (homotopy.refl f)

  @[hott, elab_simple] def apd10  {f g : Πx, P x} (H : f = g) : f ~ g :=
  λx, by hinduction H; reflexivity

  --the next theorem is useful if you want to write "apply (apd10' a)"
  @[hott] def apd10'  {f g : Πx, P x} (a : A) (H : f = g) : f a = g a :=
  by hinduction H; reflexivity

  --apd10 is also ap evaluation
  @[hott] def apd10_eq_ap_eval {f g : Πx, P x} (H : f = g) (a : A)
    : apd10 H a = ap (λs : Πx, P x, s a) H :=
  by hinduction H; reflexivity

  @[reducible,hott]
  def ap10 {f g : A → B} (H : f = g) : f ~ g := apd10 H

  @[hott, congr] def ap11 {f g : A → B} (H : f = g) {x y : A} (p : x = y) : f x = g y :=
  by hinduction H; exact ap f p

  -- [apd] is defined in init.pathover using pathover instead of an equality with transport.
  @[hott] def apdt  (f : Πa, P a) {x y : A} (p : x = y) : p ▸ f x = f y :=
  by hinduction p; reflexivity

  @[hott, elab_simple] def ap011  (f : A → B → C) (Ha : a = a') (Hb : b = b') : f a b = f a' b' :=
  by hinduction Ha; exact ap (f a) Hb

  /- More theorems for moving things around in equations -/

  @[hott] def tr_eq_of_eq_inv_tr {P : A → Type v} {x y : A} {p : x = y} {u : P x} {v : P y} :
    u = p⁻¹ ▸ v → p ▸ u = v :=
  by hinduction p; exact id

  @[hott] def inv_tr_eq_of_eq_tr {P : A → Type v} {x y : A} {p : y = x} {u : P x} {v : P y} :
    u = p ▸ v → p⁻¹ ▸ u = v :=
  by hinduction p; exact id

  @[hott] def eq_inv_tr_of_tr_eq {P : A → Type v} {x y : A} {p : x = y} {u : P x} {v : P y} :
    p ▸ u = v → u = p⁻¹ ▸ v :=
  by hinduction p; exact id

  @[hott] def eq_tr_of_inv_tr_eq {P : A → Type v} {x y : A} {p : y = x} {u : P x} {v : P y} :
    p⁻¹ ▸ u = v → u = p ▸ v :=
  by hinduction p; exact id

  /- Transporting along the diagonal of a type family -/
  @[hott] def tr_diag_eq_tr_tr {A : Type u} (P : A → A → Type v) {x y : A} (p : x = y) (a : P x x) :
    transport (λ x, P x x) p a = transport (λ z, P y z) p (@transport _ (λ z, P z x) _ _ p a) :=
  by hinduction p; reflexivity

  /- Functoriality of functions -/

  -- Here we prove that functions behave like functors between groupoids, and that [ap] itself is
  -- functorial.

  -- Functions take identity paths to identity paths
  @[hott, hsimp] def ap_idp  (x : A) (f : A → B) : ap f idp = idp :> (f x = f x) := idp

  -- Functions commute with concatenation.
  @[hott] def ap_con  (f : A → B) {x y z : A} (p : x = y) (q : y = z) :
    ap f (p ⬝ q) = ap f p ⬝ ap f q :=
  by hinduction q; reflexivity

  @[hott] def con_ap_con_eq_con_ap_con_ap (f : A → B) {w x y z : A} (r : f w = f x)
    (p : x = y) (q : y = z) : r ⬝ ap f (p ⬝ q) = (r ⬝ ap f p) ⬝ ap f q :=
  by hinduction q; hinduction p; reflexivity

  @[hott] def ap_con_con_eq_ap_con_ap_con (f : A → B) {w x y z : A} (p : x = y) (q : y = z)
    (r : f z = f w) : ap f (p ⬝ q) ⬝ r = ap f p ⬝ (ap f q ⬝ r) :=
  begin hinduction q; hinduction p, exact (idp_con _)⁻¹ end

  -- Functions commute with path inverses.
  @[hott] def ap_inv'  (f : A → B) {x y : A} (p : x = y) : (ap f p)⁻¹ = ap f p⁻¹ :=
  by hinduction p; reflexivity

  @[hott] def ap_inv  (f : A → B) {x y : A} (p : x = y) : ap f p⁻¹ = (ap f p)⁻¹ :=
  by hinduction p; reflexivity

  -- [ap] itself is functorial in the first argument.

  @[hott, hsimp] def ap_id  (p : x = y) : ap id p = p :=
  by hinduction p; reflexivity

  @[hott,elab_simple] def ap_compose  (g : B → C) (f : A → B) {x y : A} (p : x = y) :
    ap (g ∘ f) p = (ap g (ap f p) : g (f x) = g (f y)) :=
  by hinduction p; reflexivity

  -- Sometimes we don't have the actual function [compose].
  @[hott] def ap_compose'  (g : B → C) (f : A → B) {x y : A} (p : x = y) :
    ap g (ap f p) = ap (λa, g (f a)) p :=
  by hinduction p; reflexivity

  -- The action of constant maps.
  @[hott] def ap_constant  (p : x = y) (z : B) : ap (λu, z) p = idp :=
  by hinduction p; reflexivity

  -- Naturality of [ap].
  -- see also natural_square in cubical.square
  @[hott] def ap_con_eq_con_ap {f g : A → B} (p : f ~ g) {x y : A} (q : x = y) :
    ap f q ⬝ p y = p x ⬝ ap g q :=
  by hinduction q; apply idp_con

  @[hott, hsimp] def ap_r_con_r (f : A → B) (a : A) :
    ap f (refl a) ⬝ refl (f a) = refl (f a) :=
  refl _

  -- Naturality of [ap] at identity.
  @[hott] def ap_con_eq_con {f : A → A} (p : Πx, f x = x) {x y : A} (q : x = y) :
    ap f q ⬝ p y = p x ⬝ q :=
  by hinduction q; apply idp_con

  @[hott] def con_ap_eq_con {f : A → A} (p : Πx, x = f x) {x y : A} (q : x = y) :
    p x ⬝ ap f q =  q ⬝ p y :=
  by hinduction q; exact (idp_con _)⁻¹

  -- Naturality of [ap] with constant function
  @[hott] def ap_con_eq {f : A → B} {b : B} (p : Πx, f x = b) {x y : A} (q : x = y) :
    ap f q ⬝ p y = p x :=
  by hinduction q; apply idp_con

  -- Naturality with other paths hanging around.

  @[hott] def con_ap_con_con_eq_con_con_ap_con {f g : A → B} (p : f ~ g) {x y : A} (q : x = y)
      {w z : B} (r : w = f x) (s : g y = z) :
    (r ⬝ ap f q) ⬝ (p y ⬝ s) = (r ⬝ p x) ⬝ (ap g q ⬝ s) :=
  by hinduction s; hinduction q; reflexivity

  @[hott] def con_ap_con_eq_con_con_ap {f g : A → B} (p : f ~ g) {x y : A} (q : x = y)
      {w : B} (r : w = f x) :
    (r ⬝ ap f q) ⬝ p y = (r ⬝ p x) ⬝ ap g q :=
  by hinduction q; reflexivity

  -- TODO: try this using the simplifier, and compare proofs
  @[hott] def ap_con_con_eq_con_ap_con {f g : A → B} (p : f ~ g) {x y : A} (q : x = y)
      {z : B} (s : g y = z) :
    ap f q ⬝ (p y ⬝ s) = p x ⬝ (ap g q ⬝ s) :=
  begin
    hinduction s,
    hinduction q,
    apply idp_con
  end

  @[hott] def con_ap_con_con_eq_con_con_con {f : A → A} (p : f ~ id) {x y : A} (q : x = y)
      {w z : A} (r : w = f x) (s : y = z) :
    (r ⬝ ap f q) ⬝ (p y ⬝ s) = (r ⬝ p x) ⬝ (q ⬝ s) :=
  by hinduction s; hinduction q; reflexivity

  @[hott] def con_con_ap_con_eq_con_con_con {g : A → A} (p : @id A ~ g) {x y : A} (q : x = y)
      {w z : A} (r : w = x) (s : g y = z) :
    (r ⬝ p x) ⬝ (ap g q ⬝ s) = (r ⬝ q) ⬝ (p y ⬝ s) :=
  by hinduction s; hinduction q; reflexivity

  @[hott] def con_ap_con_eq_con_con {f : A → A} (p : f ~ id) {x y : A} (q : x = y)
      {w : A} (r : w = f x) :
    (r ⬝ ap f q) ⬝ p y = (r ⬝ p x) ⬝ q :=
  by hinduction q; reflexivity

  @[hott] def ap_con_con_eq_con_con {f : A → A} (p : f ~ id) {x y : A} (q : x = y)
      {z : A} (s : y = z) :
    ap f q ⬝ (p y ⬝ s) = p x ⬝ (q ⬝ s) :=
  by hinduction s; hinduction q; apply idp_con

  @[hott] def con_con_ap_eq_con_con {g : A → A} (p : @id A ~ g) {x y : A} (q : x = y)
      {w : A} (r : w = x) :
    (r ⬝ p x) ⬝ ap g q = (r ⬝ q) ⬝ p y :=
  begin hinduction q, exact idp end

  @[hott] def con_ap_con_eq_con_con' {g : A → A} (p : @id A ~ g) {x y : A} (q : x = y)
      {z : A} (s : g y = z) :
    p x ⬝ (ap g q ⬝ s) = q ⬝ (p y ⬝ s) :=
  by hinduction s; hinduction q; exact (idp_con _)⁻¹

  /- Action of [apd10] and [ap10] on paths -/

  -- Application of paths between functions preserves the groupoid structure

  @[hott, hsimp] def apd10_idp (f : Πx, P x) (x : A) : apd10 (refl f) x = idp := idp

  @[hott] def apd10_con {f f' f'' : Πx, P x} (h : f = f') (h' : f' = f'') (x : A) :
    apd10 (h ⬝ h') x = apd10 h x ⬝ apd10 h' x :=
  by hinduction h; hinduction h'; reflexivity

  @[hott] def apd10_inv {f g : Πx : A, P x} (h : f = g) (x : A) :
    apd10 h⁻¹ x = (apd10 h x)⁻¹ :=
  by hinduction h; reflexivity

  @[hott, hsimp] def ap10_idp {f : A → B} (x : A) : ap10 (refl f) x = idp := idp

  @[hott] def ap10_con {f f' f'' : A → B} (h : f = f') (h' : f' = f'') (x : A) :
  ap10 (h ⬝ h') x = ap10 h x ⬝ ap10 h' x := apd10_con h h' x

  @[hott] def ap10_inv {f g : A → B} (h : f = g) (x : A) : ap10 h⁻¹ x = (ap10 h x)⁻¹ :=
  apd10_inv h x

  -- [ap10] also behaves nicely on paths produced by [ap]
  @[hott] def ap_ap10 (f g : A → B) (h : B → C) (p : f = g) (a : A) :
    ap h (ap10 p a) = ap10 (ap (λ f' : A → B, h ∘ f') p) a:=
  by hinduction p; reflexivity

  /- some lemma's about ap011 -/

  @[hott] def ap_eq_ap011_left (f : A → B → C) (Ha : a = a') (b : B) :
    ap (λa, f a b) Ha = ap011 f Ha idp :=
  by hinduction Ha; reflexivity

  @[hott] def ap_eq_ap011_right (f : A → B → C) (a : A) (Hb : b = b') :
    ap (f a) Hb = ap011 f idp Hb :=
  by reflexivity

  @[hott] def ap_ap011 {A B C D : Type _} (g : C → D) (f : A → B → C) {a a' : A} {b b' : B}
    (p : a = a') (q : b = b') : ap g (ap011 f p q) = ap011 (λa b, g (f a b)) p q :=
  begin
    hinduction p, exact (ap_compose g (f a) q)⁻¹
  end

  /- Transport and the groupoid structure of paths -/

  @[hott, hsimp] def idp_tr {P : A → Type u} {x : A} (u : P x) : idp ▸ u = u := idp

  @[hott] def con_tr  {P : A → Type w} {x y z : A} (p : x = y) (q : y = z) (u : P x) :
    p ⬝ q ▸ u = q ▸ p ▸ u :=
  by hinduction q; reflexivity

  @[hott, hsimp] def tr_inv_tr {P : A → Type v} {x y : A} (p : x = y) (z : P y) :
    p ▸ p⁻¹ ▸ z = z :=
  (con_tr p⁻¹ p z)⁻¹ ⬝ ap (λr, transport P r z) (con.left_inv p)

  @[hott, hsimp] def inv_tr_tr {P : A → Type v} {x y : A} (p : x = y) (z : P x) :
    p⁻¹ ▸ p ▸ z = z :=
  (con_tr p p⁻¹ z)⁻¹ ⬝ ap (λr, transport P r z) (con.right_inv p)

  @[hott] def cast_cast_inv {A : Type u} {P : A → Type u} {x y : A} (p : x = y) (z : P y) :
    cast (ap P p) (cast (ap P p⁻¹) z) = z :=
  by hinduction p; reflexivity

  @[hott] def cast_inv_cast {A : Type u} {P : A → Type u} {x y : A} (p : x = y) (z : P x) :
    cast (ap P p⁻¹) (cast (ap P p) z) = z :=
  by hinduction p; reflexivity

  @[hott] def fn_tr_eq_tr_fn {P : A → Type _} {Q : A → Type _} {x y : A} (p : x = y) (f : Πx, P x → Q x) (z : P x) :
    f y (p ▸ z) = p ▸ f x z :=
  by hinduction p; reflexivity

  @[hott] def fn_cast_eq_cast_fn {A : Type _} {P : A → Type _} {Q : A → Type _} {x y : A}
    (p : x = y) (f : Πx, P x → Q x) (z : P x) : f y (cast (ap P p) z) = cast (ap Q p) (f x z) :=
  by hinduction p; reflexivity

  @[hott] def con_con_tr {P : A → Type u}
      {x y z w : A} (p : x = y) (q : y = z) (r : z = w) (u : P x) :
    ap (λe, e ▸ u) (con.assoc' p q r) ⬝ con_tr (p ⬝ q) r u ⬝
        ap (transport P r) (con_tr p q u)
      = con_tr p (q ⬝ r) u ⬝ con_tr q r (p ▸ u)
      :> ((p ⬝ (q ⬝ r)) ▸ u = r ▸ q ▸ p ▸ u) :=
  by hinduction r; hinduction q; hinduction p; reflexivity

  --  Here is another coherence lemma for transport.
  @[hott] def tr_inv_tr_lemma {P : A → Type v} {x y : A} (p : x = y) (z : P x) :
    tr_inv_tr p (transport P p z) = ap (transport P p) (inv_tr_tr p z) :=
  by hinduction p; reflexivity

  /- some properties for apdt -/

  @[hott, hsimp] def apdt_idp (x : A) (f : Πx, P x) : apdt f idp = idp :> (f x = f x) := idp

  @[hott] def apdt_con (f : Πx, P x) {x y z : A} (p : x = y) (q : y = z)
    : apdt f (p ⬝ q) = con_tr p q (f x) ⬝ ap (transport P q) (apdt f p) ⬝ apdt f q :=
  by hinduction p; hinduction q; apply idp

  @[hott] def apdt_inv (f : Πx, P x) {x y : A} (p : x = y)
    : apdt f p⁻¹ = (eq_inv_tr_of_tr_eq (apdt f p))⁻¹ :=
  by hinduction p; apply idp

  -- Dependent transport in a doubly dependent type.
  -- This is a special case of transporto in init.pathover
  @[hott] def transportD  {P : A → Type _} (Q : Πa, P a → Type _)
      {a a' : A} (p : a = a') (b : P a) (z : Q a b) : Q a' (p ▸ b) :=
  by hinduction p; exact z

  -- In Coq the variables P, Q and b are explicit, but in Lean we can probably have them implicit
  -- using the following notation
  notation p ` ▸D `:65 x:64 := transportD _ p _ x

  -- transporting over 2 one-dimensional paths
  -- This is a special case of transporto in init.pathover
  @[hott] def transport11 (P : A → B → Type _)
    (p : a = a') (q : b = b') (z : P a b) : P a' b' :=
  transport (P a') q (@transport _ (λ x : A, P x b) _ _ p z)

  @[hott] def transport11_con (P : A → B → Type _) (p : a = a') (p' : a' = a'') (q : b = b')
    (q' : b' = b'') (z : P a b) :
    transport11 P (p ⬝ p') (q ⬝ q') z = transport11 P p' q' (transport11 P p q z) :=
  begin hinduction p', hinduction q', refl end

  @[hott] def transport11_compose (P : A' → B' → Type _) (f : A → A') (g : B → B')
    (p : a = a') (q : b = b') (z : P (f a) (g b)) :
    transport11 (λa b, P (f a) (g b)) p q z = transport11 P (ap f p) (ap g q) z :=
  by hinduction p; hinduction q; refl

  @[hott] def transport11_ap (P : A' → B' → Type _) (f : A → A') (g : B → B')
    (p : a = a') (q : b = b') (z : P (f a) (g b)) :
     transport11 P (ap f p) (ap g q) z =
     @transport11 _ _ _ _ _ _ (λ(a : A) (b : B), P (f a) (g b)) p q z :=
  (transport11_compose P f g p q z)⁻¹

  @[hott] def fn_transport11_eq_transport11_fn (P : A → B → Type _)
    (Q : A → B → Type _) (p : a = a') (q : b = b')
    (f : Πa b, P a b → Q a b) (z : P a b) :
    f a' b' (transport11 P p q z) = transport11 Q p q (f a b z) :=
  by hinduction p; hinduction q; reflexivity

  -- Transporting along higher-dimensional paths
  @[hott] def transport2  (P : A → Type w) {x y : A} {p q : x = y} (r : p = q) (z : P x) :
    p ▸ z = q ▸ z :=
  ap (λp', p' ▸ z) r

  notation p ` ▸2 `:65 x:64 := transport2 _ p _ x

  -- An alternative definition.
  @[hott] def tr2_eq_ap10 (Q : A → Type w) {x y : A} {p q : x = y} (r : p = q) (z : Q x) :
    transport2 Q r z = ap10 (ap (transport Q) r) z :=
  by hinduction r; reflexivity

  @[hott] def tr2_con {P : A → Type w} {x y : A} {p1 p2 p3 : x = y}
      (r1 : p1 = p2) (r2 : p2 = p3) (z : P x) :
    transport2 P (r1 ⬝ r2) z = transport2 P r1 z ⬝ transport2 P r2 z :=
  by hinduction r1; hinduction r2; reflexivity

  @[hott] def tr2_inv (Q : A → Type w) {x y : A} {p q : x = y} (r : p = q) (z : Q x) :
    transport2 Q r⁻¹ z = (transport2 Q r z)⁻¹ :=
  by hinduction r; reflexivity

  @[hott] def transportD2  {B C : A → Type _} (D : Π(a:A), B a → C a → Type _)
    {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1) (w : D x1 y z) : D x2 (p ▸ y) (p ▸ z) :=
  by hinduction p; exact w

  notation p ` ▸D2 `:65 x:64 := transportD2 _ p _ _ x

  @[hott] def ap_tr_con_tr2 (P : A → Type _) {x y : A} {p q : x = y} {z w : P x} (r : p = q)
      (s : z = w) :
    ap (transport P p) s  ⬝  transport2 P r w = transport2 P r z  ⬝  ap (transport P q) s :=
  by hinduction r; exact (idp_con _)⁻¹

  /- Transporting in particular fibrations -/

  /-
  From the Coq HoTT library:

  One frequently needs lemmas showing that transport in a certain dependent type is equal to some
  more explicitly defined operation, defined according to the structure of that dependent type.
  For most dependent types, we prove these lemmas in the appropriate file in the types/
  subdirectory.  Here we consider only the most basic cases.
  -/

  -- Transporting in a constant fibration.
  @[hott] def tr_constant (p : x = y) (z : B) : transport (λx, B) p z = z :=
  by hinduction p; reflexivity

  @[hott] def tr2_constant {p q : x = y} (r : p = q) (z : B) :
    tr_constant p z = transport2 (λu, B) r z ⬝ tr_constant q z :=
  by hinduction r; exact (idp_con _)⁻¹

  -- Transporting in a pulled back fibration.
  @[hott] def tr_compose (P : B → Type _) (f : A → B) (p : x = y) (z : P (f x)) :
    transport (P ∘ f) p z  = transport P (ap f p) z :=
  by hinduction p; reflexivity

  @[hott] def tr_ap (P : B → Type _) (f : A → B) (p : x = y) (z : P (f x)) :
    transport P (ap f p) z = transport (P ∘ f) p z :=
  (tr_compose P f p z)⁻¹

  @[hott] def ap_precompose (f : A → B) (g g' : B → C) (p : g = g') :
    ap (λh : B → C, h ∘ f) p = transport (λh : B → C, g ∘ f = h ∘ f) p idp :=
  by hinduction p; reflexivity

  @[hott] def apd10_ap_precompose (f : A → B) (g g' : B → C) (p : g = g') :
    apd10 (ap (λh : B → C, h ∘ f) p) = λa, apd10 p (f a) :=
  by hinduction p; reflexivity

  @[hott] def apd10_ap_precompose_dependent {C : B → Type _}
    (f : A → B) {g g' : Πb : B, C b} (p : g = g')
    : apd10 (ap (λ(h : (Πb : B, C b))(a : A), h (f a)) p) = λa, apd10 p (f a) :=
  by hinduction p; reflexivity

  @[hott] def apd10_ap_postcompose (f : B → C) (g g' : A → B) (p : g = g') :
    apd10 (ap (λh : A → B, f ∘ h) p) = λa, ap f (apd10 p a) :=
  by hinduction p; reflexivity

  -- A special case of [tr_compose] which seems to come up a lot.
  @[hott] def tr_eq_cast_ap {P : A → Type _} {x y} (p : x = y) (u : P x) : p ▸ u = cast (ap P p) u :=
  tr_compose id P p u

  @[hott] def tr_eq_cast_ap_fn {P : A → Type _} {x y} (p : x = y) : transport P p = cast (ap P p) :=
  by hinduction p; reflexivity

  /- The behavior of [ap] and [apdt] -/

  -- In a constant fibration, [apdt] reduces to [ap], modulo [transport_const].
  @[hott] def apdt_eq_tr_constant_con_ap (f : A → B) (p : x = y) :
    apdt f p = tr_constant p (f x) ⬝ ap f p :=
  by hinduction p; reflexivity

  /- The 2-dimensional groupoid structure -/

  -- Horizontal composition of 2-dimensional paths.
  @[hott] def concat2  {p p' : x = y} {q q' : y = z} (h : p = p') (h' : q = q')
    : p ⬝ q = p' ⬝ q' :=
  ap011 concat h h'

  -- 2-dimensional path inversion
  @[hott] def inverse2  {p q : x = y} (h : p = q) : p⁻¹ = q⁻¹ :=
  ap inverse h

  infixl ` ◾ `:80 := concat2
  postfix `⁻²`:(max+10) := inverse2 --this notation is abusive, should we use it?

  /- Whiskering -/

  @[hott] def whisker_left  (p : x = y) {q r : y = z} (h : q = r) : p ⬝ q = p ⬝ r :=
  idp ◾ h

  @[hott] def whisker_right  {p q : x = y} (r : y = z) (h : p = q) : p ⬝ r = q ⬝ r :=
  h ◾ idp

  -- Unwhiskering, a.k.a. cancelling

  @[hott] def cancel_left {x y z : A} (p : x = y) {q r : y = z} : (p ⬝ q = p ⬝ r) → (q = r) :=
  λs, (inv_con_cancel_left _ _)⁻¹ ⬝ whisker_left p⁻¹ s ⬝ inv_con_cancel_left _ _

  @[hott] def cancel_right {x y z : A} {p q : x = y} (r : y = z) : (p ⬝ r = q ⬝ r) → (p = q) :=
  λs, (con_inv_cancel_right _ _)⁻¹ ⬝ whisker_right r⁻¹ s ⬝ con_inv_cancel_right _ _

  -- Whiskering and identity paths.

  @[hott, hsimp] def whisker_right_idp {p q : x = y} (h : p = q) :
    whisker_right idp h = h :=
  by hinduction h; hinduction p; reflexivity

  @[hott, hsimp] def whisker_right_idp_left  (p : x = y) (q : y = z) :
    whisker_right q idp = idp :> (p ⬝ q = p ⬝ q) :=
  idp

  @[hott, hsimp] def whisker_left_idp_right  (p : x = y) (q : y = z) :
    whisker_left p idp = idp :> (p ⬝ q = p ⬝ q) :=
  idp

  @[hott, hsimp] def whisker_left_idp {p q : x = y} (h : p = q) :
    (idp_con p)⁻¹ ⬝ whisker_left idp h ⬝ idp_con q = h :=
  by hinduction h; hinduction p; reflexivity

  @[hott, hsimp] def whisker_left_idp2 {A : Type u} {a : A} (p : idp = idp :> a = a) :
    whisker_left idp p = p :=
  begin
    refine _ ⬝ whisker_left_idp p,
    exact (idp_con _)⁻¹
  end

  @[hott] def con2_idp  {p q : x = y} (h : p = q) :
    h ◾ idp = whisker_right idp h :> (p ⬝ idp = q ⬝ idp) :=
  idp

  @[hott] def idp_con2  {p q : x = y} (h : p = q) :
    idp ◾ h = whisker_left idp h :> (idp ⬝ p = idp ⬝ q) :=
  idp

  @[hott] def inv2_con2 {p p' : x = y} (h : p = p')
    : h⁻² ◾ h = con.left_inv p ⬝ (con.left_inv p')⁻¹ :=
  by hinduction h; hinduction p; reflexivity

  -- The interchange law for concatenation.
  @[hott] def con2_con_con2 {p p' p'' : x = y} {q q' q'' : y = z}
      (a : p = p') (b : p' = p'') (c : q = q') (d : q' = q'') :
    a ◾ c ⬝ b ◾ d = (a ⬝ b) ◾ (c ⬝ d) :=
  by hinduction d; hinduction c; hinduction b;induction a; reflexivity

  @[hott] def con2_eq_rl {A : Type _} {x y z : A} {p p' : x = y} {q q' : y = z}
    (a : p = p') (b : q = q') : a ◾ b = whisker_right q a ⬝ whisker_left p' b :=
  by hinduction b; hinduction a; reflexivity

  @[hott] def con2_eq_lf {A : Type _} {x y z : A} {p p' : x = y} {q q' : y = z}
    (a : p = p') (b : q = q') : a ◾ b = whisker_left p b ⬝ whisker_right q' a :=
  by hinduction b; hinduction a; reflexivity

  @[hott] def whisker_right_con_whisker_left {x y z : A} {p p' : x = y} {q q' : y = z}
    (a : p = p') (b : q = q') :
    (whisker_right q a) ⬝ (whisker_left p' b) = (whisker_left p b) ⬝ (whisker_right q' a) :=
  by hinduction b; hinduction a; reflexivity

  -- Structure corresponding to the coherence equations of a bicategory.

  -- The "pentagonator": the 3-cell witnessing the associativity pentagon.
  @[hott] def pentagon {v w x y z : A} (p : v = w) (q : w = x) (r : x = y) (s : y = z) :
    whisker_left p (con.assoc' q r s)
      ⬝ con.assoc' p (q ⬝ r) s
      ⬝ whisker_right s (con.assoc' p q r)
    = con.assoc' p q (r ⬝ s) ⬝ con.assoc' (p ⬝ q) r s :=
  by hinduction s;induction r;induction q;induction p;reflexivity

  -- The 3-cell witnessing the left unit triangle.
  @[hott] def triangulator (p : x = y) (q : y = z) :
    con.assoc' p idp q ⬝ whisker_right q (con_idp p) = whisker_left p (idp_con q) :=
  by hinduction q; hinduction p; reflexivity

  @[hott] def eckmann_hilton (p q : idp = idp :> a = a) : p ⬝ q = q ⬝ p :=
  begin
    refine (whisker_right_idp p ◾ whisker_left_idp2 q)⁻¹ᵖ ⬝ _,
    refine whisker_right_con_whisker_left _ _ ⬝ _,
    refine whisker_left_idp2 _ ◾ whisker_right_idp _
  end

  @[hott] def con_eq_con2 (p q : idp = idp :> a = a) : p ⬝ q = p ◾ q :=
  begin
    refine (whisker_right_idp p ◾ whisker_left_idp2 q)⁻¹ᵖ ⬝ _,
    symmetry,
    exact con2_eq_rl _ _
  end

  @[hott] def inv_eq_inv2 (p : idp = idp :> a = a) : p⁻¹ = p⁻² :=
  begin
    apply eq.cancel_right p,
    refine con.left_inv _ ⬝ _,
    refine _ ⬝ (con_eq_con2 _ _)⁻¹,
    exact (inv2_con2 _)⁻¹ᵖ,
  end

  -- The action of functions on 2-dimensional paths
  @[hott, elab_simple] def ap02 (f : A → B) {x y : A} {p q : x = y} (r : p = q)
    : ap f p = ap f q :=
  ap (ap f) r

  @[hott] def ap02_con (f : A → B) {x y : A} {p p' p'' : x = y} (r : p = p') (r' : p' = p'') :
    ap02 f (r ⬝ r') = ap02 f r ⬝ ap02 f r' :=
  by hinduction r; hinduction r'; reflexivity

  @[hott] def ap02_con2 (f : A → B) {x y z : A} {p p' : x = y} {q q' :y = z} (r : p = p')
    (s : q = q') :
      ap02 f (r ◾ s) = ap_con f p q
                        ⬝ (ap02 f r ◾ ap02 f s)
                        ⬝ (ap_con f p' q')⁻¹ :=
  by hinduction r; hinduction s; hinduction q; hinduction p; reflexivity

  @[hott] def apdt02  {p q : x = y} (f : Π x, P x) (r : p = q) :
    apdt f p = transport2 P r (f x) ⬝ apdt f q :=
  by hinduction r; exact (idp_con _)⁻¹

end eq

/-
  an auxillary namespace for concatenation and inversion for homotopies. We put this is a separate
  namespace because ⁻¹ʰ is also used as the inverse of a homomorphism
-/

open eq

end hott