/-
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.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.ring_quot
import Mathlib.linear_algebra.tensor_algebra
import Mathlib.linear_algebra.alternating
import Mathlib.group_theory.perm.sign
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# Exterior Algebras

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

## Notation

The exterior algebra of the `R`-semimodule `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 semimodule `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 a quotient of the tensor algebra, as follows.
1. We define a relation `exterior_algebra.rel R M` on `tensor_algebra R M`.
   This is the smallest relation which identifies squares of elements of `M` with `0`.
2. The exterior algebra is the quotient of the tensor algebra by this relation.

-/

namespace exterior_algebra

/-- `rel` relates each `ι m * ι m`, for `m : M`, with `0`.

The exterior algebra of `M` is defined as the quotient modulo this relation.
-/
inductive rel (R : Type u_1) [comm_semiring R] (M : Type u_2) [add_comm_monoid M] [semimodule R M] :
    tensor_algebra R M → tensor_algebra R M → Prop
    where
| of : ∀ (m : M), rel R M (coe_fn (tensor_algebra.ι R) m * coe_fn (tensor_algebra.ι R) m) 0

end exterior_algebra

/--
The exterior algebra of an `R`-semimodule `M`.
-/
def exterior_algebra (R : Type u_1) [comm_semiring R] (M : Type u_2) [add_comm_monoid M]
    [semimodule R M] :=
  ring_quot sorry

namespace exterior_algebra

-- typeclass resolution times out here, so we give it a hand

protected instance ring {M : Type u_2} [add_comm_monoid M] {S : Type u_1} [comm_ring S]
    [semimodule S M] : ring (exterior_algebra S M) :=
  let i : ring (tensor_algebra S M) := infer_instance;
  ring_quot.ring (rel S M)

/--
The canonical linear map `M →ₗ[R] exterior_algebra R M`.
-/
def ι (R : Type u_1) [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] :
    linear_map R M (exterior_algebra R M) :=
  linear_map.comp (alg_hom.to_linear_map (ring_quot.mk_alg_hom R (rel R M))) (tensor_algebra.ι R)

/-- As well as being linear, `ι m` squares to zero -/
@[simp] theorem ι_square_zero {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M]
    [semimodule R M] (m : M) : coe_fn (ι R) m * coe_fn (ι R) m = 0 :=
  sorry

@[simp] theorem comp_ι_square_zero {R : Type u_1} [comm_semiring R] {M : Type u_2}
    [add_comm_monoid M] [semimodule R M] {A : Type u_3} [semiring A] [algebra R A]
    (g : alg_hom R (exterior_algebra R M) A) (m : M) :
    coe_fn g (coe_fn (ι R) m) * coe_fn g (coe_fn (ι R) m) = 0 :=
  sorry

/--
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`.
-/
def lift (R : Type u_1) [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M]
    {A : Type u_3} [semiring A] [algebra R A] :
    (Subtype fun (f : linear_map R M A) => ∀ (m : M), coe_fn f m * coe_fn f m = 0) ≃
        alg_hom R (exterior_algebra R M) A :=
  equiv.mk
    (fun (f : Subtype fun (f : linear_map R M A) => ∀ (m : M), coe_fn f m * coe_fn f m = 0) =>
      coe_fn (ring_quot.lift_alg_hom R)
        { val := coe_fn (tensor_algebra.lift R) ↑f, property := sorry })
    (fun (F : alg_hom R (exterior_algebra R M) A) =>
      { val := linear_map.comp (alg_hom.to_linear_map F) (ι R), property := sorry })
    sorry sorry

@[simp] theorem ι_comp_lift (R : Type u_1) [comm_semiring R] {M : Type u_2} [add_comm_monoid M]
    [semimodule R M] {A : Type u_3} [semiring A] [algebra R A] (f : linear_map R M A)
    (cond : ∀ (m : M), coe_fn f m * coe_fn f m = 0) :
    linear_map.comp (alg_hom.to_linear_map (coe_fn (lift R) { val := f, property := cond })) (ι R) =
        f :=
  iff.mp subtype.mk_eq_mk (equiv.symm_apply_apply (lift R) { val := f, property := cond })

@[simp] theorem lift_ι_apply (R : Type u_1) [comm_semiring R] {M : Type u_2} [add_comm_monoid M]
    [semimodule R M] {A : Type u_3} [semiring A] [algebra R A] (f : linear_map R M A)
    (cond : ∀ (m : M), coe_fn f m * coe_fn f m = 0) (x : M) :
    coe_fn (coe_fn (lift R) { val := f, property := cond }) (coe_fn (ι R) x) = coe_fn f x :=
  iff.mp linear_map.ext_iff (ι_comp_lift R f cond) x

@[simp] theorem lift_unique (R : Type u_1) [comm_semiring R] {M : Type u_2} [add_comm_monoid M]
    [semimodule R M] {A : Type u_3} [semiring A] [algebra R A] (f : linear_map R M A)
    (cond : ∀ (m : M), coe_fn f m * coe_fn f m = 0) (g : alg_hom R (exterior_algebra R M) A) :
    linear_map.comp (alg_hom.to_linear_map g) (ι R) = f ↔
        g = coe_fn (lift R) { val := f, property := cond } :=
  sorry

-- Marking `exterior_algebra` irreducible makes our `ring` instances inaccessible.

-- https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/algebra.2Esemiring_to_ring.20breaks.20semimodule.20typeclass.20lookup/near/212580241

-- For now, we avoid this by not marking it irreducible.

@[simp] theorem lift_comp_ι {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M]
    [semimodule R M] {A : Type u_3} [semiring A] [algebra R A]
    (g : alg_hom R (exterior_algebra R M) A) :
    coe_fn (lift R)
          { val := linear_map.comp (alg_hom.to_linear_map g) (ι R),
            property := comp_ι_square_zero g } =
        g :=
  sorry

/-- See note [partially-applied ext lemmas]. -/
theorem hom_ext {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M]
    {A : Type u_3} [semiring A] [algebra R A] {f : alg_hom R (exterior_algebra R M) A}
    {g : alg_hom R (exterior_algebra R M) A}
    (h :
      linear_map.comp (alg_hom.to_linear_map f) (ι R) =
        linear_map.comp (alg_hom.to_linear_map g) (ι R)) :
    f = g :=
  sorry

/-- The left-inverse of `algebra_map`. -/
def algebra_map_inv {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M]
    [semimodule R M] : alg_hom R (exterior_algebra R M) R :=
  coe_fn (lift R) { val := 0, property := sorry }

theorem algebra_map_left_inverse {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M]
    [semimodule R M] :
    function.left_inverse ⇑algebra_map_inv ⇑(algebra_map R (exterior_algebra R M)) :=
  sorry

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

As an implementation detail, we implement this using `triv_sq_zero_ext` which has a suitable
algebra structure. -/
def ι_inv {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M] :
    linear_map R (exterior_algebra R M) M :=
  linear_map.comp (triv_sq_zero_ext.snd_hom R M)
    (alg_hom.to_linear_map
      (coe_fn (lift R) { val := triv_sq_zero_ext.inr_hom R M, property := sorry }))

theorem ι_left_inverse {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M]
    [semimodule R M] : function.left_inverse ⇑ι_inv ⇑(ι R) :=
  sorry

@[simp] theorem ι_add_mul_swap {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M]
    [semimodule R M] (x : M) (y : M) :
    coe_fn (ι R) x * coe_fn (ι R) y + coe_fn (ι R) y * coe_fn (ι R) x = 0 :=
  sorry

theorem ι_mul_prod_list {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M]
    [semimodule R M] {n : ℕ} (f : fin n → M) (i : fin n) :
    coe_fn (ι R) (f i) * list.prod (list.of_fn fun (i : fin n) => coe_fn (ι R) (f i)) = 0 :=
  sorry

/-- 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` -/
def ι_multi (R : Type u_1) [comm_semiring R] {M : Type u_2} [add_comm_monoid M] [semimodule R M]
    (n : ℕ) : alternating_map R M (exterior_algebra R M) (fin n) :=
  let F : multilinear_map R (fun (i : fin n) => M) (exterior_algebra R M) :=
    multilinear_map.comp_linear_map (multilinear_map.mk_pi_algebra_fin R n (exterior_algebra R M))
      fun (i : fin n) => ι R;
  alternating_map.mk ⇑F sorry sorry sorry

theorem ι_multi_apply {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M]
    [semimodule R M] {n : ℕ} (v : fin n → M) :
    coe_fn (ι_multi R n) v = list.prod (list.of_fn fun (i : fin n) => coe_fn (ι R) (v i)) :=
  rfl

end exterior_algebra

namespace tensor_algebra

/-- The canonical image of the `tensor_algebra` in the `exterior_algebra`, which maps
`tensor_algebra.ι R x` to `exterior_algebra.ι R x`. -/
def to_exterior {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M]
    [semimodule R M] : alg_hom R (tensor_algebra R M) (exterior_algebra R M) :=
  coe_fn (lift R) (exterior_algebra.ι R)

@[simp] theorem to_exterior_ι {R : Type u_1} [comm_semiring R] {M : Type u_2} [add_comm_monoid M]
    [semimodule R M] (m : M) :
    coe_fn to_exterior (coe_fn (ι R) m) = coe_fn (exterior_algebra.ι R) m :=
  sorry

end Mathlib


import lib.lib09

open m154

/-
Le bouquet final

Cette feuille utilise tout le cours de MDD 154 pour démontrer de nombreux
théorèmes parmi les plus subtils de Math 101 : la caractérisation
séquentielle des bornes supérieures, l'équivalence entre continuité
séquentielle et continuité, le fait que toute fonction continue sur un segment
est majorée et atteint son maximum, et enfin le théorème des valeurs
intermédiaires.

Il est inutile d'aborder cette feuille sans être à l'aise avec les feuilles
précédentes. Réviser les feuilles précédentes et poser des questions est toujours
une bonne idée.

On commence par un échauffement, une variante du

  lim_le (hu : limite_suite u x) (ineg : ∀ n, u n ≤ y) : x ≤ y

de la feuille 8, avec l'autre inégalité et seulement à partir d'un certain rang.

On pourra utiliser les lemmes habituels :

  `abs_inferieur_ssi (x y : ℝ) : |x| ≤ y ↔ -y ≤ x ∧ x ≤ y`

  `superieur_max_ssi (p q r) : r ≥ max p q  ↔ r ≥ p ∧ r ≥ q`

  `inferieur_max_gauche p q : p ≤ max p q`

  `inferieur_max_droite p q : q ≤ max p q`

ainsi que le lemme

  `inferieur_si_inferieur_plus_eps : (∀ ε > 0, y ≤ x + ε) →  y ≤ x`

démontré dans la feuille 8
-/

-- Si u tend vers x et y ≤ u_n pour n assez grand n alors y ≤ x.
lemma le_lim {x y : ℝ} {u : ℕ → ℝ} (hu : limite_suite u x)
  (ineg : ∃ N, ∀ n ≥ N, y ≤ u n) : y ≤ x :=
begin
  sorry
end

/-
Le premier objectif sérieux de cette feuille est de démontrer la caractérisation
séquentielle des bornes supérieures. Pour cela, et pour les objectifs suivants,
nous aurons besoin de pas mal de choses des feuilles précédentes, et de
quelques extras.

Nous avons démontré dans la feuille 5 qu'une suite constante converge vers
sa valeur :

  `lim_constante (x : ℝ) : limite_suite (λ n, x) x`

et le théorème des gendarmes :

  `gendarmes (lim_u : limite_suite u l) (lim_w : limite_suite w l)`
    `(hu : ∀ n, u n ≤ v n) (hw : ∀ n, v n ≤ w n)  : limite_suite v l`

Dans la feuille 8, nous avons introduit les deux définitions :

  Le réel x est un majorant de l'ensemble de réels A :
  `def majorant (A : set ℝ) (x : ℝ) := ∀ a ∈ A, a ≤ x`

  Le réel x est une  borne supérieure de l'ensemble de réels A :
  `def borne_sup (A : set ℝ) (x : ℝ) := majorant A x ∧ ∀ y, majorant A y → x ≤ y`

et montré que si un réel x est borne supérieure d'un ensemble de réels A alors,
pour tout y, si y < x alors il existe a dans A strictement plus grand que y.

  `lt_sup (hx : borne_sup A x) : ∀ y, y < x → ∃ a ∈ A, y < a`

Dans les exercices suivants, on pourra aussi utiliser les lemmes

  `inv_succ_pos : ∀ n : ℕ, 1/(n + 1 : ℝ) > 0`

  `limite_inv_succ :  ∀ ε > 0, ∃ N : ℕ, ∀ n ≥ N, 1/(n + 1 : ℝ) ≤ ε`

et les conséquences faciles suivantes de limite_inv_succ :

  `limite_si_inferieur_un_sur (h : ∀ n, |u n - x| ≤ 1/(n+1)) : limite_suite u x`

  `lim_plus_un_sur (x : ℝ) : limite_suite (λ n, x + 1/(n+1)) x`

  `lim_moins_un_sur (x : ℝ) : limite_suite (λ n, x - 1/(n+1)) x`

La structure de la démonstration est offerte. Les accolades servent à
délimiter les objectifs intermédiaires, tout en faisant provisoirement
disparaître l'affichage des objectifs en attente. Il ne faut surtout pas
les supprimer, sous peine de se perdre irrémédiablement.

Enfin on notera l'apparition dans la structure de démonstration ci-dessous
de la commande `Par ... on choisit ... tel que`. Cette commande est décrite
dans la dernière section du chapitre 3 du cours, intitulée
« Utilisation d'un ∀x, ∃y et axiome du choix »
(qu'il convient donc de relire ou de lire), mais n'était pas encore apparue
dans les exercices.
-/

-- Un réel x est borne supérieure d'un ensemble de réels A ssi il est
-- majorant de A et il existe une suite d'éléments de A qui tend vers x.
lemma borne_sup_ssi (A : set ℝ) (x : ℝ) :
(borne_sup A x) ↔ (majorant A x ∧ ∃ u : ℕ → ℝ, limite_suite u x ∧ ∀ n, u n ∈ A) :=
begin
  Montrons que (borne_sup A x) → (majorant A x ∧ ∃ u : ℕ → ℝ, limite_suite u x ∧ ∀ n, u n ∈ A),
  { Supposons h : borne_sup A x,
    Montrons que majorant A x,
    {
  sorry
    },
    Montrons que ∃ (u : ℕ → ℝ), limite_suite u x ∧ ∀ n, u n ∈ A,
    { Fait F1 : ∀ n : ℕ, ∃ a ∈ A, x - 1/(n+1) < a,
      {
  sorry
        },
      Par F1 on choisit u tel que (hu : ∀ n, u n ∈ A) (hu' : ∀ (n : ℕ), x - 1 / (n + 1 : ℝ) < u n),
  sorry
           } },
  {
  sorry
      },
end

/-
Les autres exercices de cette feuille utiliseront la définition de la
continuité d'une fonction de ℝ dans ℝ en un point de ℝ.
-/

/-- La fonction `f` est continue en `x₀`. -/
def continue_en (f : ℝ → ℝ) (x₀ : ℝ) : Prop :=
∀ ε > 0, ∃ δ > 0, ∀ x, |x - x₀| ≤ δ → |f x - f x₀| ≤ ε

-- Dans la suite, f désignera une fonction de ℝ dans ℝ, x₀ un réel et u
-- une suite de réels
variables {f : ℝ → ℝ} {x₀ : ℝ} {u : ℕ → ℝ}

/-
On commence par un échauffement concernant définition de la continuité.
-/

/-- Une fonction continue en x₀ est séquentiellement continue en x₀ -/
lemma seq_continue_si_continue (hf : continue_en f x₀)
  (hu : limite_suite u x₀) : limite_suite (f ∘ u) (f x₀) :=
begin
  sorry
end

/-
La réciproque de du lemme précédent est vraie aussi :
La continuité séquentielle en x₀ implique la continuité en x₀.
Mais la démonstration est moins courte. On pourra s'inspirer de
la démonstration de borne_sup_ssi (et du poly de math 101 !).
-/
example :
  (∀ u : ℕ → ℝ, limite_suite u x₀ → limite_suite (f ∘ u) (f x₀)) →
  continue_en f x₀ :=
begin
  sorry
end

/-
Dans la suite, étant donnés deux réels,
on utilise la notation habituelle [a, b] pour désigner le segment [a, b].
Attention, si par malheur b < a alors ce segment est vide. C'est un peu
une question de convention, mais notre définition d'un segment assure le
lemme suivant (dont l'utilisation est rarement nécessaire vu qu'il ne fait que
déplier une définition).
-/

lemma dans_segment {a b x : ℝ}  : x ∈ [a, b] ↔ a ≤ x ∧ x ≤ b :=
iff.rfl -- cette ligne signifie : « C'est équivalent par définition. »

/-
Nous avons vu dans la feuille 6 les définitions et le lemme :

Une extraction est une fonction strictement croissante de ℕ dans ℕ :

  `def extraction (φ : ℕ → ℕ) := ∀ n m, n < m → φ n < φ m`

Un réel a est valeur d'adhérence d'une suite u s'il
existe une suite extraite de u qui tend vers a.

  `def valeur_adherence (u : ℕ → ℝ) (a : ℝ) := ∃ φ, extraction φ ∧ limite_suite (u ∘ φ) a`

Toute extraction est supérieure à l'identité :

  `extraction_superieur_id : extraction φ → ∀ n, n ≤ φ n`

Et dans la feuille 8 la définition et le lemme :

La suite u tend vers +∞.

  `def limite_infinie_suite (u : ℕ → ℝ) := ∀ A, ∃ N, ∀ n ≥ N, u n ≥ A`

Si u tend vers +∞ alors u ne tend vers aucune limite finie

  `limite_infinie_pas_finie : limite_infinie_suite u → ∀ l, ¬ limite_suite u l`
-/

-- Dans la suite, φ sera une fonction de ℕ dans ℕ
variables {φ : ℕ → ℕ}

/-- Si `u` tend vers `+∞` alors toutes ses suites extraites tendent vers `+∞`. -/
lemma limite_infinie_extraction_si_limite
  (h : limite_infinie_suite u) (hφ : extraction φ) :
limite_infinie_suite (u ∘ φ) :=
begin
  sorry
end

lemma limite_infinie_gendarme {u v : ℕ → ℝ} (hu : limite_infinie_suite u)
(huv : ∀ n, u n ≤ v n) : limite_infinie_suite v :=
begin
  sorry
end

/-
Dans la suite, on pourra aussi utiliser le théorème de Bolzano-Weirstrass :

Toute suite à valeur dans un segment [a, b] admet une valeur d'adhérence
dans [a, b].

  `bolzano_weierstrass (h : ∀ n, u n ∈ [a, b]) : ∃ c ∈ [a, b], valeur_adherence u c`

Ce théorème se démontre à partir du théorème de la borne supérieure, mais il
faut construire une suite par récurrence, ce que nous n'avons pas appris à
faire dans Lean.

On pourra utiliser aussi le lemme suivant, qui lui est évident

  `limite_suite_id : limite_infinie_suite (λ n, n)`
-/

-- Toute fonction continue sur un segment y est majorée.
lemma majoree_segment {f : ℝ → ℝ} {a b : ℝ} (hf : ∀ x ∈ [a, b], continue_en f x) :
∃ M, ∀ x ∈ [a, b], f x ≤ M :=
begin
  sorry
end

/-
Pour l'exercice suivant, on pourra utiliser le lemme

  `abs_neg x : |-x| = |x|`
-/

-- Si f est continue en x₀ alors -f est aussi continue en x₀
lemma continue_opposee {f : ℝ → ℝ} {x₀ : ℝ} (h : continue_en f x₀) :
  continue_en (λ x, -f x) x₀ :=
begin
  sorry
end

-- Toute fonction continue sur un segment y est minorée.
lemma minoree_segment {f : ℝ → ℝ} {a b : ℝ} (hf : ∀ x ∈ [a, b], continue_en f x) :
∃ m, ∀ x ∈ [a, b], m ≤ f x :=
begin
  Fait clef : ∃ M, ∀ x ∈ [a, b], -f x ≤ M,
  {
  sorry
  },
  sorry
end

/-
Nous avons démontré dans la feuille 5 qu'une suite a au plus une limite :

 `unicite_limite : limite_suite u l → limite_suite u l' → l = l'`

et démontré dans la feuille 6 que,si u tend vers l alors toutes ses suites
extraites tendent vers l :

  `limite_extraction_si_limite (h : limite_suite u l) (hφ : extraction φ) :`
    `limite_suite (u ∘ φ) l`

On admet une version du théorème de la borne supérieure (qu'on ne peut pas
démontrer sans construire les nombres réels ou admettre un autre théorème
aussi fort) :

`sup_segment {a b : ℝ} {A : set ℝ} (hnonvide : ∃ x, x ∈ A) (h : A ⊆ [a, b]) :`
  `∃ x ∈ [a, b], borne_sup A x`

Dans l'exercice suivant, il peut être utile de démontrer une inclusion
entre ensembles A et B de nombres réels.
Par définition, `A ⊆ B` signifie : `∀ x, x ∈ A → x ∈ B`.
On peut donc commencer la démonstration de A ⊆ B par « Soit (x ∈ A) »
qui fait apparaître « x : ℝ » et « x_mem : x ∈ A  » dans le contexte,
puis démontrer x ∈ B.

On remarquera aussi l'utilisation de la notation
  {x | P x}
qui désigne l'ensemble des x vérifiant le prédicat P.
Par exemple, la définition du segment [a, b] est :
`[a, b] = { x | a ≤ x ∧ x ≤ b }`

Ainsi l'énoncé `y ∈ { x | P x}` signifie `P y`, par définition.

-/

/-- Toute fonction continue sur un segment non vide y admet un maximum. -/
example {a b : ℝ} (hab : a ≤ b) (hf : ∀ x ∈ [a, b], continue_en f x) :
∃ x₀ ∈ [a, b], ∀ x ∈ [a, b], f x ≤ f x₀ :=
begin
  Par minoree_segment appliqué à hf on obtient m
     tel que hm : ∀ (x : ℝ), x ∈ [a, b] → m ≤ f x,
  Par majoree_segment appliqué à hf on obtient M
     tel que hM : ∀ (x : ℝ), x ∈ [a, b] → f x ≤ M,
  Posons A := {y | ∃ x ∈ [a, b], y = f x}, -- A est l'image de [a, b] par f
  Fait etape1 : ∃ y₀ ∈ [m, M], borne_sup A y₀,
  {
  sorry
  },
  Par etape1 on obtient y₀ tel que (y_dans : y₀ ∈ [m, M]) (y_sup : borne_sup A y₀),
  On réécrit via borne_sup_ssi dans y_sup,
  Par y_sup on obtient (y_maj : majorant A y₀)
                       (u : ℕ → ℝ) (lim_u : limite_suite u y₀) (u_dans : ∀ n, u n ∈ A),
  Par u_dans on choisit (v : ℕ → ℝ) tel que
    (v_dans : ∀ n, v n ∈ [a, b]) (hufv : ∀ n, u n = f (v n)),
  Fait hu_eq_comp : u = f ∘ v,
    On conclut par funext appliqué à hufv,
  sorry
end

-- Malheureusement `On combine` ne fait pas tout seul le lemme suivant
lemma stupide {a b x : ℝ} (h : x ∈ [a, b]) (h' : x ≠ b) : x < b :=
begin
  On conclut par lt_of_le_of_ne appliqué à [h.right, h'],
end
/-
Et maintenant le boss final...
-/

/-- Le théorème des valeurs intermédiaires -/
example (f : ℝ → ℝ) (hf : ∀ x, continue_en f x) (h₀ : f 0 < 0) (h₁ : f 1 > 0) :
∃ x₀ ∈ [0, 1], f x₀ = 0 :=
begin
  Posons A := { x | x ∈ [0, 1] ∧ f x < 0},
  Fait ex_x₀ : ∃ x₀ ∈ [0, 1], borne_sup A x₀,
  {
  sorry
  },
  Par ex_x₀ on obtient x₀ tel que x₀_dans x₀_sup,
  Montrons que x₀ convient,
    On conclut par x₀_dans,
  Fait fx₀_neg : f x₀ ≤ 0,
  {
  sorry
  },
  Fait x₀_1: x₀ < 1,
  {
  sorry
  },
  Fait fx₀_pos : f x₀ ≥ 0,
  { Fait dans' : ∃ N : ℕ, ∀ n ≥ N, x₀ + 1/(n+1) ∈ [0, 1],
    { Fait dans'' : ∃ N : ℕ, ∀ n≥ N, 1/(n+1 : ℝ) ≤ 1-x₀,
      {
  sorry
      },
  sorry
    },
    Fait pas_dans : ∀ n : ℕ, x₀ + 1/(n+1) ∉ A,
    -- Par définition, x ∉ A signifie « non (x ∈ A) ».
    {
  sorry
    },
    On reformule pas_dans en ∀ n : ℕ, ¬(x₀ + 1 / (n + 1 : ℝ) ∈ [0, 1] ∧ f (x₀ + 1 / (n + 1 : ℝ)) < 0),
  sorry
  },
  On combine [fx₀_pos, fx₀_neg],
end


import tools.super --.card
open classical nat function set tactic

namespace classical
universe variable u
variables {A : Type u} {p : A → Prop}

local attribute [instance] prop_decidable

theorem decidable.exists_not_of_not_forall [decidable (∃ x, ¬ p x)] [∀ x, decidable (p x)]
  (h : ¬ ∀ x, p x) : ∃ x, ¬ p x :=
decidable.by_contradiction
  (assume h₁, h (take x, decidable.by_contradiction (assume hnpx, h₁ ⟨x, hnpx⟩)))

-- theorem not_forall_of_exists_not (h : ∃ x, ¬ p x) : ¬ ∀ x, p x :=
-- assume h₁, match h with ⟨x, hnpx⟩ := hnpx (h₁ x) end
theorem exists_not_of_not_forall (h : ¬ ∀ x, p x) : ∃ x, ¬ p x :=
decidable.exists_not_of_not_forall h

end classical

theorem ne_nil_desturct {A : Type} {l : list A} : l ≠ [] → ∃ p : A × list A, l = p.1::p.2 :=
list.rec_on l (λ H, absurd rfl H)
(λ a l' IH H, ⟨(a,l'),rfl⟩)
--(λ a l' IH H, ⟨a, ⟨l',rfl⟩⟩)

theorem or_resolve_right {a b : Prop} (h₁ : a ∨ b) (h₂ : ¬a) : b :=
by super

theorem or_resolve_left {a b : Prop} (h₁ : a ∨ b) (h₂ : ¬b) : a :=
by super
theorem lt_of_le_pred' {n m : ℕ} : n ≤ pred m →  n < m ∨ n = 0 :=
nat.rec_on m (λ h, or.elim (lt_or_eq_of_le h) (λ l, by super) (λ r, or.inr r))
(λ a ih h, or.inl (lt_succ_of_le h))

theorem lt_of_le_pred {n m : ℕ} : n ≤ pred m →  n < m ∨ m = 0 :=
nat.rec_on m (λ h, or.inr rfl) (λ a ih h, or.inl (lt_succ_of_le h))

theorem lt_succ_iff_le (m n : nat) : m < succ n ↔ m ≤ n :=
iff.intro le_of_lt_succ lt_succ_of_le

theorem eq_zero_or_eq_succ_pred (n : ℕ) : n = 0 ∨ n = succ (pred n) :=
begin induction n, repeat { super } end

theorem exists_eq_succ_of_ne_zero {n : ℕ} (H : n ≠ 0) : ∃k : ℕ, n = succ k :=
by super with eq_zero_or_eq_succ_pred

theorem succ_pred_of_pos {n : ℕ} (H : n > 0) : succ (pred n) = n :=
eq.symm (or_resolve_right (eq_zero_or_eq_succ_pred n) (ne.symm (ne_of_lt H)))

section
-- some facts about sets in the old library

parameter {X : Type}

theorem ext {a b : set X} (H : ∀x, x ∈ a ↔ x ∈ b) : a = b := funext (λ x, propext (H x))

theorem not_mem_empty (x : X) : ¬ (x ∈ (∅ : set X)) := λ H, H

lemma ne_empty_of_mem {s : set X} {x : X} (h : x ∈ s) : s ≠ ∅ :=
  begin intro hs, rewrite hs at h, apply not_mem_empty _ h end

theorem eq_empty_of_forall_not_mem {s : set X} (H : ∀ x, x ∉ s) : s = ∅ :=
ext (λ x, iff.intro (λ xs, absurd xs (H x)) (λ xe, absurd xe (not_mem_empty _)))

theorem exists_mem_of_ne_empty {s : set X} (H : s ≠ ∅) : ∃ x, x ∈ s :=
by_contradiction (λ H', H (eq_empty_of_forall_not_mem (forall_not_of_not_exists H')))

end

theorem image_nonempty {A B : Type} {f : A → B} {S : set A} (H : S ≠ ∅) : image f  S ≠ ∅ :=
have ∃ x, x ∈ S, from exists_mem_of_ne_empty H,
let ⟨s,h⟩ := this in
have f s ∈ image f S, from ⟨s, ⟨h,rfl⟩⟩,
ne_empty_of_mem this

section set
variable {α : Type}

theorem mem_univ (x : α) : x ∈ @univ α := trivial

theorem empty_ne_univ [h : inhabited α] : (∅ : set α) ≠ univ :=
assume H : ∅ = univ,
absurd (mem_univ (inhabited.default α)) (eq.rec_on H (not_mem_empty _))

theorem ne_empty_of_image_on_univ {A B : Type} (f : A → B) [inhabited A] : image f univ ≠ ∅ :=
have (∅ : set A) ≠ univ, from empty_ne_univ,
have ∃ a, a ∈ (univ : set A), from exists_mem_of_ne_empty (ne.symm this),
let ⟨a,h⟩ := this in
have f a ∈ image f univ, from exists.intro a (and.intro h rfl),
ne_empty_of_mem this

end set

section
-- the least number principle.

def complete_induction_on (n : ℕ) {p : ℕ → Prop} (h : ∀ n, (∀ m < n, p m) → p n) : p n :=
suffices ∀ n, ∀ m < n, p m, from this (succ n) _ (lt_succ_self n),
take n,
nat.rec_on n
  (take m, suppose m < 0, absurd this (not_lt_zero m))
  (take n,
    assume ih : ∀ m < n, p m,
    take m,
    suppose m < succ n,
    or.elim (lt_or_eq_of_le (le_of_lt_succ this))
      (ih m)
      (suppose m = n,
        begin rw this, apply h, exact ih end))

lemma wf_aux {A : set ℕ} (n : ℕ) : n ∈ A → ∃ a, a ∈ A ∧ ∀ b,  b ∈  A → a ≤ b :=
@complete_induction_on n (λ x, x ∈ A → ∃ a, a ∈  A ∧ ∀ b, b ∈ A → a ≤ b)
(λ k ih h, by_cases
(suppose ∃ m, m ∈ A ∧ m <k, let ⟨m, Hmem, Hlt⟩ := this in ih m Hlt Hmem)
(λ Hn, have ∀ m, m ∈  A →  ¬ m < k, by super, ⟨k,h,(λ m h, le_of_not_gt $ this m h)⟩))

theorem wf_of_le (S : set ℕ) (H : S ≠ ∅) : ∃ a, a ∈ S ∧ ∀ b, b ∈ S → a ≤ b :=
let ⟨n,Hn⟩ := exists_mem_of_ne_empty H in wf_aux n Hn

noncomputable definition least (S : set ℕ) (H : S ≠ ∅) : ℕ := some (wf_of_le S H)

theorem least_is_mem (S : set ℕ) (H : S ≠ ∅) : least S H ∈ S :=
let ⟨bound, Ha⟩ := some_spec (wf_of_le S H) in bound

theorem minimality {S : set ℕ} (neq : S ≠ ∅): ∀ x, x ∈ S → least S neq ≤ x :=
λ x Hx, let ⟨bound, Ha⟩ := some_spec (wf_of_le S neq) in Ha x Hx

end

-- lemma nonzero_card_of_finite {A : Type} {S : set A} (H : card S ≠ 0) : finite S :=
-- by_contradiction
-- (suppose ¬ finite S,
-- have card S = 0, from card_of_not_finite this,
-- H this)

-- lemma mem_not_in_diff {A : Type} {S : set A} {a : A} : a ∉ S \ insert a (∅ : set A) :=
-- assume h,
-- have a ∉ insert a (∅ : set A), from not_mem_of_mem_diff h,
-- this (mem_singleton a)

-- lemma insert_of_diff_singleton {A : Type} {S : set A} {a : A} (H : a ∈ S) : insert a (S \ insert a (∅ : set A)) = S :=
-- begin
-- apply eq_of_subset_of_subset,
-- intros x h, apply or.elim h, intro h1, simp [H, h1], -- simp,
-- intro hr, apply and.left hr,
-- intros x h', cases (decidable.em (x ∈ insert a (∅ : set A))),
-- apply or.inl, apply eq_of_mem_singleton, assumption,
-- apply or.inr, apply and.intro, repeat {assumption}
-- end

-- lemma union_of_diff_singleton {A : Type} {S : set A} {a : A} (H : a ∈ S)
--   : S \ (insert a (∅ : set A)) ∪ (insert a (∅ : set A)) = S :=
-- begin
-- apply eq_of_subset_of_subset,
--   intros x h, apply or.elim h, intro hl, apply and.left hl,
--   intro hr, have h : x = a, from (mem_singleton_iff x a)^.mp hr,
--   rewrite h, simp,
--   intros x h', cases (decidable.em (x ∈ insert a (∅ : set A))),
--   apply or.inr, simp, apply or.inl, apply and.intro, repeat {simp}
-- end

-- lemma finite_singleton {A : Type} {a : A} : finite '{a} :=
-- have carda : card '{a} = 1, from card_singleton a,
-- have (1:ℕ) ≠ 0, from dec_trivial,
-- have card '{a} ≠ 0, by+ rewrite -carda at this;exact this,
-- nonzero_card_of_finite this

-- lemma sub_of_eq {A : Type} {S T: set A} (H : S = T) : S ⊆ T :=
-- have T ⊆ T, from subset.refl T,
-- by+ rewrite -H at this{1};exact this

-- theorem ne_empty_of_mem' {X : Type} {s : set X} {x : X} (H : x ∈ s) : s ≠ ∅ :=
-- begin intro Hs, rewrite Hs at H, apply not_mem_empty _ H end --this is on github


import analysis.special_functions.trigonometric

open real
open_locale real

variables (x y : ℝ)

lemma sin_sub' : sin (x - y) = sin x * cos y - cos x * sin y :=
begin
  sorry
end

/- `neg_mul_eq_neg_mul_symm` may be useful -/
lemma sin_sub_pi : sin (π - x) = sin x :=
begin
  sorry
end

example : (sin x) ^ 2 + (cos x)^2 = 1 := sin_sq_add_cos_sq x

-- this may be useful `le_add_of_nonneg_right`
lemma sin_sq_le_one : sin x ^ 2 ≤ 1 :=
begin
  sorry
end

lemma sin_three_mul : sin (3 * x) = 3 * sin x - 4 * sin x ^ 3 :=
begin
  have H : 2*x + x = 3*x := by linarith,
  -- I have no proof for this, but feel it should be pretty easy.
  -- This may be where I make a fool of myself.
  -- But I believe very highly in Lean (and myself).
  sorry
end


import number_theory.padics.padic_norm
import topology.basic
import data.rat.basic
import data.real.cau_seq
import analysis.special_functions.exp_log
import analysis.special_functions.pow
import topology.metric_space.basic
import topology.homeomorph
import topology.algebra.group_with_zero
import data.nat.prime
import data.nat.basic
import tactic.apply
import tactic.linarith
import topology.metric_space.basic
import ring_theory.unique_factorization_domain

import abvs_equiv
import for_mathlib.exp_log
import ostrowski.rationals.bounded
import ostrowski.rationals.unbounded

import for_mathlib.rat

section
open_locale classical
open list option is_absolute_value
noncomputable theory

variables {α : Type*} [ring α]

def equiv_abs (α: ℝ) := λ q: ℚ, ((abs q: ℝ) ^ α)

def equiv_abs_neg (α: ℝ): ∀ q: ℚ, equiv_abs α (-q) = equiv_abs α q :=
begin
  intro q,
  unfold equiv_abs,
  push_cast,
  rw neg_eq_neg_one_mul,
  simp,
end

def equiv_abs_one {α: ℝ}: equiv_abs α 1 = 1 :=
begin
  unfold equiv_abs,
  simp,
end

def hom_of_equiv_abs (α: ℝ) (α_ne_zero: α ≠ 0):
  monoid_with_zero_hom ℚ ℝ := {
    to_fun := equiv_abs α,
    map_zero' := by {
      unfold equiv_abs,
      norm_cast,
      exact real.zero_rpow α_ne_zero,
    },
    map_one' := by {
      unfold equiv_abs,
      norm_cast,
      exact real.one_rpow α,
    },
    map_mul' := by {
      unfold equiv_abs,
      intros x y,
      push_cast,
      rw abs_mul,
      rw real.mul_rpow (abs_nonneg x) (abs_nonneg y),
    },
  }

lemma rat_abs_val_unbounded_real (abv: ℚ → ℝ)
    [habv : is_absolute_value abv]
    (exists_nat_unbounded : ¬ (∀ z : ℕ, abv (↑z) ≤ 1)):
    --∃ α: ℝ, abv = equiv_abs α :=
    abvs_equiv abv (λ x: ℚ, abs x) :=
    begin
        push_neg at exists_nat_unbounded,
        -- we want the smallest.
        set n₀ := nat.find exists_nat_unbounded,
        have n₀_spec := nat.find_spec exists_nat_unbounded,
        have n₀_smallest_spec: ∀ (a: ℕ), a < n₀ → abv a ≤ 1,
        {
          intros a ha,
          exact not_lt.1 (nat.find_min exists_nat_unbounded ha),
        },
        have aux0: ∀ (m: ℕ) (h: m ≤ 1), ¬ (1 < abv m),
        {
          intros m h,
          push_neg,
          have: m = 0 ∨ m = 1 := by dec_trivial!,
          apply or.elim this,
          intro h_zero,
          rw h_zero,
          rw_mod_cast is_absolute_value.abv_zero abv,
          exact zero_le_one,
          intro h_one,
          rw h_one,
          rw_mod_cast is_absolute_value.abv_one abv,
        },
        have n₀_not_one: n₀ > 1 := (nat.lt_find_iff exists_nat_unbounded 1).2 aux0, -- necessarily, n₀ > 1
        have n₀_ge_two: n₀ ≥ 2 := by linarith,
        apply abvs_equiv_symmetric,
        set α := real.log (abv n₀) / real.log n₀ with h_α,
        have h_n0_pow_α_eq_abv_n0: abv n₀ = n₀^α,
        {
          rw [real.rpow_def_of_pos, h_α, ← mul_div_assoc, mul_div_cancel_left, real.exp_log],
          apply (is_absolute_value.abv_pos abv).2,
          apply ne_of_gt,
          -- we throw this goal for now and we will focus on the log.
          -- so we can provide the same proof for the two similar goals.
          rotate 1,
          apply real.log_ne_zero_of_ne_one,
          rotate 1,
          norm_cast,
          exact ne_of_gt n₀_not_one,
          all_goals {
            norm_cast,
            exact lt_trans zero_lt_one (by assumption),
          }
        },
        use α,
        have zero_lt_α: 0 < α,
        {
          apply div_pos,
          have one_lt_abvn₀: 1 < abv n₀,
          {
            rw ← gt_iff_lt,
            exact n₀_spec,
          },
          exact (real.log_pos_iff (by linarith only [one_lt_abvn₀])).2
            one_lt_abvn₀,
          exact (real.log_pos_iff (by { norm_cast, linarith only [n₀_not_one], })).2
              (by { norm_cast, linarith only [n₀_not_one], }),
        },
        set abv_hom := hom_of_abv abv with abv_hom_def,
        set equiv_abs_hom := hom_of_equiv_abs α (ne.symm $ ne_of_lt zero_lt_α) with equiv_abs_def,
        have abv_eq_hom_fn: abv = abv_hom := rfl,
        have equiv_abs_eq_hom_fn: equiv_abs α = equiv_abs_hom := rfl,
        have same_on_neg_one: abv_hom (-1) = equiv_abs_hom (-1),
        {
          rw [← abv_eq_hom_fn, ← equiv_abs_eq_hom_fn],
          rw [abv_neg abv, equiv_abs_neg],
          rw [abv_one abv, equiv_abs_one],
        },
        use zero_lt_α,
        unfold equiv_abs at equiv_abs_eq_hom_fn,
        rw [abv_eq_hom_fn, equiv_abs_eq_hom_fn],
        symmetry,
        apply ext_hom_pnat _ _ same_on_neg_one,
        intro n,
        rw [← abv_eq_hom_fn, ← equiv_abs_eq_hom_fn],
        unfold equiv_abs,
        -- prove abv n = n^α
        have: abv n = n ^ α :=
        begin
          apply le_antisymm,
          apply nat_abs_val_le_nat_pow_alpha
           zero_lt_α n₀_ge_two h_n0_pow_α_eq_abv_n0 n₀_spec
           n₀_smallest_spec,
          apply nat_pow_alpha_le_nat_abs_val
           zero_lt_α n₀_ge_two h_n0_pow_α_eq_abv_n0 n₀_spec
           n₀_smallest_spec,
        end,
        rw this,
        congr' 1,
        rw abs_eq_self.2,
        all_goals { norm_cast },
        exact zero_le n,
    end

/- Théorème d'Ostrowski -/
theorem rat_abs_val_p_adic_or_real (abv: ℚ → ℝ)
    [habv: is_absolute_value abv]
    (hnontriv: abv ≠ trivial_abs):
    (abvs_equiv abv (λ x: ℚ, abs x))
    ∨
    ∃ (p) [p_prime: fact (nat.prime p)], abvs_equiv abv (@rat_padic_abv p p_prime) :=
    begin
        by_cases boundness : ∀ z : ℕ, abv z ≤ 1,
        {
            apply or.inr,
            exact rat_abs_val_one_bounded_padic _ hnontriv boundness,
        },
        {
            apply or.inl,
            exact rat_abs_val_unbounded_real abv boundness,
        }
    end
end


import algebra.field
import data.polynomial
import data.mv_polynomial
import gtm106.weierstrass_equation.regular_function.basic
import gtm106.weierstrass_equation.regular_function.mv_polynomial
import tactic

noncomputable theory

namespace weierstrass_equation

namespace regular_function_ring'

def to_regular_function_ring.to_fun {K : Type*} [comm_ring K]
{E : weierstrass_equation K} (f : regular_function_ring' E) : regular_function_ring E
:= (polynomial.eval₂ (@regular_function_ring.C K _ E) regular_function_ring.x f.1)
+ (polynomial.eval₂ (@regular_function_ring.C K _ E) regular_function_ring.x f.2) * regular_function_ring.y

lemma to_regular_function_ring.map_one' {K : Type*} [comm_ring K]
{E : weierstrass_equation K} : @to_regular_function_ring.to_fun K _ E one = 1 :=
begin
  simp [to_regular_function_ring.to_fun, one],
end

lemma to_regular_function_ring.map_mul' {K : Type*} [comm_ring K]
{E : weierstrass_equation K} (f g : regular_function_ring' E)
: (@to_regular_function_ring.to_fun K _ E (mul f g)) = (@to_regular_function_ring.to_fun K _ E f) * (@to_regular_function_ring.to_fun K _ E g) :=
begin
  have h : (@regular_function_ring.x K _ E) ^ 3 + regular_function_ring.C E.a2 * regular_function_ring.x ^ 2 + regular_function_ring.C E.a4 * regular_function_ring.x + regular_function_ring.C E.a6 = 0 := by {
    sorry,
  },
  -- simp [to_regular_function_ring.to_fun, mul],
  sorry,
end

lemma to_regular_function_ring.map_zero' {K : Type*} [comm_ring K]
{E : weierstrass_equation K} : @to_regular_function_ring.to_fun K _ E zero = 0 :=
begin
  simp [to_regular_function_ring.to_fun, zero],
end

lemma to_regular_function_ring.map_add' {K : Type*} [comm_ring K]
{E : weierstrass_equation K} (f g : regular_function_ring' E)
: (@to_regular_function_ring.to_fun K _ E (add f g)) = (@to_regular_function_ring.to_fun K _ E f) + (@to_regular_function_ring.to_fun K _ E g) :=
begin
  unfold add to_regular_function_ring.to_fun,
  dsimp only,
  repeat { rw polynomial.eval₂_add },
  ring,
end

def to_regular_function_ring {K : Type*} [comm_ring K]
{E : weierstrass_equation K} : ring_hom (regular_function_ring' E) (regular_function_ring E)
:= ⟨ to_regular_function_ring.to_fun, to_regular_function_ring.map_one', to_regular_function_ring.map_mul', to_regular_function_ring.map_zero', to_regular_function_ring.map_add' ⟩

end regular_function_ring'

end weierstrass_equation


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.encodable.basic
import Mathlib.data.finset.basic
import Mathlib.data.set.disjointed
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Lattice operations on encodable types

Lemmas about lattice and set operations on encodable types

## Implementation Notes

This is a separate file, to avoid unnecessary imports in basic files.

Previously some of these results were in the `measure_theory` folder.
-/

namespace encodable

theorem supr_decode2 {α : Type u_1} {β : Type u_2} [encodable β] [complete_lattice α] (f : β → α) : (supr fun (i : ℕ) => supr fun (b : β) => supr fun (H : b ∈ decode2 β i) => f b) = supr fun (b : β) => f b := sorry

theorem Union_decode2 {α : Type u_1} {β : Type u_2} [encodable β] (f : β → set α) : (set.Union fun (i : ℕ) => set.Union fun (b : β) => set.Union fun (H : b ∈ decode2 β i) => f b) =
  set.Union fun (b : β) => f b :=
  supr_decode2 f

theorem Union_decode2_cases {α : Type u_1} {β : Type u_2} [encodable β] {f : β → set α} {C : set α → Prop} (H0 : C ∅) (H1 : ∀ (b : β), C (f b)) {n : ℕ} : C (set.Union fun (b : β) => set.Union fun (H : b ∈ decode2 β n) => f b) := sorry

theorem Union_decode2_disjoint_on {α : Type u_1} {β : Type u_2} [encodable β] {f : β → set α} (hd : pairwise (disjoint on f)) : pairwise (disjoint on fun (i : ℕ) => set.Union fun (b : β) => set.Union fun (H : b ∈ decode2 β i) => f b) := sorry

end encodable

namespace finset

theorem nonempty_encodable {α : Type u_1} (t : finset α) : Nonempty (encodable (Subtype fun (i : α) => i ∈ t)) := sorry


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

! This file was ported from Lean 3 source module category_theory.sites.adjunction
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Adjunction.Whiskering
import Mathbin.CategoryTheory.Sites.Sheafification
import Mathbin.CategoryTheory.Sites.Whiskering

/-!

In this file, we show that an adjunction `F ⊣ G` induces an adjunction between
categories of sheaves, under certain hypotheses on `F` and `G`.

-/

namespace CategoryTheory

open CategoryTheory.GrothendieckTopology

open CategoryTheory

open CategoryTheory.Limits

open Opposite

universe w₁ w₂ v u

variable {C : Type u} [Category.{v} C] (J : GrothendieckTopology C)

variable {D : Type w₁} [Category.{max v u} D]

variable {E : Type w₂} [Category.{max v u} E]

variable {F : D ⥤ E} {G : E ⥤ D}

variable [∀ (X : C) (S : J.cover X) (P : Cᵒᵖ ⥤ D), PreservesLimit (S.index P).multicospan F]

variable [ConcreteCategory.{max v u} D] [PreservesLimits (forget D)]

/-- The forgetful functor from `Sheaf J D` to sheaves of types, for a concrete category `D`
whose forgetful functor preserves the correct limits. -/
abbrev sheafForget : Sheaf J D ⥤ SheafOfTypes J :=
  sheafCompose J (forget D) ⋙ (sheafEquivSheafOfTypes J).Functor
#align category_theory.Sheaf_forget CategoryTheory.sheafForget

-- We need to sheafify...
variable [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), HasMultiequalizer (S.index P)]
  [∀ X : C, HasColimitsOfShape (J.cover X)ᵒᵖ D]
  [∀ X : C, PreservesColimitsOfShape (J.cover X)ᵒᵖ (forget D)] [ReflectsIsomorphisms (forget D)]

namespace Sheaf

noncomputable section

/-- This is the functor sending a sheaf `X : Sheaf J E` to the sheafification
of `X ⋙ G`. -/
abbrev composeAndSheafify (G : E ⥤ D) : Sheaf J E ⥤ Sheaf J D :=
  sheafToPresheaf J E ⋙ (whiskeringRight _ _ _).obj G ⋙ presheafToSheaf J D
#align category_theory.Sheaf.compose_and_sheafify CategoryTheory.Sheaf.composeAndSheafify

/-- An auxiliary definition to be used in defining `category_theory.Sheaf.adjunction` below. -/
@[simps]
def composeEquiv (adj : G ⊣ F) (X : Sheaf J E) (Y : Sheaf J D) :
    ((composeAndSheafify J G).obj X ⟶ Y) ≃ (X ⟶ (sheafCompose J F).obj Y) :=
  let A := adj.whiskerRight Cᵒᵖ
  { toFun := fun η => ⟨A.homEquiv _ _ (J.toSheafify _ ≫ η.val)⟩
    invFun := fun γ => ⟨J.sheafifyLift ((A.homEquiv _ _).symm ((sheafToPresheaf _ _).map γ)) Y.2⟩
    left_inv := by
      intro η
      ext1
      dsimp
      symm
      apply J.sheafify_lift_unique
      rw [Equiv.symm_apply_apply]
    right_inv := by
      intro γ
      ext1
      dsimp
      rw [J.to_sheafify_sheafify_lift, Equiv.apply_symm_apply] }
#align category_theory.Sheaf.compose_equiv CategoryTheory.Sheaf.composeEquiv

/-- An adjunction `adj : G ⊣ F` with `F : D ⥤ E` and `G : E ⥤ D` induces an adjunction
between `Sheaf J D` and `Sheaf J E`, in contexts where one can sheafify `D`-valued presheaves,
and `F` preserves the correct limits. -/
@[simps unit_app_val counit_app_val]
def adjunction (adj : G ⊣ F) : composeAndSheafify J G ⊣ sheafCompose J F :=
  Adjunction.mkOfHomEquiv
    { homEquiv := composeEquiv J adj
      homEquiv_naturality_left_symm := fun X' X Y f g =>
        by
        ext1
        dsimp
        simp
      homEquiv_naturality_right := fun X Y Y' f g =>
        by
        ext1
        dsimp
        simp }
#align category_theory.Sheaf.adjunction CategoryTheory.Sheaf.adjunction

instance [IsRightAdjoint F] : IsRightAdjoint (sheafCompose J F) :=
  ⟨_, adjunction J (Adjunction.ofRightAdjoint F)⟩

section ForgetToType

/-- This is the functor sending a sheaf of types `X` to the sheafification of `X ⋙ G`. -/
abbrev composeAndSheafifyFromTypes (G : Type max v u ⥤ D) : SheafOfTypes J ⥤ Sheaf J D :=
  (sheafEquivSheafOfTypes J).inverse ⋙ composeAndSheafify _ G
#align category_theory.Sheaf.compose_and_sheafify_from_types CategoryTheory.Sheaf.composeAndSheafifyFromTypes

/-- A variant of the adjunction between sheaf categories, in the case where the right adjoint
is the forgetful functor to sheaves of types. -/
def adjunctionToTypes {G : Type max v u ⥤ D} (adj : G ⊣ forget D) :
    composeAndSheafifyFromTypes J G ⊣ sheafForget J :=
  (sheafEquivSheafOfTypes J).symm.toAdjunction.comp (adjunction J adj)
#align category_theory.Sheaf.adjunction_to_types CategoryTheory.Sheaf.adjunctionToTypes

@[simp]
theorem adjunctionToTypes_unit_app_val {G : Type max v u ⥤ D} (adj : G ⊣ forget D)
    (Y : SheafOfTypes J) :
    ((adjunctionToTypes J adj).Unit.app Y).val =
      (adj.whiskerRight _).Unit.app ((sheafOfTypesToPresheaf J).obj Y) ≫
        whiskerRight (J.toSheafify _) (forget D) :=
  by
  dsimp [adjunction_to_types, adjunction.comp]
  simpa
#align category_theory.Sheaf.adjunction_to_types_unit_app_val CategoryTheory.Sheaf.adjunctionToTypes_unit_app_val

@[simp]
theorem adjunctionToTypes_counit_app_val {G : Type max v u ⥤ D} (adj : G ⊣ forget D)
    (X : Sheaf J D) :
    ((adjunctionToTypes J adj).counit.app X).val =
      J.sheafifyLift ((Functor.associator _ _ _).Hom ≫ (adj.whiskerRight _).counit.app _) X.2 :=
  by
  dsimp [adjunction_to_types, adjunction.comp, adjunction.whisker_right]
  rw [category.id_comp]
  apply J.sheafify_lift_unique
  rw [adjunction_counit_app_val, J.sheafify_map_sheafify_lift, J.to_sheafify_sheafify_lift]
  ext
  dsimp [Sheaf_equiv_SheafOfTypes, equivalence.symm, equivalence.to_adjunction,
    nat_iso.of_components]
  simp
#align category_theory.Sheaf.adjunction_to_types_counit_app_val CategoryTheory.Sheaf.adjunctionToTypes_counit_app_val

instance [IsRightAdjoint (forget D)] : IsRightAdjoint (sheafForget J) :=
  ⟨_, adjunctionToTypes J (Adjunction.ofRightAdjoint (forget D))⟩

end ForgetToType

end Sheaf

end CategoryTheory


import order.filter.germ
import for_mathlib.filter_basic

/-! # Complements on filter germs -/

open filter function

namespace filter.germ

variables {ι α β : Type*} (l : filter ι)

local notation `∀*` binders `, ` r:(scoped p, filter.eventually p l) := r
local notation `α*` := l.germ α
local notation `β*` := l.germ β

lemma eq_def : ((=) : α* → α* → Prop) = lift_rel (=) :=
begin
  ext ⟨f⟩ ⟨g⟩,
  exact coe_eq
end

/-! ## Product of germs -/

def prod_equiv : α* × β* ≃ l.germ (α × β) :=
{ to_fun := uncurry (quotient.map₂' (λ f g i, ⟨f i, g i⟩)
    begin
      intros f f' hff' g g' hgg',
      filter_upwards [hff', hgg'],
      intros i hfi hgi,
      simp [hfi, hgi]
    end),
  inv_fun := λ i,
    ⟨quotient.map' (λ f, prod.fst ∘ f)
      begin
        intros f f' hff',
        filter_upwards [hff'],
        intros i hfi,
        simp [hfi]
      end i,
    quotient.map' (λ f, prod.snd ∘ f)
      begin
        intros g g' hgg',
        filter_upwards [hgg'],
        intros i hgi,
        simp [hgi]
      end i⟩,
  left_inv := by {rintros ⟨⟨f⟩, ⟨g⟩⟩, refl},
  right_inv := by {rintro ⟨f⟩, convert rfl, ext x; refl} }

local notation `⋈` := (prod_equiv l : α* × β* → l.germ (α × β))

@[simp] lemma prod_equiv_coe (f : ι → α) (g : ι → β) :
  ⋈ ((f : α*), (g : β*)) = ↑(λ (i : ι), (f i, g i)) :=
rfl

lemma lift_rel_iff_lift_pred_uncurry (r : α → β → Prop) (x : α*) (y : β*) :
  lift_rel r x y ↔ lift_pred (uncurry r) (⋈ (x, y)) :=
begin
  refine x.induction_on₂ y (λ f g, _),
  refl
end

lemma lift_rel_iff_lift_pred_uncurry' (r : α → β → Prop) (x : α*) (y : β*) :
  lift_rel r x y ↔ lift_pred (λ u : α × β, r u.1 u.2) (⋈ (x, y)) :=
lift_rel_iff_lift_pred_uncurry l r x y

lemma lift_rel_symm (r : α → β → Prop) (x : α*) (y : β*) :
  lift_rel r x y ↔ lift_rel (λ a b, r b a) y x :=
begin
  refine x.induction_on₂ y (λ f g, _),
  refl
end

/-! ## Transfer lemmas -/

/-! ### Forall rules -/

lemma forall_iff_forall_lift_pred [l.ne_bot] (p : α → Prop) :
  (∀ x, p x) ↔ (∀ x : α*, lift_pred p x) :=
begin
  split,
  { refine λ h x, x.induction_on (λ f, _),
    exact eventually_of_forall (λ x, h (f x)) },
  { exact λ h x, lift_pred_const_iff.mp (h ↑x) }
end

/-! ### Exists rules -/

lemma exists_iff_exists_lift_pred [l.ne_bot] (p : α → Prop) :
  (∃ x, p x) ↔ (∃ x : α*, lift_pred p x) :=
begin
  split,
  { exact λ ⟨x, hx⟩, ⟨↑x, lift_pred_const hx⟩ },
  { rintros ⟨x, hx⟩,
    revert hx,
    refine x.induction_on (λ f, _),
    exact λ hf, let ⟨i, hi⟩ := hf.exists in ⟨f i, hi⟩ }
end

lemma lift_pred_exists_iff_exists_lift_rel [l.ne_bot] (r : α → β → Prop) (x : α*) :
  lift_pred (λ x, ∃ (y : β), r x y) x ↔ ∃ (y : β*), lift_rel r x y :=
begin
  refine x.induction_on (λ f, _),
  rw lift_pred_coe,
  split,
  { exact λ h, let ⟨g, hg⟩ := h.choice in ⟨g, hg⟩ },
  { rintro ⟨y, hy⟩,
    revert hy,
    refine y.induction_on (λ g, _),
    intro hg,
    filter_upwards [hg],
    exact λ i hi, ⟨g i, hi⟩ }
end

lemma lift_pred_exists_iff_exists_lift_pred [l.ne_bot] (r : α → β → Prop) (x : α*) :
  lift_pred (λ x, ∃ (y : β), r x y) x ↔ ∃ (y : β*), lift_pred (uncurry r) (⋈ (x, y)) :=
begin
  conv_rhs {congr, funext, rw ← lift_rel_iff_lift_pred_uncurry},
  exact lift_pred_exists_iff_exists_lift_rel l r x
end

lemma lift_pred_exists_iff_exists_lift_pred' [l.ne_bot] (r : α → β → Prop) (x : α*) :
  lift_pred (λ x, ∃ (y : β), r x y) x ↔ ∃ (y : β*), lift_pred (λ u : α × β, r u.1 u.2) (⋈ (x, y)) :=
lift_pred_exists_iff_exists_lift_pred l r x

/-! ### Eq rules -/

lemma lift_pred_eq_iff_eq_map (f g : α → β) (x : α*) :
  lift_pred (λ x, f x = g x) x ↔ germ.map f x = germ.map g x :=
begin
  refine x.induction_on (λ u, _),
  rw eq_def,
  refl,
end

/-! ### And rules -/

lemma lift_pred_and_iff_and_lift_pred [l.ne_bot] (p q : α → Prop) (x : α*) :
  lift_pred (λ x, p x ∧ q x) x ↔ lift_pred p x ∧ lift_pred q x :=
begin
  refine x.induction_on (λ f, _),
  exact eventually_and
end

/-! ### Exists rules for Props -/

lemma lift_pred_exists_prop_iff_and_lift_pred [l.ne_bot] (p q : α → Prop) (x : α*) :
  lift_pred (λ x, ∃ (h : p x), q x) x ↔ lift_pred p x ∧ lift_pred q x :=
begin
  conv in (Exists _) {rw exists_prop},
  exact lift_pred_and_iff_and_lift_pred l p q x
end

end filter.germ


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

import field_theory.subfield
import field_theory.tower
import ring_theory.algebraic

/-!
# Intermediate fields

Let `L / K` be a field extension, given as an instance `algebra K L`.
This file defines the type of fields in between `K` and `L`, `intermediate_field K L`.
An `intermediate_field K L` is a subfield of `L` which contains (the image of) `K`,
i.e. it is a `subfield L` and a `subalgebra K L`.

## Main definitions

 * `intermediate_field K L` : the type of intermediate fields between `K` and `L`.

 * `subalgebra.to_intermediate_field`: turns a subalgebra closed under `⁻¹`
   into an intermediate field

 * `subfield.to_intermediate_field`: turns a subfield containing the image of `K`
   into an intermediate field

* `intermediate_field.map`: map an intermediate field along an `alg_hom`

## Implementation notes

Intermediate fields are defined with a structure extending `subfield` and `subalgebra`.
A `subalgebra` is closed under all operations except `⁻¹`,

## Tags
intermediate field, field extension
-/

open finite_dimensional
open_locale big_operators

variables (K L : Type*) [field K] [field L] [algebra K L]

section
set_option old_structure_cmd true

/-- `S : intermediate_field K L` is a subset of `L` such that there is a field
tower `L / S / K`. -/
structure intermediate_field extends subalgebra K L, subfield L

/-- Reinterpret an `intermediate_field` as a `subalgebra`. -/
add_decl_doc intermediate_field.to_subalgebra

/-- Reinterpret an `intermediate_field` as a `subfield`. -/
add_decl_doc intermediate_field.to_subfield

end

variables {K L} (S : intermediate_field K L)

namespace intermediate_field

instance : set_like (intermediate_field K L) L :=
⟨intermediate_field.carrier, λ p q h, by cases p; cases q; congr'⟩

@[simp]
lemma mem_carrier {s : intermediate_field K L} {x : L} : x ∈ s.carrier ↔ x ∈ s := iff.rfl

/-- Two intermediate fields are equal if they have the same elements. -/
@[ext] theorem ext {S T : intermediate_field K L} (h : ∀ x, x ∈ S ↔ x ∈ T) : S = T :=
set_like.ext h

@[simp] lemma coe_to_subalgebra : (S.to_subalgebra : set L) = S := rfl

@[simp] lemma coe_to_subfield : (S.to_subfield : set L) = S := rfl

@[simp] lemma mem_mk (s : set L) (hK : ∀ x, algebra_map K L x ∈ s)
  (ho hm hz ha hn hi) (x : L) :
  x ∈ intermediate_field.mk s ho hm hz ha hK hn hi ↔ x ∈ s := iff.rfl

@[simp] lemma mem_to_subalgebra (s : intermediate_field K L) (x : L) :
  x ∈ s.to_subalgebra ↔ x ∈ s := iff.rfl

@[simp] lemma mem_to_subfield (s : intermediate_field K L) (x : L) :
  x ∈ s.to_subfield ↔ x ∈ s := iff.rfl

/-- An intermediate field contains the image of the smaller field. -/
theorem algebra_map_mem (x : K) : algebra_map K L x ∈ S :=
S.algebra_map_mem' x

/-- An intermediate field contains the ring's 1. -/
theorem one_mem : (1 : L) ∈ S := S.one_mem'

/-- An intermediate field contains the ring's 0. -/
theorem zero_mem : (0 : L) ∈ S := S.zero_mem'

/-- An intermediate field is closed under multiplication. -/
theorem mul_mem : ∀ {x y : L}, x ∈ S → y ∈ S → x * y ∈ S := S.mul_mem'

/-- An intermediate field is closed under scalar multiplication. -/

/-- An intermediate field is closed under addition. -/
theorem add_mem : ∀ {x y : L}, x ∈ S → y ∈ S → x + y ∈ S := S.add_mem'

/-- An intermediate field is closed under subtraction -/
theorem sub_mem {x y : L} (hx : x ∈ S) (hy : y ∈ S) : x - y ∈ S :=
S.to_subfield.sub_mem hx hy

/-- An intermediate field is closed under negation. -/
theorem neg_mem : ∀ {x : L}, x ∈ S → -x ∈ S := S.neg_mem'

/-- An intermediate field is closed under inverses. -/
theorem inv_mem : ∀ {x : L}, x ∈ S → x⁻¹ ∈ S := S.inv_mem'

/-- An intermediate field is closed under division. -/
theorem div_mem {x y : L} (hx : x ∈ S) (hy : y ∈ S) : x / y ∈ S :=
S.to_subfield.div_mem hx hy

/-- Product of a list of elements in an intermediate_field is in the intermediate_field. -/
lemma list_prod_mem {l : list L} : (∀ x ∈ l, x ∈ S) → l.prod ∈ S :=
S.to_subfield.list_prod_mem

/-- Sum of a list of elements in an intermediate field is in the intermediate_field. -/
lemma list_sum_mem {l : list L} : (∀ x ∈ l, x ∈ S) → l.sum ∈ S :=
S.to_subfield.list_sum_mem

/-- Product of a multiset of elements in an intermediate field is in the intermediate_field. -/
lemma multiset_prod_mem (m : multiset L) :
  (∀ a ∈ m, a ∈ S) → m.prod ∈ S :=
S.to_subfield.multiset_prod_mem m

/-- Sum of a multiset of elements in a `intermediate_field` is in the `intermediate_field`. -/
lemma multiset_sum_mem (m : multiset L) :
  (∀ a ∈ m, a ∈ S) → m.sum ∈ S :=
S.to_subfield.multiset_sum_mem m

/-- Product of elements of an intermediate field indexed by a `finset` is in the intermediate_field.
-/
lemma prod_mem {ι : Type*} {t : finset ι} {f : ι → L} (h : ∀ c ∈ t, f c ∈ S) :
  ∏ i in t, f i ∈ S :=
S.to_subfield.prod_mem h

/-- Sum of elements in a `intermediate_field` indexed by a `finset` is in the `intermediate_field`.
-/
lemma sum_mem {ι : Type*} {t : finset ι} {f : ι → L} (h : ∀ c ∈ t, f c ∈ S) :
  ∑ i in t, f i ∈ S :=
S.to_subfield.sum_mem h

lemma pow_mem {x : L} (hx : x ∈ S) : ∀ (n : ℤ), x^n ∈ S
| (n : ℕ) := by { rw gpow_coe_nat,
    exact @is_submonoid.pow_mem L _ S.to_subfield.to_submonoid x _ hx n, }
| -[1+ n] := by { rw [gpow_neg_succ_of_nat],
    have h := @is_submonoid.pow_mem L _ S.to_subfield.to_submonoid x _ hx _,
    exact subfield.inv_mem S.to_subfield h }

lemma gsmul_mem {x : L} (hx : x ∈ S) (n : ℤ) :
  n • x ∈ S := S.to_subfield.gsmul_mem hx n

lemma coe_int_mem (n : ℤ) : (n : L) ∈ S :=
by simp only [← gsmul_one, gsmul_mem, one_mem]

end intermediate_field

/-- Turn a subalgebra closed under inverses into an intermediate field -/
def subalgebra.to_intermediate_field (S : subalgebra K L) (inv_mem : ∀ x ∈ S, x⁻¹ ∈ S) :
  intermediate_field K L :=
{ neg_mem' := λ x, S.neg_mem,
  inv_mem' := inv_mem,
  .. S }

@[simp] lemma to_subalgebra_to_intermediate_field
  (S : subalgebra K L) (inv_mem : ∀ x ∈ S, x⁻¹ ∈ S) :
  (S.to_intermediate_field inv_mem).to_subalgebra = S :=
by { ext, refl }

@[simp] lemma to_intermediate_field_to_subalgebra
  (S : intermediate_field K L) (inv_mem : ∀ x ∈ S.to_subalgebra, x⁻¹ ∈ S) :
  S.to_subalgebra.to_intermediate_field inv_mem = S :=
by { ext, refl }

/-- Turn a subfield of `L` containing the image of `K` into an intermediate field -/
def subfield.to_intermediate_field (S : subfield L)
  (algebra_map_mem : ∀ x, algebra_map K L x ∈ S) :
  intermediate_field K L :=
{ algebra_map_mem' := algebra_map_mem,
  .. S }

namespace intermediate_field

/-- An intermediate field inherits a field structure -/
instance to_field : field S :=
S.to_subfield.to_field

@[simp, norm_cast] lemma coe_add (x y : S) : (↑(x + y) : L) = ↑x + ↑y := rfl
@[simp, norm_cast] lemma coe_neg (x : S) : (↑(-x) : L) = -↑x := rfl
@[simp, norm_cast] lemma coe_mul (x y : S) : (↑(x * y) : L) = ↑x * ↑y := rfl
@[simp, norm_cast] lemma coe_inv (x : S) : (↑(x⁻¹) : L) = (↑x)⁻¹ := rfl
@[simp, norm_cast] lemma coe_zero : ((0 : S) : L) = 0 := rfl
@[simp, norm_cast] lemma coe_one : ((1 : S) : L) = 1 := rfl
@[simp, norm_cast] lemma coe_pow (x : S) (n : ℕ) : (↑(x ^ n) : L) = ↑x ^ n :=
begin
  induction n with n ih,
  { simp },
  { simp [pow_succ, ih] }
end

instance algebra : algebra K S :=
S.to_subalgebra.algebra

instance to_algebra : algebra S L :=
S.to_subalgebra.to_algebra

instance : is_scalar_tower K S L :=
is_scalar_tower.subalgebra' _ _ _ S.to_subalgebra

variables {L' : Type*} [field L'] [algebra K L']

/-- If `f : L →+* L'` fixes `K`, `S.map f` is the intermediate field between `L'` and `K`
such that `x ∈ S ↔ f x ∈ S.map f`. -/
def map (f : L →ₐ[K] L') : intermediate_field K L' :=
{ inv_mem' := by { rintros _ ⟨x, hx, rfl⟩, exact ⟨x⁻¹, S.inv_mem hx, f.map_inv x⟩ },
  neg_mem' := λ x hx, (S.to_subalgebra.map f).neg_mem hx,
  .. S.to_subalgebra.map f}

/-- The embedding from an intermediate field of `L / K` to `L`. -/
def val : S →ₐ[K] L :=
S.to_subalgebra.val

@[simp] theorem coe_val : ⇑S.val = coe := rfl

@[simp] lemma val_mk {x : L} (hx : x ∈ S) : S.val ⟨x, hx⟩ = x := rfl

variables {S}

lemma to_subalgebra_injective {S S' : intermediate_field K L}
  (h : S.to_subalgebra = S'.to_subalgebra) : S = S' :=
by { ext, rw [← mem_to_subalgebra, ← mem_to_subalgebra, h] }

variables (S)

lemma set_range_subset : set.range (algebra_map K L) ⊆ S :=
S.to_subalgebra.range_subset

lemma field_range_le : (algebra_map K L).field_range ≤ S.to_subfield :=
λ x hx, S.to_subalgebra.range_subset (by rwa [set.mem_range, ← ring_hom.mem_field_range])

@[simp] lemma to_subalgebra_le_to_subalgebra {S S' : intermediate_field K L} :
  S.to_subalgebra ≤ S'.to_subalgebra ↔ S ≤ S' := iff.rfl

@[simp] lemma to_subalgebra_lt_to_subalgebra {S S' : intermediate_field K L} :
  S.to_subalgebra < S'.to_subalgebra ↔ S < S' := iff.rfl

variables {S}

section tower

/-- Lift an intermediate_field of an intermediate_field -/
def lift1 {F : intermediate_field K L} (E : intermediate_field K F) : intermediate_field K L :=
  map E (val F)

/-- Lift an intermediate_field of an intermediate_field -/
def lift2 {F : intermediate_field K L} (E : intermediate_field F L) : intermediate_field K L :=
{ carrier := E.carrier,
  zero_mem' := zero_mem E,
  add_mem' := λ x y, add_mem E,
  neg_mem' := λ x, neg_mem E,
  one_mem' := one_mem E,
  mul_mem' := λ x y, mul_mem E,
  inv_mem' := λ x, inv_mem E,
  algebra_map_mem' := λ x, algebra_map_mem E (algebra_map K F x) }

instance has_lift1 {F : intermediate_field K L} :
  has_lift_t (intermediate_field K F) (intermediate_field K L) := ⟨lift1⟩

instance has_lift2 {F : intermediate_field K L} :
  has_lift_t (intermediate_field F L) (intermediate_field K L) := ⟨lift2⟩

@[simp] lemma mem_lift2 {F : intermediate_field K L} {E : intermediate_field F L} {x : L} :
  x ∈ (↑E : intermediate_field K L) ↔ x ∈ E := iff.rfl

instance lift2_alg {F : intermediate_field K L} {E : intermediate_field F L} : algebra K E :=
{ to_fun := (algebra_map F E).comp (algebra_map K F),
  map_zero' := ((algebra_map F E).comp (algebra_map K F)).map_zero,
  map_one' := ((algebra_map F E).comp (algebra_map K F)).map_one,
  map_add' := ((algebra_map F E).comp (algebra_map K F)).map_add,
  map_mul' := ((algebra_map F E).comp (algebra_map K F)).map_mul,
  smul := λ a b, (((algebra_map F E).comp (algebra_map K F)) a) * b,
  smul_def' := λ _ _, rfl,
  commutes' := λ a b, mul_comm (((algebra_map F E).comp (algebra_map K F)) a) b }

instance lift2_tower {F : intermediate_field K L} {E : intermediate_field F L} :
  is_scalar_tower K F E :=
⟨λ a b c, by { simp only [algebra.smul_def, ring_hom.map_mul, mul_assoc], refl }⟩

/-- `lift2` is isomorphic to the original `intermediate_field`. -/
def lift2_alg_equiv {F : intermediate_field K L} (E : intermediate_field F L) :
  (↑E : intermediate_field K L) ≃ₐ[K] E :=
{ to_fun := λ x, x,
  inv_fun := λ x, x,
  left_inv := λ x, rfl,
  right_inv := λ x, rfl,
  map_add' := λ x y, rfl,
  map_mul' := λ x y, rfl,
  commutes' := λ x, rfl }

end tower

section finite_dimensional

variables (F E : intermediate_field K L)

instance finite_dimensional_left [finite_dimensional K L] : finite_dimensional K F :=
finite_dimensional.finite_dimensional_submodule F.to_subalgebra.to_submodule

instance finite_dimensional_right [finite_dimensional K L] : finite_dimensional F L :=
right K F L

@[simp] lemma dim_eq_dim_subalgebra :
  module.rank K F.to_subalgebra = module.rank K F := rfl

@[simp] lemma finrank_eq_finrank_subalgebra :
  finrank K F.to_subalgebra = finrank K F := rfl

variables {F} {E}

@[simp] lemma to_subalgebra_eq_iff : F.to_subalgebra = E.to_subalgebra ↔ F = E :=
by { rw [set_like.ext_iff, set_like.ext'_iff, set.ext_iff], refl }

lemma eq_of_le_of_finrank_le [finite_dimensional K L] (h_le : F ≤ E)
  (h_finrank : finrank K E ≤ finrank K F) : F = E :=
to_subalgebra_injective $ subalgebra.to_submodule_injective $ eq_of_le_of_finrank_le h_le h_finrank

lemma eq_of_le_of_finrank_eq [finite_dimensional K L] (h_le : F ≤ E)
  (h_finrank : finrank K F = finrank K E) : F = E :=
eq_of_le_of_finrank_le h_le h_finrank.ge

lemma eq_of_le_of_finrank_le' [finite_dimensional K L] (h_le : F ≤ E)
  (h_finrank : finrank F L ≤ finrank E L) : F = E :=
begin
  apply eq_of_le_of_finrank_le h_le,
  have h1 := finrank_mul_finrank K F L,
  have h2 := finrank_mul_finrank K E L,
  have h3 : 0 < finrank E L := finrank_pos,
  nlinarith,
end

lemma eq_of_le_of_finrank_eq' [finite_dimensional K L] (h_le : F ≤ E)
  (h_finrank : finrank F L = finrank E L) : F = E :=
eq_of_le_of_finrank_le' h_le h_finrank.le

end finite_dimensional

end intermediate_field

/-- If `L/K` is algebraic, the `K`-subalgebras of `L` are all fields.  -/
def subalgebra_equiv_intermediate_field (alg : algebra.is_algebraic K L) :
  subalgebra K L ≃o intermediate_field K L :=
{ to_fun := λ S, S.to_intermediate_field (λ x hx, S.inv_mem_of_algebraic (alg (⟨x, hx⟩ : S))),
  inv_fun := λ S, S.to_subalgebra,
  left_inv := λ S, to_subalgebra_to_intermediate_field _ _,
  right_inv := λ S, to_intermediate_field_to_subalgebra _ _,
  map_rel_iff' := λ S S', iff.rfl }

@[simp] lemma mem_subalgebra_equiv_intermediate_field (alg : algebra.is_algebraic K L)
  {S : subalgebra K L} {x : L} :
  x ∈ subalgebra_equiv_intermediate_field alg S ↔ x ∈ S :=
iff.rfl

@[simp] lemma mem_subalgebra_equiv_intermediate_field_symm (alg : algebra.is_algebraic K L)
  {S : intermediate_field K L} {x : L} :
  x ∈ (subalgebra_equiv_intermediate_field alg).symm S ↔ x ∈ S :=
iff.rfl


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.data.ordering.basic init.meta init.algebra.classes init.ite_simp
set_option default_priority 100

universes u

namespace ordering
@[simp] theorem ite_eq_lt_distrib (c : Prop) [decidable c] (a b : ordering) : ((if c then a else b) = ordering.lt) = (if c then a = ordering.lt else b = ordering.lt) :=
by by_cases c; simp [*]

@[simp] theorem ite_eq_eq_distrib (c : Prop) [decidable c] (a b : ordering) : ((if c then a else b) = ordering.eq) = (if c then a = ordering.eq else b = ordering.eq) :=
by by_cases c; simp [*]

@[simp] theorem ite_eq_gt_distrib (c : Prop) [decidable c] (a b : ordering) : ((if c then a else b) = ordering.gt) = (if c then a = ordering.gt else b = ordering.gt) :=
by by_cases c; simp [*]

/- ------------------------------------------------------------------ -/
end ordering

section
variables {α : Type u} {lt : α → α → Prop} [decidable_rel lt]

local attribute [simp] cmp_using

@[simp] lemma cmp_using_eq_lt (a b : α) : (cmp_using lt a b = ordering.lt) = lt a b :=
by simp

@[simp] lemma cmp_using_eq_gt [is_strict_order α lt] (a b : α) : (cmp_using lt a b = ordering.gt) = lt b a :=
begin
  simp, apply propext, apply iff.intro,
  { exact λ h, h.2 },
  { intro hba, split, { intro hab, exact absurd (trans hab hba) (irrefl a) }, { assumption } }
end

@[simp] lemma cmp_using_eq_eq (a b : α) : (cmp_using lt a b = ordering.eq) = (¬ lt a b ∧ ¬ lt b a) :=
by simp

end


universe u

namespace Ex1

structure A (α : Type u) :=
(x : α) (f : α → α := λ x => x)

structure B (α : Type u) extends A α :=
(y : α := f (f x)) (g : α → α → α := λ x y => f x)

structure C (α : Type u) extends B α :=
(z : α := g x y) (x := f z)

end Ex1

open Ex1

def c1 : C Nat := { x := 1 }

#check { c1 with z := 2 }

#check { c1 with z := 2 }

theorem ex1 : { c1 with z := 2 }.z = 2 :=
rfl

#check ex1

theorem ex2 : { c1 with z := 2 }.x = c1.x :=
rfl

#check ex2

def c2 : C (Nat × Nat) := { z := (1, 1) }

#check { c2 with x.fst := 2 }

#check { c2 with x.1 := 3 }

#check show C _ from { c2.toB with .. }


/-
Copyright (c) 2021 Chris Birkbeck. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Birkbeck
-/
import group_theory.index
import group_theory.quotient_group
import group_theory.subgroup.pointwise
import group_theory.group_action.conj_act
/-!
# Commensurability for subgroups

This file defines commensurability for subgroups of a group `G`. It then goes on to prove that
commensurability defines an equivalence relation and finally defines the commensurator of a subgroup
of `G`.

## Main definitions

* `commensurable`: defines commensurability for two subgroups `H`, `K` of  `G`
* `commensurator`: defines the commensurator of a subgroup `H` of `G`.

## Implementation details

We define the commensurator of a subgroup `H` of `G` by first defining it as a subgroup of
`(conj_act G)`, which we call commensurator' and then taking the pre-image under
the map `G → (conj_act G)` to obtain our commensurator as a subgroup of `G`.
-/

variables {G : Type*} [group G]

/--Two subgroups `H K` of `G` are commensurable if `H ⊓ K` has finite index in both `H` and `K` -/
def commensurable (H K : subgroup G) : Prop :=
H.relindex K ≠ 0 ∧ K.relindex H ≠ 0

namespace commensurable

open_locale pointwise

@[refl] protected lemma refl (H : subgroup G) : commensurable H H := by
simp [commensurable]

lemma comm {H K : subgroup G} : commensurable H K ↔ commensurable K H := and.comm

@[symm] lemma symm {H K : subgroup G} : commensurable H K → commensurable K H := and.symm

@[trans] lemma trans {H K L : subgroup G} (hhk : commensurable H K) (hkl : commensurable K L) :
  commensurable H L :=
⟨subgroup.relindex_ne_zero_trans hhk.1 hkl.1, subgroup.relindex_ne_zero_trans hkl.2 hhk.2⟩

/--Equivalence of `K/H ⊓ K` with `gKg⁻¹/gHg⁻¹ ⊓ gKg⁻¹`-/
def  quot_conj_equiv (H K : subgroup G) (g : conj_act G) :
  K ⧸ (H.subgroup_of K) ≃ (g • K).1 ⧸ ((g • H).subgroup_of (g • K)) :=
quotient.congr (K.equiv_smul g).to_equiv (λ a b, by { rw [←quotient.eq', ←quotient.eq',
  quotient_group.eq', quotient_group.eq', subgroup.mem_subgroup_of, subgroup.mem_subgroup_of,
  mul_equiv.to_equiv_eq_coe, mul_equiv.coe_to_equiv, ←mul_equiv.map_inv, ←mul_equiv.map_mul,
  subgroup.equiv_smul_apply_coe, subgroup.smul_mem_pointwise_smul_iff] })

lemma commensurable_conj {H K : subgroup G} (g : conj_act G) :
   commensurable H K ↔ commensurable (g • H) (g • K) :=
and_congr (not_iff_not.mpr (eq.congr_left (cardinal.to_nat_congr (quot_conj_equiv H K g))))
  (not_iff_not.mpr (eq.congr_left (cardinal.to_nat_congr (quot_conj_equiv K H g))))

lemma commensurable_inv (H : subgroup G) (g : conj_act G) :
  commensurable (g • H) H ↔ commensurable H (g⁻¹ • H) :=
by rw [commensurable_conj, inv_smul_smul]

/-- For `H` a subgroup of `G`, this is the subgroup of all elements `g : conj_aut G`
such that `commensurable (g • H) H` -/
def commensurator' (H : subgroup G) : subgroup (conj_act G) :=
{ carrier := {g : conj_act G | commensurable (g • H) H},
  one_mem' := by rw [set.mem_set_of_eq, one_smul],
  mul_mem' := λ a b ha hb, by
  { rw [set.mem_set_of_eq, mul_smul],
    exact trans ((commensurable_conj a).mp hb) ha },
  inv_mem' := λ a ha, by rwa [set.mem_set_of_eq, comm, ←commensurable_inv] }

/-- For `H` a subgroup of `G`, this is the subgroup of all elements `g : G`
such that `commensurable (g H g⁻¹) H` -/
def commensurator (H : subgroup G) : subgroup G :=
(commensurator' H).comap (conj_act.to_conj_act.to_monoid_hom)

@[simp] lemma commensurator'_mem_iff (H : subgroup G) (g : conj_act G) :
  g ∈ (commensurator' H) ↔ commensurable (g • H) H := iff.rfl

@[simp] lemma commensurator_mem_iff (H : subgroup G) (g : G) :
  g ∈ (commensurator H) ↔ commensurable (conj_act.to_conj_act g • H) H := iff.rfl

lemma eq {H K : subgroup G} (hk : commensurable H K) :
  commensurator H = commensurator K :=
  subgroup.ext (λ x, let hx := (commensurable_conj x).1 hk in
  ⟨λ h, hx.symm.trans (h.trans hk), λ h, hx.trans (h.trans hk.symm)⟩)

end commensurable


import tactic
/--------------------------------------------------------------------------

Recall that for any ``P : Prop``, you can use ``false.elim : false → P``
  to prove ``P`` from a contradiction.

Delete the ``sorry,`` below and replace them with a legitimate proof.

--------------------------------------------------------------------------/

example (P Q R : Prop) : P ∧ false ↔ false :=
begin
  sorry,
end

theorem principle_of_explosion (P Q : Prop) : P ∧ ¬ P → Q :=
begin
  sorry,
end


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Reid Barton, Sean Leather, Yury Kudryashov
-/
import category_theory.types
import category_theory.epi_mono

/-!
# Concrete categories

A concrete category is a category `C` with a fixed faithful functor
`forget : C ⥤ Type*`.  We define concrete categories using `class
concrete_category`.  In particular, we impose no restrictions on the
carrier type `C`, so `Type` is a concrete category with the identity
forgetful functor.

Each concrete category `C` comes with a canonical faithful functor
`forget C : C ⥤ Type*`.  We say that a concrete category `C` admits a
*forgetful functor* to a concrete category `D`, if it has a functor
`forget₂ C D : C ⥤ D` such that `(forget₂ C D) ⋙ (forget D) = forget C`,
see `class has_forget₂`.  Due to `faithful.div_comp`, it suffices
to verify that `forget₂.obj` and `forget₂.map` agree with the equality
above; then `forget₂` will satisfy the functor laws automatically, see
`has_forget₂.mk'`.

Two classes helping construct concrete categories in the two most
common cases are provided in the files `bundled_hom` and
`unbundled_hom`, see their documentation for details.

## References

See [Ahrens and Lumsdaine, *Displayed Categories*][ahrens2017] for
related work.
-/

universes w v v' u

namespace category_theory

/--
A concrete category is a category `C` with a fixed faithful functor `forget : C ⥤ Type`.

Note that `concrete_category` potentially depends on three independent universe levels,
* the universe level `w` appearing in `forget : C ⥤ Type w`
* the universe level `v` of the morphisms (i.e. we have a `category.{v} C`)
* the universe level `u` of the objects (i.e `C : Type u`)
They are specified that order, to avoid unnecessary universe annotations.
-/
class concrete_category (C : Type u) [category.{v} C] :=
(forget [] : C ⥤ Type w)
[forget_faithful : faithful forget]

attribute [instance] concrete_category.forget_faithful

/-- The forgetful functor from a concrete category to `Type u`. -/
@[reducible] def forget (C : Type v) [category C] [concrete_category.{u} C] : C ⥤ Type u :=
concrete_category.forget C

instance concrete_category.types : concrete_category (Type u) :=
{ forget := 𝟭 _ }

/--
Provide a coercion to `Type u` for a concrete category. This is not marked as an instance
as it could potentially apply to every type, and so is too expensive in typeclass search.

You can use it on particular examples as:
```
instance : has_coe_to_sort X := concrete_category.has_coe_to_sort X
```
-/
def concrete_category.has_coe_to_sort (C : Type v) [category C] [concrete_category C] :
  has_coe_to_sort C :=
{ S := Type u, coe := (concrete_category.forget C).obj }

section
local attribute [instance] concrete_category.has_coe_to_sort

variables {C : Type v} [category C] [concrete_category C]

@[simp] lemma forget_obj_eq_coe {X : C} : (forget C).obj X = X := rfl

/-- Usually a bundled hom structure already has a coercion to function
that works with different universes. So we don't use this as a global instance. -/
def concrete_category.has_coe_to_fun {X Y : C} : has_coe_to_fun (X ⟶ Y) :=
{ F   := λ f, X → Y,
  coe := λ f, (forget _).map f }

local attribute [instance] concrete_category.has_coe_to_fun

/-- In any concrete category, we can test equality of morphisms by pointwise evaluations.-/
lemma concrete_category.hom_ext {X Y : C} (f g : X ⟶ Y) (w : ∀ x : X, f x = g x) : f = g :=
begin
  apply faithful.map_injective (forget C),
  ext,
  exact w x,
end

@[simp] lemma forget_map_eq_coe {X Y : C} (f : X ⟶ Y) : (forget C).map f = f := rfl

/--
Analogue of `congr_fun h x`,
when `h : f = g` is an equality between morphisms in a concrete category.
-/

@[simp] lemma coe_id {X : C} (x : X) : ((𝟙 X) : X → X) x = x :=
congr_fun ((forget _).map_id X) x

@[simp] lemma coe_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) :
  (f ≫ g) x = g (f x) :=
congr_fun ((forget _).map_comp _ _) x

@[simp] lemma coe_hom_inv_id {X Y : C} (f : X ≅ Y) (x : X) :
  f.inv (f.hom x) = x :=
congr_fun ((forget C).map_iso f).hom_inv_id x
@[simp] lemma coe_inv_hom_id {X Y : C} (f : X ≅ Y) (y : Y) :
  f.hom (f.inv y) = y :=
congr_fun ((forget C).map_iso f).inv_hom_id y

lemma concrete_category.congr_hom {X Y : C} {f g : X ⟶ Y} (h : f = g) (x : X) : f x = g x :=
congr_fun (congr_arg (λ f : X ⟶ Y, (f : X → Y)) h) x

lemma concrete_category.congr_arg {X Y : C} (f : X ⟶ Y) {x x' : X} (h : x = x') : f x = f x' :=
congr_arg (f : X → Y) h

/-- In any concrete category, injective morphisms are monomorphisms. -/
lemma concrete_category.mono_of_injective {X Y : C} (f : X ⟶ Y) (i : function.injective f) :
  mono f :=
faithful_reflects_mono (forget C) ((mono_iff_injective f).2 i)

/-- In any concrete category, surjective morphisms are epimorphisms. -/
lemma concrete_category.epi_of_surjective {X Y : C} (f : X ⟶ Y) (s : function.surjective f) :
  epi f :=
faithful_reflects_epi (forget C) ((epi_iff_surjective f).2 s)

@[simp] lemma concrete_category.has_coe_to_fun_Type {X Y : Type u} (f : X ⟶ Y) :
  coe_fn f = f :=
rfl

end

/--
`has_forget₂ C D`, where `C` and `D` are both concrete categories, provides a functor
`forget₂ C D : C ⥤ D` and a proof that `forget₂ ⋙ (forget D) = forget C`.
-/
class has_forget₂ (C : Type v) (D : Type v') [category C] [concrete_category.{u} C] [category D]
  [concrete_category.{u} D] :=
(forget₂ : C ⥤ D)
(forget_comp : forget₂ ⋙ (forget D) = forget C . obviously)

/-- The forgetful functor `C ⥤ D` between concrete categories for which we have an instance
`has_forget₂ C `. -/
@[reducible] def forget₂ (C : Type v) (D : Type v') [category C] [concrete_category C] [category D]
  [concrete_category D] [has_forget₂ C D] : C ⥤ D :=
has_forget₂.forget₂

instance forget_faithful (C : Type v) (D : Type v') [category C] [concrete_category C] [category D]
  [concrete_category D] [has_forget₂ C D] : faithful (forget₂ C D) :=
has_forget₂.forget_comp.faithful_of_comp

instance induced_category.concrete_category {C : Type v} {D : Type v'} [category D]
  [concrete_category D] (f : C → D) :
  concrete_category (induced_category D f) :=
{ forget := induced_functor f ⋙ forget D }

instance induced_category.has_forget₂ {C : Type v} {D : Type v'} [category D] [concrete_category D]
  (f : C → D) :
  has_forget₂ (induced_category D f) D :=
{ forget₂ := induced_functor f,
  forget_comp := rfl }

/--
In order to construct a “partially forgetting” functor, we do not need to verify functor laws;
it suffices to ensure that compositions agree with `forget₂ C D ⋙ forget D = forget C`.
-/
def has_forget₂.mk' {C : Type v} {D : Type v'} [category C] [concrete_category C] [category D]
  [concrete_category D] (obj : C → D) (h_obj : ∀ X, (forget D).obj (obj X) = (forget C).obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, (forget D).map (map f) == (forget C).map f) :
has_forget₂ C D :=
{ forget₂ := faithful.div _ _ _ @h_obj _ @h_map,
  forget_comp := by apply faithful.div_comp }

instance has_forget_to_Type (C : Type v) [category C] [concrete_category C] :
  has_forget₂ C (Type u) :=
{ forget₂ := forget C,
  forget_comp := functor.comp_id _ }

end category_theory


import SciLean.Data.Prod

import SciLean.Core.Attributes
import SciLean.Core.Defs
import SciLean.Core.CoreFunctions

namespace SciLean

open SciLean.Mathlib.Convenient

--------------------------------------------------------------------------------

variable {α β : Type}
variable {X Y Z W U V: Type} [Vec X] [Vec Y] [Vec Z] [Vec W] [Vec U] [Vec V]
variable {Y₁ Y₂ Y₃ : Type} [Vec Y₁] [Vec Y₂] [Vec Y₃]

open Smooth

--------------------------------------------------------------------------------
-- Expressing IsSmoothN in terms of IsSmoothT
--------------------------------------------------------------------------------

instance IsSmooth1_to_IsSmoothT (f : X → Y) [inst : IsSmoothN 1 f]
  : IsSmoothT f :=
by
  induction inst; infer_instance

instance IsSmooth2_to_IsSmoothT_2 (f : X → Y → Z) [inst : IsSmoothN 2 f] (x : X)
  : IsSmoothT (λ y => f x y) :=
by
  induction inst
  apply show_smoothness_via ((λ xy ⟿ (uncurryN 2 f) xy) |> (λ f => curry f x))
    (by ext y; simp)

instance IsSmooth2_to_IsSmoothT_1 (f : X → Y → Z) [inst : IsSmoothN 2 f]
  : IsSmoothT (λ x => λ y ⟿ f x y) :=
by
  induction inst
  apply show_smoothness_via ((λ xy ⟿ (uncurryN 2 f) xy) |> curry)
    (by ext x y; simp)

instance IsSmooth3_to_IsSmoothT_3 (f : X → Y → Z → W) [inst : IsSmoothN 3 f] (x : X) (y : Y)
  : IsSmoothT (λ z => f x y z) :=
by
  induction inst
  apply show_smoothness_via ((λ xyz ⟿ (uncurryN 3 f) xyz) |> (λ f => curry f x) |> (λ f => curry f y))
    (by ext z; simp)

instance IsSmooth3_to_IsSmoothT_2 (f : X → Y → Z → W) [inst : IsSmoothN 3 f] (x : X)
  : IsSmoothT (λ y => λ z ⟿ f x y z) :=
by
  induction inst
  apply show_smoothness_via (curry ((curry (λ xyz ⟿ (uncurryN 3 f) xyz)) x))
    (by ext y; simp)

instance IsSmooth3_to_IsSmoothT_1 (f : X → Y → Z → W) [inst : IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y z ⟿ f x y z) :=
by
  induction inst
  apply show_smoothness_via ((λ xyz ⟿ (uncurryN 3 f) xyz) |> curry |> comp curry)
    (by ext x y; simp)

-- ...

-- instance uncurry1_isSmooth {X Y} [Vec X] [Vec Y] (f : X → Y) [IsSmoothT f] : IsSmoothT (uncurryN (no_index 1) f) := sorry

instance uncurry2_isSmooth {X Y Z} [Vec X] [Vec Y] [Vec Z] (f : X → Y → Z) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y] : IsSmoothT (uncurryN (no_index 2) f) :=
  show_smoothness_via (Smooth.uncurry (λ x y ⟿ f x y)) (by ext xy; simp)

--------------------------------------------------------------------------------
-- Forgetting smoothness
--------------------------------------------------------------------------------

instance IsSmooth2_forget_y (f : X → Y → Z)
  [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y] -- [IsSmoothN 2 f]
  : IsSmoothT f :=
by
  try infer_instance
  apply show_smoothness_via (comp forget (λ x y ⟿ f x y))
    (by ext x y; simp[comp'])

instance IsSmooth3_forget_z (f : X → Y → Z → W)
  [∀ x y, IsSmoothT (λ z => f x y z)] [∀ x, IsSmoothT λ y => λ z ⟿ f x y z]
  [IsSmoothT λ x => λ y z ⟿ f x y z] -- [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ λ z => f x y z) :=
by
  try infer_instance
  apply show_smoothness_via (comp (comp forget) (λ x y z ⟿ f x y z))
    (by ext x y; simp[comp'])

instance IsSmooth3_forget_y (f : X → Y → Z → W) (y : Y)
  [∀ x y, IsSmoothT (λ z => f x y z)] [∀ x, IsSmoothT λ y => λ z ⟿ f x y z]
  [IsSmoothT λ x => λ y z ⟿ f x y z] -- [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ z ⟿ f x y z) :=
by
  try infer_instance
  apply show_smoothness_via (comp (eval y) (λ x y z ⟿ f x y z))
    (by ext x y; simp[comp'])

-- ...

--------------------------------------------------------------------------------
-- Lambda calculus rules for IsSmooth
--------------------------------------------------------------------------------

-- I: X⟿X

instance (priority:=high) IsSmoothT_rule_I : IsSmoothT (λ x : X => x) := id.property

-- K: X⟿Y⟿X

instance (priority:=high) IsSmoothT_rule_K₂ (x : X) : IsSmoothT (λ _ : Y => x) :=
by
  have h : (λ _ : Y => x) = curry fst x := by simp[curry,fst]
  rw[h]; infer_instance

instance (priority:=high) IsSmoothT_rule_K₁ : IsSmoothT (λ (x : X) => λ (_ : Y) ⟿ x) :=
by
  have h : (λ (x : X) => λ (_ : Y) ⟿ x) = curry fst := by simp[curry,fst]
  rw[h]; infer_instance

-- S: (X⟿Y⟿Z)⟿(X⟿Y)⟿X⟿Z

instance IsSmoothT_rule_S₃
  (f : X → Y → Z) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y] -- [IsSmoothN 2 f]
  (g : X → Y)  [IsSmoothT g]
  : IsSmoothT (λ x => f x (g x)) :=
by
  have h : (λ x => f x (g x))
           =
           comp (uncurry (λ x y ⟿ f x y)) (prodMap id (λ x ⟿ g x))
         := by simp[comp, uncurry, prodMap, Smooth.id]
  rw[h]; infer_instance

-- formulated `g` as unbundled morphism
instance IsSmoothT_rule_S₂
  (f : X → Y → Z)   [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y] -- [IsSmoothN 2 f]
  (g : V → (X → Y)) [∀ v, IsSmoothT (g v)] [IsSmoothT λ v => λ x ⟿ g v x] -- [IsSmoothN 2 g]
  : IsSmoothT (λ v => λ x ⟿ f x (g v x)) :=
by
  let f' := uncurry (λ x y ⟿ f x y)
  let g' := prodMap snd (uncurry (λ v x ⟿ g v x))
  have h : (λ v => λ x ⟿ f x (g v x))
           =
           curry (comp f' g')
         := by simp[comp,curry,uncurry,prodMap,fst,snd]
  rw[h]; infer_instance

-- we get the bundled morphism version automatically
example
  (f : X → Y → Z) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y] -- [IsSmoothN 2 f]
  : IsSmoothT (λ (g : X⟿Y) => λ x ⟿ f x (g x)) :=
by
  infer_instance

instance IsSmoothT_rule_S₁
  (f : U → (X → Y → Z)) [∀ u x, IsSmoothT (λ y => f u x y)] [∀ u, IsSmoothT λ x => λ y ⟿ f u x y] [IsSmoothT λ u => λ x y ⟿ f u x y] -- [IsSmoothT3 f]
  (g : V → (X → Y))      [∀ v, IsSmoothT (g v)] [IsSmoothT λ v => λ x ⟿ g v x]  -- [IsSmoothN 2 g]
  : IsSmoothT (λ u => λ v x ⟿ f u x (g v x)) :=
by
  let f' := uncurry (comp uncurry (λ u x y ⟿ f u x y))
  let g' := prodMap (fst (X:=U)) (prodMap (comp snd snd) (comp (uncurry (λ v x ⟿ g v x)) snd))
  have h : (λ u => λ v x ⟿ f u x (g v x))
           =
           comp curry (curry (comp f' g'))
         := by simp[comp,curry,uncurry,prodMap,fst,snd]
  rw[h]; infer_instance

-- Π : (α→X⟿Y)⟿(α→X)⟿α→Y

instance IsSmoothT_rule_forall₂
  (f : α → X → Y) [∀ a, IsSmoothT (f a)]
  : IsSmoothT λ (g : α → X) a => f a (g a) :=
by
  have h : (λ (g : α → X) a => f a (g a)) = forallMap' (λ a => λ x ⟿ f a x) := by simp[forallMap']
  rw[h]; infer_instance

instance IsSmoothT_rule_forall₁
  (f : U → α → X → Y) [∀ u a, IsSmoothT (f u a)] [IsSmoothT λ u a => λ x ⟿ (f u a x)]
  : IsSmoothT λ u => λ (g : α → X) ⟿ λ a => f u a (g a) :=
by
  let f' := forallMap' (λ a => uncurry (comp (proj a) (λ u ⟿ λ a => λ x ⟿ f u a x)))
  let p  := comp forallMap (forallMap' (λ _ : α => pair (X:=U) (Y:=X)))
  have h : (λ u => λ (g : α → X) ⟿ λ a => f u a (g a))
           =
           comp (comp (comp f') p) (const α)
         := by ext u g a; simp[comp']
  rw[h]; infer_instance

-- π : (α→X)⟿X

instance IsSmoothT_rule_proj (a : α)
  : IsSmoothT λ (f : α → X) => f a :=
by
  have h : (λ (f : α → X) => f a) = proj a := by simp[proj]
  rw[h]; infer_instance

-- const : X⟿(α→X)

instance IsSmoothT_rule_const
  : IsSmoothT λ (x : X) (_ : α) => x :=
by
  have h : (λ (x : X) (_ : α) => x) = const α := by simp[const]
  rw[h]; infer_instance

-- C : (α→X⟿Y)⟿X⟿α→Y

instance IsSmoothT_rule_C₂
  (f : α → X → Y) [∀ a, IsSmoothT (f a)]
  : IsSmoothT λ x a => f a x :=
by
  try infer_instance
  -- have : IsSmoothT λ x => λ y ⟿ (λ (_ : X) (g : α → X) a => f a (g a)) x y := by simp; infer_instance
  -- apply IsSmoothT_rule_S₃ (λ _ (g : α → X) a => f a (g a)) (λ x _ => x)
  have h : (λ x a => f a x)
           =
           comp (forallMap (λ a => λ x ⟿ f a x)) (const α)
         := by simp[comp, forallMap, const]
  rw[h]; infer_instance

instance (priority:=low) IsSmoothT_rule_C₁
  (f : U → α → X → Y) [∀ a u, IsSmoothT (λ x => f u a x)] [∀ a, IsSmoothT (λ u => λ x ⟿ f u a x)] -- [∀ a, IsSmoothN 2 (λ u x => f u a x)]
  : IsSmoothT λ u => λ x ⟿ λ a => f u a x :=
by
  try infer_instance
  apply show_smoothness_via
        (curry (λ xy ⟿ λ a => uncurry (λ u x ⟿ f u a x) xy))
        (by ext u x a; simp[curry'])

-- C' : (X⟿α→Y)⟿α→X⟿Y

instance (priority:=low) IsSmoothT_rule_C'₂
  (f : X → α → Y) (a : α) [IsSmoothT f]
  : IsSmoothT λ x => f x a :=
by
  try infer_instance
  have h : (λ x => f x a) = comp (proj a) (λ x ⟿ f x) := by simp[comp,proj]
  rw[h]; infer_instance

instance (priority:=low) IsSmoothT_rule_C'₁
  (f : U → X → α → Y) (a : α) [∀ u, IsSmoothT (f u)] [IsSmoothT λ u => λ x ⟿ f u x] -- [IsSmoothN 2 f]
  : IsSmoothT λ u => λ x ⟿ f u x a :=
by
  try infer_instance
  apply show_smoothness_via
        (curry (λ xy ⟿ uncurry (λ u x ⟿ f u x) xy a))
        (by ext u x; simp[uncurry'])
  done

--------------------------------------------------------------------------------
-- Unification hints and short circuits to reduce timeouts
--------------------------------------------------------------------------------

-- As a proper unification hint this causes all sorts of timeouts
instance (priority := low) IsSmoothT_rule_S₂.unif_hint_1
  (f : Y → X → Z) [∀ y, IsSmoothT (f y)] [IsSmoothT λ y => λ x ⟿ f y x]
  (g : U → Y) [IsSmoothT g]
  : IsSmoothT λ u => λ x ⟿ f (g u) x :=
by
  try infer_instance
  apply IsSmoothT_rule_S₂ (λ x y => f y x) (λ u _ => g u)

-- (Y⟿Z)⟿(X⟿Y)⟿X⟿Z

instance IsSmoothT_comp₃
  (f : Y → Z) [IsSmoothT f]
  (g : X → Y) [IsSmoothT g]
  : IsSmoothT fun x => f (g x) := by infer_instance

instance IsSmoothT_comp₂
  (f : Y → Z) [IsSmoothT f]
  (g : V → (X → Y))      [∀ v, IsSmoothT (g v)] [IsSmoothT λ v => λ x ⟿ g v x]  -- [IsSmoothT2 g]
  : IsSmoothT λ v => λ x ⟿ f (g v x) := by infer_instance

instance IsSmoothT_comp₁
  (f : U → (Y → Z)) [∀ u, IsSmoothT (λ y => f u y)] [IsSmoothT λ u => λ y ⟿ f u y] -- [IsSmoothT2 f]
  (g : V → (X → Y)) [∀ v, IsSmoothT (g v)] [IsSmoothT λ v => λ x ⟿ g v x]  -- [IsSmoothT2 g]
  : IsSmoothT λ u => λ v x ⟿ f u (g v x) :=
by
  have : IsSmoothT fun u => λ (_ : X) (y : Y) ⟿ f u y := by (try infer_instance); apply IsSmoothT_comp₃ (λ x => λ _ ⟿ x) (λ u => λ y ⟿ f u y)
  infer_instance

-- (X⟿Y⟿Z)⟿Y⟿X⟿Z

theorem IsSmoothT_swap_arguments₃
  (f : X → Y → Z)  [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y]
  : IsSmoothT (λ x => f x y) := by infer_instance

-- this is marked as instance to speed up some inferences
-- it seems to be quite dangerous hence the low priority
instance (priority:=low-10) IsSmoothT_swap_arguments₂
  (f : X → Y → Z)  [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y]
  : IsSmoothT (λ y => λ x ⟿ f x y) := by infer_instance

-- This one seems to be dangerous
-- instance (priority:=low-10) IsSmoothT_swap_arguments₁
--   (f : U → X → Y → Z)  [∀ u x, IsSmoothT (f u x)] [∀ u, IsSmoothT λ x => λ y ⟿ f u x y] [IsSmoothT λ u => λ x y ⟿ f u x y]
--   : IsSmoothT (λ u => λ y x ⟿ f u x y) := by infer_instance

-- instance (priority:=low-10) IsSmoothT_swap_arguments₁'
--   (f : U → X → Y → Z)  [∀ u x, IsSmoothT (f u x)] [∀ u, IsSmoothT λ x => λ y ⟿ f u x y] [IsSmoothT λ u => λ x y ⟿ f u x y]
--   : IsSmoothT (λ x => λ y u ⟿ f u x y) := by infer_instance

-- instance (priority:=low-10) IsSmoothT_swap_arguments₁''
--   (f : U → X → Y → Z)  [∀ u x, IsSmoothT (f u x)] [∀ u, IsSmoothT λ x => λ y ⟿ f u x y] [IsSmoothT λ u => λ x y ⟿ f u x y]
--   : IsSmoothT (λ y => λ x u ⟿ f u x y) := by infer_instance

-- instance (priority:=low-10) IsSmoothT_swap_arguments₁'''
--   (f : U → X → Y → Z)  [∀ u x, IsSmoothT (f u x)] [∀ u, IsSmoothT λ x => λ y ⟿ f u x y] [IsSmoothT λ u => λ x y ⟿ f u x y]
--   : IsSmoothT (λ y => λ u x ⟿ f u x y) := by infer_instance

-- instance (priority:=low-10) IsSmoothT_swap_arguments₀
--   (f : U → V → X → Y → Z)  [∀ u v x, IsSmoothT (f u v x)] [∀ u v, IsSmoothT λ x => λ y ⟿ f u v x y] [∀ u, IsSmoothT λ v => λ x y ⟿ f u v x y] [IsSmoothT λ u => λ v x y ⟿ f u v x y]
--   : IsSmoothT (λ u => λ v y x ⟿ f u v x y) := by infer_instance

-- instance (priority:=low-10) IsSmoothT_swap_arguments₀'
--   (f : U → V → X → Y → Z)  [∀ u v x, IsSmoothT (f u v x)] [∀ u v, IsSmoothT λ x => λ y ⟿ f u v x y] [∀ u, IsSmoothT λ v => λ x y ⟿ f u v x y] [IsSmoothT λ u => λ v x y ⟿ f u v x y]
--   : IsSmoothT (λ u => λ x y v ⟿ f u v x y) := by infer_instance

-- (X⟿X⟿Y)⟿(X⟿Y)

theorem IsSmoothT_duplicate_argument
  (f : X → X → Y) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ x' ⟿ f x x'] -- [IsSmoothT2 f]
  : IsSmoothT (λ x => f x x) := by infer_instance

instance (priority:=low-10) IsSmoothT_duplicate_argument.unif_hint_1
  (f : X → X → Y → Z) [∀ u x, IsSmoothT (λ y => f u x y)] [∀ u, IsSmoothT λ x => λ y ⟿ f u x y] [IsSmoothT λ u => λ x y ⟿ f u x y] -- [IsSmoothT3 f]
  : IsSmoothT (λ x => λ y ⟿ f x x y) :=
by
  try infer_instance
  apply IsSmoothT_duplicate_argument (λ x x' => λ y ⟿ f x x' y)

instance (priority:=low-1) IsSmoothT_duplicate_argument.unif_hint_2
  (f : U → (X → Y → Z)) [∀ u x, IsSmoothT (λ y => f u x y)] [∀ u, IsSmoothT λ x => λ y ⟿ f u x y] [IsSmoothT λ u => λ x y ⟿ f u x y] -- [IsSmoothT3 f]
  (g : U → (X → Y))      [∀ v, IsSmoothT (g v)] [IsSmoothT λ v => λ x ⟿ g v x]  -- [IsSmoothT2 g]
  : IsSmoothT (λ u => λ x ⟿ f u x (g u x)) :=
by
  try infer_instance
  apply IsSmoothT_duplicate_argument (λ u u' => λ x ⟿ f u x (g u' x))

-- (Y₁⟿Y₂⟿Z)⟿(X⟿Y₁)⟿(X⟿Y₂)⟿X⟿Z

instance IsSmoothT_comp_binop₄
  (f : Y₁ → Y₂ → Z) [∀ y₁, IsSmoothT (f y₁)] [IsSmoothT λ y₁ => λ y₂ ⟿ f y₁ y₂]
  (g₁ : X → Y₁) [IsSmoothT g₁]
  (g₂ : X → Y₂) [IsSmoothT g₂]
  : IsSmoothT fun x => f (g₁ x) (g₂ x) := by infer_instance

instance IsSmoothT_comp_binop₃ {V₂} [Vec V₂]
  (f : Y₁ → Y₂ → Z) [∀ y₁, IsSmoothT (f y₁)] [IsSmoothT λ y₁ => λ y₂ ⟿ f y₁ y₂]
  (g₁ : X → Y₁) [IsSmoothT g₁]
  (g₂ : V₂ → (X → Y₂)) [∀ v₂, IsSmoothT (g₂ v₂)] [IsSmoothT λ v₂ => λ x ⟿ g₂ v₂ x]
  : IsSmoothT λ v₂ => λ x ⟿ f (g₁ x) (g₂ v₂ x) := by infer_instance

instance IsSmoothT_comp_binop₂ {V₁ V₂} [Vec V₁] [Vec V₂]
  (f : Y₁ → Y₂ → Z) [∀ y₁, IsSmoothT (f y₁)] [IsSmoothT λ y₁ => λ y₂ ⟿ f y₁ y₂]
  (g₁ : V₁ → (X → Y₁)) [∀ v₁, IsSmoothT (g₁ v₁)] [IsSmoothT λ v₁ => λ x ⟿ g₁ v₁ x]
  (g₂ : V₂ → (X → Y₂)) [∀ v₂, IsSmoothT (g₂ v₂)] [IsSmoothT λ v₂ => λ x ⟿ g₂ v₂ x]
  : IsSmoothT λ v₁ => λ v₂ x ⟿ f (g₁ v₁ x) (g₂ v₂ x) :=
by
  have : IsSmoothT fun v₁ => λ x y ⟿ f (g₁ v₁ x) y := by (try infer_instance); apply IsSmoothT_rule_S₂ (λ _ y₁ => λ y₂ ⟿ f y₁ y₂) g₁
  infer_instance

instance IsSmoothT_comp_binop₁ {Y₁ Y₂ V₁ V₂} [Vec Y₁] [Vec Y₂] [Vec V₁] [Vec V₂]
  (f : U → (Y₁ → Y₂ → Z)) [∀ u y₁, IsSmoothT (λ y₂ => f u y₁ y₂)] [∀ u, IsSmoothT λ y₁ => λ y₂ ⟿ f u y₁ y₂] [IsSmoothT λ u => λ y₁ y₂ ⟿ f u y₁ y₂] -- [IsSmoothT3 f]
  (g₁ : V₁ → (X → Y₁))      [∀ v₁, IsSmoothT (g₁ v₁)] [IsSmoothT λ v₁ => λ x ⟿ g₁ v₁ x]  -- [IsSmoothN 2 g]
  (g₂ : V₂ → (X → Y₂))      [∀ v₂, IsSmoothT (g₂ v₂)] [IsSmoothT λ v₂ => λ x ⟿ g₂ v₂ x]  -- [IsSmoothN 2 g]
  : IsSmoothT (λ u => λ v₁ v₂ x ⟿ f u (g₁ v₁ x) (g₂ v₂ x)) :=
by
  sorry_proof
  -- have h : IsSmoothT (λ u => λ v₂ x v₁ ⟿ f u (g₁ v₁ x) (g₂ v₂ x))
  --          →
  --          IsSmoothT (λ u => λ v₁ v₂ x ⟿ f u (g₁ v₁ x) (g₂ v₂ x)) := by intro h; infer_instance
  -- apply h

  -- have : IsSmoothT fun u => λ x y v₁ ⟿ f u (g₁ v₁ x) y := by infer_instance
  -- apply IsSmoothT_rule_S₁ (λ u x y => λ v₁ ⟿ f u (g₁ v₁ x) y)

--------------------------------------------------------------------------------
-- Unification hints
--------------------------------------------------------------------------------

unif_hint IsSmoothT_comp.unif_hint.one_trailing_arg
  (f? : Y → Z) (g? : X → Y)
  (f : Y → α → Z) (g : X → Y) (a : α)
 where
  f? =?= λ x => f x a
  g? =?= g
  |-
  IsSmoothT (λ x => f? (g? x)) =?= IsSmoothT (λ x => f (g x) a)

unif_hint IsSmoothT_comp.unif_hint.two_trailing_arg
  (f? : Y → Z) (g? : X → Y)
  (f : Y → α → β → Z) (g : X → Y) (a : α) (b : β)
where
  f? =?= λ x => f x a b
  g? =?= g
  |-
  IsSmoothT (λ x => f? (g? x)) =?= IsSmoothT (λ x => f (g x) a b)

--------------------------------------------------------------------------------
-- Tests
--------------------------------------------------------------------------------

set_option synthInstance.maxSize 2000

-- TODO: make these work!

theorem comp3.arg_x.isSmooth_3 -- test also in y and x !
  (f : Y₁ → Y₂ → Y₃ → W) [IsSmoothN 3 f]
  (g₁ : X → Y → Z → Y₁) [IsSmoothN 3 g₁]
  (g₂ : X → Y → Z → Y₂) [IsSmoothN 3 g₂]
  (g₃ : X → Y → Z → Y₃) [IsSmoothN 3 g₃]
  : IsSmoothT (λ z => f (g₁ x y z) (g₂ x y z) (g₃ x y z)) :=
by
  (try infer_instance); admit

-- TODO: move these to tests

-- Test of S: (X⟿Y⟿Z)⟿(X⟿Y)⟿X⟿Z with boundled morphisms
example [Vec X] [Vec Y] [Vec Z] (f : X⟿Y⟿Z) (g : X⟿Y)
  : IsSmoothT λ (x : X) => f x (g x) := by infer_instance

example [Vec X] [Vec Y] [Vec Z] (f : X⟿Y⟿Z)
  : IsSmoothT λ (g : X⟿Y) => λ (x : X) ⟿ f x (g x) := by infer_instance

example [Vec X] [Vec Y] [Vec Z]
  : IsSmoothT λ (f : X⟿Y⟿Z) => λ (g : X⟿Y) (x : X) ⟿ f x (g x) := by infer_instance

-- binary operation
-- example
--   (f : Y₁ → Y₂ → Z) [IsSmoothN 2 f]
--   (g₁ : X → Y → Y₁) [IsSmoothN 2 g₁]
--   (g₂ : X → Y → Y₂) [IsSmoothN 2 g₂]
--   : IsSmoothT (λ x => λ y ⟿ f (g₁ x y) (g₂ x y)) := by infer_instance