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

! This file was ported from Lean 3 source module measure_theory.group.measure
! leanprover-community/mathlib commit 950605e4b9b4e2827681f637ba997307814a5ca9
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Dynamics.Ergodic.MeasurePreserving
import Mathbin.MeasureTheory.Measure.Regular
import Mathbin.MeasureTheory.Group.MeasurableEquiv
import Mathbin.MeasureTheory.Measure.OpenPos
import Mathbin.MeasureTheory.Group.Action
import Mathbin.MeasureTheory.Constructions.Prod
import Mathbin.Topology.ContinuousFunction.CocompactMap

/-!
# Measures on Groups

We develop some properties of measures on (topological) groups

* We define properties on measures: measures that are left or right invariant w.r.t. multiplication.
* 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 section

open NNReal ENNReal Pointwise BigOperators Topology

open Inv Set Function MeasureTheory.Measure Filter

variable {𝕜 G H : Type _} [MeasurableSpace G] [MeasurableSpace H]

namespace MeasureTheory

namespace Measure

/-- A measure `μ` on a measurable additive group is left invariant
  if the measure of left translations of a set are equal to the measure of the set itself. -/
class IsAddLeftInvariant [Add G] (μ : Measure G) : Prop where
  map_add_left_eq_self : ∀ g : G, map ((· + ·) g) μ = μ
#align measure_theory.measure.is_add_left_invariant MeasureTheory.Measure.IsAddLeftInvariant

/-- A measure `μ` on a measurable group is left invariant
  if the measure of left translations of a set are equal to the measure of the set itself. -/
@[to_additive]
class IsMulLeftInvariant [Mul G] (μ : Measure G) : Prop where
  map_mul_left_eq_self : ∀ g : G, map ((· * ·) g) μ = μ
#align measure_theory.measure.is_mul_left_invariant MeasureTheory.Measure.IsMulLeftInvariant
#align measure_theory.measure.is_add_left_invariant MeasureTheory.Measure.IsAddLeftInvariant

/-- A measure `μ` on a measurable additive group is right invariant
  if the measure of right translations of a set are equal to the measure of the set itself. -/
class IsAddRightInvariant [Add G] (μ : Measure G) : Prop where
  map_add_right_eq_self : ∀ g : G, map (· + g) μ = μ
#align measure_theory.measure.is_add_right_invariant MeasureTheory.Measure.IsAddRightInvariant

/-- A measure `μ` on a measurable group is right invariant
  if the measure of right translations of a set are equal to the measure of the set itself. -/
@[to_additive]
class IsMulRightInvariant [Mul G] (μ : Measure G) : Prop where
  map_mul_right_eq_self : ∀ g : G, map (· * g) μ = μ
#align measure_theory.measure.is_mul_right_invariant MeasureTheory.Measure.IsMulRightInvariant
#align measure_theory.measure.is_add_right_invariant MeasureTheory.Measure.IsAddRightInvariant

end Measure

open Measure

section Mul

variable [Mul G] {μ : Measure G}

@[to_additive]
theorem map_mul_left_eq_self (μ : Measure G) [IsMulLeftInvariant μ] (g : G) :
    map ((· * ·) g) μ = μ :=
  IsMulLeftInvariant.map_mul_left_eq_self g
#align measure_theory.map_mul_left_eq_self MeasureTheory.map_mul_left_eq_self
#align measure_theory.map_add_left_eq_self MeasureTheory.map_add_left_eq_self

@[to_additive]
theorem map_mul_right_eq_self (μ : Measure G) [IsMulRightInvariant μ] (g : G) : map (· * g) μ = μ :=
  IsMulRightInvariant.map_mul_right_eq_self g
#align measure_theory.map_mul_right_eq_self MeasureTheory.map_mul_right_eq_self
#align measure_theory.map_add_right_eq_self MeasureTheory.map_add_right_eq_self

@[to_additive MeasureTheory.is_add_left_invariant_smul]
instance isMulLeftInvariantSmul [IsMulLeftInvariant μ] (c : ℝ≥0∞) : IsMulLeftInvariant (c • μ) :=
  ⟨fun g => by rw [measure.map_smul, map_mul_left_eq_self]⟩
#align measure_theory.is_mul_left_invariant_smul MeasureTheory.isMulLeftInvariantSmul
#align measure_theory.is_add_left_invariant_smul MeasureTheory.is_add_left_invariant_smul

@[to_additive MeasureTheory.is_add_right_invariant_smul]
instance isMulRightInvariantSmul [IsMulRightInvariant μ] (c : ℝ≥0∞) : IsMulRightInvariant (c • μ) :=
  ⟨fun g => by rw [measure.map_smul, map_mul_right_eq_self]⟩
#align measure_theory.is_mul_right_invariant_smul MeasureTheory.isMulRightInvariantSmul
#align measure_theory.is_add_right_invariant_smul MeasureTheory.is_add_right_invariant_smul

@[to_additive MeasureTheory.is_add_left_invariant_smul_nnreal]
instance isMulLeftInvariantSmulNnreal [IsMulLeftInvariant μ] (c : ℝ≥0) :
    IsMulLeftInvariant (c • μ) :=
  MeasureTheory.isMulLeftInvariantSmul (c : ℝ≥0∞)
#align measure_theory.is_mul_left_invariant_smul_nnreal MeasureTheory.isMulLeftInvariantSmulNnreal
#align measure_theory.is_add_left_invariant_smul_nnreal MeasureTheory.is_add_left_invariant_smul_nnreal

@[to_additive MeasureTheory.is_add_right_invariant_smul_nnreal]
instance isMulRightInvariantSmulNnreal [IsMulRightInvariant μ] (c : ℝ≥0) :
    IsMulRightInvariant (c • μ) :=
  MeasureTheory.isMulRightInvariantSmul (c : ℝ≥0∞)
#align measure_theory.is_mul_right_invariant_smul_nnreal MeasureTheory.isMulRightInvariantSmulNnreal
#align measure_theory.is_add_right_invariant_smul_nnreal MeasureTheory.is_add_right_invariant_smul_nnreal

section HasMeasurableMul

variable [HasMeasurableMul G]

@[to_additive]
theorem measurePreservingMulLeft (μ : Measure G) [IsMulLeftInvariant μ] (g : G) :
    MeasurePreserving ((· * ·) g) μ μ :=
  ⟨measurable_const_mul g, map_mul_left_eq_self μ g⟩
#align measure_theory.measure_preserving_mul_left MeasureTheory.measurePreservingMulLeft
#align measure_theory.measure_preserving_add_left MeasureTheory.measure_preserving_add_left

@[to_additive]
theorem MeasurePreserving.mulLeft (μ : Measure G) [IsMulLeftInvariant μ] (g : G) {X : Type _}
    [MeasurableSpace X] {μ' : Measure X} {f : X → G} (hf : MeasurePreserving f μ' μ) :
    MeasurePreserving (fun x => g * f x) μ' μ :=
  (measurePreservingMulLeft μ g).comp hf
#align measure_theory.measure_preserving.mul_left MeasureTheory.MeasurePreserving.mulLeft
#align measure_theory.measure_preserving.add_left MeasureTheory.MeasurePreserving.add_left

@[to_additive]
theorem measurePreservingMulRight (μ : Measure G) [IsMulRightInvariant μ] (g : G) :
    MeasurePreserving (· * g) μ μ :=
  ⟨measurable_mul_const g, map_mul_right_eq_self μ g⟩
#align measure_theory.measure_preserving_mul_right MeasureTheory.measurePreservingMulRight
#align measure_theory.measure_preserving_add_right MeasureTheory.measure_preserving_add_right

@[to_additive]
theorem MeasurePreserving.mulRight (μ : Measure G) [IsMulRightInvariant μ] (g : G) {X : Type _}
    [MeasurableSpace X] {μ' : Measure X} {f : X → G} (hf : MeasurePreserving f μ' μ) :
    MeasurePreserving (fun x => f x * g) μ' μ :=
  (measurePreservingMulRight μ g).comp hf
#align measure_theory.measure_preserving.mul_right MeasureTheory.MeasurePreserving.mulRight
#align measure_theory.measure_preserving.add_right MeasureTheory.MeasurePreserving.add_right

@[to_additive]
instance IsMulLeftInvariant.smulInvariantMeasure [IsMulLeftInvariant μ] :
    SmulInvariantMeasure G G μ :=
  ⟨fun x s hs => (measurePreservingMulLeft μ x).measure_preimage hs⟩
#align measure_theory.is_mul_left_invariant.smul_invariant_measure MeasureTheory.IsMulLeftInvariant.smulInvariantMeasure
#align measure_theory.is_mul_left_invariant.vadd_invariant_measure MeasureTheory.IsMulLeftInvariant.vadd_invariant_measure

@[to_additive]
instance IsMulRightInvariant.toSmulInvariantMeasureOp [μ.IsMulRightInvariant] :
    SmulInvariantMeasure Gᵐᵒᵖ G μ :=
  ⟨fun x s hs => (measurePreservingMulRight μ (MulOpposite.unop x)).measure_preimage hs⟩
#align measure_theory.is_mul_right_invariant.to_smul_invariant_measure_op MeasureTheory.IsMulRightInvariant.toSmulInvariantMeasureOp
#align measure_theory.is_mul_right_invariant.to_vadd_invariant_measure_op MeasureTheory.IsMulRightInvariant.to_vadd_invariant_measure_op

@[to_additive]
instance Subgroup.smulInvariantMeasure {G α : Type _} [Group G] [MulAction G α] [MeasurableSpace α]
    {μ : Measure α} [SmulInvariantMeasure G α μ] (H : Subgroup G) : SmulInvariantMeasure H α μ :=
  ⟨fun y s hs => by convert smul_invariant_measure.measure_preimage_smul μ (y : G) hs⟩
#align measure_theory.subgroup.smul_invariant_measure MeasureTheory.Subgroup.smulInvariantMeasure
#align measure_theory.subgroup.vadd_invariant_measure MeasureTheory.Subgroup.vadd_invariant_measure

/-- An alternative way to prove that `μ` is left invariant under multiplication. -/
@[to_additive " An alternative way to prove that `μ` is left invariant under addition. "]
theorem forall_measure_preimage_mul_iff (μ : Measure G) :
    (∀ (g : G) (A : Set G), MeasurableSet A → μ ((fun h => g * h) ⁻¹' A) = μ A) ↔
      IsMulLeftInvariant μ :=
  by
  trans ∀ g, map ((· * ·) g) μ = μ
  · simp_rw [measure.ext_iff]
    refine' forall_congr' fun g => forall_congr' fun A => forall_congr' fun hA => _
    rw [map_apply (measurable_const_mul g) hA]
  exact ⟨fun h => ⟨h⟩, fun h => h.1⟩
#align measure_theory.forall_measure_preimage_mul_iff MeasureTheory.forall_measure_preimage_mul_iff
#align measure_theory.forall_measure_preimage_add_iff MeasureTheory.forall_measure_preimage_add_iff

/-- An alternative way to prove that `μ` is right invariant under multiplication. -/
@[to_additive " An alternative way to prove that `μ` is right invariant under addition. "]
theorem forall_measure_preimage_mul_right_iff (μ : Measure G) :
    (∀ (g : G) (A : Set G), MeasurableSet A → μ ((fun h => h * g) ⁻¹' A) = μ A) ↔
      IsMulRightInvariant μ :=
  by
  trans ∀ g, map (· * g) μ = μ
  · simp_rw [measure.ext_iff]
    refine' forall_congr' fun g => forall_congr' fun A => forall_congr' fun hA => _
    rw [map_apply (measurable_mul_const g) hA]
  exact ⟨fun h => ⟨h⟩, fun h => h.1⟩
#align measure_theory.forall_measure_preimage_mul_right_iff MeasureTheory.forall_measure_preimage_mul_right_iff
#align measure_theory.forall_measure_preimage_add_right_iff MeasureTheory.forall_measure_preimage_add_right_iff

@[to_additive]
instance [IsMulLeftInvariant μ] [SigmaFinite μ] {H : Type _} [Mul H] {mH : MeasurableSpace H}
    {ν : Measure H} [HasMeasurableMul H] [IsMulLeftInvariant ν] [SigmaFinite ν] :
    IsMulLeftInvariant (μ.Prod ν) := by
  constructor
  rintro ⟨g, h⟩
  change map (Prod.map ((· * ·) g) ((· * ·) h)) (μ.prod ν) = μ.prod ν
  rw [← map_prod_map _ _ (measurable_const_mul g) (measurable_const_mul h),
    map_mul_left_eq_self μ g, map_mul_left_eq_self ν h]
  · rw [map_mul_left_eq_self μ g]
    infer_instance
  · rw [map_mul_left_eq_self ν h]
    infer_instance

@[to_additive]
instance [IsMulRightInvariant μ] [SigmaFinite μ] {H : Type _} [Mul H] {mH : MeasurableSpace H}
    {ν : Measure H} [HasMeasurableMul H] [IsMulRightInvariant ν] [SigmaFinite ν] :
    IsMulRightInvariant (μ.Prod ν) := by
  constructor
  rintro ⟨g, h⟩
  change map (Prod.map (· * g) (· * h)) (μ.prod ν) = μ.prod ν
  rw [← map_prod_map _ _ (measurable_mul_const g) (measurable_mul_const h),
    map_mul_right_eq_self μ g, map_mul_right_eq_self ν h]
  · rw [map_mul_right_eq_self μ g]
    infer_instance
  · rw [map_mul_right_eq_self ν h]
    infer_instance

@[to_additive]
theorem isMulLeftInvariantMap {H : Type _} [MeasurableSpace H] [Mul H] [HasMeasurableMul H]
    [IsMulLeftInvariant μ] (f : G →ₙ* H) (hf : Measurable f) (h_surj : Surjective f) :
    IsMulLeftInvariant (Measure.map f μ) :=
  by
  refine' ⟨fun h => _⟩
  rw [map_map (measurable_const_mul _) hf]
  obtain ⟨g, rfl⟩ := h_surj h
  conv_rhs => rw [← map_mul_left_eq_self μ g]
  rw [map_map hf (measurable_const_mul _)]
  congr 2
  ext y
  simp only [comp_app, map_mul]
#align measure_theory.is_mul_left_invariant_map MeasureTheory.isMulLeftInvariantMap
#align measure_theory.is_add_left_invariant_map MeasureTheory.is_add_left_invariant_map

end HasMeasurableMul

end Mul

section DivInvMonoid

variable [DivInvMonoid G]

@[to_additive]
theorem map_div_right_eq_self (μ : Measure G) [IsMulRightInvariant μ] (g : G) : map (· / g) μ = μ :=
  by simp_rw [div_eq_mul_inv, map_mul_right_eq_self μ g⁻¹]
#align measure_theory.map_div_right_eq_self MeasureTheory.map_div_right_eq_self
#align measure_theory.map_sub_right_eq_self MeasureTheory.map_sub_right_eq_self

end DivInvMonoid

section Group

variable [Group G] [HasMeasurableMul G]

@[to_additive]
theorem measurePreservingDivRight (μ : Measure G) [IsMulRightInvariant μ] (g : G) :
    MeasurePreserving (· / g) μ μ := by simp_rw [div_eq_mul_inv, measure_preserving_mul_right μ g⁻¹]
#align measure_theory.measure_preserving_div_right MeasureTheory.measurePreservingDivRight
#align measure_theory.measure_preserving_sub_right MeasureTheory.measure_preserving_sub_right

/-- We shorten this from `measure_preimage_mul_left`, since left invariant is the preferred option
  for measures in this formalization. -/
@[simp,
  to_additive
      "We shorten this from `measure_preimage_add_left`, since left invariant is the\npreferred option for measures in this formalization."]
theorem measure_preimage_mul (μ : Measure G) [IsMulLeftInvariant μ] (g : G) (A : Set G) :
    μ ((fun h => g * h) ⁻¹' A) = μ A :=
  calc
    μ ((fun h => g * h) ⁻¹' A) = map (fun h => g * h) μ A :=
      ((MeasurableEquiv.mulLeft g).map_apply A).symm
    _ = μ A := by rw [map_mul_left_eq_self μ g]

#align measure_theory.measure_preimage_mul MeasureTheory.measure_preimage_mul
#align measure_theory.measure_preimage_add MeasureTheory.measure_preimage_add

@[simp, to_additive]
theorem measure_preimage_mul_right (μ : Measure G) [IsMulRightInvariant μ] (g : G) (A : Set G) :
    μ ((fun h => h * g) ⁻¹' A) = μ A :=
  calc
    μ ((fun h => h * g) ⁻¹' A) = map (fun h => h * g) μ A :=
      ((MeasurableEquiv.mulRight g).map_apply A).symm
    _ = μ A := by rw [map_mul_right_eq_self μ g]

#align measure_theory.measure_preimage_mul_right MeasureTheory.measure_preimage_mul_right
#align measure_theory.measure_preimage_add_right MeasureTheory.measure_preimage_add_right

@[to_additive]
theorem map_mul_left_ae (μ : Measure G) [IsMulLeftInvariant μ] (x : G) :
    Filter.map (fun h => x * h) μ.ae = μ.ae :=
  ((MeasurableEquiv.mulLeft x).map_ae μ).trans <| congr_arg ae <| map_mul_left_eq_self μ x
#align measure_theory.map_mul_left_ae MeasureTheory.map_mul_left_ae
#align measure_theory.map_add_left_ae MeasureTheory.map_add_left_ae

@[to_additive]
theorem map_mul_right_ae (μ : Measure G) [IsMulRightInvariant μ] (x : G) :
    Filter.map (fun h => h * x) μ.ae = μ.ae :=
  ((MeasurableEquiv.mulRight x).map_ae μ).trans <| congr_arg ae <| map_mul_right_eq_self μ x
#align measure_theory.map_mul_right_ae MeasureTheory.map_mul_right_ae
#align measure_theory.map_add_right_ae MeasureTheory.map_add_right_ae

@[to_additive]
theorem map_div_right_ae (μ : Measure G) [IsMulRightInvariant μ] (x : G) :
    Filter.map (fun t => t / x) μ.ae = μ.ae :=
  ((MeasurableEquiv.divRight x).map_ae μ).trans <| congr_arg ae <| map_div_right_eq_self μ x
#align measure_theory.map_div_right_ae MeasureTheory.map_div_right_ae
#align measure_theory.map_sub_right_ae MeasureTheory.map_sub_right_ae

@[to_additive]
theorem eventually_mul_left_iff (μ : Measure G) [IsMulLeftInvariant μ] (t : G) {p : G → Prop} :
    (∀ᵐ x ∂μ, p (t * x)) ↔ ∀ᵐ x ∂μ, p x :=
  by
  conv_rhs => rw [Filter.Eventually, ← map_mul_left_ae μ t]
  rfl
#align measure_theory.eventually_mul_left_iff MeasureTheory.eventually_mul_left_iff
#align measure_theory.eventually_add_left_iff MeasureTheory.eventually_add_left_iff

@[to_additive]
theorem eventually_mul_right_iff (μ : Measure G) [IsMulRightInvariant μ] (t : G) {p : G → Prop} :
    (∀ᵐ x ∂μ, p (x * t)) ↔ ∀ᵐ x ∂μ, p x :=
  by
  conv_rhs => rw [Filter.Eventually, ← map_mul_right_ae μ t]
  rfl
#align measure_theory.eventually_mul_right_iff MeasureTheory.eventually_mul_right_iff
#align measure_theory.eventually_add_right_iff MeasureTheory.eventually_add_right_iff

@[to_additive]
theorem eventually_div_right_iff (μ : Measure G) [IsMulRightInvariant μ] (t : G) {p : G → Prop} :
    (∀ᵐ x ∂μ, p (x / t)) ↔ ∀ᵐ x ∂μ, p x :=
  by
  conv_rhs => rw [Filter.Eventually, ← map_div_right_ae μ t]
  rfl
#align measure_theory.eventually_div_right_iff MeasureTheory.eventually_div_right_iff
#align measure_theory.eventually_sub_right_iff MeasureTheory.eventually_sub_right_iff

end Group

namespace Measure

/-- 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 [Inv G] (μ : Measure G) : Measure G :=
  Measure.map inv μ
#align measure_theory.measure.inv MeasureTheory.Measure.inv
#align measure_theory.measure.neg MeasureTheory.Measure.neg

/-- A measure is invariant under negation if `- μ = μ`. Equivalently, this means that for all
measurable `A` we have `μ (- A) = μ A`, where `- A` is the pointwise negation of `A`. -/
class IsNegInvariant [Neg G] (μ : Measure G) : Prop where
  neg_eq_self : μ.neg = μ
#align measure_theory.measure.is_neg_invariant MeasureTheory.Measure.IsNegInvariant

/-- A measure is invariant under inversion if `μ⁻¹ = μ`. Equivalently, this means that for all
measurable `A` we have `μ (A⁻¹) = μ A`, where `A⁻¹` is the pointwise inverse of `A`. -/
@[to_additive]
class IsInvInvariant [Inv G] (μ : Measure G) : Prop where
  inv_eq_self : μ.inv = μ
#align measure_theory.measure.is_inv_invariant MeasureTheory.Measure.IsInvInvariant
#align measure_theory.measure.is_neg_invariant MeasureTheory.Measure.IsNegInvariant

section Inv

variable [Inv G]

@[simp, to_additive]
theorem inv_eq_self (μ : Measure G) [IsInvInvariant μ] : μ.inv = μ :=
  IsInvInvariant.inv_eq_self
#align measure_theory.measure.inv_eq_self MeasureTheory.Measure.inv_eq_self
#align measure_theory.measure.neg_eq_self MeasureTheory.Measure.neg_eq_self

@[simp, to_additive]
theorem map_inv_eq_self (μ : Measure G) [IsInvInvariant μ] : map Inv.inv μ = μ :=
  IsInvInvariant.inv_eq_self
#align measure_theory.measure.map_inv_eq_self MeasureTheory.Measure.map_inv_eq_self
#align measure_theory.measure.map_neg_eq_self MeasureTheory.Measure.map_neg_eq_self

variable [HasMeasurableInv G]

@[to_additive]
theorem measurePreservingInv (μ : Measure G) [IsInvInvariant μ] : MeasurePreserving Inv.inv μ μ :=
  ⟨measurable_inv, map_inv_eq_self μ⟩
#align measure_theory.measure.measure_preserving_inv MeasureTheory.Measure.measurePreservingInv
#align measure_theory.measure.measure_preserving_neg MeasureTheory.Measure.measure_preserving_neg

end Inv

section InvolutiveInv

variable [InvolutiveInv G] [HasMeasurableInv G]

@[simp, to_additive]
theorem inv_apply (μ : Measure G) (s : Set G) : μ.inv s = μ s⁻¹ :=
  (MeasurableEquiv.inv G).map_apply s
#align measure_theory.measure.inv_apply MeasureTheory.Measure.inv_apply
#align measure_theory.measure.neg_apply MeasureTheory.Measure.neg_apply

@[simp, to_additive]
protected theorem inv_inv (μ : Measure G) : μ.inv.inv = μ :=
  (MeasurableEquiv.inv G).map_symm_map
#align measure_theory.measure.inv_inv MeasureTheory.Measure.inv_inv
#align measure_theory.measure.neg_neg MeasureTheory.Measure.neg_neg

@[simp, to_additive]
theorem measure_inv (μ : Measure G) [IsInvInvariant μ] (A : Set G) : μ A⁻¹ = μ A := by
  rw [← inv_apply, inv_eq_self]
#align measure_theory.measure.measure_inv MeasureTheory.Measure.measure_inv
#align measure_theory.measure.measure_neg MeasureTheory.Measure.measure_neg

@[to_additive]
theorem measure_preimage_inv (μ : Measure G) [IsInvInvariant μ] (A : Set G) :
    μ (Inv.inv ⁻¹' A) = μ A :=
  μ.measure_inv A
#align measure_theory.measure.measure_preimage_inv MeasureTheory.Measure.measure_preimage_inv
#align measure_theory.measure.measure_preimage_neg MeasureTheory.Measure.measure_preimage_neg

@[to_additive]
instance (μ : Measure G) [SigmaFinite μ] : SigmaFinite μ.inv :=
  (MeasurableEquiv.inv G).sigmaFiniteMap ‹_›

end InvolutiveInv

section DivisionMonoid

variable [DivisionMonoid G] [HasMeasurableMul G] [HasMeasurableInv G] {μ : Measure G}

@[to_additive]
instance [IsMulLeftInvariant μ] : IsMulRightInvariant μ.inv :=
  by
  constructor
  intro g
  conv_rhs => rw [← map_mul_left_eq_self μ g⁻¹]
  simp_rw [measure.inv, map_map (measurable_mul_const g) measurable_inv,
    map_map measurable_inv (measurable_const_mul g⁻¹), Function.comp, mul_inv_rev, inv_inv]

@[to_additive]
instance [IsMulRightInvariant μ] : IsMulLeftInvariant μ.inv :=
  by
  constructor
  intro g
  conv_rhs => rw [← map_mul_right_eq_self μ g⁻¹]
  simp_rw [measure.inv, map_map (measurable_const_mul g) measurable_inv,
    map_map measurable_inv (measurable_mul_const g⁻¹), Function.comp, mul_inv_rev, inv_inv]

@[to_additive]
theorem measurePreservingDivLeft (μ : Measure G) [IsInvInvariant μ] [IsMulLeftInvariant μ] (g : G) :
    MeasurePreserving (fun t => g / t) μ μ :=
  by
  simp_rw [div_eq_mul_inv]
  exact (measure_preserving_mul_left μ g).comp (measure_preserving_inv μ)
#align measure_theory.measure.measure_preserving_div_left MeasureTheory.Measure.measurePreservingDivLeft
#align measure_theory.measure.measure_preserving_sub_left MeasureTheory.Measure.measure_preserving_sub_left

@[to_additive]
theorem map_div_left_eq_self (μ : Measure G) [IsInvInvariant μ] [IsMulLeftInvariant μ] (g : G) :
    map (fun t => g / t) μ = μ :=
  (measurePreservingDivLeft μ g).map_eq
#align measure_theory.measure.map_div_left_eq_self MeasureTheory.Measure.map_div_left_eq_self
#align measure_theory.measure.map_sub_left_eq_self MeasureTheory.Measure.map_sub_left_eq_self

@[to_additive]
theorem measurePreservingMulRightInv (μ : Measure G) [IsInvInvariant μ] [IsMulLeftInvariant μ]
    (g : G) : MeasurePreserving (fun t => (g * t)⁻¹) μ μ :=
  (measurePreservingInv μ).comp <| measurePreservingMulLeft μ g
#align measure_theory.measure.measure_preserving_mul_right_inv MeasureTheory.Measure.measurePreservingMulRightInv
#align measure_theory.measure.measure_preserving_add_right_neg MeasureTheory.Measure.measure_preserving_add_right_neg

@[to_additive]
theorem map_mul_right_inv_eq_self (μ : Measure G) [IsInvInvariant μ] [IsMulLeftInvariant μ]
    (g : G) : map (fun t => (g * t)⁻¹) μ = μ :=
  (measurePreservingMulRightInv μ g).map_eq
#align measure_theory.measure.map_mul_right_inv_eq_self MeasureTheory.Measure.map_mul_right_inv_eq_self
#align measure_theory.measure.map_add_right_neg_eq_self MeasureTheory.Measure.map_add_right_neg_eq_self

end DivisionMonoid

section Group

variable [Group G] [HasMeasurableMul G] [HasMeasurableInv G] {μ : Measure G}

@[to_additive]
theorem map_div_left_ae (μ : Measure G) [IsMulLeftInvariant μ] [IsInvInvariant μ] (x : G) :
    Filter.map (fun t => x / t) μ.ae = μ.ae :=
  ((MeasurableEquiv.divLeft x).map_ae μ).trans <| congr_arg ae <| map_div_left_eq_self μ x
#align measure_theory.measure.map_div_left_ae MeasureTheory.Measure.map_div_left_ae
#align measure_theory.measure.map_sub_left_ae MeasureTheory.Measure.map_sub_left_ae

end Group

end Measure

section TopologicalGroup

variable [TopologicalSpace G] [BorelSpace G] {μ : Measure G} [Group G]

@[to_additive]
instance Measure.Regular.inv [ContinuousInv G] [T2Space G] [Regular μ] : Regular μ.inv :=
  Regular.map (Homeomorph.inv G)
#align measure_theory.measure.regular.inv MeasureTheory.Measure.Regular.inv
#align measure_theory.measure.regular.neg MeasureTheory.Measure.Regular.neg

variable [TopologicalGroup G]

@[to_additive]
theorem regular_inv_iff [T2Space G] : μ.inv.regular ↔ μ.regular :=
  by
  constructor
  · intro h
    rw [← μ.inv_inv]
    exact measure.regular.inv
  · intro h
    exact measure.regular.inv
#align measure_theory.regular_inv_iff MeasureTheory.regular_inv_iff
#align measure_theory.regular_neg_iff MeasureTheory.regular_neg_iff

variable [IsMulLeftInvariant μ]

/-- If a left-invariant measure gives positive mass to a compact set, then it gives positive mass to
any open set. -/
@[to_additive
      "If a left-invariant measure gives positive mass to a compact set, then it gives\npositive mass to any open set."]
theorem isOpenPosMeasureOfMulLeftInvariantOfCompact (K : Set G) (hK : IsCompact K) (h : μ K ≠ 0) :
    IsOpenPosMeasure μ := by
  refine' ⟨fun U hU hne => _⟩
  contrapose! h
  rw [← nonpos_iff_eq_zero]
  rw [← hU.interior_eq] at hne
  obtain ⟨t, hKt⟩ : ∃ t : Finset G, K ⊆ ⋃ (g : G) (H : g ∈ t), (fun h : G => g * h) ⁻¹' U :=
    compact_covered_by_mul_left_translates hK hne
  calc
    μ K ≤ μ (⋃ (g : G) (H : g ∈ t), (fun h : G => g * h) ⁻¹' U) := measure_mono hKt
    _ ≤ ∑ g in t, μ ((fun h : G => g * h) ⁻¹' U) := (measure_bUnion_finset_le _ _)
    _ = 0 := by simp [measure_preimage_mul, h]

#align measure_theory.is_open_pos_measure_of_mul_left_invariant_of_compact MeasureTheory.isOpenPosMeasureOfMulLeftInvariantOfCompact
#align measure_theory.is_open_pos_measure_of_add_left_invariant_of_compact MeasureTheory.is_open_pos_measure_of_add_left_invariant_of_compact

/-- A nonzero left-invariant regular measure gives positive mass to any open set. -/
@[to_additive "A nonzero left-invariant regular measure gives positive mass to any open set."]
theorem isOpenPosMeasureOfMulLeftInvariantOfRegular [Regular μ] (h₀ : μ ≠ 0) : IsOpenPosMeasure μ :=
  let ⟨K, hK, h2K⟩ := Regular.exists_compact_not_null.mpr h₀
  isOpenPosMeasureOfMulLeftInvariantOfCompact K hK h2K
#align measure_theory.is_open_pos_measure_of_mul_left_invariant_of_regular MeasureTheory.isOpenPosMeasureOfMulLeftInvariantOfRegular
#align measure_theory.is_open_pos_measure_of_add_left_invariant_of_regular MeasureTheory.is_open_pos_measure_of_add_left_invariant_of_regular

@[to_additive]
theorem null_iff_of_isMulLeftInvariant [Regular μ] {s : Set G} (hs : IsOpen s) :
    μ s = 0 ↔ s = ∅ ∨ μ = 0 := by
  by_cases h3μ : μ = 0; · simp [h3μ]
  · haveI := is_open_pos_measure_of_mul_left_invariant_of_regular h3μ
    simp only [h3μ, or_false_iff, hs.measure_eq_zero_iff μ]
#align measure_theory.null_iff_of_is_mul_left_invariant MeasureTheory.null_iff_of_isMulLeftInvariant
#align measure_theory.null_iff_of_is_add_left_invariant MeasureTheory.null_iff_of_is_add_left_invariant

@[to_additive]
theorem measure_ne_zero_iff_nonempty_of_isMulLeftInvariant [Regular μ] (hμ : μ ≠ 0) {s : Set G}
    (hs : IsOpen s) : μ s ≠ 0 ↔ s.Nonempty := by
  simpa [null_iff_of_is_mul_left_invariant hs, hμ] using nonempty_iff_ne_empty.symm
#align measure_theory.measure_ne_zero_iff_nonempty_of_is_mul_left_invariant MeasureTheory.measure_ne_zero_iff_nonempty_of_isMulLeftInvariant
#align measure_theory.measure_ne_zero_iff_nonempty_of_is_add_left_invariant MeasureTheory.measure_ne_zero_iff_nonempty_of_is_add_left_invariant

@[to_additive]
theorem measure_pos_iff_nonempty_of_isMulLeftInvariant [Regular μ] (h3μ : μ ≠ 0) {s : Set G}
    (hs : IsOpen s) : 0 < μ s ↔ s.Nonempty :=
  pos_iff_ne_zero.trans <| measure_ne_zero_iff_nonempty_of_isMulLeftInvariant h3μ hs
#align measure_theory.measure_pos_iff_nonempty_of_is_mul_left_invariant MeasureTheory.measure_pos_iff_nonempty_of_isMulLeftInvariant
#align measure_theory.measure_pos_iff_nonempty_of_is_add_left_invariant MeasureTheory.measure_pos_iff_nonempty_of_is_add_left_invariant

/-- If a left-invariant measure gives finite mass to a nonempty open set, then it gives finite mass
to any compact set. -/
@[to_additive
      "If a left-invariant measure gives finite mass to a nonempty open set, then it gives\nfinite mass to any compact set."]
theorem measure_lt_top_of_isCompact_of_isMulLeftInvariant (U : Set G) (hU : IsOpen U)
    (h'U : U.Nonempty) (h : μ U ≠ ∞) {K : Set G} (hK : IsCompact K) : μ K < ∞ :=
  by
  rw [← hU.interior_eq] at h'U
  obtain ⟨t, hKt⟩ : ∃ t : Finset G, K ⊆ ⋃ (g : G) (H : g ∈ t), (fun h : G => g * h) ⁻¹' U :=
    compact_covered_by_mul_left_translates hK h'U
  calc
    μ K ≤ μ (⋃ (g : G) (H : g ∈ t), (fun h : G => g * h) ⁻¹' U) := measure_mono hKt
    _ ≤ ∑ g in t, μ ((fun h : G => g * h) ⁻¹' U) := (measure_bUnion_finset_le _ _)
    _ = Finset.card t * μ U := by simp only [measure_preimage_mul, Finset.sum_const, nsmul_eq_mul]
    _ < ∞ := ENNReal.mul_lt_top (ENNReal.nat_ne_top _) h

#align measure_theory.measure_lt_top_of_is_compact_of_is_mul_left_invariant MeasureTheory.measure_lt_top_of_isCompact_of_isMulLeftInvariant
#align measure_theory.measure_lt_top_of_is_compact_of_is_add_left_invariant MeasureTheory.measure_lt_top_of_is_compact_of_is_add_left_invariant

/-- 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
      "If a left-invariant measure gives finite mass to a set with nonempty interior, then\nit gives finite mass to any compact set."]
theorem measure_lt_top_of_isCompact_of_is_mul_left_invariant' {U : Set G}
    (hU : (interior U).Nonempty) (h : μ U ≠ ∞) {K : Set G} (hK : IsCompact K) : μ K < ∞ :=
  measure_lt_top_of_isCompact_of_isMulLeftInvariant (interior U) isOpen_interior hU
    ((measure_mono interior_subset).trans_lt (lt_top_iff_ne_top.2 h)).Ne hK
#align measure_theory.measure_lt_top_of_is_compact_of_is_mul_left_invariant' MeasureTheory.measure_lt_top_of_isCompact_of_is_mul_left_invariant'
#align measure_theory.measure_lt_top_of_is_compact_of_is_add_left_invariant' MeasureTheory.measure_lt_top_of_is_compact_of_is_add_left_invariant'

/-- In a noncompact locally compact group, a left-invariant measure which is positive
on open sets has infinite mass. -/
@[simp,
  to_additive
      "In a noncompact locally compact additive group, a left-invariant measure which\nis positive on open sets has infinite mass."]
theorem measure_univ_of_isMulLeftInvariant [LocallyCompactSpace G] [NoncompactSpace G]
    (μ : Measure G) [IsOpenPosMeasure μ] [μ.IsMulLeftInvariant] : μ univ = ∞ :=
  by
  /- Consider a closed compact set `K` with nonempty interior. For any compact set `L`, one may
    find `g = g (L)` such that `L` is disjoint from `g • K`. Iterating this, one finds
    infinitely many translates of `K` which are disjoint from each other. As they all have the
    same positive mass, it follows that the space has infinite measure. -/
  obtain ⟨K, hK, Kclosed, Kint⟩ : ∃ K : Set G, IsCompact K ∧ IsClosed K ∧ (1 : G) ∈ interior K :=
    by
    rcases local_isCompact_isClosed_nhds_of_group (is_open_univ.mem_nhds (mem_univ (1 : G))) with
      ⟨K, hK⟩
    exact ⟨K, hK.1, hK.2.1, hK.2.2.2⟩
  have K_pos : 0 < μ K := measure_pos_of_nonempty_interior _ ⟨_, Kint⟩
  have A : ∀ L : Set G, IsCompact L → ∃ g : G, Disjoint L (g • K) := fun L hL =>
    exists_disjoint_smul_of_isCompact hL hK
  choose! g hg using A
  set L : ℕ → Set G := fun n => ((fun T => T ∪ g T • K)^[n]) K with hL
  have Lcompact : ∀ n, IsCompact (L n) := by
    intro n
    induction' n with n IH
    · exact hK
    · simp_rw [hL, iterate_succ']
      apply IsCompact.union IH (hK.smul (g (L n)))
  have Lclosed : ∀ n, IsClosed (L n) := by
    intro n
    induction' n with n IH
    · exact Kclosed
    · simp_rw [hL, iterate_succ']
      apply IsClosed.union IH (Kclosed.smul (g (L n)))
  have M : ∀ n, μ (L n) = (n + 1 : ℕ) * μ K := by
    intro n
    induction' n with n IH
    · simp only [L, one_mul, algebraMap.coe_one, iterate_zero, id.def]
    ·
      calc
        μ (L (n + 1)) = μ (L n) + μ (g (L n) • K) :=
          by
          simp_rw [hL, iterate_succ']
          exact measure_union' (hg _ (Lcompact _)) (Lclosed _).MeasurableSet
        _ = (n + 1 + 1 : ℕ) * μ K := by
          simp only [IH, measure_smul, add_mul, Nat.cast_add, algebraMap.coe_one, one_mul]

  have N : tendsto (fun n => μ (L n)) at_top (𝓝 (∞ * μ K)) :=
    by
    simp_rw [M]
    apply ENNReal.Tendsto.mul_const _ (Or.inl ENNReal.top_ne_zero)
    exact ennreal.tendsto_nat_nhds_top.comp (tendsto_add_at_top_nat _)
  simp only [ENNReal.top_mul', K_pos.ne', if_false] at N
  apply top_le_iff.1
  exact le_of_tendsto' N fun n => measure_mono (subset_univ _)
#align measure_theory.measure_univ_of_is_mul_left_invariant MeasureTheory.measure_univ_of_isMulLeftInvariant
#align measure_theory.measure_univ_of_is_add_left_invariant MeasureTheory.measure_univ_of_is_add_left_invariant

end TopologicalGroup

section CommSemigroup

variable [CommSemigroup G]

/-- In an abelian group every left invariant measure is also right-invariant.
  We don't declare the converse as an instance, since that would loop type-class inference, and
  we use `is_mul_left_invariant` as the default hypothesis in abelian groups. -/
@[to_additive IsAddLeftInvariant.is_add_right_invariant
      "In an abelian additive\ngroup every left invariant measure is also right-invariant. We don't declare the converse as an\ninstance, since that would loop type-class inference, and we use `is_add_left_invariant` as the\ndefault hypothesis in abelian groups."]
instance (priority := 100) IsMulLeftInvariant.isMulRightInvariant {μ : Measure G}
    [IsMulLeftInvariant μ] : IsMulRightInvariant μ :=
  ⟨fun g => by simp_rw [mul_comm, map_mul_left_eq_self]⟩
#align measure_theory.is_mul_left_invariant.is_mul_right_invariant MeasureTheory.IsMulLeftInvariant.isMulRightInvariant
#align is_add_left_invariant.is_add_right_invariant IsAddLeftInvariant.is_add_right_invariant

end CommSemigroup

section Haar

namespace Measure

/-- 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 IsAddHaarMeasure {G : Type _} [AddGroup G] [TopologicalSpace G] [MeasurableSpace G]
  (μ : Measure G) extends IsFiniteMeasureOnCompacts μ, IsAddLeftInvariant μ, IsOpenPosMeasure μ :
  Prop
#align measure_theory.measure.is_add_haar_measure MeasureTheory.Measure.IsAddHaarMeasure

/-- 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. -/
@[to_additive]
class IsHaarMeasure {G : Type _} [Group G] [TopologicalSpace G] [MeasurableSpace G]
  (μ : Measure G) extends IsFiniteMeasureOnCompacts μ, IsMulLeftInvariant μ, IsOpenPosMeasure μ :
  Prop
#align measure_theory.measure.is_haar_measure MeasureTheory.Measure.IsHaarMeasure
#align measure_theory.measure.is_add_haar_measure MeasureTheory.Measure.IsAddHaarMeasure

/-- Record that a Haar measure on a locally compact space is locally finite. This is needed as the
fact that a measure which is finite on compacts is locally finite is not registered as an instance,
to avoid an instance loop.

See Note [lower instance priority]. -/
@[to_additive
      "Record that an additive Haar measure on a locally compact space is\nlocally finite. This is needed as the fact that a measure which is finite on compacts is locally\nfinite is not registered as an instance, to avoid an instance loop.\n\nSee Note [lower instance priority]"]
instance (priority := 100) isLocallyFiniteMeasureOfIsHaarMeasure {G : Type _} [Group G]
    [MeasurableSpace G] [TopologicalSpace G] [LocallyCompactSpace G] (μ : Measure G)
    [IsHaarMeasure μ] : IsLocallyFiniteMeasure μ :=
  isLocallyFiniteMeasureOfIsFiniteMeasureOnCompacts
#align measure_theory.measure.is_locally_finite_measure_of_is_haar_measure MeasureTheory.Measure.isLocallyFiniteMeasureOfIsHaarMeasure
#align measure_theory.measure.is_locally_finite_measure_of_is_add_haar_measure MeasureTheory.Measure.is_locally_finite_measure_of_is_add_haar_measure

section

variable [Group G] [TopologicalSpace G] (μ : Measure G) [IsHaarMeasure μ]

@[simp, to_additive]
theorem haar_singleton [TopologicalGroup G] [BorelSpace G] (g : G) : μ {g} = μ {(1 : G)} :=
  by
  convert measure_preimage_mul μ g⁻¹ _
  simp only [mul_one, preimage_mul_left_singleton, inv_inv]
#align measure_theory.measure.haar_singleton MeasureTheory.Measure.haar_singleton
#align measure_theory.measure.add_haar_singleton MeasureTheory.Measure.add_haar_singleton

@[to_additive MeasureTheory.Measure.IsAddHaarMeasure.smul]
theorem IsHaarMeasure.smul {c : ℝ≥0∞} (cpos : c ≠ 0) (ctop : c ≠ ∞) : IsHaarMeasure (c • μ) :=
  { lt_top_of_isCompact := fun K hK => ENNReal.mul_lt_top Ctop hK.measure_lt_top.Ne
    toIsOpenPosMeasure := isOpenPosMeasureSmul μ cpos }
#align measure_theory.measure.is_haar_measure.smul MeasureTheory.Measure.IsHaarMeasure.smul
#align measure_theory.measure.is_add_haar_measure.smul MeasureTheory.Measure.IsAddHaarMeasure.smul

/-- If a left-invariant measure gives positive mass to some compact set with nonempty interior, then
it is a Haar measure. -/
@[to_additive
      "If a left-invariant measure gives positive mass to some compact set with nonempty\ninterior, then it is an additive Haar measure."]
theorem isHaarMeasureOfIsCompactNonemptyInterior [TopologicalGroup G] [BorelSpace G] (μ : Measure G)
    [IsMulLeftInvariant μ] (K : Set G) (hK : IsCompact K) (h'K : (interior K).Nonempty)
    (h : μ K ≠ 0) (h' : μ K ≠ ∞) : IsHaarMeasure μ :=
  { lt_top_of_isCompact := fun L hL =>
      measure_lt_top_of_isCompact_of_is_mul_left_invariant' h'K h' hL
    toIsOpenPosMeasure := isOpenPosMeasureOfMulLeftInvariantOfCompact K hK h }
#align measure_theory.measure.is_haar_measure_of_is_compact_nonempty_interior MeasureTheory.Measure.isHaarMeasureOfIsCompactNonemptyInterior
#align measure_theory.measure.is_add_haar_measure_of_is_compact_nonempty_interior MeasureTheory.Measure.is_add_haar_measure_of_is_compact_nonempty_interior

/-- The image of a Haar measure under a continuous surjective proper group homomorphism is again
a Haar measure. See also `mul_equiv.is_haar_measure_map`. -/
@[to_additive
      "The image of an additive Haar measure under a continuous surjective proper additive\ngroup homomorphism is again an additive Haar measure. See also\n`add_equiv.is_add_haar_measure_map`."]
theorem isHaarMeasureMap [BorelSpace G] [TopologicalGroup G] {H : Type _} [Group H]
    [TopologicalSpace H] [MeasurableSpace H] [BorelSpace H] [T2Space H] [TopologicalGroup H]
    (f : G →* H) (hf : Continuous f) (h_surj : Surjective f)
    (h_prop : Tendsto f (cocompact G) (cocompact H)) : IsHaarMeasure (Measure.map f μ) :=
  { toIsMulLeftInvariant := isMulLeftInvariantMap f.toMulHom hf.Measurable h_surj
    lt_top_of_isCompact := by
      intro K hK
      rw [map_apply hf.measurable hK.measurable_set]
      exact IsCompact.measure_lt_top ((⟨⟨f, hf⟩, h_prop⟩ : CocompactMap G H).isCompact_preimage hK)
    toIsOpenPosMeasure := hf.isOpenPosMeasureMap h_surj }
#align measure_theory.measure.is_haar_measure_map MeasureTheory.Measure.isHaarMeasureMap
#align measure_theory.measure.is_add_haar_measure_map MeasureTheory.Measure.is_add_haar_measure_map

/-- A convenience wrapper for `measure_theory.measure.is_haar_measure_map`. -/
@[to_additive "A convenience wrapper for `measure_theory.measure.is_add_haar_measure_map`."]
theorem MulEquiv.isHaarMeasureMap [BorelSpace G] [TopologicalGroup G] {H : Type _} [Group H]
    [TopologicalSpace H] [MeasurableSpace H] [BorelSpace H] [T2Space H] [TopologicalGroup H]
    (e : G ≃* H) (he : Continuous e) (hesymm : Continuous e.symm) :
    IsHaarMeasure (Measure.map e μ) :=
  isHaarMeasureMap μ (e : G →* H) he e.Surjective
    ({ e with } : G ≃ₜ H).toCocompactMap.cocompact_tendsto'
#align mul_equiv.is_haar_measure_map MulEquiv.isHaarMeasureMap
#align add_equiv.is_add_haar_measure_map AddEquiv.is_add_haar_measure_map

/-- A Haar measure on a σ-compact space is σ-finite.

See Note [lower instance priority] -/
@[to_additive
      "A Haar measure on a σ-compact space is σ-finite.\n\nSee Note [lower instance priority]"]
instance (priority := 100) IsHaarMeasure.sigmaFinite [SigmaCompactSpace G] : SigmaFinite μ :=
  ⟨⟨{   Set := compactCovering G
        set_mem := fun n => mem_univ _
        Finite := fun n => IsCompact.measure_lt_top <| isCompact_compactCovering G n
        spanning := unionᵢ_compactCovering G }⟩⟩
#align measure_theory.measure.is_haar_measure.sigma_finite MeasureTheory.Measure.IsHaarMeasure.sigmaFinite
#align measure_theory.measure.is_add_haar_measure.sigma_finite MeasureTheory.Measure.IsAddHaarMeasure.sigma_finite

@[to_additive]
instance {G : Type _} [Group G] [TopologicalSpace G] {mG : MeasurableSpace G} {H : Type _} [Group H]
    [TopologicalSpace H] {mH : MeasurableSpace H} (μ : Measure G) (ν : Measure H) [IsHaarMeasure μ]
    [IsHaarMeasure ν] [SigmaFinite μ] [SigmaFinite ν] [HasMeasurableMul G] [HasMeasurableMul H] :
    IsHaarMeasure (μ.Prod ν) where

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

The additive version of this instance applies in particular to show that an additive Haar measure on
a nontrivial finite-dimensional real vector space has no atom. -/
@[to_additive
      "If the zero element of an additive group is not isolated, then an\nadditive Haar measure on this group has no atoms.\n\nThis applies in particular to show that an additive Haar measure on a nontrivial finite-dimensional\nreal vector space has no atom."]
instance (priority := 100) IsHaarMeasure.hasNoAtoms [TopologicalGroup G] [BorelSpace G] [T1Space G]
    [LocallyCompactSpace G] [(𝓝[≠] (1 : G)).ne_bot] (μ : Measure G) [μ.IsHaarMeasure] :
    HasNoAtoms μ := by
  suffices H : μ {(1 : G)} ≤ 0
  · constructor
    simp [le_bot_iff.1 H]
  obtain ⟨K, K_compact, K_int⟩ : ∃ K : Set G, IsCompact K ∧ (1 : G) ∈ interior K :=
    by
    rcases exists_compact_subset isOpen_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.measure_lt_top.ne
  have I : ∀ n : ℕ, μ {(1 : G)} ≤ μ K / n := by
    intro 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)} :=
      by
      rw [← bUnion_of_singleton ↑t]
      change μ (⋃ x ∈ t, {x}) = n * μ {1}
      rw [@measure_bUnion_finset G G _ μ t fun i => {i}]
      · simp only [tn, Finset.sum_const, nsmul_eq_mul, haar_singleton]
      · intro x hx y hy xy
        simp only [on_fun, xy.symm, mem_singleton_iff, not_false_iff, disjoint_singleton_right]
      · intro 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 (measure_pos_of_nonempty_interior μ ⟨_, K_int⟩).ne'
  have J : tendsto (fun 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
#align measure_theory.measure.is_haar_measure.has_no_atoms MeasureTheory.Measure.IsHaarMeasure.hasNoAtoms
#align measure_theory.measure.is_add_haar_measure.has_no_atoms MeasureTheory.Measure.IsAddHaarMeasure.has_no_atoms

/- 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 _} [NormedAddCommGroup E] [NormedSpace ℝ E] [Nontrivial E] [FiniteDimensional ℝ E]
    [MeasurableSpace E] [BorelSpace E] (μ : Measure E) [IsAddHaarMeasure μ] : HasNoAtoms μ := by
  infer_instance

end

variable [NontriviallyNormedField 𝕜] [TopologicalSpace G] [TopologicalSpace H] [AddCommGroup G]
  [AddCommGroup H] [TopologicalAddGroup G] [TopologicalAddGroup H] [Module 𝕜 G] [Module 𝕜 H]
  (μ : Measure G) [IsAddHaarMeasure μ] [BorelSpace G] [BorelSpace H] [T2Space H]

instance MapContinuousLinearEquiv.isAddHaarMeasure (e : G ≃L[𝕜] H) : IsAddHaarMeasure (μ.map e) :=
  e.toAddEquiv.is_add_haar_measure_map _ e.Continuous e.symm.Continuous
#align measure_theory.measure.map_continuous_linear_equiv.is_add_haar_measure MeasureTheory.Measure.MapContinuousLinearEquiv.isAddHaarMeasure

variable [CompleteSpace 𝕜] [T2Space G] [FiniteDimensional 𝕜 G] [ContinuousSMul 𝕜 G]
  [ContinuousSMul 𝕜 H]

instance MapLinearEquiv.isAddHaarMeasure (e : G ≃ₗ[𝕜] H) : IsAddHaarMeasure (μ.map e) :=
  MapContinuousLinearEquiv.isAddHaarMeasure _ e.toContinuousLinearEquiv
#align measure_theory.measure.map_linear_equiv.is_add_haar_measure MeasureTheory.Measure.MapLinearEquiv.isAddHaarMeasure

end Measure

end Haar

end MeasureTheory


variable U : Type
variables P Q R : U → Prop

example (P1 : forall x,(R x -> Q x))
        (P2 : exists x,(P x /\ R x)) :
        exists x, (P x /\ Q x) :=

obtain (y:U)(H1 : (P y /\ R y)), from P2,
have H2 : (R y -> Q y), from P1 y,

show exists x,(P x /\ Q x), from exists.intro y (
    and.intro (and.left H1) (H2 (and.right H1))
).


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Riccardo Brasca, Johan Commelin

! This file was ported from Lean 3 source module field_theory.minpoly.field
! leanprover-community/mathlib commit cbdf7b565832144d024caa5a550117c6df0204a5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Polynomial.FieldDivision
import Mathbin.FieldTheory.Minpoly.Basic
import Mathbin.RingTheory.Algebraic

/-!
# Minimal polynomials on an algebra over a field

This file specializes the theory of minpoly to the setting of field extensions
and derives some well-known properties, amongst which the fact that minimal polynomials
are irreducible, and uniquely determined by their defining property.

-/

open Classical Polynomial

open Polynomial Set Function minpoly

namespace minpoly

variable {A B : Type _}

variable (A) [Field A]

section Ring

variable [Ring B] [Algebra A B] (x : B)

/-- If an element `x` is a root of a nonzero polynomial `p`, then the degree of `p` is at least the
degree of the minimal polynomial of `x`. See also `gcd_domain_degree_le_of_ne_zero` which relaxes
the assumptions on `A` in exchange for stronger assumptions on `B`. -/
theorem degree_le_of_ne_zero {p : A[X]} (pnz : p ≠ 0) (hp : Polynomial.aeval x p = 0) :
    degree (minpoly A x) ≤ degree p :=
  calc
    degree (minpoly A x) ≤ degree (p * C (leadingCoeff p)⁻¹) :=
      min A x (monic_mul_leadingCoeff_inv pnz) (by simp [hp])
    _ = degree p := degree_mul_leadingCoeff_inv p pnz

#align minpoly.degree_le_of_ne_zero minpoly.degree_le_of_ne_zero

theorem ne_zero_of_finite_field_extension (e : B) [FiniteDimensional A B] : minpoly A e ≠ 0 :=
  minpoly.ne_zero <| isIntegral_of_noetherian (IsNoetherian.iff_fg.2 inferInstance) _
#align minpoly.ne_zero_of_finite_field_extension minpoly.ne_zero_of_finite_field_extension

/-- The minimal polynomial of an element `x` is uniquely characterized by its defining property:
if there is another monic polynomial of minimal degree that has `x` as a root, then this polynomial
is equal to the minimal polynomial of `x`. See also `minpoly.gcd_unique` which relaxes the
assumptions on `A` in exchange for stronger assumptions on `B`. -/
theorem unique {p : A[X]} (pmonic : p.Monic) (hp : Polynomial.aeval x p = 0)
    (pmin : ∀ q : A[X], q.Monic → Polynomial.aeval x q = 0 → degree p ≤ degree q) :
    p = minpoly A x := by
  have hx : IsIntegral A x := ⟨p, pmonic, hp⟩
  symm; apply eq_of_sub_eq_zero
  by_contra hnz
  have := degree_le_of_ne_zero A x hnz (by simp [hp])
  contrapose! this
  apply degree_sub_lt _ (NeZero hx)
  · rw [(monic hx).leadingCoeff, pmonic.leading_coeff]
  · exact le_antisymm (min A x pmonic hp) (pmin (minpoly A x) (monic hx) (aeval A x))
#align minpoly.unique minpoly.unique

/-- If an element `x` is a root of a polynomial `p`, then the minimal polynomial of `x` divides `p`.
See also `minpoly.gcd_domain_dvd` which relaxes the assumptions on `A` in exchange for stronger
assumptions on `B`. -/
theorem dvd {p : A[X]} (hp : Polynomial.aeval x p = 0) : minpoly A x ∣ p :=
  by
  by_cases hp0 : p = 0
  · simp only [hp0, dvd_zero]
  have hx : IsIntegral A x := by
    rw [← isAlgebraic_iff_isIntegral]
    exact ⟨p, hp0, hp⟩
  rw [← dvd_iff_mod_by_monic_eq_zero (monic hx)]
  by_contra hnz
  have := degree_le_of_ne_zero A x hnz _
  · contrapose! this
    exact degree_mod_by_monic_lt _ (monic hx)
  · rw [← mod_by_monic_add_div p (monic hx)] at hp
    simpa using hp
#align minpoly.dvd minpoly.dvd

theorem dvd_map_of_isScalarTower (A K : Type _) {R : Type _} [CommRing A] [Field K] [CommRing R]
    [Algebra A K] [Algebra A R] [Algebra K R] [IsScalarTower A K R] (x : R) :
    minpoly K x ∣ (minpoly A x).map (algebraMap A K) :=
  by
  refine' minpoly.dvd K x _
  rw [aeval_map_algebra_map, minpoly.aeval]
#align minpoly.dvd_map_of_is_scalar_tower minpoly.dvd_map_of_isScalarTower

theorem dvd_map_of_is_scalar_tower' (R : Type _) {S : Type _} (K L : Type _) [CommRing R]
    [CommRing S] [Field K] [CommRing L] [Algebra R S] [Algebra R K] [Algebra S L] [Algebra K L]
    [Algebra R L] [IsScalarTower R K L] [IsScalarTower R S L] (s : S) :
    minpoly K (algebraMap S L s) ∣ map (algebraMap R K) (minpoly R s) :=
  by
  apply minpoly.dvd K (algebraMap S L s)
  rw [← map_aeval_eq_aeval_map, minpoly.aeval, map_zero]
  rw [← IsScalarTower.algebraMap_eq, ← IsScalarTower.algebraMap_eq]
#align minpoly.dvd_map_of_is_scalar_tower' minpoly.dvd_map_of_is_scalar_tower'

/-- If `y` is a conjugate of `x` over a field `K`, then it is a conjugate over a subring `R`. -/
theorem aeval_of_isScalarTower (R : Type _) {K T U : Type _} [CommRing R] [Field K] [CommRing T]
    [Algebra R K] [Algebra K T] [Algebra R T] [IsScalarTower R K T] [CommSemiring U] [Algebra K U]
    [Algebra R U] [IsScalarTower R K U] (x : T) (y : U)
    (hy : Polynomial.aeval y (minpoly K x) = 0) : Polynomial.aeval y (minpoly R x) = 0 :=
  aeval_map_algebraMap K y (minpoly R x) ▸
    eval₂_eq_zero_of_dvd_of_eval₂_eq_zero (algebraMap K U) y
      (minpoly.dvd_map_of_isScalarTower R K x) hy
#align minpoly.aeval_of_is_scalar_tower minpoly.aeval_of_isScalarTower

variable {A x}

theorem eq_of_irreducible_of_monic [Nontrivial B] {p : A[X]} (hp1 : Irreducible p)
    (hp2 : Polynomial.aeval x p = 0) (hp3 : p.Monic) : p = minpoly A x :=
  let ⟨q, hq⟩ := dvd A x hp2
  eq_of_monic_of_associated hp3 (monic ⟨p, ⟨hp3, hp2⟩⟩) <|
    mul_one (minpoly A x) ▸ hq.symm ▸ Associated.mul_left _ <|
      associated_one_iff_isUnit.2 <| (hp1.isUnit_or_isUnit hq).resolve_left <| not_isUnit A x
#align minpoly.eq_of_irreducible_of_monic minpoly.eq_of_irreducible_of_monic

theorem eq_of_irreducible [Nontrivial B] {p : A[X]} (hp1 : Irreducible p)
    (hp2 : Polynomial.aeval x p = 0) : p * C p.leadingCoeff⁻¹ = minpoly A x :=
  by
  have : p.leading_coeff ≠ 0 := leading_coeff_ne_zero.mpr hp1.ne_zero
  apply eq_of_irreducible_of_monic
  ·
    exact
      Associated.irreducible
        ⟨⟨C p.leading_coeff⁻¹, C p.leading_coeff, by rwa [← C_mul, inv_mul_cancel, C_1], by
            rwa [← C_mul, mul_inv_cancel, C_1]⟩,
          rfl⟩
        hp1
  · rw [aeval_mul, hp2, MulZeroClass.zero_mul]
  · rwa [Polynomial.Monic, leading_coeff_mul, leading_coeff_C, mul_inv_cancel]
#align minpoly.eq_of_irreducible minpoly.eq_of_irreducible

/-- If `y` is the image of `x` in an extension, their minimal polynomials coincide.

We take `h : y = algebra_map L T x` as an argument because `rw h` typically fails
since `is_integral R y` depends on y.
-/
theorem eq_of_algebraMap_eq {K S T : Type _} [Field K] [CommRing S] [CommRing T] [Algebra K S]
    [Algebra K T] [Algebra S T] [IsScalarTower K S T] (hST : Function.Injective (algebraMap S T))
    {x : S} {y : T} (hx : IsIntegral K x) (h : y = algebraMap S T x) : minpoly K x = minpoly K y :=
  minpoly.unique _ _ (minpoly.monic hx)
    (by rw [h, aeval_algebra_map_apply, minpoly.aeval, RingHom.map_zero]) fun q q_monic root_q =>
    minpoly.min _ _ q_monic
      ((aeval_algebraMap_eq_zero_iff_of_injective hST).mp
        (h ▸ root_q : Polynomial.aeval (algebraMap S T x) q = 0))
#align minpoly.eq_of_algebra_map_eq minpoly.eq_of_algebraMap_eq

theorem add_algebraMap {B : Type _} [CommRing B] [Algebra A B] {x : B} (hx : IsIntegral A x)
    (a : A) : minpoly A (x + algebraMap A B a) = (minpoly A x).comp (X - C a) :=
  by
  refine' (minpoly.unique _ _ ((minpoly.monic hx).comp_X_sub_C _) _ fun q qmo hq => _).symm
  · simp [aeval_comp]
  · have : (Polynomial.aeval x) (q.comp (X + C a)) = 0 := by simpa [aeval_comp] using hq
    have H := minpoly.min A x (qmo.comp_X_add_C _) this
    rw [degree_eq_nat_degree qmo.ne_zero,
      degree_eq_nat_degree ((minpoly.monic hx).comp_X_sub_C _).NeZero, WithBot.coe_le_coe,
      nat_degree_comp, nat_degree_X_sub_C, mul_one]
    rwa [degree_eq_nat_degree (minpoly.ne_zero hx),
      degree_eq_nat_degree (qmo.comp_X_add_C _).NeZero, WithBot.coe_le_coe, nat_degree_comp,
      nat_degree_X_add_C, mul_one] at H
#align minpoly.add_algebra_map minpoly.add_algebraMap

theorem sub_algebraMap {B : Type _} [CommRing B] [Algebra A B] {x : B} (hx : IsIntegral A x)
    (a : A) : minpoly A (x - algebraMap A B a) = (minpoly A x).comp (X + C a) := by
  simpa [sub_eq_add_neg] using add_algebra_map hx (-a)
#align minpoly.sub_algebra_map minpoly.sub_algebraMap

section AlgHomFintype

/-- A technical finiteness result. -/
noncomputable def Fintype.subtypeProd {E : Type _} {X : Set E} (hX : X.Finite) {L : Type _}
    (F : E → Multiset L) : Fintype (∀ x : X, { l : L // l ∈ F x }) :=
  let hX := Finite.fintype hX
  Pi.fintype
#align minpoly.fintype.subtype_prod minpoly.Fintype.subtypeProd

variable (F E K : Type _) [Field F] [Ring E] [CommRing K] [IsDomain K] [Algebra F E] [Algebra F K]
  [FiniteDimensional F E]

-- Marked as `noncomputable!` since this definition takes multiple seconds to compile,
-- and isn't very computable in practice (since neither `finrank` nor `fin_basis` are).
/-- Function from Hom_K(E,L) to pi type Π (x : basis), roots of min poly of x -/
noncomputable def rootsOfMinPolyPiType (φ : E →ₐ[F] K)
    (x : range (FiniteDimensional.finBasis F E : _ → E)) :
    { l : K // l ∈ (((minpoly F x.1).map (algebraMap F K)).roots : Multiset K) } :=
  ⟨φ x, by
    rw [mem_roots_map (minpoly.ne_zero_of_finite_field_extension F x.val), Subtype.val_eq_coe, ←
      aeval_def, aeval_alg_hom_apply, minpoly.aeval, map_zero]⟩
#align minpoly.roots_of_min_poly_pi_type minpoly.rootsOfMinPolyPiType

theorem aux_inj_roots_of_min_poly : Injective (rootsOfMinPolyPiType F E K) :=
  by
  intro f g h
  suffices (f : E →ₗ[F] K) = g by rwa [FunLike.ext'_iff] at this⊢
  rw [funext_iff] at h
  exact
    LinearMap.ext_on (FiniteDimensional.finBasis F E).span_eq fun e he =>
      subtype.ext_iff.mp (h ⟨e, he⟩)
#align minpoly.aux_inj_roots_of_min_poly minpoly.aux_inj_roots_of_min_poly

/-- Given field extensions `E/F` and `K/F`, with `E/F` finite, there are finitely many `F`-algebra
  homomorphisms `E →ₐ[K] K`. -/
noncomputable instance AlgHom.fintype : Fintype (E →ₐ[F] K) :=
  @Fintype.ofInjective _ _
    (Fintype.subtypeProd (finite_range (FiniteDimensional.finBasis F E)) fun e =>
      ((minpoly F e).map (algebraMap F K)).roots)
    _ (aux_inj_roots_of_min_poly F E K)
#align minpoly.alg_hom.fintype minpoly.AlgHom.fintype

end AlgHomFintype

variable (B) [Nontrivial B]

/-- If `B/K` is a nontrivial algebra over a field, and `x` is an element of `K`,
then the minimal polynomial of `algebra_map K B x` is `X - C x`. -/
theorem eq_x_sub_c (a : A) : minpoly A (algebraMap A B a) = X - C a :=
  eq_x_sub_c_of_algebraMap_inj a (algebraMap A B).Injective
#align minpoly.eq_X_sub_C minpoly.eq_x_sub_c

theorem eq_x_sub_C' (a : A) : minpoly A a = X - C a :=
  eq_x_sub_c A a
#align minpoly.eq_X_sub_C' minpoly.eq_x_sub_C'

variable (A)

/-- The minimal polynomial of `0` is `X`. -/
@[simp]
theorem zero : minpoly A (0 : B) = X := by
  simpa only [add_zero, C_0, sub_eq_add_neg, neg_zero, RingHom.map_zero] using eq_X_sub_C B (0 : A)
#align minpoly.zero minpoly.zero

/-- The minimal polynomial of `1` is `X - 1`. -/
@[simp]
theorem one : minpoly A (1 : B) = X - 1 := by
  simpa only [RingHom.map_one, C_1, sub_eq_add_neg] using eq_X_sub_C B (1 : A)
#align minpoly.one minpoly.one

end Ring

section IsDomain

variable [Ring B] [IsDomain B] [Algebra A B]

variable {A} {x : B}

/-- A minimal polynomial is prime. -/
theorem prime (hx : IsIntegral A x) : Prime (minpoly A x) :=
  by
  refine' ⟨NeZero hx, not_is_unit A x, _⟩
  rintro p q ⟨d, h⟩
  have : Polynomial.aeval x (p * q) = 0 := by simp [h, aeval A x]
  replace : Polynomial.aeval x p = 0 ∨ Polynomial.aeval x q = 0 := by simpa
  exact Or.imp (dvd A x) (dvd A x) this
#align minpoly.prime minpoly.prime

/-- If `L/K` is a field extension and an element `y` of `K` is a root of the minimal polynomial
of an element `x ∈ L`, then `y` maps to `x` under the field embedding. -/
theorem root {x : B} (hx : IsIntegral A x) {y : A} (h : IsRoot (minpoly A x) y) :
    algebraMap A B y = x :=
  by
  have key : minpoly A x = X - C y :=
    eq_of_monic_of_associated (monic hx) (monic_X_sub_C y)
      (associated_of_dvd_dvd
        ((irreducible_X_sub_C y).dvd_symm (irreducible hx) (dvd_iff_isRoot.2 h))
        (dvd_iff_isRoot.2 h))
  have := aeval A x
  rwa [key, AlgHom.map_sub, aeval_X, aeval_C, sub_eq_zero, eq_comm] at this
#align minpoly.root minpoly.root

/-- The constant coefficient of the minimal polynomial of `x` is `0` if and only if `x = 0`. -/
@[simp]
theorem coeff_zero_eq_zero (hx : IsIntegral A x) : coeff (minpoly A x) 0 = 0 ↔ x = 0 :=
  by
  constructor
  · intro h
    have zero_root := zero_is_root_of_coeff_zero_eq_zero h
    rw [← root hx zero_root]
    exact RingHom.map_zero _
  · rintro rfl
    simp
#align minpoly.coeff_zero_eq_zero minpoly.coeff_zero_eq_zero

/-- The minimal polynomial of a nonzero element has nonzero constant coefficient. -/
theorem coeff_zero_ne_zero (hx : IsIntegral A x) (h : x ≠ 0) : coeff (minpoly A x) 0 ≠ 0 :=
  by
  contrapose! h
  simpa only [hx, coeff_zero_eq_zero] using h
#align minpoly.coeff_zero_ne_zero minpoly.coeff_zero_ne_zero

end IsDomain

end minpoly


import data.set
import tactic
import ..tactics

/-!
# Pregeometries

This file defines the typeclass `pregeom` of pregeometries.
These are types endowed with a "closure operator" `cl` acting on subsets, satisfying various axioms.
A pregeometry is a geometry provided that the closure of ∅ is ∅ and that the closure of a singleton is itself.

# Implementation Details

Typeclasses:
1. `has_cl` -- a typeclass for the cl operator
2. `pregeom` -- see above
3. `geom` -- see above

# Remarks

See the `geometrize.lean` file for the construction of a geometry from a pregeometry.

-/

set_option default_priority 100

open_locale classical

/-- Typeclass for the `cl` operator -/
class has_cl (T : Type*) := (cl : set T → set T)

/-- Typeclass of `pregeometries` -/
class pregeom (T : Type*) extends has_cl T :=
(inclusive {S} : S ≤ cl S)
(monotone {A B} : A ≤ B → cl A ≤ cl B)
(idempotent {S} : cl (cl S) = cl S)
(exchange {x y S} : x ∈ cl (insert y S) → x ∉ cl S → y ∈ cl (insert x S))
(finchar {x S} : x ∈ cl S → ∃ A : finset T, ↑A ≤ S ∧ x ∈ cl ↑A)

/-- Typeclass for geometries -/
class geometry (T : Type*) extends pregeom T :=
(cl_singleton {x} : cl {x} = {x})
(cl_empty : cl ∅ = ∅)

notation `cl` := has_cl.cl

namespace pregeom

variables {T : Type*}

/-- A set S is closed if there exists some other set A such that `cl A = S` -/
def is_closed [has_cl T] (S : set T) := ∃ A, cl A = S

/-- `cls x` is the closure of the singleton `{x}` -/
def cls [has_cl T] (x : T) := cl ({x} : set T)

lemma mem_cls [pregeom T] {x : T} : x ∈ cls x := inclusive (set.mem_singleton x)

@[simp]
lemma cls_le_iff_mem_cl [pregeom T] {x : T} {S : set T} : cls x ⊆ cl S ↔ x ∈ cl S :=
begin
  split,
  { intro hx,
    apply hx,
    exact mem_cls, },
  { intro hx,
    suffices : cls x ≤ cl (cl S), by rwa idempotent at this,
    apply monotone,
    rintros y ⟨rfl⟩,
    assumption, }
end

@[simp]
lemma Sup_le_eq_cl [pregeom T] {S : set T} : Sup { A | (∃ x, A = cls x) ∧ A ⊆ cl S } = cl S :=
begin
  ext, split,
  { intro hx,
    rcases hx with ⟨A,⟨⟨t,rfl⟩,h⟩,hA⟩,
    exact h hA, },
  { intro hx,
    refine ⟨cls x,⟨⟨x,rfl⟩,_⟩,_⟩,
    { change _ ⊆ _, rw cls_le_iff_mem_cl, exact hx },
    { exact mem_cls }, }
end

lemma exchange_cls [pregeom T] {u v : T} (u_in_cls : u ∈ cls v) (u_regular : u ∉ cl (∅ : set T))  : v ∈ cls u :=
begin
  unfold cls at *,
  rw set.singleton_def at *,
  exact exchange u_in_cls u_regular,
end

lemma mem_cl_iff_cls_le_cl [pregeom T] {x : T} {S : set T} : x ∈ cl S ↔ cls x ≤ cl S :=
begin
  split; intro hx,
  { have : ({x} : set T) ≤ cl S,
    { rintros y ⟨hy⟩,
      assumption, },
    replace this := monotone this,
    rw idempotent at this,
    assumption, },
  { apply hx,
    exact mem_cls, }
end

@[simp]
lemma cl_cl_union_eq_cl_union [pregeom T] {A B : set T} : cl (cl A ∪ B) = cl (A ∪ B) :=
begin
  ext, split; intro h,
  { rw ←idempotent,
    refine monotone _ h,
    intros y hy,
    cases hy,
    { refine monotone _ hy,
      intros a ha,
      left, assumption, },
    { apply inclusive,
      right, assumption, }},
  { refine monotone _ h,
    intros z hz,
    cases hz,
    { left,
      apply inclusive, assumption, },
    { right, assumption, }}
end

lemma cl_union_cl_eq_cl_union [pregeom T] {A B : set T} : cl (A ∪ cl B) = cl (A ∪ B) :=
calc cl (A ∪ cl B) = cl (A ⊔ cl B) : rfl
... = cl (cl B ⊔ A) : by rw sup_comm
... = cl (B ∪ A) : cl_cl_union_eq_cl_union
... = cl (B ⊔ A) : rfl
... = cl (A ⊔ B) : by rw sup_comm

lemma cl_cl_union_cl_eq_cl_union [pregeom T] {A B : set T} : cl (cl A ∪ cl B) = cl (A ∪ B) :=
calc cl (cl A ∪ cl B) = cl (cl A ∪ B) : cl_union_cl_eq_cl_union
... = cl (A ∪ B) : cl_cl_union_eq_cl_union

@[simp]
lemma cl_union_cl_empty [pregeom T] {A : set T} : cl (cl (∅ : set T) ∪ A) = cl A :=
begin
  rw pregeom.cl_cl_union_eq_cl_union,
  rw set.empty_union,
end

lemma cl_union_eq [pregeom T] {A S : set T}: A ≤ cl S → cl (A ∪ S) = cl S :=
begin
  intro hA,
  rw ←cl_union_cl_eq_cl_union,
  suffices : A ∪ cl S = cl S, by rw [this, idempotent],
  tidy, finish,
end

/-- If `As` is a set of sets, `map_cl As` is the set of sets obtained by
    applying `cl` to every memeber of `As`. -/
def map_cl [has_cl T] : set (set T) → set (set T) := set.image cl

lemma le_map_cl [pregeom T] (As : set (set T)) : Sup As ≤ Sup (map_cl As) :=
  λ a ⟨A,hA,ha⟩, ⟨cl A,⟨A,hA,rfl⟩,inclusive ha⟩

lemma cl_le_cl_Sup [pregeom T] {As : set (set T)} {A : set T} : A ∈ As →
  cl A ≤ cl (Sup As) := λ h, monotone (λ x hx, ⟨A,h,hx⟩)

lemma map_cl_le_cl_Sup [pregeom T] (As : set (set T)) : Sup (map_cl As) ≤ cl (Sup As) :=
  λ x ⟨B,⟨C,hC,h⟩,hx⟩, by rw ←h at *; exact cl_le_cl_Sup hC hx

@[simp]
lemma cl_Sup_cl [pregeom T] {As : set (set T)} : cl (Sup (map_cl As)) = cl (Sup As) :=
begin
  ext,
  refine ⟨_,λ h, monotone (le_map_cl _) h⟩,
  intro hx,
  rw ←idempotent,
  refine monotone _ hx,
  apply map_cl_le_cl_Sup,
end

end pregeom


/-
Copyright (c) 2021 Yakov Pechersky. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yakov Pechersky
-/
import algebra.polynomial.big_operators
import data.polynomial.degree.lemmas
import linear_algebra.matrix.determinant

/-!
# Matrices of polynomials and polynomials of matrices

In this file, we prove results about matrices over a polynomial ring.
In particular, we give results about the polynomial given by
`det (t * I + A)`.

## References

  * "The trace Cayley-Hamilton theorem" by Darij Grinberg, Section 5.3

## Tags

matrix determinant, polynomial
-/

open_locale matrix big_operators polynomial

variables {n α : Type*} [decidable_eq n] [fintype n] [comm_ring α]

open polynomial matrix equiv.perm

namespace polynomial

lemma nat_degree_det_X_add_C_le (A B : matrix n n α) :
  nat_degree (det ((X : α[X]) • A.map C + B.map C)) ≤ fintype.card n :=
begin
  rw det_apply,
  refine (nat_degree_sum_le _ _).trans _,
  refine (multiset.max_nat_le_of_forall_le _ _ _),
  simp only [forall_apply_eq_imp_iff', true_and, function.comp_app, multiset.map_map,
               multiset.mem_map, exists_imp_distrib, finset.mem_univ_val],
  intro g,
  calc  nat_degree (sign g • ∏ (i : n), (X • A.map C + B.map C) (g i) i)
      ≤ nat_degree (∏ (i : n), (X • A.map C + B.map C) (g i) i) : by
    { cases int.units_eq_one_or (sign g) with sg sg,
        { rw [sg, one_smul] },
        { rw [sg, units.neg_smul, one_smul, nat_degree_neg] } }
  ... ≤ ∑ (i : n), nat_degree (((X : α[X]) • A.map C + B.map C) (g i) i) :
    nat_degree_prod_le (finset.univ : finset n) (λ (i : n), (X • A.map C + B.map C) (g i) i)
  ... ≤ finset.univ.card • 1 : finset.sum_le_card_nsmul _ _ 1 (λ (i : n) _, _)
  ... ≤ fintype.card n : by simpa,
  calc  nat_degree (((X : α[X]) • A.map C + B.map C) (g i) i)
      = nat_degree ((X : α[X]) * C (A (g i) i) + C (B (g i) i)) : by simp
  ... ≤ max (nat_degree ((X : α[X]) * C (A (g i) i))) (nat_degree (C (B (g i) i))) :
    nat_degree_add_le _ _
  ... = nat_degree ((X : α[X]) * C (A (g i) i)) :
    max_eq_left ((nat_degree_C _).le.trans (zero_le _))
  ... ≤ nat_degree (X : α[X]) : nat_degree_mul_C_le _ _
  ... ≤ 1 : nat_degree_X_le
end

lemma coeff_det_X_add_C_zero (A B : matrix n n α) :
  coeff (det ((X : α[X]) • A.map C + B.map C)) 0 = det B :=
begin
  rw [det_apply, finset_sum_coeff, det_apply],
  refine finset.sum_congr rfl _,
  intros g hg,
  convert coeff_smul (sign g) _ 0,
  rw coeff_zero_prod,
  refine finset.prod_congr rfl _,
  simp
end

lemma coeff_det_X_add_C_card (A B : matrix n n α) :
  coeff (det ((X : α[X]) • A.map C + B.map C)) (fintype.card n) = det A :=
begin
  rw [det_apply, det_apply, finset_sum_coeff],
  refine finset.sum_congr rfl _,
  simp only [algebra.id.smul_eq_mul, finset.mem_univ, ring_hom.map_matrix_apply, forall_true_left,
             map_apply, pi.smul_apply],
  intros g,
  convert coeff_smul (sign g) _ _,
  rw ←mul_one (fintype.card n),
  convert (coeff_prod_of_nat_degree_le _ _ _ _).symm,
  { ext,
    simp [coeff_C] },
  { intros p hp,
    refine (nat_degree_add_le _ _).trans _,
    simpa only [pi.smul_apply, map_apply, algebra.id.smul_eq_mul, X_mul_C, nat_degree_C,
      max_eq_left, zero_le'] using (nat_degree_C_mul_le _ _).trans nat_degree_X_le }
end

lemma leading_coeff_det_X_one_add_C (A : matrix n n α) :
  leading_coeff (det ((X : α[X]) • (1 : matrix n n α[X]) + A.map C)) = 1 :=
begin
  casesI (subsingleton_or_nontrivial α),
  { simp },
  rw [←@det_one n, ←coeff_det_X_add_C_card _ A, leading_coeff],
  simp only [matrix.map_one, C_eq_zero, ring_hom.map_one],
  cases (nat_degree_det_X_add_C_le 1 A).eq_or_lt with h h,
  { simp only [ring_hom.map_one, matrix.map_one, C_eq_zero] at h,
    rw h },
  { -- contradiction. we have a hypothesis that the degree is less than |n|
    -- but we know that coeff _ n = 1
    have H := coeff_eq_zero_of_nat_degree_lt h,
    rw coeff_det_X_add_C_card at H,
    simpa using H }
end

end polynomial


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.binary_products
import Mathlib.category_theory.limits.shapes.equalizers
import Mathlib.category_theory.limits.shapes.pullbacks
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# Constructing pullbacks from binary products and equalizers

If a category as binary products and equalizers, then it has pullbacks.
Also, if a category has binary coproducts and coequalizers, then it has pushouts
-/

namespace category_theory.limits

/-- If the product `X ⨯ Y` and the equalizer of `π₁ ≫ f` and `π₂ ≫ g` exist, then the
    pullback of `f` and `g` exists: It is given by composing the equalizer with the projections. -/
theorem has_limit_cospan_of_has_limit_pair_of_has_limit_parallel_pair {C : Type u} [𝒞 : category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) [has_limit (pair X Y)] [has_limit (parallel_pair (prod.fst ≫ f) (prod.snd ≫ g))] : has_limit (cospan f g) := sorry

/-- If a category has all binary products and all equalizers, then it also has all pullbacks.
    As usual, this is not an instance, since there may be a more direct way to construct
    pullbacks. -/
theorem has_pullbacks_of_has_binary_products_of_has_equalizers (C : Type u) [𝒞 : category C] [has_binary_products C] [has_equalizers C] : has_pullbacks C :=
  has_limits_of_shape.mk fun (F : walking_cospan ⥤ C) => has_limit_of_iso (iso.symm (diagram_iso_cospan F))

/-- If the coproduct `Y ⨿ Z` and the coequalizer of `f ≫ ι₁` and `g ≫ ι₂` exist, then the
    pushout of `f` and `g` exists: It is given by composing the inclusions with the coequalizer. -/
theorem has_colimit_span_of_has_colimit_pair_of_has_colimit_parallel_pair {C : Type u} [𝒞 : category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) (g : X ⟶ Z) [has_colimit (pair Y Z)] [has_colimit (parallel_pair (f ≫ coprod.inl) (g ≫ coprod.inr))] : has_colimit (span f g) := sorry

/-- If a category has all binary coproducts and all coequalizers, then it also has all pushouts.
    As usual, this is not an instance, since there may be a more direct way to construct
    pushouts. -/
theorem has_pushouts_of_has_binary_coproducts_of_has_coequalizers (C : Type u) [𝒞 : category C] [has_binary_coproducts C] [has_coequalizers C] : has_pushouts C :=
  has_pushouts_of_has_colimit_span C


/-
Copyright (c) 2020 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Riccardo Brasca
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.polynomial.cyclotomic
import Mathlib.topology.algebra.polynomial
import Mathlib.field_theory.finite.basic
import Mathlib.PostPort

namespace Mathlib

/-!
# Primes congruent to one

We prove that, for any positive `k : ℕ`, there are infinitely many primes `p` such that
`p ≡ 1 [MOD k]`.
-/

namespace nat

/-- For any positive `k : ℕ` there are infinitely many primes `p` such that `p ≡ 1 [MOD k]`. -/
theorem exists_prime_ge_modeq_one (k : ℕ) (n : ℕ) (hpos : 0 < k) : ∃ (p : ℕ), prime p ∧ n ≤ p ∧ modeq k p 1 := sorry

theorem frequently_at_top_modeq_one (k : ℕ) (hpos : 0 < k) : filter.frequently (fun (p : ℕ) => prime p ∧ modeq k p 1) filter.at_top := sorry

theorem infinite_set_of_prime_modeq_one (k : ℕ) (hpos : 0 < k) : set.infinite (set_of fun (p : ℕ) => prime p ∧ modeq k p 1) :=
  iff.mp frequently_at_top_iff_infinite (frequently_at_top_modeq_one k hpos)


/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
import .henkin

local attribute [instance, priority 0] classical.prop_decidable

open fol fol.Lhom

namespace fol

lemma satisfied_of_provable {L : Language} (T : Theory L) (ψ : sentence L) : T ⊢' ψ → T ⊨ ψ :=
λ _, soundness $ classical.choice ‹_›

lemma completeness_for_inconsistent_theories {L : Language} (T : Theory L) (ψ : sentence L) (h_inconsis : ¬ is_consistent T) : T ⊢' ψ ↔ T ⊨ ψ :=
⟨satisfied_of_provable _ _, λ _, exfalso' $ classical.by_contradiction ‹_›⟩

/- T is consistent iff there is a nonempty model of T -/
theorem model_existence {L : Language} (T : Theory L) : is_consistent T ↔ (∃ M : Structure L, (nonempty M) ∧ M ⊨ T) :=
begin
  refine ⟨_,_⟩; intro H,
    { refine ⟨reduct (@henkin_language_over L T H)
        (term_model $ completion_of_henkinization H), ⟨_,_⟩⟩,
      { exact reduct_nonempty_of_nonempty (by simp[fol.nonempty_term_model]) },
      { exact reduct_of_complete_henkinization_models_T _ } },
    { rcases H with ⟨M, ⟨H_nonempty, H_sat⟩⟩,
      exact λ _, false_of_satisfied_false (satisfied_of_provable _ _ ‹_› ‹_› ‹_›) }
end

noncomputable def nonempty_model_of_consis {L : Language} {T : Theory L} (hT : is_consistent T) : Σ' M : Model T, nonempty M.fst.carrier :=
begin
  have := (model_existence T).mp hT, apply classical.psigma_of_exists,
  rcases this with ⟨M, hM, h_satisfied⟩,
  apply exists.intro, swap, exact ⟨M, h_satisfied⟩, exact hM
end

/-- model_existence is implied by completeness --/
theorem model_existence_of_completeness {L : Language} (T : Theory L) (h_completeness : ∀ (T : Theory L) (ψ : sentence L), T ⊢' ψ ↔ T ⊨ ψ) : is_consistent T ↔ (∃ M : Structure L, (nonempty M) ∧ M ⊨ T) :=
begin
  refine ⟨_,_⟩; intro H,
    { by_contra H', push_neg at H', apply H,
      rw h_completeness,
      intros M hM0 hMT, exfalso, exact H' M hM0 hMT },
    { intro H', rcases H with ⟨_,_,_⟩, rw[h_completeness] at H',
      exact false_of_satisfied_false (H' ‹_› ‹_›) }
end

theorem completeness {L : Language} (T : Theory L) (ψ : sentence L) : T ⊢' ψ ↔ T ⊨ ψ :=
begin
  refine ⟨λ _, satisfied_of_provable _ _ ‹_›, _⟩, by_contra H, push_neg at H,
  rcases nonempty_model_of_consis (consis_not_of_not_provable H.right) with ⟨⟨M,HM⟩, H_nonempty⟩,
  refine absurd H.left (not_satisfied_of_model_not _ _ _), swap,
  exact ((by simp at HM; simp*) : (⟨M, by tidy⟩ : Model T) ⊨ _), from ‹_›
end

theorem compactness {L : Language} {T : Theory L} {f : sentence L} :
  T ⊨ f ↔ ∃ fs : finset (sentence L), (↑fs : Theory L) ⊨ (f : sentence L) ∧ ↑fs ⊆ T :=
begin
  rw [<-(completeness T f), theory_proof_compactness_iff], simp only [completeness]
end

end fol


/-
Copyright (c) 2015 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Mike Shulman

Ported from Coq HoTT
Theorems about fibers
-/

import .eq .arrow ..cubical.squareover .pointed ..eq2

universes u v w
hott_theory

namespace hott

open hott.equiv hott.sigma hott.eq hott.pi hott.pointed hott.is_equiv

structure fiber {A B : Type _} (f : A → B) (b : B) :=
  (point : A)
  (point_eq : f point = b)

namespace fiber
  variables {A : Type _} {B : Type _} {f : A → B} {b : B}

  @[hott] protected def sigma_char
    (f : A → B) (b : B) : fiber f b ≃ (Σ(a : A), f a = b) :=
  begin
  fapply equiv.MK,
    {intro x, exact ⟨point x, point_eq x⟩},
    {intro x, exact (fiber.mk x.1 x.2)},
    {intro x, cases x, apply idp },
    {intro x, cases x, apply idp },
  end

  @[hott, hsimp] def sigma_char_mk_pair {A B : Type*} (f : A → B) (a : A) (b : B) (p : f a = b)
    : fiber.sigma_char f b ⟨ a , p ⟩ = ⟨a, p⟩ :=
  rfl

  -- @[hott, hsimp] def sigma_char_mk_snd {A B : Type*} (f : A → B) (a : A) (b : B) (p : f a = b)
  --   : ((fiber.sigma_char f b) ⟨ a , p ⟩).snd = p  :=
  -- begin dsimp, end --refl _

  -- @[hott, hsimp] def sigma_char_mk_fst {A B : Type*} (f : A → B) (a : A) (b : B) (p : f a = b)
  --   : ((fiber.sigma_char f b) ⟨ a , p ⟩).fst = a  :=
  -- begin dsimp, end --refl _

  @[hott] def fiber_eq_equiv (x y : fiber f b)
    : (x = y) ≃ (Σ(p : point x = point y), point_eq x = ap f p ⬝ point_eq y) :=
  begin
    apply equiv.trans,
      apply eq_equiv_fn_eq_of_equiv, apply fiber.sigma_char,
    apply equiv.trans,
      apply sigma_eq_equiv,
    apply sigma_equiv_sigma_right,
    intro p,
    apply eq_pathover_equiv_Fl,
  end

  @[hott] def fiber_eq {x y : fiber f b} (p : point x = point y)
    (q : point_eq x = ap f p ⬝ point_eq y) : x = y :=
  to_inv (fiber_eq_equiv _ _) ⟨p, q⟩

  @[hott] def fiber_pathover {X : Type _} {A B : X → Type _} {x₁ x₂ : X} {p : x₁ = x₂}
    {f : Πx, A x → B x} {b : Πx, B x} {v₁ : fiber (f x₁) (b x₁)} {v₂ : fiber (f x₂) (b x₂)}
    (q : point v₁ =[p] point v₂)
    (r : squareover B hrfl (pathover_idp_of_eq _ (point_eq v₁)) (pathover_idp_of_eq _ (point_eq v₂))
                           (apo f q) (apd b p))
    : v₁ =[p; λ x, fiber (f x) (b x)] v₂ :=
  begin
    apply (pathover_of_fn_pathover_fn (λ (x : X), @fiber.sigma_char (A x) (B x) (f x) (b x))), dsimp,
    fapply sigma_pathover; dsimp,
    { exact q},
    { induction v₁ with a₁ p₁, induction v₂ with a₂ p₂, dsimp at *, induction q,
      apply pathover_idp_of_eq, apply eq_of_vdeg_square,
      dsimp[hrfl] at r,
      dsimp[apo, apd] at r,
      exact (square_of_squareover_ids B r)}
  end

  open is_trunc
  @[hott] def π₁ {B : A → Type _} : (Σa, B a) → A := sigma.fst

  @[hott] def fiber_pr1 (B : A → Type _) (a : A) : fiber (π₁ : (Σa, B a) → A) a ≃ B a :=
  calc
    fiber π₁ a ≃ Σ(u : Σ a, B a), (π₁ u) = a    : fiber.sigma_char _ _
          ... ≃ Σ (a' : A) (b : B a'), a' = a  : (sigma_assoc_equiv (λ (u : Σ a, B a), (π₁ u) = a) ) ⁻¹ᵉ
          ... ≃ Σa' (p : a' = a), B a'         : sigma_equiv_sigma_right (λa', comm_equiv_nondep _ _)
          ... ≃ Σ(w : Σ a', a'=a), B (π₁ w)    : sigma_assoc_equiv (λ (w : Σ a', a'=a), B (π₁ w))
          ... ≃ B a                            : sigma_equiv_of_is_contr_left (λ (w : Σ a', a'=a), B (π₁ w))

  @[hott] def sigma_fiber_equiv (f : A → B) : (Σb, fiber f b) ≃ A :=
  calc
    (Σb, fiber f b) ≃ Σb a, f a = b : sigma_equiv_sigma_right (λb, fiber.sigma_char _ b)
                ... ≃ Σa b, f a = b : sigma_comm_equiv _
                ... ≃ A             : sigma_equiv_of_is_contr_right _

  @[hott, instance] def is_pointed_fiber (f : A → B) (a : A)
    : pointed (fiber f (f a)) :=
  pointed.mk (fiber.mk a idp)

  @[hott] def pointed_fiber (f : A → B) (a : A) : Type* :=
  pointed.Mk (fiber.mk a (idpath (f a)))

  @[hott, reducible] def is_trunc_fun (n : ℕ₋₂) (f : A → B) :=
  Π(b : B), is_trunc n (fiber f b)

  @[hott, reducible] def is_contr_fun (f : A → B) := is_trunc_fun -2 f

  -- pre and post composition with equivalences
  open function
  variable (f)
  @[hott] protected def equiv_postcompose {B' : Type _} (g : B ≃ B') --[H : is_equiv g]
    (b : B) : fiber (g ∘ f) (g b) ≃ fiber f b :=
  calc
    fiber (g ∘ f) (g b) ≃ Σa : A, g (f a) = g b : fiber.sigma_char _ _
                    ... ≃ Σa : A, f a = b       : begin
                                                    apply sigma_equiv_sigma_right,
                                                    intro a,
                                                    apply equiv.symm,
                                                    apply eq_equiv_fn_eq
                                                  end
                    ... ≃ fiber f b             : (fiber.sigma_char _ _) ⁻¹ᵉ

  @[hott] protected def equiv_precompose {A' : Type _} (g : A' ≃ A) --[H : is_equiv g]
    (b : B) : fiber (f ∘ g) b ≃ fiber f b :=
  calc
    fiber (f ∘ g) b ≃ Σa' : A', f (g a') = b   : fiber.sigma_char _ _
                ... ≃ Σa : A, f a = b          : begin
                                                   apply sigma_equiv_sigma g,
                                                   intro a', apply erfl
                                                 end
                ... ≃ fiber f b                : (fiber.sigma_char _ _) ⁻¹ᵉ

end fiber

open unit is_trunc pointed

namespace fiber

  @[hott] def fiber_star_equiv (A : Type _) : fiber (λx : A, star) star ≃ A :=
  begin
    fapply equiv.MK,
    { intro f, cases f with a H, exact a },
    { intro a, apply fiber.mk a, reflexivity },
    { intro a, reflexivity },
    { intro f, cases f with a H, change fiber.mk a (refl star) = fiber.mk a H,
      rwr [is_set.elim H (refl star)] }
  end

  @[hott] def fiber_const_equiv (A : Type _) (a₀ : A) (a : A)
    : fiber (λz : unit, a₀) a ≃ a₀ = a :=
  calc
    fiber (λz : unit, a₀) a ≃ Σz : unit, a₀ = a : fiber.sigma_char _ _
                        ... ≃ a₀ = a : sigma_unit_left _

  -- the pointed fiber of a pointed map, which is the fiber over the basepoint
  open pointed
  @[hott] def pfiber {X Y : Type*} (f : X →* Y) : Type* :=
  pointed.MK (fiber f pt) (fiber.mk pt (respect_pt _))

  @[hott] def ppoint {X Y : Type*} (f : X →* Y) : pfiber f →* X :=
  pmap.mk point idp

  @[hott] def pfiber.sigma_char {A B : Type*} (f : A →* B)
    : pfiber f ≃* pointed.MK (Σa, f a = pt) ⟨pt, respect_pt f⟩ :=
  pequiv_of_equiv (fiber.sigma_char f pt) idp

  @[hott, hsimp] def pfiber.sigma_char_mk_snd {A B : Type*} (f : A →* B) (a : A) (p : f a = pt)
    : ((pfiber.sigma_char f).to_pmap ⟨ a , p ⟩).snd = p  :=
  refl _

  @[hott] def pointed_fst {A : Type*} (B : A → Type) (pt_B : B pt) :
    pointed.MK (Σa, B a) ⟨pt, pt_B⟩ →* A :=
  pmap.mk π₁ (refl _)

  @[hott] def ppoint_sigma_char {A B : Type*} (f : A →* B)
    : ppoint f ~* (pointed_fst _ _)  ∘* (pfiber.sigma_char f).to_pmap :=
  phomotopy.refl _

  @[hott] def pfiber_pequiv_of_phomotopy {A B : Type*} {f g : A →* B} (h : f ~* g)
    : pfiber f ≃* pfiber g :=
  begin
    fapply pequiv_of_equiv,
    { refine (fiber.sigma_char f pt ⬝e _ ⬝e (fiber.sigma_char g pt)⁻¹ᵉ),
      apply sigma_equiv_sigma_right, intros a,
      apply equiv_eq_closed_left, apply (to_homotopy h) },
    { refine (fiber_eq rfl _),
      change (h pt)⁻¹ ⬝ respect_pt f = idp ⬝ respect_pt g,
      rwr idp_con, apply inv_con_eq_of_eq_con, symmetry, exact (to_homotopy_pt h) }
  end

  @[hott] def transport_fiber_equiv {A B : Type _} (f : A → B) {b1 b2 : B} (p : b1 = b2)
    : fiber f b1 ≃ fiber f b2 :=
    calc fiber f b1 ≃ Σa, f a = b1 : fiber.sigma_char _ _
               ...  ≃ Σa, f a = b2 : sigma_equiv_sigma_right (λa, equiv_eq_closed_right (f a) p)
               ...  ≃ fiber f b2   : (fiber.sigma_char _ _) ⁻¹ᵉ

  @[hott,hsimp] def transport_fiber_equiv_mk {A B : Type _}
    (f : A → B) {b1 b2 : B} (p : b1 = b2) (a : A) (q : f a = b1) :
      (transport_fiber_equiv f p) ⟨ a , q ⟩ = ⟨ a , q ⬝ p ⟩ :=
  begin
    induction p, induction q, refl
  end

  @[hott, hsimp] def snd_point_pfiber_eq_respect_pt {A B : Type*} (f : A →* B) :
    (pfiber f).Point = ⟨ pt , respect_pt f ⟩ :=
    by refl

  @[hott] def pequiv_postcompose {A B B' : Type*} (f : A →* B) (g : B ≃* B')
    : pfiber (g.to_pmap ∘* f) ≃* pfiber f :=
  begin
    fapply pequiv_of_equiv,
    refine
      transport_fiber_equiv (g.to_pmap ∘* f) (respect_pt g.to_pmap)⁻¹ ⬝e
        fiber.equiv_postcompose f (equiv_of_pequiv g) (Point B),
    apply ap (fiber.mk (Point A)), refine con.assoc _ _ _ ⬝ _,
    apply inv_con_eq_of_eq_con,
    dsimp [fiber.sigma_char],
    rwr [con.assoc, eq.con.right_inv, con_idp, ← ap_compose],
    exact ap_con_eq_con
      (λ x, ap g⁻¹ᵉ*.to_pmap (ap g.to_pmap (pleft_inv' g x)⁻¹) ⬝ ap g⁻¹ᵉ*.to_pmap
      (pright_inv g (g.to_pmap x)) ⬝
      pleft_inv' g x) (respect_pt f)
  end

  @[hott] def pequiv_precompose {A A' B : Type*} (f : A →* B) (g : A' ≃* A)
    : pfiber (f ∘* g.to_pmap) ≃* pfiber f :=
  begin
    fapply pequiv_of_equiv,
    refine fiber.equiv_precompose f (equiv_of_pequiv g) (Point B),
    apply (eq_of_fn_eq_fn (fiber.sigma_char _ _)), fapply sigma_eq,
    { apply respect_pt g.to_pmap },
    { apply eq_pathover_Fl' }
  end

  @[hott] def pfiber_pequiv_of_square {A B C D : Type*} {f : A →* B} {g : C →* D} (h : A ≃* C)
    (k : B ≃* D) (s : k.to_pmap ∘* f ~* g ∘* h.to_pmap) : pfiber f ≃* pfiber g :=
    calc pfiber f ≃* pfiber (k.to_pmap ∘* f) : (pequiv_postcompose f k) ⁻¹ᵉ*
              ... ≃* pfiber (g ∘* h.to_pmap) : pfiber_pequiv_of_phomotopy s
              ... ≃* pfiber g : (pequiv_precompose _ _)

  @[hott] def pcompose_ppoint {A B : Type*} (f : A →* B) : f ∘* ppoint f ~* pconst (pfiber f) B :=
  begin
    fapply phomotopy.mk,
    { exact point_eq },
    { exact (idp_con _)⁻¹ }
  end

  @[hott] def point_fiber_eq {A B : Type _} {f : A → B} {b : B} {x y : fiber f b}
    (p : point x = point y) (q : point_eq x = ap f p ⬝ point_eq y) :
    ap point (fiber_eq p q) = p :=
  begin
    induction x with a γ, induction y with a' γ', dsimp at p q,
    induction p, induction γ', dsimp at q,
    hinduction q using eq.rec_symm, reflexivity
  end

  @[hott] def fiber_eq_equiv_fiber {A B : Type _} {f : A → B} {b : B} (x y : fiber f b) :
    x = y ≃ fiber (ap1_gen f (point_eq x) (point_eq y)) (idpath b) :=
  calc
    x = y ≃ fiber.sigma_char f b x = fiber.sigma_char f b y :
                    eq_equiv_fn_eq_of_equiv (fiber.sigma_char f b) x y
      ... ≃ Σ(p : point x = point y), point_eq x =[p; λ z, f z = b] point_eq y : sigma_eq_equiv _ _
      ... ≃ Σ(p : point x = point y), (point_eq x)⁻¹ ⬝ ap f p ⬝ point_eq y = idp :
      sigma_equiv_sigma_right (λp,
      calc
        point_eq x =[p; λ z, f z = b] point_eq y ≃ point_eq x = ap f p ⬝ point_eq y : eq_pathover_equiv_Fl _ _ _
              ... ≃ ap f p ⬝ point_eq y = point_eq x : eq_equiv_eq_symm _ _
              ... ≃ (point_eq x)⁻¹ ⬝ (ap f p ⬝ point_eq y) = idp : eq_equiv_inv_con_eq_idp _ _
              ... ≃ (point_eq x)⁻¹ ⬝ ap f p ⬝ point_eq y = idp : equiv_eq_closed_left _ (con.assoc _ _ _) ⁻¹)
              ... ≃ fiber (ap1_gen f (point_eq x) (point_eq y)) (idpath b) : (fiber.sigma_char _ _) ⁻¹ᵉ

  @[hott] def loop_pfiber {A B : Type*} (f : A →* B) : Ω (pfiber f) ≃* pfiber (Ω→ f) :=
  pequiv_of_equiv (fiber_eq_equiv_fiber (Point (pfiber f)) (Point (pfiber f)))
    begin
      induction f with f f₀, induction B with B b₀, dsimp at f f₀, induction f₀, reflexivity
    end

  @[hott] def pfiber_loop_space {A B : Type*} (f : A →* B) : pfiber (Ω→ f) ≃* Ω (pfiber f) :=
  (loop_pfiber f)⁻¹ᵉ*

  @[hott] def point_fiber_eq_equiv_fiber {A B : Type _} {f : A → B} {b : B} {x y : fiber f b}
    (p : x = y) : point (fiber_eq_equiv_fiber x y p) = ap1_gen point idp idp p :=
  by induction p; reflexivity

  @[hott] lemma ppoint_loop_pfiber {A B : Type*} (f : A →* B) :
    ppoint (Ω→ f) ∘* (loop_pfiber f).to_pmap ~* Ω→ (ppoint f) :=
  phomotopy.mk (point_fiber_eq_equiv_fiber)
    begin
     induction f with f f₀, induction B with B b₀, dsimp at f f₀, induction f₀, reflexivity
    end

  @[hott] lemma ppoint_loop_pfiber_inv {A B : Type*} (f : A →* B) :
    Ω→ (ppoint f) ∘* ((loop_pfiber f)⁻¹ᵉ*).to_pmap ~* ppoint (Ω→ f) :=
  (phomotopy_pinv_right_of_phomotopy (ppoint_loop_pfiber f))⁻¹*

  @[hott] def pfiber_pequiv_of_phomotopy_ppoint {A B : Type*} {f g : A →* B} (h : f ~* g)
    : ppoint g ∘* (pfiber_pequiv_of_phomotopy h).to_pmap ~* ppoint f :=
  begin
    induction f with f f₀, induction g with g g₀, induction h with h h₀,
    induction B with B b₀, induction A with A a₀,
    dsimp at *,
    induction g₀,
    dsimp [respect_pt] at h₀,
    induction h₀,
    dsimp [ppoint],
    fapply phomotopy.mk,
    { reflexivity },
    { refine idp_con _ ⬝ _, symmetry, apply point_fiber_eq }
  end

  @[hott] def pequiv_postcompose_ppoint {A B B' : Type*} (f : A →* B) (g : B ≃* B')
    : ppoint f ∘* (fiber.pequiv_postcompose f g).to_pmap ~* ppoint (g.to_pmap ∘* f) :=
  begin
    induction f with f f₀, induction g with g hg g₀, induction B with B b₀,
    induction B' with B' b₀', dsimp at *, induction g₀, induction f₀,
    fapply phomotopy.mk,
    { reflexivity },
    { refine idp_con _ ⬝ _, symmetry, dsimp [ppoint],
      refine (ap_compose' _ _ _) ⬝ _, apply ap_constant }
  end

  @[hott] def pequiv_precompose_ppoint {A A' B : Type*} (f : A →* B) (g : A' ≃* A)
    : ppoint f ∘* (fiber.pequiv_precompose f g).to_pmap ~* g.to_pmap ∘* ppoint (f ∘* g.to_pmap) :=
  begin
    induction f with f f₀, induction g with g h₁ h₂ p₁ p₂, induction B with B b₀,
    induction g with g g₀, induction A with A a₀', dsimp at *, induction g₀, induction f₀,
    reflexivity
  end

  @[hott] def pfiber_pequiv_of_square_ppoint {A B C D : Type*} {f : A →* B} {g : C →* D}
    (h : A ≃* C) (k : B ≃* D) (s : k.to_pmap ∘* f ~* g ∘* h.to_pmap)
    : ppoint g ∘* (pfiber_pequiv_of_square h k s).to_pmap ~* h.to_pmap ∘* ppoint f :=
  begin
    refine (passoc _ _ _) ⁻¹* ⬝* _,
    refine pwhisker_right _ (pequiv_precompose_ppoint _ _) ⬝* _,
    refine (passoc _ _ _) ⬝* _,
    apply pwhisker_left,
    refine (passoc _ _ _) ⁻¹* ⬝* _,
    refine pwhisker_right _ (pfiber_pequiv_of_phomotopy_ppoint _) ⬝* _,
    apply pinv_right_phomotopy_of_phomotopy,
    refine (pequiv_postcompose_ppoint _ _)⁻¹*,
  end

  -- this breaks certain proofs if it is an instance
  @[hott] def is_trunc_fiber (n : ℕ₋₂) {A B : Type _} (f : A → B) (b : B)
    [is_trunc n A] [is_trunc (n.+1) B] : is_trunc n (fiber f b) :=
  is_trunc_equiv_closed_rev n (fiber.sigma_char _ _) (is_trunc_sigma _ n)

  @[hott] def is_trunc_pfiber (n : ℕ₋₂) {A B : Type*} (f : A →* B)
    [is_trunc n A] [is_trunc (n.+1) B] : is_trunc n (pfiber f) :=
  is_trunc_fiber n f pt

  @[hott] def fiber_equiv_of_is_contr {A B : Type _} (f : A → B) (b : B) [is_contr B] :
    fiber f b ≃ A :=
  (fiber.sigma_char _ _) ⬝e sigma_equiv_of_is_contr_right _

  @[hott] def pfiber_pequiv_of_is_contr {A B : Type*} (f : A →* B) [is_contr B] :
    pfiber f ≃* A :=
  pequiv_of_equiv (fiber_equiv_of_is_contr f pt) idp

  @[hott] def pfiber_ppoint_equiv {A B : Type*} (f : A →* B) : pfiber (ppoint f) ≃ Ω B :=
  calc
    pfiber (ppoint f) ≃ Σ(x : pfiber f), ppoint f x = pt : fiber.sigma_char _ _
      ... ≃ Σ(x : Σa, f a = pt), x.1 = pt :
              by exact sigma_equiv_sigma (fiber.sigma_char _ _) (λ a, erfl)
      ... ≃ Σ(x : Σa, a = pt), f x.1 = pt : sigma_assoc_comm_equiv (λa, f a = pt) (λa, a = pt)
      ... ≃ f pt = pt : sigma_equiv_of_is_contr_left _ ⬝e by refl
      ... ≃ Ω B : equiv_eq_closed_left _ (respect_pt _)

  @[hott] def pfiber_ppoint_pequiv {A B : Type*} (f : A →* B) : pfiber (ppoint f) ≃* Ω B :=
  pequiv_of_equiv (pfiber_ppoint_equiv f) (con.left_inv _)

  @[hott] def pfiber_ppoint_equiv_eq {A B : Type*} (f : A →* B) {a : A} (p : f a = pt)
    (q : ppoint f (fiber.mk a p) = pt) :
    (pfiber_ppoint_equiv f).to_fun (fiber.mk (fiber.mk a p) q) = (respect_pt f)⁻¹ ⬝ ap f q⁻¹ ⬝ p :=
  begin
    refine _ ⬝ (con.assoc _ _ _) ⁻¹,
    apply whisker_left,
    dsimp [sigma_equiv_of_is_contr_left],
    refine eq_transport_Fl _ _ ⬝ _,
    apply whisker_right,
    refine inverse2 (ap_inv _ _) ⬝ (inv_inv _) ⬝ _,
    refine ap_compose f sigma.fst _ ⬝ ap02 f _, apply ap_fst_center_eq_sigma_eq'
  end

  @[hott] def pfiber_ppoint_equiv_inv_eq {A B : Type*} (f : A →* B) (p : Ω B) :
    (pfiber_ppoint_equiv f)⁻¹ᵉ p = fiber.mk (fiber.mk pt (respect_pt f ⬝ p)) idp :=
  begin
    apply inv_eq_of_eq,
    refine _ ⬝ (pfiber_ppoint_equiv_eq _ _ _)⁻¹,
    exact (inv_con_cancel_left _ _)⁻¹
  end

@[hott] def fiber_functor {A A' B B' : Type} {f : A → B} {f' : A' → B'} {b : B} {b' : B'}
  (g : A → A') (h : B → B') (H : hsquare g h f f') (p : h b = b') (x : fiber f b) : fiber f' b' :=
fiber.mk (g (point x)) (H (point x) ⬝ ap h (point_eq x) ⬝ p)

@[hott] def pfiber_functor {A A' B B' : Type*} {f : A →* B} {f' : A' →* B'}
  (g : A →* A') (h : B →* B') (H : psquare g h f f') : pfiber f →* pfiber f' :=
pmap.mk (fiber_functor g h H (respect_pt h))
  begin
    fapply fiber_eq,
      exact respect_pt g,
      exact con.assoc _ _ _ ⬝ to_homotopy_pt H
  end

@[hott] def ppoint_natural {A A' B B' : Type*} {f : A →* B} {f' : A' →* B'}
  (g : A →* A') (h : B →* B') (H : psquare g h f f') :
  psquare (ppoint f) (ppoint f') (pfiber_functor g h H) g :=
begin
  fapply phomotopy.mk,
  { intro x, reflexivity },
  { refine idp_con _ ⬝ _ ⬝ (idp_con _)⁻¹ᵖ, apply point_fiber_eq }
end

-- @[hott] def pfiber_ppoint_pequiv_natural {A A' B B' : Type*} {f : A →* B} {f' : A' →* B'}
--   (g : A →* A') (h : B →* B') (H : psquare g h f f') :
--   psquare (pfiber_ppoint_pequiv f).to_pmap (pfiber_ppoint_pequiv f').to_pmap
--           (pfiber_functor (pfiber_functor g h H) g (ptranspose (ppoint_natural g h H))) (Ω→ h) :=
-- begin
--   induction A' with A' a₀', induction B with B b₀, induction B' with B' b₀',
--   induction f with f f₀, induction f' with f' f₀', induction g with g g₀,
--   dsimp at *, induction f₀, induction f₀', induction g₀,
--   fapply phomotopy.mk,
--   { intro x,
--     induction x with x q, induction x with a p, dsimp [ppoint] at *,
--     dsimp [pfiber_ppoint_pequiv, pcompose, pequiv_of_equiv, pequiv.mk, pequiv_of_pmap,
--       pfiber_functor, fiber_functor],
--     refine ap (Ω→ h) (pfiber_ppoint_equiv_eq _ _ _) ⬝ _ ⬝ (pfiber_ppoint_equiv_eq _ _ _)⁻¹ᵖ,
--     dsimp [ppoint_natural, phomotopy.symm],
--     hinduction q using eq.rec_symm, refine ap (Ω→ h) (idp_con _) ⬝ _ ⬝ (idp_con _)⁻¹ᵖ,
--     apply whisker_right, apply whisker_right,
--     apply inv_eq_of_idp_eq_con,
--     exact (to_homotopy_pt H)⁻¹ ⬝ whisker_left _ (idp_con _) },
--   { sorry } -- this is easier if we redefine pfiber_ppoint_equiv after porting stuff about psigma_gen etc.
-- end

  @[hott] def pfiber_ppoint_pequiv_ppoint_homotopy {A B : Type*} (f : A →* B) (p : Ω A) :
    (pfiber_ppoint_pequiv f).to_pmap ((ppoint (ppoint (ppoint f)))
      ((pfiber_ppoint_pequiv (ppoint f))⁻¹ᵉ*.to_pmap p)) = Ω→ f p⁻¹ᵖ :=
  begin
    refine ap (λ(x : pfiber (ppoint (ppoint f))), (pfiber_ppoint_pequiv f).to_pmap
      (ppoint (ppoint (ppoint f)) x))
              (pfiber_ppoint_equiv_inv_eq (ppoint f) p) ⬝ _,
    dsimp [ppoint],
    refine pfiber_ppoint_equiv_eq f f.resp_pt _ ⬝ _,
    exact ap (Ω→ f) (idp_con p)⁻²
  end

  @[hott] def pfiber_ppoint_equiv_eq_idp {A B : Type*} (f : A →* B) :
    pfiber_ppoint_equiv_eq f (respect_pt f) idp = idp :=
  begin
    apply con_inv_eq_idp,
    refine ap (whisker_left _) (whisker_left _ _) ⬝ _,
    { reflexivity },
    { reflexivity },
    refine ap (whisker_left _) (eq_transport_Fl_idp_left f (respect_pt f)) ⬝ _,
    apply whisker_left_idp_con_eq_assoc
  end

@[hott] def pfiber_ppoint_pequiv_ppoint {A B : Type*} (f : A →* B) :
  psquare (ppoint (ppoint (ppoint f))) (Ω→ f ∘* pinverse A)
          (pfiber_ppoint_pequiv (ppoint f)).to_pmap (pfiber_ppoint_pequiv f).to_pmap :=
begin
  apply phomotopy_of_pinv_right_phomotopy,
  fapply phomotopy.mk,
  { exact pfiber_ppoint_pequiv_ppoint_homotopy f },
  { dsimp [pcompose, pinverse],
    apply whisker_right, refine idp_con _ ⬝ con_idp _ ⬝ _,
    exact pfiber_ppoint_equiv_eq_idp f }
end

end fiber

open function is_equiv

namespace fiber
  /- @[hott] theorem 4.7.6 -/
  variables {A : Type _} {P : A → Type _ } {Q : A → Type _}
  variable (f : Πa, P a → Q a)

  @[hott] def fiber_total_equiv {a : A} (q : Q a)
    : fiber (total f) ⟨a , q⟩ ≃ fiber (f a) q :=
  calc
    fiber (total f) ⟨a , q⟩
          ≃ Σ(w : Σx, P x), (⟨w.1 , f w.1 w.2 ⟩ : Σ x, _) = ⟨a , q⟩
            : fiber.sigma_char _ _
      ... ≃ Σ(x : A), Σ(p : P x), (⟨x , f x p⟩ : Σx, _) = ⟨a , q⟩
            : (@sigma_assoc_equiv A P (λ(w : Σx, P x), (⟨w.1 , f w.1 w.2 ⟩ : Σ x, _) = ⟨a , q⟩))⁻¹ᵉ
      ... ≃ Σ(x : A), Σ(p : P x), Σ(H : x = a), f x p =[H] q
            :
            begin
              apply sigma_equiv_sigma_right, intro x,
              apply sigma_equiv_sigma_right, intro p,
              apply sigma_eq_equiv
            end
      ... ≃ Σ(x : A), Σ(H : x = a), Σ(p : P x), f x p =[H] q
            :
            begin
              apply sigma_equiv_sigma_right, intro x,
              apply sigma_comm_equiv
            end
      ... ≃ Σ(w : Σx, x = a), Σ(p : P w.1), f w.1 p =[w.2] q
            : sigma_assoc_equiv (λ(w : Σx, x = a), Σ(p : P w.1), f w.1 p =[w.2] q)
      ... ≃ Σ(p : P (center (Σx, x=a)).1), f (center (Σx, x=a)).1 p =[(center (Σx, x=a)).2] q
            : sigma_equiv_of_is_contr_left _
      ... ≃ Σ(p : P a), f a p =[idpath a] q
            : equiv_of_eq idp
      ... ≃ Σ(p : P a), f a p = q
            :
            begin
              apply sigma_equiv_sigma_right, intro p,
              apply pathover_idp
            end
      ... ≃ fiber (f a) q
            : (fiber.sigma_char _ _)⁻¹ᵉ

end fiber
end hott


import data.W.basic
import data.bool.basic

universes u v

namespace W_type

section nat

/-- The constructors for the naturals -/
inductive nat_α : Type
| zero : nat_α
| succ : nat_α

/-- The arity of the constructors for the naturals, `zero` takes no arguments, `succ` takes one -/
def nat_β : nat_α → Type
| nat_α.zero := empty
| nat_α.succ := unit

/-- The isomorphism from the naturals to its corresponding `W_type` -/
@[simp] def nat_to_W_type : ℕ → W_type nat_β
| nat.zero := ⟨ nat_α.zero , empty.elim ⟩
| (nat.succ n) := ⟨ nat_α.succ , λ _ , nat_to_W_type n ⟩

/-- The isomorphism from the `W_type` of the naturals to the naturals -/
@[simp] def W_type_to_nat : W_type nat_β → ℕ
| (W_type.mk nat_α.zero f) := 0
| (W_type.mk nat_α.succ f) := (W_type_to_nat (f ())).succ

lemma left_inv_W_type_to_nat : function.left_inverse W_type_to_nat nat_to_W_type
| nat.zero := rfl
| (nat.succ n) := by simp [left_inv_W_type_to_nat n]

lemma right_inv_W_type_to_nat : function.right_inverse W_type_to_nat nat_to_W_type
| (W_type.mk nat_α.zero f) := by { simp, tidy }
| (W_type.mk nat_α.succ f) := by { simp, tidy }

/-- The naturals are equivalent to their associated `W_type` -/
def nat_equiv_W_type : ℕ ≃ W_type nat_β :=
{ to_fun := nat_to_W_type,
  inv_fun := W_type_to_nat,
  left_inv := left_inv_W_type_to_nat,
  right_inv := right_inv_W_type_to_nat }

/-- `nat_α` is equivalent to `bool` -/
@[simps] def nat_α_equiv_bool : nat_α ≃ bool :=
{ to_fun := λ c, match c with | nat_α.zero := ff | nat_α.succ := tt end,
  inv_fun := λ b, match b with | bool.tt := nat_α.succ | bool.ff := nat_α.zero end,
  left_inv := λ c, match c with | nat_α.zero := rfl | nat_α.succ := rfl end,
  right_inv := λ b, match b with | bool.tt := rfl | bool.ff := rfl end }

end nat

section list

variable (γ : Type u)

/--
The constructors for lists.
There is "one constructor `cons x` for each `x : γ`",
since we view `list γ` as
| nil : list γ
| cons x₀ : list γ → list γ
| cons x₁ : list γ → list γ
|   ⋮      γ many times
-/
inductive list_α : Type u
| nil : list_α
| cons : γ → list_α

/-- The arities of each constructor for lists, `nil` takes no arguments, `cons hd` takes one -/
def list_β : list_α γ → Type u
| list_α.nil := pempty
| (list_α.cons hd) := punit

/-- The isomorphism from lists to W_types -/
@[simp] def list_to_W_type : list γ → W_type (list_β γ)
| list.nil := ⟨ list_α.nil, pempty.elim ⟩
| (list.cons hd tl) := ⟨ list_α.cons hd, λ _ , list_to_W_type tl ⟩

/-- The isomorphism from W_types to lists -/
@[simp] def W_type_to_list : W_type (list_β γ) → list γ
| (W_type.mk list_α.nil f) := []
| (W_type.mk (list_α.cons hd) f) := hd :: W_type_to_list (f punit.star)

lemma left_inv_W_type_to_list : function.left_inverse (W_type_to_list _) (list_to_W_type γ)
| list.nil := rfl
| (list.cons hd tl) := by simp [left_inv_W_type_to_list tl]

lemma right_inv_W_type_to_list : function.right_inverse (W_type_to_list _) (list_to_W_type γ)
| (W_type.mk list_α.nil f) := by { simp, tidy }
| (W_type.mk (list_α.cons x) f) := by { simp, tidy }

/-- The naturals are equivalent to their associated `W_type` -/
def list_equiv_W_type : list γ ≃ W_type (list_β γ) :=
{ to_fun := list_to_W_type _,
  inv_fun := W_type_to_list _,
  left_inv := left_inv_W_type_to_list _,
  right_inv := right_inv_W_type_to_list _ }

/-- list_α is equivalent to γ with an extra point ≃ with_bot γ associated `W_type` -/
def list_α_equiv_punit_sum : list_α γ ≃ punit.{v + 1} ⊕ γ :=
{ to_fun := λ c, match c with | list_α.nil := sum.inl punit.star | list_α.cons x := sum.inr x end,
  inv_fun := sum.elim (λ _, list_α.nil) (λ x, list_α.cons x),
  left_inv := λ c, match c with | list_α.nil := rfl | list_α.cons x := rfl end,
  right_inv := λ x, match x with | sum.inl punit.star := rfl | sum.inr x := rfl end, }

end list

end W_type


import game.max.level07 -- hide

open_locale classical -- hide

noncomputable theory -- hide

namespace xena -- hide

/-
# Chapter 4 : Max and abs

## Level 8

See if you can do `max_lt_iff` without introducing
any auxiliary hypotheses with `have`. Don't forget to
check the list of theorems to see the interface for `≤`
and `<`.
-/

/- Lemma
If $a$, $b$, $c$ are real numbers,
then ($a<c$ and $b<c$) iff $\max(a,b)<c.$
-/

theorem max_lt_iff {a b c : ℝ} : a < c ∧ b < c ↔ max a b < c :=
begin
  split,
  intro h,
  cases h with t ht,
  exact max_lt t ht,
  intro j,
  split,
  apply lt_of_le_of_lt _ j,
  apply le_max_left,
  apply lt_of_le_of_lt _ j,
  apply le_max_right,
end

end xena --hide