import for_mathlib.exact_seq
import for_mathlib.abelian_category

noncomputable theory

open category_theory
open category_theory.limits

universes v u

variables {𝒜 : Type u} [category.{v} 𝒜] [abelian 𝒜]
variables {A B C : 𝒜} {f : A ⟶ B} {g : B ⟶ C}

namespace category_theory

namespace exact_seq

lemma drop : ∀ {L : list (arrow 𝒜)} (h : exact_seq 𝒜 L) (n : ℕ),
  exact_seq 𝒜 (L.drop n)
| _ nil               0     := nil
| _ nil               (n+1) := nil
| _ (single f)        0     := single f
| _ (single f)        (n+1) := drop nil n
| _ (cons f g h L hL) 0     := cons f g h L hL
| _ (cons f g h L hL) (n+1) := hL.drop n

lemma pair : ∀ {L : list (arrow 𝒜)} (h : exact_seq 𝒜 (f :: g :: L)),
  exact f g
| L (cons _ _ h _ _) := h

end exact_seq

namespace exact

lemma mono_of_eq_zero (h : exact f g) (hf : f = 0) : mono g :=
by rwa [(abelian.tfae_mono A g).out 0 2, ← hf]

lemma eq_zero_of_mono (h : exact f g) (hg : mono g) : f = 0 :=
by rw [← cancel_mono g, h.w, zero_comp]

lemma mono_iff_eq_zero (h : exact f g) : mono g ↔ f = 0 :=
⟨h.eq_zero_of_mono, h.mono_of_eq_zero⟩

lemma epi_of_eq_zero (h : exact f g) (hg : g = 0) : category_theory.epi f :=
by rwa [(abelian.tfae_epi C f).out 0 2, ← hg]

lemma eq_zero_of_epi (h : exact f g) (hf : category_theory.epi f) : g = 0 :=
by rw [← cancel_epi f, h.w, comp_zero]

lemma epi_iff_eq_zero (h : exact f g) : category_theory.epi f ↔ g = 0 :=
⟨h.eq_zero_of_epi, h.epi_of_eq_zero⟩

lemma mono_of_is_zero (h : exact f g) (hA : is_zero A) : mono g :=
by { rw h.mono_iff_eq_zero, exact hA.eq_of_src f _ }

lemma epi_of_is_zero (h : exact f g) (hA : is_zero C) : category_theory.epi f :=
by { rw h.epi_iff_eq_zero, exact hA.eq_of_tgt g _ }

lemma is_zero_of_eq_zero_eq_zero (h : exact f g) (hf : f = 0) (hg : g = 0) : is_zero B :=
is_zero_of_exact_zero_zero' _ _ h hf hg

lemma is_zero_of_is_zero_is_zero (h : exact f g) (hA : is_zero A) (hC : is_zero C) : is_zero B :=
is_zero_of_exact_is_zero_is_zero _ _ h hA hC

protected lemma exact_seq (h : exact f g) : exact_seq 𝒜 [f, g] :=
(exact_iff_exact_seq _ _).mp h

lemma cons (h : exact f g) {L : list (arrow 𝒜)} (hL : exact_seq 𝒜 (g :: L)) :
  exact_seq 𝒜 (f :: g :: L) :=
exact_seq.cons f g h L hL

end exact

end category_theory


import data.fix.parser.basic

universes u

namespace hidden

universes u_1 u_2 u_3

set_option trace.app_builder true
set_option pp.universes true

qpf list_F'' (α β : Type)
| cons : ℤ → (ℕ → α) → (list ℕ → α) → (ℤ → β) → list_F''
| a : α → list_F''
| b : β → list_F''
| nil : list_F''
-- #exit
-- @[derive mvqpf]
qpf list_F (α : Type)
| nil : list_F
| cons : ℤ → α → list_F

-- #exit
-- -- #print hidden.list_F.head_t
-- #print prefix hidden.list_F
-- #print hidden.list_F.child_t
-- -- #print hidden.list_F.pfunctor

-- -- #test list_F.internal_eq
-- -- #test @list_F.map

-- example : ∀ (α : Type), list_F.internal (typevec.of_ind (typevec.ind.cons α typevec.ind.nil)) = list_F α :=
-- list_F.internal_eq

-- example : Π (α β : typevec 1), α ⟹ β → list_F.internal α → list_F.internal β :=
-- list_F.internal.map

-- -- #test hidden.list_F.internal.map._equation_0
-- -- #test hidden.list_F.internal.map._equation_1

-- example : ∀ (α α' : Type) (f0 : α → α'),
--   list_F.internal.map (typevec.of_ind (typevec.ind.cons α typevec.ind.nil))
--       (typevec.of_ind (typevec.ind.cons α' typevec.ind.nil))
--       (typevec.append_fun typevec.nil_fun f0)
--       _ =
--     list_F.nil α' :=
-- list_F.internal.map._equation_0

-- example : ∀ (α α' : Type) (f0 : α → α') (a : ℤ) (a_1 : α),
--   list_F.internal.map (typevec.of_ind (typevec.ind.cons α typevec.ind.nil))
--       (typevec.of_ind (typevec.ind.cons α' typevec.ind.nil))
--       (typevec.append_fun typevec.nil_fun f0)
--       _ =
--     list_F.cons a (f0 a_1) :=
-- list_F.internal.map._equation_1

-- @[derive mvqpf]

-- @[user_command]
-- meta def my_cmd (_ : interactive.parse (lean.parser.tk "my_cmd")) : lean.parser unit :=
-- do lean.parser.with_input lean.parser.command_like
-- "inductive list_F (a : Type)
-- | nil : list_F",
--    pure ().

-- my_cmd

-- #check @list_F.no_confusion

-- -- #print hidden.list_F'.head_t
-- -- #print hidden.list_F'.child_t.α
-- -- #print hidden.list_F'.child_t.β
-- -- #print hidden.list_F'.child_t
-- -- #print hidden.list_F'.pfunctor

-- -- #test list_F'.internal_eq
-- -- #test @list_F'.map

-- example : ∀ (α β : Type),
--   list_F'.internal (typevec.of_ind (typevec.ind.cons α (typevec.ind.cons β typevec.ind.nil))) = list_F' α β :=
-- list_F'.internal_eq

-- example : Π (α β : typevec 2), α ⟹ β → list_F'.internal α → list_F'.internal β :=
-- list_F'.internal.map

-- -- #test hidden.list_F'.internal.map._equation_0
-- -- #test hidden.list_F'.internal.map._equation_1

-- example : ∀ (α β α' β' : Type) (f0 : α → α') (f1 : β → β'),
--   list_F'.internal.map (typevec.of_ind (typevec.ind.cons α (typevec.ind.cons β typevec.ind.nil)))
--       (typevec.of_ind (typevec.ind.cons α' (typevec.ind.cons β' typevec.ind.nil)))
--       (typevec.append_fun (typevec.append_fun typevec.nil_fun f1) f0)
--       _ =
--     list_F'.nil α' β' :=
-- list_F'.internal.map._equation_0

-- example : ∀ (α β α' β' : Type) (f0 : α → α') (f1 : β → β') (a : α) (a_1 : β),
--   list_F'.internal.map (typevec.of_ind (typevec.ind.cons α (typevec.ind.cons β typevec.ind.nil)))
--       (typevec.of_ind (typevec.ind.cons α' (typevec.ind.cons β' typevec.ind.nil)))
--       (typevec.append_fun (typevec.append_fun typevec.nil_fun f1) f0)
--       _ =
--     list_F'.cons (f0 a) (f1 a_1) :=
-- list_F'.internal.map._equation_1
set_option trace.app_builder true
set_option pp.universes true

-- @[derive mvqpf]
qpf list_F''_ (α β γ : Type u)
| nil : (β → γ) → list_F''_
| cons : (α → β) → list_F''_

-- #exit
-- #print hidden.list_F''.head_t
-- #print hidden.list_F''.child_t.γ
-- #print hidden.list_F''.child_t
-- #print hidden.list_F''.pfunctor

-- #check list_F''.internal_eq
-- #check @list_F''.map

-- example : ∀ (α : Type*) (β : Type*) (γ : Type*),
--     list_F''.internal α β (typevec.of_ind (typevec.ind.cons γ typevec.ind.nil)) = list_F'' α β γ :=
-- list_F''.internal_eq

-- example : Π (α : Type*) (β : Type*) (α_1 β_1 : typevec 1),
--     α_1 ⟹ β_1 → list_F''.internal α β α_1 → list_F''.internal α β β_1 :=
-- @list_F''.internal.map

-- #test hidden.list_F''.internal.map._equation_0
-- #test hidden.list_F''.internal.map._equation_1

-- #check list_F''.internal.map

-- example : ∀ (α : Type u_1) (β : Type u_1) (γ γ' : Type u_1) (f2 : γ → γ') (a : β → γ),
--   list_F''.internal.map α β (typevec.of_ind (typevec.ind.cons γ typevec.ind.nil))
--       (typevec.of_ind (typevec.ind.cons γ' typevec.ind.nil))
--       (typevec.append_fun typevec.nil_fun f2)
--       _ =
--     list_F''.nil α (λ (a_1 : β), f2 (a a_1)) :=
-- list_F''.internal.map._equation_0

-- example : ∀ (α : Type u_1) (β : Type u_1) (γ γ' : Type u_1) (f2 : γ → γ') (a : α → β),
--   list_F''.internal.map α β (typevec.of_ind (typevec.ind.cons γ typevec.ind.nil))
--       (typevec.of_ind (typevec.ind.cons γ' typevec.ind.nil))
--       (typevec.append_fun typevec.nil_fun f2)
--       _ =
--     list_F''.cons γ' (λ (a_1 : α), a a_1) :=
-- list_F''.internal.map._equation_1

-- @[derive mvqpf]
qpf list_F''' (α β γ : Type u)
| nil : list_F'''
| cons : (γ → β) → list_F'''

-- #check hidden.list_F'''.pfunctor.cons

-- #exit
-- #print hidden.list_F'''.head_t
-- #print hidden.list_F'''.child_t.α
-- #print hidden.list_F'''.child_t.β
-- #print hidden.list_F'''.child_t
-- #print hidden.list_F'''.pfunctor

-- #check list_F'''.internal_eq
-- #check @list_F'''.map

-- example : ∀ (α β γ : Type*),
--     list_F'''.internal γ (typevec.of_ind (typevec.ind.cons α (typevec.ind.cons β typevec.ind.nil))) =
--       list_F''' α β γ :=
-- list_F'''.internal_eq

-- example : Π (γ : Type*) (α β : typevec 2), α ⟹ β → list_F'''.internal γ α → list_F'''.internal γ β :=
-- @list_F'''.internal.map

-- -- #test hidden.list_F'''.internal.map._equation_0
-- -- #test hidden.list_F'''.internal.map._equation_1

-- example : ∀ (α β γ α' β' : Type u) (f0 : α → α') (f1 : β → β'),
--   list_F'''.internal.map γ (typevec.of_ind (typevec.ind.cons α (typevec.ind.cons β typevec.ind.nil)))
--       (typevec.of_ind (typevec.ind.cons α' (typevec.ind.cons β' typevec.ind.nil)))
--       (typevec.append_fun (typevec.append_fun typevec.nil_fun f1) f0)
--       _ = --(list_F'''.nil α β γ) =
--     list_F'''.nil α' β' γ :=
-- list_F'''.internal.map._equation_0

-- example : ∀ (α β γ α' β' : Type u) (f0 : α → α') (f1 : β → β') (a : γ → β),
--   list_F'''.internal.map γ (typevec.of_ind (typevec.ind.cons α (typevec.ind.cons β typevec.ind.nil)))
--       (typevec.of_ind (typevec.ind.cons α' (typevec.ind.cons β' typevec.ind.nil)))
--       (typevec.append_fun (typevec.append_fun typevec.nil_fun f1) f0)
--       ( _ ) =
--     list_F'''.cons α' (λ (a_1 : γ), f1 (a a_1)) :=
-- list_F'''.internal.map._equation_1

-- @[derive mvqpf]
qpf list_F'''' (α β γ : Type u)
| nil : (β → γ) → (γ → α) → list_F''''
| cons : (α → β) → list_F''''

-- #print prefix hidden.list_F''''
-- #check hidden.list_F''''.pfunctor.cons

-- #print hidden.list_F''''.head_t
-- #print hidden.list_F''''.child_t
-- #print hidden.list_F''''.pfunctor

-- #check @list_F''''.internal_eq
-- #check @list_F''''.internal.map

-- example : ∀ (α : Type*) (β : Type*) (γ : Type*),
--     list_F''''.internal α β γ (typevec.of_ind typevec.ind.nil) = list_F'''' α β γ :=
-- @list_F''''.internal_eq

example : Π (α : Type*) (β : Type*) (γ : Type*) (α_1 β_1 : typevec 0),
    α_1 ⟹ β_1 → list_F''''.internal α β γ α_1 → list_F''''.internal α β γ β_1 :=
@list_F''''.internal.map

-- #test hidden.list_F''''.internal.map._equation_0

example : ∀ (α : Type u_1) (β : Type u_1) (γ : Type u_1) (a : β → γ) (a_1 : γ → α),
  list_F''''.internal.map α β γ ⦃ ⦄ ⦃ ⦄ typevec.nil_fun
      _ =
    list_F''''.nil (λ (a_1 : β), a a_1) (λ (a : γ), a_1 a) :=
list_F''''.internal.map._equation_0

example : ∀ (α : Type u_1) (β : Type u_1) (γ : Type u_1) (a : α → β),
  list_F''''.internal.map α β γ (⦃ ⦄) ( ⦃ ⦄ ) typevec.nil_fun
      _ =
    list_F''''.cons γ (λ (a_1 : α), a a_1) :=
list_F''''.internal.map._equation_1

-- data list
-- | nil : list
-- | cons : ℤ → list → list

end hidden


/-
Copyright (c) 2016 Leonardo de Moura. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import data.set.lattice

/-!
# Functoriality of `set`

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

This file defines the functor structure of `set`.
-/

universes u

open function

namespace set
variables {α β : Type u} {s : set α} {f : α → set β} {g : set (α → β)}

instance : monad.{u} set :=
{ pure       := λ α a, {a},
  bind       := λ α β s f, ⋃ i ∈ s, f i,
  seq        := λ α β, set.seq,
  map        := λ α β, set.image }

@[simp] lemma bind_def : s >>= f = ⋃ i ∈ s, f i := rfl
@[simp] lemma fmap_eq_image (f : α → β) : f <$> s = f '' s := rfl
@[simp] lemma seq_eq_set_seq (s : set (α → β)) (t : set α) : s <*> t = s.seq t := rfl
@[simp] lemma pure_def (a : α) : (pure a : set α) = {a} := rfl

/-- `set.image2` in terms of monadic operations. Note that this can't be taken as the definition
because of the lack of universe polymorphism. -/
lemma image2_def {α β γ : Type*} (f : α → β → γ) (s : set α) (t : set β) :
  image2 f s t = f <$> s <*> t :=
by { ext, simp }

instance : is_lawful_monad set :=
{ id_map                := λ α, image_id,
  comp_map              := λ α β γ f g s, image_comp _ _ _,
  pure_bind             := λ α β, bUnion_singleton,
  bind_assoc            := λ α β γ s f g, by simp only [bind_def, bUnion_Union],
  bind_pure_comp_eq_map := λ α β f s, (image_eq_Union _ _).symm,
  bind_map_eq_seq       := λ α β s t, seq_def.symm }

instance : is_comm_applicative (set : Type u → Type u) :=
⟨ λ α β s t, prod_image_seq_comm s t ⟩

instance : alternative set :=
{ orelse := λ α, (∪),
  failure := λ α, ∅,
  .. set.monad }

end set


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.monoidal.braided
import category_theory.functor.reflects_isomorphisms

/-!
# Half braidings and the Drinfeld center of a monoidal category

We define `center C` to be pairs `⟨X, b⟩`, where `X : C` and `b` is a half-braiding on `X`.

We show that `center C` is braided monoidal,
and provide the monoidal functor `center.forget` from `center C` back to `C`.

## Future work

Verifying the various axioms here is done by tedious rewriting.
Using the `slice` tactic may make the proofs marginally more readable.

More exciting, however, would be to make possible one of the following options:
1. Integration with homotopy.io / globular to give "picture proofs".
2. The monoidal coherence theorem, so we can ignore associators
   (after which most of these proofs are trivial;
   I'm unsure if the monoidal coherence theorem is even usable in dependent type theory).
3. Automating these proofs using `rewrite_search` or some relative.

-/

open category_theory
open category_theory.monoidal_category

universes v v₁ v₂ v₃ u u₁ u₂ u₃
noncomputable theory

namespace category_theory

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

/--
A half-braiding on `X : C` is a family of isomorphisms `X ⊗ U ≅ U ⊗ X`,
monoidally natural in `U : C`.

Thinking of `C` as a 2-category with a single `0`-morphism, these are the same as natural
transformations (in the pseudo- sense) of the identity 2-functor on `C`, which send the unique
`0`-morphism to `X`.
-/
@[nolint has_inhabited_instance]
structure half_braiding (X : C) :=
(β : Π U, X ⊗ U ≅ U ⊗ X)
(monoidal' : ∀ U U', (β (U ⊗ U')).hom =
  (α_ _ _ _).inv ≫ ((β U).hom ⊗ 𝟙 U') ≫ (α_ _ _ _).hom ≫ (𝟙 U ⊗ (β U').hom) ≫ (α_ _ _ _).inv
  . obviously)
(naturality' : ∀ {U U'} (f : U ⟶ U'), (𝟙 X ⊗ f) ≫ (β U').hom = (β U).hom ≫ (f ⊗ 𝟙 X) . obviously)

restate_axiom half_braiding.monoidal'
attribute [reassoc, simp] half_braiding.monoidal -- the reassoc lemma is redundant as a simp lemma
restate_axiom half_braiding.naturality'
attribute [simp, reassoc] half_braiding.naturality

variables (C)
/--
The Drinfeld center of a monoidal category `C` has as objects pairs `⟨X, b⟩`, where `X : C`
and `b` is a half-braiding on `X`.
-/
@[nolint has_inhabited_instance]
def center := Σ X : C, half_braiding X

namespace center

variables {C}

/-- A morphism in the Drinfeld center of `C`. -/
@[ext, nolint has_inhabited_instance]
structure hom (X Y : center C) :=
(f : X.1 ⟶ Y.1)
(comm' : ∀ U, (f ⊗ 𝟙 U) ≫ (Y.2.β U).hom = (X.2.β U).hom ≫ (𝟙 U ⊗ f) . obviously)

restate_axiom hom.comm'
attribute [simp, reassoc] hom.comm

instance : category (center C) :=
{ hom := hom,
  id := λ X, { f := 𝟙 X.1, },
  comp := λ X Y Z f g, { f := f.f ≫ g.f, }, }

@[simp] lemma id_f (X : center C) : hom.f (𝟙 X) = 𝟙 X.1 := rfl
@[simp] lemma comp_f {X Y Z : center C} (f : X ⟶ Y) (g : Y ⟶ Z) : (f ≫ g).f = f.f ≫ g.f := rfl

@[ext]
lemma ext {X Y : center C} (f g : X ⟶ Y) (w : f.f = g.f) : f = g :=
by { cases f, cases g, congr, exact w, }

/--
Construct an isomorphism in the Drinfeld center from
a morphism whose underlying morphism is an isomorphism.
-/
@[simps]
def iso_mk {X Y : center C} (f : X ⟶ Y) [is_iso f.f] : X ≅ Y :=
{ hom := f,
  inv := ⟨inv f.f, λ U, by simp [←cancel_epi (f.f ⊗ 𝟙 U), ←comp_tensor_id_assoc, ←id_tensor_comp]⟩ }

instance is_iso_of_f_is_iso {X Y : center C} (f : X ⟶ Y) [is_iso f.f] : is_iso f :=
begin
  change is_iso (iso_mk f).hom,
  apply_instance,
end

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
@[simps]
def tensor_obj (X Y : center C) : center C :=
⟨X.1 ⊗ Y.1,
  { β := λ U, α_ _ _ _ ≪≫ (iso.refl X.1 ⊗ Y.2.β U) ≪≫ (α_ _ _ _).symm
      ≪≫ (X.2.β U ⊗ iso.refl Y.1) ≪≫ α_ _ _ _,
    monoidal' := λ U U',
    begin
      dsimp,
      simp only [comp_tensor_id, id_tensor_comp, category.assoc, half_braiding.monoidal],
      rw [pentagon_assoc, pentagon_inv_assoc, iso.eq_inv_comp, ←pentagon_assoc,
        ←id_tensor_comp_assoc, iso.hom_inv_id, tensor_id, category.id_comp,
        ←associator_naturality_assoc, cancel_epi, cancel_epi,
        ←associator_inv_naturality_assoc (X.2.β U).hom,
        associator_inv_naturality_assoc _ _ (Y.2.β U').hom, tensor_id, tensor_id,
        id_tensor_comp_tensor_id_assoc, associator_naturality_assoc (X.2.β U).hom,
        ←associator_naturality_assoc _ _ (Y.2.β U').hom, tensor_id, tensor_id,
        tensor_id_comp_id_tensor_assoc, ←id_tensor_comp_tensor_id, tensor_id, category.comp_id,
        ←is_iso.inv_comp_eq, inv_tensor, is_iso.inv_id, is_iso.iso.inv_inv, pentagon_assoc,
        iso.hom_inv_id_assoc, cancel_epi, cancel_epi, ←is_iso.inv_comp_eq, is_iso.iso.inv_hom,
        ←pentagon_inv_assoc, ←comp_tensor_id_assoc, iso.inv_hom_id, tensor_id, category.id_comp,
        ←associator_inv_naturality_assoc, cancel_epi, cancel_epi, ←is_iso.inv_comp_eq, inv_tensor,
        is_iso.iso.inv_hom, is_iso.inv_id, pentagon_inv_assoc, iso.inv_hom_id, category.comp_id],
    end,
    naturality' := λ U U' f,
    begin
      dsimp,
      rw [category.assoc, category.assoc, category.assoc, category.assoc,
        id_tensor_associator_naturality_assoc, ←id_tensor_comp_assoc, half_braiding.naturality,
        id_tensor_comp_assoc, associator_inv_naturality_assoc, ←comp_tensor_id_assoc,
        half_braiding.naturality, comp_tensor_id_assoc, associator_naturality, ←tensor_id],
    end, }⟩

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
@[simps]
def tensor_hom {X₁ Y₁ X₂ Y₂ : center C} (f : X₁ ⟶ Y₁) (g : X₂ ⟶ Y₂) :
  tensor_obj X₁ X₂ ⟶ tensor_obj Y₁ Y₂ :=
{ f := f.f ⊗ g.f,
  comm' := λ U, begin
    dsimp,
    rw [category.assoc, category.assoc, category.assoc, category.assoc,
      associator_naturality_assoc, ←tensor_id_comp_id_tensor, category.assoc,
      ←id_tensor_comp_assoc, g.comm, id_tensor_comp_assoc, tensor_id_comp_id_tensor_assoc,
      ←id_tensor_comp_tensor_id, category.assoc, associator_inv_naturality_assoc,
      id_tensor_associator_inv_naturality_assoc, tensor_id,
      id_tensor_comp_tensor_id_assoc, ←tensor_id_comp_id_tensor g.f, category.assoc,
      ←comp_tensor_id_assoc, f.comm, comp_tensor_id_assoc, id_tensor_associator_naturality,
      associator_naturality_assoc, ←id_tensor_comp, tensor_id_comp_id_tensor],
  end }

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
@[simps]
def tensor_unit : center C :=
⟨𝟙_ C,
  { β := λ U, (λ_ U) ≪≫ (ρ_ U).symm,
    monoidal' := λ U U', by simp,
    naturality' := λ U U' f, begin
      dsimp,
      rw [left_unitor_naturality_assoc, right_unitor_inv_naturality, category.assoc],
    end, }⟩

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
def associator (X Y Z : center C) : tensor_obj (tensor_obj X Y) Z ≅ tensor_obj X (tensor_obj Y Z) :=
iso_mk ⟨(α_ X.1 Y.1 Z.1).hom, λ U, begin
  dsimp,
  simp only [category.assoc, comp_tensor_id, id_tensor_comp],
  rw [pentagon, pentagon_assoc, ←associator_naturality_assoc (𝟙 X.1) (𝟙 Y.1), tensor_id, cancel_epi,
    cancel_epi, iso.eq_inv_comp, ←pentagon_assoc, ←id_tensor_comp_assoc, iso.hom_inv_id, tensor_id,
    category.id_comp, ←associator_naturality_assoc, cancel_epi, cancel_epi, ←is_iso.inv_comp_eq,
    inv_tensor, is_iso.inv_id, is_iso.iso.inv_inv, pentagon_assoc, iso.hom_inv_id_assoc, ←tensor_id,
    ←associator_naturality_assoc],
end⟩

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
def left_unitor (X : center C) : tensor_obj tensor_unit X ≅ X :=
iso_mk ⟨(λ_ X.1).hom, λ U, begin
  dsimp,
  simp only [category.comp_id, category.assoc, tensor_inv_hom_id, comp_tensor_id,
    tensor_id_comp_id_tensor, triangle_assoc_comp_right_inv],
  rw [←left_unitor_tensor, left_unitor_naturality, left_unitor_tensor'_assoc],
end⟩

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
def right_unitor (X : center C) : tensor_obj X tensor_unit ≅ X :=
iso_mk ⟨(ρ_ X.1).hom, λ U, begin
  dsimp,
  simp only [tensor_id_comp_id_tensor_assoc, triangle_assoc, id_tensor_comp, category.assoc],
  rw [←tensor_id_comp_id_tensor_assoc (ρ_ U).inv, cancel_epi, ←right_unitor_tensor_inv_assoc,
    ←right_unitor_inv_naturality_assoc],
  simp,
end⟩

section
local attribute [simp] associator_naturality left_unitor_naturality right_unitor_naturality
  pentagon
local attribute [simp] center.associator center.left_unitor center.right_unitor

instance : monoidal_category (center C) :=
{ tensor_obj := λ X Y, tensor_obj X Y,
  tensor_hom := λ X₁ Y₁ X₂ Y₂ f g, tensor_hom f g,
  tensor_unit := tensor_unit,
  associator := associator,
  left_unitor := left_unitor,
  right_unitor := right_unitor, }

@[simp] lemma tensor_fst (X Y : center C) : (X ⊗ Y).1 = X.1 ⊗ Y.1 := rfl

@[simp] lemma tensor_β (X Y : center C) (U : C) :
  (X ⊗ Y).2.β U =
    α_ _ _ _ ≪≫ (iso.refl X.1 ⊗ Y.2.β U) ≪≫ (α_ _ _ _).symm
      ≪≫ (X.2.β U ⊗ iso.refl Y.1) ≪≫ α_ _ _ _ :=
rfl
@[simp]

@[simp] lemma tensor_unit_β (U : C) : (𝟙_ (center C)).2.β U = (λ_ U) ≪≫ (ρ_ U).symm := rfl

@[simp] lemma associator_hom_f (X Y Z : center C) : hom.f (α_ X Y Z).hom = (α_ X.1 Y.1 Z.1).hom :=
rfl

@[simp] lemma associator_inv_f (X Y Z : center C) : hom.f (α_ X Y Z).inv = (α_ X.1 Y.1 Z.1).inv :=
by { ext, rw [←associator_hom_f, ←comp_f, iso.hom_inv_id], refl, }

@[simp] lemma left_unitor_hom_f (X : center C) : hom.f (λ_ X).hom = (λ_ X.1).hom :=
rfl

@[simp] lemma left_unitor_inv_f (X : center C) : hom.f (λ_ X).inv = (λ_ X.1).inv :=
by { ext, rw [←left_unitor_hom_f, ←comp_f, iso.hom_inv_id], refl, }

@[simp] lemma right_unitor_hom_f (X : center C) : hom.f (ρ_ X).hom = (ρ_ X.1).hom :=
rfl

@[simp] lemma right_unitor_inv_f (X : center C) : hom.f (ρ_ X).inv = (ρ_ X.1).inv :=
by { ext, rw [←right_unitor_hom_f, ←comp_f, iso.hom_inv_id], refl, }

end

section
variables (C)

/-- The forgetful monoidal functor from the Drinfeld center to the original category. -/
@[simps]
def forget : monoidal_functor (center C) C :=
{ obj := λ X, X.1,
  map := λ X Y f, f.f,
  ε := 𝟙 (𝟙_ C),
  μ := λ X Y, 𝟙 (X.1 ⊗ Y.1), }

instance : reflects_isomorphisms (forget C).to_functor :=
{ reflects := λ A B f i, by { dsimp at i, resetI, change is_iso (iso_mk f).hom, apply_instance, } }

end

/-- Auxiliary definition for the `braided_category` instance on `center C`. -/
@[simps]
def braiding (X Y : center C) : X ⊗ Y ≅ Y ⊗ X :=
iso_mk ⟨(X.2.β Y.1).hom, λ U, begin
  dsimp,
  simp only [category.assoc],
  rw [←is_iso.inv_comp_eq, is_iso.iso.inv_hom, ←half_braiding.monoidal_assoc,
    ←half_braiding.naturality_assoc, half_braiding.monoidal],
  simp,
end⟩

instance braided_category_center : braided_category (center C) :=
{ braiding := braiding,
  braiding_naturality' := λ X Y X' Y' f g, begin
    ext,
    dsimp,
    rw [←tensor_id_comp_id_tensor, category.assoc, half_braiding.naturality, f.comm_assoc,
      id_tensor_comp_tensor_id],
  end, } -- `obviously` handles the hexagon axioms

section
variables [braided_category C]

open braided_category

/-- Auxiliary construction for `of_braided`. -/
@[simps]
def of_braided_obj (X : C) : center C :=
⟨X, { β := λ Y, β_ X Y,
  monoidal' := λ U U', begin
    rw [iso.eq_inv_comp, ←category.assoc, ←category.assoc, iso.eq_comp_inv,
      category.assoc, category.assoc],
    exact hexagon_forward X U U',
  end }⟩

variables (C)

/--
The functor lifting a braided category to its center, using the braiding as the half-braiding.
-/
@[simps]
def of_braided : monoidal_functor C (center C) :=
{ obj := of_braided_obj,
  map := λ X X' f,
  { f := f,
    comm' := λ U, braiding_naturality _ _, },
  ε :=
  { f := 𝟙 _,
    comm' := λ U, begin
      dsimp,
      rw [tensor_id, category.id_comp, tensor_id, category.comp_id, ←braiding_right_unitor,
        category.assoc, iso.hom_inv_id, category.comp_id],
    end, },
  μ := λ X Y,
  { f := 𝟙 _,
    comm' := λ U, begin
      dsimp,
      rw [tensor_id, tensor_id, category.id_comp, category.comp_id,
        ←iso.inv_comp_eq, ←category.assoc, ←category.assoc, ←iso.comp_inv_eq,
        category.assoc, hexagon_reverse, category.assoc],
    end, }, }

end

end center

end category_theory


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import measure_theory.integral.lebesgue
import measure_theory.measure.regular
import measure_theory.group.measurable_equiv

/-!
# Measures on Groups

We develop some properties of measures on (topological) groups

* We define properties on measures: left and right invariant measures.
* We define the measure `μ.inv : A ↦ μ(A⁻¹)` and show that it is right invariant iff
  `μ` is left invariant.
* We define a class `is_haar_measure μ`, requiring that the measure `μ` is left-invariant, finite
  on compact sets, and positive on open sets.

We also give analogues of all these notions in the additive world.
-/

noncomputable theory

open_locale ennreal pointwise big_operators
open has_inv set function measure_theory.measure

namespace measure_theory

variables {G : Type*}

section

variables [measurable_space G] [has_mul G]

/-- A measure `μ` on a topological group is left invariant
  if the measure of left translations of a set are equal to the measure of the set itself.
  To left translate sets we use preimage under left multiplication,
  since preimages are nicer to work with than images. -/
@[to_additive "A measure on a topological group is left invariant
  if the measure of left translations of a set are equal to the measure of the set itself.
  To left translate sets we use preimage under left addition,
  since preimages are nicer to work with than images."]
def is_mul_left_invariant (μ : set G → ℝ≥0∞) : Prop :=
∀ (g : G) {A : set G} (h : measurable_set A), μ ((λ h, g * h) ⁻¹' A) = μ A

/-- A measure `μ` on a topological group is right invariant
  if the measure of right translations of a set are equal to the measure of the set itself.
  To right translate sets we use preimage under right multiplication,
  since preimages are nicer to work with than images. -/
@[to_additive "A measure on a topological group is right invariant
  if the measure of right translations of a set are equal to the measure of the set itself.
  To right translate sets we use preimage under right addition,
  since preimages are nicer to work with than images."]
def is_mul_right_invariant (μ : set G → ℝ≥0∞) : Prop :=
∀ (g : G) {A : set G} (h : measurable_set A), μ ((λ h, h * g) ⁻¹' A) = μ A

@[to_additive measure_theory.is_add_left_invariant.smul]
lemma is_mul_left_invariant.smul {μ : measure G} (h : is_mul_left_invariant μ) (c : ℝ≥0∞) :
  is_mul_left_invariant ((c • μ : measure G) : set G → ℝ≥0∞) :=
λ g A hA, by rw [smul_apply, smul_apply, h g hA]

@[to_additive measure_theory.is_add_right_invariant.smul]
lemma is_mul_right_invariant.smul {μ : measure G} (h : is_mul_right_invariant μ) (c : ℝ≥0∞) :
  is_mul_right_invariant ((c • μ : measure G) : set G → ℝ≥0∞) :=
λ g A hA, by rw [smul_apply, smul_apply, h g hA]

end

namespace measure

variables [measurable_space G]

@[to_additive]
lemma map_mul_left_eq_self [topological_space G] [has_mul G] [has_continuous_mul G] [borel_space G]
  {μ : measure G} : (∀ g, measure.map ((*) g) μ = μ) ↔ is_mul_left_invariant μ :=
begin
  apply forall_congr, intro g, rw [measure.ext_iff], apply forall_congr, intro A,
  apply forall_congr, intro hA, rw [map_apply (measurable_const_mul g) hA]
end

@[to_additive]
lemma _root_.measure_theory.is_mul_left_invariant.measure_preimage_mul
  [topological_space G] [group G] [topological_group G] [borel_space G]
  {μ : measure G} (h : is_mul_left_invariant μ) (g : G) (A : set G) :
  μ ((λ h, g * h) ⁻¹' A) = μ A :=
calc μ ((λ h, g * h) ⁻¹' A) = measure.map (λ h, g * h) μ A :
  ((homeomorph.mul_left g).to_measurable_equiv.map_apply A).symm
... = μ A : by rw map_mul_left_eq_self.2 h g

@[to_additive]
lemma map_mul_right_eq_self [topological_space G] [has_mul G] [has_continuous_mul G] [borel_space G]
  {μ : measure G} :
  (∀ g, measure.map (λ h, h * g) μ = μ) ↔ is_mul_right_invariant μ :=
begin
  apply forall_congr, intro g, rw [measure.ext_iff], apply forall_congr, intro A,
  apply forall_congr, intro hA, rw [map_apply (measurable_mul_const g) hA]
end

/-- The measure `A ↦ μ (A⁻¹)`, where `A⁻¹` is the pointwise inverse of `A`. -/
@[to_additive "The measure `A ↦ μ (- A)`, where `- A` is the pointwise negation of `A`."]
protected def inv [has_inv G] (μ : measure G) : measure G :=
measure.map inv μ

variables [group G] [topological_space G] [topological_group G] [borel_space G]

@[to_additive]
lemma inv_apply (μ : measure G) (s : set G) :
  μ.inv s = μ s⁻¹ :=
(measurable_equiv.inv G).map_apply s

@[simp, to_additive] protected lemma inv_inv (μ : measure G) : μ.inv.inv = μ :=
(measurable_equiv.inv G).map_symm_map

variables {μ : measure G}

@[to_additive]
instance regular.inv [t2_space G] [regular μ] : regular μ.inv :=
regular.map (homeomorph.inv G)

end measure

section inv
variables [measurable_space G] [group G] [topological_space G] [topological_group G] [borel_space G]
  {μ : measure G}

@[simp, to_additive] lemma regular_inv_iff [t2_space G] : μ.inv.regular ↔ μ.regular :=
begin
  split,
  { introI h,
    rw ←μ.inv_inv,
    exact measure.regular.inv },
  { introI h,
    exact measure.regular.inv }
end

@[to_additive]
lemma is_mul_left_invariant.inv (h : is_mul_left_invariant μ) :
  is_mul_right_invariant μ.inv :=
begin
  intros g A hA,
  rw [μ.inv_apply, μ.inv_apply],
  convert h g⁻¹ (measurable_inv hA) using 2,
  simp only [←preimage_comp, ← inv_preimage],
  apply preimage_congr,
  intro h,
  simp only [mul_inv_rev, comp_app, inv_inv]
end

@[to_additive]
lemma is_mul_right_invariant.inv (h : is_mul_right_invariant μ) : is_mul_left_invariant μ.inv :=
begin
  intros g A hA,
  rw [μ.inv_apply, μ.inv_apply],
  convert h g⁻¹ (measurable_inv hA) using 2,
  simp only [←preimage_comp, ← inv_preimage],
  apply preimage_congr,
  intro h,
  simp only [mul_inv_rev, comp_app, inv_inv]
end

@[simp, to_additive]
lemma is_mul_right_invariant_inv : is_mul_right_invariant μ.inv ↔ is_mul_left_invariant μ :=
⟨λ h, by { rw ← μ.inv_inv, exact h.inv }, λ h, h.inv⟩

@[simp, to_additive]
lemma is_mul_left_invariant_inv : is_mul_left_invariant μ.inv ↔ is_mul_right_invariant μ :=
⟨λ h, by { rw ← μ.inv_inv, exact h.inv }, λ h, h.inv⟩

end inv

section group

variables [measurable_space G] [topological_space G] [borel_space G] {μ : measure G}
variables [group G] [topological_group G]

/-- If a left-invariant measure gives positive mass to a compact set, then
it gives positive mass to any open set. -/
@[to_additive]
lemma is_mul_left_invariant.measure_pos_of_is_open (hμ : is_mul_left_invariant μ)
  (K : set G) (hK : is_compact K) (h : μ K ≠ 0) {U : set G} (hU : is_open U) (h'U : U.nonempty) :
  0 < μ U :=
begin
  contrapose! h,
  rw ← nonpos_iff_eq_zero,
  rw nonpos_iff_eq_zero at h,
  rw ← hU.interior_eq at h'U,
  obtain ⟨t, hKt⟩ : ∃ (t : finset G), K ⊆ ⋃ (g : G) (H : g ∈ t), (λ (h : G), g * h) ⁻¹' U :=
    compact_covered_by_mul_left_translates hK h'U,
  calc μ K ≤ μ (⋃ (g : G) (H : g ∈ t), (λ (h : G), g * h) ⁻¹' U) : measure_mono hKt
  ... ≤ ∑ g in t, μ ((λ (h : G), g * h) ⁻¹' U) : measure_bUnion_finset_le _ _
  ... = 0 : by simp [hμ _ hU.measurable_set, h]
end

/-! A nonzero left-invariant regular measure gives positive mass to any open set. -/
@[to_additive]
lemma is_mul_left_invariant.null_iff_empty [regular μ] (hμ : is_mul_left_invariant μ)
  (h3μ : μ ≠ 0) {s : set G} (hs : is_open s) :
  μ s = 0 ↔ s = ∅ :=
begin
  obtain ⟨K, hK, h2K⟩ := regular.exists_compact_not_null.mpr h3μ,
  refine ⟨λ h, _, λ h, by simp only [h, measure_empty]⟩,
  contrapose h,
  exact (hμ.measure_pos_of_is_open K hK h2K hs (ne_empty_iff_nonempty.mp h)).ne'
end

@[to_additive]
lemma is_mul_left_invariant.null_iff [regular μ] (h2μ : is_mul_left_invariant μ)
  {s : set G} (hs : is_open s) :
  μ s = 0 ↔ s = ∅ ∨ μ = 0 :=
begin
  by_cases h3μ : μ = 0, { simp [h3μ] },
  simp only [h3μ, or_false],
  exact h2μ.null_iff_empty h3μ hs,
end

@[to_additive]
lemma is_mul_left_invariant.measure_ne_zero_iff_nonempty [regular μ]
  (h2μ : is_mul_left_invariant μ) (h3μ : μ ≠ 0) {s : set G} (hs : is_open s) :
  μ s ≠ 0 ↔ s.nonempty :=
by simp_rw [← ne_empty_iff_nonempty, ne.def, h2μ.null_iff_empty h3μ hs]

@[to_additive]
lemma is_mul_left_invariant.measure_pos_iff_nonempty [regular μ]
  (h2μ : is_mul_left_invariant μ) (h3μ : μ ≠ 0) {s : set G} (hs : is_open s) :
  0 < μ s ↔ s.nonempty :=
pos_iff_ne_zero.trans $ h2μ.measure_ne_zero_iff_nonempty h3μ hs

/-- If a left-invariant measure gives finite mass to a nonempty open set, then
it gives finite mass to any compact set. -/
@[to_additive]
lemma is_mul_left_invariant.measure_lt_top_of_is_compact (hμ : is_mul_left_invariant μ)
  (U : set G) (hU : is_open U) (h'U : U.nonempty) (h : μ U ≠ ∞) {K : set G} (hK : is_compact K) :
  μ K < ∞ :=
begin
  rw ← hU.interior_eq at h'U,
  obtain ⟨t, hKt⟩ : ∃ (t : finset G), K ⊆ ⋃ (g : G) (H : g ∈ t), (λ (h : G), g * h) ⁻¹' U :=
    compact_covered_by_mul_left_translates hK h'U,
  calc μ K ≤ μ (⋃ (g : G) (H : g ∈ t), (λ (h : G), g * h) ⁻¹' U) : measure_mono hKt
  ... ≤ ∑ g in t, μ ((λ (h : G), g * h) ⁻¹' U) : measure_bUnion_finset_le _ _
  ... = finset.card t * μ U : by simp only [hμ _ hU.measurable_set, finset.sum_const, nsmul_eq_mul]
  ... < ∞ : ennreal.mul_lt_top ennreal.coe_nat_ne_top h
end

/-- If a left-invariant measure gives finite mass to a set with nonempty interior, then
it gives finite mass to any compact set. -/
@[to_additive]
lemma is_mul_left_invariant.measure_lt_top_of_is_compact' (hμ : is_mul_left_invariant μ)
  (U : set G) (hU : (interior U).nonempty) (h : μ U ≠ ∞) {K : set G} (hK : is_compact K) :
  μ K < ∞ :=
hμ.measure_lt_top_of_is_compact (interior U) is_open_interior hU
  ((measure_mono (interior_subset)).trans_lt (lt_top_iff_ne_top.2 h)).ne hK

/-- For nonzero regular left invariant measures, the integral of a continuous nonnegative function
  `f` is 0 iff `f` is 0. -/
@[to_additive]
lemma lintegral_eq_zero_of_is_mul_left_invariant [regular μ]
  (h2μ : is_mul_left_invariant μ) (h3μ : μ ≠ 0) {f : G → ℝ≥0∞} (hf : continuous f) :
  ∫⁻ x, f x ∂μ = 0 ↔ f = 0 :=
begin
  split, swap, { rintro rfl, simp_rw [pi.zero_apply, lintegral_zero] },
  intro h, contrapose h,
  simp_rw [funext_iff, not_forall, pi.zero_apply] at h, cases h with x hx,
  obtain ⟨r, h1r, h2r⟩ : ∃ r : ℝ≥0∞, 0 < r ∧ r < f x :=
  exists_between (pos_iff_ne_zero.mpr hx),
  have h3r := hf.is_open_preimage (Ioi r) is_open_Ioi,
  let s := Ioi r,
  rw [← ne.def, ← pos_iff_ne_zero],
  have : 0 < r * μ (f ⁻¹' Ioi r),
  { have : (f ⁻¹' Ioi r).nonempty, from ⟨x, h2r⟩,
    simpa [h1r.ne', h2μ.measure_pos_iff_nonempty h3μ h3r, h1r] },
  refine this.trans_le _,
  rw [← set_lintegral_const, ← lintegral_indicator _ h3r.measurable_set],
  apply lintegral_mono,
  refine indicator_le (λ y, le_of_lt),
end

end group

section integration

variables [measurable_space G] [topological_space G] [borel_space G] {μ : measure G}
variables [group G] [has_continuous_mul G]
open measure

/-- Translating a function by left-multiplication does not change its `lintegral` with respect to
a left-invariant measure. -/
@[to_additive]
lemma lintegral_mul_left_eq_self (hμ : is_mul_left_invariant μ) (f : G → ℝ≥0∞) (g : G) :
  ∫⁻ x, f (g * x) ∂μ = ∫⁻ x, f x ∂μ :=
begin
  have : measure.map (has_mul.mul g) μ = μ,
  { rw ← map_mul_left_eq_self at hμ,
    exact hμ g },
  convert (lintegral_map_equiv f (homeomorph.mul_left g).to_measurable_equiv).symm,
  simp [this]
end

/-- Translating a function by right-multiplication does not change its `lintegral` with respect to
a right-invariant measure. -/
@[to_additive]
lemma lintegral_mul_right_eq_self (hμ : is_mul_right_invariant μ) (f : G → ℝ≥0∞) (g : G) :
  ∫⁻ x, f (x * g) ∂μ = ∫⁻ x, f x ∂μ :=
begin
  have : measure.map (λ g', g' * g) μ = μ,
  { rw ← map_mul_right_eq_self at hμ,
    exact hμ g },
  convert (lintegral_map_equiv f (homeomorph.mul_right g).to_measurable_equiv).symm,
  simp [this]
end

end integration

section haar
namespace measure

/-- A measure on a group is a Haar measure if it is left-invariant, and gives finite mass to compact
sets and positive mass to open sets. -/
class is_haar_measure {G : Type*} [group G] [topological_space G] [measurable_space G]
  (μ : measure G) : Prop :=
(left_invariant : is_mul_left_invariant μ)
(compact_lt_top : ∀ (K : set G), is_compact K → μ K < ∞)
(open_pos : ∀ (U : set G), is_open U → U.nonempty → 0 < μ U)

/-- A measure on an additive group is an additive Haar measure if it is left-invariant, and gives
finite mass to compact sets and positive mass to open sets. -/
class is_add_haar_measure {G : Type*} [add_group G] [topological_space G] [measurable_space G]
  (μ : measure G) : Prop :=
(add_left_invariant : is_add_left_invariant μ)
(compact_lt_top : ∀ (K : set G), is_compact K → μ K < ∞)
(open_pos : ∀ (U : set G), is_open U → U.nonempty → 0 < μ U)

attribute [to_additive] is_haar_measure

section

variables [group G] [measurable_space G] [topological_space G] (μ : measure G) [is_haar_measure μ]

@[to_additive]
lemma _root_.is_compact.haar_lt_top {K : set G} (hK : is_compact K) :
  μ K < ∞ :=
is_haar_measure.compact_lt_top K hK

@[to_additive]
lemma _root_.is_open.haar_pos {U : set G} (hU : is_open U) (h'U : U.nonempty) :
  0 < μ U :=
is_haar_measure.open_pos U hU h'U

@[to_additive]
lemma haar_pos_of_nonempty_interior {U : set G} (hU : (interior U).nonempty) : 0 < μ U :=
lt_of_lt_of_le (is_open_interior.haar_pos μ hU) (measure_mono (interior_subset))

@[to_additive]
lemma is_mul_left_invariant_haar : is_mul_left_invariant μ :=
is_haar_measure.left_invariant

@[simp, to_additive]
lemma haar_preimage_mul [topological_group G] [borel_space G] (g : G) (A : set G) :
  μ ((λ h, g * h) ⁻¹' A) = μ A :=
(is_mul_left_invariant_haar μ).measure_preimage_mul _ _

@[simp, to_additive]
lemma haar_singleton [topological_group G] [borel_space G] (g : G) :
  μ {g} = μ {(1 : G)} :=
begin
  convert haar_preimage_mul μ (g⁻¹) _,
  simp only [mul_one, preimage_mul_left_singleton, inv_inv],
end

@[simp, to_additive]
lemma haar_preimage_mul_right {G : Type*}
  [comm_group G] [measurable_space G] [topological_space G] (μ : measure G) [is_haar_measure μ]
  [topological_group G] [borel_space G] (g : G) (A : set G) :
  μ ((λ h, h * g) ⁻¹' A) = μ A :=
by simp_rw [mul_comm, haar_preimage_mul μ g A]

@[to_additive measure_theory.measure.is_add_haar_measure.smul]
lemma is_haar_measure.smul {c : ℝ≥0∞} (cpos : c ≠ 0) (ctop : c ≠ ∞) :
  is_haar_measure (c • μ) :=
{ left_invariant := (is_mul_left_invariant_haar μ).smul _,
  compact_lt_top := λ K hK, begin
    change c * μ K < ∞,
    simp [lt_top_iff_ne_top, (hK.haar_lt_top μ).ne, cpos, ctop],
  end,
  open_pos := λ U U_open U_ne, bot_lt_iff_ne_bot.2 $ begin
    change c * μ U ≠ 0,
    simp [cpos, (_root_.is_open.haar_pos μ U_open U_ne).ne'],
  end }

/-- If a left-invariant measure gives positive mass to some compact set with nonempty interior, then
it is a Haar measure -/
@[to_additive]
lemma is_haar_measure_of_is_compact_nonempty_interior [topological_group G] [borel_space G]
  (μ : measure G) (hμ : is_mul_left_invariant μ)
  (K : set G) (hK : is_compact K) (h'K : (interior K).nonempty) (h : μ K ≠ 0) (h' : μ K ≠ ∞) :
  is_haar_measure μ :=
{ left_invariant := hμ,
  compact_lt_top := λ L hL, hμ.measure_lt_top_of_is_compact' _ h'K h' hL,
  open_pos := λ U hU, hμ.measure_pos_of_is_open K hK h hU }

/-- The image of a Haar measure under a group homomorphism which is also a homeomorphism is again
a Haar measure. -/
@[to_additive]
lemma is_haar_measure_map [borel_space G] [topological_group G] {H : Type*} [group H]
  [topological_space H] [measurable_space H] [borel_space H] [t2_space H] [topological_group H]
  (f : G ≃* H) (hf : continuous f) (hfsymm : continuous f.symm) :
  is_haar_measure (measure.map f μ) :=
{ left_invariant := begin
    rw ← map_mul_left_eq_self,
    assume h,
    rw map_map (continuous_mul_left h).measurable hf.measurable,
    conv_rhs { rw ← map_mul_left_eq_self.2 (is_mul_left_invariant_haar μ) (f.symm h) },
    rw map_map hf.measurable (continuous_mul_left _).measurable,
    congr' 2,
    ext y,
    simp only [mul_equiv.apply_symm_apply, comp_app, mul_equiv.map_mul],
  end,
  compact_lt_top := begin
    assume K hK,
    rw map_apply hf.measurable hK.measurable_set,
    have : f.symm '' K = f ⁻¹' K := equiv.image_eq_preimage _ _,
    rw ← this,
    exact is_compact.haar_lt_top _ (hK.image hfsymm)
  end,
  open_pos := begin
    assume U hU h'U,
    rw map_apply hf.measurable hU.measurable_set,
    refine (hU.preimage hf).haar_pos _ _,
    have : f.symm '' U = f ⁻¹' U := equiv.image_eq_preimage _ _,
    rw ← this,
    simp [h'U],
  end }

/-- A Haar measure on a sigma-compact space is sigma-finite. -/
@[priority 100, to_additive] -- see Note [lower instance priority]
instance is_haar_measure.sigma_finite
  {G : Type*} [group G] [measurable_space G] [topological_space G] [sigma_compact_space G]
  (μ : measure G) [μ.is_haar_measure] :
  sigma_finite μ :=
⟨⟨{ set := compact_covering G,
  set_mem := λ n, mem_univ _,
  finite := λ n, is_compact.haar_lt_top μ $ is_compact_compact_covering G n,
  spanning := Union_compact_covering G }⟩⟩

open_locale topological_space
open filter

/-- If the neutral element of a group is not isolated, then a Haar measure on this group has
no atom.

This applies in particular to show that an additive Haar measure on a nontrivial
finite-dimensional real vector space has no atom. -/
@[priority 100, to_additive]
instance is_haar_measure.has_no_atoms
  {G : Type*} [group G] [measurable_space G] [topological_space G] [t1_space G]
  [topological_group G] [locally_compact_space G] [borel_space G] [(𝓝[{(1 : G)}ᶜ] (1 : G)).ne_bot]
  (μ : measure G) [μ.is_haar_measure] :
  has_no_atoms μ :=
begin
  suffices H : μ {(1 : G)} ≤ 0, by { constructor, simp [le_bot_iff.1 H] },
  obtain ⟨K, K_compact, K_int⟩ : ∃ (K : set G), is_compact K ∧ (1 : G) ∈ interior K,
  { rcases exists_compact_subset is_open_univ (mem_univ (1 : G)) with ⟨K, hK⟩,
    exact ⟨K, hK.1, hK.2.1⟩ },
  have K_inf : set.infinite K := infinite_of_mem_nhds (1 : G) (mem_interior_iff_mem_nhds.1 K_int),
  have μKlt : μ K ≠ ∞ := (K_compact.haar_lt_top μ).ne,
  have I : ∀ (n : ℕ), μ {(1 : G)} ≤ μ K / n,
  { assume n,
    obtain ⟨t, tK, tn⟩ : ∃ (t : finset G), ↑t ⊆ K ∧ t.card = n := K_inf.exists_subset_card_eq n,
    have A : μ t ≤ μ K := measure_mono tK,
    have B : μ t = n * μ {(1 : G)},
    { rw ← bUnion_of_singleton ↑t,
      change μ (⋃ (x ∈ t), {x}) = n * μ {1},
      rw @measure_bUnion_finset G G _ μ t (λ i, {i}),
      { simp only [tn, finset.sum_const, nsmul_eq_mul, haar_singleton] },
      { assume x hx y hy xy,
        simp only [on_fun, xy.symm, mem_singleton_iff, not_false_iff, disjoint_singleton_right] },
      { assume b hb, exact measurable_set_singleton b } },
    rw B at A,
    rwa [ennreal.le_div_iff_mul_le _ (or.inr μKlt), mul_comm],
    right,
    apply ne_of_gt (haar_pos_of_nonempty_interior μ ⟨_, K_int⟩) },
  have J : tendsto (λ (n : ℕ),  μ K / n) at_top (𝓝 (μ K / ∞)) :=
    ennreal.tendsto.const_div ennreal.tendsto_nat_nhds_top (or.inr μKlt),
  simp only [ennreal.div_top] at J,
  exact ge_of_tendsto' J I,
end

/- The above instance applies in particular to show that an additive Haar measure on a nontrivial
finite-dimensional real vector space has no atom. -/
example {E : Type*} [normed_group E] [normed_space ℝ E] [nontrivial E] [finite_dimensional ℝ E]
  [measurable_space E] [borel_space E] (μ : measure E) [is_add_haar_measure μ] :
  has_no_atoms μ := by apply_instance

end

end measure
end haar

end measure_theory


import tactic.interactive

def X := [1,2,3]
def g (n : ℕ) := [n, 7*n]

def Z : list ℕ :=
do x ← X,
   y ← g x,
   return y

#eval Z
-- set_option pp.notation false
#print Z
-- https://github.com/leanprover-community/mathlib/blob/master/docs/extras/tactic_writing.md

def h (n : ℕ) := if 2 ∣ n then some (n/2) else none

def Y (n : ℕ) :=
do n ← h n,
   n ← h n,
   n ← h n,
   return n

#eval Y 24
#eval Y 12

def monad_list : monad list := by apply_instance
#print monad_list
#print list.monad

def option_monad : monad option :=
{ pure := @option.some, bind := λ α β o f, match o with | none := none | some a := f a end, map := λ α β f o, match o with | none := none | some a := some (f a) end}

example : is_lawful_monad option :=
{pure_bind := begin intros, refl, end,
 bind_assoc := begin intros, cases x,
 refl,
 refl, end}

def Z' : list ℕ :=
do x ← X,
   y ← g x,
   guard (3 ∣ y),
   return y

#eval Z'

/-
A monad is just a monoid object in the monoidal category
of natural endomorphisms of a functor.

To a computer scientist, all functors are functors from Type to Type.
α → list α is a functor. So is option
-/

/-
A functor from C to D, takes objects of C to objects of D,
and arrows in C to arrows in D, respecting all the structure
(sources, targets, identities, compositions).

A natural transformation from a function `F : C ⥤ D` to another `G : C ⥤ D`,
compares the values of `F` and `G`. That is, for each object `X : C`,
it gives an arrow (in `D`) from `F.obj X` to `G.obj X`.

It satisfies a compatibility condition: for every arrow in `C`, `f : X ⟶ Y`.
Then the two arrows F X  → F Y → G Y and F X → G X → G Y are equal:

* GL_n is a functor from rings to groups under matrix multiplication. det is a
natural transformation from GL_n to GL_1, as factors Ring ⥤ Grp.

A monad is a functor `T` from Type to Type, along with natural transformations
`η : 1 ⟶ T` and `μ : TT ⟶ T`.
i.e. for each Type α, the component of η at α is a function from α → T α (`pure`).
i.e. for each Type α, the component of μ at α is a function from T T α → T α.
-/

def state_ (σ : Type) (α : Type) := σ → σ × α

instance (σ : Type) : monad (state_ σ) :=
{pure := λ α a s, (s, a),
 bind := λ α β f k s,
 begin have p := f s, clear s f, have q := k p.2, clear k, exact q p.1, end}

#print tactic
meta def tactic_monad : monad tactic := by apply_instance
#print tactic_monad

#print interaction_monad.monad

open tactic
meta def swap' : tactic unit :=
do gs ← get_goals,
   match gs with
    | (a :: b :: rem) := set_goals (b :: a :: rem)
    | _ := skip
   end

meta def swap'' : tactic unit :=
do a :: b :: t ← get_goals | fail "There must be at least two goals!",
   set_goals (b :: a :: t)

example : true :=
begin
    success_if_fail {swap''},
    trivial,
end

example : true ∧ 1=1 :=
begin
    split,
    swap'',
    refl,
    trivial,
end

meta def swap''' : tactic unit :=
do a :: b :: t ← get_goals | fail "There must be at least two goals!",
   set_goals [b,a]

example : true ∧ true ∧ 1 = 2 :=
begin
    (do result >>= trace),
    split; [skip, split],
    (do result >>= trace),
    swap''',
    (do result >>= trace),
    trivial,
    (do result >>= trace),
    trivial,
    (do result >>= trace),
    -- :-) .... :-(
    recover,
    sorry,
end

meta def show_locals : tactic unit :=
do ctx ← local_context,
   trace ctx,
   ctx.mmap infer_type >>= trace,
   skip

meta def target' : tactic expr :=
do gs ← get_goals,
   match gs with
    | [] := fail "No tactics left!"
    | (h :: rem) := infer_type h
end

meta def try_0_on_all_goals : tactic unit :=
`[all_goals {try {exact 0}}]

#check unify
meta def try_0_on_all_goals' : tactic unit :=
do gs ← get_goals,
   z ← to_expr ``(0 : ℕ),
   trace gs,
   gs.mmap' (λ g, try_core $ unify g z),
   trace gs,
   skip

set_option pp.instantiate_mvars false
def bar : ℕ × ℕ × list ℤ :=
begin
    split; [skip, split],
    try_0_on_all_goals',
    (do result >>= trace),
end