/-
Copyright (c) 2018 Michael Jendrusch. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Jendrusch, Scott Morrison, Bhavik Mehta, Jakob von Raumer
-/
import category_theory.products.basic

/-!
# Monoidal categories

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

A monoidal category is a category equipped with a tensor product, unitors, and an associator.
In the definition, we provide the tensor product as a pair of functions
* `tensor_obj : C → C → C`
* `tensor_hom : (X₁ ⟶ Y₁) → (X₂ ⟶ Y₂) → ((X₁ ⊗ X₂) ⟶ (Y₁ ⊗ Y₂))`
and allow use of the overloaded notation `⊗` for both.
The unitors and associator are provided componentwise.

The tensor product can be expressed as a functor via `tensor : C × C ⥤ C`.
The unitors and associator are gathered together as natural
isomorphisms in `left_unitor_nat_iso`, `right_unitor_nat_iso` and `associator_nat_iso`.

Some consequences of the definition are proved in other files,
e.g. `(λ_ (𝟙_ C)).hom = (ρ_ (𝟙_ C)).hom` in `category_theory.monoidal.unitors_equal`.

## Implementation
Dealing with unitors and associators is painful, and at this stage we do not have a useful
implementation of coherence for monoidal categories.

In an effort to lessen the pain, we put some effort into choosing the right `simp` lemmas.
Generally, the rule is that the component index of a natural transformation "weighs more"
in considering the complexity of an expression than does a structural isomorphism (associator, etc).

As an example when we prove Proposition 2.2.4 of
<http://www-math.mit.edu/~etingof/egnobookfinal.pdf>
we state it as a `@[simp]` lemma as
```
(λ_ (X ⊗ Y)).hom = (α_ (𝟙_ C) X Y).inv ≫ (λ_ X).hom ⊗ (𝟙 Y)
```

This is far from completely effective, but seems to prove a useful principle.

## References
* Tensor categories, Etingof, Gelaki, Nikshych, Ostrik,
  http://www-math.mit.edu/~etingof/egnobookfinal.pdf
* <https://stacks.math.columbia.edu/tag/0FFK>.
-/

open category_theory

universes v u

open category_theory
open category_theory.category
open category_theory.iso

namespace category_theory

/--
In a monoidal category, we can take the tensor product of objects, `X ⊗ Y` and of morphisms `f ⊗ g`.
Tensor product does not need to be strictly associative on objects, but there is a
specified associator, `α_ X Y Z : (X ⊗ Y) ⊗ Z ≅ X ⊗ (Y ⊗ Z)`. There is a tensor unit `𝟙_ C`,
with specified left and right unitor isomorphisms `λ_ X : 𝟙_ C ⊗ X ≅ X` and `ρ_ X : X ⊗ 𝟙_ C ≅ X`.
These associators and unitors satisfy the pentagon and triangle equations.

See <https://stacks.math.columbia.edu/tag/0FFK>.
-/
class monoidal_category (C : Type u) [𝒞 : category.{v} C] :=
-- curried tensor product of objects:
(tensor_obj               : C → C → C)
(infixr (name := tensor_obj) ` ⊗ `:70 := tensor_obj) -- This notation is only temporary
-- curried tensor product of morphisms:
(tensor_hom               :
  Π {X₁ Y₁ X₂ Y₂ : C}, (X₁ ⟶ Y₁) → (X₂ ⟶ Y₂) → ((X₁ ⊗ X₂) ⟶ (Y₁ ⊗ Y₂)))
(infixr ` ⊗' `:69         := tensor_hom) -- This notation is only temporary
-- tensor product laws:
(tensor_id'               :
  ∀ (X₁ X₂ : C), (𝟙 X₁) ⊗' (𝟙 X₂) = 𝟙 (X₁ ⊗ X₂) . obviously)
(tensor_comp'             :
  ∀ {X₁ Y₁ Z₁ X₂ Y₂ Z₂ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (g₁ : Y₁ ⟶ Z₁) (g₂ : Y₂ ⟶ Z₂),
  (f₁ ≫ g₁) ⊗' (f₂ ≫ g₂) = (f₁ ⊗' f₂) ≫ (g₁ ⊗' g₂) . obviously)
-- tensor unit:
(tensor_unit []           : C)
(notation `𝟙_`            := tensor_unit)
-- associator:
(associator               :
  Π X Y Z : C, (X ⊗ Y) ⊗ Z ≅ X ⊗ (Y ⊗ Z))
(notation `α_`            := associator)
(associator_naturality'   :
  ∀ {X₁ X₂ X₃ Y₁ Y₂ Y₃ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (f₃ : X₃ ⟶ Y₃),
  ((f₁ ⊗' f₂) ⊗' f₃) ≫ (α_ Y₁ Y₂ Y₃).hom = (α_ X₁ X₂ X₃).hom ≫ (f₁ ⊗' (f₂ ⊗' f₃)) . obviously)
-- left unitor:
(left_unitor              : Π X : C, 𝟙_ ⊗ X ≅ X)
(notation `λ_`            := left_unitor)
(left_unitor_naturality'  :
  ∀ {X Y : C} (f : X ⟶ Y), ((𝟙 𝟙_) ⊗' f) ≫ (λ_ Y).hom = (λ_ X).hom ≫ f . obviously)
-- right unitor:
(right_unitor             : Π X : C, X ⊗ 𝟙_ ≅ X)
(notation `ρ_`            := right_unitor)
(right_unitor_naturality' :
  ∀ {X Y : C} (f : X ⟶ Y), (f ⊗' (𝟙 𝟙_)) ≫ (ρ_ Y).hom = (ρ_ X).hom ≫ f . obviously)
-- pentagon identity:
(pentagon'                : ∀ W X Y Z : C,
  ((α_ W X Y).hom ⊗' (𝟙 Z)) ≫ (α_ W (X ⊗ Y) Z).hom ≫ ((𝟙 W) ⊗' (α_ X Y Z).hom)
  = (α_ (W ⊗ X) Y Z).hom ≫ (α_ W X (Y ⊗ Z)).hom . obviously)
-- triangle identity:
(triangle'                :
  ∀ X Y : C, (α_ X 𝟙_ Y).hom ≫ ((𝟙 X) ⊗' (λ_ Y).hom) = (ρ_ X).hom ⊗' (𝟙 Y) . obviously)

restate_axiom monoidal_category.tensor_id'
attribute [simp] monoidal_category.tensor_id
restate_axiom monoidal_category.tensor_comp'
attribute [reassoc] monoidal_category.tensor_comp -- This would be redundant in the simp set.
attribute [simp] monoidal_category.tensor_comp
restate_axiom monoidal_category.associator_naturality'
attribute [reassoc] monoidal_category.associator_naturality
restate_axiom monoidal_category.left_unitor_naturality'
attribute [reassoc] monoidal_category.left_unitor_naturality
restate_axiom monoidal_category.right_unitor_naturality'
attribute [reassoc] monoidal_category.right_unitor_naturality
restate_axiom monoidal_category.pentagon'
restate_axiom monoidal_category.triangle'
attribute [reassoc] monoidal_category.pentagon
attribute [simp, reassoc] monoidal_category.triangle

open monoidal_category

infixr (name := tensor_obj) ` ⊗ `:70 := tensor_obj
infixr (name := tensor_hom) ` ⊗ `:70 := tensor_hom

notation `𝟙_` := tensor_unit
notation `α_` := associator
notation `λ_` := left_unitor
notation `ρ_` := right_unitor

/-- The tensor product of two isomorphisms is an isomorphism. -/
@[simps]
def tensor_iso {C : Type u} {X Y X' Y' : C} [category.{v} C] [monoidal_category.{v} C]
  (f : X ≅ Y) (g : X' ≅ Y') :
    X ⊗ X' ≅ Y ⊗ Y' :=
{ hom := f.hom ⊗ g.hom,
  inv := f.inv ⊗ g.inv,
  hom_inv_id' := by rw [←tensor_comp, iso.hom_inv_id, iso.hom_inv_id, ←tensor_id],
  inv_hom_id' := by rw [←tensor_comp, iso.inv_hom_id, iso.inv_hom_id, ←tensor_id] }

infixr (name := tensor_iso) ` ⊗ `:70 := tensor_iso

namespace monoidal_category

section

variables {C : Type u} [category.{v} C] [monoidal_category.{v} C]

instance tensor_is_iso {W X Y Z : C} (f : W ⟶ X) [is_iso f] (g : Y ⟶ Z) [is_iso g] :
  is_iso (f ⊗ g) :=
is_iso.of_iso (as_iso f ⊗ as_iso g)

@[simp] lemma inv_tensor {W X Y Z : C} (f : W ⟶ X) [is_iso f] (g : Y ⟶ Z) [is_iso g] :
  inv (f ⊗ g) = inv f ⊗ inv g :=
by { ext, simp [←tensor_comp], }

variables {U V W X Y Z : C}

lemma tensor_dite {P : Prop} [decidable P]
  {W X Y Z : C} (f : W ⟶ X) (g : P → (Y ⟶ Z)) (g' : ¬P → (Y ⟶ Z)) :
  f ⊗ (if h : P then g h else g' h) = if h : P then f ⊗ g h else f ⊗ g' h :=
by { split_ifs; refl }

lemma dite_tensor {P : Prop} [decidable P]
  {W X Y Z : C} (f : W ⟶ X) (g : P → (Y ⟶ Z)) (g' : ¬P → (Y ⟶ Z)) :
  (if h : P then g h else g' h) ⊗ f  = if h : P then g h ⊗ f else g' h ⊗ f :=
by { split_ifs; refl }

@[reassoc, simp] lemma comp_tensor_id (f : W ⟶ X) (g : X ⟶ Y) :
  (f ≫ g) ⊗ (𝟙 Z) = (f ⊗ (𝟙 Z)) ≫ (g ⊗ (𝟙 Z)) :=
by { rw ←tensor_comp, simp }

@[reassoc, simp]

@[simp, reassoc] lemma id_tensor_comp_tensor_id (f : W ⟶ X) (g : Y ⟶ Z) :
  ((𝟙 Y) ⊗ f) ≫ (g ⊗ (𝟙 X)) = g ⊗ f :=
by { rw [←tensor_comp], simp }

@[simp, reassoc] lemma tensor_id_comp_id_tensor (f : W ⟶ X) (g : Y ⟶ Z) :
  (g ⊗ (𝟙 W)) ≫ ((𝟙 Z) ⊗ f) = g ⊗ f :=
by { rw [←tensor_comp], simp }

@[simp]
lemma right_unitor_conjugation {X Y : C} (f : X ⟶ Y) :
  (f ⊗ (𝟙 (𝟙_ C))) = (ρ_ X).hom ≫ f ≫ (ρ_ Y).inv :=
by rw [←right_unitor_naturality_assoc, iso.hom_inv_id, category.comp_id]

@[simp]
lemma left_unitor_conjugation {X Y : C} (f : X ⟶ Y) :
  ((𝟙 (𝟙_ C)) ⊗ f) = (λ_ X).hom ≫ f ≫ (λ_ Y).inv :=
by rw [←left_unitor_naturality_assoc, iso.hom_inv_id, category.comp_id]

@[reassoc]
lemma left_unitor_inv_naturality {X X' : C} (f : X ⟶ X') :
  f ≫ (λ_ X').inv = (λ_ X).inv ≫ (𝟙 _ ⊗ f) :=
by simp

@[reassoc]
lemma right_unitor_inv_naturality {X X' : C} (f : X ⟶ X') :
  f ≫ (ρ_ X').inv = (ρ_ X).inv ≫ (f ⊗ 𝟙 _) :=
by simp

lemma tensor_left_iff
  {X Y : C} (f g : X ⟶ Y) :
  ((𝟙 (𝟙_ C)) ⊗ f = (𝟙 (𝟙_ C)) ⊗ g) ↔ (f = g) :=
by simp

lemma tensor_right_iff
  {X Y : C} (f g : X ⟶ Y) :
  (f ⊗ (𝟙 (𝟙_ C)) = g ⊗ (𝟙 (𝟙_ C))) ↔ (f = g) :=
by simp

/-! The lemmas in the next section are true by coherence,
but we prove them directly as they are used in proving the coherence theorem. -/
section

@[reassoc]
lemma pentagon_inv (W X Y Z : C) :
  ((𝟙 W) ⊗ (α_ X Y Z).inv) ≫ (α_ W (X ⊗ Y) Z).inv ≫ ((α_ W X Y).inv ⊗ (𝟙 Z))
    = (α_ W X (Y ⊗ Z)).inv ≫ (α_ (W ⊗ X) Y Z).inv :=
category_theory.eq_of_inv_eq_inv (by simp [pentagon])

@[reassoc, simp]
lemma right_unitor_tensor (X Y : C) :
  (ρ_ (X ⊗ Y)).hom = (α_ X Y (𝟙_ C)).hom ≫ ((𝟙 X) ⊗ (ρ_ Y).hom) :=
by
  rw [←tensor_right_iff, comp_tensor_id, ←cancel_mono (α_ X Y (𝟙_ C)).hom, assoc,
      associator_naturality, ←triangle_assoc, ←triangle, id_tensor_comp, pentagon_assoc,
      ←associator_naturality, tensor_id]

@[reassoc, simp]
lemma right_unitor_tensor_inv (X Y : C) :
  ((ρ_ (X ⊗ Y)).inv) = ((𝟙 X) ⊗ (ρ_ Y).inv) ≫ (α_ X Y (𝟙_ C)).inv :=
eq_of_inv_eq_inv (by simp)

@[simp, reassoc] lemma triangle_assoc_comp_right (X Y : C) :
  (α_ X (𝟙_ C) Y).inv ≫ ((ρ_ X).hom ⊗ 𝟙 Y) = ((𝟙 X) ⊗ (λ_ Y).hom) :=
by rw [←triangle, iso.inv_hom_id_assoc]

@[simp, reassoc] lemma triangle_assoc_comp_left_inv (X Y : C) :
  ((𝟙 X) ⊗ (λ_ Y).inv) ≫ (α_ X (𝟙_ C) Y).inv = ((ρ_ X).inv ⊗ 𝟙 Y) :=
begin
  apply (cancel_mono ((ρ_ X).hom ⊗ 𝟙 Y)).1,
  simp only [triangle_assoc_comp_right, assoc],
  rw [←id_tensor_comp, iso.inv_hom_id, ←comp_tensor_id, iso.inv_hom_id]
end

end

@[reassoc]
lemma associator_inv_naturality {X Y Z X' Y' Z' : C} (f : X ⟶ X') (g : Y ⟶ Y') (h : Z ⟶ Z') :
  (f ⊗ (g ⊗ h)) ≫ (α_ X' Y' Z').inv = (α_ X Y Z).inv ≫ ((f ⊗ g) ⊗ h) :=
by { rw [comp_inv_eq, assoc, associator_naturality], simp }

@[reassoc, simp]
lemma associator_conjugation {X X' Y Y' Z Z' : C} (f : X ⟶ X') (g : Y ⟶ Y') (h : Z ⟶ Z') :
  (f ⊗ g) ⊗ h = (α_ X Y Z).hom ≫ (f ⊗ (g ⊗ h)) ≫ (α_ X' Y' Z').inv :=
by rw [associator_inv_naturality, hom_inv_id_assoc]

@[reassoc]
lemma associator_inv_conjugation {X X' Y Y' Z Z' : C} (f : X ⟶ X') (g : Y ⟶ Y') (h : Z ⟶ Z') :
  f ⊗ g ⊗ h = (α_ X Y Z).inv ≫ ((f ⊗ g) ⊗ h) ≫ (α_ X' Y' Z').hom :=
by rw [associator_naturality, inv_hom_id_assoc]

-- TODO these next two lemmas aren't so fundamental, and perhaps could be removed
-- (replacing their usages by their proofs).
@[reassoc]
lemma id_tensor_associator_naturality {X Y Z Z' : C} (h : Z ⟶ Z') :
  (𝟙 (X ⊗ Y) ⊗ h) ≫ (α_ X Y Z').hom = (α_ X Y Z).hom ≫ (𝟙 X ⊗ (𝟙 Y ⊗ h)) :=
by { rw [←tensor_id, associator_naturality], }

@[reassoc]
lemma id_tensor_associator_inv_naturality {X Y Z X' : C} (f : X ⟶ X')  :
  (f ⊗ 𝟙 (Y ⊗ Z)) ≫ (α_ X' Y Z).inv = (α_ X Y Z).inv ≫ ((f ⊗ 𝟙 Y) ⊗ 𝟙 Z) :=
by { rw [←tensor_id, associator_inv_naturality] }

@[simp, reassoc]
lemma hom_inv_id_tensor {V W X Y Z : C} (f : V ≅ W) (g : X ⟶ Y) (h : Y ⟶ Z) :
  (f.hom ⊗ g) ≫ (f.inv ⊗ h) = (𝟙 V ⊗ g) ≫ (𝟙 V ⊗ h) :=
by rw [←tensor_comp, f.hom_inv_id, id_tensor_comp]

@[simp, reassoc]
lemma inv_hom_id_tensor {V W X Y Z : C} (f : V ≅ W) (g : X ⟶ Y) (h : Y ⟶ Z) :
  (f.inv ⊗ g) ≫ (f.hom ⊗ h) = (𝟙 W ⊗ g) ≫ (𝟙 W ⊗ h) :=
by rw [←tensor_comp, f.inv_hom_id, id_tensor_comp]

@[simp, reassoc]
lemma tensor_hom_inv_id {V W X Y Z : C} (f : V ≅ W) (g : X ⟶ Y) (h : Y ⟶ Z) :
  (g ⊗ f.hom) ≫ (h ⊗ f.inv) = (g ⊗ 𝟙 V) ≫ (h ⊗ 𝟙 V) :=
by rw [←tensor_comp, f.hom_inv_id, comp_tensor_id]

@[simp, reassoc]
lemma tensor_inv_hom_id {V W X Y Z : C} (f : V ≅ W) (g : X ⟶ Y) (h : Y ⟶ Z) :
  (g ⊗ f.inv) ≫ (h ⊗ f.hom) = (g ⊗ 𝟙 W) ≫ (h ⊗ 𝟙 W) :=
by rw [←tensor_comp, f.inv_hom_id, comp_tensor_id]

@[simp, reassoc]
lemma hom_inv_id_tensor' {V W X Y Z : C} (f : V ⟶ W) [is_iso f] (g : X ⟶ Y) (h : Y ⟶ Z) :
  (f ⊗ g) ≫ (inv f ⊗ h) = (𝟙 V ⊗ g) ≫ (𝟙 V ⊗ h) :=
by rw [←tensor_comp, is_iso.hom_inv_id, id_tensor_comp]

@[simp, reassoc]
lemma inv_hom_id_tensor' {V W X Y Z : C} (f : V ⟶ W) [is_iso f] (g : X ⟶ Y) (h : Y ⟶ Z) :
  (inv f ⊗ g) ≫ (f ⊗ h) = (𝟙 W ⊗ g) ≫ (𝟙 W ⊗ h) :=
by rw [←tensor_comp, is_iso.inv_hom_id, id_tensor_comp]

@[simp, reassoc]
lemma tensor_hom_inv_id' {V W X Y Z : C} (f : V ⟶ W) [is_iso f] (g : X ⟶ Y) (h : Y ⟶ Z) :
  (g ⊗ f) ≫ (h ⊗ inv f) = (g ⊗ 𝟙 V) ≫ (h ⊗ 𝟙 V) :=
by rw [←tensor_comp, is_iso.hom_inv_id, comp_tensor_id]

@[simp, reassoc]
lemma tensor_inv_hom_id' {V W X Y Z : C} (f : V ⟶ W) [is_iso f] (g : X ⟶ Y) (h : Y ⟶ Z) :
  (g ⊗ inv f) ≫ (h ⊗ f) = (g ⊗ 𝟙 W) ≫ (h ⊗ 𝟙 W) :=
by rw [←tensor_comp, is_iso.inv_hom_id, comp_tensor_id]

end

section
variables (C : Type u) [category.{v} C] [monoidal_category.{v} C]

/-- The tensor product expressed as a functor. -/
@[simps] def tensor : (C × C) ⥤ C :=
{ obj := λ X, X.1 ⊗ X.2,
  map := λ {X Y : C × C} (f : X ⟶ Y), f.1 ⊗ f.2 }

/-- The left-associated triple tensor product as a functor. -/
def left_assoc_tensor : (C × C × C) ⥤ C :=
{ obj := λ X, (X.1 ⊗ X.2.1) ⊗ X.2.2,
  map := λ {X Y : C × C × C} (f : X ⟶ Y), (f.1 ⊗ f.2.1) ⊗ f.2.2 }

@[simp] lemma left_assoc_tensor_obj (X) :
  (left_assoc_tensor C).obj X = (X.1 ⊗ X.2.1) ⊗ X.2.2 := rfl
@[simp] lemma left_assoc_tensor_map {X Y} (f : X ⟶ Y) :
  (left_assoc_tensor C).map f = (f.1 ⊗ f.2.1) ⊗ f.2.2 := rfl

/-- The right-associated triple tensor product as a functor. -/
def right_assoc_tensor : (C × C × C) ⥤ C :=
{ obj := λ X, X.1 ⊗ (X.2.1 ⊗ X.2.2),
  map := λ {X Y : C × C × C} (f : X ⟶ Y), f.1 ⊗ (f.2.1 ⊗ f.2.2) }

@[simp] lemma right_assoc_tensor_obj (X) :
  (right_assoc_tensor C).obj X = X.1 ⊗ (X.2.1 ⊗ X.2.2) := rfl
@[simp] lemma right_assoc_tensor_map {X Y} (f : X ⟶ Y) :
  (right_assoc_tensor C).map f = f.1 ⊗ (f.2.1 ⊗ f.2.2) := rfl

/-- The functor `λ X, 𝟙_ C ⊗ X`. -/
def tensor_unit_left : C ⥤ C :=
{ obj := λ X, 𝟙_ C ⊗ X,
  map := λ {X Y : C} (f : X ⟶ Y), (𝟙 (𝟙_ C)) ⊗ f }
/-- The functor `λ X, X ⊗ 𝟙_ C`. -/
def tensor_unit_right : C ⥤ C :=
{ obj := λ X, X ⊗ 𝟙_ C,
  map := λ {X Y : C} (f : X ⟶ Y), f ⊗ (𝟙 (𝟙_ C)) }

-- We can express the associator and the unitors, given componentwise above,
-- as natural isomorphisms.

/-- The associator as a natural isomorphism. -/
@[simps]
def associator_nat_iso :
  left_assoc_tensor C ≅ right_assoc_tensor C :=
nat_iso.of_components
  (by { intros, apply monoidal_category.associator })
  (by { intros, apply monoidal_category.associator_naturality })

/-- The left unitor as a natural isomorphism. -/
@[simps]
def left_unitor_nat_iso :
  tensor_unit_left C ≅ 𝟭 C :=
nat_iso.of_components
  (by { intros, apply monoidal_category.left_unitor })
  (by { intros, apply monoidal_category.left_unitor_naturality })

/-- The right unitor as a natural isomorphism. -/
@[simps]
def right_unitor_nat_iso :
  tensor_unit_right C ≅ 𝟭 C :=
nat_iso.of_components
  (by { intros, apply monoidal_category.right_unitor })
  (by { intros, apply monoidal_category.right_unitor_naturality })

section
variables {C}

/-- Tensoring on the left with a fixed object, as a functor. -/
@[simps]
def tensor_left (X : C) : C ⥤ C :=
{ obj := λ Y, X ⊗ Y,
  map := λ Y Y' f, (𝟙 X) ⊗ f, }

/--
Tensoring on the left with `X ⊗ Y` is naturally isomorphic to
tensoring on the left with `Y`, and then again with `X`.
-/
def tensor_left_tensor (X Y : C) : tensor_left (X ⊗ Y) ≅ tensor_left Y ⋙ tensor_left X :=
nat_iso.of_components
  (associator _ _)
  (λ Z Z' f, by { dsimp, rw[←tensor_id], apply associator_naturality })

@[simp] lemma tensor_left_tensor_hom_app (X Y Z : C) :
  (tensor_left_tensor X Y).hom.app Z = (associator X Y Z).hom :=
rfl
@[simp] lemma tensor_left_tensor_inv_app (X Y Z : C) :
  (tensor_left_tensor X Y).inv.app Z = (associator X Y Z).inv :=
by { simp [tensor_left_tensor], }

/-- Tensoring on the right with a fixed object, as a functor. -/
@[simps]
def tensor_right (X : C) : C ⥤ C :=
{ obj := λ Y, Y ⊗ X,
  map := λ Y Y' f, f ⊗ (𝟙 X), }

variables (C)

/--
Tensoring on the left, as a functor from `C` into endofunctors of `C`.

TODO: show this is a op-monoidal functor.
-/
@[simps]
def tensoring_left : C ⥤ C ⥤ C :=
{ obj := tensor_left,
  map := λ X Y f,
  { app := λ Z, f ⊗ (𝟙 Z) } }

instance : faithful (tensoring_left C) :=
{ map_injective' := λ X Y f g h,
  begin
    injections with h,
    replace h := congr_fun h (𝟙_ C),
    simpa using h,
  end }

/--
Tensoring on the right, as a functor from `C` into endofunctors of `C`.

We later show this is a monoidal functor.
-/
@[simps]
def tensoring_right : C ⥤ C ⥤ C :=
{ obj := tensor_right,
  map := λ X Y f,
  { app := λ Z, (𝟙 Z) ⊗ f } }

instance : faithful (tensoring_right C) :=
{ map_injective' := λ X Y f g h,
  begin
    injections with h,
    replace h := congr_fun h (𝟙_ C),
    simpa using h,
  end }

variables {C}

/--
Tensoring on the right with `X ⊗ Y` is naturally isomorphic to
tensoring on the right with `X`, and then again with `Y`.
-/
def tensor_right_tensor (X Y : C) : tensor_right (X ⊗ Y) ≅ tensor_right X ⋙ tensor_right Y :=
nat_iso.of_components
  (λ Z, (associator Z X Y).symm)
  (λ Z Z' f, by { dsimp, rw[←tensor_id], apply associator_inv_naturality })

@[simp] lemma tensor_right_tensor_hom_app (X Y Z : C) :
  (tensor_right_tensor X Y).hom.app Z = (associator Z X Y).inv :=
rfl
@[simp] lemma tensor_right_tensor_inv_app (X Y Z : C) :
  (tensor_right_tensor X Y).inv.app Z = (associator Z X Y).hom :=
by simp [tensor_right_tensor]

end

end

section

universes v₁ v₂ u₁ u₂

variables (C₁ : Type u₁) [category.{v₁} C₁] [monoidal_category.{v₁} C₁]
variables (C₂ : Type u₂) [category.{v₂} C₂] [monoidal_category.{v₂} C₂]

local attribute [simp]
associator_naturality left_unitor_naturality right_unitor_naturality pentagon

@[simps tensor_obj tensor_hom tensor_unit associator]
instance prod_monoidal : monoidal_category (C₁ × C₂) :=
{ tensor_obj := λ X Y, (X.1 ⊗ Y.1, X.2 ⊗ Y.2),
  tensor_hom := λ _ _ _ _ f g, (f.1 ⊗ g.1, f.2 ⊗ g.2),
  tensor_unit := (𝟙_ C₁, 𝟙_ C₂),
  associator := λ X Y Z, (α_ X.1 Y.1 Z.1).prod (α_ X.2 Y.2 Z.2),
  left_unitor := λ ⟨X₁, X₂⟩, (λ_ X₁).prod (λ_ X₂),
  right_unitor := λ ⟨X₁, X₂⟩, (ρ_ X₁).prod (ρ_ X₂) }

@[simp] lemma prod_monoidal_left_unitor_hom_fst (X : C₁ × C₂) :
  ((λ_ X).hom : (𝟙_ _) ⊗ X ⟶ X).1 = (λ_ X.1).hom := by { cases X, refl }

@[simp] lemma prod_monoidal_left_unitor_hom_snd (X : C₁ × C₂) :
  ((λ_ X).hom : (𝟙_ _) ⊗ X ⟶ X).2 = (λ_ X.2).hom := by { cases X, refl }

@[simp] lemma prod_monoidal_left_unitor_inv_fst (X : C₁ × C₂) :
  ((λ_ X).inv : X ⟶ (𝟙_ _) ⊗ X).1 = (λ_ X.1).inv := by { cases X, refl }

@[simp] lemma prod_monoidal_left_unitor_inv_snd (X : C₁ × C₂) :
  ((λ_ X).inv : X ⟶ (𝟙_ _) ⊗ X).2 = (λ_ X.2).inv := by { cases X, refl }

@[simp] lemma prod_monoidal_right_unitor_hom_fst (X : C₁ × C₂) :
  ((ρ_ X).hom : X ⊗ (𝟙_ _) ⟶ X).1 = (ρ_ X.1).hom := by { cases X, refl }

@[simp] lemma prod_monoidal_right_unitor_hom_snd (X : C₁ × C₂) :
  ((ρ_ X).hom : X ⊗ (𝟙_ _) ⟶ X).2 = (ρ_ X.2).hom := by { cases X, refl }

@[simp] lemma prod_monoidal_right_unitor_inv_fst (X : C₁ × C₂) :
  ((ρ_ X).inv : X ⟶ X ⊗ (𝟙_ _)).1 = (ρ_ X.1).inv := by { cases X, refl }

@[simp] lemma prod_monoidal_right_unitor_inv_snd (X : C₁ × C₂) :
  ((ρ_ X).inv : X ⟶ X ⊗ (𝟙_ _)).2 = (ρ_ X.2).inv := by { cases X, refl }

end

end monoidal_category

end category_theory


/-
Copyright (c) 2019 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.list
import Mathlib.PostPort

universes u_1 u_2 l

namespace Mathlib

/-!
# W types

Given `α : Type` and `β : α → Type`, the W type determined by this data, `W_type β`, is the
inductively defined type of trees where the nodes are labeled by elements of `α` and the children of
a node labeled `a` are indexed by elements of `β a`.

This file is currently a stub, awaiting a full development of the theory. Currently, the main result
is that if `α` is an encodable fintype and `β a` is encodable for every `a : α`, then `W_type β` is
encodable. This can be used to show the encodability of other inductive types, such as those that
are commonly used to formalize syntax, e.g. terms and expressions in a given language. The strategy
is illustrated in the example found in the file `prop_encodable` in the `archive/examples` folder of
mathlib.

## Implementation details

While the name `W_type` is somewhat verbose, it is preferable to putting a single character
identifier `W` in the root namespace.
-/

/--
Given `β : α → Type*`, `W_type β` is the type of finitely branching trees where nodes are labeled by
elements of `α` and the children of a node labeled `a` are indexed by elements of `β a`.
-/
inductive W_type {α : Type u_1} (β : α → Type u_2) where
| mk : (a : α) → (β a → W_type β) → W_type β

protected instance W_type.inhabited : Inhabited (W_type fun (_x : Unit) => empty) :=
  { default := W_type.mk Unit.unit empty.elim }

namespace W_type

/-- The depth of a finitely branching tree. -/
def depth {α : Type u_1} {β : α → Type u_2} [(a : α) → fintype (β a)] : W_type β → ℕ := sorry

theorem depth_pos {α : Type u_1} {β : α → Type u_2} [(a : α) → fintype (β a)] (t : W_type β) :
    0 < depth t :=
  W_type.cases_on t
    fun (t_a : α) (t_f : β t_a → W_type β) =>
      nat.succ_pos (finset.sup finset.univ fun (n : β t_a) => depth (t_f n))

theorem depth_lt_depth_mk {α : Type u_1} {β : α → Type u_2} [(a : α) → fintype (β a)] (a : α)
    (f : β a → W_type β) (i : β a) : depth (f i) < depth (mk a f) :=
  nat.lt_succ_of_le (finset.le_sup (finset.mem_univ i))

end W_type

/-
Show that W types are encodable when `α` is an encodable fintype and for every `a : α`, `β a` is
encodable.

We define an auxiliary type `W_type' β n` of trees of depth at most `n`, and then we show by
induction on `n` that these are all encodable. These auxiliary constructions are not interesting in
and of themselves, so we mark them as `private`.
-/

namespace encodable

/-- `W_type` is encodable when `α` is an encodable fintype and for every `a : α`, `β a` is
encodable. -/
protected instance W_type.encodable {α : Type u_1} {β : α → Type u_2} [(a : α) → fintype (β a)]
    [(a : α) → encodable (β a)] [encodable α] : encodable (W_type β) :=
  let f : W_type β → sigma fun (n : ℕ) => W_type' β n :=
    fun (t : W_type β) => sigma.mk (W_type.depth t) { val := t, property := sorry };
  let finv : (sigma fun (n : ℕ) => W_type' β n) → W_type β :=
    fun (p : sigma fun (n : ℕ) => W_type' β n) => subtype.val (sigma.snd p);
  of_left_inverse f finv sorry

end Mathlib


import number_theory.bernoulli

--OUTPUT 1
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  -- We apply strong induction on $n$. So, for all $m < d$, we have $B_{m} (1 + x) = B_{m} (x) + m x^{m - 1}$ and we want to show that $$B_{d} (1 + x) = B_{d} (x) + d x^{d - 1}$$
  induction n with d hd,
  { -- base case
    -- $B_0 (1 + x) = B_0 (x) + 0 x^{0 - 1}$
    have h1 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0 * x^(0 - 1), from by auto [polynomial.bernoulli_zero, polynomial.eval_zero, polynomial.eval_one, polynomial.eval_add, polynomial.eval_mul, polynomial.eval_pow, polynomial.eval_C],
    -- $B_0 (1 + x) = B_0 (x) + 0$
    have h2 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0, from by auto [h1],
    -- $B_0 (1 + x) = B_0 (x)$
    have h3 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x, from by auto [h2],
    -- $B_0 (1 + x) = 1$
    have h4 : (polynomial.bernoulli 0).eval (1 + x) = 1, from by auto [polynomial.bernoulli_zero, polynomial.eval_zero, polynomial.eval_one, polynomial.eval_add, polynomial.eval_mul, polynomial.eval_pow, polynomial.eval_C],
    -- $1 = 1$
    have h5 : 1 = 1, from by auto [h4],
    -- $B_0 (1 + x) = B_0 (x) + 0 x^{0 - 1}$
    have h6 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0 * x^(0 - 1), from by auto [h5],
    -- $B_0 (1 + x) = B_0 (x) + 0$
    have h7 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0, from by auto [h6],
    -- $B_0 (1 + x) = B_0 (x)$
    have h8 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x, from by auto [h7],
    -- $B_0 (1 + x) = B_0 (x) + 0 x^{0 - 1}$
    have h9 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0 * x^(0 - 1), from by auto [h8],
    -- $B_0 (1 + x) = B_0 (x) + 0$
    have h10 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0, from by auto [h9],
    -- $B_0 (1 + x) = B_0 (x)$
    have h11 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x, from by auto [h10],
    -- $B_0 (1 + x) = B_0 (x) + 0 x^{0 - 1}$
    have h12 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0 * x^(0 - 1), from by auto [h11],
    -- $B_0 (1 + x) = B_0 (x) + 0$
    have h13 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0, from by auto [h12],
    -- $B_0 (1 + x) = B_0 (x)$
    have h14 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x, from by auto [h13],
    -- $B_0 (1 + x) = B_0 (x) + 0 x^{0 - 1}$
    have h15 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0 * x^(0 - 1), from by auto [h14],
    -- $B_0 (1 + x) = B_0 (x) + 0$
    have h16 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0, from by auto [h15],
    -- $B_0 (1 + x) = B_0 (x)$
    have h17 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x, from by auto [h16],
    -- $B_0 (1 + x) = B_0 (x) + 0 x^{0 - 1}$
    have h18 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0 * x^(0 - 1), from by auto [h17],
    -- $B_0 (1 + x) = B_0 (x) + 0$
    have h19 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0, from by auto [h18],
    -- $B_0 (1 + x) = B_0 (x)$
    have h20 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x, from by auto [h19],
    -- $B_0 (1 + x) = B_0 (x) + 0 x^{0 - 1}$
    have h21 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0 * x^(0 - 1), from by auto [h20],
    -- $B_0 (1 + x) = B_0 (x) + 0$
    have h22 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0, from by auto [h21],
    -- $B_0 (1 + x) = B_0 (x)$
    have h23 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x, from by auto [h22],
    -- $B_0 (1 + x) = B_0 (x) + 0 x^{0 - 1}$
    have h24 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0 * x^(0 - 1), from by auto [h23],
    -- $B_0 (1 + x) = B_0 (x) + 0$
    have h25 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0, from by auto [h24],
    -- $B_0 (1 + x) = B_0 (x)$
    have h26 : (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x, from by auto [h25],
    -- $B_0 (1 + x) = B_0 (x) + 0 x^{0 - 1}$
    have h27 : (
end --Needs more than 2000 tokens!

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

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

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

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

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

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

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

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

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

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

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

Setting $b = a$, this becomes:

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

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

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

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

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

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

/--`theorem`
Bernoulli polynomial evaluation
Given a natural number $n$ and a rational $x$, let $B_n (x)$ denote the $n$-th Bernoulli polynomial evaluated at $x$. Then, $$B_n (1 + x) = B_n (x) + n x^{n - 1}$$
`proof`
We apply strong induction on $n$. So, for all $m < d$, we have $B_{m} (1 + x) = B_{m} (x) + m x^{m - 1}$ and we want to show that $$B_{d} (1 + x) = B_{d} (x) + d x^{d - 1}$$
Multiplying both sides by $d + 1$, and using the fact that, for all $l \in \mathbb{N}$, $\sum_{k = 0}^{l} {l + 1 \choose k} B_k = (l + 1) X^l$ (where $B_k$ is the $k$-th Bernoulli number), we get that
$$ (d + 1) (1 + x)^d - (d + 1) x^d = \sum_{l = 0}^{d} {d + 1 \choose l} l x^{l - 1} $$
The conclusion then follows easily.

QED

-/
theorem  bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
FEW SHOT PROMPTS TO CODEX(END)-/


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

! This file was ported from Lean 3 source module group_theory.group_action.sigma
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.GroupTheory.GroupAction.Defs

/-!
# Sigma instances for additive and multiplicative actions

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

This file defines instances for arbitrary sum of additive and multiplicative actions.

## See also

* `group_theory.group_action.pi`
* `group_theory.group_action.prod`
* `group_theory.group_action.sum`
-/

variable {ι : Type _} {M N : Type _} {α : ι → Type _}

namespace Sigma

section SMul

variable [∀ i, SMul M (α i)] [∀ i, SMul N (α i)] (a : M) (i : ι) (b : α i) (x : Σi, α i)

@[to_additive Sigma.hasVadd]
instance : SMul M (Σi, α i) :=
  ⟨fun a => Sigma.map id fun i => (· • ·) a⟩

/- warning: sigma.smul_def -> Sigma.smul_def is a dubious translation:
lean 3 declaration is
  forall {ι : Type.{u1}} {M : Type.{u2}} {α : ι -> Type.{u3}} [_inst_1 : forall (i : ι), SMul.{u2, u3} M (α i)] (a : M) (x : Sigma.{u1, u3} ι (fun (i : ι) => α i)), Eq.{succ (max u1 u3)} (Sigma.{u1, u3} ι (fun (i : ι) => α i)) (SMul.smul.{u2, max u1 u3} M (Sigma.{u1, u3} ι (fun (i : ι) => α i)) (Sigma.hasSmul.{u1, u2, u3} ι M (fun (i : ι) => α i) (fun (i : ι) => _inst_1 i)) a x) (Sigma.map.{u1, u1, u3, u3} ι ι (fun (i : ι) => α i) (fun (i : ι) => α i) (id.{succ u1} ι) (fun (i : ι) => SMul.smul.{u2, u3} M (α i) (_inst_1 i) a) x)
but is expected to have type
  forall {ι : Type.{u3}} {M : Type.{u1}} {α : ι -> Type.{u2}} [_inst_1 : forall (i : ι), SMul.{u1, u2} M (α i)] (a : M) (x : Sigma.{u3, u2} ι (fun (i : ι) => α i)), Eq.{max (succ u3) (succ u2)} (Sigma.{u3, u2} ι (fun (i : ι) => α i)) (HSMul.hSMul.{u1, max u3 u2, max u3 u2} M (Sigma.{u3, u2} ι (fun (i : ι) => α i)) (Sigma.{u3, u2} ι (fun (i : ι) => α i)) (instHSMul.{u1, max u3 u2} M (Sigma.{u3, u2} ι (fun (i : ι) => α i)) (Sigma.instSMulSigma.{u3, u1, u2} ι M (fun (i : ι) => α i) (fun (i : ι) => _inst_1 i))) a x) (Sigma.map.{u3, u3, u2, u2} ι ι (fun (i : ι) => α i) α (id.{succ u3} ι) (fun (i : ι) => (fun (x._@.Mathlib.GroupTheory.GroupAction.Sigma._hyg.231 : M) (x._@.Mathlib.GroupTheory.GroupAction.Sigma._hyg.233 : α i) => HSMul.hSMul.{u1, u2, u2} M (α i) (α (id.{succ u3} ι i)) (instHSMul.{u1, u2} M (α i) (_inst_1 i)) x._@.Mathlib.GroupTheory.GroupAction.Sigma._hyg.231 x._@.Mathlib.GroupTheory.GroupAction.Sigma._hyg.233) a) x)
Case conversion may be inaccurate. Consider using '#align sigma.smul_def Sigma.smul_defₓ'. -/
@[to_additive]
theorem smul_def : a • x = x.map id fun i => (· • ·) a :=
  rfl
#align sigma.smul_def Sigma.smul_def
#align sigma.vadd_def Sigma.vadd_def

/- warning: sigma.smul_mk -> Sigma.smul_mk is a dubious translation:
lean 3 declaration is
  forall {ι : Type.{u1}} {M : Type.{u2}} {α : ι -> Type.{u3}} [_inst_1 : forall (i : ι), SMul.{u2, u3} M (α i)] (a : M) (i : ι) (b : α i), Eq.{succ (max u1 u3)} (Sigma.{u1, u3} ι (fun (i : ι) => α i)) (SMul.smul.{u2, max u1 u3} M (Sigma.{u1, u3} ι (fun (i : ι) => α i)) (Sigma.hasSmul.{u1, u2, u3} ι M (fun (i : ι) => α i) (fun (i : ι) => _inst_1 i)) a (Sigma.mk.{u1, u3} ι (fun (i : ι) => α i) i b)) (Sigma.mk.{u1, u3} ι (fun (i : ι) => α i) i (SMul.smul.{u2, u3} M (α i) (_inst_1 i) a b))
but is expected to have type
  forall {ι : Type.{u3}} {M : Type.{u1}} {α : ι -> Type.{u2}} [_inst_1 : forall (i : ι), SMul.{u1, u2} M (α i)] (a : M) (i : ι) (b : α i), Eq.{max (succ u3) (succ u2)} (Sigma.{u3, u2} ι α) (HSMul.hSMul.{u1, max u2 u3, max u3 u2} M (Sigma.{u3, u2} ι α) (Sigma.{u3, u2} ι α) (instHSMul.{u1, max u3 u2} M (Sigma.{u3, u2} ι α) (Sigma.instSMulSigma.{u3, u1, u2} ι M (fun (i : ι) => α i) (fun (i : ι) => _inst_1 i))) a (Sigma.mk.{u3, u2} ι α i b)) (Sigma.mk.{u3, u2} ι α i (HSMul.hSMul.{u1, u2, u2} M (α i) (α i) (instHSMul.{u1, u2} M (α i) (_inst_1 i)) a b))
Case conversion may be inaccurate. Consider using '#align sigma.smul_mk Sigma.smul_mkₓ'. -/
@[simp, to_additive]
theorem smul_mk : a • mk i b = ⟨i, a • b⟩ :=
  rfl
#align sigma.smul_mk Sigma.smul_mk
#align sigma.vadd_mk Sigma.vadd_mk

@[to_additive]
instance [SMul M N] [∀ i, IsScalarTower M N (α i)] : IsScalarTower M N (Σi, α i) :=
  ⟨fun a b x => by
    cases x
    rw [smul_mk, smul_mk, smul_mk, smul_assoc]⟩

@[to_additive]
instance [∀ i, SMulCommClass M N (α i)] : SMulCommClass M N (Σi, α i) :=
  ⟨fun a b x => by
    cases x
    rw [smul_mk, smul_mk, smul_mk, smul_mk, smul_comm]⟩

@[to_additive]
instance [∀ i, SMul Mᵐᵒᵖ (α i)] [∀ i, IsCentralScalar M (α i)] : IsCentralScalar M (Σi, α i) :=
  ⟨fun a x => by
    cases x
    rw [smul_mk, smul_mk, op_smul_eq_smul]⟩

/- warning: sigma.has_faithful_smul' -> Sigma.FaithfulSMul' is a dubious translation:
lean 3 declaration is
  forall {ι : Type.{u1}} {M : Type.{u2}} {α : ι -> Type.{u3}} [_inst_1 : forall (i : ι), SMul.{u2, u3} M (α i)] (i : ι) [_inst_3 : FaithfulSMul.{u2, u3} M (α i) (_inst_1 i)], FaithfulSMul.{u2, max u1 u3} M (Sigma.{u1, u3} ι (fun (i : ι) => α i)) (Sigma.hasSmul.{u1, u2, u3} ι M (fun (i : ι) => α i) (fun (i : ι) => _inst_1 i))
but is expected to have type
  forall {ι : Type.{u1}} {M : Type.{u3}} {α : ι -> Type.{u2}} [_inst_1 : forall (i : ι), SMul.{u3, u2} M (α i)] (i : ι) [_inst_3 : FaithfulSMul.{u3, u2} M (α i) (_inst_1 i)], FaithfulSMul.{u3, max u2 u1} M (Sigma.{u1, u2} ι (fun (i : ι) => α i)) (Sigma.instSMulSigma.{u1, u3, u2} ι M (fun (i : ι) => α i) (fun (i : ι) => _inst_1 i))
Case conversion may be inaccurate. Consider using '#align sigma.has_faithful_smul' Sigma.FaithfulSMul'ₓ'. -/
/-- This is not an instance because `i` becomes a metavariable. -/
@[to_additive "This is not an instance because `i` becomes a metavariable."]
protected theorem FaithfulSMul' [FaithfulSMul M (α i)] : FaithfulSMul M (Σi, α i) :=
  ⟨fun x y h => eq_of_smul_eq_smul fun a : α i => heq_iff_eq.1 (ext_iff.1 <| h <| mk i a).2⟩
#align sigma.has_faithful_smul' Sigma.FaithfulSMul'
#align sigma.has_faithful_vadd' Sigma.FaithfulVAdd'

@[to_additive]
instance [Nonempty ι] [∀ i, FaithfulSMul M (α i)] : FaithfulSMul M (Σi, α i) :=
  Nonempty.elim ‹_› fun i => Sigma.FaithfulSMul' i

end SMul

@[to_additive]
instance {m : Monoid M} [∀ i, MulAction M (α i)] : MulAction M (Σi, α i)
    where
  mul_smul a b x := by
    cases x
    rw [smul_mk, smul_mk, smul_mk, mul_smul]
  one_smul x := by
    cases x
    rw [smul_mk, one_smul]

end Sigma


/- This file includes proofs of the axioms for the 3 parallel operators ||, |_ and |. This also includes some axioms for the deadlock operator. -/
import .iff_lemmas

open mcrl2

variable {α : Type}
variable [comm_semigroup_with_zero α]

/- parl_def ((x || y) = x |_ y + y |_ x + x | y) needs to be proved via bisimulation-/

lemma transition.parl_seq_atom (a₁) (x : mcrl2 α) (x' : option (mcrl2 α)) (a₂)  :
transition ((atom a₁) |_ x) a₂ x' ↔ transition ((atom a₁) ⬝ x) a₂ x' :=
begin
  simp [transition.parl_iff, transition.atom_iff, transition.seq_iff, and_rotate, exists_eq_left]
end

/- parl_seq  (((atom a ⬝ x) |_ y) = (atom a) ⬝ (x || y)) needs to be proved via bisimulation.-/

lemma transition.parl_alt (x y z : mcrl2 α) (x' : option (mcrl2 α)) (a) :
  transition ((x + y) |_ z) a x' ↔ transition (x |_ z + y |_ z) a x' :=
begin
  simp only [transition.alt_iff, transition.parl_iff, and_or_distrib_left, exists_or_distrib]
end

lemma transition.comm_success (a b c : α) (h₁ : a * b = c)  (x' : option (mcrl2 α)) (d):
transition ((atom a) ∣ (atom b)) d x' ↔ transition (atom c) d x' :=
begin
  simp only [transition.comm_iff, transition.atom_iff, ← h₁, exists_and_distrib_left,
      exists_and_distrib_right, ← and_assoc, @eq_comm _ b, exists_eq_right, par'],
  split,
  { intro h,
    cases h with h hb,
    cases h with h ha,
    cases h with h hd,
    cases h with hx' hdab,
    apply and.intro,
    { apply and.intro hx',
      rw ← hdab,
      assumption},
    {assumption}},
  { intro h,
    cases h with h hdab,
    cases h with hx' hab,
    repeat {apply and.intro},
    assumption,
    assumption,
    { rw hdab,
      assumption},
    { intro h,
      rw h at hab,
      exact hab (zero_mul b)},
    { intro h,
      rw h at hab,
      exact hab (mul_zero a)}}
end

lemma transition.comm_fail (a b : α) (h₁ : a * b = 0)  (x' : option (mcrl2 α)) (d) :
transition ((atom a) ∣ (atom b)) d x' ↔ transition δ d x' :=
begin
  simp [transition.deadlock_iff, transition.comm_iff, transition.atom_iff],
  intros x y hx' a' b' hd hnd hx ha ha' hy hb hb',
  simp [hd, ha', hb'] at hnd,
  exact hnd h₁
end

lemma transition.comm_seq_distl (a b : α) (x : mcrl2 α) (x' : option (mcrl2 α)) (c) :
transition ((atom a) ⬝ x ∣ (atom b)) c x' ↔ transition ((atom a ∣ atom b)⬝ x) c x' :=
begin
  simp [transition.comm_iff, transition.seq_iff, transition.atom_iff, ← and_assoc]
end

lemma transition.comm_seq_distr (a b : α) (x : mcrl2 α) (x' : option (mcrl2 α)) (c) :
transition ((atom a) ∣ (atom b) ⬝ x) c x' ↔ transition ((atom a ∣ atom b)⬝ x) c x' :=
begin
  simp [transition.comm_iff, transition.seq_iff, transition.atom_iff, ← and_assoc]
end

lemma transition.comm_seq_dist (a b : α) (x y : mcrl2 α) (x' : option (mcrl2 α)) (c) :
transition ((atom a) ⬝ x ∣ (atom b) ⬝ y) c x' ↔ transition ((atom a ∣ atom b)⬝ (x || y)) c x' :=
begin
  simp [transition.comm_iff, transition.seq_iff, transition.atom_iff, ← and_assoc]
end

lemma transition.comm_alt_distl  (x y z : mcrl2 α) (x' : option (mcrl2 α)) (a):
transition ((x + y) ∣ z) a x' ↔ transition (x ∣z + y ∣ z) a x' :=
begin
  simp [transition.alt_iff, transition.comm_iff, ← and_assoc, exists_or_distrib, or_and_distrib_right, and_or_distrib_left]
end

lemma transition.comm_alt_distr (x y z : mcrl2 α) (x' : option (mcrl2 α)) (a)  :
transition (x ∣ (y + z)) a x' ↔ transition (x ∣ y + x ∣ z) a x' :=
begin
  simp [transition.alt_iff, transition.comm_iff, ← and_assoc, exists_or_distrib, or_and_distrib_right, and_or_distrib_left]
end

lemma transition.alt_deadlock  (x : mcrl2 α) (z) (a) :
transition (x + δ) a z ↔ transition x a z :=
begin
  simp [transition.alt_iff, transition.deadlock_iff]
end

lemma transition.seq_deadlock (x : mcrl2 α) (z) (a):
transition (δ ⬝ x) a z ↔ transition δ a z :=
begin
  simp [transition.seq_iff, transition.deadlock_iff]
end

lemma transition.parl_deadlock (x: mcrl2 α) (z) (a) :
transition (δ |_ x) a z ↔ transition (δ : mcrl2 α) a z :=
begin
  simp [transition.parl_iff, transition.deadlock_iff]
end

lemma transition.comm_deadlockl (x z) (a) :
transition ((δ : mcrl2 α) ∣ x) a z ↔ transition (δ : mcrl2 α) a z :=
begin
  simp [transition.comm_iff, transition.deadlock_iff]
end

lemma transition.comm_deadlockr (x z) (a) :
transition (x ∣ (δ : mcrl2 α)) a z ↔ transition (δ : mcrl2 α) a z :=
begin
  simp [transition.comm_iff, transition.deadlock_iff]
end


import phase0.params

/-!
# Pretangles
-/

noncomputable theory

universe u

namespace con_nf
variables [params.{u}] {α : Λ}

/-- A *pretangle* is an object that may become a *tangle*, an element of the model.
The type of pretangles forms a model of TTT without extensionality. -/
def pretangle : type_index → Type u
| ⊥ := atom
| (α : Λ) := Π β : type_index, β < α → set (pretangle β)
using_well_founded { dec_tac := `[assumption] }

namespace pretangle

/-- The "identity" equivalence between `atom` and `pretangle ⊥`. -/
def to_bot : atom ≃ pretangle ⊥ := equiv.cast $ by unfold pretangle

/-- The "identity" equivalence between `pretangle ⊥` and `atom`. -/
def of_bot : pretangle ⊥ ≃ atom := equiv.cast $ by unfold pretangle

/-- The "identity" equivalence between `Π β < α, set (pretangle β)` and `pretangle α`. -/
def to_coe : (Π β : type_index, β < α → set (pretangle β)) ≃ pretangle α :=
equiv.cast $ by unfold pretangle

/-- The "identity" equivalence between `pretangle α` and `Π β < α, set (pretangle β)`. -/
def of_coe : pretangle α ≃ Π β : type_index, β < α → set (pretangle β) :=
equiv.cast $ by unfold pretangle

@[simp] lemma to_bot_symm : to_bot.symm = of_bot := rfl
@[simp] lemma of_bot_symm : of_bot.symm = to_bot := rfl
@[simp] lemma to_coe_symm : to_coe.symm = (of_coe : pretangle α ≃ _) := rfl
@[simp] lemma of_coe_symm : of_coe.symm = (to_coe : _ ≃ pretangle α) := rfl
@[simp] lemma to_bot_of_bot (a) : to_bot (of_bot a) = a := by simp [to_bot, of_bot]
@[simp] lemma of_bot_to_bot (a) : of_bot (to_bot a) = a := by simp [to_bot, of_bot]
@[simp] lemma to_coe_of_coe (a : pretangle α) : to_coe (of_coe a) = a := by simp [to_coe, of_coe]
@[simp] lemma of_coe_to_coe (a) : of_coe (to_coe a : pretangle α) = a := by simp [to_coe, of_coe]
@[simp] lemma to_bot_inj {a b} : to_bot a = to_bot b ↔ a = b := to_bot.injective.eq_iff
@[simp] lemma of_bot_inj {a b} : of_bot a = of_bot b ↔ a = b := of_bot.injective.eq_iff
@[simp] lemma to_coe_inj {a b} : (to_coe a : pretangle α) = to_coe b ↔ a = b :=
to_coe.injective.eq_iff
@[simp] lemma of_coe_inj {a b : pretangle α} : of_coe a = of_coe b ↔ a = b :=
of_coe.injective.eq_iff

-- Yaël: Note, this instance is useless as it won't fire because `β < α` is not a class
/-- The membership relation defined on pretangles.
This is exactly the membership relation on tangles, without the extensionality condition that
allows this membership relation to be used in a model of TTT. -/
instance has_mem {β : type_index} (hβ : β < α) : has_mem (pretangle β) (pretangle α) :=
⟨λ b a, b ∈ of_coe a β hβ⟩

end pretangle
end con_nf


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.traversable.lemmas
import logic.equiv.defs

/-!
# Transferring `traversable` instances along isomorphisms

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

This file allows to transfer `traversable` instances along isomorphisms.

## Main declarations

* `equiv.map`: Turns functorially a function `α → β` into a function `t' α → t' β` using the functor
  `t` and the equivalence `Π α, t α ≃ t' α`.
* `equiv.functor`: `equiv.map` as a functor.
* `equiv.traverse`: Turns traversably a function `α → m β` into a function `t' α → m (t' β)` using
  the traversable functor `t` and the equivalence `Π α, t α ≃ t' α`.
* `equiv.traversable`: `equiv.traverse` as a traversable functor.
* `equiv.is_lawful_traversable`: `equiv.traverse` as a lawful traversable functor.
-/

universes u

namespace equiv

section functor
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [functor t]

open functor

/-- Given a functor `t`, a function `t' : Type u → Type u`, and
equivalences `t α ≃ t' α` for all `α`, then every function `α → β` can
be mapped to a function `t' α → t' β` functorially (see
`equiv.functor`). -/
protected def map {α β : Type u} (f : α → β) (x : t' α) : t' β :=
eqv β $ map f ((eqv α).symm x)

/-- The function `equiv.map` transfers the functoriality of `t` to
`t'` using the equivalences `eqv`.  -/
protected def functor : functor t' :=
{ map := @equiv.map _ }

variables [is_lawful_functor t]

protected lemma id_map {α : Type u} (x : t' α) : equiv.map id x = x :=
by simp [equiv.map, id_map]

protected lemma comp_map {α β γ : Type u} (g : α → β) (h : β → γ) (x : t' α) :
  equiv.map (h ∘ g) x = equiv.map h (equiv.map g x) :=
by simp [equiv.map]; apply comp_map

protected lemma is_lawful_functor : @is_lawful_functor _ equiv.functor :=
{ id_map := @equiv.id_map _ _,
  comp_map := @equiv.comp_map _ _ }

protected lemma is_lawful_functor' [F : _root_.functor t']
  (h₀ : ∀ {α β} (f : α → β), _root_.functor.map f = equiv.map f)
  (h₁ : ∀ {α β} (f : β), _root_.functor.map_const f = (equiv.map ∘ function.const α) f) :
  _root_.is_lawful_functor t' :=
begin
  have : F = equiv.functor,
  { casesI F, dsimp [equiv.functor],
    congr; ext; [rw ← h₀, rw ← h₁] },
  substI this,
  exact equiv.is_lawful_functor
end

end functor

section traversable
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [traversable t]
variables {m : Type u → Type u} [applicative m]
variables {α β : Type u}

/-- Like `equiv.map`, a function `t' : Type u → Type u` can be given
the structure of a traversable functor using a traversable functor
`t'` and equivalences `t α ≃ t' α` for all α.  See `equiv.traversable`. -/
protected def traverse (f : α → m β) (x : t' α) : m (t' β) :=
eqv β <$> traverse f ((eqv α).symm x)

/-- The function `equiv.traverse` transfers a traversable functor
instance across the equivalences `eqv`. -/
protected def traversable : traversable t' :=
{ to_functor := equiv.functor eqv,
  traverse := @equiv.traverse _ }

end traversable

section equiv
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [traversable t] [is_lawful_traversable t]
variables {F G : Type u → Type u} [applicative F] [applicative G]
variables [is_lawful_applicative F] [is_lawful_applicative G]
variables (η : applicative_transformation F G)
variables {α β γ : Type u}

open is_lawful_traversable functor

protected lemma id_traverse (x : t' α) :
  equiv.traverse eqv id.mk x = x :=
by simp! [equiv.traverse,id_bind,id_traverse,functor.map] with functor_norm

protected lemma traverse_eq_map_id (f : α → β) (x : t' α) :
  equiv.traverse eqv (id.mk ∘ f) x = id.mk (equiv.map eqv f x) :=
by simp [equiv.traverse, traverse_eq_map_id] with functor_norm; refl

protected lemma comp_traverse (f : β → F γ) (g : α → G β) (x : t' α) :
  equiv.traverse eqv (comp.mk ∘ functor.map f ∘ g) x =
  comp.mk (equiv.traverse eqv f <$> equiv.traverse eqv g x) :=
by simp [equiv.traverse,comp_traverse] with functor_norm; congr; ext; simp

protected lemma naturality (f : α → F β) (x : t' α) :
  η (equiv.traverse eqv f x) = equiv.traverse eqv (@η _ ∘ f) x :=
by simp only [equiv.traverse] with functor_norm

/-- The fact that `t` is a lawful traversable functor carries over the
equivalences to `t'`, with the traversable functor structure given by
`equiv.traversable`. -/
protected def is_lawful_traversable : @is_lawful_traversable t' (equiv.traversable eqv) :=
{ to_is_lawful_functor := @equiv.is_lawful_functor _ _ eqv _ _,
  id_traverse := @equiv.id_traverse _ _,
  comp_traverse := @equiv.comp_traverse _ _,
  traverse_eq_map_id := @equiv.traverse_eq_map_id _ _,
  naturality := @equiv.naturality _ _ }

/-- If the `traversable t'` instance has the properties that `map`,
`map_const`, and `traverse` are equal to the ones that come from
carrying the traversable functor structure from `t` over the
equivalences, then the fact that `t` is a lawful traversable functor
carries over as well. -/
protected def is_lawful_traversable' [_i : traversable t']
  (h₀ : ∀ {α β} (f : α → β),
         map f = equiv.map eqv f)
  (h₁ : ∀ {α β} (f : β),
         map_const f = (equiv.map eqv ∘ function.const α) f)
  (h₂ : ∀ {F : Type u → Type u} [applicative F],
        by exactI ∀ [is_lawful_applicative F]
          {α β} (f : α → F β),
         traverse f = equiv.traverse eqv f) :
  _root_.is_lawful_traversable t' :=
begin
    -- we can't use the same approach as for `is_lawful_functor'` because
    -- h₂ needs a `is_lawful_applicative` assumption
  refine {to_is_lawful_functor :=
    equiv.is_lawful_functor' eqv @h₀ @h₁, ..}; introsI,
  { rw [h₂, equiv.id_traverse], apply_instance },
  { rw [h₂, equiv.comp_traverse f g x, h₂], congr,
    rw [h₂], all_goals { apply_instance } },
  { rw [h₂, equiv.traverse_eq_map_id, h₀]; apply_instance },
  { rw [h₂, equiv.naturality, h₂]; apply_instance }
end

end equiv
end equiv


def f : Bool → Bool → Nat
| _, _ => 10

example : f true true = 10 :=
rfl

def g : Bool → Bool → Bool → Nat
| true, _,    true  => 1
| _,   false, false => 2
| _,   _,     _     => 3

theorem ex1 : g true true true = 1 := rfl
theorem ex2 : g true false true = 1 := rfl
theorem ex3 : g true false false = 2 := rfl
theorem ex4 : g false false false = 2 := rfl
theorem ex5 : g false true true = 3 := rfl


import category_theory.category
import category_theory.functor
import category_theory.concrete_category
import category_theory.types

/-
universes u v

variable Automat₁ {S α : Type u}
    (δ : S → α → S)
    (terminal : S → bool) : Type v

variables S α β : Type u
variable δ : S → α → S
variable terminal : S → bool

variable σ : Automat₁ δ terminal → Automat₁ δ terminal

def id_Automat (X : Automat₁ δ terminal) := X
-/

---------------------------
section Automat
    parameter α : Type          -- Alphabet

    structure Automat := mk:: {S: Type*}
                (δ : S → α × S)
                     -- Here δ returns a pair from (α × S)
                (terminal : S → bool)

    structure functor_A (A B :Automat) :=
        mk::
            (states : A.S → B.S)
            (delta : α × A.S → α × B.S)     -- maps a pair to a pair

    def homomorphismus
            (A B : Automat)
            (σ : functor_A A B) : Prop :=
            ∀ a : A.S ,
                (A.terminal a = B.terminal (σ.states a) ∧
                    σ.delta (A.δ a) = B.δ (σ.states a))
                        -- comparing a pair with a pair (B.S , α)

end Automat

section Automat_1
    parameter α : Type

    structure Automat_1 := mk:: {S: Type*}
                (δ : S → α → S)
                    -- Here delta returns a function (α → S)
                (terminal : S → bool)

    #check Automat

    variable f : Automat_1 → Automat_1

    structure map_1 (A B :Automat_1) :=
        mk::
            (states : A.S → B.S)
                -- Here there is no use of the morphism part

    def homomorphismus_1
            (A B : Automat_1)
            (σ : map_1 A B) : Prop :=
            ∀ a : A.S ,
                (A.terminal a = B.terminal (σ.states a) ∧
                ∀ e : α ,
                    σ.states (A.δ a e) = B.δ (σ.states a) e)
                        -- comparing a state to a state from B.S

end Automat_1

section Automat_2
    parameter α : Type

    structure Automat_2 := mk:: {S : Type*}
            (F : S → (α → S) × bool)

    #check Automat

    variable f : Automat_2 → Automat_2

    structure map_2 (A B :Automat_2) :=
        mk::
            (states : A.S → B.S)

    def homomorphismus_2
            (A B : Automat_2)
            (σ : map_2 A B) : Prop :=
            ∀ a : A.S ,
                ((A.F a).2 = (B.F (σ.states a)).2 ∧
                ∀ e : α ,
                    σ.states ((A.F a).1 e) = (B.F (σ.states a)).1 e)

end Automat_2

section Automat_3       -- Coalgebric Automat
    parameter Alphabet : Type                          -- Alphabet
    def F := λ S: Type , (Alphabet → S) × bool         -- Signature

    structure Automat_3 :=
                mk:: (S : Type) (γ : S → F S)

    /-structure map_3 (A B :Automat_3) :=
        mk::
            (states : A.S → B.S)-/

    def homomorphismus_3
            (A B : Automat_3) (σ : A.S → B.S) : Prop :=
            ∀ a : A.S ,
                ((A.γ a).2 = (B.γ (σ a)).2 ∧
                ∀ e : Alphabet ,
                    σ ((A.γ a).1 e) = (B.γ (σ a)).1 e)

end Automat_3

open category_theory

section Coalgebra

    universes u v w

    class someStructure (α : Type u) : Type u

    @[reducible] def Carrier : Type (u+1) := bundled someStructure

    def is_XX_hom {α β}
        [someStructure α]
        [someStructure β] (f : α → β) : Prop := true

    instance concrete_is_XX_hom :
        concrete_category @is_XX_hom := sorry

    variable F1 : Carrier  ⥤ Type w

    structure coalgebra :=
            (A : Carrier) (α : A → F1.obj A)

    #check coalgebra

end Coalgebra

universe u

instance Set : large_category (Type u) :=
{ hom     := λ a b, (a → b),
  id      := λ a, id,
  comp    := λ _ _ _ f g, g ∘ f }

variables (p : Prop) (h : p)

#check classical.em

variables (X B C : Type)

variable (S : set X)

open set

def fun_to_image (f : X → B) : X → range f :=
    λ a ,
    have h : f a ∈ range f :=
        exists.intro a
            (eq.refl (f a)),
    ⟨f a, h⟩

#check range_factorization

#check Sort 1

variables {AA BB : Type u} (ff gg: AA → BB)
#check setoid
#check eqv_gen

def R (f g: AA → BB)
    : BB → BB → Prop := λ b₁ b₂ , ∃ a , f a = b₁ ∧ g a = b₂

def Θ := @eqv_gen BB (R ff gg)
def s := eqv_gen.setoid (R ff gg)

--def proj : B → quotient (s f g) := λ b , ⟦b⟧

#check quotient (eqv_gen.setoid (R ff gg))

    --setoid BB := eqv_gen.setoid (R ff gg)

def set_BB : setoid BB := eqv_gen.setoid (R ff gg)

--instance quot.mk (R ff gg)

variables (b : BB)

#check quotient (set_BB ff gg)

def bla (s : setoid BB) (b : BB) : @quot BB setoid.r :=
    quot.mk setoid.r b

variable [s : setoid BB]

#check ⟦b⟧

#check bla (eqv_gen.setoid (R ff gg)) b

example (A : Type) (S T : set A)
    (h: ∀a : A ,a ∈ S ↔ a ∈ T)
    : S = T  :=
    begin
        have h1 : ∀s : S , s.val ∈ T :=
           λ s, (h s.val).1 s.property,
        have h2 : ∀t : T , t.val ∈ S :=
           λ t, (h t.val).2 t.property,
        simp at *,
        ext1,
        fsplit,
        intros s,
        exact h1 x s,
        intros t,
        exact h2 x t
    end


theorem Q1007 (r : ℤ → ℤ → Prop) [is_equiv ℤ r] (h₁ : ∀ n : ℤ, r n (n + 5))
(h₂ : ∀ n : ℤ, r n (n + 8)) (x y : ℤ) : r x y := sorry


import phase2.weak_approx

open cardinal quiver set sum with_bot
open_locale cardinal classical pointwise

universe u

namespace con_nf
variables [params.{u}]

/-!
# Filling in ranges of weak near-litter approximations
TODO: Rename the gadgetry created in this file.
-/

namespace weak_near_litter_approx

variables (w : weak_near_litter_approx)

noncomputable def preimage_litter : litter :=
w.not_banned_litter_nonempty.some

lemma preimage_litter_not_banned : ¬w.banned_litter w.preimage_litter :=
w.not_banned_litter_nonempty.some.prop

/-- An atom is called *without preimage* if it is not in the range of the approximation,
but it is in a litter near some near-litter in the range.
Atoms without preimage need to have something map to it, so that the resulting map that we use in
the freedom of action theorem actually maps to the correct near-litter. -/
@[mk_iff] structure without_preimage (a : atom) : Prop :=
(mem_map : ∃ (L : litter) (hL : (w.litter_map L).dom), a ∈ litter_set ((w.litter_map L).get hL).1)
(not_mem_map : ∀ (L : litter) (hL : (w.litter_map L).dom), a ∉ (w.litter_map L).get hL)
(not_mem_ran : a ∉ w.atom_map.ran)

lemma without_preimage_small :
  small {a | w.without_preimage a} :=
begin
  simp only [without_preimage_iff, set_of_and],
  rw ← inter_assoc,
  refine small.mono (inter_subset_left _ _) _,
  suffices : small ⋃ (L : litter) (hL),
    litter_set ((w.litter_map L).get hL).1 \ (w.litter_map L).get hL,
  { refine small.mono _ this,
    rintro a ⟨⟨L, hL, ha₁⟩, ha₂⟩,
    simp only [mem_Union],
    exact ⟨L, hL, ha₁, ha₂ _ _⟩, },
  refine small.bUnion _ _,
  { refine lt_of_le_of_lt _ w.litter_map_dom_small,
    refine ⟨⟨λ L, ⟨_, L.prop⟩, _⟩⟩,
    intros L₁ L₂ h,
    simp only [subtype.mk_eq_mk, prod.mk.inj_iff, eq_self_iff_true, and_true,
      litter.to_near_litter_injective.eq_iff, subtype.coe_inj] at h,
    exact h, },
  { intros L hL,
    refine small.mono _ ((w.litter_map L).get hL).2.prop,
    exact λ x hx, or.inl hx, },
end

/-- The subset of the preimage litter that is put in correspondence with the set of
atoms without preimage. -/
def preimage_litter_subset : set atom :=
(le_mk_iff_exists_subset.mp
  (lt_of_lt_of_eq w.without_preimage_small (mk_litter_set w.preimage_litter).symm).le).some

lemma preimage_litter_subset_spec :
  w.preimage_litter_subset ⊆ litter_set w.preimage_litter ∧
    #w.preimage_litter_subset = #{a : atom | w.without_preimage a} :=
(le_mk_iff_exists_subset.mp
  (lt_of_lt_of_eq w.without_preimage_small (mk_litter_set w.preimage_litter).symm).le).some_spec

lemma preimage_litter_subset_subset :
  w.preimage_litter_subset ⊆ litter_set w.preimage_litter :=
w.preimage_litter_subset_spec.1

lemma preimage_litter_subset_small :
  small (w.preimage_litter_subset) :=
lt_of_eq_of_lt w.preimage_litter_subset_spec.2 w.without_preimage_small

@[irreducible] noncomputable def preimage_litter_equiv :
  w.preimage_litter_subset ≃ {a : atom | w.without_preimage a} :=
(cardinal.eq.mp w.preimage_litter_subset_spec.2).some

/-- The images of atoms in a litter `L` that were mapped outside the target litter, but
were not in the domain. -/
@[mk_iff] structure mapped_outside (L : litter) (hL : (w.litter_map L).dom) (a : atom) : Prop :=
(mem_map : a ∈ (w.litter_map L).get hL)
(not_mem_map : a ∉ litter_set ((w.litter_map L).get hL).1)
(not_mem_ran : a ∉ w.atom_map.ran)

/-- There are only `< κ`-many atoms in a litter `L` that are mapped outside the image litter,
and that are not already in the domain. -/
lemma mapped_outside_small (L : litter) (hL : (w.litter_map L).dom) :
  small {a | w.mapped_outside L hL a} :=
begin
  simp only [mapped_outside_iff, set_of_and],
  rw ← inter_assoc,
  refine small.mono (inter_subset_left _ _) _,
  refine small.mono _ ((w.litter_map L).get hL).2.prop,
  exact λ x hx, or.inr hx,
end

lemma without_preimage.not_mapped_outside {a : atom} (ha : w.without_preimage a)
  (L : litter) (hL : (w.litter_map L).dom) : ¬w.mapped_outside L hL a :=
λ ha', ha.not_mem_map L hL ha'.mem_map

lemma mapped_outside.not_without_preimage {a : atom} {L : litter} {hL : (w.litter_map L).dom}
  (ha : w.mapped_outside L hL a) : ¬w.without_preimage a :=
λ ha', ha'.not_mem_map L hL ha.mem_map

/-- The amount of atoms in a litter that are not in the domain already is `κ`. -/
lemma mk_mapped_outside_domain (L : litter) : #(litter_set L \ w.atom_map.dom : set atom) = #κ :=
begin
  refine le_antisymm _ _,
  { rw ← mk_litter_set,
    exact mk_subtype_mono (λ x hx, hx.1), },
  by_contra' h,
  have := small.union h w.atom_map_dom_small,
  rw diff_union_self at this,
  exact (mk_litter_set L).not_lt (small.mono (subset_union_left _ _) this),
end

/-- To each litter we associate a subset which is to contain the atoms mapped outside it. -/
def mapped_outside_subset (L : litter) (hL : (w.litter_map L).dom) : set atom :=
(le_mk_iff_exists_subset.mp
  (lt_of_lt_of_eq (w.mapped_outside_small L hL) (w.mk_mapped_outside_domain L).symm).le).some

lemma mapped_outside_subset_spec (L : litter) (hL : (w.litter_map L).dom) :
  w.mapped_outside_subset L hL ⊆ litter_set L \ w.atom_map.dom ∧
    #(w.mapped_outside_subset L hL) = #{a : atom | w.mapped_outside L hL a} :=
(le_mk_iff_exists_subset.mp
  (lt_of_lt_of_eq (w.mapped_outside_small L hL) (w.mk_mapped_outside_domain L).symm).le).some_spec

lemma mapped_outside_subset_subset (L : litter) (hL : (w.litter_map L).dom) :
  w.mapped_outside_subset L hL ⊆ litter_set L :=
λ x hx, ((w.mapped_outside_subset_spec L hL).1 hx).1

lemma mapped_outside_subset_closure (L : litter) (hL : (w.litter_map L).dom) :
  w.mapped_outside_subset L hL ⊆ w.atom_map.domᶜ :=
λ x hx, ((w.mapped_outside_subset_spec L hL).1 hx).2

lemma mapped_outside_subset_small (L : litter) (hL : (w.litter_map L).dom) :
  small (w.mapped_outside_subset L hL) :=
lt_of_eq_of_lt (w.mapped_outside_subset_spec L hL).2 (w.mapped_outside_small L hL)

/-- A correspondence between the "mapped outside" subset of `L` and its atoms which were mapped
outside the target litter. We will use this equivalence to construct an approximation to
use in the freedom of action theorem. -/
@[irreducible] noncomputable def mapped_outside_equiv (L : litter) (hL : (w.litter_map L).dom) :
  w.mapped_outside_subset L hL ≃ {a : atom | w.mapped_outside L hL a} :=
(cardinal.eq.mp (w.mapped_outside_subset_spec L hL).2).some

noncomputable def supported_action_atom_map_core : atom →. atom :=
λ a, {
  dom := (w.atom_map a).dom ∨ a ∈ w.preimage_litter_subset ∨
    ∃ L hL, a ∈ w.mapped_outside_subset L hL,
  get := λ h, h.elim' (w.atom_map a).get
    (λ h, h.elim'
      (λ h, w.preimage_litter_equiv ⟨a, h⟩)
      (λ h, w.mapped_outside_equiv h.some h.some_spec.some ⟨a, h.some_spec.some_spec⟩)),
}

lemma mem_supported_action_atom_map_core_dom_iff (a : atom) :
  (w.supported_action_atom_map_core a).dom ↔
  a ∈ w.atom_map.dom ∪ w.preimage_litter_subset ∪ ⋃ L hL, w.mapped_outside_subset L hL :=
begin
  rw supported_action_atom_map_core,
  simp only [pfun.dom_mk, mem_set_of_eq, mem_union, mem_Union],
  rw or_assoc,
  refl,
end

lemma supported_action_atom_map_core_dom_eq :
  w.supported_action_atom_map_core.dom =
  w.atom_map.dom ∪ w.preimage_litter_subset ∪ ⋃ L hL, w.mapped_outside_subset L hL :=
begin
  ext a : 1,
  exact w.mem_supported_action_atom_map_core_dom_iff a,
end

lemma supported_action_atom_map_core_dom_small :
  small w.supported_action_atom_map_core.dom :=
begin
  rw supported_action_atom_map_core_dom_eq,
  refine small.union (small.union w.atom_map_dom_small _) _,
  { exact w.preimage_litter_subset_small, },
  { refine small.bUnion _ _,
    { refine lt_of_le_of_lt _ w.litter_map_dom_small,
      refine ⟨⟨λ L, ⟨_, L.prop⟩, λ L₁ L₂ h, _⟩⟩,
      simp only [subtype.mk_eq_mk, prod.mk.inj_iff, eq_self_iff_true, and_true,
        litter.to_near_litter_injective.eq_iff, subtype.coe_inj] at h,
      exact h, },
    { intros L hL,
      exact w.mapped_outside_subset_small L hL, }, },
end

lemma mk_supported_action_atom_map_dom :
  #(w.supported_action_atom_map_core.dom ∆
    ((λ a, part.get_or_else (w.supported_action_atom_map_core a) (arbitrary atom)) ''
      w.supported_action_atom_map_core.dom) : set atom) ≤
  #(litter_set $ w.preimage_litter) :=
begin
  rw mk_litter_set,
  refine le_trans (mk_subtype_mono symm_diff_subset_union) (le_trans (mk_union_le _ _) _),
  refine add_le_of_le κ_regular.aleph_0_le _ _,
  exact le_of_lt w.supported_action_atom_map_core_dom_small,
  exact le_trans mk_image_le (le_of_lt w.supported_action_atom_map_core_dom_small),
end

lemma supported_action_eq_of_dom {a : atom} (ha : (w.atom_map a).dom) :
  (w.supported_action_atom_map_core a).get (or.inl ha) = (w.atom_map a).get ha :=
begin
  simp only [supported_action_atom_map_core],
  rw or.elim'_left,
end

lemma supported_action_eq_of_mem_preimage_litter_subset {a : atom}
  (ha : a ∈ w.preimage_litter_subset) :
  (w.supported_action_atom_map_core a).get (or.inr (or.inl ha)) = w.preimage_litter_equiv ⟨a, ha⟩ :=
begin
  simp only [supported_action_atom_map_core],
  rw [or.elim'_right, or.elim'_left],
  intro h',
  have := w.preimage_litter_not_banned,
  rw banned_litter_iff at this,
  push_neg at this,
  exact this.1 a h' (w.preimage_litter_subset_subset ha).symm,
end

lemma supported_action_eq_of_mem_mapped_outside_subset {a : atom}
  {L hL} (ha : a ∈ w.mapped_outside_subset L hL) :
  (w.supported_action_atom_map_core a).get (or.inr (or.inr ⟨L, hL, ha⟩)) =
  w.mapped_outside_equiv L hL ⟨a, ha⟩ :=
begin
  have : ∃ L hL, a ∈ w.mapped_outside_subset L hL := ⟨L, hL, ha⟩,
  simp only [supported_action_atom_map_core],
  rw [or.elim'_right, or.elim'_right],
  { cases eq_of_mem_litter_set_of_mem_litter_set
      (w.mapped_outside_subset_subset _ hL ha)
      (w.mapped_outside_subset_subset _ this.some_spec.some this.some_spec.some_spec),
    refl, },
  { intro h,
    have := eq_of_mem_litter_set_of_mem_litter_set
      (w.mapped_outside_subset_subset _ hL ha)
      (w.preimage_litter_subset_subset h),
    cases this,
    have := w.preimage_litter_not_banned,
    rw banned_litter_iff at this,
    push_neg at this,
    cases this.2.1 hL, },
  { exact ((mapped_outside_subset_spec _ _ hL).1 ha).2, },
end

lemma supported_action_atom_map_core_injective ⦃a b : atom⦄
  (ha :  (supported_action_atom_map_core w a).dom) (hb :  (supported_action_atom_map_core w b).dom)
  (hab : (w.supported_action_atom_map_core a).get ha =
    (w.supported_action_atom_map_core b).get hb) :
  a = b :=
begin
  obtain (ha | ha | ⟨L, hL, ha⟩) := ha;
  obtain (hb | hb | ⟨L', hL', hb⟩) := hb,
  { have := (supported_action_eq_of_dom _ ha).symm.trans
      (hab.trans (supported_action_eq_of_dom _ hb)),
    exact w.atom_map_injective ha hb this, },
  { have := (supported_action_eq_of_dom _ ha).symm.trans
      (hab.trans (supported_action_eq_of_mem_preimage_litter_subset _ hb)),
    obtain ⟨hab, -⟩ := subtype.coe_eq_iff.mp this.symm,
    cases hab.not_mem_ran ⟨a, ha, rfl⟩, },
  { have := (supported_action_eq_of_dom _ ha).symm.trans
      (hab.trans (supported_action_eq_of_mem_mapped_outside_subset _ hb)),
    obtain ⟨hab, -⟩ := subtype.coe_eq_iff.mp this.symm,
    cases hab.not_mem_ran ⟨a, ha, rfl⟩, },
  { have := (supported_action_eq_of_mem_preimage_litter_subset _ ha).symm.trans
      (hab.trans (supported_action_eq_of_dom _ hb)),
    obtain ⟨hab, -⟩ := subtype.coe_eq_iff.mp this,
    cases hab.not_mem_ran ⟨b, hb, rfl⟩, },
  { have := (supported_action_eq_of_mem_preimage_litter_subset _ ha).symm.trans
      (hab.trans (supported_action_eq_of_mem_preimage_litter_subset _ hb)),
    rw [subtype.coe_inj, embedding_like.apply_eq_iff_eq] at this,
    exact subtype.coe_inj.mpr this, },
  { have := (supported_action_eq_of_mem_preimage_litter_subset _ ha).symm.trans
      (hab.trans (supported_action_eq_of_mem_mapped_outside_subset _ hb)),
    obtain ⟨hab, -⟩ := subtype.coe_eq_iff.mp this,
    cases without_preimage.not_mapped_outside w hab _ hL'
      (w.mapped_outside_equiv L' hL' ⟨b, hb⟩).prop, },
  { have := (supported_action_eq_of_mem_mapped_outside_subset _ ha).symm.trans
      (hab.trans (supported_action_eq_of_dom _ hb)),
    obtain ⟨hab, -⟩ := subtype.coe_eq_iff.mp this,
    cases hab.not_mem_ran ⟨b, hb, rfl⟩, },
  { have := (supported_action_eq_of_mem_mapped_outside_subset _ ha).symm.trans
      (hab.trans (supported_action_eq_of_mem_preimage_litter_subset _ hb)),
    obtain ⟨hab, -⟩ := subtype.coe_eq_iff.mp this.symm,
    cases without_preimage.not_mapped_outside w hab _ hL
      (w.mapped_outside_equiv L hL ⟨a, ha⟩).prop, },
  { have := (supported_action_eq_of_mem_mapped_outside_subset _ ha).symm.trans
      (hab.trans (supported_action_eq_of_mem_mapped_outside_subset _ hb)),
    cases w.litter_map_injective hL hL' _,
    { simp only [subtype.coe_inj, embedding_like.apply_eq_iff_eq] at this,
      exact this, },
    obtain ⟨hab, -⟩ := subtype.coe_eq_iff.mp this,
    exact ⟨_, hab.1, (w.mapped_outside_equiv L' hL' ⟨b, hb⟩).prop.1⟩, },
end

lemma supported_action_atom_map_core_mem (a : atom) (ha : (w.supported_action_atom_map_core a).dom)
  (L : litter) (hL : (w.litter_map L).dom) :
  a.fst = L ↔ (w.supported_action_atom_map_core a).get ha ∈ (w.litter_map L).get hL :=
begin
  obtain (ha | ha | ⟨L', hL', ha⟩) := ha,
  { rw [w.atom_mem a ha L hL, supported_action_eq_of_dom], },
  { rw supported_action_eq_of_mem_preimage_litter_subset,
    split,
    { rintro rfl,
      have := w.preimage_litter_subset_subset ha,
      rw mem_litter_set at this,
      rw this at hL,
      have := banned_litter.litter_dom _ hL,
      cases w.preimage_litter_not_banned this, },
    { intro h,
      cases (w.preimage_litter_equiv ⟨a, ha⟩).prop.not_mem_map L hL h, }, },
  { cases w.mapped_outside_subset_subset L' hL' ha,
    rw supported_action_eq_of_mem_mapped_outside_subset,
    split,
    { rintro rfl,
      exact (w.mapped_outside_equiv _ _ _ ).prop.mem_map, },
    { intro h,
      refine w.litter_map_injective hL' hL ⟨_, _, h⟩,
      exact (w.mapped_outside_equiv _ _ _ ).prop.mem_map, }, },
end

noncomputable def fill_atom_range : weak_near_litter_approx := {
  atom_map := w.supported_action_atom_map_core,
  litter_map := w.litter_map,
  atom_map_dom_small := w.supported_action_atom_map_core_dom_small,
  litter_map_dom_small := w.litter_map_dom_small,
  atom_map_injective := w.supported_action_atom_map_core_injective,
  litter_map_injective := w.litter_map_injective,
  atom_mem := w.supported_action_atom_map_core_mem,
}

variable {w}

@[simp] lemma fill_atom_range_atom_map :
  w.fill_atom_range.atom_map = w.supported_action_atom_map_core := rfl

@[simp] lemma fill_atom_range_litter_map :
  w.fill_atom_range.litter_map = w.litter_map := rfl

lemma subset_supported_action_atom_map_core_dom :
  w.atom_map.dom ⊆ w.supported_action_atom_map_core.dom :=
subset_union_left _ _

lemma subset_supported_action_atom_map_core_ran :
  w.atom_map.ran ⊆ w.supported_action_atom_map_core.ran :=
begin
  rintro _ ⟨a, ha, rfl⟩,
  exact ⟨a, subset_supported_action_atom_map_core_dom ha, w.supported_action_eq_of_dom _⟩,
end

lemma fill_atom_range_symm_diff_subset_ran
  (L : litter) (hL : (w.fill_atom_range.litter_map L).dom) :
  ((w.fill_atom_range.litter_map L).get hL : set atom) ∆ litter_set
    ((w.fill_atom_range.litter_map L).get hL).fst ⊆ w.fill_atom_range.atom_map.ran :=
begin
  rintro a,
  by_cases ha₁ : a ∈ w.atom_map.ran,
  { obtain ⟨b, hb, rfl⟩ := ha₁,
    exact λ _, ⟨b, or.inl hb, w.supported_action_eq_of_dom hb⟩, },
  rintro (⟨ha₂, ha₃⟩ | ⟨ha₂, ha₃⟩),
  { refine ⟨(w.mapped_outside_equiv L hL).symm ⟨a, ha₂, ha₃, ha₁⟩, _, _⟩,
    { exact or.inr (or.inr ⟨L, hL, ((w.mapped_outside_equiv L hL).symm _).prop⟩), },
    { simp only [fill_atom_range_atom_map],
      refine (w.supported_action_eq_of_mem_mapped_outside_subset
        ((w.mapped_outside_equiv L hL).symm _).prop).trans _,
      simp only [subtype.coe_eta, equiv.apply_symm_apply, subtype.coe_mk], }, },
  { by_cases ha₄ : ∀ (L' : litter) (hL' : (w.litter_map L').dom), a ∉ (w.litter_map L').get hL',
    { refine ⟨w.preimage_litter_equiv.symm ⟨a, ⟨L, hL, ha₂⟩, ha₄, ha₁⟩, _, _⟩,
      { exact or.inr (or.inl (w.preimage_litter_equiv.symm _).prop), },
      { simp only [fill_atom_range_atom_map],
        refine (w.supported_action_eq_of_mem_preimage_litter_subset
          (w.preimage_litter_equiv.symm _).prop).trans _,
        simp only [subtype.coe_eta, equiv.apply_symm_apply, subtype.coe_mk], }, },
    { push_neg at ha₄,
      obtain ⟨L', hL', ha₄⟩ := ha₄,
      refine ⟨(w.mapped_outside_equiv L' hL').symm ⟨a, ha₄, _, ha₁⟩, _, _⟩,
      { intro ha,
        have := near_litter.inter_nonempty_of_fst_eq_fst
          (eq_of_mem_litter_set_of_mem_litter_set ha₂ ha),
        cases w.litter_map_injective hL hL' this,
        exact ha₃ ha₄, },
      { exact or.inr (or.inr ⟨L', hL', ((w.mapped_outside_equiv L' hL').symm _).prop⟩), },
      { simp only [fill_atom_range_atom_map],
        refine (w.supported_action_eq_of_mem_mapped_outside_subset
          ((w.mapped_outside_equiv L' hL').symm _).prop).trans _,
        simp only [subtype.coe_eta, equiv.apply_symm_apply, subtype.coe_mk], }, }, },
end

end weak_near_litter_approx

end con_nf


/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.Module.epi_mono
import linear_algebra.pi

/-!
# The concrete products in the category of modules are products in the categorical sense.
-/

open category_theory
open category_theory.limits

universes u v w

namespace Module
variables {R : Type u} [ring R]

variables {ι : Type v} (Z : ι → Module.{max v w} R)

/-- The product cone induced by the concrete product. -/
def product_cone : fan Z :=
fan.mk (Module.of R (Π i : ι, Z i)) (λ i, (linear_map.proj i : (Π i : ι, Z i) →ₗ[R] Z i))

/-- The concrete product cone is limiting. -/
def product_cone_is_limit : is_limit (product_cone Z) :=
{ lift := λ s, (linear_map.pi (λ j, s.π.app ⟨j⟩) : s.X →ₗ[R] (Π i : ι, Z i)),
  fac' := λ s j, by { cases j, tidy, },
  uniq' := λ s m w, by { ext x i, exact linear_map.congr_fun (w ⟨i⟩) x, }, }

-- While we could use this to construct a `has_products (Module R)` instance,
-- we already have `has_limits (Module R)` in `algebra.category.Module.limits`.

variables [has_product Z]

/--
The categorical product of a family of objects in `Module`
agrees with the usual module-theoretical product.
-/
noncomputable def pi_iso_pi :
  ∏ Z ≅ Module.of R (Π i, Z i) :=
limit.iso_limit_cone ⟨_, product_cone_is_limit Z⟩

-- We now show this isomorphism commutes with the inclusion of the kernel into the source.

@[simp, elementwise] lemma pi_iso_pi_inv_kernel_ι (i : ι) :
  (pi_iso_pi Z).inv ≫ pi.π Z i = (linear_map.proj i : (Π i : ι, Z i) →ₗ[R] Z i) :=
limit.iso_limit_cone_inv_π _ _

@[simp, elementwise] lemma pi_iso_pi_hom_ker_subtype (i : ι) :
  (pi_iso_pi Z).hom ≫ (linear_map.proj i : (Π i : ι, Z i) →ₗ[R] Z i) = pi.π Z i :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ (limit.is_limit _) (discrete.mk i)

end Module


import topology.algebra.infinite_sum
import topology.metric_space.basic
import data.complex.exponential
import data.real.pi.bounds
import tactic.omega
import analysis.complex.cauchy_integral
import analysis.special_functions.exp
import analysis.special_functions.exp_deriv
import analysis.special_functions.polar_coord
import analysis.special_functions.complex.log
import analysis.special_functions.polynomials
import measure_theory.measure.lebesgue
import measure_theory.integral.integral_eq_improper
import measure_theory.group.integration
import measure_theory.measure.haar_lebesgue
import measure_theory.constructions.prod

noncomputable theory

open classical complex (hiding abs_of_nonneg)
open function measure_theory (hiding norm_integral_le_of_norm_le_const)
open absolute_value filter polynomial metric set

open_locale real

local attribute [instance] prop_decidable
local attribute [instance] type_decidable_eq

def inj_posℤ : ℕ ↪ ℤ := ⟨λ x, (x : ℤ),
  by {intros a b, apply int.coe_nat_inj} ⟩

def inj_negℤ : ℕ ↪ ℤ := ⟨λ x, -(x : ℤ),
begin
  intros a b, simp only [imp_self], intro Hab,
  apply int.coe_nat_inj, apply int.neg_inj,
  exact Hab
end⟩

lemma inj_posℤ_mem_image (x : ℤ)
: x ∈ inj_posℤ.image ⊤ ↔ x ≥ 0 :=
begin
  simp only [set.image_congr, inj_posℤ.equations._eqn_1,
    set.image_univ, set.mem_range, ge_iff_le,
    function.embedding.coe_fn_mk, set.top_eq_univ,
    function.embedding.image_apply],
  split, rintro ⟨y, Hy⟩, rw ←Hy, apply int.coe_nat_nonneg,
  intro Hx, use x.to_nat, rwa int.to_nat_of_nonneg
end

lemma inj_negℤ_mem_image (x : ℤ)
: x ∈ inj_negℤ.image ⊤ ↔ x ≤ 0 :=
begin
  simp only [set.image_congr, set.image_univ,
    set.mem_range, inj_negℤ.equations._eqn_1,
    function.embedding.coe_fn_mk, set.top_eq_univ,
    function.embedding.image_apply],
  split, rintro ⟨y, Hy⟩,
  have : 0 ≤ (y : ℤ),
    by { apply int.coe_nat_nonneg }, linarith,
  intro Hx, use (-x).to_nat,
  have : -x ≥ 0, by linarith,
  rw int.to_nat_of_nonneg, linarith, linarith
end

lemma lattice_1 {T : Type} [semilattice_inf T]
  [order_bot T] {a x : T} (y : T)
  {Hxy : x ≤ y} {Hy : disjoint a y} : disjoint a x :=
begin
  have : (a ⊓ x ≤ a ⊓ y) := by
    { apply inf_le_inf_left, exact Hxy },
  rw disjoint_iff_inf_le at Hy ⊢,
  exact le_trans this Hy
end

namespace finset
noncomputable def inv_map
  {α β : Type} (f : α ↪ β) (s : finset β) : finset α :=
  (s.preimage f) (f.injective.inj_on _)

lemma disjoint_inj' {S T : Type}
  {X : finset S} {Y : finset T} {f : S ↪ T}
: disjoint X (Y.inv_map f) ↔ disjoint (X.map f) Y :=
begin
repeat {rw disjoint_iff},
simp only [eq_empty_iff_forall_not_mem, inf_eq_inter,
  bot_eq_empty, mem_inter, inv_map, mem_preimage,
  mem_map, not_and, forall_exists_index],
split, {
  intros hXY x y y_in_x Hy, have := (hXY y y_in_x),
  rw Hy at this, contradiction
}, {
  intros H x Hx, exact H (f x) x Hx rfl
}
end

@[simp]
lemma inv_map_of_map
  {S T : Type} {X : finset S} {f : S ↪ T}
: inv_map f (map f X) = X :=
begin
  simp only [inv_map], ext,
  simp only [mem_map, mem_preimage],
  split, intro H, obtain ⟨a₁, a₁_in_H, H⟩ := H,
  rw f.injective.eq_iff at H, rw ←H, exact a₁_in_H,
  intro Ha, use a, split, exact Ha, refl
end

lemma disjoint_inj {S T : Type} {X Y : finset S}
  {f : S ↪ T} {hXY : disjoint X Y}
: disjoint (X.map f) (Y.map f) :=
  by { rw [←disjoint_inj', inv_map_of_map], exact hXY }

lemma map_of_inv_map {S T : Type} {X : finset T} {i : S ↪ T}
: (X.inv_map i).map i = {x ∈ X | x ∈ (i.image ⊤)} :=
begin
  ext, simp only [mem_map, sep_def, mem_filter, mem_preimage,
    inv_map, filter_congr_decidable, set.image_univ, set.mem_range,
    set.top_eq_univ, function.embedding.image_apply],
  split, rintro ⟨b, Hb, H⟩,
  rw ←H, split, exact Hb, use b, rintro ⟨Ha, y, Hy⟩,
  use y, rw Hy, split, exact Ha, refl,
end
end finset

section summable_lemmas
open finset

lemma summable_ℤ_imp_subset_summable
  (inj : ℕ ↪ ℤ) (f : ℤ → ℂ) (Hf : summable f)
: summable (λ n : ℕ, f (inj n)) :=
begin
  rw summable_iff_vanishing at Hf ⊢ , intros e He,
  replace Hf := Hf e He, obtain ⟨S⟩ := Hf,
  let i_inv_S := S.inv_map inj,
  use i_inv_S, intros t Ht, rw [←sum_map],
  apply Hf_h, rw ←disjoint_inj', exact Ht
end

lemma not_mem_imp_neq {S T : Type} [has_mem S T]
  {a : S} {X : T} (Ha : a ∉ X)
: ∀ (b : S), b ∈ X → b ≠ a :=
  by { intros b Hb Hab, rw Hab at Hb, exact Ha Hb }

lemma add_abs_bound {x y : ℂ} {a b : ℝ}
  (Hx : abs x < a) (Hy : abs y < b)
: abs (x + y) < a + b := by
{ have : abs (x + y) ≤ abs x + abs y,
    by apply absolute_value.add_le, linarith }

lemma summable_ℤ_if_summable_two_sides
  (f : ℤ → ℂ) (Hpos : summable (λ n : ℕ, f n))
  (Hneg : summable (λ n : ℕ, f (-n))) : summable f :=
begin
  rw summable_iff_vanishing, intros e He,
  rw [metric.mem_nhds_iff] at He,
  obtain ⟨ε, Hε, He⟩ := He,
  obtain ⟨s₁, Hs₁⟩ :=
    (iff.mp summable_iff_vanishing Hpos) (ball 0 (ε/2))
    (by {apply ball_mem_nhds, linarith}),
  obtain ⟨s₂, Hs₂⟩ :=
    (iff.mp summable_iff_vanishing Hneg) (ball 0 (ε/2))
    (by {apply ball_mem_nhds, linarith}),
  clear Hpos Hneg,
  use (s₁.map inj_posℤ) ∪ (s₂.map inj_negℤ) ∪ {0},
  intros t Ht, apply He, clear He, clear e,
  repeat {rw finset.disjoint_union_right at Ht},
  rcases Ht with ⟨⟨Ht₁, Ht₂⟩, t_ne_0⟩,
  rw finset.disjoint_singleton_right at t_ne_0,
  replace t_ne_0 := not_mem_imp_neq t_ne_0,
  rw [disjoint.comm, ←disjoint_inj', disjoint.comm] at Ht₁ Ht₂,
  replace Hs₁ := Hs₁ (t.inv_map inj_posℤ) Ht₁,
  replace Hs₂ := Hs₂ (t.inv_map inj_negℤ) Ht₂,
  clear Ht₁ Ht₂,
  simp only [
    show (λ (b : ℕ), f ↑b) = λ (b : ℕ), f (inj_posℤ b), by {ext1, congr},
    show (λ (b : ℕ), f (-↑b)) = λ (b : ℕ), f (inj_negℤ b), by {ext1, congr},
    ←sum_map, map_of_inv_map,
    inj_posℤ_mem_image, inj_negℤ_mem_image]
  at Hs₁ Hs₂,
  have : t = {x ∈ t | x ≤ 0} ∪ {x ∈ t | x ≥ 0} :=
  begin
    ext, simp only [finset.mem_union, finset.sep_def,
      finset.mem_filter, ←and_or_distrib_left, iff_self_and],
    intro Ha, have := t_ne_0 a Ha, omega
  end,
  rw [this, sum_union], clear this,
  {
    simp only [ball, set.mem_set_of_eq,
      dist_zero_right, complex.norm_eq_abs] at Hs₁ Hs₂ ⊢,
    rw [show ε = ε / 2 + ε / 2, by linarith],
    apply add_abs_bound, repeat {assumption}
  }, {
    clear this, rw disjoint_iff,
    simp only [finset.inf_eq_inter,
      finset.bot_eq_empty, finset.sep_def,
      finset.eq_empty_iff_forall_not_mem,
      not_and, finset.mem_inter, finset.mem_filter],
    rintro x ⟨H1, H2⟩ H3, have := t_ne_0 x H1, omega
  }
end
end summable_lemmas

lemma real_bounded_iff_subset_Icc {X : set ℝ}
: bounded X ↔ ∃ (M N : ℝ), X ⊆ (set.Icc M N) :=
begin
  simp only [real.bounded_iff_bdd_below_bdd_above,
    bdd_below_def, bdd_above_def, set.mem_set_of_eq],
  split, {
    rintro ⟨⟨M, H1⟩, ⟨N, H2⟩⟩, use M, use N,
    change ∀x ∈ X, M ≤ x ∧ x ≤ N,
    intros x Hx, split, exact H1 x Hx, exact H2 x Hx
  }, {
    rintro ⟨M, N, H⟩, split,
    use M, intros y Hy, exact (H Hy).1,
    use N, intros y Hy, exact (H Hy).2,
  }
end

lemma bounded_if_tends_neginf {f : ℝ → ℝ}
(Hpos : tendsto f at_top at_top)
(Hneg : tendsto f at_bot at_top)
: bounded {x : ℝ | f x < 0} :=
begin
  replace Hneg := (Hneg $ Ioi_mem_at_top 0),
  replace Hpos := (Hpos $ Ioi_mem_at_top 0),
  simp only [filter.mem_at_top_sets,
    filter.mem_map, filter.mem_at_bot_sets,
    set.mem_preimage, set.mem_Ioi] at *,
  cases Hneg with M Hneg,
  cases Hpos with N Hpos,
  simp only [real_bounded_iff_subset_Icc],
  use M, use N, intro x,
  simp_rw [set.mem_set_of_eq], intro Hx,
  have H1 := Hneg x, have H2 := Hpos x,
  rw imp_iff_not_or at H1 H2,
  split, cases H1, repeat{linarith},
  cases H2, repeat{linarith}
end

lemma nat_fin_from_real_bounded (φ : ℝ → Prop)
(Hφ : bounded {x | φ x})
: {x : ℕ | φ (↑x)}.finite :=
begin
  rw real_bounded_iff_subset_Icc at Hφ,
  rcases Hφ with ⟨M, N, Hφ⟩,
  rw [←set.finite_coe_iff],
  let S₁ := {x : ℕ | M ≤ ↑x ∧ ↑x ≤ N},
  haveI : finite S₁, begin
    let S₂ := {x : ℤ | M ≤ ↑x ∧ ↑x ≤ N},
    have : S₂.finite, begin
      have : (S₂ = S₂), from rfl,
      conv_rhs at this {simp only [S₂]},
      simp_rw [←int.le_floor, ←int.ceil_le] at this,
      rw this, clear this, clear S₁ S₂,
      apply set.finite_Icc
    end,
    haveI := set.finite_coe_iff.mpr
      (set.finite.preimage_embedding inj_posℤ this),
    apply finite.set.subset (inj_posℤ ⁻¹' S₂),
    simp only [inj_posℤ.equations._eqn_1,
      set.set_of_subset_set_of, set.preimage_set_of_eq,
      function.embedding.coe_fn_mk,
      int.cast_coe_nat, and_imp], tauto
  end,
  apply finite.set.subset S₁,
  intro x, exact @Hφ (x : ℝ)
end

lemma sum_exp {x : ℝ} (Hx : x > 0)
: summable (λ n : ℕ, real.exp (-n * x)) :=
begin
  let c := real.exp (-x),
  have : ∀n : ℕ, real.exp (-n * x) = c ^ n,
    by {intro n, rw [neg_mul, ←mul_neg, real.exp_nat_mul]},
  simp_rw this,
  apply summable_geometric_of_lt_1,
  have := real.exp_pos (-x), linarith,
  rw real.exp_lt_one_iff, linarith
end

notation (name := polynomial) R`[X]`:9000 := polynomial R

lemma quadratic_tendsto {a b c : ℝ} (Ha : a > 0)
: tendsto (λ x, eval x
  ((C a * X ^ 2) + ((C b * X ^ 1) + (C c * X ^ 0))))
  at_top at_top :=
begin
  rw tendsto_at_top_iff_leading_coeff_nonneg,
  rw [show (0 : with_bot ℕ) = ↑(0 : ℕ), by refl, coe_lt_degree],
  let p := (C a * X ^ 2) + ((C b * X ^ 1) + (C c * X ^ 0)),
  have : p.nat_degree = 2, begin
    rw nat_degree_add_eq_left_of_nat_degree_lt,
    all_goals {rw nat_degree_C_mul_X_pow},
    linarith, swap, linarith,
    rw [show ∀(x : ℕ), x < 2 ↔ x ≤ 1, by omega],
    apply nat_degree_add_le_of_degree_le,
    apply nat_degree_C_mul_X_pow_le,
    transitivity 0, apply nat_degree_C_mul_X_pow_le,
    omega
  end,
  simp only [leading_coeff],
  rw this, split, omega,
  simp only [coeff_add, coeff_X_pow, coeff_C_mul],
  norm_num, linarith
end

lemma quadratic_lemma_1 {a b c : ℝ}
: ∀ x : ℝ,
  eval x ((C a * X ^ 2) + ((C b * X ^ 1) + (C c * X ^ 0)))
  = a * (x * x) + b * x + c :=
begin
  intro x,
  simp only [eval_C, eval_X, eval_pow, eval_mul,
    pow_one, monomial_zero_left, eval_add,
    show 2 = 1 + 1, from rfl, pow_succ, pow_zero,
    true_or, eq_self_iff_true, add_assoc, mul_one]
end

lemma quadratic_bounded {a b c : ℝ} (Ha : a > 0)
: (bounded {x : ℝ | a * (x * x) + b * x + c < 0}) :=
begin
  apply bounded_if_tends_neginf, {
    simp_rw ←quadratic_lemma_1,
    apply quadratic_tendsto, exact Ha
  }, {
    rw [←map_neg_at_top, tendsto_map'_iff],
    simp only [function.comp],
    have : ∀x : ℝ,
       (a * (-x * -x) + b * -x + c
      = a * (x * x) + (-b) * x + c), by {intro, ring_nf},
    simp_rw [this, ←quadratic_lemma_1], clear this,
    apply quadratic_tendsto, exact Ha
  }
end

lemma summable_theta_pos (z : ℂ) (a : ℝ) (Hz : z.re > 0)
: summable (λ n : ℕ, exp (- (n + a) ^ 2 * π * z)) :=
begin
  simp only [int.cast_coe_nat, neg_mul],
  apply summable_of_norm_bounded_eventually
    (λ n : ℕ, real.exp (- n * z.re)),
  swap 3, apply_instance, swap,
  simp only [complex.norm_eq_abs], simp_rw complex.abs_exp,
  simp only [real.exp_le_exp, sq, filter.eventually_cofinite,
    not_le, neg_re, mul_re, mul_im, add_re, add_im,
    of_real_re, of_real_im,
    nat_cast_re, nat_cast_im, add_zero, mul_zero,
    zero_mul, zero_add, sub_zero, sub_lt_zero,
    lt_neg_iff_add_neg
  ],
  simp_rw [
  show ∀ x : ℝ,
    -x * z.re + (x + a) * (x + a) * π * z.re
    = π * z.re * (x * x) + (2 * a * π - 1) * z.re * x
      + π * z.re * a * a, by {intro, ring} ],
  {
    apply nat_fin_from_real_bounded
      (λ x, π * z.re * (x * x) +
        (2 * a * π - 1) * z.re * x + π * z.re * a * a < 0),
    apply quadratic_bounded,
    have : π > 0, by exact real.pi_pos,
    nlinarith
  }, {
    apply sum_exp, exact Hz
  }
end

lemma summable_theta_neg (z : ℂ) (a : ℝ) (Hz : z.re > 0)
: summable (λ n : ℕ, exp (- (-n + a) ^ 2 * π * z)) :=
begin
  simp_rw [show
    ∀n : ℕ, (-(n : ℂ) + a) ^ 2 = (n + (-a : ℝ)) ^ 2, by
    {intro, repeat{rw sq},
      simp only [complex.of_real_neg], ring_nf}],
  exact summable_theta_pos z (-a) Hz
end

def ℂ_re_pos := {x : ℂ // x.re > 0}

@[simp] instance C_re_pos_coe :
  has_coe ℂ_re_pos ℂ := ⟨λ x, x.val⟩

lemma summable_theta (z : ℂ_re_pos) (a : ℝ)
: summable (λ n : ℤ, exp (- (-n + a) ^ 2 * π * z)) :=
begin
  apply summable_ℤ_if_summable_two_sides,
  convert summable_theta_neg z.1 a z.2,
  convert summable_theta_pos z.1 a z.2,
  ext1, congr, push_cast, ring,
end

def θ := λ (z : ℂ) (a : ℝ),
  ∑' (n : ℤ), complex.exp (- (n + a) ^ 2 * π * z)

@[reducible] def ℝexp := real.exp
def complex.sqrt (z : ℂ) := exp (log(z)/2)
notation `√` := real.sqrt
notation `√'` := complex.sqrt

open measure interval_integral
open_locale topological_space

lemma integrable_1 (a b : ℝ)
: integrable_on (λ (x : ℝ), x * ℝexp (-x ^ 2)) (Ioc a b) :=
  by { apply continuous.integrable_on_Ioc, continuity }

lemma integral_1 (b : ℝ) :
  ∫ x in 0 .. b, x * ℝexp (-x^2) = 1/2 * (1 - ℝexp (-b^2)) :=
begin
  set f := λ (x : ℝ), (-1/2) * ℝexp (-x^2),
  set f' := λ (x : ℝ), x * ℝexp (-x^2),
  have : deriv f = f' ∧ ∀ x : ℝ, differentiable_at ℝ f x :=
  begin
    split,
    simp_rw [deriv_const_mul_field'],
    have : ∀ x : ℝ, differentiable_at ℝ (λ x, -x^2) x,
    by {intros, simp only [differentiable_at.pow,
        differentiable_at.neg, differentiable_at_id']},
    simp_rw [λ x, deriv_exp (this x)],
    simp only [deriv.neg', deriv_pow'',
      differentiable_at_id', coe_bit0,
      algebra_map.coe_one, pow_one, deriv_id'',
      mul_one, mul_neg], ring_nf,
    intros, simp only [differentiable_at.mul,
      differentiable_at_neg_iff,
      differentiable_at_const, differentiable_at.exp,
      differentiable_at.pow, differentiable_at_id']
  end,
  rw [←this.1, integral_deriv_eq_sub (λ x Hx, this.2 x)],
  { simp only [f], ring_nf, rwa [ℝexp, real.exp_zero, mul_one] },
  { simp only [this.1, f'],
    rw interval_integrable_iff, apply integrable_1 }
end

lemma integral_2 :
  ∫ x in Ioi 0, x * ℝexp (-x^2) = 1/2 :=
begin
  have : tendsto
    (λ b, ∫ x in 0 .. b, x * ℝexp (-x^2)) at_top (𝓝 $ 1/2) :=
  begin
    simp_rw integral_1,
    rw [show 𝓝 ((1 : ℝ) / 2) = 𝓝 ((1 / 2) * 1), by rwa [mul_one]],
    apply tendsto.mul, apply tendsto_const_nhds,
    rw [show 𝓝 (1 : ℝ) = 𝓝 (1 - 0), by norm_num],
    apply tendsto.sub, apply tendsto_const_nhds,
    dsimp [ℝexp], rw real.tendsto_exp_comp_nhds_zero,
    simp_rw [show ∀ (x : ℝ),
      (-x ^ 2) = (-x) * x, by {intros, nlinarith}],
    apply tendsto.at_bot_mul_at_top,
    apply tendsto_neg_at_top_at_bot, apply tendsto_id
  end,
  refine tendsto_nhds_unique
    (interval_integral_tendsto_integral_Ioi
      0 _ tendsto_id) this,
  refine integrable_on_Ioi_of_interval_integral_norm_tendsto
    (1/2) 0 _ tendsto_id _,
  { intros, apply integrable_1 },
  dsimp [id], refine (tendsto_congr' _).mp this,
  clear this, rw eventually_eq_iff_exists_mem, use (Ioi 0),
  split, apply Ioi_mem_at_top,
  intros x Hx,
  apply integral_congr,
  intros t Ht, dsimp, rw abs_of_nonneg,
  apply mul_nonneg, have := min_le_iff.mp Ht.1,
  change 0 < x at Hx,
  cases this, repeat {linarith},
  apply le_of_lt, apply real.exp_pos
end

lemma integral_3 :
  ∫ (x : ℝ × ℝ), ℝexp (-(x.1^2+x.2^2))
= 2 * π * ∫ x in Ioi 0, x * ℝexp (-x^2) :=
begin
  rw [←integral_comp_polar_coord_symm
    (λ (x : ℝ × ℝ), ℝexp (-(x.1^2+x.2^2)))],
  dsimp,
  simp_rw [show ∀ (x y z : ℝ),
    (z * x)^2 + (z * y)^2 = z^2 * (x^2 + y^2),
      by {intros, nlinarith},
    real.cos_sq_add_sin_sq, mul_one],
  conv_rhs {rw [mul_comm]},
  convert integral_prod_mul (λx, x * ℝexp (-x^2)) (λx, 1),
  swap 4,
  exact ((volume : measure ℝ).restrict $ Ioo (-π) π),
  { symmetry, apply measure.prod_restrict },
  { ext, rwa mul_one },
  {
    rw [measure_theory.integral_const,
        measure.restrict_apply, set.univ_inter,
        real.volume_Ioo, ennreal.to_real_of_real],
    norm_num, ring_nf,
    linarith [real.pi_pos], exact measurable_set.univ
  },
  { apply_instance }, { apply_instance }
end

lemma integral_4 :
∫ (x : ℝ × ℝ), ℝexp (-(x.1^2+x.2^2)) =
  (∫ (x : ℝ), ℝexp (-x^2))^2 :=
begin
  conv_rhs{rw sq},
  convert integral_prod_mul (λx, ℝexp (-x^2)) (λx, ℝexp (-x^2)),
  ext1, convert real.exp_add _ _, ring_nf,
  { apply_instance }, { apply_instance }
end

lemma integral_exp_neg_sq
: (∫ (x : ℝ), ℝexp (-x^2) = √π) :=
begin
  have : ∫ (x : ℝ), ℝexp (-x ^ 2) ≥ 0 :=
    integral_nonneg (λ x, le_of_lt $ real.exp_pos (-x ^ 2)),
  rw [←(abs_of_nonneg this), ←real.sqrt_sq_eq_abs],
  congr, rw [←integral_4, integral_3, integral_2], ring_nf
end

lemma integrable_exp_neg_sq
: integrable (λx : ℝ, ℝexp (-x ^ 2)) :=
begin
  have := integral_exp_neg_sq,
  contrapose! this, rw measure_theory.integral_undef this,
  clear this, apply ne.symm, rw real.sqrt_ne_zero,
  all_goals { have := real.pi_pos, linarith }
end

noncomputable def I₃ (c T : ℝ) := ∫ (y : ℝ) in 0..c,
    I * (exp (-(T + y * I) ^ 2) - exp (-(T - y * I) ^ 2))

lemma estimate_I₃ (c T : ℝ)
: ∥I₃ c T∥ ≤ 2 * |c| * ℝexp(c^2 - T^2) :=
begin
  conv_rhs {
  rw show 2 * |c| * ℝexp(c^2 - T^2)
    = 2 * (ℝexp (c^2) * ℝexp (-T^2)) * |c-0|,
    by {rw [show c^2 - T^2 = c^2 + (-T^2), by linarith],
        rw [ℝexp, sub_zero, real.exp_add], ring_nf }},
  apply interval_integral.norm_integral_le_of_norm_le_const,
  intros x Hx, rw norm_mul,
  conv in ∥I∥ {rw [complex.norm_eq_abs, complex.abs_I]},
  rw one_mul, refine le_trans (norm_sub_le _ _) _, rw two_mul,
  conv_lhs {simp only [norm_eq_abs, complex.abs_exp,
    tsub_zero, sub_re, neg_re, add_zero, neg_mul,
    mul_one, mul_re, zero_sub, zero_mul, of_real_re, mul_neg,
    neg_sub, of_real_im, I_im, sq, sub_im, I_re, neg_neg,
    mul_im, mul_zero, neg_zero, add_im, add_re, zero_add]},
  have : ℝexp (x * x - T * T) ≤ ℝexp (c ^ 2) * ℝexp (-T ^ 2) :=
  begin
    rw [show x * x - T * T = x ^ 2 + (-T ^ 2), by nlinarith],
    rw [ℝexp, real.exp_add], apply mul_le_mul_of_nonneg_right,
    rw mem_interval_oc at Hx, rw [real.exp_le_exp, sq_le_sq],
    rw [abs_le, le_abs, neg_le, le_abs],
    { apply of_not_not, intro H,
      simp only [not_and_distrib, not_or_distrib] at H,
      cases H, all_goals {cases Hx}, repeat {linarith} },
    { apply le_of_lt, apply real.exp_pos }
  end,
  apply add_le_add, exact this, exact this
end

lemma interval_integrable_3 (c : ℝ):
  integrable (λ (x : ℝ), exp (-(x + c * I) ^ 2)) :=
begin
  have : integrable (λ x : ℝ, ℝexp (c ^ 2) * ℝexp (-x ^ 2)),
    by {apply integrable.const_mul integrable_exp_neg_sq},
  apply integrable.mono' this,
  all_goals {clear this},
  apply continuous.ae_strongly_measurable, continuity,
  filter_upwards with x,
  simp only [neg_re, abs_exp, complex.norm_eq_abs, sq,
    tsub_zero, add_im, add_zero, mul_one, mul_re,
    zero_mul, of_real_re, add_re, neg_sub, of_real_im,
    I_im, zero_add, I_re, mul_im, mul_zero, ℝexp],
  rwa [sub_eq_add_neg, real.exp_add]
end

lemma tendsto_I₂:
  tendsto (λ (T : ℝ), ∫ (x : ℝ) in -T..T, exp (-↑x ^ 2))
  at_top (nhds ↑(√ π)) :=
begin
  convert interval_integral_tendsto_integral _
      tendsto_neg_at_top_at_bot tendsto_id,
  all_goals {norm_cast}, rwa integral_exp_neg_sq,
  exact of_real_clm.integrable_comp integrable_exp_neg_sq
end

lemma tendsto_I₃ (c : ℝ):
  tendsto (λ (x : ℝ), I₃ c x) at_top (nhds 0) :=
begin
  rw tendsto_zero_iff_norm_tendsto_zero,
  refine squeeze_zero _ (estimate_I₃ c) _,
  { intros, apply norm_nonneg },
  rw [show 0 = 2 * |c| * 0, by norm_num],
  apply tendsto.const_mul, rw real.tendsto_exp_comp_nhds_zero,
  apply tendsto.add_at_bot, apply tendsto_const_nhds,
  simp_rw [show ∀ (x : ℝ),
    (-x ^ 2) = (-x) * x, by {intros, nlinarith}],
  apply tendsto.at_bot_mul_at_top,
  apply tendsto_neg_at_top_at_bot, apply tendsto_id
end

lemma fourier_exp_negsq_1 (c : ℝ)
: (∫ (x : ℝ), exp (-(x+c*I)^2) = √π) :=
begin
  refine tendsto_nhds_unique
    (interval_integral_tendsto_integral _
      tendsto_neg_at_top_at_bot tendsto_id) _,
  apply interval_integrable_3,
  have C := λ T : ℝ,
    integral_boundary_rect_eq_zero_of_differentiable_on
    (λ z, exp (-z^2)) (-T) (T + c*I) _,
  simp only [neg_re, of_real_re, add_re, mul_re,
    I_re, mul_zero, of_real_im, I_im, zero_mul,
    tsub_zero, add_zero, neg_im, neg_zero, add_im,
    mul_im, mul_one, zero_add, of_real_zero,
    algebra.id.smul_eq_mul, of_real_neg] at C,
  swap,
  { suffices : ∀ X : set ℂ,
      differentiable_on ℂ (λ (z : ℂ), exp (-z ^ 2)) X,
    apply this,
    intro X, apply differentiable_on.cexp,
    apply differentiable_on.neg, apply differentiable_on.pow,
    apply differentiable_on_id },
  set I₁ :=
    (λ T, ∫ (x : ℝ) in -T..T, exp (-(x + c * I) ^ 2)) with HI₁,
  dsimp, simp_rw [←HI₁], clear HI₁,
  let I₂ := λ T, ∫ (x : ℝ) in -T..T, exp (-x ^ 2),
  let I₄ := λ T : ℝ, ∫ (y : ℝ) in 0..c, exp (-(T + y * I) ^ 2),
  let I₅ := λ T : ℝ, ∫ (y : ℝ) in 0..c, exp (-(-T + y * I) ^ 2),
  change ∀ (T : ℝ), I₂ T - I₁ T + I * I₄ T - I * I₅ T = 0 at C,
  have : ∀ (T : ℝ), I₁ T = I₂ T + I₃ c T :=
  begin
    intro T, specialize C T, rw sub_eq_zero at C, unfold I₃,
    rw [integral_const_mul, interval_integral.integral_sub],
    repeat {swap,
      {apply continuous.interval_integrable, continuity }},
    simp_rw [show ∀ a b : ℂ, (a - b * I)^2 = (- a + b * I)^2,
      by {intros, rw sq, ring_nf}],
    change I₁ T = I₂ T + I * (I₄ T - I₅ T),
    rw [mul_sub, ←C], abel
  end,
  clear C I₄ I₅,
  rw [show I₁ = λ T, I₂ T + I₃ c T, by {ext1 x, apply this}],
  clear this I₁, rw [show √π = √π + 0, by rw add_zero],
  push_cast, apply tendsto.add,
  apply tendsto_I₂, apply tendsto_I₃
end

lemma fourier_exp_negsq_2 (c : ℂ)
: (∫ (x : ℝ), exp (-(x+c)^2) = √π) :=
begin
  rw ←re_add_im c, simp_rw [←add_assoc],
  norm_cast,
  rw integral_add_right_eq_self
    (λ(x : ℝ), exp (-(↑x + ↑(c.im) * I) ^ 2)),
  apply fourier_exp_negsq_1, apply_instance
end

lemma fourier_exp_negsq (n : ℂ)
: ∫ (x : ℝ), exp (I*n*x) * exp (-x^2) = exp (-n^2/4) * √π :=
begin
  simp_rw [←exp_add,
    show ∀ x : ℂ, I*n*x + (-x^2) = -n^2/4 + -(x+(-I*n/2))^2,
    by {intros, ring_nf SOP, rw I_sq, ring_nf}, exp_add],
  conv in (exp _ * _) {rw ←smul_eq_mul},
  rw [measure_theory.integral_smul, smul_eq_mul], congr,
  apply fourier_exp_negsq_2
end