/-
Copyright (c) 2020 Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kyle Miller, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.fintype.basic
import Mathlib.algebra.big_operators.order
import Mathlib.PostPort

universes u v w

namespace Mathlib

/-!
# Pigeonhole principles

Given pigeons (possibly infinitely many) in pigeonholes, the
pigeonhole principle states that, if there are more pigeons than
pigeonholes, then there is a pigeonhole with two or more pigeons.

There are a few variations on this statement, and the conclusion can
be made stronger depending on how many pigeons you know you might
have.

The basic statements of the pigeonhole principle appear in the
following locations:

* `data.finset.basic` has `finset.exists_ne_map_eq_of_card_lt_of_maps_to`
* `data.fintype.basic` has `fintype.exists_ne_map_eq_of_card_lt`
* `data.fintype.basic` has `fintype.exists_ne_map_eq_of_infinite`
* `data.fintype.basic` has `fintype.exists_infinite_fiber`

This module gives access to these pigeonhole principles along with 20 more.
The versions vary by:

* using a function between `fintype`s or a function between possibly infinite types restricted to
  `finset`s;
* counting pigeons by a general weight function (`∑ x in s, w x`) or by heads (`finset.card s`);
* using strict or non-strict inequalities;
* establishing upper or lower estimate on the number (or the total weight) of the pigeons in one
  pigeonhole;
* in case when we count pigeons by some weight function `w` and consider a function `f` between
  `finset`s `s` and `t`, we can either assume that each pigeon is in one of the pigeonholes
  (`∀ x ∈ s, f x ∈ t`), or assume that for `y ∉ t`, the total weight of the pigeons in this
  pigeonhole `∑ x in s.filter (λ x, f x = y), w x` is nonpositive or nonnegative depending on
  the inequality we are proving.

Lemma names follow `mathlib` convention (e.g.,
`finset.exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum`); "pigeonhole principle" is mentioned in the
docstrings instead of the names.

## See also

* `ordinal.infinite_pigeonhole`: pigeonhole principle for cardinals, formulated using cofinality;

* `measure_theory.exists_nonempty_inter_of_measure_univ_lt_tsum_measure`,
  `measure_theory.exists_nonempty_inter_of_measure_univ_lt_sum_measure`: pigeonhole principle in a
  measure space.

## Tags

pigeonhole principle
-/

namespace finset

/-!
### The pigeonhole principles on `finset`s, pigeons counted by weight

In this section we prove the following version of the pigeonhole principle: if the total weight of a
finite set of pigeons is greater than `n •ℕ b`, and they are sorted into `n` pigeonholes, then for
some pigeonhole, the total weight of the pigeons in this pigeonhole is greateer than `b`, and a few
variations of this theorem.

The principle is formalized in the following way, see
`finset.exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum`: if `f : α → β` is a function which maps all
elements of `s : finset α` to `t : finset β` and `card t •ℕ b < ∑ x in s, w x`, where `w : α → M` is
a weight function taking values in a `linear_ordered_cancel_add_comm_monoid`, then for
some `y ∈ t`, the sum of the weights of all `x ∈ s` such that `f x = y` is greater than `b`.

There are a few bits we can change in this theorem:

* reverse all inequalities, with obvious adjustments to the name;
* replace the assumption `∀ a ∈ s, f a ∈ t` with
  `∀ y ∉ t, (∑ x in s.filter (λ x, f x = y), w x) ≤ 0`,
  and replace `of_maps_to` with `of_sum_fiber_nonpos` in the name;
* use non-strict inequalities assuming `t` is nonempty.

We can do all these variations independently, so we have eight versions of the theorem.
-/

/-!
#### Strict inequality versions
-/

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is greater than `n •ℕ b`, and they are sorted into
`n` pigeonholes, then for some pigeonhole, the total weight of the pigeons in this pigeonhole is
greater than `b`. -/
theorem exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum {α : Type u} {β : Type v} {M : Type w} [linear_ordered_cancel_add_comm_monoid M] [DecidableEq β] {s : finset α} {t : finset β} {f : α → β} {w : α → M} {b : M} (hf : ∀ (a : α), a ∈ s → f a ∈ t) (hb : card t •ℕ b < finset.sum s fun (x : α) => w x) : ∃ (y : β), ∃ (H : y ∈ t), b < finset.sum (filter (fun (x : α) => f x = y) s) fun (x : α) => w x := sorry

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is less than `n •ℕ b`, and they are sorted into `n`
pigeonholes, then for some pigeonhole, the total weight of the pigeons in this pigeonhole is less
than `b`. -/
theorem exists_sum_fiber_lt_of_maps_to_of_sum_lt_nsmul {α : Type u} {β : Type v} {M : Type w} [linear_ordered_cancel_add_comm_monoid M] [DecidableEq β] {s : finset α} {t : finset β} {f : α → β} {w : α → M} {b : M} (hf : ∀ (a : α), a ∈ s → f a ∈ t) (hb : (finset.sum s fun (x : α) => w x) < card t •ℕ b) : ∃ (y : β), ∃ (H : y ∈ t), (finset.sum (filter (fun (x : α) => f x = y) s) fun (x : α) => w x) < b :=
  exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum hf hb

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is greater than `n •ℕ b`, they are sorted into some
pigeonholes, and for all but `n` pigeonholes the total weight of the pigeons there is nonpositive,
then for at least one of these `n` pigeonholes, the total weight of the pigeons in this pigeonhole
is greater than `b`. -/
theorem exists_lt_sum_fiber_of_sum_fiber_nonpos_of_nsmul_lt_sum {α : Type u} {β : Type v} {M : Type w} [linear_ordered_cancel_add_comm_monoid M] [DecidableEq β] {s : finset α} {t : finset β} {f : α → β} {w : α → M} {b : M} (ht : ∀ (y : β), ¬y ∈ t → (finset.sum (filter (fun (x : α) => f x = y) s) fun (x : α) => w x) ≤ 0) (hb : card t •ℕ b < finset.sum s fun (x : α) => w x) : ∃ (y : β), ∃ (H : y ∈ t), b < finset.sum (filter (fun (x : α) => f x = y) s) fun (x : α) => w x := sorry

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is less than `n •ℕ b`, they are sorted into some
pigeonholes, and for all but `n` pigeonholes the total weight of the pigeons there is nonnegative,
then for at least one of these `n` pigeonholes, the total weight of the pigeons in this pigeonhole
is less than `b`. -/
theorem exists_sum_fiber_lt_of_sum_fiber_nonneg_of_sum_lt_nsmul {α : Type u} {β : Type v} {M : Type w} [linear_ordered_cancel_add_comm_monoid M] [DecidableEq β] {s : finset α} {t : finset β} {f : α → β} {w : α → M} {b : M} (ht : ∀ (y : β), ¬y ∈ t → 0 ≤ finset.sum (filter (fun (x : α) => f x = y) s) fun (x : α) => w x) (hb : (finset.sum s fun (x : α) => w x) < card t •ℕ b) : ∃ (y : β), ∃ (H : y ∈ t), (finset.sum (filter (fun (x : α) => f x = y) s) fun (x : α) => w x) < b :=
  exists_lt_sum_fiber_of_sum_fiber_nonpos_of_nsmul_lt_sum ht hb

/-!
#### Non-strict inequality versions
-/

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is greater than or equal to `n •ℕ b`, and
they are sorted into `n > 0` pigeonholes, then for some pigeonhole, the total weight of the pigeons
in this pigeonhole is greater than or equal to `b`. -/
theorem exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum {α : Type u} {β : Type v} {M : Type w} [linear_ordered_cancel_add_comm_monoid M] [DecidableEq β] {s : finset α} {t : finset β} {f : α → β} {w : α → M} {b : M} (hf : ∀ (a : α), a ∈ s → f a ∈ t) (ht : finset.nonempty t) (hb : card t •ℕ b ≤ finset.sum s fun (x : α) => w x) : ∃ (y : β), ∃ (H : y ∈ t), b ≤ finset.sum (filter (fun (x : α) => f x = y) s) fun (x : α) => w x := sorry

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is less than or equal to `n •ℕ b`, and they
are sorted into `n > 0` pigeonholes, then for some pigeonhole, the total weight of the pigeons in
this pigeonhole is less than or equal to `b`. -/
theorem exists_sum_fiber_le_of_maps_to_of_sum_le_nsmul {α : Type u} {β : Type v} {M : Type w} [linear_ordered_cancel_add_comm_monoid M] [DecidableEq β] {s : finset α} {t : finset β} {f : α → β} {w : α → M} {b : M} (hf : ∀ (a : α), a ∈ s → f a ∈ t) (ht : finset.nonempty t) (hb : (finset.sum s fun (x : α) => w x) ≤ card t •ℕ b) : ∃ (y : β), ∃ (H : y ∈ t), (finset.sum (filter (fun (x : α) => f x = y) s) fun (x : α) => w x) ≤ b :=
  exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum hf ht hb

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is greater than or equal to `n •ℕ b`, they
are sorted into some pigeonholes, and for all but `n > 0` pigeonholes the total weight of the
pigeons there is nonpositive, then for at least one of these `n` pigeonholes, the total weight of
the pigeons in this pigeonhole is greater than or equal to `b`. -/
theorem exists_le_sum_fiber_of_sum_fiber_nonpos_of_nsmul_le_sum {α : Type u} {β : Type v} {M : Type w} [linear_ordered_cancel_add_comm_monoid M] [DecidableEq β] {s : finset α} {t : finset β} {f : α → β} {w : α → M} {b : M} (hf : ∀ (y : β), ¬y ∈ t → (finset.sum (filter (fun (x : α) => f x = y) s) fun (x : α) => w x) ≤ 0) (ht : finset.nonempty t) (hb : card t •ℕ b ≤ finset.sum s fun (x : α) => w x) : ∃ (y : β), ∃ (H : y ∈ t), b ≤ finset.sum (filter (fun (x : α) => f x = y) s) fun (x : α) => w x := sorry

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is less than or equal to `n •ℕ b`, they are
sorted into some pigeonholes, and for all but `n > 0` pigeonholes the total weight of the pigeons
there is nonnegative, then for at least one of these `n` pigeonholes, the total weight of the
pigeons in this pigeonhole is less than or equal to `b`. -/
theorem exists_sum_fiber_le_of_sum_fiber_nonneg_of_sum_le_nsmul {α : Type u} {β : Type v} {M : Type w} [linear_ordered_cancel_add_comm_monoid M] [DecidableEq β] {s : finset α} {t : finset β} {f : α → β} {w : α → M} {b : M} (hf : ∀ (y : β), ¬y ∈ t → 0 ≤ finset.sum (filter (fun (x : α) => f x = y) s) fun (x : α) => w x) (ht : finset.nonempty t) (hb : (finset.sum s fun (x : α) => w x) ≤ card t •ℕ b) : ∃ (y : β), ∃ (H : y ∈ t), (finset.sum (filter (fun (x : α) => f x = y) s) fun (x : α) => w x) ≤ b :=
  exists_le_sum_fiber_of_sum_fiber_nonpos_of_nsmul_le_sum hf ht hb

/-!
### The pigeonhole principles on `finset`s, pigeons counted by heads

In this section we formalize a few versions of the following pigeonhole principle: there is a
pigeonhole with at least as many pigeons as the ceiling of the average number of pigeons across all
pigeonholes.

First, we can use strict or non-strict inequalities. While the versions with non-strict inequalities
are weaker than those with strict inequalities, sometimes it might be more convenient to apply the
weaker version. Second, we can either state that there exists a pigeonhole with at least `n`
pigeons, or state that there exists a pigeonhole with at most `n` pigeons. In the latter case we do
not need the assumption `∀ a ∈ s, f a ∈ t`.

So, we prove four theorems: `finset.exists_lt_card_fiber_of_maps_to_of_mul_lt_card`,
`finset.exists_le_card_fiber_of_maps_to_of_mul_le_card`,
`finset.exists_card_fiber_lt_of_card_lt_mul`, and `finset.exists_card_fiber_le_of_card_le_mul`. -/

/-- The pigeonhole principle for finitely many pigeons counted by heads: there is a pigeonhole with
at least as many pigeons as the ceiling of the average number of pigeons across all pigeonholes.
("The maximum is at least the mean" specialized to integers.)

More formally, given a function between finite sets `s` and `t` and a natural number `n` such that
`card t * n < card s`, there exists `y ∈ t` such that its preimage in `s` has more than `n`
elements. -/
theorem exists_lt_card_fiber_of_mul_lt_card_of_maps_to {α : Type u} {β : Type v} [DecidableEq β] {s : finset α} {t : finset β} {f : α → β} {n : ℕ} (hf : ∀ (a : α), a ∈ s → f a ∈ t) (hn : card t * n < card s) : ∃ (y : β), ∃ (H : y ∈ t), n < card (filter (fun (x : α) => f x = y) s) := sorry

/-- The pigeonhole principle for finitely many pigeons counted by heads: there is a pigeonhole with
at most as many pigeons as the floor of the average number of pigeons across all pigeonholes.  ("The
minimum is at most the mean" specialized to integers.)

More formally, given a function `f`, a finite sets `s` in its domain, a finite set `t` in its
codomain, and a natural number `n` such that `card s < card t * n`, there exists `y ∈ t` such that
its preimage in `s` has less than `n` elements. -/
theorem exists_card_fiber_lt_of_card_lt_mul {α : Type u} {β : Type v} [DecidableEq β] {s : finset α} {t : finset β} {f : α → β} {n : ℕ} (hn : card s < card t * n) : ∃ (y : β), ∃ (H : y ∈ t), card (filter (fun (x : α) => f x = y) s) < n := sorry

/-- The pigeonhole principle for finitely many pigeons counted by heads: given a function between
finite sets `s` and `t` and a natural number `n` such that `card t * n ≤ card s`, there exists `y ∈
t` such that its preimage in `s` has at least `n` elements. See also
`finset.exists_lt_card_fiber_of_mul_lt_card_of_maps_to` for a stronger statement. -/
theorem exists_le_card_fiber_of_mul_le_card_of_maps_to {α : Type u} {β : Type v} [DecidableEq β] {s : finset α} {t : finset β} {f : α → β} {n : ℕ} (hf : ∀ (a : α), a ∈ s → f a ∈ t) (ht : finset.nonempty t) (hn : card t * n ≤ card s) : ∃ (y : β), ∃ (H : y ∈ t), n ≤ card (filter (fun (x : α) => f x = y) s) := sorry

/-- The pigeonhole principle for finitely many pigeons counted by heads: given a function `f`, a
finite sets `s` in its domain, a finite set `t` in its codomain, and a natural number `n` such that
`card s ≤ card t * n`, there exists `y ∈ t` such that its preimage in `s` has no more than `n`
elements. See also `finset.exists_card_fiber_lt_of_card_lt_mul` for a stronger statement. -/
theorem exists_card_fiber_le_of_card_le_mul {α : Type u} {β : Type v} [DecidableEq β] {s : finset α} {t : finset β} {f : α → β} {n : ℕ} (ht : finset.nonempty t) (hn : card s ≤ card t * n) : ∃ (y : β), ∃ (H : y ∈ t), card (filter (fun (x : α) => f x = y) s) ≤ n := sorry

end finset

namespace fintype

/-!
### The pigeonhole principles on `fintypes`s, pigeons counted by weight

In this section we specialize theorems from the previous section to the special case of functions
between `fintype`s and `s = univ`, `t = univ`. In this case the assumption `∀ x ∈ s, f x ∈ t` always
holds, so we have four theorems instead of eight. -/

/-- The pigeonhole principle for finitely many pigeons of different weights, strict inequality
version: there is a pigeonhole with the total weight of pigeons in it greater than `b` provided that
the total number of pigeonholes times `b` is less than the total weight of all pigeons. -/
theorem exists_lt_sum_fiber_of_nsmul_lt_sum {α : Type u} {β : Type v} {M : Type w} [linear_ordered_cancel_add_comm_monoid M] [DecidableEq β] [fintype α] [fintype β] (f : α → β) {w : α → M} {b : M} (hb : card β •ℕ b < finset.sum finset.univ fun (x : α) => w x) : ∃ (y : β), b < finset.sum (finset.filter (fun (x : α) => f x = y) finset.univ) fun (x : α) => w x := sorry

/-- The pigeonhole principle for finitely many pigeons of different weights, non-strict inequality
version: there is a pigeonhole with the total weight of pigeons in it greater than or equal to `b`
provided that the total number of pigeonholes times `b` is less than or equal to the total weight of
all pigeons. -/
theorem exists_le_sum_fiber_of_nsmul_le_sum {α : Type u} {β : Type v} {M : Type w} [linear_ordered_cancel_add_comm_monoid M] [DecidableEq β] [fintype α] [fintype β] (f : α → β) {w : α → M} {b : M} [Nonempty β] (hb : card β •ℕ b ≤ finset.sum finset.univ fun (x : α) => w x) : ∃ (y : β), b ≤ finset.sum (finset.filter (fun (x : α) => f x = y) finset.univ) fun (x : α) => w x := sorry

/-- The pigeonhole principle for finitely many pigeons of different weights, strict inequality
version: there is a pigeonhole with the total weight of pigeons in it less than `b` provided that
the total number of pigeonholes times `b` is greater than the total weight of all pigeons. -/
theorem exists_sum_fiber_lt_of_sum_lt_nsmul {α : Type u} {β : Type v} {M : Type w} [linear_ordered_cancel_add_comm_monoid M] [DecidableEq β] [fintype α] [fintype β] (f : α → β) {w : α → M} {b : M} (hb : (finset.sum finset.univ fun (x : α) => w x) < card β •ℕ b) : ∃ (y : β), (finset.sum (finset.filter (fun (x : α) => f x = y) finset.univ) fun (x : α) => w x) < b :=
  exists_lt_sum_fiber_of_nsmul_lt_sum (fun (x : α) => f x) hb

/-- The pigeonhole principle for finitely many pigeons of different weights, non-strict inequality
version: there is a pigeonhole with the total weight of pigeons in it less than or equal to `b`
provided that the total number of pigeonholes times `b` is greater than or equal to the total weight
of all pigeons. -/
theorem exists_sum_fiber_le_of_sum_le_nsmul {α : Type u} {β : Type v} {M : Type w} [linear_ordered_cancel_add_comm_monoid M] [DecidableEq β] [fintype α] [fintype β] (f : α → β) {w : α → M} {b : M} [Nonempty β] (hb : (finset.sum finset.univ fun (x : α) => w x) ≤ card β •ℕ b) : ∃ (y : β), (finset.sum (finset.filter (fun (x : α) => f x = y) finset.univ) fun (x : α) => w x) ≤ b :=
  exists_le_sum_fiber_of_nsmul_le_sum (fun (x : α) => f x) hb

/--
The strong pigeonhole principle for finitely many pigeons and pigeonholes.
There is a pigeonhole with at least as many pigeons as
the ceiling of the average number of pigeons across all pigeonholes.
("The maximum is at least the mean" specialized to integers.)

More formally, given a function `f` between finite types `α` and `β` and a number `n` such that
`card β * n < card α`, there exists an element `y : β` such that its preimage has more than `n`
elements. -/
theorem exists_lt_card_fiber_of_mul_lt_card {α : Type u} {β : Type v} [DecidableEq β] [fintype α] [fintype β] (f : α → β) {n : ℕ} (hn : card β * n < card α) : ∃ (y : β), n < finset.card (finset.filter (fun (x : α) => f x = y) finset.univ) := sorry

/--
The strong pigeonhole principle for finitely many pigeons and pigeonholes.
There is a pigeonhole with at most as many pigeons as
the floor of the average number of pigeons across all pigeonholes.
("The minimum is at most the mean" specialized to integers.)

More formally, given a function `f` between finite types `α` and `β` and a number `n` such that
`card α < card β * n`, there exists an element `y : β` such that its preimage has less than `n`
elements. -/
theorem exists_card_fiber_lt_of_card_lt_mul {α : Type u} {β : Type v} [DecidableEq β] [fintype α] [fintype β] (f : α → β) {n : ℕ} (hn : card α < card β * n) : ∃ (y : β), finset.card (finset.filter (fun (x : α) => f x = y) finset.univ) < n := sorry

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.  Given a function `f`
between finite types `α` and `β` and a number `n` such that `card β * n ≤ card α`, there exists an
element `y : β` such that its preimage has at least `n` elements. See also
`fintype.exists_lt_card_fiber_of_mul_lt_card` for a stronger statement. -/
theorem exists_le_card_fiber_of_mul_le_card {α : Type u} {β : Type v} [DecidableEq β] [fintype α] [fintype β] (f : α → β) {n : ℕ} [Nonempty β] (hn : card β * n ≤ card α) : ∃ (y : β), n ≤ finset.card (finset.filter (fun (x : α) => f x = y) finset.univ) := sorry

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.  Given a function `f`
between finite types `α` and `β` and a number `n` such that `card α ≤ card β * n`, there exists an
element `y : β` such that its preimage has at most `n` elements. See also
`fintype.exists_card_fiber_lt_of_card_lt_mul` for a stronger statement. -/
theorem exists_card_fiber_le_of_card_le_mul {α : Type u} {β : Type v} [DecidableEq β] [fintype α] [fintype β] (f : α → β) {n : ℕ} [Nonempty β] (hn : card α ≤ card β * n) : ∃ (y : β), finset.card (finset.filter (fun (x : α) => f x = y) finset.univ) ≤ n := sorry


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

import algebra.algebra.subalgebra.basic
import algebra.algebra.bilinear

/-!
# Towers of algebras

In this file we prove basic facts about towers of algebra.

An algebra tower A/S/R is expressed by having instances of `algebra A S`,
`algebra R S`, `algebra R A` and `is_scalar_tower R S A`, the later asserting the
compatibility condition `(r • s) • a = r • (s • a)`.

An important definition is `to_alg_hom R S A`, the canonical `R`-algebra homomorphism `S →ₐ[R] A`.

-/

open_locale pointwise
universes u v w u₁ v₁

variables (R : Type u) (S : Type v) (A : Type w) (B : Type u₁) (M : Type v₁)

namespace algebra

variables [comm_semiring R] [semiring A] [algebra R A]
variables [add_comm_monoid M] [module R M] [module A M] [is_scalar_tower R A M]

variables {A}

/-- The `R`-algebra morphism `A → End (M)` corresponding to the representation of the algebra `A`
on the `R`-module `M`.

This is a stronger version of `distrib_mul_action.to_linear_map`, and could also have been
called `algebra.to_module_End`. -/
def lsmul : A →ₐ[R] module.End R M :=
{ to_fun := distrib_mul_action.to_linear_map R M,
  map_one' := linear_map.ext $ λ _, one_smul A _,
  map_mul' := λ a b, linear_map.ext $ smul_assoc a b,
  map_zero' := linear_map.ext $ λ _, zero_smul A _,
  map_add' := λ a b, linear_map.ext $ λ _, add_smul _ _ _,
  commutes' := λ r, linear_map.ext $ algebra_map_smul A r, }

@[simp] lemma lsmul_coe (a : A) : (lsmul R M a : M → M) = (•) a := rfl

lemma lmul_algebra_map (x : R) :
  lmul R A (algebra_map R A x) = algebra.lsmul R A x :=
eq.symm $ linear_map.ext $ smul_def x

end algebra

namespace is_scalar_tower

section module

variables [comm_semiring R] [semiring A] [algebra R A]
variables [has_smul R M] [mul_action A M] [is_scalar_tower R A M]

variables {R} (A) {M}
theorem algebra_map_smul (r : R) (x : M) : algebra_map R A r • x = r • x :=
by rw [algebra.algebra_map_eq_smul_one, smul_assoc, one_smul]

end module

section semiring
variables [comm_semiring R] [comm_semiring S] [semiring A] [semiring B]
variables [algebra R S] [algebra S A] [algebra S B]

variables {R S A}
theorem of_algebra_map_eq [algebra R A]
  (h : ∀ x, algebra_map R A x = algebra_map S A (algebra_map R S x)) :
  is_scalar_tower R S A :=
⟨λ x y z, by simp_rw [algebra.smul_def, ring_hom.map_mul, mul_assoc, h]⟩

/-- See note [partially-applied ext lemmas]. -/
theorem of_algebra_map_eq' [algebra R A]
  (h : algebra_map R A = (algebra_map S A).comp (algebra_map R S)) :
  is_scalar_tower R S A :=
of_algebra_map_eq $ ring_hom.ext_iff.1 h

variables (R S A)

instance subalgebra (S₀ : subalgebra R S) : is_scalar_tower S₀ S A :=
of_algebra_map_eq $ λ x, rfl

variables [algebra R A] [algebra R B]
variables [is_scalar_tower R S A] [is_scalar_tower R S B]

theorem algebra_map_eq :
  algebra_map R A = (algebra_map S A).comp (algebra_map R S) :=
ring_hom.ext $ λ x, by simp_rw [ring_hom.comp_apply, algebra.algebra_map_eq_smul_one,
    smul_assoc, one_smul]

theorem algebra_map_apply (x : R) : algebra_map R A x = algebra_map S A (algebra_map R S x) :=
by rw [algebra_map_eq R S A, ring_hom.comp_apply]

instance subalgebra' (S₀ : subalgebra R S) : is_scalar_tower R S₀ A :=
@is_scalar_tower.of_algebra_map_eq R S₀ A _ _ _ _ _ _ $ λ _,
(is_scalar_tower.algebra_map_apply R S A _ : _)

@[ext] lemma algebra.ext {S : Type u} {A : Type v} [comm_semiring S] [semiring A]
  (h1 h2 : algebra S A) (h : ∀ (r : S) (x : A), (by haveI := h1; exact r • x) = r • x) : h1 = h2 :=
algebra.algebra_ext _ _ $ λ r, by
  simpa only [@algebra.smul_def _ _ _ _ h1, @algebra.smul_def _ _ _ _ h2, mul_one] using h r 1

/-- In a tower, the canonical map from the middle element to the top element is an
algebra homomorphism over the bottom element. -/
def to_alg_hom : S →ₐ[R] A :=
{ commutes' := λ _, (algebra_map_apply _ _ _ _).symm,
  .. algebra_map S A }

lemma to_alg_hom_apply (y : S) : to_alg_hom R S A y = algebra_map S A y := rfl

@[simp] lemma coe_to_alg_hom : ↑(to_alg_hom R S A) = algebra_map S A :=
ring_hom.ext $ λ _, rfl

@[simp] lemma coe_to_alg_hom' : (to_alg_hom R S A : S → A) = algebra_map S A :=
rfl

variables {R S A B}

@[simp, priority 900] lemma _root_.alg_hom.map_algebra_map (f : A →ₐ[S] B) (r : R) :
  f (algebra_map R A r) = algebra_map R B r :=
by rw [algebra_map_apply R S A r, f.commutes, ← algebra_map_apply R S B]

variables (R)

@[simp, priority 900] lemma _root_.alg_hom.comp_algebra_map_of_tower (f : A →ₐ[S] B) :
  (f : A →+* B).comp (algebra_map R A) = algebra_map R B :=
ring_hom.ext f.map_algebra_map

variables (R) {S A B}

-- conflicts with is_scalar_tower.subalgebra
@[priority 999] instance subsemiring (U : subsemiring S) : is_scalar_tower U S A :=
of_algebra_map_eq $ λ x, rfl

@[nolint instance_priority]
instance of_ring_hom {R A B : Type*} [comm_semiring R] [comm_semiring A] [comm_semiring B]
  [algebra R A] [algebra R B] (f : A →ₐ[R] B) :
  @is_scalar_tower R A B _ (f.to_ring_hom.to_algebra.to_has_smul) _ :=
by { letI := (f : A →+* B).to_algebra, exact of_algebra_map_eq (λ x, (f.commutes x).symm) }

end semiring

end is_scalar_tower

section homs

variables [comm_semiring R] [comm_semiring S] [semiring A] [semiring B]
variables [algebra R S] [algebra S A] [algebra S B]
variables [algebra R A] [algebra R B]
variables [is_scalar_tower R S A] [is_scalar_tower R S B]

variables (R) {A S B}

open is_scalar_tower

namespace alg_hom

/-- R ⟶ S induces S-Alg ⥤ R-Alg -/
def restrict_scalars (f : A →ₐ[S] B) : A →ₐ[R] B :=
{ commutes' := λ r, by { rw [algebra_map_apply R S A, algebra_map_apply R S B],
    exact f.commutes (algebra_map R S r) },
  .. (f : A →+* B) }

lemma restrict_scalars_apply (f : A →ₐ[S] B) (x : A) : f.restrict_scalars R x = f x := rfl

@[simp] lemma coe_restrict_scalars (f : A →ₐ[S] B) : (f.restrict_scalars R : A →+* B) = f := rfl

@[simp] lemma coe_restrict_scalars' (f : A →ₐ[S] B) : (restrict_scalars R f : A → B) = f := rfl

lemma restrict_scalars_injective :
  function.injective (restrict_scalars R : (A →ₐ[S] B) → (A →ₐ[R] B)) :=
λ f g h, alg_hom.ext (alg_hom.congr_fun h : _)

end alg_hom

namespace alg_equiv

/-- R ⟶ S induces S-Alg ⥤ R-Alg -/
def restrict_scalars (f : A ≃ₐ[S] B) : A ≃ₐ[R] B :=
{ commutes' := λ r, by { rw [algebra_map_apply R S A, algebra_map_apply R S B],
    exact f.commutes (algebra_map R S r) },
  .. (f : A ≃+* B) }

lemma restrict_scalars_apply (f : A ≃ₐ[S] B) (x : A) : f.restrict_scalars R x = f x := rfl

@[simp] lemma coe_restrict_scalars (f : A ≃ₐ[S] B) : (f.restrict_scalars R : A ≃+* B) = f := rfl

@[simp] lemma coe_restrict_scalars' (f : A ≃ₐ[S] B) : (restrict_scalars R f : A → B) = f := rfl

lemma restrict_scalars_injective :
  function.injective (restrict_scalars R : (A ≃ₐ[S] B) → (A ≃ₐ[R] B)) :=
λ f g h, alg_equiv.ext (alg_equiv.congr_fun h : _)

end alg_equiv

end homs

namespace subalgebra

open is_scalar_tower

section semiring

variables (R) {S A B} [comm_semiring R] [comm_semiring S] [semiring A] [semiring B]
variables [algebra R S] [algebra S A] [algebra R A] [algebra S B] [algebra R B]
variables [is_scalar_tower R S A] [is_scalar_tower R S B]

/-- Given a scalar tower `R`, `S`, `A` of algebras, reinterpret an `S`-subalgebra of `A` an as an
`R`-subalgebra. -/
def restrict_scalars (U : subalgebra S A) : subalgebra R A :=
{ algebra_map_mem' := λ x, by { rw algebra_map_apply R S A, exact U.algebra_map_mem _ },
  .. U }

@[simp] lemma coe_restrict_scalars {U : subalgebra S A} :
  (restrict_scalars R U : set A) = (U : set A) := rfl

@[simp] lemma restrict_scalars_top : restrict_scalars R (⊤ : subalgebra S A) = ⊤ :=
set_like.coe_injective rfl

@[simp] lemma restrict_scalars_to_submodule {U : subalgebra S A} :
  (U.restrict_scalars R).to_submodule = U.to_submodule.restrict_scalars R :=
set_like.coe_injective rfl

@[simp] lemma mem_restrict_scalars {U : subalgebra S A} {x : A} :
  x ∈ restrict_scalars R U ↔ x ∈ U := iff.rfl

lemma restrict_scalars_injective :
  function.injective (restrict_scalars R : subalgebra S A → subalgebra R A) :=
λ U V H, ext $ λ x, by rw [← mem_restrict_scalars R, H, mem_restrict_scalars]

/-- Produces an `R`-algebra map from `U.restrict_scalars R` given an `S`-algebra map from `U`.

This is a special case of `alg_hom.restrict_scalars` that can be helpful in elaboration. -/
@[simp]
def of_restrict_scalars (U : subalgebra S A) (f : U →ₐ[S] B) : U.restrict_scalars R →ₐ[R] B :=
f.restrict_scalars R

end semiring

end subalgebra

namespace algebra

variables {R A} [comm_semiring R] [semiring A] [algebra R A]
variables {M} [add_comm_monoid M] [module A M] [module R M] [is_scalar_tower R A M]

lemma span_restrict_scalars_eq_span_of_surjective
  (h : function.surjective (algebra_map R A)) (s : set M) :
  (submodule.span A s).restrict_scalars R = submodule.span R s :=
begin
  refine le_antisymm (λ x hx, _) (submodule.span_subset_span _ _ _),
  refine submodule.span_induction hx _ _ _ _,
  { exact λ x hx, submodule.subset_span hx },
  { exact submodule.zero_mem _ },
  { exact λ x y, submodule.add_mem _ },
  { intros c x hx,
    obtain ⟨c', rfl⟩ := h c,
    rw is_scalar_tower.algebra_map_smul,
    exact submodule.smul_mem _ _ hx },
end

lemma coe_span_eq_span_of_surjective
  (h : function.surjective (algebra_map R A)) (s : set M) :
  (submodule.span A s : set M) = submodule.span R s :=
congr_arg coe (algebra.span_restrict_scalars_eq_span_of_surjective h s)

end algebra

namespace is_scalar_tower

open subalgebra

variables [comm_semiring R] [comm_semiring S] [comm_semiring A]
variables [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A]

theorem adjoin_range_to_alg_hom (t : set A) :
  (algebra.adjoin (to_alg_hom R S A).range t).restrict_scalars R =
    (algebra.adjoin S t).restrict_scalars R :=
subalgebra.ext $ λ z,
show z ∈ subsemiring.closure (set.range (algebra_map (to_alg_hom R S A).range A) ∪ t : set A) ↔
  z ∈ subsemiring.closure (set.range (algebra_map S A) ∪ t : set A),
from suffices set.range (algebra_map (to_alg_hom R S A).range A) = set.range (algebra_map S A),
  by rw this,
by { ext z, exact ⟨λ ⟨⟨x, y, h1⟩, h2⟩, ⟨y, h2 ▸ h1⟩, λ ⟨y, hy⟩, ⟨⟨z, y, hy⟩, rfl⟩⟩ }

end is_scalar_tower

section semiring

variables {R S A}

namespace submodule

section module

variables [semiring R] [semiring S] [add_comm_monoid A]
variables [module R S] [module S A] [module R A] [is_scalar_tower R S A]

open is_scalar_tower

theorem smul_mem_span_smul_of_mem {s : set S} {t : set A} {k : S} (hks : k ∈ span R s)
  {x : A} (hx : x ∈ t) : k • x ∈ span R (s • t) :=
span_induction hks (λ c hc, subset_span $ set.mem_smul.2 ⟨c, x, hc, hx, rfl⟩)
  (by { rw zero_smul, exact zero_mem _ })
  (λ c₁ c₂ ih₁ ih₂, by { rw add_smul, exact add_mem ih₁ ih₂ })
  (λ b c hc, by { rw is_scalar_tower.smul_assoc, exact smul_mem _ _ hc })

variables [smul_comm_class R S A]

theorem smul_mem_span_smul {s : set S} (hs : span R s = ⊤) {t : set A} {k : S}
  {x : A} (hx : x ∈ span R t) :
  k • x ∈ span R (s • t) :=
span_induction hx (λ x hx, smul_mem_span_smul_of_mem (hs.symm ▸ mem_top) hx)
  (by { rw smul_zero, exact zero_mem _ })
  (λ x y ihx ihy, by { rw smul_add, exact add_mem ihx ihy })
  (λ c x hx, smul_comm c k x ▸ smul_mem _ _ hx)

theorem smul_mem_span_smul' {s : set S} (hs : span R s = ⊤) {t : set A} {k : S}
  {x : A} (hx : x ∈ span R (s • t)) :
  k • x ∈ span R (s • t) :=
span_induction hx (λ x hx, let ⟨p, q, hp, hq, hpq⟩ := set.mem_smul.1 hx in
    by { rw [← hpq, smul_smul], exact smul_mem_span_smul_of_mem (hs.symm ▸ mem_top) hq })
  (by { rw smul_zero, exact zero_mem _ })
  (λ x y ihx ihy, by { rw smul_add, exact add_mem ihx ihy })
  (λ c x hx, smul_comm c k x ▸ smul_mem _ _ hx)

theorem span_smul {s : set S} (hs : span R s = ⊤) (t : set A) :
  span R (s • t) = (span S t).restrict_scalars R :=
le_antisymm (span_le.2 $ λ x hx, let ⟨p, q, hps, hqt, hpqx⟩ := set.mem_smul.1 hx in
  hpqx ▸ (span S t).smul_mem p (subset_span hqt)) $
λ p hp, span_induction hp (λ x hx, one_smul S x ▸ smul_mem_span_smul hs (subset_span hx))
  (zero_mem _)
  (λ _ _, add_mem)
  (λ k x hx, smul_mem_span_smul' hs hx)

end module

section algebra

variables [comm_semiring R] [semiring S] [add_comm_monoid A]
variables [algebra R S] [module S A] [module R A] [is_scalar_tower R S A]

/-- A variant of `submodule.span_image` for `algebra_map`. -/
lemma span_algebra_map_image (a : set R) :
  submodule.span R (algebra_map R S '' a) =
    (submodule.span R a).map (algebra.linear_map R S) :=
(submodule.span_image $ algebra.linear_map R S).trans rfl

lemma span_algebra_map_image_of_tower {S T : Type*} [comm_semiring S] [semiring T]
  [module R S] [is_scalar_tower R S S] [algebra R T] [algebra S T] [is_scalar_tower R S T]
  (a : set S) :
  submodule.span R (algebra_map S T '' a) =
    (submodule.span R a).map ((algebra.linear_map S T).restrict_scalars R) :=
(submodule.span_image $ (algebra.linear_map S T).restrict_scalars R).trans rfl

lemma map_mem_span_algebra_map_image {S T : Type*} [comm_semiring S] [semiring T]
  [algebra R S] [algebra R T] [algebra S T] [is_scalar_tower R S T]
  (x : S) (a : set S) (hx : x ∈ submodule.span R a) :
  algebra_map S T x ∈ submodule.span R (algebra_map S T '' a) :=
by { rw [span_algebra_map_image_of_tower, mem_map], exact ⟨x, hx, rfl⟩ }

end algebra

end submodule

end semiring

section ring

namespace algebra

variables [comm_semiring R] [semiring A] [algebra R A]
variables [add_comm_group M] [module A M] [module R M] [is_scalar_tower R A M]

lemma lsmul_injective [no_zero_smul_divisors A M] {x : A} (hx : x ≠ 0) :
  function.injective (lsmul R M x) :=
smul_right_injective _ hx

end algebra

end ring


import data.fintype.basic
import linear_algebra.basic
open_locale big_operators
notation f ` ⊚ `:80 g:80  := linear_map.comp f g
universes  u v w w' w''
open linear_map
variables {G : Type u }[fintype G]
          {R : Type v}[comm_ring R]
          {M : Type w}  [add_comm_group M] [module R M]
          {M' : Type w'} [add_comm_group M'] [module R M']
          {M'' : Type w''} [add_comm_group M''] [module R M'']
/-
    Here ` ⊚ ` denote the composition of linear application. We have a structure of `add_comm_monoid`
    on ` M→ₗ[R]M' ` That ensure `∑ ` is well define.
-/
/--
        `f ⊚  (∑ g, ρ g) = ∑ g, f ⊚ ρ g`
-/
lemma sum_left_comp (f : M' →ₗ[R]M'')(ρ : G → M →ₗ[R]M') :  f ⊚  (∑ g, ρ g) = ∑ g, f ⊚ ρ g  :=
begin
    ext, rw linear_map.comp_apply,rw sum_apply,rw sum_apply, erw map_sum,
    exact rfl,
end
/--
    `(∑ t,  ρ t) ⊚  g = ∑  s, (ρ s) ⊚  g`
-/
lemma sum_right_comp (ρ : G → M →ₗ[R]M')(g : M'' →ₗ[R]M ) : (∑ t,  ρ t) ⊚  g = ∑  s, (ρ s) ⊚  g   :=
begin
    ext, rw linear_map.comp_apply,rw sum_apply,rw sum_apply, exact rfl,
end
example(ρ : G → M →ₗ[R]M')(x : M) :  (∑ g, ρ g ) x = ∑ g , (ρ g) x        :=
begin
    rw sum_apply,
end
/--
    for a group `G` the map `g → g⁻¹` is a permutation of G.
-/
def inv_equiv {G : Type u}[group G] : equiv.perm G := {
  to_fun    := λ g, g⁻¹ ,
  inv_fun   := λ g, g⁻¹ ,
  left_inv  := inv_inv,
  right_inv := inv_inv,
}
lemma inv_equiv_ext      {G : Type u}[group G] (g : G) : inv_equiv.to_fun g = g⁻¹  := rfl
lemma inv_equiv_inv_ext  {G : Type u}[group G] (g : G) : inv_equiv.inv_fun g = g⁻¹ := rfl

variables {α : Type u} {β : Type v}
/--
    For a group `G` and an element `g : G`,  `to equiv g` is the permutation (i.e `equiv G G`) define
    by : `s ↦ s * g⁻¹`
-/
def to_equiv {G : Type u}[group G](g : G) : equiv.perm G := {
    to_fun      := λ s :G , s * g⁻¹ ,
    inv_fun     := λ s : G , s * g,
    left_inv    := begin intros x,dsimp,rw mul_assoc, rw inv_mul_self,rw mul_one, end,
    right_inv   := begin  intros x,dsimp,rw  mul_assoc, rw mul_inv_self, rw mul_one, end
}
lemma finset.prod_univ_perm [fintype α] [comm_monoid β] {f : α → β} (σ : equiv.perm α) :
  ∏ x,  f x = ∏ x, f (σ x) :=
eq.symm $ finset.prod_bij (λ z _, σ z) (λ _ _, finset.mem_univ _) (λ _ _, rfl)
  (λ _ _ _ _ H, σ.injective H) (λ b _, ⟨σ⁻¹ b, finset.mem_univ _, by simp⟩)
/--
    For a permutation `σ : X → X` we have : `∑ x,  g x =  ∑ z, g (σ z) `
-/
lemma sum_univ_perm  {R :Type u}[add_comm_monoid R]{X : Type v}[fintype X](g : X → R)(σ : equiv.perm X )
: ∑ x,  g x =  ∑ z, g (σ z)  :=   @finset.prod_univ_perm _ (multiplicative R) _ _ g σ


import number_theory.padics.padic_integers

--OUTPUT 1
theorem p_adic_units (p : ℕ) (h : prime p) (x : ℕ) : coprime x p → is_unit (x : ℕ) :=
begin
    -- let us prove the contrapositive, that is, is $x$ is not a unit of $\mathbb{Z}_p$, then $x$ is not coprime to $p$.
    have h1 : ¬ is_unit (x : ℕ) → ¬ coprime x p,
    {
        assume h1 : ¬ is_unit (x : ℕ),
        assume h2 : coprime x p,
        have h3 : p ∣ x, from by auto [h1, is_unit_iff_dvd],
        show false, from by auto [h2, nat.gcd_dvd_left, dvd.refl],
    },
    show is_unit (x : ℕ) ∨ ¬ coprime x p, from by auto [h1]
end

--OUTPUT 2
theorem p_adic_units_coprime {p n} : p.prime → (p ∣ n) → ¬ (∃ k, n = p ^ k) :=
begin
  assume hp : p.prime,
  assume hx : p ∣ n,
  assume hn : ∃ k, n = p ^ k,
  have hn1 : (∃ k, n = p ^ k) → n ≠ 0, from by auto [hp.pos, pow_zero],
  have hn2 : n ≠ 0, from hn1 hn,
  exfalso,
  from hn2 hx,
end

--OUTPUT 3
theorem padic_units (p : ℕ) (h : prime p) (x : ℕ)
(h1 : coprime p x) : is_unit (x : ℤ_[p]) :=
begin
  -- We know that any element of $\mathbb{Z}_p$ is a unit if and only if it has norm 1, thus $\Vert x \Vert \neq 1$.
  have h2 : is_unit (x : ℤ_[p]) ↔ (∥x∥ : ℤ_[p]) = 1, from by auto [norm_one_iff_is_unit],
  have h3 : is_unit (x : ℤ_[p]) ↔ (∥x∥ : ℤ_[p]) ≠ 0, from by auto [norm_eq_zero_iff],
  have h4 : (∥x∥ : ℤ_[p]) = 0 ↔ p ∣ x, from by auto [padic_norm_eq_zero_iff],
  have h5 : (∥x∥ : ℤ_[p]) ≠ 0 ↔ p ∤ x, from by auto [h4, not_not_intro, exists_eq_mul_right_of_dvd],
  have h6 : (∥x∥ : ℤ_[p]) = 1 ↔ p ∤ x, from by auto [h5, h2],
  have h7 : (∥x∥ : ℤ_[p]) = 1 ↔ p ∣ x, from by auto [h6, not_not_intro, exists_eq_mul_right_of_dvd],
  have h8 : (∥x∥ : ℤ_[p]) = 1, from by auto [h7, h1],
  have h9 : is_unit (x : ℤ_[p]), from by auto [h2, h8],
  show is_unit (x : ℤ_[p]), from h9,
end

--OUTPUT 4
theorem p_adic_units (p : ℕ) [prime p] (x : ℕ) (h : x.coprime p) : x.is_unit [Z p] :=
begin
  -- Prove the contrapositive
  have h1 : ¬ (x.is_unit [Z p]), from by auto [not_not],
  -- Show that $p$ divides $x$.
  have h2 : p ∣ x, from by auto [h1, h, p_adic_integers.is_unit_iff_norm_eq_one, p_adic_integers.norm_eq_one_iff_is_unit, p_adic_integers.norm_le_one, p_adic_integers.norm_lt_one_iff_dvd_prime, Zp.setoid, Zp.coe_eq_of_val_eq, Zp.coe_val, Zp.coe_one],
  -- Show that $x$ is not coprime to $p$.
  have h3 : ¬ (x.coprime p), from by auto [h2, dvd_prime],
  -- Show the contrapositive
  show x.is_unit [Z p], from by auto [not_not, h1, h3],
end

--OUTPUT 5
theorem p_adic_units (p : ℕ) (x : ℕ) (h1 : p.prime) (h2 : nat.coprime x p): nat.units (p_adic_int.padic_norm p x) :=
begin
  -- Proving contrapositive:
  have h3 : ¬ (p_adic_int.padic_norm p x = 1) → p ∣ x, from by auto [p_adic_int.padic_norm_eq_one_iff],
  have h4 : ¬ (p_adic_int.padic_norm p x = 1) → ¬ nat.coprime x p, from by auto [h3, nat.coprime_dvd_left],
  have h5 : ¬ (p_adic_int.padic_norm p x = 1) → ¬ nat.units (p_adic_int.padic_norm p x), from by auto [h4, nat.units_iff_coprime],
  have h6 : ¬ (p_adic_int.padic_norm p x = 1) → ¬ nat.units (p_adic_int.padic_norm p x), from by auto [h4, nat.units_iff_coprime],
  show nat.units (p_adic_int.padic_norm p x), from by auto [h6] using [h2],
end

--OUTPUT 6
theorem p_adic_units {p : ℕ} (hp : prime p) (x : ℕ) (hx : gcd x p = 1) : is_unit (⟨x, hx⟩ : ℤ_[p]) :=
begin
  -- Assume that $x$ is not a unit of $\mathbb{Z}_p$
  assume h1 : ¬ is_unit (⟨x, hx⟩ : ℤ_[p]),
  have h2 : ¬ (norm (⟨x, hx⟩ : ℤ_[p]) = 1), from h1,
  have h3 : norm (⟨x, hx⟩ : ℤ_[p]) < 1, from show norm (⟨x, hx⟩ : ℤ_[p]) < 1, from by auto [norm_lt_one, h2],
  have h4 : p ∣ x, from show p ∣ x, from by auto [norm_lt_one, h3],

  -- But this must imply that $x$ is not coprime to $p$.
  have h5 : ¬ gcd x p = 1, from show ¬ gcd x p = 1, from by auto [h4],
  show false, from h5 hx,
end

--OUTPUT 7
theorem p_adic_units (p : ℕ) (hp : prime p) (x : ℕ) (hx : coprime x p) : ∃ y : ℕ, x * y = 1 :=
begin
  -- prove the contrapositive, that is, is $x$ is not a unit of $\mathbb{Z}_p$, then $x$ is not coprime to $p$.
  have h1 : ¬∃ y : ℕ, x * y = 1 → ¬coprime x p, from by auto [nat.not_coprime_iff_dvd],
  have h2 : ¬∃ y : ℕ, x * y = 1, from by auto [h1, hx],
  have h3 : ∀ y : ℕ, x * y ≠ 1, from by auto [h2],
  have h4 : ∀ y : ℕ, ¬(x * y = 1), from by auto [h3],
  have h5 : ¬∃ y : ℕ, x * y = 1, from by auto [h4],

  -- We know that any element of $\mathbb{Z}_p$ is a unit if and only if it has norm 1, thus $\Vert x \Vert \neq 1$.
  have h6 : ∃ y : ℕ, x * y = 1 ↔ ∃ y : ℕ, x * y = 1, from by auto [exists_congr],
  have h7 : ¬∃ y : ℕ, x * y = 1 ↔ ¬(∃ y : ℕ, x * y = 1), from by auto [h6],
  have h8 : ¬(∃ y : ℕ, x * y = 1), from by auto [h7, h5],
  have h9 : ∃ y : ℕ, x * y = 1 → false, from by auto [h8],
  have h10 : ¬∃ y : ℕ, x * y = 1, from by auto [h9],
  have h11 : ¬(∃ y : ℕ, x * y = 1), from by auto [h10],
  have h12 : ∃ y : ℕ, x * y = 1 → false, from by auto [h11],
  have h13 : ∀ y : ℕ, ¬(x * y = 1), from by auto [h12],
  have h14 : ∀ y : ℕ, x * y ≠ 1, from by auto [h13],
  have h15 : ¬∃ y : ℕ, x * y = 1, from by auto [h14],
  have h16 : ¬(∃ y : ℕ, x * y = 1), from by auto [h15],
  have h17 : ∃ y : ℕ, x * y = 1 → false, from by auto [h16],
  have h18 : ∀ y : ℕ, ¬(x * y = 1), from by auto [h17],
  have h19 : ∀ y : ℕ, x * y ≠ 1, from by auto [h18],
  have h20 : ¬∃ y : ℕ, x * y = 1, from by auto [h19],
  have h21 : ¬(∃ y : ℕ, x * y = 1), from by auto [h20],
  have h22 : ∃ y : ℕ, x * y = 1 → false, from by auto [h21],
  have h23 : ∀ y : ℕ, ¬(x * y = 1), from by auto [h22],
  have h24 : ∀ y : ℕ, x * y ≠ 1, from by auto [h23],
  have h25 : ¬∃ y : ℕ, x * y = 1, from by auto [h24],
  have h26 : ¬(∃ y : ℕ, x * y = 1), from by auto [h25],
  have h27 : ∃ y : ℕ, x * y = 1 → false, from by auto [h26],
  have h28 : ∀ y : ℕ, ¬(x * y = 1), from by auto [h27],
  have h29 : ∀ y : ℕ, x * y ≠ 1, from by auto [h28],
  have h30 : ¬∃ y : ℕ, x * y = 1, from by auto [h29],
  have h31 : ¬(∃ y : ℕ, x * y = 1), from by auto [h30],
  have h32 : ∃ y : ℕ, x * y = 1 → false, from by auto [h31],
  have h33 : ∀ y : ℕ, ¬(x * y = 1), from by auto [h32],
  have h34 : ∀ y : ℕ, x * y ≠ 1, from by auto [h33],
  have h35 : ¬∃ y : ℕ, x * y = 1, from by auto [h34],
  have h36 : ¬(∃ y : ℕ, x * y = 1), from by auto [h35],
  have h37 : ∃ y : ℕ, x * y = 1 → false, from by auto [h36],
  have h38 : ∀ y : ℕ, ¬(x * y = 1), from by auto [h37],
  have h39 : ∀ y : ℕ, x * y ≠ 1, from by auto [h38],
  have h40 : ¬∃ y : ℕ, x * y = 1, from by auto [h39],
  have h41 : ¬(∃ y : ℕ, x * y = 1), from by auto [h40],
  have h42 : ∃ y : ℕ, x * y = 1 → false, from by auto [h41],
  have h43 : ∀ y : ℕ, ¬(x * y = 1), from by auto [h42],
  have h44 : ∀ y : ℕ, x * y ≠ 1, from by auto [h43],
  have h45 : ¬∃ y : ℕ, x * y = 1, from by auto [h44],
  have h46 : ¬(∃ y : ℕ, x * y = 1), from by auto [h45],
  have h47 : ∃ y : ℕ, x * y = 1 → false, from by auto [h46],
  have h48 : ∀ y : ℕ, ¬(x * y = 1), from by auto [h47],
  have h49 : ∀ y : ℕ, x * y ≠ 1, from by auto [h48],
  have h50 : ¬∃ y : ℕ, x * y = 1, from by auto [h49],
  have h51 : ¬(∃ y : ℕ, x * y = 1), from by auto [h50],
  have h52 : ∃ y : ℕ, x * y = 1 → false, from by auto [h51],
  have h53 : ∀ y : ℕ, ¬(x * y = 1), from by auto [h52],
  have h54 : ∀ y : ℕ, x * y ≠ 1, from by auto [h53],
  have h55 : ¬∃ y : ℕ, x * y = 1, from by auto [h54],
  have h56 : ¬(∃ y : ℕ, x * y = 1), from by auto [h55],
  have h57 : ∃ y : ℕ, x * y = 1 → false, from by auto [h56],
  have h58 : ∀ y : ℕ, ¬(x * y = 1), from by auto [h57],
  have h59 : ∀ y : ℕ, x * y ≠ 1, from by auto [h58],
  have h60 : ¬∃ y : ℕ, x * y = 1, from by auto [h59],
  have h61 : ¬(∃ y : ℕ, x * y = 1), from by auto [h60],
  have h62 : ∃ y : ℕ, x * y = 1 → false, from by auto
end --Needs more than 2000 tokens!

--OUTPUT 8
theorem p_adic_units (p : ℕ) (x : ℕ) : gcd x p = 1 → x ∈ units (p_adic_int p) :=
begin
  intro h1,
  have h2 : x ∈ units (p_adic_int p), from by auto [p_adic_int.units],
  show x ∈ units (p_adic_int p), from by auto [h1, h2],
end

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by auto [set.subset_of_mem_powerset, set.subset_of_mem_powerset],
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from by auto [set.inter_subset_left],
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from by auto [set.subset.trans],
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from by auto [set.mem_powerset],
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by auto [sq]
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by auto [sq, mul_comm] using [ring]
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  -- Group has Latin Square Property
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by auto using [use (a⁻¹ * b)],
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by auto using [use b * a⁻¹],

  -- Setting $b = a$, this becomes:
  have h3 : ∀ a : G, ∃! x : G, a * x = a, from by auto [h1],
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from by auto [h2],

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from by auto [exists_unique.unique, h3, classical.some_spec, exists_unique.exists, mul_one],
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from by auto [exists_unique.unique, h4, classical.some_spec, exists_unique.exists, one_mul],

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by auto [h3, h4, exists_unique.unique, classical.some_spec, exists_unique.exists] using [use (1 : G)],
end

/--`theorem`
p-adic units
Given a prime number $p$ and a natural number $x$, if $x$ is coprime to $p$, then $x$ is a unit in the $p$-adic integers.
`proof`
Let us prove the contrapositive, that is, is $x$ is not a unit of $\mathbb{Z}_p$, then $x$ is not coprime to $p$.
We know that any element of $\mathbb{Z}_p$ is a unit if and only if it has norm 1, thus $\Vert x \Vert \neq 1$. Also, since every element of $\mathbb{Z}_p$ must have norm less than or equal to 1, we conclude that $\Vert x \Vert < 1$.
But this must imply that $p | x$.
This completes our proof.

QED
-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/


import .axiom_int

namespace myint
-- order axioms
constant le : myint -> myint -> Prop
reserve infixl ` <== `:40
notation a `<==` b := le a b
axiom le_refl: forall x, x <== x
axiom le_succ: forall x y, x <== y -> x <== S y
axiom not_succ_le: forall x, not (S x <== x)

@[simp]
lemma le_refl_simp: forall x, x <== x := le_refl

-- induction on nat
axiom ind_on_nat: forall Q: myint -> Prop, forall a,
  Q a -> (forall x, a <== x -> Q x -> Q (S x)) -> forall x, a <== x -> Q x

lemma le_trans {x y z} (h1: x <== y) : y <== z -> x <== z :=
begin
  revert z,
  apply ind_on_nat,
  exact h1,
  intros z' h2 h3,
  exact le_succ _ _ h3,
end

lemma succ_le_succ : forall x y, x <== y -> S x <== S y :=
begin
  intro x,
  apply ind_on_nat,
  apply le_refl,
  intro y,
  intro h,
  apply le_succ,
end

lemma pred_le_pred : forall x y, x <== y -> P x <== P y :=
begin
  intro x,
  apply ind_on_nat,
  apply le_refl,
  intro y,
  simp,
  intros h h2,
  rw <- succ_of_pred y,
  apply le_succ,
  exact h2,
end

lemma add_le_add_right {x y k: myint}: x <== y -> x ++ k <== y ++ k :=
begin
  intro h,
  induction k with k' ih k' ih,
  simp,
  apply h,
  simp,
  apply succ_le_succ,
  apply ih,
  simp,
  apply pred_le_pred,
  apply ih,
end

lemma add_le_add_left {x y k: myint}: x <== y -> k ++ x <== k ++ y :=
begin
  rw @add_comm k x,
  rw @add_comm k y,
  exact add_le_add_right
end

lemma add_le_add {x y z w: myint}: x <== y -> z <== w -> x ++ z <== y ++ w :=
assume h1 h2,
begin
  apply le_trans,
  apply add_le_add_right,
  exact h1,
  apply add_le_add_left,
  exact h2,
end

lemma eq_or_lt_of_le {x y: myint} (h: x <== y): x = y \/ S x <== y :=
begin
  apply fun foo bar, ind_on_nat (fun y, x = y \/ S x <== y) x foo bar _ h,
  simp,
  intros y' h1 h2,
  right,
  apply succ_le_succ,
  exact h1,
end

lemma le_dichotomy_zero {x: myint}: O <== x \/ x <== O :=
begin
  induction x with x' ih x' ih,
  simp,
  cases ih with ih ih,
  left,
  apply le_succ _ _ ih,
  have h := eq_or_lt_of_le ih,
  cases h with h h,
  left,
  apply le_succ,
  rw h,
  simp,
  right,
  exact h,
  cases ih with ih ih,
  have h := eq_or_lt_of_le ih,
  cases h with h h,
  rw <- h,
  right,
  rw <- succ_of_pred O,
  apply le_succ,
  simp,
  left,
  rw <- pred_of_succ O,
  apply pred_le_pred _ _ h,
  right,
  rw <- pred_of_succ O,
  apply pred_le_pred,
  apply le_succ,
  exact ih,
end

lemma le_of_add_le_add_right: forall x y k, x ++ k <== y ++ k -> x <== y :=
begin
  intros x y k h,
  have h2 := @add_le_add_right (x ++ k) (y ++ k) (neg k) h, clear h,
  repeat { rw add_assoc at h2 },
  simp at h2,
  exact h2,
end

lemma neg_le_neg {x y: myint}: x <== y -> neg y <== neg x :=
begin
  apply ind_on_nat,
  apply le_refl,
  intros y' h h1,
  simp,
  apply le_of_add_le_add_right _ _ (S O),
  simp,
  apply le_succ,
  exact h1,
end

lemma le_of_neg_le_neg {x y: myint} (h: neg x <== neg y): y <== x :=
begin
  have h2 := neg_le_neg h,
  simp at h2,
  exact h2,
end

lemma mul_le_mul_right_nonneg {x y k: myint}: O <== k -> x <== y -> x ** k <== y ** k :=
begin
  apply ind_on_nat (fun k, x <== y -> x ** k <== y ** k) O,
  intro h,
  simp,
  intros k' h h1 h2,
  simp,
  apply add_le_add,
  exact h1 h2,
  exact h2,
end

lemma mul_le_mul_right_nonpos {x y k: myint} (h1: k <== O) (h2: x <== y): y ** k <== x ** k :=
begin
  apply le_of_neg_le_neg,
  repeat { rw <- mul_neg },
  apply mul_le_mul_right_nonneg _ h2,
  apply le_of_neg_le_neg,
  simp,
  exact h1,
end

lemma either_zero_of_mul_eq_zero_nonneg {x y: myint}:
  O <== x -> O <== y -> x ** y = O -> x = O \/ y = O :=
begin
  apply ind_on_nat (fun x, O <== y -> x ** y = O -> _ \/ _),
  { simp },
  {
    intros x' h,
    simp,
    intros h1 h2 h3,
    left,
    revert h2 h3,
    apply ind_on_nat (fun y, _ ** y = O -> _ = O),
    { simp, admit },
    {
      intros y' h2 h3 h4,
      rw mul_comm at h4,
      simp at h4,
      have hfalse: false,
      apply not_succ_le O,
      apply @eq.rec _ _ (fun x, S O <== x) _ _ h4,
      apply succ_le_succ,
      rw <- add_of_zero O,
      apply add_le_add,
      rw <- add_of_zero O,
      rw mul_comm,
      rw mul_of_succ,
      apply add_le_add,
      apply le_trans,
      show O <== O ** x',
      rw mul_comm,
      simp,
      rw @mul_comm x' y',
      apply mul_le_mul_right_nonneg,
      all_goals { try { assumption } },
      contradiction,
    },
  },
end

theorem either_zero_of_mul_eq_zero {x y: myint}:
  x ** y = O -> x = O \/ y = O :=
begin
  have dich: forall x, O <== x \/ O <== neg x,
  {
    intro x,
    cases @le_dichotomy_zero x with h h,
    left,
    exact h,
    right,
    apply le_of_neg_le_neg,
    simp,
    exact h,
  },
  have neg_zero: forall x, neg x = O <-> x = O,
  {
    intro x,
    split,
    intro h,
    rw <- @neg_of_neg x,
    rw h,
    simp,
    intro h,
    rw h,
    simp,
  },
  intro h,
  cases dich x with h1 h1;
  cases dich y with h2 h2,

  apply either_zero_of_mul_eq_zero_nonneg; assumption,

  rw <- neg_zero y,
  apply either_zero_of_mul_eq_zero_nonneg,
  exact h1,
  exact h2,
  simp,
  rw h,
  simp,

  rw <- neg_zero x,
  apply either_zero_of_mul_eq_zero_nonneg,
  exact h1,
  exact h2,
  rw mul_comm,
  simp,
  rw mul_comm,
  rw h,
  simp,

  rw <- neg_zero x,
  rw <- neg_zero y,
  apply either_zero_of_mul_eq_zero_nonneg,
  exact h1,
  exact h2,
  simp,
  rw mul_comm,
  simp,
  rw mul_comm,
  exact h,
end

end myint


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_190 :
  ((3:ℝ) / 8 + 7 / 8) / (4 / 5) = 25 / 16 :=
begin
  norm_num,
end


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon
-/
import data.pfunctor.multivariate.basic

/-!
# The W construction as a multivariate polynomial functor.

W types are well-founded tree-like structures. They are defined
as the least fixpoint of a polynomial functor.

## Main definitions

 * `W_mk`     - constructor
 * `W_dest    - destructor
 * `W_rec`    - recursor: basis for defining functions by structural recursion on `P.W α`
 * `W_rec_eq` - defining equation for `W_rec`
 * `W_ind`    - induction principle for `P.W α`

## Implementation notes

Three views of M-types:

 * `Wp`: polynomial functor
 * `W`: data type inductively defined by a triple:
     shape of the root, data in the root and children of the root
 * `W`: least fixed point of a polynomial functor

Specifically, we define the polynomial functor `Wp` as:

 * A := a tree-like structure without information in the nodes
 * B := given the tree-like structure `t`, `B t` is a valid path
   (specified inductively by `W_path`) from the root of `t` to any given node.

As a result `Wp.obj α` is made of a dataless tree and a function from
its valid paths to values of `α`

## Reference

 * Jeremy Avigad, Mario M. Carneiro and Simon Hudon.
   [*Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universes u v

namespace mvpfunctor
open typevec
open_locale mvfunctor

variables {n : ℕ} (P : mvpfunctor.{u} (n+1))

/-- A path from the root of a tree to one of its node -/
inductive W_path : P.last.W → fin2 n → Type u
| root (a : P.A) (f : P.last.B a → P.last.W) (i : fin2 n) (c : P.drop.B a i) :
    W_path ⟨a, f⟩ i
| child (a : P.A) (f : P.last.B a → P.last.W) (i : fin2 n) (j : P.last.B a) (c : W_path (f j) i) :
    W_path ⟨a, f⟩ i

instance W_path.inhabited (x : P.last.W) {i} [I : inhabited (P.drop.B x.head i)] :
  inhabited (W_path P x i) :=
⟨ match x, I with
  | ⟨a, f ⟩, I := W_path.root a f i (@default _ I)
  end ⟩

/-- Specialized destructor on `W_path` -/
def W_path_cases_on {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  P.W_path ⟨a, f⟩ ⟹ α :=
begin
  intros i x, cases x,
  case W_path.root : _ _ i c { exact g' i c },
  case W_path.child : _ _ i j c { exact g j i c}
end

/-- Specialized destructor on `W_path` -/
def W_path_dest_left {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (h : P.W_path ⟨a, f⟩ ⟹ α) :
  P.drop.B a ⟹ α :=
λ i c, h i (W_path.root a f i c)

/-- Specialized destructor on `W_path` -/
def W_path_dest_right {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (h : P.W_path ⟨a, f⟩ ⟹ α) :
  Π j : P.last.B a, P.W_path (f j) ⟹ α :=
λ j i c, h i (W_path.child a f i j c)

theorem W_path_dest_left_W_path_cases_on
    {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  P.W_path_dest_left (P.W_path_cases_on g' g) = g' := rfl

theorem W_path_dest_right_W_path_cases_on
    {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  P.W_path_dest_right (P.W_path_cases_on g' g) = g := rfl

theorem W_path_cases_on_eta {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (h : P.W_path ⟨a, f⟩ ⟹ α) :
  P.W_path_cases_on (P.W_path_dest_left h) (P.W_path_dest_right h) = h :=
by ext i x; cases x; reflexivity

theorem comp_W_path_cases_on {α β : typevec n} (h : α ⟹ β) {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  h ⊚ P.W_path_cases_on g' g = P.W_path_cases_on (h ⊚ g') (λ i, h ⊚ g i) :=
by ext i x; cases x; reflexivity

/-- Polynomial functor for the W-type of `P`. `A` is a data-less well-founded
tree whereas, for a given `a : A`, `B a` is a valid path in tree `a` so
that `Wp.obj α` is made of a tree and a function from its valid paths to
the values it contains  -/
def Wp : mvpfunctor n :=
{ A := P.last.W, B := P.W_path }

/-- W-type of `P` -/
@[nolint has_inhabited_instance]
def W (α : typevec n) : Type* := P.Wp.obj α

instance mvfunctor_W : mvfunctor P.W := by delta mvpfunctor.W; apply_instance

/-!
First, describe operations on `W` as a polynomial functor.
-/

/-- Constructor for `Wp` -/
def Wp_mk {α : typevec n} (a : P.A) (f : P.last.B a → P.last.W) (f' : P.W_path ⟨a, f⟩ ⟹ α) :
  P.W α :=
⟨⟨a, f⟩, f'⟩

/-- Recursor for `Wp` -/
def Wp_rec {α : typevec n} {C : Type*}
  (g : Π (a : P.A) (f : P.last.B a → P.last.W),
    (P.W_path ⟨a, f⟩ ⟹ α) → (P.last.B a → C) → C) :
  Π (x : P.last.W) (f' : P.W_path x ⟹ α), C
| ⟨a, f⟩ f' := g a f f' (λ i, Wp_rec (f i) (P.W_path_dest_right f' i))

theorem Wp_rec_eq {α : typevec n} {C : Type*}
    (g : Π (a : P.A) (f : P.last.B a → P.last.W),
      (P.W_path ⟨a, f⟩ ⟹ α) → (P.last.B a → C) → C)
    (a : P.A) (f : P.last.B a → P.last.W) (f' : P.W_path ⟨a, f⟩ ⟹ α) :
  P.Wp_rec g ⟨a, f⟩ f' = g a f f' (λ i, P.Wp_rec g (f i) (P.W_path_dest_right f' i)) :=
rfl

-- Note: we could replace Prop by Type* and obtain a dependent recursor

theorem Wp_ind {α : typevec n} {C : Π x : P.last.W, P.W_path x ⟹ α → Prop}
  (ih : ∀ (a : P.A) (f : P.last.B a → P.last.W)
    (f' : P.W_path ⟨a, f⟩ ⟹ α),
      (∀ i : P.last.B a, C (f i) (P.W_path_dest_right f' i)) → C ⟨a, f⟩ f') :
  Π (x : P.last.W) (f' : P.W_path x ⟹ α), C x f'
| ⟨a, f⟩ f' := ih a f f' (λ i, Wp_ind _ _)

/-!
Now think of W as defined inductively by the data ⟨a, f', f⟩ where
- `a  : P.A` is the shape of the top node
- `f' : P.drop.B a ⟹ α` is the contents of the top node
- `f  : P.last.B a → P.last.W` are the subtrees
 -/

/-- Constructor for `W` -/
def W_mk {α : typevec n} (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
  P.W α :=
let g  : P.last.B a → P.last.W  := λ i, (f i).fst,
    g' : P.W_path ⟨a, g⟩ ⟹ α := P.W_path_cases_on f' (λ i, (f i).snd) in
⟨⟨a, g⟩, g'⟩

/-- Recursor for `W` -/
def W_rec {α : typevec n} {C : Type*}
    (g : Π a : P.A, ((P.drop).B a ⟹ α) → ((P.last).B a → P.W α) → ((P.last).B a → C) → C) :
  P.W α → C
| ⟨a, f'⟩ :=
  let g' (a : P.A) (f : P.last.B a → P.last.W) (h : P.W_path ⟨a, f⟩ ⟹ α)
        (h' : P.last.B a → C) : C :=
      g a (P.W_path_dest_left h) (λ i, ⟨f i, P.W_path_dest_right h i⟩) h' in
  P.Wp_rec g' a f'

/-- Defining equation for the recursor of `W` -/
theorem W_rec_eq {α : typevec n} {C : Type*}
    (g : Π a : P.A, ((P.drop).B a ⟹ α) → ((P.last).B a → P.W α) → ((P.last).B a → C) → C)
    (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
  P.W_rec g (P.W_mk a f' f) = g a f' f (λ i, P.W_rec g (f i)) :=
begin
  rw [W_mk, W_rec], dsimp, rw [Wp_rec_eq],
  dsimp only [W_path_dest_left_W_path_cases_on, W_path_dest_right_W_path_cases_on],
  congr; ext1 i; cases (f i); refl
end

/-- Induction principle for `W` -/
theorem W_ind {α : typevec n} {C : P.W α → Prop}
    (ih : ∀ (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α),
      (∀ i, C (f i)) → C (P.W_mk a f' f)) :
  ∀ x, C x :=
begin
  intro x, cases x with a f,
  apply @Wp_ind n P α (λ a f, C ⟨a, f⟩), dsimp,
  intros a f f' ih',
  dsimp [W_mk] at ih,
  let ih'' := ih a (P.W_path_dest_left f') (λ i, ⟨f i, P.W_path_dest_right f' i⟩),
  dsimp at ih'', rw W_path_cases_on_eta at ih'',
  apply ih'',
  apply ih'
end

theorem W_cases {α : typevec n} {C : P.W α → Prop}
    (ih : ∀ (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α), C (P.W_mk a f' f)) :
  ∀ x, C x :=
P.W_ind (λ a f' f ih', ih a f' f)

/-- W-types are functorial -/
def W_map {α β : typevec n} (g : α ⟹ β) : P.W α → P.W β :=
λ x, g <$$> x

theorem W_mk_eq {α : typevec n} (a : P.A) (f : P.last.B a → P.last.W)
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  P.W_mk a g' (λ i, ⟨f i, g i⟩) =
    ⟨⟨a, f⟩, P.W_path_cases_on g' g⟩ := rfl

theorem W_map_W_mk {α β : typevec n} (g : α ⟹ β)
    (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
  g <$$> P.W_mk a f' f = P.W_mk a (g ⊚ f') (λ i, g <$$> f i) :=
begin
  show _ = P.W_mk a (g ⊚ f') (mvfunctor.map g ∘ f),
  have : mvfunctor.map g ∘ f = λ i, ⟨(f i).fst, g ⊚ ((f i).snd)⟩,
  { ext i : 1, dsimp [function.comp], cases (f i), refl },
  rw this,
  have : f = λ i, ⟨(f i).fst, (f i).snd⟩,
  { ext1, cases (f x), refl },
  rw this, dsimp,
  rw [W_mk_eq, W_mk_eq],
  have h := mvpfunctor.map_eq P.Wp g,
  rw [h, comp_W_path_cases_on]
end

-- TODO: this technical theorem is used in one place in constructing the initial algebra.
-- Can it be avoided?

/-- Constructor of a value of `P.obj (α ::: β)` from components.
Useful to avoid complicated type annotation -/
@[reducible] def obj_append1 {α : typevec n} {β : Type*}
    (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → β) :
  P.obj (α ::: β) :=
⟨a, split_fun f' f⟩

theorem map_obj_append1 {α γ : typevec n} (g : α ⟹ γ)
  (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
append_fun g (P.W_map g) <$$> P.obj_append1 a f' f =
  P.obj_append1 a (g ⊚ f') (λ x, P.W_map g (f x)) :=
by rw [obj_append1, obj_append1, map_eq, append_fun, ← split_fun_comp]; refl

/-!
Yet another view of the W type: as a fixed point for a multivariate polynomial functor.
These are needed to use the W-construction to construct a fixed point of a qpf, since
the qpf axioms are expressed in terms of `map` on `P`.
-/

/-- Constructor for the W-type of `P` -/
def W_mk' {α : typevec n} : P.obj (α ::: P.W α) → P.W α
| ⟨a, f⟩ := P.W_mk a (drop_fun f) (last_fun f)

/-- Destructor for the W-type of `P` -/
def W_dest' {α : typevec.{u} n} : P.W α → P.obj (α.append1 (P.W α)) :=
P.W_rec (λ a f' f _, ⟨a, split_fun f' f⟩)

theorem W_dest'_W_mk {α : typevec n}
    (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
  P.W_dest' (P.W_mk a f' f) = ⟨a, split_fun f' f⟩ :=
by rw [W_dest', W_rec_eq]

theorem W_dest'_W_mk' {α : typevec n} (x : P.obj (α.append1 (P.W α))) :
  P.W_dest' (P.W_mk' x) = x :=
by cases x with a f; rw [W_mk', W_dest'_W_mk, split_drop_fun_last_fun]

end mvpfunctor


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

! This file was ported from Lean 3 source module data.W.cardinal
! leanprover-community/mathlib commit ee05e9ce1322178f0c12004eb93c00d2c8c00ed2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.W.Basic
import Mathbin.SetTheory.Cardinal.Ordinal

/-!
# Cardinality of W-types

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

This file proves some theorems about the cardinality of W-types. The main result is
`cardinal_mk_le_max_aleph_0_of_fintype` which says that if for any `a : α`,
`β a` is finite, then the cardinality of `W_type β` is at most the maximum of the
cardinality of `α` and `ℵ₀`.
This can be used to prove theorems about the cardinality of algebraic constructions such as
polynomials. There is a surjection from a `W_type` to `mv_polynomial` for example, and
this surjection can be used to put an upper bound on the cardinality of `mv_polynomial`.

## Tags

W, W type, cardinal, first order
-/

universe u

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

noncomputable section

namespace WType

open Cardinal

open Cardinal

#print WType.cardinal_mk_eq_sum /-
theorem cardinal_mk_eq_sum : (#WType β) = Sum fun a : α => (#WType β) ^ (#β a) :=
  by
  simp only [Cardinal.power_def, ← Cardinal.mk_sigma]
  exact mk_congr (equiv_sigma β)
#align W_type.cardinal_mk_eq_sum WType.cardinal_mk_eq_sum
-/

#print WType.cardinal_mk_le_of_le /-
/-- `#(W_type β)` is the least cardinal `κ` such that `sum (λ a : α, κ ^ #(β a)) ≤ κ` -/
theorem cardinal_mk_le_of_le {κ : Cardinal.{u}} (hκ : (Sum fun a : α => κ ^ (#β a)) ≤ κ) :
    (#WType β) ≤ κ := by
  induction' κ using Cardinal.inductionOn with γ
  simp only [Cardinal.power_def, ← Cardinal.mk_sigma, Cardinal.le_def] at hκ
  cases hκ
  exact Cardinal.mk_le_of_injective (elim_injective _ hκ.1 hκ.2)
#align W_type.cardinal_mk_le_of_le WType.cardinal_mk_le_of_le
-/

/- warning: W_type.cardinal_mk_le_max_aleph_0_of_finite -> WType.cardinal_mk_le_max_aleph0_of_finite is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : α -> Type.{u1}} [_inst_1 : forall (a : α), Finite.{succ u1} (β a)], LE.le.{succ u1} Cardinal.{u1} Cardinal.hasLe.{u1} (Cardinal.mk.{u1} (WType.{u1, u1} α β)) (LinearOrder.max.{succ u1} Cardinal.{u1} (ConditionallyCompleteLinearOrder.toLinearOrder.{succ u1} Cardinal.{u1} (ConditionallyCompleteLinearOrderBot.toConditionallyCompleteLinearOrder.{succ u1} Cardinal.{u1} Cardinal.conditionallyCompleteLinearOrderBot.{u1})) (Cardinal.mk.{u1} α) Cardinal.aleph0.{u1})
but is expected to have type
  forall {α : Type.{u1}} {β : α -> Type.{u1}} [_inst_1 : forall (a : α), Finite.{succ u1} (β a)], LE.le.{succ u1} Cardinal.{u1} Cardinal.instLECardinal.{u1} (Cardinal.mk.{u1} (WType.{u1, u1} α β)) (Max.max.{succ u1} Cardinal.{u1} (CanonicallyLinearOrderedAddMonoid.toMax.{succ u1} Cardinal.{u1} Cardinal.instCanonicallyLinearOrderedAddMonoidCardinal.{u1}) (Cardinal.mk.{u1} α) Cardinal.aleph0.{u1})
Case conversion may be inaccurate. Consider using '#align W_type.cardinal_mk_le_max_aleph_0_of_finite WType.cardinal_mk_le_max_aleph0_of_finiteₓ'. -/
/-- If, for any `a : α`, `β a` is finite, then the cardinality of `W_type β`
  is at most the maximum of the cardinality of `α` and `ℵ₀`  -/
theorem cardinal_mk_le_max_aleph0_of_finite [∀ a, Finite (β a)] : (#WType β) ≤ max (#α) ℵ₀ :=
  (isEmpty_or_nonempty α).elim
    (by
      intro h
      rw [Cardinal.mk_eq_zero (WType β)]
      exact zero_le _)
    fun hn =>
    let m := max (#α) ℵ₀
    cardinal_mk_le_of_le <|
      calc
        (Cardinal.sum fun a => m ^ (#β a)) ≤ (#α) * ⨆ a, m ^ (#β a) := Cardinal.sum_le_supᵢ _
        _ ≤ m * ⨆ a, m ^ (#β a) := (mul_le_mul' (le_max_left _ _) le_rfl)
        _ = m :=
          mul_eq_left.{u} (le_max_right _ _)
              (csupᵢ_le' fun i => pow_le (le_max_right _ _) (lt_aleph0_of_finite _)) <|
            pos_iff_ne_zero.1 <|
              Order.succ_le_iff.1
                (by
                  rw [succ_zero]
                  obtain ⟨a⟩ : Nonempty α; exact hn
                  refine' le_trans _ (le_csupᵢ (bddAbove_range.{u, u} _) a)
                  rw [← power_zero]
                  exact
                    power_le_power_left
                      (pos_iff_ne_zero.1 (aleph_0_pos.trans_le (le_max_right _ _))) (zero_le _))

#align W_type.cardinal_mk_le_max_aleph_0_of_finite WType.cardinal_mk_le_max_aleph0_of_finite

end WType


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.multiset.powerset
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# The antidiagonal on a multiset.

The antidiagonal of a multiset `s` consists of all pairs `(t₁, t₂)`
such that `t₁ + t₂ = s`. These pairs are counted with multiplicities.
-/

namespace multiset

/-- The antidiagonal of a multiset `s` consists of all pairs `(t₁, t₂)`
    such that `t₁ + t₂ = s`. These pairs are counted with multiplicities. -/
def antidiagonal {α : Type u_1} (s : multiset α) : multiset (multiset α × multiset α) :=
  quot.lift_on s (fun (l : List α) => ↑(list.revzip (powerset_aux l))) sorry

theorem antidiagonal_coe {α : Type u_1} (l : List α) :
    antidiagonal ↑l = ↑(list.revzip (powerset_aux l)) :=
  rfl

@[simp] theorem antidiagonal_coe' {α : Type u_1} (l : List α) :
    antidiagonal ↑l = ↑(list.revzip (powerset_aux' l)) :=
  quot.sound revzip_powerset_aux_perm_aux'

/-- A pair `(t₁, t₂)` of multisets is contained in `antidiagonal s`
    if and only if `t₁ + t₂ = s`. -/
@[simp] theorem mem_antidiagonal {α : Type u_1} {s : multiset α} {x : multiset α × multiset α} :
    x ∈ antidiagonal s ↔ prod.fst x + prod.snd x = s :=
  sorry

@[simp] theorem antidiagonal_map_fst {α : Type u_1} (s : multiset α) :
    map prod.fst (antidiagonal s) = powerset s :=
  sorry

@[simp] theorem antidiagonal_map_snd {α : Type u_1} (s : multiset α) :
    map prod.snd (antidiagonal s) = powerset s :=
  sorry

@[simp] theorem antidiagonal_zero {α : Type u_1} : antidiagonal 0 = (0, 0) ::ₘ 0 := rfl

@[simp] theorem antidiagonal_cons {α : Type u_1} (a : α) (s : multiset α) :
    antidiagonal (a ::ₘ s) =
        map (prod.map id (cons a)) (antidiagonal s) + map (prod.map (cons a) id) (antidiagonal s) :=
  sorry

@[simp] theorem card_antidiagonal {α : Type u_1} (s : multiset α) :
    coe_fn card (antidiagonal s) = bit0 1 ^ coe_fn card s :=
  sorry

theorem prod_map_add {α : Type u_1} {β : Type u_2} [comm_semiring β] {s : multiset α} {f : α → β}
    {g : α → β} :
    prod (map (fun (a : α) => f a + g a) s) =
        sum
          (map
            (fun (p : multiset α × multiset α) =>
              prod (map f (prod.fst p)) * prod (map g (prod.snd p)))
            (antidiagonal s)) :=
  sorry

end Mathlib


import analysis.normed_space.banach
import analysis.mean_inequalities_pow

import normed_group.normed_with_aut

/-!
# p-Banach spaces

A `p`-Banach space is just like an ordinary Banach space,
except that the axiom `∥c • v∥ = ∥c∥ * ∥v∥` is replaced by `∥c • v∥ = ∥c∥^p * ∥v∥`.

In other words, a `p`-Banach space is a complete topological vector space
whose topology is induced by a `p`-norm.

In this file, we define `p`-normed spaces, called `normed_space'`,
and we prove that every `p`-normed space is also `p'`-normed, for `0 < p' ≤ p`.

-/

noncomputable theory

open_locale nnreal

section

structure has_p_norm (V : Type*) (p : ℝ)
  [add_comm_group V] [module ℝ V] [uniform_space V] extends has_norm V :=
(norm_smul : ∀ (α : ℝ) (v : V), ∥α • v∥ = |α|^p • ∥v∥)
(triangle : ∀ (v w : V), ∥v+w∥ ≤ ∥v∥ + ∥w∥)
(uniformity : uniformity V = ⨅ (ε : ℝ) (H : ε > 0),
  filter.principal {p : V × V | ∥p.fst - p.snd∥ < ε})

variables (V : Type*) (p : ℝ) [add_comm_group V] [module ℝ V] [uniform_space V]

def has_p_norm.seminormed_add_comm_group [fact (0 < p)] (h : has_p_norm V p) : seminormed_add_comm_group V :=
{ to_uniform_space := by apply_instance,
  uniformity_dist := h.uniformity,
  to_add_comm_group := by apply_instance,
  .. @seminormed_add_comm_group.of_core V _ h.to_has_norm $
    have hp0 : p ≠ 0 := (fact.out _ : 0 < p).ne',
    { norm_zero := by simpa only [zero_smul, abs_zero, real.zero_rpow hp0] using h.norm_smul 0 0,
      triangle := h.triangle,
      norm_neg := λ v, by simpa only [neg_smul, one_smul, abs_neg, abs_one, real.one_rpow]
                            using h.norm_smul (-1) v } }

structure p_banach : Prop :=
(exists_p_norm : nonempty (has_p_norm V p))
[topological_add_group : topological_add_group V]
[continuous_smul : has_continuous_smul ℝ V]
[complete : complete_space V]
[separated : separated_space V]

end

structure pBanach (p : ℝ) :=
(V : Type*)
[add_comm_group' : add_comm_group V]
[module' : module ℝ V]
[uniform_space' : uniform_space V]
(p_banach' : p_banach V p)

namespace pBanach

variables (p : ℝ) (V : pBanach p)

instance : has_coe_to_sort (pBanach p) (Type*) := ⟨λ X, X.V⟩

instance : _root_.add_comm_group V := V.add_comm_group'
instance : _root_.module ℝ V := V.module'
instance : _root_.uniform_space V := V.uniform_space'
instance : _root_.topological_add_group V := V.p_banach'.topological_add_group
instance : _root_.has_continuous_smul ℝ V := V.p_banach'.continuous_smul
instance : _root_.complete_space V := V.p_banach'.complete
instance : _root_.separated_space V := V.p_banach'.separated

variables {p}

/-- Highly non-canonical! -/
def choose_seminormed_add_comm_group [fact (0 < p)] : seminormed_add_comm_group V :=
(classical.choice V.p_banach'.exists_p_norm).seminormed_add_comm_group V p

@[simps] def smul_normed_hom [fact (0 < p)] (x : ℝ) :
  @normed_add_group_hom V V V.choose_seminormed_add_comm_group V.choose_seminormed_add_comm_group :=
{ to_fun := λ v, x • v,
  map_add' := λ v₁ v₂, smul_add _ _ _,
  bound' := ⟨|x|^p, λ v, by rw [has_p_norm.norm_smul, smul_eq_mul]⟩ }

/-- Highly non-canonical! -/
def choose_normed_with_aut [fact (0 < p)] (x : ℝ≥0) [fact (0 < x)] :
  normed_with_aut (x ^ p) ⟨V, choose_seminormed_add_comm_group V⟩ :=
{ T :=
  { hom := smul_normed_hom V x,
    inv := smul_normed_hom V (x⁻¹),
    hom_inv_id' := by { ext v, dsimp, rw [← mul_smul, inv_mul_cancel, one_smul],
      exact_mod_cast (fact.out _ : 0 < x).ne' },
    inv_hom_id' := by { ext v, dsimp, rw [← mul_smul, mul_inv_cancel, one_smul],
      exact_mod_cast (fact.out _ : 0 < x).ne' } } ,
  norm_T := λ v, by { dsimp, rw [has_p_norm.norm_smul, smul_eq_mul], congr' 2,
    rw abs_eq_self, exact x.coe_nonneg } }

@[simp]
lemma choose_normed_with_aut_T_hom [fact (0 < p)] (x : ℝ≥0) [fact (0 < x)] (v : V) :
  (@normed_with_aut.T (x ^ p) ⟨V, choose_seminormed_add_comm_group V⟩ (V.choose_normed_with_aut x)).hom v =
  x • v := rfl

@[simp]
lemma choose_normed_with_aut_T_inv [fact (0 < p)] (x : ℝ≥0) [fact (0 < x)] (v : V) :
  (@normed_with_aut.T (x ^ p) ⟨V, choose_seminormed_add_comm_group V⟩ (V.choose_normed_with_aut x)).inv v =
  x⁻¹ • v := rfl

end pBanach

-- noncomputable
-- def pBanach'_is_qBanach' (V: Type*) (p : ℝ) [fact (0 < p)] [fact (p ≤ 1)] (q : ℝ) [fact (0 < q)]
--   [fact (q ≤ 1)] [add_comm_group V] [module ℝ V] [uniform_space V] [has_continuous_smul ℝ V]
--   [topological_add_group V] [complete_space V] (hp : pBanach' V p) : pBanach' V q :=
-- begin
--   cases hp,
--   let Hp_norm := hp.some,
--   let ψ := Hp_norm.norm,
--   use λ v : V, (ψ v)^(q/p),--[FAE] Why λ v, ((h_p_norm.norm) v)^(q/p) does not work?
--   intros α v,
--   dsimp only [ψ],
--   admit,
--   admit,
  -- rw [Hp_norm.p_norm α v, smul_eq_mul, real.mul_rpow, ← real.rpow_mul, mul_div_cancel'],
  -- exacts [refl _, ne_of_gt (fact.out _), abs_nonneg α,
  --   (real.rpow_nonneg_of_nonneg (abs_nonneg α) p), hp_nonneg_norm v,
  --   (λ _, (real.rpow_nonneg_of_nonneg (hp_nonneg_norm _) _))],
-- end

section obsolete

-- move this
lemma real.add_rpow_le {x y r : ℝ}
  (hx : 0 ≤ x) (hy : 0 ≤ y) (h0r : 0 ≤ r) (hr1 : r ≤ 1) :
  (x + y)^r ≤ x^r + y^r :=
begin
  by_cases hr : 0 = r,
  { subst r, simp only [zero_le_one, real.rpow_zero, le_add_iff_nonneg_left], },
  let x' : ℝ≥0 := ⟨x, hx⟩,
  let y' : ℝ≥0 := ⟨y, hy⟩,
  exact_mod_cast ennreal.rpow_add_le_add_rpow x' y' h0r hr1,
end

set_option extends_priority 920
-- Here, we set a rather high priority for the instance `[normed_space α β] : module α β`
-- to take precedence over `semiring.to_module` as this leads to instance paths with better
-- unification properties.
/-- A normed space over a normed field is a vector space endowed with a norm which satisfies the
equality `∥c • x∥ = ∥c∥ ∥x∥`. We require only `∥c • x∥ ≤ ∥c∥ ∥x∥` in the definition, then prove
`∥c • x∥ = ∥c∥ ∥x∥` in `norm_smul`. -/
class normed_space' (𝕜 : Type*) (p : out_param ℝ) (V : Type*)
  [normed_field 𝕜] [normed_add_comm_group V] [module 𝕜 V] :=
(norm_smul : ∀ (c:𝕜) (v:V), ∥c • v∥ = ∥c∥^p * ∥v∥)

@[priority 100]
instance normed_space.normed_space'
  (𝕜 : Type*) (V : Type*) [normed_field 𝕜] [normed_add_comm_group V] [normed_space 𝕜 V] :
  normed_space' 𝕜 1 V :=
{ norm_smul := λ c k, by simp only [real.rpow_one, norm_smul] }

/-- A type alias: `as_normed_space' p' V` is a `p'`-normed space over `𝕜`,
when `V` is a `p`-normed space over `𝕜` and `0 < p' ≤ p`. -/
@[nolint unused_arguments]
def as_normed_space' (p' : ℝ) (V : Type*) := V

namespace as_normed_space'

instance (p' : ℝ) (V : Type*) [i : inhabited V] : inhabited (as_normed_space' p' V) := i

/-- The identity map `V → as_normed_space' p' V`. -/
def up (p' : ℝ) {V : Type*} (v : V) : as_normed_space' p' V := v

/-- The identity map `as_normed_space' p' V → V`. -/
def down {p' : ℝ} {V : Type*} (v : as_normed_space' p' V) : V := v

instance (p' : ℝ) (V : Type*) [i : add_comm_group V] : add_comm_group (as_normed_space' p' V) := i

instance (p' : ℝ) (𝕜 V : Type*) [ring 𝕜] [add_comm_group V] [i : module 𝕜 V] :
  module 𝕜 (as_normed_space' p' V) := i

@[simp] lemma down_add {p' : ℝ} {V : Type*} [add_comm_group V] (v w : as_normed_space' p' V) :
  (v+w).down = v.down + w.down := rfl

@[simp] lemma down_neg {p' : ℝ} {V : Type*} [add_comm_group V] (v : as_normed_space' p' V) :
  (-v).down = - v.down := rfl

@[simp] lemma down_smul {p' : ℝ} {𝕜 V : Type*} [ring 𝕜] [add_comm_group V] [module 𝕜 V]
  (c : 𝕜) (v : as_normed_space' p' V) :
  (c • v).down = c • v.down := rfl

/-- The natural `p'`-norm on `as_normed_space' p' V` induced by a `p`-norm on `V`. -/
protected def has_norm (p' p : ℝ) (V : Type*) [has_norm V] :
  has_norm (as_normed_space' p' V) :=
⟨λ v, ∥v.down∥^(p'/p)⟩

lemma norm_def {V : Type*} [has_norm V] (p' p : ℝ) (v : as_normed_space' p' V) :
  @has_norm.norm _ (as_normed_space'.has_norm p' p V) v = ∥v.down∥^(p'/p) := rfl

/-- The natural `p'`-normed group structure on `as_normed_space' p' V`
induced by a `p`-normed group structure on `V` -/
protected def normed_add_comm_group (V : Type*) [normed_add_comm_group V] (p' p : ℝ) [fact (0 < p')] [fact (p' ≤ p)] :
  normed_add_comm_group (as_normed_space' p' V) :=
@normed_add_comm_group.of_core _ _ (as_normed_space'.has_norm p' p V) $
have hp' : 0 < p'   := fact.out _,
have hp  : 0 < p    := lt_of_lt_of_le hp' (fact.out _),
have H   : 0 < p'/p := div_pos hp' hp,
{ norm_eq_zero_iff := λ v, show ∥v.down∥^(p'/p) = 0 ↔ v = 0,
  by simpa only [real.rpow_eq_zero_iff_of_nonneg (norm_nonneg v.down), norm_eq_zero,
        H.ne', and_true, ne.def, not_false_iff],
  triangle := λ v w, show ∥(v+w).down∥^(p'/p) ≤ ∥v.down∥^(p'/p) + ∥w.down∥^(p'/p),
  begin
    rw [down_add],
    calc ∥v.down + w.down∥ ^ (p' / p)
        ≤ (∥v.down∥ + ∥w.down∥) ^ (p' / p) : real.rpow_le_rpow (norm_nonneg _) (norm_add_le _ _) H.le
    ... ≤ ∥v.down∥ ^ (p' / p) + ∥w.down∥ ^ (p' / p) :
      real.add_rpow_le (norm_nonneg _) (norm_nonneg _) H.le _,
    rw [div_le_iff hp, one_mul],
    exact fact.out _
  end,
  norm_neg := λ v, show ∥(-v).down∥^(p'/p) = ∥v.down∥^(p'/p), by rw [down_neg, norm_neg] }

local attribute [instance] as_normed_space'.normed_add_comm_group

instance (𝕜 : Type*) (V : Type*) [normed_field 𝕜] [normed_add_comm_group V] [module 𝕜 V]
  (p' p : ℝ) [fact (0 < p')] [fact (p' ≤ p)] [normed_space' 𝕜 p V] :
  normed_space' 𝕜 p' (as_normed_space' p' V) :=
{ norm_smul := λ c v,
  begin
    have hp' : 0 < p'   := fact.out _,
    have hp  : 0 < p    := lt_of_lt_of_le hp' (fact.out _),
    rw [norm_def, norm_def, down_smul, normed_space'.norm_smul, real.mul_rpow, ← real.rpow_mul,
      mul_div_cancel' _ hp.ne'],
    { exact norm_nonneg _ },
    { exact real.rpow_nonneg_of_nonneg (norm_nonneg _) _ },
    { exact norm_nonneg _ },
  end }

end as_normed_space'

end obsolete


/-
Copyright (c) 2021 Martin Dvorak. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Martin Dvorak, Kyle Miller, Eric Wieser
-/

import data.matrix.notation
import linear_algebra.bilinear_map
import linear_algebra.matrix.determinant
import algebra.lie.basic

/-!
# Cross products

This module defines the cross product of vectors in $R^3$ for $R$ a commutative ring,
as a bilinear map.

## Main definitions

* `cross_product` is the cross product of pairs of vectors in $R^3$.

## Main results

* `triple_product_eq_det`
* `cross_dot_cross`
* `jacobi_cross`

## Notation

The locale `matrix` gives the following notation:

* `×₃` for the cross product

## Tags

crossproduct
-/

open matrix
open_locale matrix

variables {R : Type*} [comm_ring R]

/-- The cross product of two vectors in $R^3$ for $R$ a commutative ring. -/
def cross_product : (fin 3 → R) →ₗ[R] (fin 3 → R) →ₗ[R] (fin 3 → R) :=
begin
  apply linear_map.mk₂ R (λ (a b : fin 3 → R),
    ![a 1 * b 2 - a 2 * b 1,
      a 2 * b 0 - a 0 * b 2,
      a 0 * b 1 - a 1 * b 0]),
  { intros,
    simp [vec3_add (_ : R), add_comm, add_assoc, add_left_comm, add_mul, sub_eq_add_neg] },
  { intros,
    simp [smul_vec3 (_ : R) (_ : R), mul_comm, mul_assoc, mul_left_comm, mul_add, sub_eq_add_neg] },
  { intros,
    simp [vec3_add (_ : R), add_comm, add_assoc, add_left_comm, mul_add, sub_eq_add_neg] },
  { intros,
    simp [smul_vec3 (_ : R) (_ : R), mul_comm, mul_assoc, mul_left_comm, mul_add, sub_eq_add_neg] },
end

localized "infixl ` ×₃ `: 74 := cross_product" in matrix

lemma cross_apply (a b : fin 3 → R) :
  a ×₃ b = ![a 1 * b 2 - a 2 * b 1,
             a 2 * b 0 - a 0 * b 2,
             a 0 * b 1 - a 1 * b 0] :=
rfl

section products_properties

@[simp] lemma cross_anticomm (v w : fin 3 → R) :
  - (v ×₃ w) = w ×₃ v :=
by simp [cross_apply, mul_comm]
alias cross_anticomm ← neg_cross

@[simp] lemma cross_anticomm' (v w : fin 3 → R) :
  v ×₃ w + w ×₃ v = 0 :=
by rw [add_eq_zero_iff_eq_neg, cross_anticomm]

@[simp] lemma cross_self (v : fin 3 → R) :
  v ×₃ v = 0 :=
by simp [cross_apply, mul_comm]

/-- The cross product of two vectors is perpendicular to the first vector. -/
@[simp] lemma dot_self_cross (v w : fin 3 → R) :
  v ⬝ᵥ (v ×₃ w) = 0 :=
by simp [cross_apply, vec3_dot_product, mul_sub, mul_assoc, mul_left_comm]

/-- The cross product of two vectors is perpendicular to the second vector. -/
@[simp] lemma dot_cross_self (v w : fin 3 → R) :
  w ⬝ᵥ (v ×₃ w) = 0 :=
by rw [← cross_anticomm, matrix.dot_product_neg, dot_self_cross, neg_zero]

/-- Cyclic permutations preserve the triple product. See also `triple_product_eq_det`. -/
lemma triple_product_permutation (u v w : fin 3 → R) :
  u ⬝ᵥ (v ×₃ w) = v ⬝ᵥ (w ×₃ u) :=
begin
  simp only [cross_apply, vec3_dot_product,
    matrix.head_cons, matrix.cons_vec_bit0_eq_alt0, matrix.empty_append, matrix.cons_val_one,
    matrix.cons_vec_alt0, matrix.cons_append, matrix.cons_val_zero],
  ring,
end

/-- The triple product of `u`, `v`, and `w` is equal to the determinant of the matrix
    with those vectors as its rows. -/
theorem triple_product_eq_det (u v w : fin 3 → R) :
  u ⬝ᵥ (v ×₃ w) = matrix.det ![u, v, w] :=
begin
  simp only [vec3_dot_product, cross_apply, matrix.det_fin_three,
    matrix.head_cons, matrix.cons_vec_bit0_eq_alt0, matrix.empty_vec_alt0, matrix.cons_vec_alt0,
    matrix.vec_head_vec_alt0, fin.fin_append_apply_zero, matrix.empty_append, matrix.cons_append,
    matrix.cons_val', matrix.cons_val_one, matrix.cons_val_zero],
  ring,
end

/-- The scalar quadruple product identity, related to the Binet-Cauchy identity. -/
theorem cross_dot_cross (u v w x : fin 3 → R) :
  (u ×₃ v) ⬝ᵥ (w ×₃ x) = (u ⬝ᵥ w) * (v ⬝ᵥ x) - (u ⬝ᵥ x) * (v ⬝ᵥ w) :=
begin
  simp only [vec3_dot_product, cross_apply, cons_append, cons_vec_bit0_eq_alt0,
    cons_val_one, cons_vec_alt0, linear_map.mk₂_apply, cons_val_zero, head_cons, empty_append],
  ring_nf,
end

end products_properties

section leibniz_properties

/-- The cross product satisfies the Leibniz lie property. -/
lemma leibniz_cross (u v w : fin 3 → R) :
  u ×₃ (v ×₃ w) = (u ×₃ v) ×₃ w + v ×₃ (u ×₃ w) :=
begin
  dsimp only [cross_apply],
  ext i,
  fin_cases i; norm_num; ring,
end

/-- The three-dimensional vectors together with the operations + and ×₃ form a Lie ring.
    Note we do not make this an instance as a conflicting one already exists
    via `lie_ring.of_associative_ring`. -/
def cross.lie_ring : lie_ring (fin 3 → R) :=
{ bracket := λ u v, u ×₃ v,
  add_lie := linear_map.map_add₂ _,
  lie_add := λ u, linear_map.map_add _,
  lie_self := cross_self,
  leibniz_lie := leibniz_cross,
  ..pi.add_comm_group }

local attribute [instance] cross.lie_ring

lemma cross_cross (u v w : fin 3 → R) :
  (u ×₃ v) ×₃ w = u ×₃ (v ×₃ w) - v ×₃ (u ×₃ w) :=
lie_lie u v w

/-- Jacobi identity: For a cross product of three vectors,
    their sum over the three even permutations is equal to the zero vector. -/
theorem jacobi_cross (u v w : fin 3 → R) :
  u ×₃ (v ×₃ w) + v ×₃ (w ×₃ u) + w ×₃ (u ×₃ v) = 0 :=
lie_jacobi u v w

end leibniz_properties