/-
Copyright (c) 2022 Yuma Mizuno. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yuma Mizuno
-/
import category_theory.bicategory.coherence

/-!
# A `coherence` tactic for bicategories, and `⊗≫` (composition up to associators)

We provide a `coherence` tactic,
which proves that any two 2-morphisms (with the same source and target)
in a bicategory which are built out of associators and unitors
are equal.

We also provide `f ⊗≫ g`, the `bicategorical_comp` operation,
which automatically inserts associators and unitors as needed
to make the target of `f` match the source of `g`.

This file mainly deals with the type class setup for the coherence tactic. The actual front end
tactic is given in `category_theory/monooidal/coherence.lean` at the same time as the coherence
tactic for monoidal categories.
-/

noncomputable theory

universes w v u

open category_theory
open category_theory.free_bicategory
open_locale bicategory

variables {B : Type u} [bicategory.{w v} B] {a b c d e : B}

namespace category_theory.bicategory

/-- A typeclass carrying a choice of lift of a 1-morphism from `B` to `free_bicategory B`. -/
class lift_hom {a b : B} (f : a ⟶ b) :=
(lift : of.obj a ⟶ of.obj b)

instance lift_hom_id : lift_hom (𝟙 a) := { lift := 𝟙 (of.obj a), }
instance lift_hom_comp (f : a ⟶ b) (g : b ⟶ c) [lift_hom f] [lift_hom g] : lift_hom (f ≫ g) :=
{ lift := lift_hom.lift f ≫ lift_hom.lift g, }
@[priority 100]
instance lift_hom_of (f : a ⟶ b) : lift_hom f := { lift := of.map f, }

/-- A typeclass carrying a choice of lift of a 2-morphism from `B` to `free_bicategory B`. -/
class lift_hom₂ {f g : a ⟶ b} [lift_hom f] [lift_hom g] (η : f ⟶ g) :=
(lift : lift_hom.lift f ⟶ lift_hom.lift g)

instance lift_hom₂_id (f : a ⟶ b) [lift_hom f] : lift_hom₂ (𝟙 f) :=
{ lift := 𝟙 _, }
instance lift_hom₂_left_unitor_hom (f : a ⟶ b) [lift_hom f] : lift_hom₂ (λ_ f).hom :=
{ lift := (λ_ (lift_hom.lift f)).hom, }
instance lift_hom₂_left_unitor_inv (f : a ⟶ b) [lift_hom f] : lift_hom₂ (λ_ f).inv :=
{ lift := (λ_ (lift_hom.lift f)).inv, }
instance lift_hom₂_right_unitor_hom (f : a ⟶ b) [lift_hom f] : lift_hom₂ (ρ_ f).hom :=
{ lift := (ρ_ (lift_hom.lift f)).hom, }
instance lift_hom₂_right_unitor_inv (f : a ⟶ b) [lift_hom f] : lift_hom₂ (ρ_ f).inv :=
{ lift := (ρ_ (lift_hom.lift f)).inv, }
instance lift_hom₂_associator_hom (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d)
  [lift_hom f] [lift_hom g] [lift_hom h] :
  lift_hom₂ (α_ f g h).hom :=
{ lift := (α_ (lift_hom.lift f) (lift_hom.lift g) (lift_hom.lift h)).hom, }
instance lift_hom₂_associator_inv (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d)
  [lift_hom f] [lift_hom g] [lift_hom h] :
  lift_hom₂ (α_ f g h).inv :=
{ lift := (α_ (lift_hom.lift f) (lift_hom.lift g) (lift_hom.lift h)).inv, }
instance lift_hom₂_comp {f g h : a ⟶ b} [lift_hom f] [lift_hom g] [lift_hom h]
  (η : f ⟶ g) (θ : g ⟶ h) [lift_hom₂ η] [lift_hom₂ θ] : lift_hom₂ (η ≫ θ) :=
{ lift := lift_hom₂.lift η ≫ lift_hom₂.lift θ }
instance lift_hom₂_whisker_left (f : a ⟶ b) [lift_hom f] {g h : b ⟶ c} (η : g ⟶ h)
  [lift_hom g] [lift_hom h] [lift_hom₂ η] : lift_hom₂ (f ◁ η) :=
{ lift := lift_hom.lift f ◁ lift_hom₂.lift η }
instance lift_hom₂_whisker_right {f g : a ⟶ b} (η : f ⟶ g) [lift_hom f] [lift_hom g] [lift_hom₂ η]
  {h : b ⟶ c} [lift_hom h] : lift_hom₂ (η ▷ h) :=
{ lift := lift_hom₂.lift η ▷ lift_hom.lift h }

/--
A typeclass carrying a choice of bicategorical structural isomorphism between two objects.
Used by the `⊗≫` bicategorical composition operator, and the `coherence` tactic.
-/
class bicategorical_coherence (f g : a ⟶ b) [lift_hom f] [lift_hom g] :=
(hom [] : f ⟶ g)
[is_iso : is_iso hom . tactic.apply_instance]

attribute [instance] bicategorical_coherence.is_iso

namespace bicategorical_coherence

@[simps]
instance refl (f : a ⟶ b) [lift_hom f] : bicategorical_coherence f f := ⟨𝟙 _⟩

@[simps]
instance whisker_left
  (f : a ⟶ b) (g h : b ⟶ c) [lift_hom f][lift_hom g] [lift_hom h] [bicategorical_coherence g h] :
  bicategorical_coherence (f ≫ g) (f ≫ h) :=
⟨f ◁ bicategorical_coherence.hom g h⟩

@[simps]
instance whisker_right
  (f g : a ⟶ b) (h : b ⟶ c) [lift_hom f] [lift_hom g] [lift_hom h] [bicategorical_coherence f g] :
  bicategorical_coherence (f ≫ h) (g ≫ h) :=
⟨bicategorical_coherence.hom f g ▷ h⟩

@[simps]
instance tensor_right (f : a ⟶ b) (g : b ⟶ b) [lift_hom f] [lift_hom g]
  [bicategorical_coherence (𝟙 b) g] :
  bicategorical_coherence f (f ≫ g) :=
⟨(ρ_ f).inv ≫ (f ◁ bicategorical_coherence.hom (𝟙 b) g)⟩

@[simps]
instance tensor_right' (f : a ⟶ b) (g : b ⟶ b) [lift_hom f] [lift_hom g]
  [bicategorical_coherence g (𝟙 b)] :
  bicategorical_coherence (f ≫ g) f :=
⟨(f ◁ bicategorical_coherence.hom g (𝟙 b)) ≫ (ρ_ f).hom⟩

@[simps]
instance left (f g : a ⟶ b) [lift_hom f] [lift_hom g] [bicategorical_coherence f g] :
  bicategorical_coherence (𝟙 a ≫ f) g :=
⟨(λ_ f).hom ≫ bicategorical_coherence.hom f g⟩

@[simps]
instance left' (f g : a ⟶ b) [lift_hom f] [lift_hom g] [bicategorical_coherence f g] :
  bicategorical_coherence f (𝟙 a ≫ g) :=
⟨bicategorical_coherence.hom f g ≫ (λ_ g).inv⟩

@[simps]
instance right (f g : a ⟶ b) [lift_hom f] [lift_hom g] [bicategorical_coherence f g] :
  bicategorical_coherence (f ≫ 𝟙 b) g :=
⟨(ρ_ f).hom ≫ bicategorical_coherence.hom f g⟩

@[simps]
instance right' (f g : a ⟶ b) [lift_hom f] [lift_hom g] [bicategorical_coherence f g] :
  bicategorical_coherence f (g ≫ 𝟙 b) :=
⟨bicategorical_coherence.hom f g ≫ (ρ_ g).inv⟩

@[simps]
instance assoc (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) (i : a ⟶ d)
  [lift_hom f] [lift_hom g] [lift_hom h] [lift_hom i] [bicategorical_coherence (f ≫ (g ≫ h)) i] :
  bicategorical_coherence ((f ≫ g) ≫ h) i :=
⟨(α_ f g h).hom ≫ bicategorical_coherence.hom (f ≫ (g ≫ h)) i⟩

@[simps]
instance assoc' (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) (i : a ⟶ d)
  [lift_hom f] [lift_hom g] [lift_hom h] [lift_hom i] [bicategorical_coherence i (f ≫ (g ≫ h))] :
  bicategorical_coherence i ((f ≫ g) ≫ h) :=
⟨bicategorical_coherence.hom i (f ≫ (g ≫ h)) ≫ (α_ f g h).inv⟩

end bicategorical_coherence

/-- Construct an isomorphism between two objects in a bicategorical category
out of unitors and associators. -/
def bicategorical_iso (f g : a ⟶ b) [lift_hom f] [lift_hom g] [bicategorical_coherence f g] :
  f ≅ g :=
as_iso (bicategorical_coherence.hom f g)

/-- Compose two morphisms in a bicategorical category,
inserting unitors and associators between as necessary. -/
def bicategorical_comp {f g h i : a ⟶ b} [lift_hom g] [lift_hom h]
  [bicategorical_coherence g h] (η : f ⟶ g) (θ : h ⟶ i) : f ⟶ i :=
η ≫ bicategorical_coherence.hom g h ≫ θ

localized "infixr (name := bicategorical_comp) ` ⊗≫ `:80 :=
  category_theory.bicategory.bicategorical_comp" in bicategory -- type as \ot \gg

/-- Compose two isomorphisms in a bicategorical category,
inserting unitors and associators between as necessary. -/
def bicategorical_iso_comp {f g h i : a ⟶ b} [lift_hom g] [lift_hom h]
  [bicategorical_coherence g h] (η : f ≅ g) (θ : h ≅ i) : f ≅ i :=
η ≪≫ as_iso (bicategorical_coherence.hom g h) ≪≫ θ

localized "infixr (name := bicategorical_iso_comp) ` ≪⊗≫ `:80 :=
  category_theory.bicategory.bicategorical_iso_comp" in bicategory -- type as \ot \gg

example {f' : a ⟶ d} {f : a ⟶ b} {g : b ⟶ c} {h : c ⟶ d} {h' : a ⟶ d}
  (η : f' ⟶ f ≫ (g ≫ h)) (θ : (f ≫ g) ≫ h ⟶ h') : f' ⟶ h' := η ⊗≫ θ

-- To automatically insert unitors/associators at the beginning or end,
-- you can use `η ⊗≫ 𝟙 _`
example {f' : a ⟶ d } {f : a ⟶ b} {g : b ⟶ c} {h : c ⟶ d} (η : f' ⟶ (f ≫ g) ≫ h) :
  f' ⟶ f ≫ (g ≫ h) := η ⊗≫ 𝟙 _

@[simp] lemma bicategorical_comp_refl {f g h : a ⟶ b} (η : f ⟶ g) (θ : g ⟶ h) :
  η ⊗≫ θ = η ≫ θ :=
by { dsimp [bicategorical_comp], simp, }

end category_theory.bicategory

open category_theory.bicategory

namespace tactic

setup_tactic_parser

/-- Coherence tactic for bicategories. -/
meta def bicategorical_coherence : tactic unit :=
focus1 $
do
  o ← get_options, set_options $ o.set_nat `class.instance_max_depth 128,
  try `[dsimp],
  `(%%lhs = %%rhs) ← target,
  to_expr  ``((free_bicategory.lift (prefunctor.id _)).map₂ (lift_hom₂.lift %%lhs) =
    (free_bicategory.lift (prefunctor.id _)).map₂ (lift_hom₂.lift %%rhs))
    >>= tactic.change,
  congr

namespace bicategory

/-- Simp lemmas for rewriting a 2-morphism into a normal form. -/
meta def whisker_simps : tactic unit :=
`[simp only [
    category_theory.category.assoc,
    category_theory.bicategory.comp_whisker_left,
    category_theory.bicategory.id_whisker_left,
    category_theory.bicategory.whisker_right_comp,
    category_theory.bicategory.whisker_right_id,
    category_theory.bicategory.whisker_left_comp,
    category_theory.bicategory.whisker_left_id,
    category_theory.bicategory.comp_whisker_right,
    category_theory.bicategory.id_whisker_right,
    category_theory.bicategory.whisker_assoc]]

namespace coherence

/--
Auxiliary simp lemma for the `coherence` tactic:
this move brackets to the left in order to expose a maximal prefix
built out of unitors and associators.
-/
-- We have unused typeclass arguments here.
-- They are intentional, to ensure that `simp only [assoc_lift_hom₂]` only left associates
-- bicategorical structural morphisms.
@[nolint unused_arguments]
lemma assoc_lift_hom₂ {f g h i : a ⟶ b} [lift_hom f] [lift_hom g] [lift_hom h]
  (η : f ⟶ g) (θ : g ⟶ h) (ι : h ⟶ i) [lift_hom₂ η] [lift_hom₂ θ] :
  η ≫ (θ ≫ ι) = (η ≫ θ) ≫ ι :=
(category.assoc _ _ _).symm

end coherence

end bicategory

end tactic


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

import ring_theory.integrally_closed
import ring_theory.localization.num_denom
import ring_theory.polynomial.scale_roots

/-!
# Rational root theorem and integral root theorem

This file contains the rational root theorem and integral root theorem.
The rational root theorem for a unique factorization domain `A`
with localization `S`, states that the roots of `p : polynomial A` in `A`'s
field of fractions are of the form `x / y` with `x y : A`, `x ∣ p.coeff 0` and
`y ∣ p.leading_coeff`.
The corollary is the integral root theorem `is_integer_of_is_root_of_monic`:
if `p` is monic, its roots must be integers.
Finally, we use this to show unique factorization domains are integrally closed.

## References

 * https://en.wikipedia.org/wiki/Rational_root_theorem
-/

open_locale polynomial
section scale_roots

variables {A K R S : Type*} [comm_ring A] [field K] [comm_ring R] [comm_ring S]
variables {M : submonoid A} [algebra A S] [is_localization M S] [algebra A K] [is_fraction_ring A K]

open finsupp is_fraction_ring is_localization polynomial

lemma scale_roots_aeval_eq_zero_of_aeval_mk'_eq_zero {p : A[X]} {r : A} {s : M}
  (hr : aeval (mk' S r s) p = 0) :
  aeval (algebra_map A S r) (scale_roots p s) = 0 :=
begin
  convert scale_roots_eval₂_eq_zero (algebra_map A S) hr,
  rw [aeval_def, mk'_spec' _ r s]
end

variables [is_domain A]

lemma num_is_root_scale_roots_of_aeval_eq_zero
  [unique_factorization_monoid A] {p : A[X]} {x : K} (hr : aeval x p = 0) :
  is_root (scale_roots p (denom A x)) (num A x) :=
begin
  apply is_root_of_eval₂_map_eq_zero (is_fraction_ring.injective A K),
  refine scale_roots_aeval_eq_zero_of_aeval_mk'_eq_zero _,
  rw mk'_num_denom,
  exact hr
end

end scale_roots

section rational_root_theorem

variables {A K : Type*} [comm_ring A] [is_domain A] [unique_factorization_monoid A] [field K]
variables [algebra A K] [is_fraction_ring A K]

open is_fraction_ring is_localization polynomial unique_factorization_monoid

/-- Rational root theorem part 1:
if `r : f.codomain` is a root of a polynomial over the ufd `A`,
then the numerator of `r` divides the constant coefficient -/
theorem num_dvd_of_is_root {p : A[X]} {r : K} (hr : aeval r p = 0) :
  num A r ∣ p.coeff 0 :=
begin
  suffices : num A r ∣ (scale_roots p (denom A r)).coeff 0,
  { simp only [coeff_scale_roots, tsub_zero] at this,
    haveI := classical.prop_decidable,
    by_cases hr : num A r = 0,
    { obtain ⟨u, hu⟩ := (is_unit_denom_of_num_eq_zero hr).pow p.nat_degree,
      rw ←hu at this,
      exact units.dvd_mul_right.mp this },
    { refine dvd_of_dvd_mul_left_of_no_prime_factors hr _ this,
      intros q dvd_num dvd_denom_pow hq,
      apply hq.not_unit,
      exact num_denom_reduced A r dvd_num (hq.dvd_of_dvd_pow dvd_denom_pow) } },
  convert dvd_term_of_is_root_of_dvd_terms 0 (num_is_root_scale_roots_of_aeval_eq_zero hr) _,
  { rw [pow_zero, mul_one] },
  intros j hj,
  apply dvd_mul_of_dvd_right,
  convert pow_dvd_pow (num A r) (nat.succ_le_of_lt (bot_lt_iff_ne_bot.mpr hj)),
  exact (pow_one _).symm
end

/-- Rational root theorem part 2:
if `r : f.codomain` is a root of a polynomial over the ufd `A`,
then the denominator of `r` divides the leading coefficient -/
theorem denom_dvd_of_is_root {p : A[X]} {r : K} (hr : aeval r p = 0) :
  (denom A r : A) ∣ p.leading_coeff :=
begin
  suffices : (denom A r : A) ∣ p.leading_coeff * num A r ^ p.nat_degree,
  { refine dvd_of_dvd_mul_left_of_no_prime_factors
      (mem_non_zero_divisors_iff_ne_zero.mp (denom A r).2) _ this,
    intros q dvd_denom dvd_num_pow hq,
    apply hq.not_unit,
    exact num_denom_reduced A r (hq.dvd_of_dvd_pow dvd_num_pow) dvd_denom },
  rw ←coeff_scale_roots_nat_degree,
  apply dvd_term_of_is_root_of_dvd_terms _ (num_is_root_scale_roots_of_aeval_eq_zero hr),
  intros j hj,
  by_cases h : j < p.nat_degree,
  { rw coeff_scale_roots,
    refine (dvd_mul_of_dvd_right _ _).mul_right _,
    convert pow_dvd_pow _ (nat.succ_le_iff.mpr (lt_tsub_iff_left.mpr _)),
    { exact (pow_one _).symm },
    simpa using h },
  rw [←nat_degree_scale_roots p (denom A r)] at *,
  rw [coeff_eq_zero_of_nat_degree_lt (lt_of_le_of_ne (le_of_not_gt h) hj.symm), zero_mul],
  exact dvd_zero _
end

/-- Integral root theorem:
if `r : f.codomain` is a root of a monic polynomial over the ufd `A`,
then `r` is an integer -/
theorem is_integer_of_is_root_of_monic {p : A[X]} (hp : monic p) {r : K}
  (hr : aeval r p = 0) : is_integer A r :=
is_integer_of_is_unit_denom (is_unit_of_dvd_one _ (hp ▸ denom_dvd_of_is_root hr))

namespace unique_factorization_monoid

lemma integer_of_integral {x : K} :
  is_integral A x → is_integer A x :=
λ ⟨p, hp, hx⟩, is_integer_of_is_root_of_monic hp hx

@[priority 100] -- See library note [lower instance priority]
instance : is_integrally_closed A :=
⟨λ x, integer_of_integral⟩

end unique_factorization_monoid

end rational_root_theorem


/-
Copyright (c) 2022 Violeta Hernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Violeta Hernández

! This file was ported from Lean 3 source module data.finsupp.alist
! leanprover-community/mathlib commit 0ebfdb71919ac6ca5d7fbc61a082fa2519556818
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Finsupp.Basic
import Mathbin.Data.List.Alist

/-!
# Connections between `finsupp` and `alist`

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

## Main definitions

* `finsupp.to_alist`
* `alist.lookup_finsupp`: converts an association list into a finitely supported function
  via `alist.lookup`, sending absent keys to zero.

-/

namespace Finsupp

variable {α M : Type _} [Zero M]

#print Finsupp.toAList /-
/-- Produce an association list for the finsupp over its support using choice. -/
@[simps]
noncomputable def toAList (f : α →₀ M) : AList fun x : α => M :=
  ⟨f.graph.toList.map Prod.toSigma,
    by
    rw [List.NodupKeys, List.keys, List.map_map, Prod.fst_comp_toSigma, List.nodup_map_iff_inj_on]
    · rintro ⟨b, m⟩ hb ⟨c, n⟩ hc (rfl : b = c)
      rw [Finset.mem_toList, Finsupp.mem_graph_iff] at hb hc
      dsimp at hb hc
      rw [← hc.1, hb.1]
    · apply Finset.nodup_toList⟩
#align finsupp.to_alist Finsupp.toAList
-/

/- warning: finsupp.to_alist_keys_to_finset -> Finsupp.toAList_keys_toFinset is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {M : Type.{u2}} [_inst_1 : Zero.{u2} M] [_inst_2 : DecidableEq.{succ u1} α] (f : Finsupp.{u1, u2} α M _inst_1), Eq.{succ u1} (Finset.{u1} α) (List.toFinset.{u1} α (fun (a : α) (b : α) => _inst_2 a b) (AList.keys.{u1, u2} α (fun (x : α) => M) (Finsupp.toAList.{u1, u2} α M _inst_1 f))) (Finsupp.support.{u1, u2} α M _inst_1 f)
but is expected to have type
  forall {α : Type.{u2}} {M : Type.{u1}} [_inst_1 : Zero.{u1} M] [_inst_2 : DecidableEq.{succ u2} α] (f : Finsupp.{u2, u1} α M _inst_1), Eq.{succ u2} (Finset.{u2} α) (List.toFinset.{u2} α (fun (a : α) (b : α) => _inst_2 a b) (AList.keys.{u2, u1} α (fun (x : α) => M) (Finsupp.toAList.{u2, u1} α M _inst_1 f))) (Finsupp.support.{u2, u1} α M _inst_1 f)
Case conversion may be inaccurate. Consider using '#align finsupp.to_alist_keys_to_finset Finsupp.toAList_keys_toFinsetₓ'. -/
@[simp]
theorem toAList_keys_toFinset [DecidableEq α] (f : α →₀ M) : f.toAList.keys.toFinset = f.support :=
  by
  ext
  simp [to_alist, AList.mem_keys, AList.keys, List.keys]
#align finsupp.to_alist_keys_to_finset Finsupp.toAList_keys_toFinset

/- warning: finsupp.mem_to_alist -> Finsupp.mem_toAlist is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {M : Type.{u2}} [_inst_1 : Zero.{u2} M] {f : Finsupp.{u1, u2} α M _inst_1} {x : α}, Iff (Membership.Mem.{u1, max u1 u2} α (AList.{u1, u2} α (fun (x : α) => M)) (AList.hasMem.{u1, u2} α (fun (x : α) => M)) x (Finsupp.toAList.{u1, u2} α M _inst_1 f)) (Ne.{succ u2} M (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (Finsupp.{u1, u2} α M _inst_1) (fun (_x : Finsupp.{u1, u2} α M _inst_1) => α -> M) (Finsupp.coeFun.{u1, u2} α M _inst_1) f x) (OfNat.ofNat.{u2} M 0 (OfNat.mk.{u2} M 0 (Zero.zero.{u2} M _inst_1))))
but is expected to have type
  forall {α : Type.{u2}} {M : Type.{u1}} [_inst_1 : Zero.{u1} M] {f : Finsupp.{u2, u1} α M _inst_1} {x : α}, Iff (Membership.mem.{u2, max u2 u1} α (AList.{u2, u1} α (fun (x : α) => M)) (AList.instMembershipAList.{u2, u1} α (fun (x : α) => M)) x (Finsupp.toAList.{u2, u1} α M _inst_1 f)) (Ne.{succ u1} ((fun (x._@.Mathlib.Data.Finsupp.Defs._hyg.779 : α) => M) x) (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (Finsupp.{u2, u1} α M _inst_1) α (fun (_x : α) => (fun (x._@.Mathlib.Data.Finsupp.Defs._hyg.779 : α) => M) _x) (Finsupp.funLike.{u2, u1} α M _inst_1) f x) (OfNat.ofNat.{u1} ((fun (x._@.Mathlib.Data.Finsupp.Defs._hyg.779 : α) => M) x) 0 (Zero.toOfNat0.{u1} ((fun (x._@.Mathlib.Data.Finsupp.Defs._hyg.779 : α) => M) x) _inst_1)))
Case conversion may be inaccurate. Consider using '#align finsupp.mem_to_alist Finsupp.mem_toAlistₓ'. -/
@[simp]
theorem mem_toAlist {f : α →₀ M} {x : α} : x ∈ f.toAList ↔ f x ≠ 0 := by
  classical rw [AList.mem_keys, ← List.mem_toFinset, to_alist_keys_to_finset, mem_support_iff]
#align finsupp.mem_to_alist Finsupp.mem_toAlist

end Finsupp

namespace AList

variable {α M : Type _} [Zero M]

open List

#print AList.lookupFinsupp /-
/-- Converts an association list into a finitely supported function via `alist.lookup`, sending
absent keys to zero. -/
noncomputable def lookupFinsupp (l : AList fun x : α => M) : α →₀ M
    where
  support := by
    haveI := Classical.decEq α <;> haveI := Classical.decEq M <;>
      exact (l.1.filterₓ fun x => Sigma.snd x ≠ 0).keys.toFinset
  toFun a :=
    haveI := Classical.decEq α
    (l.lookup a).getD 0
  mem_support_toFun a := by
    classical
      simp_rw [mem_to_finset, List.mem_keys, List.mem_filter, ← mem_lookup_iff]
      cases lookup a l <;> simp
#align alist.lookup_finsupp AList.lookupFinsupp
-/

/- warning: alist.lookup_finsupp_apply -> AList.lookupFinsupp_apply is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {M : Type.{u2}} [_inst_1 : Zero.{u2} M] [_inst_2 : DecidableEq.{succ u1} α] (l : AList.{u1, u2} α (fun (x : α) => M)) (a : α), Eq.{succ u2} M (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (Finsupp.{u1, u2} α M _inst_1) (fun (_x : Finsupp.{u1, u2} α M _inst_1) => α -> M) (Finsupp.coeFun.{u1, u2} α M _inst_1) (AList.lookupFinsupp.{u1, u2} α M _inst_1 l) a) (Option.getD.{u2} M (AList.lookup.{u1, u2} α (fun (x : α) => M) (fun (a : α) (b : α) => _inst_2 a b) a l) (OfNat.ofNat.{u2} M 0 (OfNat.mk.{u2} M 0 (Zero.zero.{u2} M _inst_1))))
but is expected to have type
  forall {α : Type.{u2}} {M : Type.{u1}} [_inst_1 : Zero.{u1} M] [_inst_2 : DecidableEq.{succ u2} α] (l : AList.{u2, u1} α (fun (x : α) => M)) (a : α), Eq.{succ u1} ((fun (x._@.Mathlib.Data.Finsupp.Defs._hyg.779 : α) => M) a) (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (Finsupp.{u2, u1} α M _inst_1) α (fun (_x : α) => (fun (x._@.Mathlib.Data.Finsupp.Defs._hyg.779 : α) => M) _x) (Finsupp.funLike.{u2, u1} α M _inst_1) (AList.lookupFinsupp.{u2, u1} α M _inst_1 l) a) (Option.getD.{u1} M (AList.lookup.{u2, u1} α (fun (x : α) => M) (fun (a : α) (b : α) => _inst_2 a b) a l) (OfNat.ofNat.{u1} M 0 (Zero.toOfNat0.{u1} M _inst_1)))
Case conversion may be inaccurate. Consider using '#align alist.lookup_finsupp_apply AList.lookupFinsupp_applyₓ'. -/
@[simp]
theorem lookupFinsupp_apply [DecidableEq α] (l : AList fun x : α => M) (a : α) :
    l.lookupFinsupp a = (l.dlookup a).getD 0 := by convert rfl
#align alist.lookup_finsupp_apply AList.lookupFinsupp_apply

/- warning: alist.lookup_finsupp_support -> AList.lookupFinsupp_support is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {M : Type.{u2}} [_inst_1 : Zero.{u2} M] [_inst_2 : DecidableEq.{succ u1} α] [_inst_3 : DecidableEq.{succ u2} M] (l : AList.{u1, u2} α (fun (x : α) => M)), Eq.{succ u1} (Finset.{u1} α) (Finsupp.support.{u1, u2} α M _inst_1 (AList.lookupFinsupp.{u1, u2} α M _inst_1 l)) (List.toFinset.{u1} α (fun (a : α) (b : α) => _inst_2 a b) (List.keys.{u1, u2} α (fun (x : α) => M) (List.filterₓ.{max u1 u2} (Sigma.{u1, u2} α (fun (x : α) => M)) (fun (x : Sigma.{u1, u2} α (fun (x : α) => M)) => Ne.{succ u2} M (Sigma.snd.{u1, u2} α (fun (x : α) => M) x) (OfNat.ofNat.{u2} M 0 (OfNat.mk.{u2} M 0 (Zero.zero.{u2} M _inst_1)))) (fun (a : Sigma.{u1, u2} α (fun (x : α) => M)) => Ne.decidable.{succ u2} ((fun (x : α) => M) (Sigma.fst.{u1, u2} α (fun (x : α) => M) a)) (fun (a : M) (b : M) => _inst_3 a b) (Sigma.snd.{u1, u2} α (fun (x : α) => M) a) (OfNat.ofNat.{u2} M 0 (OfNat.mk.{u2} M 0 (Zero.zero.{u2} M _inst_1)))) (AList.entries.{u1, u2} α (fun (x : α) => M) l))))
but is expected to have type
  forall {α : Type.{u2}} {M : Type.{u1}} [_inst_1 : Zero.{u1} M] [_inst_2 : DecidableEq.{succ u2} α] [_inst_3 : DecidableEq.{succ u1} M] (l : AList.{u2, u1} α (fun (x : α) => M)), Eq.{succ u2} (Finset.{u2} α) (Finsupp.support.{u2, u1} α M _inst_1 (AList.lookupFinsupp.{u2, u1} α M _inst_1 l)) (List.toFinset.{u2} α (fun (a : α) (b : α) => _inst_2 a b) (List.keys.{u2, u1} α (fun (x : α) => M) (List.filter.{max u1 u2} (Sigma.{u2, u1} α (fun (_x : α) => M)) (fun (a : Sigma.{u2, u1} α (fun (x : α) => M)) => Decidable.decide (Ne.{succ u1} M (Sigma.snd.{u2, u1} α (fun (_x : α) => M) a) (OfNat.ofNat.{u1} M 0 (Zero.toOfNat0.{u1} M _inst_1))) (instDecidableNot (Eq.{succ u1} M (Sigma.snd.{u2, u1} α (fun (_x : α) => M) a) (OfNat.ofNat.{u1} M 0 (Zero.toOfNat0.{u1} M _inst_1))) (_inst_3 (Sigma.snd.{u2, u1} α (fun (_x : α) => M) a) (OfNat.ofNat.{u1} M 0 (Zero.toOfNat0.{u1} M _inst_1))))) (AList.entries.{u2, u1} α (fun (x : α) => M) l))))
Case conversion may be inaccurate. Consider using '#align alist.lookup_finsupp_support AList.lookupFinsupp_supportₓ'. -/
@[simp]
theorem lookupFinsupp_support [DecidableEq α] [DecidableEq M] (l : AList fun x : α => M) :
    l.lookupFinsupp.support = (l.1.filterₓ fun x => Sigma.snd x ≠ 0).keys.toFinset := by convert rfl
#align alist.lookup_finsupp_support AList.lookupFinsupp_support

/- warning: alist.lookup_finsupp_eq_iff_of_ne_zero -> AList.lookupFinsupp_eq_iff_of_ne_zero is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {M : Type.{u2}} [_inst_1 : Zero.{u2} M] [_inst_2 : DecidableEq.{succ u1} α] {l : AList.{u1, u2} α (fun (x : α) => M)} {a : α} {x : M}, (Ne.{succ u2} M x (OfNat.ofNat.{u2} M 0 (OfNat.mk.{u2} M 0 (Zero.zero.{u2} M _inst_1)))) -> (Iff (Eq.{succ u2} M (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (Finsupp.{u1, u2} α M _inst_1) (fun (_x : Finsupp.{u1, u2} α M _inst_1) => α -> M) (Finsupp.coeFun.{u1, u2} α M _inst_1) (AList.lookupFinsupp.{u1, u2} α M _inst_1 l) a) x) (Membership.Mem.{u2, u2} M (Option.{u2} M) (Option.hasMem.{u2} M) x (AList.lookup.{u1, u2} α (fun (x : α) => M) (fun (a : α) (b : α) => _inst_2 a b) a l)))
but is expected to have type
  forall {α : Type.{u2}} {M : Type.{u1}} [_inst_1 : Zero.{u1} M] [_inst_2 : DecidableEq.{succ u2} α] {l : AList.{u2, u1} α (fun (x : α) => M)} {a : α} {x : M}, (Ne.{succ u1} M x (OfNat.ofNat.{u1} M 0 (Zero.toOfNat0.{u1} M _inst_1))) -> (Iff (Eq.{succ u1} ((fun (x._@.Mathlib.Data.Finsupp.Defs._hyg.779 : α) => M) a) (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (Finsupp.{u2, u1} α M _inst_1) α (fun (_x : α) => (fun (x._@.Mathlib.Data.Finsupp.Defs._hyg.779 : α) => M) _x) (Finsupp.funLike.{u2, u1} α M _inst_1) (AList.lookupFinsupp.{u2, u1} α M _inst_1 l) a) x) (Membership.mem.{u1, u1} M (Option.{u1} M) (Option.instMembershipOption.{u1} M) x (AList.lookup.{u2, u1} α (fun (x : α) => M) (fun (a : α) (b : α) => _inst_2 a b) a l)))
Case conversion may be inaccurate. Consider using '#align alist.lookup_finsupp_eq_iff_of_ne_zero AList.lookupFinsupp_eq_iff_of_ne_zeroₓ'. -/
theorem lookupFinsupp_eq_iff_of_ne_zero [DecidableEq α] {l : AList fun x : α => M} {a : α} {x : M}
    (hx : x ≠ 0) : l.lookupFinsupp a = x ↔ x ∈ l.dlookup a :=
  by
  rw [lookup_finsupp_apply]
  cases' lookup a l with m <;> simp [hx.symm]
#align alist.lookup_finsupp_eq_iff_of_ne_zero AList.lookupFinsupp_eq_iff_of_ne_zero

/- warning: alist.lookup_finsupp_eq_zero_iff -> AList.lookupFinsupp_eq_zero_iff is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {M : Type.{u2}} [_inst_1 : Zero.{u2} M] [_inst_2 : DecidableEq.{succ u1} α] {l : AList.{u1, u2} α (fun (x : α) => M)} {a : α}, Iff (Eq.{succ u2} M (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (Finsupp.{u1, u2} α M _inst_1) (fun (_x : Finsupp.{u1, u2} α M _inst_1) => α -> M) (Finsupp.coeFun.{u1, u2} α M _inst_1) (AList.lookupFinsupp.{u1, u2} α M _inst_1 l) a) (OfNat.ofNat.{u2} M 0 (OfNat.mk.{u2} M 0 (Zero.zero.{u2} M _inst_1)))) (Or (Not (Membership.Mem.{u1, max u1 u2} α (AList.{u1, u2} α (fun (x : α) => M)) (AList.hasMem.{u1, u2} α (fun (x : α) => M)) a l)) (Membership.Mem.{u2, u2} M (Option.{u2} M) (Option.hasMem.{u2} M) (OfNat.ofNat.{u2} M 0 (OfNat.mk.{u2} M 0 (Zero.zero.{u2} M _inst_1))) (AList.lookup.{u1, u2} α (fun (x : α) => M) (fun (a : α) (b : α) => _inst_2 a b) a l)))
but is expected to have type
  forall {α : Type.{u2}} {M : Type.{u1}} [_inst_1 : Zero.{u1} M] [_inst_2 : DecidableEq.{succ u2} α] {l : AList.{u2, u1} α (fun (x : α) => M)} {a : α}, Iff (Eq.{succ u1} ((fun (x._@.Mathlib.Data.Finsupp.Defs._hyg.779 : α) => M) a) (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (Finsupp.{u2, u1} α M _inst_1) α (fun (_x : α) => (fun (x._@.Mathlib.Data.Finsupp.Defs._hyg.779 : α) => M) _x) (Finsupp.funLike.{u2, u1} α M _inst_1) (AList.lookupFinsupp.{u2, u1} α M _inst_1 l) a) (OfNat.ofNat.{u1} ((fun (x._@.Mathlib.Data.Finsupp.Defs._hyg.779 : α) => M) a) 0 (Zero.toOfNat0.{u1} ((fun (x._@.Mathlib.Data.Finsupp.Defs._hyg.779 : α) => M) a) _inst_1))) (Or (Not (Membership.mem.{u2, max u2 u1} α (AList.{u2, u1} α (fun (x : α) => M)) (AList.instMembershipAList.{u2, u1} α (fun (x : α) => M)) a l)) (Membership.mem.{u1, u1} M (Option.{u1} M) (Option.instMembershipOption.{u1} M) (OfNat.ofNat.{u1} M 0 (Zero.toOfNat0.{u1} M _inst_1)) (AList.lookup.{u2, u1} α (fun (x : α) => M) (fun (a : α) (b : α) => _inst_2 a b) a l)))
Case conversion may be inaccurate. Consider using '#align alist.lookup_finsupp_eq_zero_iff AList.lookupFinsupp_eq_zero_iffₓ'. -/
theorem lookupFinsupp_eq_zero_iff [DecidableEq α] {l : AList fun x : α => M} {a : α} :
    l.lookupFinsupp a = 0 ↔ a ∉ l ∨ (0 : M) ∈ l.dlookup a :=
  by
  rw [lookup_finsupp_apply, ← lookup_eq_none]
  cases' lookup a l with m <;> simp
#align alist.lookup_finsupp_eq_zero_iff AList.lookupFinsupp_eq_zero_iff

/- warning: alist.empty_lookup_finsupp -> AList.empty_lookupFinsupp is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {M : Type.{u2}} [_inst_1 : Zero.{u2} M], Eq.{max (succ u1) (succ u2)} (Finsupp.{u1, u2} α M _inst_1) (AList.lookupFinsupp.{u1, u2} α M _inst_1 (EmptyCollection.emptyCollection.{max u1 u2} (AList.{u1, u2} α (fun (x : α) => M)) (AList.hasEmptyc.{u1, u2} α (fun (x : α) => M)))) (OfNat.ofNat.{max u1 u2} (Finsupp.{u1, u2} α M _inst_1) 0 (OfNat.mk.{max u1 u2} (Finsupp.{u1, u2} α M _inst_1) 0 (Zero.zero.{max u1 u2} (Finsupp.{u1, u2} α M _inst_1) (Finsupp.zero.{u1, u2} α M _inst_1))))
but is expected to have type
  forall {α : Type.{u2}} {M : Type.{u1}} [_inst_1 : Zero.{u1} M], Eq.{max (succ u2) (succ u1)} (Finsupp.{u2, u1} α M _inst_1) (AList.lookupFinsupp.{u2, u1} α M _inst_1 (EmptyCollection.emptyCollection.{max u2 u1} (AList.{u2, u1} α (fun (x : α) => M)) (AList.instEmptyCollectionAList.{u2, u1} α (fun (x : α) => M)))) (OfNat.ofNat.{max u2 u1} (Finsupp.{u2, u1} α M _inst_1) 0 (Zero.toOfNat0.{max u2 u1} (Finsupp.{u2, u1} α M _inst_1) (Finsupp.zero.{u2, u1} α M _inst_1)))
Case conversion may be inaccurate. Consider using '#align alist.empty_lookup_finsupp AList.empty_lookupFinsuppₓ'. -/
@[simp]
theorem empty_lookupFinsupp : lookupFinsupp (∅ : AList fun x : α => M) = 0 := by
  classical
    ext
    simp
#align alist.empty_lookup_finsupp AList.empty_lookupFinsupp

/- warning: alist.insert_lookup_finsupp -> AList.insert_lookupFinsupp is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {M : Type.{u2}} [_inst_1 : Zero.{u2} M] [_inst_2 : DecidableEq.{succ u1} α] (l : AList.{u1, u2} α (fun (x : α) => M)) (a : α) (m : M), Eq.{max (succ u1) (succ u2)} (Finsupp.{u1, u2} α M _inst_1) (AList.lookupFinsupp.{u1, u2} α M _inst_1 (AList.insert.{u1, u2} α (fun (a : α) => M) (fun (a : α) (b : α) => _inst_2 a b) a m l)) (Finsupp.update.{u1, u2} α M _inst_1 (AList.lookupFinsupp.{u1, u2} α M _inst_1 l) a m)
but is expected to have type
  forall {α : Type.{u2}} {M : Type.{u1}} [_inst_1 : Zero.{u1} M] [_inst_2 : DecidableEq.{succ u2} α] (l : AList.{u2, u1} α (fun (x : α) => M)) (a : α) (m : M), Eq.{max (succ u2) (succ u1)} (Finsupp.{u2, u1} α M _inst_1) (AList.lookupFinsupp.{u2, u1} α M _inst_1 (AList.insert.{u2, u1} α (fun (a : α) => M) (fun (a : α) (b : α) => _inst_2 a b) a m l)) (Finsupp.update.{u2, u1} α M _inst_1 (AList.lookupFinsupp.{u2, u1} α M _inst_1 l) a m)
Case conversion may be inaccurate. Consider using '#align alist.insert_lookup_finsupp AList.insert_lookupFinsuppₓ'. -/
@[simp]
theorem insert_lookupFinsupp [DecidableEq α] (l : AList fun x : α => M) (a : α) (m : M) :
    (l.insert a m).lookupFinsupp = l.lookupFinsupp.update a m :=
  by
  ext b
  by_cases h : b = a <;> simp [h]
#align alist.insert_lookup_finsupp AList.insert_lookupFinsupp

/- warning: alist.singleton_lookup_finsupp -> AList.singleton_lookupFinsupp is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {M : Type.{u2}} [_inst_1 : Zero.{u2} M] (a : α) (m : M), Eq.{max (succ u1) (succ u2)} (Finsupp.{u1, u2} α M _inst_1) (AList.lookupFinsupp.{u1, u2} α M _inst_1 (AList.singleton.{u1, u2} α (fun (a : α) => M) a m)) (Finsupp.single.{u1, u2} α M _inst_1 a m)
but is expected to have type
  forall {α : Type.{u2}} {M : Type.{u1}} [_inst_1 : Zero.{u1} M] (a : α) (m : M), Eq.{max (succ u2) (succ u1)} (Finsupp.{u2, u1} α M _inst_1) (AList.lookupFinsupp.{u2, u1} α M _inst_1 (AList.singleton.{u2, u1} α (fun (a : α) => M) a m)) (Finsupp.single.{u2, u1} α M _inst_1 a m)
Case conversion may be inaccurate. Consider using '#align alist.singleton_lookup_finsupp AList.singleton_lookupFinsuppₓ'. -/
@[simp]
theorem singleton_lookupFinsupp (a : α) (m : M) :
    (singleton a m).lookupFinsupp = Finsupp.single a m := by classical simp [← AList.insert_empty]
#align alist.singleton_lookup_finsupp AList.singleton_lookupFinsupp

/- warning: finsupp.to_alist_lookup_finsupp -> Finsupp.toAList_lookupFinsupp is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {M : Type.{u2}} [_inst_1 : Zero.{u2} M] (f : Finsupp.{u1, u2} α M _inst_1), Eq.{max (succ u1) (succ u2)} (Finsupp.{u1, u2} α M _inst_1) (AList.lookupFinsupp.{u1, u2} α M _inst_1 (Finsupp.toAList.{u1, u2} α M _inst_1 f)) f
but is expected to have type
  forall {α : Type.{u2}} {M : Type.{u1}} [_inst_1 : Zero.{u1} M] (f : Finsupp.{u2, u1} α M _inst_1), Eq.{max (succ u2) (succ u1)} (Finsupp.{u2, u1} α M _inst_1) (AList.lookupFinsupp.{u2, u1} α M _inst_1 (Finsupp.toAList.{u2, u1} α M _inst_1 f)) f
Case conversion may be inaccurate. Consider using '#align finsupp.to_alist_lookup_finsupp Finsupp.toAList_lookupFinsuppₓ'. -/
@[simp]
theorem Finsupp.toAList_lookupFinsupp (f : α →₀ M) : f.toAList.lookupFinsupp = f :=
  by
  ext
  classical
    by_cases h : f a = 0
    · suffices f.to_alist.lookup a = none by simp [h, this]
      · simp [lookup_eq_none, h]
    · suffices f.to_alist.lookup a = some (f a) by simp [h, this]
      · apply mem_lookup_iff.2
        simpa using h
#align finsupp.to_alist_lookup_finsupp Finsupp.toAList_lookupFinsupp

/- warning: alist.lookup_finsupp_surjective -> AList.lookupFinsupp_surjective is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {M : Type.{u2}} [_inst_1 : Zero.{u2} M], Function.Surjective.{succ (max u1 u2), max (succ u1) (succ u2)} (AList.{u1, u2} α (fun (x : α) => M)) (Finsupp.{u1, u2} α M _inst_1) (AList.lookupFinsupp.{u1, u2} α M _inst_1)
but is expected to have type
  forall {α : Type.{u2}} {M : Type.{u1}} [_inst_1 : Zero.{u1} M], Function.Surjective.{max (succ u2) (succ u1), max (succ u2) (succ u1)} (AList.{u2, u1} α (fun (x : α) => M)) (Finsupp.{u2, u1} α M _inst_1) (AList.lookupFinsupp.{u2, u1} α M _inst_1)
Case conversion may be inaccurate. Consider using '#align alist.lookup_finsupp_surjective AList.lookupFinsupp_surjectiveₓ'. -/
theorem lookupFinsupp_surjective : Function.Surjective (@lookupFinsupp α M _) := fun f =>
  ⟨_, Finsupp.toAList_lookupFinsupp f⟩
#align alist.lookup_finsupp_surjective AList.lookupFinsupp_surjective

end AList


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

! This file was ported from Lean 3 source module category_theory.localization.predicate
! leanprover-community/mathlib commit 8efef279998820353694feb6ff5631ed0d309ecc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Localization.Construction

/-!

# Predicate for localized categories

In this file, a predicate `L.IsLocalization W` is introduced for a functor `L : C ⥤ D`
and `W : MorphismProperty C`: it expresses that `L` identifies `D` with the localized
category of `C` with respect to `W` (up to equivalence).

We introduce a universal property `StrictUniversalPropertyFixedTarget L W E` which
states that `L` inverts the morphisms in `W` and that all functors `C ⥤ E` inverting
`W` uniquely factors as a composition of `L ⋙ G` with `G : D ⥤ E`. Such universal
properties are inputs for the constructor `IsLocalization.mk'` for `L.IsLocalization W`.

When `L : C ⥤ D` is a localization functor for `W : MorphismProperty` (i.e. when
`[L.IsLocalization W]` holds), for any category `E`, there is
an equivalence `FunctorEquivalence L W E : (D ⥤ E) ≌ (W.FunctorsInverting E)`
that is induced by the composition with the functor `L`. When two functors
`F : C ⥤ E` and `F' : D ⥤ E` correspond via this equivalence, we shall say
that `F'` lifts `F`, and the associated isomorphism `L ⋙ F' ≅ F` is the
datum that is part of the class `Lifting L W F F'`. The functions
`liftNatTrans` and `liftNatIso` can be used to lift natural transformations
and natural isomorphisms between functors.

-/

noncomputable section

namespace CategoryTheory

open Category

variable {C D : Type _} [Category C] [Category D] (L : C ⥤ D) (W : MorphismProperty C) (E : Type _)
  [Category E]

namespace Functor

/-- The predicate expressing that, up to equivalence, a functor `L : C ⥤ D`
identifies the category `D` with the localized category of `C` with respect
to `W : MorphismProperty C`. -/
class IsLocalization : Prop where
  /-- the functor inverts the given `MorphismProperty` -/
  inverts : W.IsInvertedBy L
  /-- the induced functor from the constructed localized category is an equivalence -/
  nonempty_isEquivalence : Nonempty (IsEquivalence (Localization.Construction.lift L inverts))
#align category_theory.functor.is_localization CategoryTheory.Functor.IsLocalization

instance q_isLocalization : W.Q.IsLocalization W
    where
  inverts := W.Q_inverts
  nonempty_isEquivalence :=
    by
    suffices Localization.Construction.lift W.Q W.Q_inverts = 𝟭 _
      by
      apply Nonempty.intro
      rw [this]
      infer_instance
    apply Localization.Construction.uniq
    simp only [Localization.Construction.fac]
    rfl
set_option linter.uppercaseLean3 false in
#align category_theory.functor.Q_is_localization CategoryTheory.Functor.q_isLocalization

end Functor

namespace Localization

/-- This universal property states that a functor `L : C ⥤ D` inverts morphisms
in `W` and the all functors `D ⥤ E` (for a fixed category `E`) uniquely factors
through `L`. -/
structure StrictUniversalPropertyFixedTarget where
  /-- the functor `L` inverts `W` -/
  inverts : W.IsInvertedBy L
  /-- any functor `C ⥤ E` which inverts `W` can be lifted as a functor `D ⥤ E`  -/
  lift : ∀ (F : C ⥤ E) (_ : W.IsInvertedBy F), D ⥤ E
  /-- there is a factorisation involving the lifted functor  -/
  fac : ∀ (F : C ⥤ E) (hF : W.IsInvertedBy F), L ⋙ lift F hF = F
  /-- uniqueness of the lifted functor -/
  uniq : ∀ (F₁ F₂ : D ⥤ E) (_ : L ⋙ F₁ = L ⋙ F₂), F₁ = F₂
#align category_theory.localization.strict_universal_property_fixed_target CategoryTheory.Localization.StrictUniversalPropertyFixedTarget

/-- The localized category `W.Localization` that was constructed satisfies
the universal property of the localization. -/
@[simps]
def strictUniversalPropertyFixedTargetQ : StrictUniversalPropertyFixedTarget W.Q W E
    where
  inverts := W.Q_inverts
  lift := Construction.lift
  fac := Construction.fac
  uniq := Construction.uniq
set_option linter.uppercaseLean3 false in
#align category_theory.localization.strict_universal_property_fixed_target_Q CategoryTheory.Localization.strictUniversalPropertyFixedTargetQ

instance : Inhabited (StrictUniversalPropertyFixedTarget W.Q W E) :=
  ⟨strictUniversalPropertyFixedTargetQ _ _⟩

/-- When `W` consists of isomorphisms, the identity satisfies the universal property
of the localization. -/
@[simps]
def strictUniversalPropertyFixedTargetId (hW : W ⊆ MorphismProperty.isomorphisms C) :
    StrictUniversalPropertyFixedTarget (𝟭 C) W E
    where
  inverts X Y f hf := hW f hf
  lift F _ := F
  fac F hF := by
    cases F
    rfl
  uniq F₁ F₂ eq := by
    cases F₁
    cases F₂
    exact eq
#align category_theory.localization.strict_universal_property_fixed_target_id CategoryTheory.Localization.strictUniversalPropertyFixedTargetId

end Localization

namespace Functor

theorem IsLocalization.mk' (h₁ : Localization.StrictUniversalPropertyFixedTarget L W D)
    (h₂ : Localization.StrictUniversalPropertyFixedTarget L W W.Localization) :
    IsLocalization L W :=
  { inverts := h₁.inverts
    nonempty_isEquivalence :=
      Nonempty.intro
        { inverse := h₂.lift W.Q W.Q_inverts
          unitIso :=
            eqToIso
              (Localization.Construction.uniq _ _
                (by
                  simp only [← Functor.assoc, Localization.Construction.fac, h₂.fac,
                    Functor.comp_id]))
          counitIso :=
            eqToIso
              (h₁.uniq _ _
                (by
                  simp only [← Functor.assoc, h₂.fac, Localization.Construction.fac,
                    Functor.comp_id]))
          functor_unitIso_comp := fun X => by
            simp only [eqToIso.hom, eqToHom_app, eqToHom_map, eqToHom_trans,
              eqToHom_refl]
            rfl } }
#align category_theory.functor.is_localization.mk' CategoryTheory.Functor.IsLocalization.mk'

theorem IsLocalization.for_id (hW : W ⊆ MorphismProperty.isomorphisms C) : (𝟭 C).IsLocalization W :=
  IsLocalization.mk' _ _ (Localization.strictUniversalPropertyFixedTargetId W _ hW)
    (Localization.strictUniversalPropertyFixedTargetId W _ hW)
#align category_theory.functor.is_localization.for_id CategoryTheory.Functor.IsLocalization.for_id

end Functor

namespace Localization

variable [L.IsLocalization W]

theorem inverts : W.IsInvertedBy L :=
  (inferInstance : L.IsLocalization W).inverts
#align category_theory.localization.inverts CategoryTheory.Localization.inverts

/-- The isomorphism `L.obj X ≅ L.obj Y` that is deduced from a morphism `f : X ⟶ Y` which
belongs to `W`, when `L.IsLocalization W`. -/
@[simps!]
def isoOfHom {X Y : C} (f : X ⟶ Y) (hf : W f) : L.obj X ≅ L.obj Y :=
  haveI : IsIso (L.map f) := inverts L W f hf
  asIso (L.map f)
#align category_theory.localization.iso_of_hom CategoryTheory.Localization.isoOfHom

instance : IsEquivalence (Localization.Construction.lift L (inverts L W)) :=
  (inferInstance : L.IsLocalization W).nonempty_isEquivalence.some

/-- A chosen equivalence of categories `W.Localization ≅ D` for a functor
`L : C ⥤ D` which satisfies `L.IsLocalization W`. This shall be used in
order to deduce properties of `L` from properties of `W.Q`. -/
def equivalenceFromModel : W.Localization ≌ D :=
  (Localization.Construction.lift L (inverts L W)).asEquivalence
#align category_theory.localization.equivalence_from_model CategoryTheory.Localization.equivalenceFromModel

/-- Via the equivalence of categories `equivalence_from_model L W : W.localization ≌ D`,
one may identify the functors `W.Q` and `L`. -/
def qCompEquivalenceFromModelFunctorIso : W.Q ⋙ (equivalenceFromModel L W).functor ≅ L :=
  eqToIso (Construction.fac _ _)
set_option linter.uppercaseLean3 false in
#align category_theory.localization.Q_comp_equivalence_from_model_functor_iso CategoryTheory.Localization.qCompEquivalenceFromModelFunctorIso

/-- Via the equivalence of categories `equivalence_from_model L W : W.localization ≌ D`,
one may identify the functors `L` and `W.Q`. -/
def compEquivalenceFromModelInverseIso : L ⋙ (equivalenceFromModel L W).inverse ≅ W.Q :=
  calc
    L ⋙ (equivalenceFromModel L W).inverse ≅ _ :=
      isoWhiskerRight (qCompEquivalenceFromModelFunctorIso L W).symm _
    _ ≅ W.Q ⋙ (equivalenceFromModel L W).functor ⋙ (equivalenceFromModel L W).inverse :=
      (Functor.associator _ _ _)
    _ ≅ W.Q ⋙ 𝟭 _ := (isoWhiskerLeft _ (equivalenceFromModel L W).unitIso.symm)
    _ ≅ W.Q := Functor.rightUnitor _
#align category_theory.localization.comp_equivalence_from_model_inverse_iso CategoryTheory.Localization.compEquivalenceFromModelInverseIso

theorem essSurj : EssSurj L :=
  ⟨fun X =>
    ⟨(Construction.objEquiv W).invFun ((equivalenceFromModel L W).inverse.obj X),
      Nonempty.intro
        ((qCompEquivalenceFromModelFunctorIso L W).symm.app _ ≪≫
          (equivalenceFromModel L W).counitIso.app X)⟩⟩
#align category_theory.localization.ess_surj CategoryTheory.Localization.essSurj

/-- The functor `(D ⥤ E) ⥤ W.functors_inverting E` induced by the composition
with a localization functor `L : C ⥤ D` with respect to `W : morphism_property C`. -/
def whiskeringLeftFunctor : (D ⥤ E) ⥤ W.FunctorsInverting E :=
  FullSubcategory.lift _ ((whiskeringLeft _ _ E).obj L)
    (MorphismProperty.IsInvertedBy.of_comp W L (inverts L W))
#align category_theory.localization.whiskering_left_functor CategoryTheory.Localization.whiskeringLeftFunctor

instance : IsEquivalence (whiskeringLeftFunctor L W E) := by
  refine'
    IsEquivalence.ofIso _
      (IsEquivalence.ofEquivalence
        ((Equivalence.congrLeft (equivalenceFromModel L W).symm).trans
          (Construction.whiskeringLeftEquivalence W E)))
  exact
    NatIso.ofComponents
      (fun F =>
        eqToIso
          (by
            ext
            change (W.Q ⋙ Localization.Construction.lift L (inverts L W)) ⋙ F = L ⋙ F
            rw [Construction.fac]))
      fun τ => by
        apply NatTrans.ext
        ext
        dsimp [Construction.whiskeringLeftEquivalence, equivalenceFromModel, whiskerLeft]
        erw [NatTrans.comp_app, NatTrans.comp_app, eqToHom_app, eqToHom_app, eqToHom_refl,
          eqToHom_refl, comp_id, id_comp]
        . rfl
        all_goals
          change (W.Q ⋙ Localization.Construction.lift L (inverts L W)) ⋙ _ = L ⋙ _
          rw [Construction.fac]

/-- The equivalence of categories `(D ⥤ E) ≌ (W.FunctorsInverting E)` induced by
the composition with a localization functor `L : C ⥤ D` with respect to
`W : MorphismProperty C`. -/
def functorEquivalence : D ⥤ E ≌ W.FunctorsInverting E :=
  (whiskeringLeftFunctor L W E).asEquivalence
#align category_theory.localization.functor_equivalence CategoryTheory.Localization.functorEquivalence

/-- The functor `(D ⥤ E) ⥤ (C ⥤ E)` given by the composition with a localization
functor `L : C ⥤ D` with respect to `W : MorphismProperty C`. -/
@[nolint unusedArguments]
def whiskeringLeftFunctor' (_ : MorphismProperty C) (E : Type _) [Category E] :
  (D ⥤ E) ⥤ C ⥤ E :=
  (whiskeringLeft C D E).obj L
#align category_theory.localization.whiskering_left_functor' CategoryTheory.Localization.whiskeringLeftFunctor'

theorem whiskeringLeftFunctor'_eq :
    whiskeringLeftFunctor' L W E = Localization.whiskeringLeftFunctor L W E ⋙ inducedFunctor _ :=
  rfl
#align category_theory.localization.whiskering_left_functor'_eq CategoryTheory.Localization.whiskeringLeftFunctor'_eq

variable {E}

@[simp]

instance : Full (whiskeringLeftFunctor' L W E) := by
  rw [whiskeringLeftFunctor'_eq]
  apply @Full.comp _ _ _ _ _ _ _ _ ?_ ?_
  infer_instance
  apply InducedCategory.full -- why is it not found automatically ???

instance : Faithful (whiskeringLeftFunctor' L W E) := by
  rw [whiskeringLeftFunctor'_eq]
  apply @Faithful.comp _ _ _ _ _ _ _ _ ?_ ?_
  infer_instance
  apply InducedCategory.faithful -- why is it not found automatically ???

theorem natTrans_ext {F₁ F₂ : D ⥤ E} (τ τ' : F₁ ⟶ F₂)
    (h : ∀ X : C, τ.app (L.obj X) = τ'.app (L.obj X)) : τ = τ' := by
  haveI : CategoryTheory.EssSurj L := essSurj L W
  ext Y
  rw [← cancel_epi (F₁.map (L.objObjPreimageIso Y).hom), τ.naturality, τ'.naturality, h]
#align category_theory.localization.nat_trans_ext CategoryTheory.Localization.natTrans_ext

-- porting note: the field `iso` was renamed `Lifting.iso'` and it was redefined as
-- `Lifting.iso` with explicit parameters
/-- When `L : C ⥤ D` is a localization functor for `W : MorphismProperty C` and
`F : C ⥤ E` is a functor, we shall say that `F' : D ⥤ E` lifts `F` if the obvious diagram
is commutative up to an isomorphism. -/
class Lifting (W : MorphismProperty C) (F : C ⥤ E) (F' : D ⥤ E) where
  /-- the isomorphism relating the localization functor and the two other given functors -/
  iso' : L ⋙ F' ≅ F
#align category_theory.localization.lifting CategoryTheory.Localization.Lifting

/-- The distinguished isomorphism `L ⋙ F' ≅ F` given by `[Lifting L W F F']`. -/
def Lifting.iso (F : C ⥤ E) (F' : D ⥤ E) [Lifting L W F F'] :
    L ⋙ F' ≅ F :=
  Lifting.iso' W

variable {W}

/-- Given a localization functor `L : C ⥤ D` for `W : MorphismProperty C` and
a functor `F : C ⥤ E` which inverts `W`, this is a choice of functor
`D ⥤ E` which lifts `F`. -/
def lift (F : C ⥤ E) (hF : W.IsInvertedBy F) (L : C ⥤ D) [L.IsLocalization W] : D ⥤ E :=
  (functorEquivalence L W E).inverse.obj ⟨F, hF⟩
#align category_theory.localization.lift CategoryTheory.Localization.lift

instance liftingLift (F : C ⥤ E) (hF : W.IsInvertedBy F) (L : C ⥤ D) [L.IsLocalization W] :
    Lifting L W F (lift F hF L) :=
  ⟨(inducedFunctor _).mapIso ((functorEquivalence L W E).counitIso.app ⟨F, hF⟩)⟩
#align category_theory.localization.lifting_lift CategoryTheory.Localization.liftingLift

-- porting note: removed the unnecessary @[simps] attribute
/-- The canonical isomorphism `L ⋙ lift F hF L ≅ F` for any functor `F : C ⥤ E`
which inverts `W`, when `L : C ⥤ D` is a localization functor for `W`. -/
def fac (F : C ⥤ E) (hF : W.IsInvertedBy F) (L : C ⥤ D) [L.IsLocalization W] :
    L ⋙ lift F hF L ≅ F :=
  Lifting.iso L W F _
#align category_theory.localization.fac CategoryTheory.Localization.fac

instance liftingConstructionLift (F : C ⥤ D) (hF : W.IsInvertedBy F) :
    Lifting W.Q W F (Construction.lift F hF) :=
  ⟨eqToIso (Construction.fac F hF)⟩
#align category_theory.localization.lifting_construction_lift CategoryTheory.Localization.liftingConstructionLift

variable (W)

/-- Given a localization functor `L : C ⥤ D` for `W : MorphismProperty C`,
if `(F₁' F₂' : D ⥤ E)` are functors which lifts functors `(F₁ F₂ : C ⥤ E)`,
a natural transformation `τ : F₁ ⟶ F₂` uniquely lifts to a natural transformation `F₁' ⟶ F₂'`. -/
def liftNatTrans (F₁ F₂ : C ⥤ E) (F₁' F₂' : D ⥤ E) [Lifting L W F₁ F₁'] [Lifting L W F₂ F₂']
    (τ : F₁ ⟶ F₂) : F₁' ⟶ F₂' :=
  (whiskeringLeftFunctor' L W E).preimage
    ((Lifting.iso L W F₁ F₁').hom ≫ τ ≫ (Lifting.iso L W F₂ F₂').inv)
#align category_theory.localization.lift_nat_trans CategoryTheory.Localization.liftNatTrans

@[simp]
theorem liftNatTrans_app (F₁ F₂ : C ⥤ E) (F₁' F₂' : D ⥤ E) [Lifting L W F₁ F₁'] [Lifting L W F₂ F₂']
    (τ : F₁ ⟶ F₂) (X : C) :
    (liftNatTrans L W F₁ F₂ F₁' F₂' τ).app (L.obj X) =
      (Lifting.iso L W F₁ F₁').hom.app X ≫ τ.app X ≫ (Lifting.iso L W F₂ F₂').inv.app X :=
  congr_app (Functor.image_preimage (whiskeringLeftFunctor' L W E) _) X
#align category_theory.localization.lift_nat_trans_app CategoryTheory.Localization.liftNatTrans_app

@[reassoc (attr := simp)]
theorem comp_liftNatTrans (F₁ F₂ F₃ : C ⥤ E) (F₁' F₂' F₃' : D ⥤ E) [h₁ : Lifting L W F₁ F₁']
    [h₂ : Lifting L W F₂ F₂'] [h₃ : Lifting L W F₃ F₃'] (τ : F₁ ⟶ F₂) (τ' : F₂ ⟶ F₃) :
    liftNatTrans L W F₁ F₂ F₁' F₂' τ ≫ liftNatTrans L W F₂ F₃ F₂' F₃' τ' =
      liftNatTrans L W F₁ F₃ F₁' F₃' (τ ≫ τ') :=
  natTrans_ext L W _ _ fun X => by
    simp only [NatTrans.comp_app, liftNatTrans_app, assoc, Iso.inv_hom_id_app_assoc]
#align category_theory.localization.comp_lift_nat_trans CategoryTheory.Localization.comp_liftNatTrans

@[simp]
theorem liftNatTrans_id (F : C ⥤ E) (F' : D ⥤ E) [h : Lifting L W F F'] :
    liftNatTrans L W F F F' F' (𝟙 F) = 𝟙 F' :=
  natTrans_ext L W _ _ fun X => by
    simp only [liftNatTrans_app, NatTrans.id_app, id_comp, Iso.hom_inv_id_app]
    rfl
#align category_theory.localization.lift_nat_trans_id CategoryTheory.Localization.liftNatTrans_id

/-- Given a localization functor `L : C ⥤ D` for `W : MorphismProperty C`,
if `(F₁' F₂' : D ⥤ E)` are functors which lifts functors `(F₁ F₂ : C ⥤ E)`,
a natural isomorphism `τ : F₁ ⟶ F₂` lifts to a natural isomorphism `F₁' ⟶ F₂'`. -/
@[simps]
def liftNatIso (F₁ F₂ : C ⥤ E) (F₁' F₂' : D ⥤ E) [h₁ : Lifting L W F₁ F₁'] [h₂ : Lifting L W F₂ F₂']
    (e : F₁ ≅ F₂) : F₁' ≅ F₂'
    where
  hom := liftNatTrans L W F₁ F₂ F₁' F₂' e.hom
  inv := liftNatTrans L W F₂ F₁ F₂' F₁' e.inv
#align category_theory.localization.lift_nat_iso CategoryTheory.Localization.liftNatIso

namespace Lifting

@[simps]
instance compRight {E' : Type _} [Category E'] (F : C ⥤ E) (F' : D ⥤ E) [Lifting L W F F']
    (G : E ⥤ E') : Lifting L W (F ⋙ G) (F' ⋙ G) :=
  ⟨isoWhiskerRight (iso L W F F') G⟩
#align category_theory.localization.lifting.comp_right CategoryTheory.Localization.Lifting.compRight

@[simps]
instance id : Lifting L W L (𝟭 D) :=
  ⟨Functor.rightUnitor L⟩
#align category_theory.localization.lifting.id CategoryTheory.Localization.Lifting.id

/-- Given a localization functor `L : C ⥤ D` for `W : MorphismProperty C`,
if `F₁' : D ⥤ E` lifts a functor `F₁ : C ⥤ D`, then a functor `F₂'` which
is isomorphic to `F₁'` also lifts a functor `F₂` that is isomorphic to `F₁`.  -/
@[simps]
def ofIsos {F₁ F₂ : C ⥤ E} {F₁' F₂' : D ⥤ E} (e : F₁ ≅ F₂) (e' : F₁' ≅ F₂') [Lifting L W F₁ F₁'] :
    Lifting L W F₂ F₂' :=
  ⟨isoWhiskerLeft L e'.symm ≪≫ iso L W F₁ F₁' ≪≫ e⟩
#align category_theory.localization.lifting.of_isos CategoryTheory.Localization.Lifting.ofIsos

end Lifting

end Localization

namespace Functor

namespace IsLocalization

open Localization

theorem of_iso {L₁ L₂ : C ⥤ D} (e : L₁ ≅ L₂) [L₁.IsLocalization W] : L₂.IsLocalization W := by
  have h := Localization.inverts L₁ W
  rw [MorphismProperty.IsInvertedBy.iff_of_iso W e] at h
  let F₁ := Localization.Construction.lift L₁ (Localization.inverts L₁ W)
  let F₂ := Localization.Construction.lift L₂ h
  exact
    { inverts := h
      nonempty_isEquivalence :=
        Nonempty.intro (IsEquivalence.ofIso (liftNatIso W.Q W L₁ L₂ F₁ F₂ e) inferInstance) }
#align category_theory.functor.is_localization.of_iso CategoryTheory.Functor.IsLocalization.of_iso

/-- If `L : C ⥤ D` is a localization for `W : MorphismProperty C`, then it is also
the case of a functor obtained by post-composing `L` with an equivalence of categories. -/
theorem of_equivalence_target {E : Type _} [Category E] (L' : C ⥤ E) (eq : D ≌ E)
    [L.IsLocalization W] (e : L ⋙ eq.functor ≅ L') : L'.IsLocalization W := by
  have h : W.IsInvertedBy L' := by
    rw [← MorphismProperty.IsInvertedBy.iff_of_iso W e]
    exact MorphismProperty.IsInvertedBy.of_comp W L (Localization.inverts L W) eq.functor
  let F₁ := Localization.Construction.lift L (Localization.inverts L W)
  let F₂ := Localization.Construction.lift L' h
  let e' : F₁ ⋙ eq.functor ≅ F₂ := liftNatIso W.Q W (L ⋙ eq.functor) L' _ _ e
  exact
    { inverts := h
      nonempty_isEquivalence := Nonempty.intro (IsEquivalence.ofIso e' inferInstance) }
#align category_theory.functor.is_localization.of_equivalence_target CategoryTheory.Functor.IsLocalization.of_equivalence_target

end IsLocalization

end Functor

end CategoryTheory


inductive Vector (α : Type u): Nat → Type u where
| nil : Vector α 0
| cons (head : α) (tail : Vector α n) : Vector α (n+1)

namespace Vector
  def nth : ∀{n}, Vector α n → Fin n → α
  | n+1, cons x xs, ⟨  0, _⟩ => x
  | n+1, cons x xs, ⟨k+1, h⟩ => xs.nth ⟨k, sorry⟩

  def snoc : ∀{n : Nat} (xs : Vector α n) (x : α), Vector α (n+1)
  | _, nil,    x' => cons x' nil
  | _, cons x xs, x' => cons x (snoc xs x')

  theorem nth_snoc_eq (k: Fin (n+1))(v : Vector α n)
    (h: k.val = n):
    (v.snoc x).nth k = x := by
    cases k; rename_i k hk
    induction v generalizing k <;> subst h
    · simp only [nth]
    · simp! [*]

  theorem nth_snoc_eq_works (k: Fin (n+1))(v : Vector α n)
    (h: k.val = n):
    (v.snoc x).nth k = x := by
    cases k; rename_i k hk
    induction v generalizing k <;> subst h
    · simp only [nth]
    · simp[*,nth]
end Vector


import AltClassical

section ch3_examples

open AltClassical
variable (p q r s ω: Type u)

example : CImpl ω (CImpl ω p (COr ω r s)) (COr ω (CImpl ω p r) (CImpl ω p s)) := by
  apply CImpl.lift
  intro p_to_r_or_s ⟨not_p_to_r, not_p_to_s⟩
  apply CImpl.elim p_to_r_or_s
  . intro not_p
    have p_to_r: CImpl ω p r := CImpl.byRefuteAntecedent not_p
    exact CNot.annihilate not_p_to_r p_to_r
  . intro r_or_s
    apply COr.elim r_or_s
    . intro pr
      have p_to_r: CImpl ω p r := CImpl.byProveConsequent (CPos.lift pr)
      exact CNot.annihilate not_p_to_r p_to_r
    . intro ps
      have p_to_s: CImpl ω p s := CImpl.byProveConsequent (CPos.lift ps)
      exact CNot.annihilate not_p_to_s p_to_s

example : CImpl ω (CNot ω (CAnd ω p q)) (COr ω (CNot ω p) (CNot ω q)) := by
  apply CImpl.lift
  intro not_p_and_q ⟨cp, cq⟩
  exact CNot.annihilate not_p_and_q (CAnd.intro cp cq)

example : CImpl ω (CNot ω (CImpl ω p q)) (COr ω (CNot ω p) (CNot ω q)) := by
  apply CImpl.lift
  intro not_p_to_q ⟨_, cq⟩
  have p_to_q: CImpl ω p q := CImpl.byProveConsequent cq
  exact CNot.annihilate not_p_to_q p_to_q

example : CImpl ω (CNot ω (CImpl ω p q)) (CAnd ω p (CNot ω q)) := by
  apply CImpl.lift
  intro not_p_to_q
  apply CAnd.intro
  . intro not_p
    have p_to_q: CImpl ω p q := CImpl.byRefuteAntecedent not_p
    exact CNot.annihilate not_p_to_q p_to_q
  . intro cq
    have p_to_q: CImpl ω p q := CImpl.byProveConsequent cq
    exact CNot.annihilate not_p_to_q p_to_q

example : CImpl ω (CImpl ω p q) (COr ω (CNot ω p) q) := by
  apply CImpl.lift
  intro p_to_q
  intro ⟨cp, not_q⟩
  apply CImpl.elim p_to_q
  . exact cp
  . exact not_q

example : CImpl ω (CImpl ω (CNot ω q) (CNot ω p)) (CImpl ω p q) := by
  apply CImpl.lift
  intro not_q_to_not_p ⟨cp, not_q⟩
  apply CImpl.elim not_q_to_not_p
  . intro cq
    exact cq not_q
  . intro not_p
    exact cp not_p

example : COr ω p (CNot ω p) := by
  intro ⟨not_p, not_not_p⟩
  exact not_not_p not_p

example : CImpl ω (CImpl ω (CImpl ω p q) p) p := by
  intro ⟨g, not_p⟩
  have g' : CImpl ω (CImpl ω p q) p := CPos.isCNot g
  apply CImpl.elim g'
  . intro not_p_to_q
    have p_to_q: CImpl ω p q := CImpl.byRefuteAntecedent not_p
    exact CNot.annihilate not_p_to_q p_to_q
  . intro pp
    exact CNot.annihilate not_p pp

example : CImpl ω (CNot ω (CNot ω p)) (CPos ω p) := CImpl.lift id

end ch3_examples


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

import topology.homotopy.basic
import topology.path_connected
import analysis.convex.basic

/-!
# Homotopy between paths

In this file, we define a `homotopy` between two `path`s. In addition, we define a relation
`homotopic` on `path`s, and prove that it is an equivalence relation.

## Definitions

* `path.homotopy p₀ p₁` is the type of homotopies between paths `p₀` and `p₁`
* `path.homotopy.refl p` is the constant homotopy between `p` and itself
* `path.homotopy.symm F` is the `path.homotopy p₁ p₀` defined by reversing the homotopy
* `path.homotopy.trans F G`, where `F : path.homotopy p₀ p₁`, `G : path.homotopy p₁ p₂` is the
  `path.homotopy p₀ p₂` defined by putting the first homotopy on `[0, 1/2]` and the second on
  `[1/2, 1]`
* `path.homotopy.hcomp F G`, where `F : path.homotopy p₀ q₀` and `G : path.homotopy p₁ q₁` is
  a `path.homotopy (p₀.trans p₁) (q₀.trans q₁)`
* `path.homotopic p₀ p₁` is the relation saying that there is a homotopy between `p₀` and `p₁`
* `path.homotopic.setoid x₀ x₁` is the setoid on `path`s from `path.homotopic`
* `path.homotopic.quotient x₀ x₁` is the quotient type from `path x₀ x₀` by `path.homotopic.setoid`

-/

universes u v

variables {X : Type u} {Y : Type v} [topological_space X] [topological_space Y]
variables {x₀ x₁ x₂ : X}

noncomputable theory

open_locale unit_interval

namespace path

/--
The type of homotopies between two paths.
-/
abbreviation homotopy (p₀ p₁ : path x₀ x₁) :=
continuous_map.homotopy_rel p₀.to_continuous_map p₁.to_continuous_map {0, 1}

namespace homotopy

section

variables {p₀ p₁ : path x₀ x₁}

instance : has_coe_to_fun (homotopy p₀ p₁) (λ _, I × I → X) := ⟨λ F, F.to_fun⟩

lemma coe_fn_injective : @function.injective (homotopy p₀ p₁) (I × I → X) coe_fn :=
continuous_map.homotopy_with.coe_fn_injective

@[simp]
lemma source (F : homotopy p₀ p₁) (t : I) : F (t, 0) = x₀ :=
begin
  simp_rw [←p₀.source],
  apply continuous_map.homotopy_rel.eq_fst,
  simp,
end

@[simp]
lemma target (F : homotopy p₀ p₁) (t : I) : F (t, 1) = x₁ :=
begin
  simp_rw [←p₁.target],
  apply continuous_map.homotopy_rel.eq_snd,
  simp,
end

/--
Evaluating a path homotopy at an intermediate point, giving us a `path`.
-/
def eval (F : homotopy p₀ p₁) (t : I) : path x₀ x₁ :=
{ to_fun := F.to_homotopy.curry t,
  source' := by simp,
  target' := by simp }

@[simp]
lemma eval_zero (F : homotopy p₀ p₁) : F.eval 0 = p₀ :=
begin
  ext t,
  simp [eval],
end

@[simp]
lemma eval_one (F : homotopy p₀ p₁) : F.eval 1 = p₁ :=
begin
  ext t,
  simp [eval],
end

end

section

variables {p₀ p₁ p₂ : path x₀ x₁}

/--
Given a path `p`, we can define a `homotopy p p` by `F (t, x) = p x`
-/
@[simps]
def refl (p : path x₀ x₁) : homotopy p p :=
continuous_map.homotopy_rel.refl p.to_continuous_map {0, 1}

/--
Given a `homotopy p₀ p₁`, we can define a `homotopy p₁ p₀` by reversing the homotopy.
-/
@[simps]
def symm (F : homotopy p₀ p₁) : homotopy p₁ p₀ :=
continuous_map.homotopy_rel.symm F

@[simp]
lemma symm_symm (F : homotopy p₀ p₁) : F.symm.symm = F :=
continuous_map.homotopy_rel.symm_symm F

/--
Given `homotopy p₀ p₁` and `homotopy p₁ p₂`, we can define a `homotopy p₀ p₂` by putting the first
homotopy on `[0, 1/2]` and the second on `[1/2, 1]`.
-/
def trans (F : homotopy p₀ p₁) (G : homotopy p₁ p₂) : homotopy p₀ p₂ :=
continuous_map.homotopy_rel.trans F G

lemma trans_apply (F : homotopy p₀ p₁) (G : homotopy p₁ p₂) (x : I × I) :
  (F.trans G) x =
    if h : (x.1 : ℝ) ≤ 1/2 then
      F (⟨2 * x.1, (unit_interval.mul_pos_mem_iff zero_lt_two).2 ⟨x.1.2.1, h⟩⟩, x.2)
    else
      G (⟨2 * x.1 - 1, unit_interval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.1.2.2⟩⟩, x.2) :=
continuous_map.homotopy_rel.trans_apply _ _ _

lemma symm_trans (F : homotopy p₀ p₁) (G : homotopy p₁ p₂) :
  (F.trans G).symm = G.symm.trans F.symm :=
continuous_map.homotopy_rel.symm_trans _ _

/--
Casting a `homotopy p₀ p₁` to a `homotopy q₀ q₁` where `p₀ = q₀` and `p₁ = q₁`.
-/
@[simps]
def cast {p₀ p₁ q₀ q₁ : path x₀ x₁} (F : homotopy p₀ p₁) (h₀ : p₀ = q₀) (h₁ : p₁ = q₁) :
  homotopy q₀ q₁ :=
continuous_map.homotopy_rel.cast F (congr_arg _ h₀) (congr_arg _ h₁)

end

section

variables {p₀ q₀ : path x₀ x₁} {p₁ q₁ : path x₁ x₂}

/--
Suppose `p₀` and `q₀` are paths from `x₀` to `x₁`, `p₁` and `q₁` are paths from `x₁` to `x₂`.
Furthermore, suppose `F : homotopy p₀ q₀` and `G : homotopy p₁ q₁`. Then we can define a homotopy
from `p₀.trans p₁` to `q₀.trans q₁`.
-/
def hcomp (F : homotopy p₀ q₀) (G : homotopy p₁ q₁) :
  homotopy (p₀.trans p₁) (q₀.trans q₁) :=
{ to_fun := λ x,
  if (x.2 : ℝ) ≤ 1/2 then
    (F.eval x.1).extend (2 * x.2)
  else
    (G.eval x.1).extend (2 * x.2 - 1),
  continuous_to_fun := begin
    refine continuous_if_le (continuous_induced_dom.comp continuous_snd) continuous_const
      (F.to_homotopy.continuous.comp (by continuity)).continuous_on
      (G.to_homotopy.continuous.comp (by continuity)).continuous_on _,
    intros x hx,
    norm_num [hx]
  end,
  to_fun_zero := λ x, by norm_num [path.trans],
  to_fun_one := λ x, by norm_num [path.trans],
  prop' := begin
    rintros x t ht,
    cases ht,
    { rw ht,
      simp },
    { rw set.mem_singleton_iff at ht,
      rw ht,
      norm_num }
  end }

lemma hcomp_apply (F : homotopy p₀ q₀) (G : homotopy p₁ q₁) (x : I × I) :
  F.hcomp G x =
  if h : (x.2 : ℝ) ≤ 1/2 then
    F.eval x.1 ⟨2 * x.2, (unit_interval.mul_pos_mem_iff zero_lt_two).2 ⟨x.2.2.1, h⟩⟩
  else
    G.eval x.1 ⟨2 * x.2 - 1, unit_interval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.2.2.2⟩⟩ :=
show ite _ _ _ = _, by split_ifs; exact path.extend_extends _ _

lemma hcomp_half (F : homotopy p₀ q₀) (G : homotopy p₁ q₁) (t : I) :
  F.hcomp G (t, ⟨1/2, by norm_num, by norm_num⟩) = x₁ :=
show ite _ _ _ = _, by norm_num

end

/--
Suppose `p` is a path, then we have a homotopy from `p` to `p.reparam f` by the convexity of `I`.
-/
def reparam (p  : path x₀ x₁) (f : I → I) (hf : continuous f) (hf₀ : f 0 = 0) (hf₁ : f 1 = 1) :
  homotopy p (p.reparam f hf hf₀ hf₁) :=
{ to_fun := λ x, p ⟨σ x.1 * x.2 + x.1 * f x.2,
    show (σ x.1 : ℝ) • (x.2 : ℝ) + (x.1 : ℝ) • (f x.2 : ℝ) ∈ I, from convex_Icc _ _ x.2.2 (f x.2).2
    (by unit_interval) (by unit_interval) (by simp)⟩,
  to_fun_zero := λ x, by norm_num,
  to_fun_one := λ x, by norm_num,
  prop' := λ t x hx,
  begin
    cases hx,
    { rw hx, norm_num [hf₀] },
    { rw set.mem_singleton_iff at hx,
      rw hx,
      norm_num [hf₁] }
  end }

/--
Suppose `F : homotopy p q`. Then we have a `homotopy p.symm q.symm` by reversing the second
argument.
-/
@[simps]
def symm₂ {p q : path x₀ x₁} (F : p.homotopy q) : p.symm.homotopy q.symm :=
{ to_fun := λ x, F ⟨x.1, σ x.2⟩,
  to_fun_zero := by simp [path.symm],
  to_fun_one := by simp [path.symm],
  prop' := λ t x hx, begin
    cases hx,
    { rw hx, simp },
    { rw set.mem_singleton_iff at hx,
      rw hx,
      simp }
  end }

/--
Given `F : homotopy p q`, and `f : C(X, Y)`, we can define a homotopy from `p.map f.continuous` to
`q.map f.continuous`.
-/
@[simps]
def map {p q : path x₀ x₁} (F : p.homotopy q) (f : C(X, Y)) :
  homotopy (p.map f.continuous) (q.map f.continuous) :=
{ to_fun := f ∘ F,
  to_fun_zero := by simp,
  to_fun_one := by simp,
  prop' := λ t x hx, begin
    cases hx,
    { simp [hx] },
    { rw set.mem_singleton_iff at hx,
      simp [hx] }
  end }

end homotopy

/--
Two paths `p₀` and `p₁` are `path.homotopic` if there exists a `homotopy` between them.
-/
def homotopic (p₀ p₁ : path x₀ x₁) : Prop := nonempty (p₀.homotopy p₁)

namespace homotopic

@[refl]

@[symm]
lemma symm ⦃p₀ p₁ : path x₀ x₁⦄ (h : p₀.homotopic p₁) : p₁.homotopic p₀ := h.map homotopy.symm

@[trans]
lemma trans ⦃p₀ p₁ p₂ : path x₀ x₁⦄ (h₀ : p₀.homotopic p₁) (h₁ : p₁.homotopic p₂) :
  p₀.homotopic p₂ := h₀.map2 homotopy.trans h₁

lemma equivalence : equivalence (@homotopic X _ x₀ x₁) := ⟨refl, symm, trans⟩

lemma map {p q : path x₀ x₁} (h : p.homotopic q) (f : C(X, Y)) :
  homotopic (p.map f.continuous) (q.map f.continuous) := h.map (λ F, F.map f)

lemma hcomp {p₀ p₁ : path x₀ x₁} {q₀ q₁ : path x₁ x₂} (hp : p₀.homotopic p₁)
  (hq : q₀.homotopic q₁) : (p₀.trans q₀).homotopic (p₁.trans q₁) := hp.map2 homotopy.hcomp hq

/--
The setoid on `path`s defined by the equivalence relation `path.homotopic`. That is, two paths are
equivalent if there is a `homotopy` between them.
-/
protected def setoid (x₀ x₁ : X) : setoid (path x₀ x₁) := ⟨homotopic, equivalence⟩

/--
The quotient on `path x₀ x₁` by the equivalence relation `path.homotopic`.
-/
protected def quotient (x₀ x₁ : X) := quotient (homotopic.setoid x₀ x₁)

instance : inhabited (homotopic.quotient () ()) :=
⟨@quotient.mk _ (homotopic.setoid _ _) $ path.refl ()⟩

end homotopic

end path


inductive fml
| atom (i : ℕ)
| imp (a b : fml)
| not (a : fml)

open fml

infixr ` →' `:50 := imp -- right associative

prefix `¬' `:51 := fml.not

inductive prf : fml → Type
| axk (p q) : prf (p →' q →' p)
| axs (p q r) : prf $ (p →' q →' r) →' (p →' q) →' (p →' r)
| axX (p q) : prf $ ((¬' q) →' (¬' p)) →' p →' q
| mp {p q} : prf p → prf (p →' q) → prf q

open prf

theorem not_not_p_of_p (p q : fml) : prf (p →' (¬' (¬' p))) :=
mp (mp (mp (axk (¬' p) (¬' p))
           (axk (¬' p →' ¬' p →' ¬' p) (¬' ¬' ¬' p))
       )
       (mp (mp (mp (mp (mp (axk (¬' ¬' ¬' p) (¬' ¬' ¬' p))
                           (mp (axk (¬' ¬' ¬' p) (¬' ¬' ¬' p →' ¬' ¬' ¬' p))
                               (axs (¬' ¬' ¬' p) (¬' ¬' ¬' p →' ¬' ¬' ¬' p) (¬' ¬' ¬' p))
                           )
                       )
                       (mp (mp (axk (¬' ¬' ¬' p) (¬' ¬' (¬' p →' ¬' p →' ¬' p)))
                               (axk (¬' ¬' ¬' p →' (¬' ¬' (¬' p →' ¬' p →' ¬' p)) →' ¬' ¬' ¬' p) (¬' ¬' ¬' p))
                           )
                           (axs (¬' ¬' ¬' p) (¬' ¬' ¬' p) (¬' ¬' (¬' p →' ¬' p →' ¬' p) →' ¬' ¬' ¬' p))
                       )
                   )
                   (mp (mp (axX (¬' ¬' p) ¬' (¬' p →' ¬' p →' ¬' p))
                           (axk ((¬' ¬' (¬' p →' ¬' p →' ¬' p) →' ¬' ¬' ¬' p) →' ¬' ¬' p →' ¬' (¬' p →' ¬' p →' ¬' p)) (¬' ¬' ¬' p))
                       )
                       (axs (¬' ¬' ¬' p) (¬' ¬' (¬' p →' ¬' p →' ¬' p) →' ¬' ¬' ¬' p) (¬' ¬' p →' ¬' (¬' p →' ¬' p →' ¬' p)))
                   )
               )
               (mp (mp (axX (¬' p →' ¬' p →' ¬' p) (¬' p))
                       (axk ((¬' (¬' p) →' ¬' (¬' p →' ¬' p →' ¬' p)) →' (¬' p →' ¬' p →' ¬' p) →' ¬' p) (¬' ¬' ¬' p))
                   )
                   (axs (¬' ¬' ¬' p) (¬' ¬' p →' ¬' (¬' p →' ¬' p →' ¬' p)) ((¬' p →' ¬' p →' ¬' p) →' ¬' p))
               )
           )
           (axs (¬' ¬' ¬' p) (¬' p →' ¬' p →' ¬' p) (¬' p))
       )
   )
   (axX p (¬' ¬' p))


import ring_theory.ideal.basic
import exercise6

-- The Chinese remainder theorem

def ideals_are_comaximal {R : Type} [comm_semiring R] (A : ideal R) (B : ideal R) : Prop :=
  R = (A + B).carrier

-- 7a)
lemma prod_eq_cap_of_comaximal {R : Type} [comm_semiring R] {A : ideal R} {B : ideal R} [ideals_are_comaximal A B] :
  (A ⬝ B) = (A ∩ B) :=
begin
  ext,
  split,
  {
    intro h,
    apply ideal_prod_sub_cap,
    exact h,
  },
  {
    sorry,
  }
end


-- Copyright © 2019 François G. Dorais. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.

import .basic
import .lattice
import .semiring

namespace algebra

signature bounded_lattice (α : Type*) :=
(join : α → α → α)
(meet : α → α → α)
(bot : α)
(top : α)

namespace bounded_lattice_sig
variables {α : Type*} (s : bounded_lattice_sig α)

@[signature_instance]
definition to_lattice : lattice_sig α :=
{ join := s.join
, meet := s.meet
}

@[signature_instance]
definition to_bounded_join_semilattice : bounded_semilattice_sig α :=
{ op := s.join
, id := s.bot
}

@[signature_instance]
definition to_bounded_meet_semilattice : bounded_semilattice_sig α :=
{ op := s.meet
, id := s.top
}

@[signature_instance]
definition to_join_meet_semiring : semiring_sig α :=
{ add := s.join
, zero := s.bot
, mul := s.meet
, one := s.top
}

@[signature_instance]
definition to_meet_join_semiring : semiring_sig α :=
{ add := s.meet
, zero := s.top
, mul := s.join
, one := s.bot
}

end bounded_lattice_sig

variables {α : Type*} (s : bounded_lattice_sig α)
local infix ∪ := s.join
local infix ∩ := s.meet
local notation `𝟙` := s.top
local notation `𝟘` := s.bot

@[theory]
class bounded_lattice : Prop := intro ::
(join_associative : identity.op_associative s.join)
(join_commutative : identity.op_commutative s.join)
(join_right_absorptive : identity.op_right_absorptive s.join s.meet)
(join_right_identity : identity.op_right_identity s.join s.bot)
(meet_associative : identity.op_associative s.meet)
(meet_commutative : identity.op_commutative s.meet)
(meet_right_absorptive : identity.op_right_absorptive s.meet s.join)
(meet_right_identity : identity.op_right_identity s.meet s.top)

namespace bounded_lattice
variable [i : bounded_lattice s]
include i

instance to_lattice : lattice s.to_lattice := lattice.infer _

@[identity_instance]
theorem join_idempotent : identity.op_idempotent s.join :=
λ x, op_idempotent s.join x

@[identity_instance]
theorem meet_idempotent : identity.op_idempotent s.meet :=
λ x, op_idempotent s.meet x

instance to_bounded_join_semilattice : bounded_semilattice s.to_bounded_join_semilattice := bounded_semilattice.infer _

instance to_bounded_meet_semilattice : bounded_semilattice s.to_bounded_meet_semilattice := bounded_semilattice.infer _

@[identity_instance]
theorem join_right_null : identity.op_right_fixpoint s.join s.top :=
λ x, calc x ∪ 𝟙
= (x ∩ 𝟙) ∪ 𝟙 : by rw op_right_identity s.meet ...
= 𝟙 : by rw op_left_absorptive s.join

@[identity_instance]
theorem meet_right_null : identity.op_right_fixpoint s.meet s.bot :=
λ x, calc x ∩ 𝟘
= (x ∪ 𝟘) ∩ 𝟘 : by rw op_right_identity s.join ...
= 𝟘 : by rw op_left_absorptive s.meet

end bounded_lattice

@[theory]
class bounded_distributive_lattice : Prop := intro ::
(join_associative : identity.op_associative s.join)
(join_commutative : identity.op_commutative s.join)
(join_right_absorptive : identity.op_right_absorptive s.join s.meet)
(join_right_identity : identity.op_right_identity s.join s.bot)
(meet_associative : identity.op_associative s.meet)
(meet_commutative : identity.op_commutative s.meet)
(meet_right_absorptive : identity.op_right_absorptive s.meet s.join)
(meet_right_identity : identity.op_right_identity s.meet s.top)
(meet_join_right_distributive : identity.op_right_distributive s.meet s.join)

namespace bounded_distributive_lattice
variable [i : bounded_distributive_lattice s]
include i

instance to_bounded_lattice : bounded_lattice s := bounded_lattice.infer _

instance to_distributive_lattice : distributive_lattice s.to_lattice := distributive_lattice.infer _

instance to_join_meet_semiring : comm_semiring s.to_join_meet_semiring := comm_semiring.infer _

/- help to_meet_join_semiring inference -/
@[identity_instance]
theorem join_meet_right_distributive : identity.op_right_distributive s.join s.meet :=
op_right_distributive _ _

instance to_meet_join_semiring : comm_semiring s.to_meet_join_semiring := comm_semiring.infer _

end bounded_distributive_lattice

end algebra


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura, Jeremy Avigad, Floris van Doorn
-/
prelude
import init.logic init.wf

notation `Σ` binders `, ` r:(scoped p, sigma p) := r
notation `Σ'` binders `, ` r:(scoped p, psigma p) := r

universes u v

lemma ex_of_psig {α : Type u} {p : α → Prop} : (Σ' x, p x) → ∃ x, p x
| ⟨x, hx⟩ := ⟨x, hx⟩

section
variables {α : Type u} {β : α → Type v}

protected lemma sigma.eq : ∀ {p₁ p₂ : Σ a : α, β a} (h₁ : p₁.1 = p₂.1), (eq.rec_on h₁ p₁.2 : β p₂.1) = p₂.2 → p₁ = p₂
| ⟨a, b⟩ ⟨.(a), .(b)⟩ rfl rfl := rfl
end

section
variables {α : Sort u} {β : α → Sort v}

protected lemma psigma.eq : ∀ {p₁ p₂ : psigma β} (h₁ : p₁.1 = p₂.1), (eq.rec_on h₁ p₁.2 : β p₂.1) = p₂.2 → p₁ = p₂
| ⟨a, b⟩ ⟨.(a), .(b)⟩ rfl rfl := rfl
end


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

! This file was ported from Lean 3 source module analysis.box_integral.integrability
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.BoxIntegral.Basic
import Mathbin.MeasureTheory.Measure.Regular

/-!
# McShane integrability vs Bochner integrability

In this file we prove that any Bochner integrable function is McShane integrable (hence, it is
Henstock and `⊥` integrable) with the same integral. The proof is based on
[Russel A. Gordon, *The integrals of Lebesgue, Denjoy, Perron, and Henstock*][Gordon55].

## Tags

integral, McShane integral, Bochner integral
-/

open Classical NNReal ENNReal Topology BigOperators

universe u v

variable {ι : Type u} {E : Type v} [Fintype ι] [NormedAddCommGroup E] [NormedSpace ℝ E]

open MeasureTheory Metric Set Finset Filter BoxIntegral

namespace BoxIntegral

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (F «expr ⊆ » «expr ∩ »(s, I.Icc)) -/
/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (U «expr ⊇ » «expr ∩ »(s, I.Icc)) -/
/-- The indicator function of a measurable set is McShane integrable with respect to any
locally-finite measure. -/
theorem hasIntegralIndicatorConst (l : IntegrationParams) (hl : l.bRiemann = false)
    {s : Set (ι → ℝ)} (hs : MeasurableSet s) (I : Box ι) (y : E) (μ : Measure (ι → ℝ))
    [IsLocallyFiniteMeasure μ] :
    HasIntegral.{u, v, v} I l (s.indicator fun _ => y) μ.toBoxAdditive.toSmul
      ((μ (s ∩ I)).toReal • y) :=
  by
  refine' has_integral_of_mul ‖y‖ fun ε ε0 => _
  lift ε to ℝ≥0 using ε0.le
  rw [NNReal.coe_pos] at ε0
  /- First we choose a closed set `F ⊆ s ∩ I.Icc` and an open set `U ⊇ s` such that
    both `(s ∩ I.Icc) \ F` and `U \ s` have measuer less than `ε`. -/
  have A : μ (s ∩ I.Icc) ≠ ∞ :=
    ((measure_mono <| Set.inter_subset_right _ _).trans_lt (I.measure_Icc_lt_top μ)).Ne
  have B : μ (s ∩ I) ≠ ∞ :=
    ((measure_mono <| Set.inter_subset_right _ _).trans_lt (I.measure_coe_lt_top μ)).Ne
  obtain ⟨F, hFs, hFc, hμF⟩ : ∃ (F : _)(_ : F ⊆ s ∩ I.Icc), IsClosed F ∧ μ ((s ∩ I.Icc) \ F) < ε
  exact (hs.inter I.measurable_set_Icc).exists_isClosed_diff_lt A (ENNReal.coe_pos.2 ε0).ne'
  obtain ⟨U, hsU, hUo, hUt, hμU⟩ :
    ∃ (U : _)(_ : U ⊇ s ∩ I.Icc), IsOpen U ∧ μ U < ∞ ∧ μ (U \ (s ∩ I.Icc)) < ε
  exact (hs.inter I.measurable_set_Icc).exists_isOpen_diff_lt A (ENNReal.coe_pos.2 ε0).ne'
  /- Then we choose `r` so that `closed_ball x (r x) ⊆ U` whenever `x ∈ s ∩ I.Icc` and
    `closed_ball x (r x)` is disjoint with `F` otherwise. -/
  have : ∀ x ∈ s ∩ I.Icc, ∃ r : Ioi (0 : ℝ), closed_ball x r ⊆ U := fun x hx =>
    Subtype.exists'.1 (nhds_basis_closed_ball.mem_iff.1 (hUo.mem_nhds <| hsU hx))
  choose! rs hrsU
  have : ∀ x ∈ I.Icc \ s, ∃ r : Ioi (0 : ℝ), closed_ball x r ⊆ Fᶜ := fun x hx =>
    Subtype.exists'.1
      (nhds_basis_closed_ball.mem_iff.1 (hFc.is_open_compl.mem_nhds fun hx' => hx.2 (hFs hx').1))
  choose! rs' hrs'F
  set r : (ι → ℝ) → Ioi (0 : ℝ) := s.piecewise rs rs'
  refine' ⟨fun c => r, fun c => l.r_cond_of_bRiemann_eq_ff hl, fun c π hπ hπp => _⟩
  rw [mul_comm]
  /- Then the union of boxes `J ∈ π` such that `π.tag ∈ s` includes `F` and is included by `U`,
    hence its measure is `ε`-close to the measure of `s`. -/
  dsimp [integral_sum]
  simp only [mem_closed_ball, dist_eq_norm, ← indicator_const_smul_apply,
    sum_indicator_eq_sum_filter, ← sum_smul, ← sub_smul, norm_smul, Real.norm_eq_abs, ←
    prepartition.filter_boxes, ← prepartition.measure_Union_to_real]
  refine' mul_le_mul_of_nonneg_right _ (norm_nonneg y)
  set t := (π.to_prepartition.filter fun J => π.tag J ∈ s).unionᵢ
  change abs ((μ t).toReal - (μ (s ∩ I)).toReal) ≤ ε
  have htU : t ⊆ U ∩ I :=
    by
    simp only [t, prepartition.Union_def, Union_subset_iff, prepartition.mem_filter, and_imp]
    refine' fun J hJ hJs x hx => ⟨hrsU _ ⟨hJs, π.tag_mem_Icc J⟩ _, π.le_of_mem' J hJ hx⟩
    simpa only [r, s.piecewise_eq_of_mem _ _ hJs] using hπ.1 J hJ (box.coe_subset_Icc hx)
  refine' abs_sub_le_iff.2 ⟨_, _⟩
  · refine' (ENNReal.le_toReal_sub B).trans (ENNReal.toReal_le_coe_of_le_coe _)
    refine' (tsub_le_tsub (measure_mono htU) le_rfl).trans (le_measure_diff.trans _)
    refine' (measure_mono fun x hx => _).trans hμU.le
    exact ⟨hx.1.1, fun hx' => hx.2 ⟨hx'.1, hx.1.2⟩⟩
  · have hμt : μ t ≠ ∞ := ((measure_mono (htU.trans (inter_subset_left _ _))).trans_lt hUt).Ne
    refine' (ENNReal.le_toReal_sub hμt).trans (ENNReal.toReal_le_coe_of_le_coe _)
    refine' le_measure_diff.trans ((measure_mono _).trans hμF.le)
    rintro x ⟨⟨hxs, hxI⟩, hxt⟩
    refine' ⟨⟨hxs, box.coe_subset_Icc hxI⟩, fun hxF => hxt _⟩
    simp only [t, prepartition.Union_def, prepartition.mem_filter, Set.mem_unionᵢ, exists_prop]
    rcases hπp x hxI with ⟨J, hJπ, hxJ⟩
    refine' ⟨J, ⟨hJπ, _⟩, hxJ⟩
    contrapose hxF
    refine' hrs'F _ ⟨π.tag_mem_Icc J, hxF⟩ _
    simpa only [r, s.piecewise_eq_of_not_mem _ _ hxF] using hπ.1 J hJπ (box.coe_subset_Icc hxJ)
#align box_integral.has_integral_indicator_const BoxIntegral.hasIntegralIndicatorConst

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (U «expr ⊇ » «expr ⁻¹' »(N, {n})) -/
/-- If `f` is a.e. equal to zero on a rectangular box, then it has McShane integral zero on this
box. -/
theorem hasIntegralZeroOfAeEqZero {l : IntegrationParams} {I : Box ι} {f : (ι → ℝ) → E}
    {μ : Measure (ι → ℝ)} [IsLocallyFiniteMeasure μ] (hf : f =ᵐ[μ.restrict I] 0)
    (hl : l.bRiemann = false) : HasIntegral.{u, v, v} I l f μ.toBoxAdditive.toSmul 0 :=
  by
  /- Each set `{x | n < ‖f x‖ ≤ n + 1}`, `n : ℕ`, has measure zero. We cover it by an open set of
    measure less than `ε / 2 ^ n / (n + 1)`. Then the norm of the integral sum is less than `ε`. -/
  refine' has_integral_iff.2 fun ε ε0 => _
  lift ε to ℝ≥0 using ε0.lt.le
  rw [gt_iff_lt, NNReal.coe_pos] at ε0
  rcases NNReal.exists_pos_sum_of_countable ε0.ne' ℕ with ⟨δ, δ0, c, hδc, hcε⟩
  haveI := Fact.mk (I.measure_coe_lt_top μ)
  change μ.restrict I { x | f x ≠ 0 } = 0 at hf
  set N : (ι → ℝ) → ℕ := fun x => ⌈‖f x‖⌉₊
  have N0 : ∀ {x}, N x = 0 ↔ f x = 0 := by
    intro x
    simp [N]
  have : ∀ n, ∃ (U : _)(_ : U ⊇ N ⁻¹' {n}), IsOpen U ∧ μ.restrict I U < δ n / n :=
    by
    refine' fun n => (N ⁻¹' {n}).exists_isOpen_lt_of_lt _ _
    cases n
    · simpa [ENNReal.div_zero (ENNReal.coe_pos.2 (δ0 _)).ne'] using measure_lt_top (μ.restrict I) _
    · refine' (measure_mono_null _ hf).le.trans_lt _
      · exact fun x hxN hxf => n.succ_ne_zero ((Eq.symm hxN).trans <| N0.2 hxf)
      · simp [(δ0 _).ne']
  choose U hNU hUo hμU
  have : ∀ x, ∃ r : Ioi (0 : ℝ), closed_ball x r ⊆ U (N x) := fun x =>
    Subtype.exists'.1 (nhds_basis_closed_ball.mem_iff.1 ((hUo _).mem_nhds (hNU _ rfl)))
  choose r hrU
  refine' ⟨fun _ => r, fun c => l.r_cond_of_bRiemann_eq_ff hl, fun c π hπ hπp => _⟩
  rw [dist_eq_norm, sub_zero, ← integral_sum_fiberwise fun J => N (π.tag J)]
  refine' le_trans _ (NNReal.coe_lt_coe.2 hcε).le
  refine'
    (norm_sum_le_of_le _ _).trans (sum_le_hasSum _ (fun n _ => (δ n).2) (NNReal.hasSum_coe.2 hδc))
  rintro n -
  dsimp [integral_sum]
  have :
    ∀ J ∈ π.filter fun J => N (π.tag J) = n, ‖(μ ↑J).toReal • f (π.tag J)‖ ≤ (μ J).toReal * n :=
    by
    intro J hJ
    rw [tagged_prepartition.mem_filter] at hJ
    rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg ENNReal.toReal_nonneg]
    exact mul_le_mul_of_nonneg_left (hJ.2 ▸ Nat.le_ceil _) ENNReal.toReal_nonneg
  refine' (norm_sum_le_of_le _ this).trans _
  clear this
  rw [← sum_mul, ← prepartition.measure_Union_to_real]
  generalize hm : μ (π.filter fun J => N (π.tag J) = n).unionᵢ = m
  have : m < δ n / n :=
    by
    simp only [measure.restrict_apply (hUo _).MeasurableSet] at hμU
    refine' hm ▸ (measure_mono _).trans_lt (hμU _)
    simp only [Set.subset_def, tagged_prepartition.mem_Union, exists_prop,
      tagged_prepartition.mem_filter]
    rintro x ⟨J, ⟨hJ, rfl⟩, hx⟩
    exact ⟨hrU _ (hπ.1 _ hJ (box.coe_subset_Icc hx)), π.le_of_mem' J hJ hx⟩
  lift m to ℝ≥0 using ne_top_of_lt this
  rw [ENNReal.coe_toReal, ← NNReal.coe_nat_cast, ← NNReal.coe_mul, NNReal.coe_le_coe, ←
    ENNReal.coe_le_coe, ENNReal.coe_mul, ENNReal.coe_nat, mul_comm]
  exact (mul_le_mul_left' this.le _).trans ENNReal.mul_div_le
#align box_integral.has_integral_zero_of_ae_eq_zero BoxIntegral.hasIntegralZeroOfAeEqZero

/-- If `f` has integral `y` on a box `I` with respect to a locally finite measure `μ` and `g` is
a.e. equal to `f` on `I`, then `g` has the same integral on `I`.  -/
theorem HasIntegral.congrAe {l : IntegrationParams} {I : Box ι} {y : E} {f g : (ι → ℝ) → E}
    {μ : Measure (ι → ℝ)} [IsLocallyFiniteMeasure μ]
    (hf : HasIntegral.{u, v, v} I l f μ.toBoxAdditive.toSmul y) (hfg : f =ᵐ[μ.restrict I] g)
    (hl : l.bRiemann = false) : HasIntegral.{u, v, v} I l g μ.toBoxAdditive.toSmul y :=
  by
  have : g - f =ᵐ[μ.restrict I] 0 := hfg.mono fun x hx => sub_eq_zero.2 hx.symm
  simpa using hf.add (has_integral_zero_of_ae_eq_zero this hl)
#align box_integral.has_integral.congr_ae BoxIntegral.HasIntegral.congrAe

end BoxIntegral

namespace MeasureTheory

namespace SimpleFunc

/-- A simple function is McShane integrable w.r.t. any locally finite measure. -/
theorem hasBoxIntegral (f : SimpleFunc (ι → ℝ) E) (μ : Measure (ι → ℝ)) [IsLocallyFiniteMeasure μ]
    (I : Box ι) (l : IntegrationParams) (hl : l.bRiemann = false) :
    HasIntegral.{u, v, v} I l f μ.toBoxAdditive.toSmul (f.integral (μ.restrict I)) :=
  by
  induction' f using MeasureTheory.SimpleFunc.induction with y s hs f g hd hfi hgi
  ·
    simpa only [measure.restrict_apply hs, const_zero, integral_piecewise_zero, integral_const,
      measure.restrict_apply, MeasurableSet.univ, Set.univ_inter] using
      BoxIntegral.hasIntegralIndicatorConst l hl hs I y μ
  · borelize E
    haveI := Fact.mk (I.measure_coe_lt_top μ)
    rw [integral_add]
    exacts[hfi.add hgi, integrable_iff.2 fun _ _ => measure_lt_top _ _,
      integrable_iff.2 fun _ _ => measure_lt_top _ _]
#align measure_theory.simple_func.has_box_integral MeasureTheory.SimpleFunc.hasBoxIntegral

/-- For a simple function, its McShane (or Henstock, or `⊥`) box integral is equal to its
integral in the sense of `measure_theory.simple_func.integral`. -/
theorem box_integral_eq_integral (f : SimpleFunc (ι → ℝ) E) (μ : Measure (ι → ℝ))
    [IsLocallyFiniteMeasure μ] (I : Box ι) (l : IntegrationParams) (hl : l.bRiemann = false) :
    BoxIntegral.integral.{u, v, v} I l f μ.toBoxAdditive.toSmul = f.integral (μ.restrict I) :=
  (f.hasBoxIntegral μ I l hl).integral_eq
#align measure_theory.simple_func.box_integral_eq_integral MeasureTheory.SimpleFunc.box_integral_eq_integral

end SimpleFunc

open TopologicalSpace

/-- If `f : ℝⁿ → E` is Bochner integrable w.r.t. a locally finite measure `μ` on a rectangular box
`I`, then it is McShane integrable on `I` with the same integral.  -/
theorem IntegrableOn.hasBoxIntegral [CompleteSpace E] {f : (ι → ℝ) → E} {μ : Measure (ι → ℝ)}
    [IsLocallyFiniteMeasure μ] {I : Box ι} (hf : IntegrableOn f I μ) (l : IntegrationParams)
    (hl : l.bRiemann = false) :
    HasIntegral.{u, v, v} I l f μ.toBoxAdditive.toSmul (∫ x in I, f x ∂μ) :=
  by
  borelize E
  -- First we replace an `ae_strongly_measurable` function by a measurable one.
  rcases hf.ae_strongly_measurable with ⟨g, hg, hfg⟩
  haveI : separable_space (range g ∪ {0} : Set E) := hg.separable_space_range_union_singleton
  rw [integral_congr_ae hfg]
  have hgi : integrable_on g I μ := (integrable_congr hfg).1 hf
  refine' BoxIntegral.HasIntegral.congrAe _ hfg.symm hl
  clear! f
  /- Now consider the sequence of simple functions
    `simple_func.approx_on g hg.measurable (range g ∪ {0}) 0 (by simp)`
    approximating `g`. Recall some properties of this sequence. -/
  set f : ℕ → simple_func (ι → ℝ) E :=
    simple_func.approx_on g hg.measurable (range g ∪ {0}) 0 (by simp)
  have hfi : ∀ n, integrable_on (f n) I μ :=
    simple_func.integrable_approx_on_range hg.measurable hgi
  have hfi' := fun n => ((f n).hasBoxIntegral μ I l hl).Integrable
  have hfgi : tendsto (fun n => (f n).integral (μ.restrict I)) at_top (𝓝 <| ∫ x in I, g x ∂μ) :=
    tendsto_integral_approx_on_of_measurable_of_range_subset hg.measurable hgi _ subset.rfl
  have hfg_mono : ∀ (x) {m n}, m ≤ n → ‖f n x - g x‖ ≤ ‖f m x - g x‖ :=
    by
    intro x m n hmn
    rw [← dist_eq_norm, ← dist_eq_norm, dist_nndist, dist_nndist, NNReal.coe_le_coe, ←
      ENNReal.coe_le_coe, ← edist_nndist, ← edist_nndist]
    exact simple_func.edist_approx_on_mono hg.measurable _ x hmn
  /- Now consider `ε > 0`. We need to find `r` such that for any tagged partition subordinate
    to `r`, the integral sum is `(μ I + 1 + 1) * ε`-close to the Bochner integral. -/
  refine' has_integral_of_mul ((μ I).toReal + 1 + 1) fun ε ε0 => _
  lift ε to ℝ≥0 using ε0.le
  rw [NNReal.coe_pos] at ε0
  have ε0' := ENNReal.coe_pos.2 ε0
  -- Choose `N` such that the integral of `‖f N x - g x‖` is less than or equal to `ε`.
  obtain ⟨N₀, hN₀⟩ : ∃ N : ℕ, (∫ x in I, ‖f N x - g x‖ ∂μ) ≤ ε :=
    by
    have : tendsto (fun n => ∫⁻ x in I, ‖f n x - g x‖₊ ∂μ) at_top (𝓝 0) :=
      simple_func.tendsto_approx_on_range_L1_nnnorm hg.measurable hgi
    refine' (this.eventually (ge_mem_nhds ε0')).exists.imp fun N hN => _
    exact integral_coe_le_of_lintegral_coe_le hN
  -- For each `x`, we choose `Nx x ≥ N₀` such that `dist (f Nx x) (g x) ≤ ε`.
  have : ∀ x, ∃ N₁, N₀ ≤ N₁ ∧ dist (f N₁ x) (g x) ≤ ε :=
    by
    intro x
    have : tendsto (fun n => f n x) at_top (𝓝 <| g x) :=
      simple_func.tendsto_approx_on hg.measurable _ (subset_closure (by simp))
    exact ((eventually_ge_at_top N₀).And <| this <| closed_ball_mem_nhds _ ε0).exists
  choose Nx hNx hNxε
  -- We also choose a convergent series with `∑' i : ℕ, δ i < ε`.
  rcases NNReal.exists_pos_sum_of_countable ε0.ne' ℕ with ⟨δ, δ0, c, hδc, hcε⟩
  /- Since each simple function `fᵢ` is integrable, there exists `rᵢ : ℝⁿ → (0, ∞)` such that
    the integral sum of `f` over any tagged prepartition is `δᵢ`-close to the sum of integrals
    of `fᵢ` over the boxes of this prepartition. For each `x`, we choose `r (Nx x)` as the radius
    at `x`. -/
  set r : ℝ≥0 → (ι → ℝ) → Ioi (0 : ℝ) := fun c x => (hfi' <| Nx x).convergenceR (δ <| Nx x) c x
  refine' ⟨r, fun c => l.r_cond_of_bRiemann_eq_ff hl, fun c π hπ hπp => _⟩
  /- Now we prove the estimate in 3 "jumps": first we replace `g x` in the formula for the
    integral sum by `f (Nx x)`; then we replace each `μ J • f (Nx (π.tag J)) (π.tag J)`
    by the Bochner integral of `f (Nx (π.tag J)) x` over `J`, then we jump to the Bochner
    integral of `g`. -/
  refine'
    (dist_triangle4 _ (∑ J in π.boxes, (μ J).toReal • f (Nx <| π.tag J) (π.tag J))
          (∑ J in π.boxes, ∫ x in J, f (Nx <| π.tag J) x ∂μ) _).trans
      _
  rw [add_mul, add_mul, one_mul]
  refine' add_le_add_three _ _ _
  · /- Since each `f (Nx $ π.tag J)` is `ε`-close to `g (π.tag J)`, replacing the latter with
        the former in the formula for the integral sum changes the sum at most by `μ I * ε`. -/
    rw [← hπp.Union_eq, π.to_prepartition.measure_Union_to_real, sum_mul, integral_sum]
    refine' dist_sum_sum_le_of_le _ fun J hJ => _
    dsimp
    rw [dist_eq_norm, ← smul_sub, norm_smul, Real.norm_eq_abs, abs_of_nonneg ENNReal.toReal_nonneg]
    refine' mul_le_mul_of_nonneg_left _ ENNReal.toReal_nonneg
    rw [← dist_eq_norm']
    exact hNxε _
  · /- We group the terms of both sums by the values of `Nx (π.tag J)`.
        For each `N`, the sum of Bochner integrals over the boxes is equal
        to the sum of box integrals, and the sum of box integrals is `δᵢ`-close
        to the corresponding integral sum due to the Henstock-Sacks inequality. -/
    rw [← π.to_prepartition.sum_fiberwise fun J => Nx (π.tag J), ←
      π.to_prepartition.sum_fiberwise fun J => Nx (π.tag J)]
    refine' le_trans _ (NNReal.coe_lt_coe.2 hcε).le
    refine'
      (dist_sum_sum_le_of_le _ fun n hn => _).trans
        (sum_le_hasSum _ (fun n _ => (δ n).2) (NNReal.hasSum_coe.2 hδc))
    have hNxn : ∀ J ∈ π.filter fun J => Nx (π.tag J) = n, Nx (π.tag J) = n := fun J hJ =>
      (π.mem_filter.1 hJ).2
    have hrn :
      ∀ J ∈ π.filter fun J => Nx (π.tag J) = n,
        r c (π.tag J) = (hfi' n).convergenceR (δ n) c (π.tag J) :=
      by
      intro J hJ
      obtain rfl := hNxn J hJ
      rfl
    have :
      l.mem_base_set I c ((hfi' n).convergenceR (δ n) c) (π.filter fun J => Nx (π.tag J) = n) :=
      (hπ.filter _).mono' _ le_rfl le_rfl fun J hJ => (hrn J hJ).le
    convert(hfi' n).dist_integralSum_sum_integral_le_of_memBaseSet (δ0 _) this using 2
    · refine' sum_congr rfl fun J hJ => _
      simp [hNxn J hJ]
    · refine' sum_congr rfl fun J hJ => _
      rw [← simple_func.integral_eq_integral, simple_func.box_integral_eq_integral _ _ _ _ hl,
        hNxn J hJ]
      exact (hfi _).monoSet (prepartition.le_of_mem _ hJ)
  · /-  For the last jump, we use the fact that the distance between `f (Nx x) x` and `g x` is less
        than or equal to the distance between `f N₀ x` and `g x` and the integral of `‖f N₀ x - g x‖`
        is less than or equal to `ε`. -/
    refine' le_trans _ hN₀
    have hfi : ∀ (n), ∀ J ∈ π, integrable_on (f n) (↑J) μ := fun n J hJ =>
      (hfi n).monoSet (π.le_of_mem' J hJ)
    have hgi : ∀ J ∈ π, integrable_on g (↑J) μ := fun J hJ => hgi.mono_set (π.le_of_mem' J hJ)
    have hfgi : ∀ (n), ∀ J ∈ π, integrable_on (fun x => ‖f n x - g x‖) J μ := fun n J hJ =>
      ((hfi n J hJ).sub (hgi J hJ)).norm
    rw [← hπp.Union_eq, prepartition.Union_def',
      integral_finset_bUnion π.boxes (fun J hJ => J.measurableSet_coe) π.pairwise_disjoint hgi,
      integral_finset_bUnion π.boxes (fun J hJ => J.measurableSet_coe) π.pairwise_disjoint (hfgi _)]
    refine' dist_sum_sum_le_of_le _ fun J hJ => _
    rw [dist_eq_norm, ← integral_sub (hfi _ J hJ) (hgi J hJ)]
    refine' norm_integral_le_of_norm_le (hfgi _ J hJ) (eventually_of_forall fun x => _)
    exact hfg_mono x (hNx (π.tag J))
#align measure_theory.integrable_on.has_box_integral MeasureTheory.IntegrableOn.hasBoxIntegral

end MeasureTheory


/- Introduces types of Synchronous GV. -/

import metastuff

mutual inductive tp, sesh_tp
/- A, B, C -/
with tp: Type
| unit: tp
| fn: tp → tp → tp /- A⊸B -/
| sum: tp → tp → tp /- A+B -/
| prod: tp → tp → tp /- AxB -/
| sesh: sesh_tp → tp /- S -/
| hash: sesh_tp → tp /- S♯ -/
/- S, T -/
with sesh_tp: Type
| send: tp → sesh_tp → sesh_tp /- !A.S -/
| recv: tp → sesh_tp → sesh_tp /- ?A.S -/
| end_send: sesh_tp /- End! -/
| end_recv: sesh_tp /- End? -/

infix `⊸`:90 := tp.fn
notation S`♯`:90 := tp.hash S
notation `End!` := sesh_tp.end_send
notation `End?` := sesh_tp.end_recv
notation `!`A`⬝`S:90 := sesh_tp.send A S
notation `?`A`⬝`S:90 := sesh_tp.recv A S

/- Automatically coerce session types to types. -/
instance sesh_tp_to_tp : has_coe sesh_tp tp :=
  ⟨λ S, tp.sesh S⟩

namespace sesh_tp

-- TODO perhaps this should be an inductive relation.
def dual: sesh_tp → sesh_tp
| !A⬝S := ?A⬝(dual S)
| ?A⬝S := !A⬝(dual S)
| End! := End?
| End? := End!

lemma dual_dual (S: sesh_tp)
  : dual (dual S) = S :=
begin
  induction S with _ _ ih _ _ ih ih ih;
  unfold dual;
  rw [ih]
end

@[simp] lemma dual_end_send: dual End! = End? := by refl
@[simp] lemma dual_end_recv: dual End? = End! := by refl

-- dual S♯ = S♯ should work as an axiom to remove both connects
-- could be added to the session type/environment reduction -> this might break associativity proof
-- but could be better if added as a separate relation -~~>

end sesh_tp


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import analysis.normed_space.hahn_banach.extension
import combinatorics.double_counting
import order.partition.finpartition

/-!
# The Littlewood-Offord problem

-/

open_locale big_operators

namespace finset
variables {ι E : Type*} [normed_add_comm_group E] [normed_space ℝ E] {𝒜 : finset (finset ι)}
  {s : finset ι} {f : ι → E} {r : ℝ}

lemma exists_littlewood_offord_partition [decidable_eq ι] (hr : 0 < r) (hf : ∀ i ∈ s, r ≤ ‖f i‖) :
  ∃ P : finpartition s.powerset,
    P.parts.card = s.card.choose (s.card / 2) ∧
    (∀ (𝒜 ∈ P.parts) (t ∈ 𝒜), t ⊆ s) ∧
    (∀ 𝒜 ∈ P.parts,
      (𝒜 : set (finset ι)).pairwise $ λ u v, r ≤ dist (∑ i in u, f i) (∑ i in v, f i)) :=
begin
  classical,
  induction s using finset.induction with i s hi ih,
  { exact ⟨finpartition.indiscrete $ singleton_ne_empty _, by simp⟩ },
  obtain ⟨P, hP, hs, hPr⟩ := ih (λ j hj, hf _ $ mem_insert_of_mem hj),
  clear ih,
  obtain ⟨g, hg, hgf⟩ := exists_dual_vector ℝ (f i)
    (norm_pos_iff.1 $ hr.trans_le $ hf _ $ mem_insert_self _ _),
  choose t ht using λ 𝒜 (h𝒜 : 𝒜 ∈ P.parts),
    finset.exists_max_image _ (λ t, g (∑ i in t, f i)) (P.nonempty_of_mem_parts h𝒜),
  sorry,
end

/-- **Kleitman's theorem** -/
lemma card_le_of_forall_dist_sum_le (hr : 0 < r) (h𝒜 : ∀ t ∈ 𝒜, t ⊆ s) (hf : ∀ i ∈ s, r ≤ ‖f i‖)
  (h𝒜r : ∀ u v ∈ 𝒜, dist (∑ i in u, f i) (∑ i in v, f i) < r) :
  𝒜.card ≤ s.card.choose (s.card / 2) :=
begin
  classical,
  obtain ⟨P, hP, hs, hr⟩ := exists_littlewood_offord_partition hr hf,
  rw ←hP,
  refine card_le_card_of_forall_subsingleton (∈) (λ t ht, _)
    (λ ℬ hℬ t ht u hu, (hr _ hℬ).eq ht.2 hu.2 (h𝒜r _ ht.1 _ hu.1).not_le),
  simpa only [exists_prop] using P.exists_mem (mem_powerset.2 $ h𝒜 _ ht),
end

end finset


import tactic --hide

/-Lemma
If $P$ is a logical statement then $P \implies ¬P$ implies $\mathrm{false}$.
-/

lemma P_imp_not_P_false (P : Prop) : P → ¬ P → false :=
begin
  intros h1 h2,
  apply h2,
  exact h1,

end