/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Robert Y. Lewis
-/

import algebra.ring.ulift
import ring_theory.witt_vector.basic
import data.mv_polynomial.funext

/-!
# The `is_poly` predicate

`witt_vector.is_poly` is a (type-valued) predicate on functions `f : Π R, 𝕎 R → 𝕎 R`.
It asserts that there is a family of polynomials `φ : ℕ → mv_polynomial ℕ ℤ`,
such that the `n`th coefficient of `f x` is equal to `φ n` evaluated on the coefficients of `x`.
Many operations on Witt vectors satisfy this predicate (or an analogue for higher arity functions).
We say that such a function `f` is a *polynomial function*.

The power of satisfying this predicate comes from `is_poly.ext`.
It shows that if `φ` and `ψ` witness that `f` and `g` are polynomial functions,
then `f = g` not merely when `φ = ψ`, but in fact it suffices to prove
```
∀ n, bind₁ φ (witt_polynomial p _ n) = bind₁ ψ (witt_polynomial p _ n)
```
(in other words, when evaluating the Witt polynomials on `φ` and `ψ`, we get the same values)
which will then imply `φ = ψ` and hence `f = g`.

Even though this sufficient condition looks somewhat intimidating,
it is rather pleasant to check in practice;
more so than direct checking of `φ = ψ`.

In practice, we apply this technique to show that the composition of `witt_vector.frobenius`
and `witt_vector.verschiebung` is equal to multiplication by `p`.

## Main declarations

* `witt_vector.is_poly`, `witt_vector.is_poly₂`:
  two predicates that assert that a unary/binary function on Witt vectors
  is polynomial in the coefficients of the input values.
* `witt_vector.is_poly.ext`, `witt_vector.is_poly₂.ext`:
  two polynomial functions are equal if their families of polynomials are equal
  after evaluating the Witt polynmials on them.
* `witt_vector.is_poly.comp` (+ many variants) show that unary/binary compositions
  of polynomial functions are polynomial.
* `witt_vector.id_is_poly`, `witt_vector.neg_is_poly`,
  `witt_vector.add_is_poly₂`, `witt_vector.mul_is_poly₂`:
  several well-known operations are polynomial functions
  (for Verschiebung, Frobenius, and multiplication by `p`, see their respective files).

## On higher arity analogues

Ideally, there should be a predicate `is_polyₙ` for functions of higher arity,
together with `is_polyₙ.comp` that shows how such functions compose.
Since mathlib does not have a library on composition of higher arity functions,
we have only implemented the unary and binary variants so far.
Nullary functions (a.k.a. constants) are treated
as constant functions and fall under the unary case.

## Tactics

There are important metaprograms defined in this file:
the tactics `ghost_simp` and `ghost_calc` and the attributes `@[is_poly]` and `@[ghost_simps]`.
These are used in combination to discharge proofs of identities between polynomial functions.

Any atomic proof of `is_poly` or `is_poly₂` (i.e. not taking additional `is_poly` arguments)
should be tagged as `@[is_poly]`.

Any lemma doing "ring equation rewriting" with polynomial functions should be tagged
`@[ghost_simps]`, e.g.
```lean
@[ghost_simps]
lemma bind₁_frobenius_poly_witt_polynomial (n : ℕ) :
  bind₁ (frobenius_poly p) (witt_polynomial p ℤ n) = (witt_polynomial p ℤ (n+1))
```

Proofs of identities between polynomial functions will often follow the pattern
```lean
begin
  ghost_calc _,
  <minor preprocessing>,
  ghost_simp
end
```

## References

* [Hazewinkel, *Witt Vectors*][Haze09]

* [Commelin and Lewis, *Formalizing the Ring of Witt Vectors*][CL21]
-/

/-
### Simplification tactics

`ghost_simp` is used later in the development for certain simplifications.
We define it here so it is a shared import.
-/

mk_simp_attribute ghost_simps
"Simplification rules for ghost equations"

namespace tactic
namespace interactive
setup_tactic_parser

/-- A macro for a common simplification when rewriting with ghost component equations. -/
meta def ghost_simp (lems : parse simp_arg_list) : tactic unit :=
do tactic.try tactic.intro1,
   simp none none tt
     (lems ++ [simp_arg_type.symm_expr ``(sub_eq_add_neg)])
     [`ghost_simps] (loc.ns [none])

/--
`ghost_calc` is a tactic for proving identities between polynomial functions.
Typically, when faced with a goal like
```lean
∀ (x y : 𝕎 R), verschiebung (x * frobenius y) = verschiebung x * y
```
you can
1. call `ghost_calc`
2. do a small amount of manual work -- maybe nothing, maybe `rintro`, etc
3. call `ghost_simp`

and this will close the goal.

`ghost_calc` cannot detect whether you are dealing with unary or binary polynomial functions.
You must give it arguments to determine this.
If you are proving a universally quantified goal like the above,
call `ghost_calc _ _`.
If the variables are introduced already, call `ghost_calc x y`.
In the unary case, use `ghost_calc _` or `ghost_calc x`.

`ghost_calc` is a light wrapper around type class inference.
All it does is apply the appropriate extensionality lemma and try to infer the resulting goals.
This is subtle and Lean's elaborator doesn't like it because of the HO unification involved,
so it is easier (and prettier) to put it in a tactic script.
-/
meta def ghost_calc (ids' : parse ident_*) : tactic unit :=
do ids ← ids'.mmap $ λ n, get_local n <|> tactic.intro n,
   `(@eq (witt_vector _ %%R) _ _) ← target,
   match ids with
   | [x] := refine ```(is_poly.ext _ _ _ _ %%x)
   | [x, y] := refine ```(is_poly₂.ext _ _ _ _ %%x %%y)
   | _ := fail "ghost_calc takes one or two arguments"
   end,
   nm ← match R with
   | expr.local_const _ nm _ _ := return nm
   | _ := get_unused_name `R
   end,
   iterate_exactly 2 apply_instance,
   unfreezingI (tactic.clear' tt [R]),
   introsI $ [nm, nm<.>"_inst"] ++ ids',
   skip

end interactive

end tactic

namespace witt_vector
universe variable u

variables {p : ℕ} {R S : Type u} {σ idx : Type*} [hp : fact p.prime] [comm_ring R] [comm_ring S]

local notation `𝕎` := witt_vector p -- type as `\bbW`

open mv_polynomial
open function (uncurry)

include hp
variables (p)

noncomputable theory

/-!
### The `is_poly` predicate
-/

lemma poly_eq_of_witt_polynomial_bind_eq (f g : ℕ → mv_polynomial ℕ ℤ)
  (h : ∀ n, bind₁ f (witt_polynomial p _ n) = bind₁ g (witt_polynomial p _ n)) :
  f = g :=
begin
  ext1 n,
  apply mv_polynomial.map_injective (int.cast_ring_hom ℚ) int.cast_injective,
  rw ← function.funext_iff at h,
  replace h := congr_arg
    (λ fam, bind₁ (mv_polynomial.map (int.cast_ring_hom ℚ) ∘ fam)
    (X_in_terms_of_W p ℚ n)) h,
  simpa only [function.comp, map_bind₁, map_witt_polynomial,
    ← bind₁_bind₁, bind₁_witt_polynomial_X_in_terms_of_W, bind₁_X_right] using h
end

omit hp

-- Ideally, we would generalise this to n-ary functions
-- But we don't have a good theory of n-ary compositions in mathlib

/--
A function `f : Π R, 𝕎 R → 𝕎 R` that maps Witt vectors to Witt vectors over arbitrary base rings
is said to be *polynomial* if there is a family of polynomials `φₙ` over `ℤ` such that the `n`th
coefficient of `f x` is given by evaluating `φₙ` at the coefficients of `x`.

See also `witt_vector.is_poly₂` for the binary variant.

The `ghost_calc` tactic treats `is_poly` as a type class,
and the `@[is_poly]` attribute derives certain specialized composition instances
for declarations of type `is_poly f`.
For the most part, users are not expected to treat `is_poly` as a class.
-/
class is_poly (f : Π ⦃R⦄ [comm_ring R], witt_vector p R → 𝕎 R) : Prop :=
mk' :: (poly : ∃ φ : ℕ → mv_polynomial ℕ ℤ, ∀ ⦃R⦄ [comm_ring R] (x : 𝕎 R),
  by exactI (f x).coeff = λ n, aeval x.coeff (φ n))

/-- The identity function on Witt vectors is a polynomial function. -/
instance id_is_poly : is_poly p (λ _ _, id) :=
⟨⟨X, by { introsI, simp only [aeval_X, id] }⟩⟩

instance id_is_poly_i' : is_poly p (λ _ _ a, a) :=
witt_vector.id_is_poly _

namespace is_poly

instance : inhabited (is_poly p (λ _ _, id)) :=
⟨witt_vector.id_is_poly p⟩

variables {p}
include hp
lemma ext {f g} (hf : is_poly p f) (hg : is_poly p g)
  (h : ∀ (R : Type u) [_Rcr : comm_ring R] (x : 𝕎 R) (n : ℕ),
    by exactI ghost_component n (f x) = ghost_component n (g x)) :
  ∀ (R : Type u) [_Rcr : comm_ring R] (x : 𝕎 R), by exactI f x = g x :=
begin
  unfreezingI
  { obtain ⟨φ, hf⟩ := hf,
    obtain ⟨ψ, hg⟩ := hg },
  intros,
  ext n,
  rw [hf, hg, poly_eq_of_witt_polynomial_bind_eq p φ ψ],
  intro k,
  apply mv_polynomial.funext,
  intro x,
  simp only [hom_bind₁],
  specialize h (ulift ℤ) (mk p $ λ i, ⟨x i⟩) k,
  simp only [ghost_component_apply, aeval_eq_eval₂_hom] at h,
  apply (ulift.ring_equiv.{0 u}).symm.injective,
  simp only [map_eval₂_hom],
  convert h,
  all_goals {
    funext i,
    rw [← ring_equiv.coe_to_ring_hom],
    simp only [hf, hg, mv_polynomial.eval, map_eval₂_hom],
    apply eval₂_hom_congr (ring_hom.ext_int _ _) _ rfl,
    ext1,
    apply eval₂_hom_congr (ring_hom.ext_int _ _) _ rfl,
    simp only [coeff_mk], refl }
end

omit hp

/-- The composition of polynomial functions is polynomial. -/
lemma comp {g f} (hg : is_poly p g) (hf : is_poly p f) :
  is_poly p (λ R _Rcr, @g R _Rcr ∘ @f R _Rcr) :=
begin
  unfreezingI
  { obtain ⟨φ, hf⟩ := hf,
    obtain ⟨ψ, hg⟩ := hg },
  use (λ n, bind₁ φ (ψ n)),
  intros,
  simp only [aeval_bind₁, function.comp, hg, hf]
end

end is_poly

/--
A binary function `f : Π R, 𝕎 R → 𝕎 R → 𝕎 R` on Witt vectors
is said to be *polynomial* if there is a family of polynomials `φₙ` over `ℤ` such that the `n`th
coefficient of `f x y` is given by evaluating `φₙ` at the coefficients of `x` and `y`.

See also `witt_vector.is_poly` for the unary variant.

The `ghost_calc` tactic treats `is_poly₂` as a type class,
and the `@[is_poly]` attribute derives certain specialized composition instances
for declarations of type `is_poly₂ f`.
For the most part, users are not expected to treat `is_poly₂` as a class.
-/
class is_poly₂ (f : Π ⦃R⦄ [comm_ring R], witt_vector p R → 𝕎 R → 𝕎 R) : Prop :=
mk' :: (poly : ∃ φ : ℕ → mv_polynomial (fin 2 × ℕ) ℤ, ∀ ⦃R⦄ [comm_ring R] (x y : 𝕎 R),
  by exactI (f x y).coeff = λ n, peval (φ n) ![x.coeff, y.coeff])

variable {p}

/-- The composition of polynomial functions is polynomial. -/
lemma is_poly₂.comp {h f g} (hh : is_poly₂ p h) (hf : is_poly p f) (hg : is_poly p g) :
  is_poly₂ p (λ R _Rcr x y, by exactI h (f x) (g y)) :=
begin
  unfreezingI
  { obtain ⟨φ, hf⟩ := hf,
    obtain ⟨ψ, hg⟩ := hg,
    obtain ⟨χ, hh⟩ := hh },
  refine ⟨⟨(λ n, bind₁ (uncurry $
          ![λ k, rename (prod.mk (0 : fin 2)) (φ k),
            λ k, rename (prod.mk (1 : fin 2)) (ψ k)]) (χ n)), _⟩⟩,
  intros,
  funext n,
  simp only [peval, aeval_bind₁, function.comp, hh, hf, hg, uncurry],
  apply eval₂_hom_congr rfl _ rfl,
  ext ⟨i, n⟩,
  fin_cases i;
  simp only [aeval_eq_eval₂_hom, eval₂_hom_rename, function.comp, matrix.cons_val_zero,
    matrix.head_cons, matrix.cons_val_one],
end

/-- The composition of a polynomial function with a binary polynomial function is polynomial. -/
lemma is_poly.comp₂ {g f} (hg : is_poly p g) (hf : is_poly₂ p f) :
  is_poly₂ p (λ R _Rcr x y, by exactI g (f x y)) :=
begin
  unfreezingI
  { obtain ⟨φ, hf⟩ := hf,
    obtain ⟨ψ, hg⟩ := hg },
  use (λ n, bind₁ φ (ψ n)),
  intros,
  simp only [peval, aeval_bind₁, function.comp, hg, hf]
end

/-- The diagonal `λ x, f x x` of a polynomial function `f` is polynomial. -/
lemma is_poly₂.diag {f} (hf : is_poly₂ p f) :
  is_poly p (λ R _Rcr x, by exactI f x x) :=
begin
  unfreezingI {obtain ⟨φ, hf⟩ := hf},
  refine ⟨⟨λ n, bind₁ (uncurry ![X, X]) (φ n), _⟩⟩,
  intros, funext n,
  simp only [hf, peval, uncurry, aeval_bind₁],
  apply eval₂_hom_congr rfl _ rfl,
  ext ⟨i, k⟩, fin_cases i;
  simp only [matrix.head_cons, aeval_X, matrix.cons_val_zero, matrix.cons_val_one],
end

namespace tactic
open tactic

/-!
### The `@[is_poly]` attribute

This attribute is used to derive specialized composition instances
for `is_poly` and `is_poly₂` declarations.
-/

/--
If `n` is the name of a lemma with opened type `∀ vars, is_poly p _`,
`mk_poly_comp_lemmas n vars p` adds composition instances to the environment
`n.comp_i` and `n.comp₂_i`.
-/
meta def mk_poly_comp_lemmas (n : name) (vars : list expr) (p : expr) : tactic unit :=
do c ← mk_const n,
   let appd := vars.foldl expr.app c,

   tgt_bod ← to_expr ``(λ f [hf : is_poly %%p f], is_poly.comp %%appd hf) >>=
     replace_univ_metas_with_univ_params,
   tgt_bod ← lambdas vars tgt_bod,
   tgt_tp ← infer_type tgt_bod,
   let nm := n <.> "comp_i",
   add_decl $ mk_definition nm tgt_tp.collect_univ_params tgt_tp tgt_bod,
   set_attribute `instance nm,

   tgt_bod ← to_expr ``(λ f [hf : is_poly₂ %%p f], is_poly.comp₂ %%appd hf) >>=
     replace_univ_metas_with_univ_params,
   tgt_bod ← lambdas vars tgt_bod,
   tgt_tp ← infer_type tgt_bod,
   let nm := n <.> "comp₂_i",
   add_decl $ mk_definition nm tgt_tp.collect_univ_params tgt_tp tgt_bod,
   set_attribute `instance nm

/--
If `n` is the name of a lemma with opened type `∀ vars, is_poly₂ p _`,
`mk_poly₂_comp_lemmas n vars p` adds composition instances to the environment
`n.comp₂_i` and `n.comp_diag`.
-/
meta def mk_poly₂_comp_lemmas (n : name) (vars : list expr) (p : expr) : tactic unit :=
do c ← mk_const n,
   let appd := vars.foldl expr.app c,

   tgt_bod ← to_expr ``(λ {f g} [hf : is_poly %%p f] [hg : is_poly %%p g],
     is_poly₂.comp %%appd hf hg) >>= replace_univ_metas_with_univ_params,
   tgt_bod ← lambdas vars tgt_bod,
   tgt_tp ← infer_type tgt_bod >>= simp_lemmas.mk.dsimplify,
   let nm := n <.> "comp₂_i",
   add_decl $ mk_definition nm tgt_tp.collect_univ_params tgt_tp tgt_bod,
   set_attribute `instance nm,

   tgt_bod ← to_expr ``(λ {f g} [hf : is_poly %%p f] [hg : is_poly %%p g],
     (is_poly₂.comp %%appd hf hg).diag) >>= replace_univ_metas_with_univ_params,
   tgt_bod ← lambdas vars tgt_bod,
   tgt_tp ← infer_type tgt_bod >>= simp_lemmas.mk.dsimplify,
   let nm := n <.> "comp_diag",
   add_decl $ mk_definition nm tgt_tp.collect_univ_params tgt_tp tgt_bod,
   set_attribute `instance nm

/--
The `after_set` function for `@[is_poly]`. Calls `mk_poly(₂)_comp_lemmas`.
-/
meta def mk_comp_lemmas (n : name) : tactic unit :=
do d ← get_decl n,
   (vars, tp) ← open_pis d.type,
   match tp with
   | `(is_poly %%p _) := mk_poly_comp_lemmas n vars p
   | `(is_poly₂ %%p _) := mk_poly₂_comp_lemmas n vars p
   | _ := fail "@[is_poly] should only be applied to terms of type `is_poly _ _` or `is_poly₂ _ _`"
   end

/--
`@[is_poly]` is applied to lemmas of the form `is_poly f φ` or `is_poly₂ f φ`.
These lemmas should *not* be tagged as instances, and only atomic `is_poly` defs should be tagged:
composition lemmas should not. Roughly speaking, lemmas that take `is_poly` proofs as arguments
should not be tagged.

Type class inference struggles with function composition, and the higher order unification problems
involved in inferring `is_poly` proofs are complex. The standard style writing these proofs by hand
doesn't work very well. Instead, we construct the type class hierarchy "under the hood", with
limited forms of composition.

Applying `@[is_poly]` to a lemma creates a number of instances. Roughly, if the tagged lemma is a
proof of `is_poly f φ`, the instances added have the form
```lean
∀ g ψ, [is_poly g ψ] → is_poly (f ∘ g) _
```
Since `f` is fixed in this instance, it restricts the HO unification needed when the instance is
applied. Composition lemmas relating `is_poly` with `is_poly₂` are also added.
`id_is_poly` is an atomic instance.

The user-written lemmas are not instances. Users should be able to assemble `is_poly` proofs by hand
"as normal" if the tactic fails.
-/
@[user_attribute] meta def is_poly_attr : user_attribute :=
{ name := `is_poly,
  descr := "Lemmas with this attribute describe the polynomial structure of functions",
  after_set := some $ λ n _ _, mk_comp_lemmas n }

end tactic

include hp

/-!
### `is_poly` instances

These are not declared as instances at the top level,
but the `@[is_poly]` attribute adds instances based on each one.
Users are expected to use the non-instance versions manually.
-/

/-- The additive negation is a polynomial function on Witt vectors. -/
@[is_poly]
lemma neg_is_poly : is_poly p (λ R _, by exactI @has_neg.neg (𝕎 R) _) :=
⟨⟨λ n, rename prod.snd (witt_neg p n),
begin
  introsI, funext n,
  rw [neg_coeff, aeval_eq_eval₂_hom, eval₂_hom_rename],
  apply eval₂_hom_congr rfl _ rfl,
  ext ⟨i, k⟩, fin_cases i, refl,
end⟩⟩

section zero_one
/- To avoid a theory of 0-ary functions (a.k.a. constants)
we model them as constant unary functions. -/

/-- The function that is constantly zero on Witt vectors is a polynomial function. -/
instance zero_is_poly : is_poly p (λ _ _ _, by exactI 0) :=
⟨⟨0, by { introsI, funext n, simp only [pi.zero_apply, alg_hom.map_zero, zero_coeff] }⟩⟩

@[simp] lemma bind₁_zero_witt_polynomial (n : ℕ) :
  bind₁ (0 : ℕ → mv_polynomial ℕ R) (witt_polynomial p R n) = 0 :=
by rw [← aeval_eq_bind₁, aeval_zero, constant_coeff_witt_polynomial, ring_hom.map_zero]

omit hp

/-- The coefficients of `1 : 𝕎 R` as polynomials. -/
def one_poly (n : ℕ) : mv_polynomial ℕ ℤ := if n = 0 then 1 else 0

include hp

@[simp] lemma bind₁_one_poly_witt_polynomial (n : ℕ) :
  bind₁ one_poly (witt_polynomial p ℤ n) = 1 :=
begin
  rw [witt_polynomial_eq_sum_C_mul_X_pow, alg_hom.map_sum, finset.sum_eq_single 0],
  { simp only [one_poly, one_pow, one_mul, alg_hom.map_pow, C_1, pow_zero, bind₁_X_right,
      if_true, eq_self_iff_true], },
  { intros i hi hi0,
    simp only [one_poly, if_neg hi0, zero_pow (pow_pos hp.1.pos _), mul_zero,
      alg_hom.map_pow, bind₁_X_right, alg_hom.map_mul], },
  { rw finset.mem_range, dec_trivial }
end

/-- The function that is constantly one on Witt vectors is a polynomial function. -/
instance one_is_poly : is_poly p (λ _ _ _, by exactI 1) :=
⟨⟨one_poly,
begin
  introsI, funext n, cases n,
  { simp only [one_poly, if_true, eq_self_iff_true, one_coeff_zero, alg_hom.map_one], },
  { simp only [one_poly, nat.succ_pos', one_coeff_eq_of_pos,
      if_neg n.succ_ne_zero, alg_hom.map_zero] }
end⟩⟩

end zero_one

omit hp

/-- Addition of Witt vectors is a polynomial function. -/
@[is_poly] lemma add_is_poly₂ [fact p.prime] : is_poly₂ p (λ _ _, by exactI (+)) :=
⟨⟨witt_add p, by { introsI, dunfold witt_vector.has_add, simp [eval] }⟩⟩

/-- Multiplication of Witt vectors is a polynomial function. -/
@[is_poly] lemma mul_is_poly₂ [fact p.prime] : is_poly₂ p (λ _ _, by exactI (*)) :=
⟨⟨witt_mul p, by { introsI, dunfold witt_vector.has_mul, simp [eval] }⟩⟩

include hp

-- unfortunately this is not universe polymorphic, merely because `f` isn't
lemma is_poly.map {f} (hf : is_poly p f) (g : R →+* S) (x : 𝕎 R) :
  map g (f x) = f (map g x) :=
begin
  -- this could be turned into a tactic “macro” (taking `hf` as parameter)
  -- so that applications do not have to worry about the universe issue
  -- see `is_poly₂.map` for a slightly more general proof strategy
  unfreezingI {obtain ⟨φ, hf⟩ := hf},
  ext n,
  simp only [map_coeff, hf, map_aeval],
  apply eval₂_hom_congr (ring_hom.ext_int _ _) _ rfl,
  simp only [map_coeff]
end

namespace is_poly₂
omit hp
instance [fact p.prime] : inhabited (is_poly₂ p _) := ⟨add_is_poly₂⟩

variables {p}

/-- The composition of a binary polynomial function
 with a unary polynomial function in the first argument is polynomial. -/
lemma comp_left {g f} (hg : is_poly₂ p g) (hf : is_poly p f) :
  is_poly₂ p (λ R _Rcr x y, by exactI g (f x) y) :=
hg.comp hf (witt_vector.id_is_poly _)

/-- The composition of a binary polynomial function
 with a unary polynomial function in the second argument is polynomial. -/
lemma comp_right {g f} (hg : is_poly₂ p g) (hf : is_poly p f) :
  is_poly₂ p (λ R _Rcr x y, by exactI g x (f y)) :=
hg.comp (witt_vector.id_is_poly p) hf

include hp

lemma ext {f g} (hf : is_poly₂ p f) (hg : is_poly₂ p g)
  (h : ∀ (R : Type u) [_Rcr : comm_ring R] (x y : 𝕎 R) (n : ℕ),
    by exactI ghost_component n (f x y) = ghost_component n (g x y)) :
  ∀ (R) [_Rcr : comm_ring R] (x y : 𝕎 R), by exactI f x y = g x y :=
begin
  unfreezingI
  { obtain ⟨φ, hf⟩ := hf,
    obtain ⟨ψ, hg⟩ := hg },
  intros,
  ext n,
  rw [hf, hg, poly_eq_of_witt_polynomial_bind_eq' p φ ψ],
  clear x y,
  intro k,
  apply mv_polynomial.funext,
  intro x,
  simp only [hom_bind₁],
  specialize h (ulift ℤ) (mk p $ λ i, ⟨x (0, i)⟩) (mk p $ λ i, ⟨x (1, i)⟩) k,
  simp only [ghost_component_apply, aeval_eq_eval₂_hom] at h,
  apply (ulift.ring_equiv.{0 u}).symm.injective,
  simp only [map_eval₂_hom],
  convert h; clear h,
  all_goals {
    funext i,
    rw [← ring_equiv.coe_to_ring_hom],
    simp only [hf, hg, mv_polynomial.eval, map_eval₂_hom],
    apply eval₂_hom_congr (ring_hom.ext_int _ _) _ rfl,
    ext1,
    apply eval₂_hom_congr (ring_hom.ext_int _ _) _ rfl,
    ext ⟨b, _⟩,
    fin_cases b; simp only [coeff_mk, uncurry]; refl }
end

-- unfortunately this is not universe polymorphic, merely because `f` isn't
lemma map {f} (hf : is_poly₂ p f) (g : R →+* S) (x y : 𝕎 R) :
  map g (f x y) = f (map g x) (map g y) :=
begin
  -- this could be turned into a tactic “macro” (taking `hf` as parameter)
  -- so that applications do not have to worry about the universe issue
  unfreezingI {obtain ⟨φ, hf⟩ := hf},
  ext n,
  simp only [map_coeff, hf, map_aeval, peval, uncurry],
  apply eval₂_hom_congr (ring_hom.ext_int _ _) _ rfl,
  try { ext ⟨i, k⟩, fin_cases i },
  all_goals {
    simp only [map_coeff, matrix.cons_val_zero, matrix.head_cons, matrix.cons_val_one] },
end

end is_poly₂

attribute [ghost_simps]
      alg_hom.map_zero alg_hom.map_one alg_hom.map_add alg_hom.map_mul
      alg_hom.map_sub alg_hom.map_neg alg_hom.id_apply alg_hom.map_nat_cast
      ring_hom.map_zero ring_hom.map_one ring_hom.map_mul ring_hom.map_add
      ring_hom.map_sub ring_hom.map_neg ring_hom.id_apply ring_hom.map_nat_cast
      mul_add add_mul add_zero zero_add mul_one one_mul mul_zero zero_mul
      nat.succ_ne_zero nat.add_sub_cancel nat.succ_eq_add_one
      if_true eq_self_iff_true if_false forall_true_iff forall_2_true_iff forall_3_true_iff

end witt_vector


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

! This file was ported from Lean 3 source module data.nat.with_bot
! leanprover-community/mathlib commit 12665d3612d46b1838ec1273d291c21a61fc1707
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Nat.Order.Basic
import Mathbin.Algebra.Order.Monoid.WithTop

/-!
# `with_bot ℕ`

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

Lemmas about the type of natural numbers with a bottom element adjoined.
-/

namespace Nat

namespace WithBot

#print Nat.WithBot.add_eq_zero_iff /-
theorem add_eq_zero_iff {n m : WithBot ℕ} : n + m = 0 ↔ n = 0 ∧ m = 0 :=
  by
  rcases n, m with ⟨_ | _, _ | _⟩
  any_goals tauto
  repeat' erw [WithBot.coe_eq_coe]
  exact add_eq_zero_iff
#align nat.with_bot.add_eq_zero_iff Nat.WithBot.add_eq_zero_iff
-/

#print Nat.WithBot.add_eq_one_iff /-
theorem add_eq_one_iff {n m : WithBot ℕ} : n + m = 1 ↔ n = 0 ∧ m = 1 ∨ n = 1 ∧ m = 0 :=
  by
  rcases n, m with ⟨_ | _, _ | _⟩
  any_goals tauto
  repeat' erw [WithBot.coe_eq_coe]
  exact add_eq_one_iff
#align nat.with_bot.add_eq_one_iff Nat.WithBot.add_eq_one_iff
-/

#print Nat.WithBot.add_eq_two_iff /-
theorem add_eq_two_iff {n m : WithBot ℕ} :
    n + m = 2 ↔ n = 0 ∧ m = 2 ∨ n = 1 ∧ m = 1 ∨ n = 2 ∧ m = 0 :=
  by
  rcases n, m with ⟨_ | _, _ | _⟩
  any_goals tauto
  repeat' erw [WithBot.coe_eq_coe]
  exact add_eq_two_iff
#align nat.with_bot.add_eq_two_iff Nat.WithBot.add_eq_two_iff
-/

#print Nat.WithBot.add_eq_three_iff /-
theorem add_eq_three_iff {n m : WithBot ℕ} :
    n + m = 3 ↔ n = 0 ∧ m = 3 ∨ n = 1 ∧ m = 2 ∨ n = 2 ∧ m = 1 ∨ n = 3 ∧ m = 0 :=
  by
  rcases n, m with ⟨_ | _, _ | _⟩
  any_goals tauto
  repeat' erw [WithBot.coe_eq_coe]
  exact add_eq_three_iff
#align nat.with_bot.add_eq_three_iff Nat.WithBot.add_eq_three_iff
-/

#print Nat.WithBot.coe_nonneg /-
theorem coe_nonneg {n : ℕ} : 0 ≤ (n : WithBot ℕ) :=
  by
  rw [← WithBot.coe_zero, WithBot.coe_le_coe]
  exact Nat.zero_le _
#align nat.with_bot.coe_nonneg Nat.WithBot.coe_nonneg
-/

#print Nat.WithBot.lt_zero_iff /-
@[simp]
theorem lt_zero_iff (n : WithBot ℕ) : n < 0 ↔ n = ⊥ :=
  Option.casesOn n (by decide) fun n =>
    iff_of_false (by simp [WithBot.some_eq_coe, coe_nonneg]) fun h => Option.noConfusion h
#align nat.with_bot.lt_zero_iff Nat.WithBot.lt_zero_iff
-/

#print Nat.WithBot.one_le_iff_zero_lt /-
theorem one_le_iff_zero_lt {x : WithBot ℕ} : 1 ≤ x ↔ 0 < x :=
  by
  refine' ⟨fun h => lt_of_lt_of_le (with_bot.coe_lt_coe.mpr zero_lt_one) h, fun h => _⟩
  induction x using WithBot.recBotCoe
  · exact (not_lt_bot h).elim
  · exact with_bot.coe_le_coe.mpr (nat.succ_le_iff.mpr (with_bot.coe_lt_coe.mp h))
#align nat.with_bot.one_le_iff_zero_lt Nat.WithBot.one_le_iff_zero_lt
-/

#print Nat.WithBot.lt_one_iff_le_zero /-
theorem lt_one_iff_le_zero {x : WithBot ℕ} : x < 1 ↔ x ≤ 0 :=
  not_iff_not.mp (by simpa using one_le_iff_zero_lt)
#align nat.with_bot.lt_one_iff_le_zero Nat.WithBot.lt_one_iff_le_zero
-/

#print Nat.WithBot.add_one_le_of_lt /-
theorem add_one_le_of_lt {n m : WithBot ℕ} (h : n < m) : n + 1 ≤ m :=
  by
  cases n; · exact bot_le
  cases m; exacts[(not_lt_bot h).elim, WithBot.some_le_some.2 (WithBot.some_lt_some.1 h)]
#align nat.with_bot.add_one_le_of_lt Nat.WithBot.add_one_le_of_lt
-/

end WithBot

end Nat


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.Module.basic
import category_theory.linear.basic
import category_theory.preadditive.yoneda.basic

/-!
# The Yoneda embedding for `R`-linear categories

The Yoneda embedding for `R`-linear categories `C`,
sends an object `X : C` to the `Module R`-valued presheaf on `C`,
with value on `Y : Cᵒᵖ` given by `Module.of R (unop Y ⟶ X)`.

TODO: `linear_yoneda R C` is `R`-linear.
TODO: In fact, `linear_yoneda` itself is additive and `R`-linear.
-/

universes w v u

open opposite

namespace category_theory

variables (R : Type w) [ring R] (C : Type u) [category.{v} C] [preadditive C] [linear R C]

/-- The Yoneda embedding for `R`-linear categories `C`,
sending an object `X : C` to the `Module R`-valued presheaf on `C`,
with value on `Y : Cᵒᵖ` given by `Module.of R (unop Y ⟶ X)`. -/
@[simps]
def linear_yoneda : C ⥤ Cᵒᵖ ⥤ Module R :=
{ obj := λ X,
  { obj := λ Y, Module.of R (unop Y ⟶ X),
    map := λ Y Y' f, linear.left_comp R _ f.unop,
    map_comp' := λ _ _ _ f g, linear_map.ext $ λ _, category.assoc _ _ _,
    map_id' := λ Y, linear_map.ext $ λ _, category.id_comp _ },
  map := λ X X' f,
  { app := λ Y, linear.right_comp R _ f,
    naturality' := λ X Y f, linear_map.ext $ λ x, by simp only [category.assoc, Module.coe_comp,
      function.comp_app, linear.left_comp_apply, linear.right_comp_apply] },
  map_id' := λ X, nat_trans.ext _ _ $ funext $ λ _, linear_map.ext $ λ _,
    by simp only [linear.right_comp_apply, category.comp_id, nat_trans.id_app, Module.id_apply],
  map_comp' := λ _ _ _ f g, nat_trans.ext _ _ $ funext $ λ _, linear_map.ext $ λ _,
    by simp only [category.assoc, linear.right_comp_apply, nat_trans.comp_app, Module.coe_comp,
      function.comp_app] }

/-- The Yoneda embedding for `R`-linear categories `C`,
sending an object `Y : Cᵒᵖ` to the `Module R`-valued copresheaf on `C`,
with value on `X : C` given by `Module.of R (unop Y ⟶ X)`. -/
@[simps]
def linear_coyoneda : Cᵒᵖ ⥤ C ⥤ Module R :=
{ obj := λ Y,
  { obj := λ X, Module.of R (unop Y ⟶ X),
    map := λ Y Y', linear.right_comp _ _,
    map_id' := λ Y, linear_map.ext $ λ _, category.comp_id _,
    map_comp' := λ _ _ _ f g, linear_map.ext $ λ _, eq.symm (category.assoc _ _ _) },
  map := λ Y Y' f,
  { app := λ X, linear.left_comp _ _ f.unop,
    naturality' := λ X Y f, linear_map.ext $ λ x, by simp only [category.assoc, Module.coe_comp,
      function.comp_app, linear.right_comp_apply, linear.left_comp_apply] },
  map_id' := λ X, nat_trans.ext _ _ $ funext $ λ _, linear_map.ext $ λ _,
    by simp only [linear.left_comp_apply, unop_id, category.id_comp, nat_trans.id_app,
      Module.id_apply],
  map_comp' := λ _ _ _ f g, nat_trans.ext _ _ $ funext $ λ _, linear_map.ext $ λ _,
    by simp only [category.assoc, Module.coe_comp, function.comp_app, linear.left_comp_apply,
      unop_comp, nat_trans.comp_app]}

instance linear_yoneda_obj_additive (X : C) : ((linear_yoneda R C).obj X).additive := {}
instance linear_coyoneda_obj_additive (Y : Cᵒᵖ) : ((linear_coyoneda R C).obj Y).additive := {}

@[simp] lemma whiskering_linear_yoneda : linear_yoneda R C ⋙
  (whiskering_right _ _ _).obj (forget (Module.{v} R)) = yoneda :=
rfl

@[simp] lemma whiskering_linear_yoneda₂ : linear_yoneda R C ⋙
  (whiskering_right _ _ _).obj (forget₂ (Module.{v} R) AddCommGroup.{v}) = preadditive_yoneda :=
rfl

@[simp] lemma whiskering_linear_coyoneda : linear_coyoneda R C ⋙
  (whiskering_right _ _ _).obj (forget (Module.{v} R)) = coyoneda :=
rfl

@[simp] lemma whiskering_linear_coyoneda₂ : linear_coyoneda R C ⋙
  (whiskering_right _ _ _).obj (forget₂ (Module.{v} R) AddCommGroup.{v}) = preadditive_coyoneda :=
rfl

instance linear_yoneda_full : full (linear_yoneda R C) :=
let yoneda_full : full (linear_yoneda R C ⋙
  (whiskering_right _ _ _).obj (forget (Module.{v} R))) := yoneda.yoneda_full in
by exactI full.of_comp_faithful (linear_yoneda R C)
  (((whiskering_right _ _ _)).obj (forget (Module.{v} R)))

instance linear_coyoneda_full : full (linear_coyoneda R C) :=
let coyoneda_full : full (linear_coyoneda R C ⋙
  (whiskering_right _ _ _).obj (forget (Module.{v} R))) := coyoneda.coyoneda_full in
by exactI full.of_comp_faithful (linear_coyoneda R C)
  (((whiskering_right _ _ _)).obj (forget (Module.{v} R)))

instance linear_yoneda_faithful : faithful (linear_yoneda R C) :=
faithful.of_comp_eq (whiskering_linear_yoneda R C)

instance linear_coyoneda_faithful : faithful (linear_coyoneda R C) :=
faithful.of_comp_eq (whiskering_linear_coyoneda R C)

end category_theory


/-
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

! This file was ported from Lean 3 source module analysis.convex.gauge
! leanprover-community/mathlib commit 468b141b14016d54b479eb7a0fff1e360b7e3cf6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Convex.Basic
import Mathbin.Analysis.NormedSpace.Pointwise
import Mathbin.Analysis.Seminorm
import Mathbin.Data.IsROrC.Basic
import Mathbin.Tactic.Congrm

/-!
# The Minkowksi functional

This file defines the Minkowski functional, aka gauge.

The Minkowski functional of a set `s` is the function which associates each point to how much you
need to scale `s` for `x` to be inside it. When `s` is symmetric, convex and absorbent, its gauge is
a seminorm. Reciprocally, any seminorm arises as the gauge of some set, namely its unit ball. This
induces the equivalence of seminorms and locally convex topological vector spaces.

## Main declarations

For a real vector space,
* `gauge`: Aka Minkowksi functional. `gauge s x` is the least (actually, an infimum) `r` such
  that `x ∈ r • s`.
* `gauge_seminorm`: The Minkowski functional as a seminorm, when `s` is symmetric, convex and
  absorbent.

## References

* [H. H. Schaefer, *Topological Vector Spaces*][schaefer1966]

## Tags

Minkowski functional, gauge
-/

open NormedField Set

open Pointwise

noncomputable section

variable {𝕜 E F : Type _}

section AddCommGroup

variable [AddCommGroup E] [Module ℝ E]

/-- The Minkowski functional. Given a set `s` in a real vector space, `gauge s` is the functional
which sends `x : E` to the smallest `r : ℝ` such that `x` is in `s` scaled by `r`. -/
def gauge (s : Set E) (x : E) : ℝ :=
  infₛ { r : ℝ | 0 < r ∧ x ∈ r • s }
#align gauge gauge

variable {s t : Set E} {a : ℝ} {x : E}

theorem gauge_def : gauge s x = infₛ ({ r ∈ Set.Ioi 0 | x ∈ r • s }) :=
  rfl
#align gauge_def gauge_def

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:73:14: unsupported tactic `congrm #[[expr Inf (λ r, _)]] -/
/-- An alternative definition of the gauge using scalar multiplication on the element rather than on
the set. -/
theorem gauge_def' : gauge s x = infₛ ({ r ∈ Set.Ioi 0 | r⁻¹ • x ∈ s }) :=
  by
  trace
    "./././Mathport/Syntax/Translate/Tactic/Builtin.lean:73:14: unsupported tactic `congrm #[[expr Inf (λ r, _)]]"
  exact and_congr_right fun hr => mem_smul_set_iff_inv_smul_mem₀ hr.ne' _ _
#align gauge_def' gauge_def'

private theorem gauge_set_bdd_below : BddBelow { r : ℝ | 0 < r ∧ x ∈ r • s } :=
  ⟨0, fun r hr => hr.1.le⟩
#align gauge_set_bdd_below gauge_set_bdd_below

/-- If the given subset is `absorbent` then the set we take an infimum over in `gauge` is nonempty,
which is useful for proving many properties about the gauge.  -/
theorem Absorbent.gauge_set_nonempty (absorbs : Absorbent ℝ s) :
    { r : ℝ | 0 < r ∧ x ∈ r • s }.Nonempty :=
  let ⟨r, hr₁, hr₂⟩ := Absorbs x
  ⟨r, hr₁, hr₂ r (Real.norm_of_nonneg hr₁.le).ge⟩
#align absorbent.gauge_set_nonempty Absorbent.gauge_set_nonempty

theorem gauge_mono (hs : Absorbent ℝ s) (h : s ⊆ t) : gauge t ≤ gauge s := fun x =>
  cinfₛ_le_cinfₛ gauge_set_bddBelow hs.gauge_set_nonempty fun r hr => ⟨hr.1, smul_set_mono h hr.2⟩
#align gauge_mono gauge_mono

theorem exists_lt_of_gauge_lt (absorbs : Absorbent ℝ s) (h : gauge s x < a) :
    ∃ b, 0 < b ∧ b < a ∧ x ∈ b • s :=
  by
  obtain ⟨b, ⟨hb, hx⟩, hba⟩ := exists_lt_of_cinfₛ_lt absorbs.gauge_set_nonempty h
  exact ⟨b, hb, hba, hx⟩
#align exists_lt_of_gauge_lt exists_lt_of_gauge_lt

/-- The gauge evaluated at `0` is always zero (mathematically this requires `0` to be in the set `s`
but, the real infimum of the empty set in Lean being defined as `0`, it holds unconditionally). -/
@[simp]
theorem gauge_zero : gauge s 0 = 0 := by
  rw [gauge_def']
  by_cases (0 : E) ∈ s
  · simp only [smul_zero, sep_true, h, cinfₛ_Ioi]
  · simp only [smul_zero, sep_false, h, Real.infₛ_empty]
#align gauge_zero gauge_zero

@[simp]
theorem gauge_zero' : gauge (0 : Set E) = 0 := by
  ext
  rw [gauge_def']
  obtain rfl | hx := eq_or_ne x 0
  · simp only [cinfₛ_Ioi, mem_zero, Pi.zero_apply, eq_self_iff_true, sep_true, smul_zero]
  · simp only [mem_zero, Pi.zero_apply, inv_eq_zero, smul_eq_zero]
    convert Real.infₛ_empty
    exact eq_empty_iff_forall_not_mem.2 fun r hr => hr.2.elim (ne_of_gt hr.1) hx
#align gauge_zero' gauge_zero'

@[simp]
theorem gauge_empty : gauge (∅ : Set E) = 0 := by
  ext
  simp only [gauge_def', Real.infₛ_empty, mem_empty_iff_false, Pi.zero_apply, sep_false]
#align gauge_empty gauge_empty

theorem gauge_of_subset_zero (h : s ⊆ 0) : gauge s = 0 :=
  by
  obtain rfl | rfl := subset_singleton_iff_eq.1 h
  exacts[gauge_empty, gauge_zero']
#align gauge_of_subset_zero gauge_of_subset_zero

/-- The gauge is always nonnegative. -/
theorem gauge_nonneg (x : E) : 0 ≤ gauge s x :=
  Real.infₛ_nonneg _ fun x hx => hx.1.le
#align gauge_nonneg gauge_nonneg

theorem gauge_neg (symmetric : ∀ x ∈ s, -x ∈ s) (x : E) : gauge s (-x) = gauge s x :=
  by
  have : ∀ x, -x ∈ s ↔ x ∈ s := fun x => ⟨fun h => by simpa using Symmetric _ h, Symmetric x⟩
  simp_rw [gauge_def', smul_neg, this]
#align gauge_neg gauge_neg

theorem gauge_neg_set_neg (x : E) : gauge (-s) (-x) = gauge s x := by
  simp_rw [gauge_def', smul_neg, neg_mem_neg]
#align gauge_neg_set_neg gauge_neg_set_neg

theorem gauge_neg_set_eq_gauge_neg (x : E) : gauge (-s) x = gauge s (-x) := by
  rw [← gauge_neg_set_neg, neg_neg]
#align gauge_neg_set_eq_gauge_neg gauge_neg_set_eq_gauge_neg

theorem gauge_le_of_mem (ha : 0 ≤ a) (hx : x ∈ a • s) : gauge s x ≤ a :=
  by
  obtain rfl | ha' := ha.eq_or_lt
  · rw [mem_singleton_iff.1 (zero_smul_set_subset _ hx), gauge_zero]
  · exact cinfₛ_le gauge_set_bdd_below ⟨ha', hx⟩
#align gauge_le_of_mem gauge_le_of_mem

theorem gauge_le_eq (hs₁ : Convex ℝ s) (hs₀ : (0 : E) ∈ s) (hs₂ : Absorbent ℝ s) (ha : 0 ≤ a) :
    { x | gauge s x ≤ a } = ⋂ (r : ℝ) (H : a < r), r • s :=
  by
  ext
  simp_rw [Set.mem_interᵢ, Set.mem_setOf_eq]
  refine' ⟨fun h r hr => _, fun h => le_of_forall_pos_lt_add fun ε hε => _⟩
  · have hr' := ha.trans_lt hr
    rw [mem_smul_set_iff_inv_smul_mem₀ hr'.ne']
    obtain ⟨δ, δ_pos, hδr, hδ⟩ := exists_lt_of_gauge_lt hs₂ (h.trans_lt hr)
    suffices (r⁻¹ * δ) • δ⁻¹ • x ∈ s by rwa [smul_smul, mul_inv_cancel_right₀ δ_pos.ne'] at this
    rw [mem_smul_set_iff_inv_smul_mem₀ δ_pos.ne'] at hδ
    refine' hs₁.smul_mem_of_zero_mem hs₀ hδ ⟨by positivity, _⟩
    rw [inv_mul_le_iff hr', mul_one]
    exact hδr.le
  · have hε' := (lt_add_iff_pos_right a).2 (half_pos hε)
    exact
      (gauge_le_of_mem (ha.trans hε'.le) <| h _ hε').trans_lt (add_lt_add_left (half_lt_self hε) _)
#align gauge_le_eq gauge_le_eq

theorem gauge_lt_eq' (absorbs : Absorbent ℝ s) (a : ℝ) :
    { x | gauge s x < a } = ⋃ (r : ℝ) (H : 0 < r) (H : r < a), r • s :=
  by
  ext
  simp_rw [mem_set_of_eq, mem_Union, exists_prop]
  exact
    ⟨exists_lt_of_gauge_lt Absorbs, fun ⟨r, hr₀, hr₁, hx⟩ =>
      (gauge_le_of_mem hr₀.le hx).trans_lt hr₁⟩
#align gauge_lt_eq' gauge_lt_eq'

theorem gauge_lt_eq (absorbs : Absorbent ℝ s) (a : ℝ) :
    { x | gauge s x < a } = ⋃ r ∈ Set.Ioo 0 (a : ℝ), r • s :=
  by
  ext
  simp_rw [mem_set_of_eq, mem_Union, exists_prop, mem_Ioo, and_assoc']
  exact
    ⟨exists_lt_of_gauge_lt Absorbs, fun ⟨r, hr₀, hr₁, hx⟩ =>
      (gauge_le_of_mem hr₀.le hx).trans_lt hr₁⟩
#align gauge_lt_eq gauge_lt_eq

theorem gauge_lt_one_subset_self (hs : Convex ℝ s) (h₀ : (0 : E) ∈ s) (absorbs : Absorbent ℝ s) :
    { x | gauge s x < 1 } ⊆ s := by
  rw [gauge_lt_eq Absorbs]
  refine' Set.unionᵢ₂_subset fun r hr _ => _
  rintro ⟨y, hy, rfl⟩
  exact hs.smul_mem_of_zero_mem h₀ hy (Ioo_subset_Icc_self hr)
#align gauge_lt_one_subset_self gauge_lt_one_subset_self

theorem gauge_le_one_of_mem {x : E} (hx : x ∈ s) : gauge s x ≤ 1 :=
  gauge_le_of_mem zero_le_one <| by rwa [one_smul]
#align gauge_le_one_of_mem gauge_le_one_of_mem

theorem self_subset_gauge_le_one : s ⊆ { x | gauge s x ≤ 1 } := fun x => gauge_le_one_of_mem
#align self_subset_gauge_le_one self_subset_gauge_le_one

theorem Convex.gauge_le (hs : Convex ℝ s) (h₀ : (0 : E) ∈ s) (absorbs : Absorbent ℝ s) (a : ℝ) :
    Convex ℝ { x | gauge s x ≤ a } := by
  by_cases ha : 0 ≤ a
  · rw [gauge_le_eq hs h₀ Absorbs ha]
    exact convex_interᵢ fun i => convex_interᵢ fun hi => hs.smul _
  · convert convex_empty
    exact eq_empty_iff_forall_not_mem.2 fun x hx => ha <| (gauge_nonneg _).trans hx
#align convex.gauge_le Convex.gauge_le

theorem Balanced.starConvex (hs : Balanced ℝ s) : StarConvex ℝ 0 s :=
  starConvex_zero_iff.2 fun x hx a ha₀ ha₁ =>
    hs _ (by rwa [Real.norm_of_nonneg ha₀]) (smul_mem_smul_set hx)
#align balanced.star_convex Balanced.starConvex

theorem le_gauge_of_not_mem (hs₀ : StarConvex ℝ 0 s) (hs₂ : Absorbs ℝ s {x}) (hx : x ∉ a • s) :
    a ≤ gauge s x := by
  rw [starConvex_zero_iff] at hs₀
  obtain ⟨r, hr, h⟩ := hs₂
  refine' le_cinfₛ ⟨r, hr, singleton_subset_iff.1 <| h _ (Real.norm_of_nonneg hr.le).ge⟩ _
  rintro b ⟨hb, x, hx', rfl⟩
  refine' not_lt.1 fun hba => hx _
  have ha := hb.trans hba
  refine' ⟨(a⁻¹ * b) • x, hs₀ hx' (by positivity) _, _⟩
  · rw [← div_eq_inv_mul]
    exact div_le_one_of_le hba.le ha.le
  · rw [← mul_smul, mul_inv_cancel_left₀ ha.ne']
#align le_gauge_of_not_mem le_gauge_of_not_mem

theorem one_le_gauge_of_not_mem (hs₁ : StarConvex ℝ 0 s) (hs₂ : Absorbs ℝ s {x}) (hx : x ∉ s) :
    1 ≤ gauge s x :=
  le_gauge_of_not_mem hs₁ hs₂ <| by rwa [one_smul]
#align one_le_gauge_of_not_mem one_le_gauge_of_not_mem

section LinearOrderedField

variable {α : Type _} [LinearOrderedField α] [MulActionWithZero α ℝ] [OrderedSMul α ℝ]

theorem gauge_smul_of_nonneg [MulActionWithZero α E] [IsScalarTower α ℝ (Set E)] {s : Set E} {a : α}
    (ha : 0 ≤ a) (x : E) : gauge s (a • x) = a • gauge s x :=
  by
  obtain rfl | ha' := ha.eq_or_lt
  · rw [zero_smul, gauge_zero, zero_smul]
  rw [gauge_def', gauge_def', ← Real.infₛ_smul_of_nonneg ha]
  congr 1
  ext r
  simp_rw [Set.mem_smul_set, Set.mem_sep_iff]
  constructor
  · rintro ⟨hr, hx⟩
    simp_rw [mem_Ioi] at hr⊢
    rw [← mem_smul_set_iff_inv_smul_mem₀ hr.ne'] at hx
    have := smul_pos (inv_pos.2 ha') hr
    refine' ⟨a⁻¹ • r, ⟨this, _⟩, smul_inv_smul₀ ha'.ne' _⟩
    rwa [← mem_smul_set_iff_inv_smul_mem₀ this.ne', smul_assoc,
      mem_smul_set_iff_inv_smul_mem₀ (inv_ne_zero ha'.ne'), inv_inv]
  · rintro ⟨r, ⟨hr, hx⟩, rfl⟩
    rw [mem_Ioi] at hr⊢
    rw [← mem_smul_set_iff_inv_smul_mem₀ hr.ne'] at hx
    have := smul_pos ha' hr
    refine' ⟨this, _⟩
    rw [← mem_smul_set_iff_inv_smul_mem₀ this.ne', smul_assoc]
    exact smul_mem_smul_set hx
#align gauge_smul_of_nonneg gauge_smul_of_nonneg

theorem gauge_smul_left_of_nonneg [MulActionWithZero α E] [SMulCommClass α ℝ ℝ]
    [IsScalarTower α ℝ ℝ] [IsScalarTower α ℝ E] {s : Set E} {a : α} (ha : 0 ≤ a) :
    gauge (a • s) = a⁻¹ • gauge s :=
  by
  obtain rfl | ha' := ha.eq_or_lt
  · rw [inv_zero, zero_smul, gauge_of_subset_zero (zero_smul_set_subset _)]
  ext
  rw [gauge_def', Pi.smul_apply, gauge_def', ← Real.infₛ_smul_of_nonneg (inv_nonneg.2 ha)]
  congr 1
  ext r
  simp_rw [Set.mem_smul_set, Set.mem_sep_iff]
  constructor
  · rintro ⟨hr, y, hy, h⟩
    simp_rw [mem_Ioi] at hr⊢
    refine' ⟨a • r, ⟨smul_pos ha' hr, _⟩, inv_smul_smul₀ ha'.ne' _⟩
    rwa [smul_inv₀, smul_assoc, ← h, inv_smul_smul₀ ha'.ne']
  · rintro ⟨r, ⟨hr, hx⟩, rfl⟩
    rw [mem_Ioi] at hr⊢
    have := smul_pos ha' hr
    refine' ⟨smul_pos (inv_pos.2 ha') hr, r⁻¹ • x, hx, _⟩
    rw [smul_inv₀, smul_assoc, inv_inv]
#align gauge_smul_left_of_nonneg gauge_smul_left_of_nonneg

theorem gauge_smul_left [Module α E] [SMulCommClass α ℝ ℝ] [IsScalarTower α ℝ ℝ]
    [IsScalarTower α ℝ E] {s : Set E} (symmetric : ∀ x ∈ s, -x ∈ s) (a : α) :
    gauge (a • s) = (|a|)⁻¹ • gauge s :=
  by
  rw [← gauge_smul_left_of_nonneg (abs_nonneg a)]
  obtain h | h := abs_choice a
  · rw [h]
  · rw [h, Set.neg_smul_set, ← Set.smul_set_neg]
    congr
    ext y
    refine' ⟨Symmetric _, fun hy => _⟩
    rw [← neg_neg y]
    exact Symmetric _ hy
  · infer_instance
#align gauge_smul_left gauge_smul_left

end LinearOrderedField

section IsROrC

variable [IsROrC 𝕜] [Module 𝕜 E] [IsScalarTower ℝ 𝕜 E]

theorem gauge_norm_smul (hs : Balanced 𝕜 s) (r : 𝕜) (x : E) : gauge s (‖r‖ • x) = gauge s (r • x) :=
  by
  rw [@IsROrC.real_smul_eq_coe_smul 𝕜]
  obtain rfl | hr := eq_or_ne r 0
  · simp only [norm_zero, IsROrC.of_real_zero]
  unfold gauge
  congr with θ
  refine' and_congr_right fun hθ => (hs.smul _).mem_smul_iff _
  rw [IsROrC.norm_of_real, norm_norm]
#align gauge_norm_smul gauge_norm_smul

/-- If `s` is balanced, then the Minkowski functional is ℂ-homogeneous. -/
theorem gauge_smul (hs : Balanced 𝕜 s) (r : 𝕜) (x : E) : gauge s (r • x) = ‖r‖ * gauge s x :=
  by
  rw [← smul_eq_mul, ← gauge_smul_of_nonneg (norm_nonneg r), gauge_norm_smul hs]
  infer_instance
#align gauge_smul gauge_smul

end IsROrC

section TopologicalSpace

variable [TopologicalSpace E] [ContinuousSMul ℝ E]

theorem interior_subset_gauge_lt_one (s : Set E) : interior s ⊆ { x | gauge s x < 1 } :=
  by
  intro x hx
  let f : ℝ → E := fun t => t • x
  have hf : Continuous f := by continuity
  let s' := f ⁻¹' interior s
  have hs' : IsOpen s' := hf.is_open_preimage _ isOpen_interior
  have one_mem : (1 : ℝ) ∈ s' := by simpa only [s', f, Set.mem_preimage, one_smul]
  obtain ⟨ε, hε₀, hε⟩ := (Metric.nhds_basis_closedBall.1 _).1 (isOpen_iff_mem_nhds.1 hs' 1 one_mem)
  rw [Real.closedBall_eq_Icc] at hε
  have hε₁ : 0 < 1 + ε := hε₀.trans (lt_one_add ε)
  have : (1 + ε)⁻¹ < 1 := by
    rw [inv_lt_one_iff]
    right
    linarith
  refine' (gauge_le_of_mem (inv_nonneg.2 hε₁.le) _).trans_lt this
  rw [mem_inv_smul_set_iff₀ hε₁.ne']
  exact
    interior_subset
      (hε ⟨(sub_le_self _ hε₀.le).trans ((le_add_iff_nonneg_right _).2 hε₀.le), le_rfl⟩)
#align interior_subset_gauge_lt_one interior_subset_gauge_lt_one

theorem gauge_lt_one_eq_self_of_open (hs₁ : Convex ℝ s) (hs₀ : (0 : E) ∈ s) (hs₂ : IsOpen s) :
    { x | gauge s x < 1 } = s :=
  by
  refine' (gauge_lt_one_subset_self hs₁ ‹_› <| absorbent_nhds_zero <| hs₂.mem_nhds hs₀).antisymm _
  convert interior_subset_gauge_lt_one s
  exact hs₂.interior_eq.symm
#align gauge_lt_one_eq_self_of_open gauge_lt_one_eq_self_of_open

theorem gauge_lt_one_of_mem_of_open (hs₁ : Convex ℝ s) (hs₀ : (0 : E) ∈ s) (hs₂ : IsOpen s) {x : E}
    (hx : x ∈ s) : gauge s x < 1 := by rwa [← gauge_lt_one_eq_self_of_open hs₁ hs₀ hs₂] at hx
#align gauge_lt_one_of_mem_of_open gauge_lt_one_of_mem_of_open

theorem gauge_lt_of_mem_smul (x : E) (ε : ℝ) (hε : 0 < ε) (hs₀ : (0 : E) ∈ s) (hs₁ : Convex ℝ s)
    (hs₂ : IsOpen s) (hx : x ∈ ε • s) : gauge s x < ε :=
  by
  have : ε⁻¹ • x ∈ s := by rwa [← mem_smul_set_iff_inv_smul_mem₀ hε.ne']
  have h_gauge_lt := gauge_lt_one_of_mem_of_open hs₁ hs₀ hs₂ this
  rwa [gauge_smul_of_nonneg (inv_nonneg.2 hε.le), smul_eq_mul, inv_mul_lt_iff hε, mul_one] at
    h_gauge_lt
  infer_instance
#align gauge_lt_of_mem_smul gauge_lt_of_mem_smul

end TopologicalSpace

theorem gauge_add_le (hs : Convex ℝ s) (absorbs : Absorbent ℝ s) (x y : E) :
    gauge s (x + y) ≤ gauge s x + gauge s y :=
  by
  refine' le_of_forall_pos_lt_add fun ε hε => _
  obtain ⟨a, ha, ha', hx⟩ :=
    exists_lt_of_gauge_lt Absorbs (lt_add_of_pos_right (gauge s x) (half_pos hε))
  obtain ⟨b, hb, hb', hy⟩ :=
    exists_lt_of_gauge_lt Absorbs (lt_add_of_pos_right (gauge s y) (half_pos hε))
  rw [mem_smul_set_iff_inv_smul_mem₀ ha.ne'] at hx
  rw [mem_smul_set_iff_inv_smul_mem₀ hb.ne'] at hy
  suffices gauge s (x + y) ≤ a + b by linarith
  have hab : 0 < a + b := add_pos ha hb
  apply gauge_le_of_mem hab.le
  have := convex_iff_div.1 hs hx hy ha.le hb.le hab
  rwa [smul_smul, smul_smul, ← mul_div_right_comm, ← mul_div_right_comm, mul_inv_cancel ha.ne',
    mul_inv_cancel hb.ne', ← smul_add, one_div, ← mem_smul_set_iff_inv_smul_mem₀ hab.ne'] at this
#align gauge_add_le gauge_add_le

section IsROrC

variable [IsROrC 𝕜] [Module 𝕜 E] [IsScalarTower ℝ 𝕜 E]

/-- `gauge s` as a seminorm when `s` is  balanced, convex and absorbent. -/
@[simps]
def gaugeSeminorm (hs₀ : Balanced 𝕜 s) (hs₁ : Convex ℝ s) (hs₂ : Absorbent ℝ s) : Seminorm 𝕜 E :=
  Seminorm.of (gauge s) (gauge_add_le hs₁ hs₂) (gauge_smul hs₀)
#align gauge_seminorm gaugeSeminorm

variable {hs₀ : Balanced 𝕜 s} {hs₁ : Convex ℝ s} {hs₂ : Absorbent ℝ s} [TopologicalSpace E]
  [ContinuousSMul ℝ E]

theorem gaugeSeminorm_lt_one_of_open (hs : IsOpen s) {x : E} (hx : x ∈ s) :
    gaugeSeminorm hs₀ hs₁ hs₂ x < 1 :=
  gauge_lt_one_of_mem_of_open hs₁ hs₂.zero_mem hs hx
#align gauge_seminorm_lt_one_of_open gaugeSeminorm_lt_one_of_open

theorem gaugeSeminorm_ball_one (hs : IsOpen s) : (gaugeSeminorm hs₀ hs₁ hs₂).ball 0 1 = s :=
  by
  rw [Seminorm.ball_zero_eq]
  exact gauge_lt_one_eq_self_of_open hs₁ hs₂.zero_mem hs
#align gauge_seminorm_ball_one gaugeSeminorm_ball_one

end IsROrC

/-- Any seminorm arises as the gauge of its unit ball. -/
@[simp]
protected theorem Seminorm.gauge_ball (p : Seminorm ℝ E) : gauge (p.ball 0 1) = p :=
  by
  ext
  obtain hp | hp := { r : ℝ | 0 < r ∧ x ∈ r • p.ball 0 1 }.eq_empty_or_nonempty
  · rw [gauge, hp, Real.infₛ_empty]
    by_contra
    have hpx : 0 < p x := (map_nonneg _ _).lt_of_ne h
    have hpx₂ : 0 < 2 * p x := mul_pos zero_lt_two hpx
    refine' hp.subset ⟨hpx₂, (2 * p x)⁻¹ • x, _, smul_inv_smul₀ hpx₂.ne' _⟩
    rw [p.mem_ball_zero, map_smul_eq_mul, Real.norm_eq_abs, abs_of_pos (inv_pos.2 hpx₂),
      inv_mul_lt_iff hpx₂, mul_one]
    exact lt_mul_of_one_lt_left hpx one_lt_two
  refine' IsGLB.cinfₛ_eq ⟨fun r => _, fun r hr => le_of_forall_pos_le_add fun ε hε => _⟩ hp
  · rintro ⟨hr, y, hy, rfl⟩
    rw [p.mem_ball_zero] at hy
    rw [map_smul_eq_mul, Real.norm_eq_abs, abs_of_pos hr]
    exact mul_le_of_le_one_right hr.le hy.le
  · have hpε : 0 < p x + ε := by positivity
    refine' hr ⟨hpε, (p x + ε)⁻¹ • x, _, smul_inv_smul₀ hpε.ne' _⟩
    rw [p.mem_ball_zero, map_smul_eq_mul, Real.norm_eq_abs, abs_of_pos (inv_pos.2 hpε),
      inv_mul_lt_iff hpε, mul_one]
    exact lt_add_of_pos_right _ hε
#align seminorm.gauge_ball Seminorm.gauge_ball

theorem Seminorm.gaugeSeminorm_ball (p : Seminorm ℝ E) :
    gaugeSeminorm (p.balanced_ball_zero 1) (p.convex_ball 0 1) (p.absorbent_ball_zero zero_lt_one) =
      p :=
  FunLike.coe_injective p.gauge_ball
#align seminorm.gauge_seminorm_ball Seminorm.gaugeSeminorm_ball

end AddCommGroup

section Norm

variable [SeminormedAddCommGroup E] [NormedSpace ℝ E] {s : Set E} {r : ℝ} {x : E}

theorem gauge_unit_ball (x : E) : gauge (Metric.ball (0 : E) 1) x = ‖x‖ :=
  by
  obtain rfl | hx := eq_or_ne x 0
  · rw [norm_zero, gauge_zero]
  refine' (le_of_forall_pos_le_add fun ε hε => _).antisymm _
  · have : 0 < ‖x‖ + ε := by positivity
    refine' gauge_le_of_mem this.le _
    rw [smul_ball this.ne', smul_zero, Real.norm_of_nonneg this.le, mul_one, mem_ball_zero_iff]
    exact lt_add_of_pos_right _ hε
  refine'
    le_gauge_of_not_mem balanced_ball_zero.star_convex (absorbent_ball_zero zero_lt_one).Absorbs
      fun h => _
  obtain hx' | hx' := eq_or_ne ‖x‖ 0
  · rw [hx'] at h
    exact hx (zero_smul_set_subset _ h)
  · rw [mem_smul_set_iff_inv_smul_mem₀ hx', mem_ball_zero_iff, norm_smul, norm_inv, norm_norm,
      inv_mul_cancel hx'] at h
    exact lt_irrefl _ h
#align gauge_unit_ball gauge_unit_ball

theorem gauge_ball (hr : 0 < r) (x : E) : gauge (Metric.ball (0 : E) r) x = ‖x‖ / r :=
  by
  rw [← smul_unit_ball_of_pos hr, gauge_smul_left, Pi.smul_apply, gauge_unit_ball, smul_eq_mul,
    abs_of_nonneg hr.le, div_eq_inv_mul]
  simp_rw [mem_ball_zero_iff, norm_neg]
  exact fun _ => id
#align gauge_ball gauge_ball

theorem mul_gauge_le_norm (hs : Metric.ball (0 : E) r ⊆ s) : r * gauge s x ≤ ‖x‖ :=
  by
  obtain hr | hr := le_or_lt r 0
  · exact (mul_nonpos_of_nonpos_of_nonneg hr <| gauge_nonneg _).trans (norm_nonneg _)
  rw [mul_comm, ← le_div_iff hr, ← gauge_ball hr]
  exact gauge_mono (absorbent_ball_zero hr) hs x
#align mul_gauge_le_norm mul_gauge_le_norm

end Norm


theorem test (p q : Prop) (hp : p) (hq : q) : p ∧ q ∧ p :=
begin
  apply and.intro hp,
  exact and.intro hq hp,
end

#print test


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

! This file was ported from Lean 3 source module geometry.manifold.diffeomorph
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Geometry.Manifold.ContMdiffMap

/-!
# Diffeomorphisms
This file implements diffeomorphisms.

## Definitions

* `diffeomorph I I' M M' n`:  `n`-times continuously differentiable diffeomorphism between
  `M` and `M'` with respect to I and I'; we do not introduce a separate definition for the case
  `n = ∞`; we use notation instead.
* `diffeomorph.to_homeomorph`: reinterpret a diffeomorphism as a homeomorphism.
* `continuous_linear_equiv.to_diffeomorph`: reinterpret a continuous equivalence as
  a diffeomorphism.
* `model_with_corners.trans_diffeomorph`: compose a given `model_with_corners` with a diffeomorphism
  between the old and the new target spaces. Useful, e.g, to turn any finite dimensional manifold
  into a manifold modelled on a Euclidean space.
* `diffeomorph.to_trans_diffeomorph`: the identity diffeomorphism between `M` with model `I` and `M`
  with model `I.trans_diffeomorph e`.

## Notations

* `M ≃ₘ^n⟮I, I'⟯ M'`  := `diffeomorph I J M N n`
* `M ≃ₘ⟮I, I'⟯ M'`    := `diffeomorph I J M N ⊤`
* `E ≃ₘ^n[𝕜] E'`      := `E ≃ₘ^n⟮𝓘(𝕜, E), 𝓘(𝕜, E')⟯ E'`
* `E ≃ₘ[𝕜] E'`        := `E ≃ₘ⟮𝓘(𝕜, E), 𝓘(𝕜, E')⟯ E'`

## Implementation notes

This notion of diffeomorphism is needed although there is already a notion of structomorphism
because structomorphisms do not allow the model spaces `H` and `H'` of the two manifolds to be
different, i.e. for a structomorphism one has to impose `H = H'` which is often not the case in
practice.

## Keywords

diffeomorphism, manifold
-/

open Manifold Topology

open Function Set

variable {𝕜 : Type _} [NontriviallyNormedField 𝕜] {E : Type _} [NormedAddCommGroup E]
  [NormedSpace 𝕜 E] {E' : Type _} [NormedAddCommGroup E'] [NormedSpace 𝕜 E'] {F : Type _}
  [NormedAddCommGroup F] [NormedSpace 𝕜 F] {H : Type _} [TopologicalSpace H] {H' : Type _}
  [TopologicalSpace H'] {G : Type _} [TopologicalSpace G] {G' : Type _} [TopologicalSpace G']
  {I : ModelWithCorners 𝕜 E H} {I' : ModelWithCorners 𝕜 E' H'} {J : ModelWithCorners 𝕜 F G}
  {J' : ModelWithCorners 𝕜 F G'}

variable {M : Type _} [TopologicalSpace M] [ChartedSpace H M] {M' : Type _} [TopologicalSpace M']
  [ChartedSpace H' M'] {N : Type _} [TopologicalSpace N] [ChartedSpace G N] {N' : Type _}
  [TopologicalSpace N'] [ChartedSpace G' N'] {n : ℕ∞}

section Defs

variable (I I' M M' n)

/--
`n`-times continuously differentiable diffeomorphism between `M` and `M'` with respect to I and I'
-/
@[protect_proj, nolint has_nonempty_instance]
structure Diffeomorph extends M ≃ M' where
  contMdiff_toFun : ContMdiff I I' n to_equiv
  contMdiff_inv_fun : ContMdiff I' I n to_equiv.symm
#align diffeomorph Diffeomorph

end Defs

-- mathport name: diffeomorph
scoped[Manifold] notation M " ≃ₘ^" n:1000 "⟮" I ", " J "⟯ " N => Diffeomorph I J M N n

-- mathport name: diffeomorph.top
scoped[Manifold] notation M " ≃ₘ⟮" I ", " J "⟯ " N => Diffeomorph I J M N ⊤

-- mathport name: diffeomorph.self
scoped[Manifold]
  notation E " ≃ₘ^" n:1000 "[" 𝕜 "] " E' =>
    Diffeomorph (modelWithCornersSelf 𝕜 E) (modelWithCornersSelf 𝕜 E') E E' n

-- mathport name: diffeomorph.self.top
scoped[Manifold]
  notation E " ≃ₘ[" 𝕜 "] " E' =>
    Diffeomorph (modelWithCornersSelf 𝕜 E) (modelWithCornersSelf 𝕜 E') E E' ⊤

namespace Diffeomorph

instance : CoeFun (M ≃ₘ^n⟮I, I'⟯ M') fun _ => M → M' :=
  ⟨fun e => e.toEquiv⟩

instance : Coe (M ≃ₘ^n⟮I, I'⟯ M') C^n⟮I, M; I', M'⟯ :=
  ⟨fun Φ => ⟨Φ, Φ.contMdiff_toFun⟩⟩

@[continuity]
protected theorem continuous (h : M ≃ₘ^n⟮I, I'⟯ M') : Continuous h :=
  h.contMdiff_toFun.Continuous
#align diffeomorph.continuous Diffeomorph.continuous

protected theorem contMdiff (h : M ≃ₘ^n⟮I, I'⟯ M') : ContMdiff I I' n h :=
  h.contMdiff_toFun
#align diffeomorph.cont_mdiff Diffeomorph.contMdiff

protected theorem contMdiffAt (h : M ≃ₘ^n⟮I, I'⟯ M') {x} : ContMdiffAt I I' n h x :=
  h.ContMdiff.ContMdiffAt
#align diffeomorph.cont_mdiff_at Diffeomorph.contMdiffAt

protected theorem contMdiffWithinAt (h : M ≃ₘ^n⟮I, I'⟯ M') {s x} : ContMdiffWithinAt I I' n h s x :=
  h.ContMdiffAt.ContMdiffWithinAt
#align diffeomorph.cont_mdiff_within_at Diffeomorph.contMdiffWithinAt

protected theorem contDiff (h : E ≃ₘ^n[𝕜] E') : ContDiff 𝕜 n h :=
  h.ContMdiff.ContDiff
#align diffeomorph.cont_diff Diffeomorph.contDiff

protected theorem smooth (h : M ≃ₘ⟮I, I'⟯ M') : Smooth I I' h :=
  h.contMdiff_toFun
#align diffeomorph.smooth Diffeomorph.smooth

protected theorem mdifferentiable (h : M ≃ₘ^n⟮I, I'⟯ M') (hn : 1 ≤ n) : Mdifferentiable I I' h :=
  h.ContMdiff.Mdifferentiable hn
#align diffeomorph.mdifferentiable Diffeomorph.mdifferentiable

protected theorem mdifferentiableOn (h : M ≃ₘ^n⟮I, I'⟯ M') (s : Set M) (hn : 1 ≤ n) :
    MdifferentiableOn I I' h s :=
  (h.Mdifferentiable hn).MdifferentiableOn
#align diffeomorph.mdifferentiable_on Diffeomorph.mdifferentiableOn

@[simp]
theorem coe_toEquiv (h : M ≃ₘ^n⟮I, I'⟯ M') : ⇑h.toEquiv = h :=
  rfl
#align diffeomorph.coe_to_equiv Diffeomorph.coe_toEquiv

@[simp, norm_cast]
theorem coe_coe (h : M ≃ₘ^n⟮I, I'⟯ M') : ⇑(h : C^n⟮I, M; I', M'⟯) = h :=
  rfl
#align diffeomorph.coe_coe Diffeomorph.coe_coe

theorem toEquiv_injective : Injective (Diffeomorph.toEquiv : (M ≃ₘ^n⟮I, I'⟯ M') → M ≃ M')
  | ⟨e, _, _⟩, ⟨e', _, _⟩, rfl => rfl
#align diffeomorph.to_equiv_injective Diffeomorph.toEquiv_injective

@[simp]
theorem toEquiv_inj {h h' : M ≃ₘ^n⟮I, I'⟯ M'} : h.toEquiv = h'.toEquiv ↔ h = h' :=
  toEquiv_injective.eq_iff
#align diffeomorph.to_equiv_inj Diffeomorph.toEquiv_inj

/-- Coercion to function `λ h : M ≃ₘ^n⟮I, I'⟯ M', (h : M → M')` is injective. -/
theorem coeFn_injective : Injective fun (h : M ≃ₘ^n⟮I, I'⟯ M') (x : M) => h x :=
  Equiv.coe_fn_injective.comp toEquiv_injective
#align diffeomorph.coe_fn_injective Diffeomorph.coeFn_injective

@[ext]
theorem ext {h h' : M ≃ₘ^n⟮I, I'⟯ M'} (Heq : ∀ x, h x = h' x) : h = h' :=
  coeFn_injective <| funext Heq
#align diffeomorph.ext Diffeomorph.ext

section

variable (M I n)

/-- Identity map as a diffeomorphism. -/
protected def refl : M ≃ₘ^n⟮I, I⟯ M
    where
  contMdiff_toFun := contMdiff_id
  contMdiff_inv_fun := contMdiff_id
  toEquiv := Equiv.refl M
#align diffeomorph.refl Diffeomorph.refl

@[simp]
theorem refl_toEquiv : (Diffeomorph.refl I M n).toEquiv = Equiv.refl _ :=
  rfl
#align diffeomorph.refl_to_equiv Diffeomorph.refl_toEquiv

@[simp]
theorem coe_refl : ⇑(Diffeomorph.refl I M n) = id :=
  rfl
#align diffeomorph.coe_refl Diffeomorph.coe_refl

end

/-- Composition of two diffeomorphisms. -/
protected def trans (h₁ : M ≃ₘ^n⟮I, I'⟯ M') (h₂ : M' ≃ₘ^n⟮I', J⟯ N) : M ≃ₘ^n⟮I, J⟯ N
    where
  contMdiff_toFun := h₂.contMdiff_toFun.comp h₁.contMdiff_toFun
  contMdiff_inv_fun := h₁.contMdiff_inv_fun.comp h₂.contMdiff_inv_fun
  toEquiv := h₁.toEquiv.trans h₂.toEquiv
#align diffeomorph.trans Diffeomorph.trans

@[simp]
theorem trans_refl (h : M ≃ₘ^n⟮I, I'⟯ M') : h.trans (Diffeomorph.refl I' M' n) = h :=
  ext fun _ => rfl
#align diffeomorph.trans_refl Diffeomorph.trans_refl

@[simp]
theorem refl_trans (h : M ≃ₘ^n⟮I, I'⟯ M') : (Diffeomorph.refl I M n).trans h = h :=
  ext fun _ => rfl
#align diffeomorph.refl_trans Diffeomorph.refl_trans

@[simp]
theorem coe_trans (h₁ : M ≃ₘ^n⟮I, I'⟯ M') (h₂ : M' ≃ₘ^n⟮I', J⟯ N) : ⇑(h₁.trans h₂) = h₂ ∘ h₁ :=
  rfl
#align diffeomorph.coe_trans Diffeomorph.coe_trans

/-- Inverse of a diffeomorphism. -/
protected def symm (h : M ≃ₘ^n⟮I, J⟯ N) : N ≃ₘ^n⟮J, I⟯ M
    where
  contMdiff_toFun := h.contMdiff_inv_fun
  contMdiff_inv_fun := h.contMdiff_toFun
  toEquiv := h.toEquiv.symm
#align diffeomorph.symm Diffeomorph.symm

@[simp]
theorem apply_symm_apply (h : M ≃ₘ^n⟮I, J⟯ N) (x : N) : h (h.symm x) = x :=
  h.toEquiv.apply_symm_apply x
#align diffeomorph.apply_symm_apply Diffeomorph.apply_symm_apply

@[simp]
theorem symm_apply_apply (h : M ≃ₘ^n⟮I, J⟯ N) (x : M) : h.symm (h x) = x :=
  h.toEquiv.symm_apply_apply x
#align diffeomorph.symm_apply_apply Diffeomorph.symm_apply_apply

@[simp]
theorem symm_refl : (Diffeomorph.refl I M n).symm = Diffeomorph.refl I M n :=
  ext fun _ => rfl
#align diffeomorph.symm_refl Diffeomorph.symm_refl

@[simp]
theorem self_trans_symm (h : M ≃ₘ^n⟮I, J⟯ N) : h.trans h.symm = Diffeomorph.refl I M n :=
  ext h.symm_apply_apply
#align diffeomorph.self_trans_symm Diffeomorph.self_trans_symm

@[simp]
theorem symm_trans_self (h : M ≃ₘ^n⟮I, J⟯ N) : h.symm.trans h = Diffeomorph.refl J N n :=
  ext h.apply_symm_apply
#align diffeomorph.symm_trans_self Diffeomorph.symm_trans_self

@[simp]
theorem symm_trans' (h₁ : M ≃ₘ^n⟮I, I'⟯ M') (h₂ : M' ≃ₘ^n⟮I', J⟯ N) :
    (h₁.trans h₂).symm = h₂.symm.trans h₁.symm :=
  rfl
#align diffeomorph.symm_trans' Diffeomorph.symm_trans'

@[simp]
theorem symm_toEquiv (h : M ≃ₘ^n⟮I, J⟯ N) : h.symm.toEquiv = h.toEquiv.symm :=
  rfl
#align diffeomorph.symm_to_equiv Diffeomorph.symm_toEquiv

@[simp, mfld_simps]
theorem toEquiv_coe_symm (h : M ≃ₘ^n⟮I, J⟯ N) : ⇑h.toEquiv.symm = h.symm :=
  rfl
#align diffeomorph.to_equiv_coe_symm Diffeomorph.toEquiv_coe_symm

theorem image_eq_preimage (h : M ≃ₘ^n⟮I, J⟯ N) (s : Set M) : h '' s = h.symm ⁻¹' s :=
  h.toEquiv.image_eq_preimage s
#align diffeomorph.image_eq_preimage Diffeomorph.image_eq_preimage

theorem symm_image_eq_preimage (h : M ≃ₘ^n⟮I, J⟯ N) (s : Set N) : h.symm '' s = h ⁻¹' s :=
  h.symm.image_eq_preimage s
#align diffeomorph.symm_image_eq_preimage Diffeomorph.symm_image_eq_preimage

@[simp, mfld_simps]
theorem range_comp {α} (h : M ≃ₘ^n⟮I, J⟯ N) (f : α → M) : range (h ∘ f) = h.symm ⁻¹' range f := by
  rw [range_comp, image_eq_preimage]
#align diffeomorph.range_comp Diffeomorph.range_comp

@[simp]
theorem image_symm_image (h : M ≃ₘ^n⟮I, J⟯ N) (s : Set N) : h '' (h.symm '' s) = s :=
  h.toEquiv.image_symm_image s
#align diffeomorph.image_symm_image Diffeomorph.image_symm_image

@[simp]
theorem symm_image_image (h : M ≃ₘ^n⟮I, J⟯ N) (s : Set M) : h.symm '' (h '' s) = s :=
  h.toEquiv.symm_image_image s
#align diffeomorph.symm_image_image Diffeomorph.symm_image_image

/-- A diffeomorphism is a homeomorphism. -/
def toHomeomorph (h : M ≃ₘ^n⟮I, J⟯ N) : M ≃ₜ N :=
  ⟨h.toEquiv, h.Continuous, h.symm.Continuous⟩
#align diffeomorph.to_homeomorph Diffeomorph.toHomeomorph

@[simp]
theorem toHomeomorph_toEquiv (h : M ≃ₘ^n⟮I, J⟯ N) : h.toHomeomorph.toEquiv = h.toEquiv :=
  rfl
#align diffeomorph.to_homeomorph_to_equiv Diffeomorph.toHomeomorph_toEquiv

@[simp]
theorem symm_toHomeomorph (h : M ≃ₘ^n⟮I, J⟯ N) : h.symm.toHomeomorph = h.toHomeomorph.symm :=
  rfl
#align diffeomorph.symm_to_homeomorph Diffeomorph.symm_toHomeomorph

@[simp]
theorem coe_toHomeomorph (h : M ≃ₘ^n⟮I, J⟯ N) : ⇑h.toHomeomorph = h :=
  rfl
#align diffeomorph.coe_to_homeomorph Diffeomorph.coe_toHomeomorph

@[simp]
theorem coe_toHomeomorph_symm (h : M ≃ₘ^n⟮I, J⟯ N) : ⇑h.toHomeomorph.symm = h.symm :=
  rfl
#align diffeomorph.coe_to_homeomorph_symm Diffeomorph.coe_toHomeomorph_symm

@[simp]
theorem contMdiffWithinAt_comp_diffeomorph_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : N → M'} {s x}
    (hm : m ≤ n) :
    ContMdiffWithinAt I I' m (f ∘ h) s x ↔ ContMdiffWithinAt J I' m f (h.symm ⁻¹' s) (h x) :=
  by
  constructor
  · intro Hfh
    rw [← h.symm_apply_apply x] at Hfh
    simpa only [(· ∘ ·), h.apply_symm_apply] using
      Hfh.comp (h x) (h.symm.cont_mdiff_within_at.of_le hm) (maps_to_preimage _ _)
  · rw [← h.image_eq_preimage]
    exact fun hf => hf.comp x (h.cont_mdiff_within_at.of_le hm) (maps_to_image _ _)
#align diffeomorph.cont_mdiff_within_at_comp_diffeomorph_iff Diffeomorph.contMdiffWithinAt_comp_diffeomorph_iff

@[simp]
theorem contMdiffOn_comp_diffeomorph_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : N → M'} {s} (hm : m ≤ n) :
    ContMdiffOn I I' m (f ∘ h) s ↔ ContMdiffOn J I' m f (h.symm ⁻¹' s) :=
  h.toEquiv.forall_congr' fun x => by
    simp only [hm, coe_to_equiv, symm_apply_apply, cont_mdiff_within_at_comp_diffeomorph_iff,
      mem_preimage]
#align diffeomorph.cont_mdiff_on_comp_diffeomorph_iff Diffeomorph.contMdiffOn_comp_diffeomorph_iff

@[simp]
theorem contMdiffAt_comp_diffeomorph_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : N → M'} {x} (hm : m ≤ n) :
    ContMdiffAt I I' m (f ∘ h) x ↔ ContMdiffAt J I' m f (h x) :=
  h.contMdiffWithinAt_comp_diffeomorph_iff hm
#align diffeomorph.cont_mdiff_at_comp_diffeomorph_iff Diffeomorph.contMdiffAt_comp_diffeomorph_iff

@[simp]
theorem contMdiff_comp_diffeomorph_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : N → M'} (hm : m ≤ n) :
    ContMdiff I I' m (f ∘ h) ↔ ContMdiff J I' m f :=
  h.toEquiv.forall_congr' fun x => h.contMdiffAt_comp_diffeomorph_iff hm
#align diffeomorph.cont_mdiff_comp_diffeomorph_iff Diffeomorph.contMdiff_comp_diffeomorph_iff

@[simp]
theorem contMdiffWithinAt_diffeomorph_comp_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : M' → M} (hm : m ≤ n)
    {s x} : ContMdiffWithinAt I' J m (h ∘ f) s x ↔ ContMdiffWithinAt I' I m f s x :=
  ⟨fun Hhf => by
    simpa only [(· ∘ ·), h.symm_apply_apply] using
      (h.symm.cont_mdiff_at.of_le hm).comp_contMdiffWithinAt _ Hhf,
    fun Hf => (h.ContMdiffAt.of_le hm).comp_contMdiffWithinAt _ Hf⟩
#align diffeomorph.cont_mdiff_within_at_diffeomorph_comp_iff Diffeomorph.contMdiffWithinAt_diffeomorph_comp_iff

@[simp]
theorem contMdiffAt_diffeomorph_comp_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : M' → M} (hm : m ≤ n) {x} :
    ContMdiffAt I' J m (h ∘ f) x ↔ ContMdiffAt I' I m f x :=
  h.contMdiffWithinAt_diffeomorph_comp_iff hm
#align diffeomorph.cont_mdiff_at_diffeomorph_comp_iff Diffeomorph.contMdiffAt_diffeomorph_comp_iff

@[simp]
theorem contMdiffOn_diffeomorph_comp_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : M' → M} (hm : m ≤ n) {s} :
    ContMdiffOn I' J m (h ∘ f) s ↔ ContMdiffOn I' I m f s :=
  forall₂_congr fun x hx => h.contMdiffWithinAt_diffeomorph_comp_iff hm
#align diffeomorph.cont_mdiff_on_diffeomorph_comp_iff Diffeomorph.contMdiffOn_diffeomorph_comp_iff

@[simp]
theorem contMdiff_diffeomorph_comp_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : M' → M} (hm : m ≤ n) :
    ContMdiff I' J m (h ∘ f) ↔ ContMdiff I' I m f :=
  forall_congr' fun x => h.contMdiffWithinAt_diffeomorph_comp_iff hm
#align diffeomorph.cont_mdiff_diffeomorph_comp_iff Diffeomorph.contMdiff_diffeomorph_comp_iff

theorem toLocalHomeomorph_mdifferentiable (h : M ≃ₘ^n⟮I, J⟯ N) (hn : 1 ≤ n) :
    h.toHomeomorph.toLocalHomeomorph.Mdifferentiable I J :=
  ⟨h.MdifferentiableOn _ hn, h.symm.MdifferentiableOn _ hn⟩
#align diffeomorph.to_local_homeomorph_mdifferentiable Diffeomorph.toLocalHomeomorph_mdifferentiable

section Constructions

/-- Product of two diffeomorphisms. -/
def prodCongr (h₁ : M ≃ₘ^n⟮I, I'⟯ M') (h₂ : N ≃ₘ^n⟮J, J'⟯ N') :
    (M × N) ≃ₘ^n⟮I.Prod J, I'.Prod J'⟯ M' × N'
    where
  contMdiff_toFun := (h₁.ContMdiff.comp contMdiff_fst).prod_mk (h₂.ContMdiff.comp contMdiff_snd)
  contMdiff_inv_fun :=
    (h₁.symm.ContMdiff.comp contMdiff_fst).prod_mk (h₂.symm.ContMdiff.comp contMdiff_snd)
  toEquiv := h₁.toEquiv.prodCongr h₂.toEquiv
#align diffeomorph.prod_congr Diffeomorph.prodCongr

@[simp]
theorem prodCongr_symm (h₁ : M ≃ₘ^n⟮I, I'⟯ M') (h₂ : N ≃ₘ^n⟮J, J'⟯ N') :
    (h₁.prodCongr h₂).symm = h₁.symm.prodCongr h₂.symm :=
  rfl
#align diffeomorph.prod_congr_symm Diffeomorph.prodCongr_symm

@[simp]
theorem coe_prodCongr (h₁ : M ≃ₘ^n⟮I, I'⟯ M') (h₂ : N ≃ₘ^n⟮J, J'⟯ N') :
    ⇑(h₁.prodCongr h₂) = Prod.map h₁ h₂ :=
  rfl
#align diffeomorph.coe_prod_congr Diffeomorph.coe_prodCongr

section

variable (I J J' M N N' n)

/-- `M × N` is diffeomorphic to `N × M`. -/
def prodComm : (M × N) ≃ₘ^n⟮I.Prod J, J.Prod I⟯ N × M
    where
  contMdiff_toFun := contMdiff_snd.prod_mk contMdiff_fst
  contMdiff_inv_fun := contMdiff_snd.prod_mk contMdiff_fst
  toEquiv := Equiv.prodComm M N
#align diffeomorph.prod_comm Diffeomorph.prodComm

@[simp]
theorem prodComm_symm : (prodComm I J M N n).symm = prodComm J I N M n :=
  rfl
#align diffeomorph.prod_comm_symm Diffeomorph.prodComm_symm

@[simp]
theorem coe_prodComm : ⇑(prodComm I J M N n) = Prod.swap :=
  rfl
#align diffeomorph.coe_prod_comm Diffeomorph.coe_prodComm

/-- `(M × N) × N'` is diffeomorphic to `M × (N × N')`. -/
def prodAssoc : ((M × N) × N') ≃ₘ^n⟮(I.Prod J).Prod J', I.Prod (J.Prod J')⟯ M × N × N'
    where
  contMdiff_toFun :=
    (contMdiff_fst.comp contMdiff_fst).prod_mk
      ((contMdiff_snd.comp contMdiff_fst).prod_mk contMdiff_snd)
  contMdiff_inv_fun :=
    (contMdiff_fst.prod_mk (contMdiff_fst.comp contMdiff_snd)).prod_mk
      (contMdiff_snd.comp contMdiff_snd)
  toEquiv := Equiv.prodAssoc M N N'
#align diffeomorph.prod_assoc Diffeomorph.prodAssoc

end

end Constructions

variable [SmoothManifoldWithCorners I M] [SmoothManifoldWithCorners J N]

theorem uniqueMdiffOn_image_aux (h : M ≃ₘ^n⟮I, J⟯ N) (hn : 1 ≤ n) {s : Set M}
    (hs : UniqueMdiffOn I s) : UniqueMdiffOn J (h '' s) :=
  by
  convert hs.unique_mdiff_on_preimage (h.to_local_homeomorph_mdifferentiable hn)
  simp [h.image_eq_preimage]
#align diffeomorph.unique_mdiff_on_image_aux Diffeomorph.uniqueMdiffOn_image_aux

@[simp]
theorem uniqueMdiffOn_image (h : M ≃ₘ^n⟮I, J⟯ N) (hn : 1 ≤ n) {s : Set M} :
    UniqueMdiffOn J (h '' s) ↔ UniqueMdiffOn I s :=
  ⟨fun hs => h.symm_image_image s ▸ h.symm.uniqueMdiffOn_image_aux hn hs,
    h.uniqueMdiffOn_image_aux hn⟩
#align diffeomorph.unique_mdiff_on_image Diffeomorph.uniqueMdiffOn_image

@[simp]
theorem uniqueMdiffOn_preimage (h : M ≃ₘ^n⟮I, J⟯ N) (hn : 1 ≤ n) {s : Set N} :
    UniqueMdiffOn I (h ⁻¹' s) ↔ UniqueMdiffOn J s :=
  h.symm_image_eq_preimage s ▸ h.symm.uniqueMdiffOn_image hn
#align diffeomorph.unique_mdiff_on_preimage Diffeomorph.uniqueMdiffOn_preimage

@[simp]
theorem uniqueDiffOn_image (h : E ≃ₘ^n[𝕜] F) (hn : 1 ≤ n) {s : Set E} :
    UniqueDiffOn 𝕜 (h '' s) ↔ UniqueDiffOn 𝕜 s := by
  simp only [← uniqueMdiffOn_iff_uniqueDiffOn, unique_mdiff_on_image, hn]
#align diffeomorph.unique_diff_on_image Diffeomorph.uniqueDiffOn_image

@[simp]
theorem uniqueDiffOn_preimage (h : E ≃ₘ^n[𝕜] F) (hn : 1 ≤ n) {s : Set F} :
    UniqueDiffOn 𝕜 (h ⁻¹' s) ↔ UniqueDiffOn 𝕜 s :=
  h.symm_image_eq_preimage s ▸ h.symm.uniqueDiffOn_image hn
#align diffeomorph.unique_diff_on_preimage Diffeomorph.uniqueDiffOn_preimage

end Diffeomorph

namespace ContinuousLinearEquiv

variable (e : E ≃L[𝕜] E')

/-- A continuous linear equivalence between normed spaces is a diffeomorphism. -/
def toDiffeomorph : E ≃ₘ[𝕜] E'
    where
  contMdiff_toFun := e.ContDiff.ContMdiff
  contMdiff_inv_fun := e.symm.ContDiff.ContMdiff
  toEquiv := e.toLinearEquiv.toEquiv
#align continuous_linear_equiv.to_diffeomorph ContinuousLinearEquiv.toDiffeomorph

@[simp]
theorem coe_toDiffeomorph : ⇑e.toDiffeomorph = e :=
  rfl
#align continuous_linear_equiv.coe_to_diffeomorph ContinuousLinearEquiv.coe_toDiffeomorph

@[simp]
theorem symm_toDiffeomorph : e.symm.toDiffeomorph = e.toDiffeomorph.symm :=
  rfl
#align continuous_linear_equiv.symm_to_diffeomorph ContinuousLinearEquiv.symm_toDiffeomorph

@[simp]
theorem coe_toDiffeomorph_symm : ⇑e.toDiffeomorph.symm = e.symm :=
  rfl
#align continuous_linear_equiv.coe_to_diffeomorph_symm ContinuousLinearEquiv.coe_toDiffeomorph_symm

end ContinuousLinearEquiv

namespace ModelWithCorners

variable (I) (e : E ≃ₘ[𝕜] E')

/-- Apply a diffeomorphism (e.g., a continuous linear equivalence) to the model vector space. -/
def transDiffeomorph (I : ModelWithCorners 𝕜 E H) (e : E ≃ₘ[𝕜] E') : ModelWithCorners 𝕜 E' H
    where
  toLocalEquiv := I.toLocalEquiv.trans e.toEquiv.toLocalEquiv
  source_eq := by simp
  unique_diff' := by simp [range_comp e, I.unique_diff]
  continuous_toFun := e.Continuous.comp I.Continuous
  continuous_invFun := I.continuous_symm.comp e.symm.Continuous
#align model_with_corners.trans_diffeomorph ModelWithCorners.transDiffeomorph

@[simp, mfld_simps]
theorem coe_transDiffeomorph : ⇑(I.transDiffeomorph e) = e ∘ I :=
  rfl
#align model_with_corners.coe_trans_diffeomorph ModelWithCorners.coe_transDiffeomorph

@[simp, mfld_simps]
theorem coe_transDiffeomorph_symm : ⇑(I.transDiffeomorph e).symm = I.symm ∘ e.symm :=
  rfl
#align model_with_corners.coe_trans_diffeomorph_symm ModelWithCorners.coe_transDiffeomorph_symm

theorem transDiffeomorph_range : range (I.transDiffeomorph e) = e '' range I :=
  range_comp e I
#align model_with_corners.trans_diffeomorph_range ModelWithCorners.transDiffeomorph_range

theorem coe_extChartAt_transDiffeomorph (x : M) :
    ⇑(extChartAt (I.transDiffeomorph e) x) = e ∘ extChartAt I x :=
  rfl
#align model_with_corners.coe_ext_chart_at_trans_diffeomorph ModelWithCorners.coe_extChartAt_transDiffeomorph

theorem coe_extChartAt_transDiffeomorph_symm (x : M) :
    ⇑(extChartAt (I.transDiffeomorph e) x).symm = (extChartAt I x).symm ∘ e.symm :=
  rfl
#align model_with_corners.coe_ext_chart_at_trans_diffeomorph_symm ModelWithCorners.coe_extChartAt_transDiffeomorph_symm

theorem extChartAt_transDiffeomorph_target (x : M) :
    (extChartAt (I.transDiffeomorph e) x).target = e.symm ⁻¹' (extChartAt I x).target := by
  simp only [range_comp e, e.image_eq_preimage, preimage_preimage, mfld_simps]
#align model_with_corners.ext_chart_at_trans_diffeomorph_target ModelWithCorners.extChartAt_transDiffeomorph_target

end ModelWithCorners

namespace Diffeomorph

variable (e : E ≃ₘ[𝕜] F)

instance smoothManifoldWithCorners_transDiffeomorph [SmoothManifoldWithCorners I M] :
    SmoothManifoldWithCorners (I.transDiffeomorph e) M :=
  by
  refine' smoothManifoldWithCorners_of_contDiffOn _ _ fun e₁ e₂ h₁ h₂ => _
  refine'
    e.cont_diff.comp_cont_diff_on
      (((contDiffGroupoid ⊤ I).compatible h₁ h₂).1.comp e.symm.cont_diff.cont_diff_on _)
  mfld_set_tac
#align diffeomorph.smooth_manifold_with_corners_trans_diffeomorph Diffeomorph.smoothManifoldWithCorners_transDiffeomorph

variable (I M)

/-- The identity diffeomorphism between a manifold with model `I` and the same manifold
with model `I.trans_diffeomorph e`. -/
def toTransDiffeomorph (e : E ≃ₘ[𝕜] F) : M ≃ₘ⟮I, I.transDiffeomorph e⟯ M
    where
  toEquiv := Equiv.refl M
  contMdiff_toFun x :=
    by
    refine' contMdiffWithinAt_iff'.2 ⟨continuousWithinAt_id, _⟩
    refine' e.cont_diff.cont_diff_within_at.congr' (fun y hy => _) _
    ·
      simp only [Equiv.coe_refl, id, (· ∘ ·), I.coe_ext_chart_at_trans_diffeomorph,
        (extChartAt I x).right_inv hy.1]
    exact
      ⟨(extChartAt I x).map_source (mem_ext_chart_source I x), trivial, by simp only [mfld_simps]⟩
  contMdiff_inv_fun x :=
    by
    refine' contMdiffWithinAt_iff'.2 ⟨continuousWithinAt_id, _⟩
    refine' e.symm.cont_diff.cont_diff_within_at.congr' (fun y hy => _) _
    · simp only [mem_inter_iff, I.ext_chart_at_trans_diffeomorph_target] at hy
      simp only [Equiv.coe_refl, Equiv.refl_symm, id, (· ∘ ·),
        I.coe_ext_chart_at_trans_diffeomorph_symm, (extChartAt I x).right_inv hy.1]
    exact
      ⟨(extChartAt _ x).map_source (mem_ext_chart_source _ x), trivial, by
        simp only [e.symm_apply_apply, Equiv.refl_symm, Equiv.coe_refl, mfld_simps]⟩
#align diffeomorph.to_trans_diffeomorph Diffeomorph.toTransDiffeomorph

variable {I M}

@[simp]
theorem contMdiffWithinAt_transDiffeomorph_right {f : M' → M} {x s} :
    ContMdiffWithinAt I' (I.transDiffeomorph e) n f s x ↔ ContMdiffWithinAt I' I n f s x :=
  (toTransDiffeomorph I M e).contMdiffWithinAt_diffeomorph_comp_iff le_top
#align diffeomorph.cont_mdiff_within_at_trans_diffeomorph_right Diffeomorph.contMdiffWithinAt_transDiffeomorph_right

@[simp]
theorem contMdiffAt_transDiffeomorph_right {f : M' → M} {x} :
    ContMdiffAt I' (I.transDiffeomorph e) n f x ↔ ContMdiffAt I' I n f x :=
  (toTransDiffeomorph I M e).contMdiffAt_diffeomorph_comp_iff le_top
#align diffeomorph.cont_mdiff_at_trans_diffeomorph_right Diffeomorph.contMdiffAt_transDiffeomorph_right

@[simp]
theorem contMdiffOn_transDiffeomorph_right {f : M' → M} {s} :
    ContMdiffOn I' (I.transDiffeomorph e) n f s ↔ ContMdiffOn I' I n f s :=
  (toTransDiffeomorph I M e).contMdiffOn_diffeomorph_comp_iff le_top
#align diffeomorph.cont_mdiff_on_trans_diffeomorph_right Diffeomorph.contMdiffOn_transDiffeomorph_right

@[simp]
theorem contMdiff_transDiffeomorph_right {f : M' → M} :
    ContMdiff I' (I.transDiffeomorph e) n f ↔ ContMdiff I' I n f :=
  (toTransDiffeomorph I M e).contMdiff_diffeomorph_comp_iff le_top
#align diffeomorph.cont_mdiff_trans_diffeomorph_right Diffeomorph.contMdiff_transDiffeomorph_right

@[simp]
theorem smooth_transDiffeomorph_right {f : M' → M} :
    Smooth I' (I.transDiffeomorph e) f ↔ Smooth I' I f :=
  contMdiff_transDiffeomorph_right e
#align diffeomorph.smooth_trans_diffeomorph_right Diffeomorph.smooth_transDiffeomorph_right

@[simp]
theorem contMdiffWithinAt_transDiffeomorph_left {f : M → M'} {x s} :
    ContMdiffWithinAt (I.transDiffeomorph e) I' n f s x ↔ ContMdiffWithinAt I I' n f s x :=
  ((toTransDiffeomorph I M e).contMdiffWithinAt_comp_diffeomorph_iff le_top).symm
#align diffeomorph.cont_mdiff_within_at_trans_diffeomorph_left Diffeomorph.contMdiffWithinAt_transDiffeomorph_left

@[simp]
theorem contMdiffAt_transDiffeomorph_left {f : M → M'} {x} :
    ContMdiffAt (I.transDiffeomorph e) I' n f x ↔ ContMdiffAt I I' n f x :=
  ((toTransDiffeomorph I M e).contMdiffAt_comp_diffeomorph_iff le_top).symm
#align diffeomorph.cont_mdiff_at_trans_diffeomorph_left Diffeomorph.contMdiffAt_transDiffeomorph_left

@[simp]
theorem contMdiffOn_transDiffeomorph_left {f : M → M'} {s} :
    ContMdiffOn (I.transDiffeomorph e) I' n f s ↔ ContMdiffOn I I' n f s :=
  ((toTransDiffeomorph I M e).contMdiffOn_comp_diffeomorph_iff le_top).symm
#align diffeomorph.cont_mdiff_on_trans_diffeomorph_left Diffeomorph.contMdiffOn_transDiffeomorph_left

@[simp]
theorem contMdiff_transDiffeomorph_left {f : M → M'} :
    ContMdiff (I.transDiffeomorph e) I' n f ↔ ContMdiff I I' n f :=
  ((toTransDiffeomorph I M e).contMdiff_comp_diffeomorph_iff le_top).symm
#align diffeomorph.cont_mdiff_trans_diffeomorph_left Diffeomorph.contMdiff_transDiffeomorph_left

@[simp]
theorem smooth_transDiffeomorph_left {f : M → M'} :
    Smooth (I.transDiffeomorph e) I' f ↔ Smooth I I' f :=
  e.contMdiff_transDiffeomorph_left
#align diffeomorph.smooth_trans_diffeomorph_left Diffeomorph.smooth_transDiffeomorph_left

end Diffeomorph


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Zhangir Azerbayev, Adam Topaz, Eric Wieser

! This file was ported from Lean 3 source module linear_algebra.exterior_algebra.basic
! leanprover-community/mathlib commit b8d2eaa69d69ce8f03179a5cda774fc0cde984e4
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.CliffordAlgebra.Basic
import Mathbin.LinearAlgebra.Alternating

/-!
# Exterior Algebras

We construct the exterior algebra of a module `M` over a commutative semiring `R`.

## Notation

The exterior algebra of the `R`-module `M` is denoted as `exterior_algebra R M`.
It is endowed with the structure of an `R`-algebra.

Given a linear morphism `f : M → A` from a module `M` to another `R`-algebra `A`, such that
`cond : ∀ m : M, f m * f m = 0`, there is a (unique) lift of `f` to an `R`-algebra morphism,
which is denoted `exterior_algebra.lift R f cond`.

The canonical linear map `M → exterior_algebra R M` is denoted `exterior_algebra.ι R`.

## Theorems

The main theorems proved ensure that `exterior_algebra R M` satisfies the universal property
of the exterior algebra.
1. `ι_comp_lift` is  fact that the composition of `ι R` with `lift R f cond` agrees with `f`.
2. `lift_unique` ensures the uniqueness of `lift R f cond` with respect to 1.

## Definitions

* `ι_multi` is the `alternating_map` corresponding to the wedge product of `ι R m` terms.

## Implementation details

The exterior algebra of `M` is constructed as simply `clifford_algebra (0 : quadratic_form R M)`,
as this avoids us having to duplicate API.
-/

universe u1 u2 u3

variable (R : Type u1) [CommRing R]

variable (M : Type u2) [AddCommGroup M] [Module R M]

/-- The exterior algebra of an `R`-module `M`.
-/
@[reducible]
def ExteriorAlgebra :=
  CliffordAlgebra (0 : QuadraticForm R M)
#align exterior_algebra ExteriorAlgebra

namespace ExteriorAlgebra

variable {M}

/-- The canonical linear map `M →ₗ[R] exterior_algebra R M`.
-/
@[reducible]
def ι : M →ₗ[R] ExteriorAlgebra R M :=
  CliffordAlgebra.ι _
#align exterior_algebra.ι ExteriorAlgebra.ι

variable {R}

/-- As well as being linear, `ι m` squares to zero -/
@[simp]
theorem ι_sq_zero (m : M) : ι R m * ι R m = 0 :=
  (CliffordAlgebra.ι_sq_scalar _ m).trans <| map_zero _
#align exterior_algebra.ι_sq_zero ExteriorAlgebra.ι_sq_zero

variable {A : Type _} [Semiring A] [Algebra R A]

@[simp]
theorem comp_ι_sq_zero (g : ExteriorAlgebra R M →ₐ[R] A) (m : M) : g (ι R m) * g (ι R m) = 0 := by
  rw [← AlgHom.map_mul, ι_sq_zero, AlgHom.map_zero]
#align exterior_algebra.comp_ι_sq_zero ExteriorAlgebra.comp_ι_sq_zero

variable (R)

/-- Given a linear map `f : M →ₗ[R] A` into an `R`-algebra `A`, which satisfies the condition:
`cond : ∀ m : M, f m * f m = 0`, this is the canonical lift of `f` to a morphism of `R`-algebras
from `exterior_algebra R M` to `A`.
-/
@[simps symm_apply]
def lift : { f : M →ₗ[R] A // ∀ m, f m * f m = 0 } ≃ (ExteriorAlgebra R M →ₐ[R] A) :=
  Equiv.trans (Equiv.subtypeEquiv (Equiv.refl _) <| by simp) <| CliffordAlgebra.lift _
#align exterior_algebra.lift ExteriorAlgebra.lift

@[simp]
theorem ι_comp_lift (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = 0) :
    (lift R ⟨f, cond⟩).toLinearMap.comp (ι R) = f :=
  CliffordAlgebra.ι_comp_lift f _
#align exterior_algebra.ι_comp_lift ExteriorAlgebra.ι_comp_lift

@[simp]
theorem lift_ι_apply (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = 0) (x) :
    lift R ⟨f, cond⟩ (ι R x) = f x :=
  CliffordAlgebra.lift_ι_apply f _ x
#align exterior_algebra.lift_ι_apply ExteriorAlgebra.lift_ι_apply

@[simp]
theorem lift_unique (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = 0) (g : ExteriorAlgebra R M →ₐ[R] A) :
    g.toLinearMap.comp (ι R) = f ↔ g = lift R ⟨f, cond⟩ :=
  CliffordAlgebra.lift_unique f _ _
#align exterior_algebra.lift_unique ExteriorAlgebra.lift_unique

variable {R M}

@[simp]
theorem lift_comp_ι (g : ExteriorAlgebra R M →ₐ[R] A) :
    lift R ⟨g.toLinearMap.comp (ι R), comp_ι_sq_zero _⟩ = g :=
  CliffordAlgebra.lift_comp_ι g
#align exterior_algebra.lift_comp_ι ExteriorAlgebra.lift_comp_ι

/-- See note [partially-applied ext lemmas]. -/
@[ext]
theorem hom_ext {f g : ExteriorAlgebra R M →ₐ[R] A}
    (h : f.toLinearMap.comp (ι R) = g.toLinearMap.comp (ι R)) : f = g :=
  CliffordAlgebra.hom_ext h
#align exterior_algebra.hom_ext ExteriorAlgebra.hom_ext

/-- If `C` holds for the `algebra_map` of `r : R` into `exterior_algebra R M`, the `ι` of `x : M`,
and is preserved under addition and muliplication, then it holds for all of `exterior_algebra R M`.
-/
@[elab_as_elim]
theorem induction {C : ExteriorAlgebra R M → Prop}
    (h_grade0 : ∀ r, C (algebraMap R (ExteriorAlgebra R M) r)) (h_grade1 : ∀ x, C (ι R x))
    (h_mul : ∀ a b, C a → C b → C (a * b)) (h_add : ∀ a b, C a → C b → C (a + b))
    (a : ExteriorAlgebra R M) : C a :=
  CliffordAlgebra.induction h_grade0 h_grade1 h_mul h_add a
#align exterior_algebra.induction ExteriorAlgebra.induction

/-- The left-inverse of `algebra_map`. -/
def algebraMapInv : ExteriorAlgebra R M →ₐ[R] R :=
  ExteriorAlgebra.lift R ⟨(0 : M →ₗ[R] R), fun m => by simp⟩
#align exterior_algebra.algebra_map_inv ExteriorAlgebra.algebraMapInv

variable (M)

theorem algebraMap_leftInverse :
    Function.LeftInverse algebraMapInv (algebraMap R <| ExteriorAlgebra R M) := fun x => by
  simp [algebra_map_inv]
#align exterior_algebra.algebra_map_left_inverse ExteriorAlgebra.algebraMap_leftInverse

@[simp]
theorem algebraMap_inj (x y : R) :
    algebraMap R (ExteriorAlgebra R M) x = algebraMap R (ExteriorAlgebra R M) y ↔ x = y :=
  (algebraMap_leftInverse M).Injective.eq_iff
#align exterior_algebra.algebra_map_inj ExteriorAlgebra.algebraMap_inj

@[simp]
theorem algebraMap_eq_zero_iff (x : R) : algebraMap R (ExteriorAlgebra R M) x = 0 ↔ x = 0 :=
  map_eq_zero_iff (algebraMap _ _) (algebraMap_leftInverse _).Injective
#align exterior_algebra.algebra_map_eq_zero_iff ExteriorAlgebra.algebraMap_eq_zero_iff

@[simp]
theorem algebraMap_eq_one_iff (x : R) : algebraMap R (ExteriorAlgebra R M) x = 1 ↔ x = 1 :=
  map_eq_one_iff (algebraMap _ _) (algebraMap_leftInverse _).Injective
#align exterior_algebra.algebra_map_eq_one_iff ExteriorAlgebra.algebraMap_eq_one_iff

theorem isUnit_algebraMap (r : R) : IsUnit (algebraMap R (ExteriorAlgebra R M) r) ↔ IsUnit r :=
  isUnit_map_of_leftInverse _ (algebraMap_leftInverse M)
#align exterior_algebra.is_unit_algebra_map ExteriorAlgebra.isUnit_algebraMap

/-- Invertibility in the exterior algebra is the same as invertibility of the base ring. -/
@[simps]
def invertibleAlgebraMapEquiv (r : R) :
    Invertible (algebraMap R (ExteriorAlgebra R M) r) ≃ Invertible r :=
  invertibleEquivOfLeftInverse _ _ _ (algebraMap_leftInverse M)
#align exterior_algebra.invertible_algebra_map_equiv ExteriorAlgebra.invertibleAlgebraMapEquiv

variable {M}

/-- The canonical map from `exterior_algebra R M` into `triv_sq_zero_ext R M` that sends
`exterior_algebra.ι` to `triv_sq_zero_ext.inr`. -/
def toTrivSqZeroExt [Module Rᵐᵒᵖ M] [IsCentralScalar R M] :
    ExteriorAlgebra R M →ₐ[R] TrivSqZeroExt R M :=
  lift R ⟨TrivSqZeroExt.inrHom R M, fun m => TrivSqZeroExt.inr_mul_inr R m m⟩
#align exterior_algebra.to_triv_sq_zero_ext ExteriorAlgebra.toTrivSqZeroExt

@[simp]
theorem toTrivSqZeroExt_ι [Module Rᵐᵒᵖ M] [IsCentralScalar R M] (x : M) :
    toTrivSqZeroExt (ι R x) = TrivSqZeroExt.inr x :=
  lift_ι_apply _ _ _ _
#align exterior_algebra.to_triv_sq_zero_ext_ι ExteriorAlgebra.toTrivSqZeroExt_ι

/-- The left-inverse of `ι`.

As an implementation detail, we implement this using `triv_sq_zero_ext` which has a suitable
algebra structure. -/
def ιInv : ExteriorAlgebra R M →ₗ[R] M :=
  by
  letI : Module Rᵐᵒᵖ M := Module.compHom _ ((RingHom.id R).fromOpposite mul_comm)
  haveI : IsCentralScalar R M := ⟨fun r m => rfl⟩
  exact (TrivSqZeroExt.sndHom R M).comp to_triv_sq_zero_ext.to_linear_map
#align exterior_algebra.ι_inv ExteriorAlgebra.ιInv

theorem ι_leftInverse : Function.LeftInverse ιInv (ι R : M → ExteriorAlgebra R M) := fun x => by
  simp [ι_inv]
#align exterior_algebra.ι_left_inverse ExteriorAlgebra.ι_leftInverse

variable (R)

@[simp]
theorem ι_inj (x y : M) : ι R x = ι R y ↔ x = y :=
  ι_leftInverse.Injective.eq_iff
#align exterior_algebra.ι_inj ExteriorAlgebra.ι_inj

variable {R}

@[simp]
theorem ι_eq_zero_iff (x : M) : ι R x = 0 ↔ x = 0 := by rw [← ι_inj R x 0, LinearMap.map_zero]
#align exterior_algebra.ι_eq_zero_iff ExteriorAlgebra.ι_eq_zero_iff

@[simp]
theorem ι_eq_algebraMap_iff (x : M) (r : R) : ι R x = algebraMap R _ r ↔ x = 0 ∧ r = 0 :=
  by
  refine' ⟨fun h => _, _⟩
  · letI : Module Rᵐᵒᵖ M := Module.compHom _ ((RingHom.id R).fromOpposite mul_comm)
    haveI : IsCentralScalar R M := ⟨fun r m => rfl⟩
    have hf0 : to_triv_sq_zero_ext (ι R x) = (0, x) := to_triv_sq_zero_ext_ι _
    rw [h, AlgHom.commutes] at hf0
    have : r = 0 ∧ 0 = x := Prod.ext_iff.1 hf0
    exact this.symm.imp_left Eq.symm
  · rintro ⟨rfl, rfl⟩
    rw [LinearMap.map_zero, RingHom.map_zero]
#align exterior_algebra.ι_eq_algebra_map_iff ExteriorAlgebra.ι_eq_algebraMap_iff

@[simp]
theorem ι_ne_one [Nontrivial R] (x : M) : ι R x ≠ 1 :=
  by
  rw [← (algebraMap R (ExteriorAlgebra R M)).map_one, Ne.def, ι_eq_algebra_map_iff]
  exact one_ne_zero ∘ And.right
#align exterior_algebra.ι_ne_one ExteriorAlgebra.ι_ne_one

/-- The generators of the exterior algebra are disjoint from its scalars. -/
theorem ι_range_disjoint_one :
    Disjoint (LinearMap.range (ι R : M →ₗ[R] ExteriorAlgebra R M))
      (1 : Submodule R (ExteriorAlgebra R M)) :=
  by
  rw [Submodule.disjoint_def]
  rintro _ ⟨x, hx⟩ ⟨r, rfl : algebraMap _ _ _ = _⟩
  rw [ι_eq_algebra_map_iff x] at hx
  rw [hx.2, RingHom.map_zero]
#align exterior_algebra.ι_range_disjoint_one ExteriorAlgebra.ι_range_disjoint_one

@[simp]
theorem ι_add_mul_swap (x y : M) : ι R x * ι R y + ι R y * ι R x = 0 :=
  calc
    _ = ι R (x + y) * ι R (x + y) := by simp [mul_add, add_mul]
    _ = _ := ι_sq_zero _

#align exterior_algebra.ι_add_mul_swap ExteriorAlgebra.ι_add_mul_swap

theorem ι_mul_prod_list {n : ℕ} (f : Fin n → M) (i : Fin n) :
    (ι R <| f i) * (List.ofFn fun i => ι R <| f i).Prod = 0 :=
  by
  induction' n with n hn
  · exact i.elim0
  · rw [List.ofFn_succ, List.prod_cons, ← mul_assoc]
    by_cases h : i = 0
    · rw [h, ι_sq_zero, MulZeroClass.zero_mul]
    · replace hn := congr_arg ((· * ·) <| ι R <| f 0) (hn (fun i => f <| Fin.succ i) (i.pred h))
      simp only at hn
      rw [Fin.succ_pred, ← mul_assoc, MulZeroClass.mul_zero] at hn
      refine' (eq_zero_iff_eq_zero_of_add_eq_zero _).mp hn
      rw [← add_mul, ι_add_mul_swap, MulZeroClass.zero_mul]
#align exterior_algebra.ι_mul_prod_list ExteriorAlgebra.ι_mul_prod_list

variable (R)

/-- The product of `n` terms of the form `ι R m` is an alternating map.

This is a special case of `multilinear_map.mk_pi_algebra_fin`, and the exterior algebra version of
`tensor_algebra.tprod`. -/
def ιMulti (n : ℕ) : AlternatingMap R M (ExteriorAlgebra R M) (Fin n) :=
  let F := (MultilinearMap.mkPiAlgebraFin R n (ExteriorAlgebra R M)).compLinearMap fun i => ι R
  {-- one of the repeated terms is on the left
    -- ignore the left-most term and induct on the remaining ones, decrementing indices
    F with
    map_eq_zero_of_eq' := fun f x y hfxy hxy =>
      by
      rw [MultilinearMap.compLinearMap_apply, MultilinearMap.mkPiAlgebraFin_apply]
      clear F
      wlog h : x < y
      · exact this n f y x hfxy.symm hxy.symm (hxy.lt_or_lt.resolve_left h)
      clear hxy
      induction' n with n hn
      · exact x.elim0
      · rw [List.ofFn_succ, List.prod_cons]
        by_cases hx : x = 0
        · rw [hx] at hfxy h
          rw [hfxy, ← Fin.succ_pred y (ne_of_lt h).symm]
          exact ι_mul_prod_list (f ∘ Fin.succ) _
        · convert MulZeroClass.mul_zero _
          refine'
            hn (fun i => f <| Fin.succ i) (x.pred hx)
              (y.pred (ne_of_lt <| lt_of_le_of_lt x.zero_le h).symm) _ (fin.pred_lt_pred_iff.mpr h)
          simp only [Fin.succ_pred]
          exact hfxy
    toFun := F }
#align exterior_algebra.ι_multi ExteriorAlgebra.ιMulti

variable {R}

theorem ιMulti_apply {n : ℕ} (v : Fin n → M) : ιMulti R n v = (List.ofFn fun i => ι R (v i)).Prod :=
  rfl
#align exterior_algebra.ι_multi_apply ExteriorAlgebra.ιMulti_apply

@[simp]
theorem ιMulti_zero_apply (v : Fin 0 → M) : ιMulti R 0 v = 1 :=
  rfl
#align exterior_algebra.ι_multi_zero_apply ExteriorAlgebra.ιMulti_zero_apply

@[simp]
theorem ιMulti_succ_apply {n : ℕ} (v : Fin n.succ → M) :
    ιMulti R _ v = ι R (v 0) * ιMulti R _ (Matrix.vecTail v) :=
  (congr_arg List.prod (List.ofFn_succ _)).trans List.prod_cons
#align exterior_algebra.ι_multi_succ_apply ExteriorAlgebra.ιMulti_succ_apply

theorem ιMulti_succ_curryLeft {n : ℕ} (m : M) :
    (ιMulti R n.succ).curryLeft m = (LinearMap.mulLeft R (ι R m)).compAlternatingMap (ιMulti R n) :=
  AlternatingMap.ext fun v =>
    (ιMulti_succ_apply _).trans <| by
      simp_rw [Matrix.tail_cons]
      rfl
#align exterior_algebra.ι_multi_succ_curry_left ExteriorAlgebra.ιMulti_succ_curryLeft

end ExteriorAlgebra

namespace TensorAlgebra

variable {R M}

/-- The canonical image of the `tensor_algebra` in the `exterior_algebra`, which maps
`tensor_algebra.ι R x` to `exterior_algebra.ι R x`. -/
def toExterior : TensorAlgebra R M →ₐ[R] ExteriorAlgebra R M :=
  TensorAlgebra.lift R (ExteriorAlgebra.ι R : M →ₗ[R] ExteriorAlgebra R M)
#align tensor_algebra.to_exterior TensorAlgebra.toExterior

@[simp]
theorem toExterior_ι (m : M) : (TensorAlgebra.ι R m).toExterior = ExteriorAlgebra.ι R m := by
  simp [to_exterior]
#align tensor_algebra.to_exterior_ι TensorAlgebra.toExterior_ι

end TensorAlgebra