import Cat.Fam.Functor

/-! # Additional definitions for functors -/

namespace Cat

/-! ## Functors and iso arrows/objects  -/
section iso_proper
  variable
    {ℂ₁ ℂ₂ : Fam.Cat}
    (F : Fam.Cat.Func ℂ₁ ℂ₂)

  theorem Fam.Cat.Func.proper_inv
    {α β : ℂ₁.Obj}
    {f₁ : α ↠ β}
    {f₂ : β ↠ α}
    (h : f₁ ⊚ f₂ ≈ ℂ₁.id)
  : (F.fMap f₁) ⊚ (F.fMap f₂) ≈ F.id :=
    let f₁' :=
      F.fMap f₁
    let f₂' :=
      F.fMap f₂
    let h₁ : f₁' ⊚ f₂' ≈ F.fMap (f₁ ⊚ f₂) :=
      F.comp_law f₁ f₂
      |> Setoid.symm
    let h₂ : f₁' ⊚ f₂' ≈ F.fMap ℂ₁.id :=
      F.fmap_proper h
      |> Setoid.trans h₁
    let h₃ : f₁' ⊚ f₂' ≈ ℂ₂.id :=
      F.id_law' β
      |> Setoid.trans h₂
    h₃

  /-- Functors preserve the *iso* property over arrows. -/
  instance instIsoFuncIso
    {F : Fam.Cat.Func ℂ₁ ℂ₂}
    {α β : ℂ₁.Obj}
    (f : α ↠ β)
    [instIso : Fam.Cat.Iso f]
  : Fam.Cat.Iso (F.fmap f) :=
    let fInv' :=
      F.fmap instIso.inv
    Fam.Cat.Iso.mk
      fInv'
      (F.proper_inv instIso.law_left)
      (F.proper_inv instIso.law_right)

  /-- Functors preserve the *iso* property over objects. -/
  instance instIsoObjFuncIsoObj
    {α β : ℂ₁.Obj}
    (h_iso : α ≅ β)
  : F α ≅ F β where
    iso :=
      F.fmap h_iso.iso
    instIso :=
      instIsoFuncIso h_iso.iso

end iso_proper

/-! ## Faithful / full functors -/
section
  variable
    {ℂ₁ ℂ₂ : Fam.Cat}
    (F : Fam.Cat.Func ℂ₁ ℂ₂)

  /-- Proof that a functor is *faithful*, *i.e.* `F f ≈ F g → f ≈ g`. -/
  class Fam.Cat.Func.Faithful
    {ℂ₁ ℂ₂ : Cat}
    (F : Func ℂ₁ ℂ₂)
  where
    /-- Faithfulness law. -/
    law' :
      ∀ {α β : ℂ₁.Obj} (f g : α ↠ β),
        F.fmap f ≈ F.fmap g → f ≈ g

  /-- Same as `Faithful.law'` but `f` and `g` are implicit. -/
  @[simp]
  abbrev Fam.Cat.Func.Faithful.law
    [inst : Faithful F]
    {α β : ℂ₁.Obj}
    {f g : α ↠ β}
  : F.fmap f ≈ F.fmap g → f ≈ g :=
    inst.law' f g

  /-- Faithfulness is closed under functor composition. -/
  instance instFaithfulFuncComp
    (F₂₃ : Fam.Cat.Func ℂ₂ ℂ₃)
    [inst₂₃ : Fam.Cat.Func.Faithful F₂₃]
    (F₁₂ : Fam.Cat.Func ℂ₁ ℂ₂)
    [inst₁₂ : Fam.Cat.Func.Faithful F₁₂]
  : Fam.Cat.Func.Faithful (F₂₃ ⊙ F₁₂) where
    law' {α β} (f g) h :=
      by
        apply inst₁₂.law
        apply inst₂₃.law
        exact h

  /-- Proof that a functor is *full*, *i.e.* any `h : F α ↠ F β` has a preimage by `F.fmap`. -/
  class Fam.Cat.Func.Full
    {ℂ₁ ℂ₂ : Cat}
    (F : Func ℂ₁ ℂ₂)
  where
    /-- Yields the preimage of `h` by `F.fmap`. -/
    preimage
      {α β : ℂ₁.Obj}
      (h : F α ↠ F β)
    : α ↠ β
    /-- Proof that `h` and the image of its preimage are equivalent. -/
    law'
      {α β : ℂ₁.Obj}
      (h : F α ↠ F β)
    : h ≈ F.fmap (preimage h)

  /-- Same as `Full.law'` but `h` is implicit. -/
  @[simp]
  abbrev Fam.Cat.Func.Full.law
    [inst : Full F]
    {α β : ℂ₁.Obj}
    {h : F α ↠ F β}
  : h ≈ F.fmap (inst.preimage h) :=
    inst.law' h

  /-- Fullness is closed under functor composition. -/
  instance instFullFuncComp
    (F₂₃ : Fam.Cat.Func ℂ₂ ℂ₃)
    [inst₂₃ : Fam.Cat.Func.Full F₂₃]
    (F₁₂ : Fam.Cat.Func ℂ₁ ℂ₂)
    [inst₁₂ : Fam.Cat.Func.Full F₁₂]
  : Fam.Cat.Func.Full (F₂₃ ⊙ F₁₂) where
    preimage h :=
      inst₂₃.preimage h
      |> inst₁₂.preimage
    law' g₃ :=
      let g₂ :=
        inst₂₃.preimage g₃
      let g₁ :=
        inst₁₂.preimage g₂
      let h : g₃ ≈ F₂₃.fmap g₂ :=
        inst₂₃.law
      let h' : g₂ ≈ F₁₂.fmap g₁ :=
        inst₁₂.law
      let h : g₃ ≈ F₂₃.fmap (F₁₂.fmap g₁) :=
        F₂₃.fmap_proper h'
        |> Setoid.trans h
      h

end


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.preadditive.basic
import algebra.module.linear_map
import algebra.invertible
import algebra.algebra.basic

/-!
# Linear categories

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

An `R`-linear category is a category in which `X ⟶ Y` is an `R`-module in such a way that
composition of morphisms is `R`-linear in both variables.

Note that sometimes in the literature a "linear category" is further required to be abelian.

## Implementation

Corresponding to the fact that we need to have an `add_comm_group X` structure in place
to talk about a `module R X` structure,
we need `preadditive C` as a prerequisite typeclass for `linear R C`.
This makes for longer signatures than would be ideal.

## Future work

It would be nice to have a usable framework of enriched categories in which this just became
a category enriched in `Module R`.

-/

universes w v u

open category_theory.limits
open linear_map

namespace category_theory

/-- A category is called `R`-linear if `P ⟶ Q` is an `R`-module such that composition is
    `R`-linear in both variables. -/
class linear (R : Type w) [semiring R] (C : Type u) [category.{v} C] [preadditive C] :=
(hom_module : Π X Y : C, module R (X ⟶ Y) . tactic.apply_instance)
(smul_comp' : ∀ (X Y Z : C) (r : R) (f : X ⟶ Y) (g : Y ⟶ Z),
  (r • f) ≫ g = r • (f ≫ g) . obviously)
(comp_smul' : ∀ (X Y Z : C) (f : X ⟶ Y) (r : R) (g : Y ⟶ Z),
  f ≫ (r • g) = r • (f ≫ g) . obviously)

attribute [instance] linear.hom_module
restate_axiom linear.smul_comp'
restate_axiom linear.comp_smul'
attribute [simp,reassoc] linear.smul_comp
attribute [reassoc, simp] linear.comp_smul -- (the linter doesn't like `simp` on the `_assoc` lemma)

end category_theory

open category_theory

namespace category_theory.linear

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

instance preadditive_nat_linear : linear ℕ C :=
{ smul_comp' := λ X Y Z r f g, (preadditive.right_comp X g).map_nsmul f r,
  comp_smul' := λ X Y Z f r g, (preadditive.left_comp Z f).map_nsmul g r, }

instance preadditive_int_linear : linear ℤ C :=
{ smul_comp' := λ X Y Z r f g, (preadditive.right_comp X g).map_zsmul f r,
  comp_smul' := λ X Y Z f r g, (preadditive.left_comp Z f).map_zsmul g r, }

section End

variables {R : Type w}

instance [semiring R] [linear R C] (X : C) : module R (End X) :=
by { dsimp [End], apply_instance, }

instance [comm_semiring R] [linear R C] (X : C) : algebra R (End X) :=
algebra.of_module (λ r f g, comp_smul _ _ _ _ _ _) (λ r f g, smul_comp _ _ _ _ _ _)

end End

section
variables {R : Type w} [semiring R] [linear R C]

section induced_category
universes u'
variables {C} {D : Type u'} (F : D → C)

instance induced_category : linear.{w v} R (induced_category C F) :=
{ hom_module := λ X Y, @linear.hom_module R _ C _ _ _ (F X) (F Y),
  smul_comp' := λ P Q R f f' g, smul_comp' _ _ _ _ _ _,
  comp_smul' := λ P Q R f g g', comp_smul' _ _ _ _ _ _, }

end induced_category

instance full_subcategory (Z : C → Prop) : linear.{w v} R (full_subcategory Z) :=
{ hom_module := λ X Y, @linear.hom_module R _ C _ _ _ X.obj Y.obj,
  smul_comp' := λ P Q R f f' g, smul_comp' _ _ _ _ _ _,
  comp_smul' := λ P Q R f g g', comp_smul' _ _ _ _ _ _, }

variables (R)

/-- Composition by a fixed left argument as an `R`-linear map. -/
@[simps]
def left_comp {X Y : C} (Z : C) (f : X ⟶ Y) : (Y ⟶ Z) →ₗ[R] (X ⟶ Z) :=
{ to_fun := λ g, f ≫ g,
  map_add' := by simp,
  map_smul' := by simp, }

/-- Composition by a fixed right argument as an `R`-linear map. -/
@[simps]
def right_comp (X : C) {Y Z : C} (g : Y ⟶ Z) : (X ⟶ Y) →ₗ[R] (X ⟶ Z) :=
{ to_fun := λ f, f ≫ g,
  map_add' := by simp,
  map_smul' := by simp, }

instance {X Y : C} (f : X ⟶ Y) [epi f] (r : R) [invertible r] : epi (r • f) :=
⟨λ R g g' H, begin
  rw [smul_comp, smul_comp, ←comp_smul, ←comp_smul, cancel_epi] at H,
  simpa [smul_smul] using congr_arg (λ f, ⅟r • f) H,
end⟩

instance {X Y : C} (f : X ⟶ Y) [mono f] (r : R) [invertible r] : mono (r • f) :=
⟨λ R g g' H, begin
  rw [comp_smul, comp_smul, ←smul_comp, ←smul_comp, cancel_mono] at H,
  simpa [smul_smul] using congr_arg (λ f, ⅟r • f) H,
end⟩

/-- Given isomorphic objects `X ≅ Y, W ≅ Z` in a `k`-linear category, we have a `k`-linear
isomorphism between `Hom(X, W)` and `Hom(Y, Z).` -/
def hom_congr (k : Type*) {C : Type*} [category C] [semiring k]
  [preadditive C] [linear k C] {X Y W Z : C} (f₁ : X ≅ Y) (f₂ : W ≅ Z) :
  (X ⟶ W) ≃ₗ[k] (Y ⟶ Z) :=
{ inv_fun := (left_comp k W f₁.hom).comp (right_comp k Y f₂.symm.hom),
  left_inv := λ x, by simp only [iso.symm_hom, linear_map.to_fun_eq_coe, linear_map.coe_comp,
    function.comp_app, left_comp_apply, right_comp_apply, category.assoc, iso.hom_inv_id,
    category.comp_id, iso.hom_inv_id_assoc],
  right_inv := λ x, by simp only [iso.symm_hom, linear_map.coe_comp, function.comp_app,
    right_comp_apply, left_comp_apply, linear_map.to_fun_eq_coe, iso.inv_hom_id_assoc,
    category.assoc, iso.inv_hom_id, category.comp_id],
  ..(right_comp k Y f₂.hom).comp (left_comp k W f₁.symm.hom) }

lemma hom_congr_apply (k : Type*) {C : Type*} [category C] [semiring k]
  [preadditive C] [linear k C] {X Y W Z : C} (f₁ : X ≅ Y) (f₂ : W ≅ Z) (f : X ⟶ W) :
  hom_congr k f₁ f₂ f = (f₁.inv ≫ f) ≫ f₂.hom := rfl

lemma hom_congr_symm_apply (k : Type*) {C : Type*} [category C] [semiring k]
  [preadditive C] [linear k C] {X Y W Z : C} (f₁ : X ≅ Y) (f₂ : W ≅ Z) (f : Y ⟶ Z) :
  (hom_congr k f₁ f₂).symm f = f₁.hom ≫ f ≫ f₂.inv := rfl

end

section
variables {S : Type w} [comm_semiring S] [linear S C]

/-- Composition as a bilinear map. -/
@[simps]
def comp (X Y Z : C) : (X ⟶ Y) →ₗ[S] ((Y ⟶ Z) →ₗ[S] (X ⟶ Z)) :=
{ to_fun := λ f, left_comp S Z f,
  map_add' := by { intros, ext, simp, },
  map_smul' := by { intros, ext, simp, }, }

end

end category_theory.linear


variables p q : Prop
variables (hp : p) (hq : q)

example : p ∧ q := (|hp, hq|)


/-
Copyright (c) 2021 Yakov Pechersky. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yakov Pechersky, Chris Hughes

! This file was ported from Lean 3 source module data.list.duplicate
! leanprover-community/mathlib commit f694c7dead66f5d4c80f446c796a5aad14707f0e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.List.Nodup

/-!
# List duplicates

## Main definitions

* `List.Duplicate x l : Prop` is an inductive property that holds when `x` is a duplicate in `l`

## Implementation details

In this file, `x ∈+ l` notation is shorthand for `List.Duplicate x l`.

-/

variable {α : Type _}

namespace List

/-- Property that an element `x : α` of `l : list α` can be found in the list more than once. -/
inductive Duplicate (x : α) : List α → Prop
  | cons_mem {l : List α} : x ∈ l → Duplicate x (x :: l)
  | cons_duplicate {y : α} {l : List α} : Duplicate x l → Duplicate x (y :: l)
#align list.duplicate List.Duplicate

-- mathport name: «expr ∈+ »
local infixl:50 " ∈+ " => List.Duplicate

variable {l : List α} {x : α}

theorem Mem.duplicate_cons_self (h : x ∈ l) : x ∈+ x :: l :=
  Duplicate.cons_mem h
#align list.mem.duplicate_cons_self List.Mem.duplicate_cons_self

theorem Duplicate.duplicate_cons (h : x ∈+ l) (y : α) : x ∈+ y :: l :=
  Duplicate.cons_duplicate h
#align list.duplicate.duplicate_cons List.Duplicate.duplicate_cons

theorem Duplicate.mem (h : x ∈+ l) : x ∈ l := by
  induction' h with l' _ y l' _ hm
  · exact mem_cons_self _ _
  · exact mem_cons_of_mem _ hm
#align list.duplicate.mem List.Duplicate.mem

theorem Duplicate.mem_cons_self (h : x ∈+ x :: l) : x ∈ l := by
  cases' h with _ h _ _ h
  · exact h
  · exact h.mem
#align list.duplicate.mem_cons_self List.Duplicate.mem_cons_self

@[simp]
theorem duplicate_cons_self_iff : x ∈+ x :: l ↔ x ∈ l :=
  ⟨Duplicate.mem_cons_self, Mem.duplicate_cons_self⟩
#align list.duplicate_cons_self_iff List.duplicate_cons_self_iff

theorem Duplicate.ne_nil (h : x ∈+ l) : l ≠ [] := fun H => (mem_nil_iff x).mp (H ▸ h.mem)
#align list.duplicate.ne_nil List.Duplicate.ne_nil

@[simp]
theorem not_duplicate_nil (x : α) : ¬x ∈+ [] := fun H => H.ne_nil rfl
#align list.not_duplicate_nil List.not_duplicate_nil

theorem Duplicate.ne_singleton (h : x ∈+ l) (y : α) : l ≠ [y] := by
  induction' h with l' h z l' h _
  · simp [ne_nil_of_mem h]
  · simp [ne_nil_of_mem h.mem]
#align list.duplicate.ne_singleton List.Duplicate.ne_singleton

@[simp]

theorem Duplicate.elim_nil (h : x ∈+ []) : False :=
  not_duplicate_nil x h
#align list.duplicate.elim_nil List.Duplicate.elim_nil

theorem Duplicate.elim_singleton {y : α} (h : x ∈+ [y]) : False :=
  not_duplicate_singleton x y h
#align list.duplicate.elim_singleton List.Duplicate.elim_singleton

theorem duplicate_cons_iff {y : α} : x ∈+ y :: l ↔ y = x ∧ x ∈ l ∨ x ∈+ l := by
  refine' ⟨fun h => _, fun h => _⟩
  · cases' h with _ hm _ _ hm
    · exact Or.inl ⟨rfl, hm⟩
    · exact Or.inr hm
  · rcases h with (⟨rfl | h⟩ | h)
    · simpa
    · exact h.cons_duplicate
#align list.duplicate_cons_iff List.duplicate_cons_iff

theorem Duplicate.of_duplicate_cons {y : α} (h : x ∈+ y :: l) (hx : x ≠ y) : x ∈+ l := by
  simpa [duplicate_cons_iff, hx.symm] using h
#align list.duplicate.of_duplicate_cons List.Duplicate.of_duplicate_cons

theorem duplicate_cons_iff_of_ne {y : α} (hne : x ≠ y) : x ∈+ y :: l ↔ x ∈+ l := by
  simp [duplicate_cons_iff, hne.symm]
#align list.duplicate_cons_iff_of_ne List.duplicate_cons_iff_of_ne

theorem Duplicate.mono_sublist {l' : List α} (hx : x ∈+ l) (h : l <+ l') : x ∈+ l' := by
  induction' h with l₁ l₂ y _ IH l₁ l₂ y h IH
  · exact hx
  · exact (IH hx).duplicate_cons _
  · rw [duplicate_cons_iff] at hx⊢
    rcases hx with (⟨rfl, hx⟩ | hx)
    · simp [h.subset hx]
    · simp [IH hx]
#align list.duplicate.mono_sublist List.Duplicate.mono_sublist

/-- The contrapositive of `List.nodup_iff_sublist`. -/
theorem duplicate_iff_sublist : x ∈+ l ↔ [x, x] <+ l := by
  induction' l with y l IH
  · simp
  · by_cases hx : x = y
    · simp [hx, cons_sublist_cons_iff, singleton_sublist]
    · rw [duplicate_cons_iff_of_ne hx, IH]
      refine' ⟨sublist_cons_of_sublist y, fun h => _⟩
      cases h
      · assumption
      · contradiction
#align list.duplicate_iff_sublist List.duplicate_iff_sublist

theorem nodup_iff_forall_not_duplicate : Nodup l ↔ ∀ x : α, ¬x ∈+ l := by
  simp_rw [nodup_iff_sublist, duplicate_iff_sublist]
#align list.nodup_iff_forall_not_duplicate List.nodup_iff_forall_not_duplicate

theorem exists_duplicate_iff_not_nodup : (∃ x : α, x ∈+ l) ↔ ¬Nodup l := by
  simp [nodup_iff_forall_not_duplicate]
#align list.exists_duplicate_iff_not_nodup List.exists_duplicate_iff_not_nodup

theorem Duplicate.not_nodup (h : x ∈+ l) : ¬Nodup l := fun H =>
  nodup_iff_forall_not_duplicate.mp H _ h
#align list.duplicate.not_nodup List.Duplicate.not_nodup

theorem duplicate_iff_two_le_count [DecidableEq α] : x ∈+ l ↔ 2 ≤ count x l := by
  simp [duplicate_iff_sublist, le_count_iff_replicate_sublist]
#align list.duplicate_iff_two_le_count List.duplicate_iff_two_le_count

instance decidableDuplicate [DecidableEq α] (x : α) : ∀ l : List α, Decidable (x ∈+ l)
  | [] => isFalse (not_duplicate_nil x)
  | y :: l =>
    match decidableDuplicate x l with
    | isTrue h => isTrue (h.duplicate_cons y)
    | isFalse h =>
      if hx : y = x ∧ x ∈ l then isTrue (hx.left.symm ▸ List.Mem.duplicate_cons_self hx.right)
      else isFalse (by simpa [duplicate_cons_iff, h] using hx)
#align list.decidable_duplicate List.decidableDuplicate

end List


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Kevin Buzzard, Jujian Zhang

! This file was ported from Lean 3 source module ring_theory.graded_algebra.basic
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.DirectSum.Algebra
import Mathbin.Algebra.DirectSum.Decomposition
import Mathbin.Algebra.DirectSum.Internal
import Mathbin.Algebra.DirectSum.Ring

/-!
# Internally-graded rings and algebras

This file defines the typeclass `graded_algebra 𝒜`, for working with an algebra `A` that is
internally graded by a collection of submodules `𝒜 : ι → submodule R A`.
See the docstring of that typeclass for more information.

## Main definitions

* `graded_ring 𝒜`: the typeclass, which is a combination of `set_like.graded_monoid`, and
  `direct_sum.decomposition 𝒜`.
* `graded_algebra 𝒜`: A convenience alias for `graded_ring` when `𝒜` is a family of submodules.
* `direct_sum.decompose_ring_equiv 𝒜 : A ≃ₐ[R] ⨁ i, 𝒜 i`, a more bundled version of
  `direct_sum.decompose 𝒜`.
* `direct_sum.decompose_alg_equiv 𝒜 : A ≃ₐ[R] ⨁ i, 𝒜 i`, a more bundled version of
  `direct_sum.decompose 𝒜`.
* `graded_algebra.proj 𝒜 i` is the linear map from `A` to its degree `i : ι` component, such that
  `proj 𝒜 i x = decompose 𝒜 x i`.

## Implementation notes

For now, we do not have internally-graded semirings and internally-graded rings; these can be
represented with `𝒜 : ι → submodule ℕ A` and `𝒜 : ι → submodule ℤ A` respectively, since all
`semiring`s are ℕ-algebras via `algebra_nat`, and all `ring`s are `ℤ`-algebras via `algebra_int`.

## Tags

graded algebra, graded ring, graded semiring, decomposition
-/

open DirectSum BigOperators

variable {ι R A σ : Type _}

section GradedRing

variable [DecidableEq ι] [AddMonoid ι] [CommSemiring R] [Semiring A] [Algebra R A]

variable [SetLike σ A] [AddSubmonoidClass σ A] (𝒜 : ι → σ)

include A

open DirectSum

/-- An internally-graded `R`-algebra `A` is one that can be decomposed into a collection
of `submodule R A`s indexed by `ι` such that the canonical map `A → ⨁ i, 𝒜 i` is bijective and
respects multiplication, i.e. the product of an element of degree `i` and an element of degree `j`
is an element of degree `i + j`.

Note that the fact that `A` is internally-graded, `graded_algebra 𝒜`, implies an externally-graded
algebra structure `direct_sum.galgebra R (λ i, ↥(𝒜 i))`, which in turn makes available an
`algebra R (⨁ i, 𝒜 i)` instance.
-/
class GradedRing (𝒜 : ι → σ) extends SetLike.GradedMonoid 𝒜, DirectSum.Decomposition 𝒜
#align graded_ring GradedRing

variable [GradedRing 𝒜]

namespace DirectSum

/-- If `A` is graded by `ι` with degree `i` component `𝒜 i`, then it is isomorphic as
a ring to a direct sum of components. -/
def decomposeRingEquiv : A ≃+* ⨁ i, 𝒜 i :=
  RingEquiv.symm
    {
      (decomposeAddEquiv 𝒜).symm with
      map_mul' := (coeRingHom 𝒜).map_mul
      map_add' := (coeRingHom 𝒜).map_add }
#align direct_sum.decompose_ring_equiv DirectSum.decomposeRingEquiv

@[simp]
theorem decompose_one : decompose 𝒜 (1 : A) = 1 :=
  map_one (decomposeRingEquiv 𝒜)
#align direct_sum.decompose_one DirectSum.decompose_one

@[simp]
theorem decompose_symm_one : (decompose 𝒜).symm 1 = (1 : A) :=
  map_one (decomposeRingEquiv 𝒜).symm
#align direct_sum.decompose_symm_one DirectSum.decompose_symm_one

@[simp]
theorem decompose_mul (x y : A) : decompose 𝒜 (x * y) = decompose 𝒜 x * decompose 𝒜 y :=
  map_mul (decomposeRingEquiv 𝒜) x y
#align direct_sum.decompose_mul DirectSum.decompose_mul

@[simp]
theorem decompose_symm_mul (x y : ⨁ i, 𝒜 i) :
    (decompose 𝒜).symm (x * y) = (decompose 𝒜).symm x * (decompose 𝒜).symm y :=
  map_mul (decomposeRingEquiv 𝒜).symm x y
#align direct_sum.decompose_symm_mul DirectSum.decompose_symm_mul

end DirectSum

/-- The projection maps of a graded ring -/
def GradedRing.proj (i : ι) : A →+ A :=
  (AddSubmonoidClass.Subtype (𝒜 i)).comp <|
    (Dfinsupp.evalAddMonoidHom i).comp <|
      RingHom.toAddMonoidHom <| RingEquiv.toRingHom <| DirectSum.decomposeRingEquiv 𝒜
#align graded_ring.proj GradedRing.proj

@[simp]
theorem GradedRing.proj_apply (i : ι) (r : A) :
    GradedRing.proj 𝒜 i r = (decompose 𝒜 r : ⨁ i, 𝒜 i) i :=
  rfl
#align graded_ring.proj_apply GradedRing.proj_apply

theorem GradedRing.proj_recompose (a : ⨁ i, 𝒜 i) (i : ι) :
    GradedRing.proj 𝒜 i ((decompose 𝒜).symm a) = (decompose 𝒜).symm (DirectSum.of _ i (a i)) := by
  rw [GradedRing.proj_apply, decompose_symm_of, Equiv.apply_symm_apply]
#align graded_ring.proj_recompose GradedRing.proj_recompose

theorem GradedRing.mem_support_iff [∀ (i) (x : 𝒜 i), Decidable (x ≠ 0)] (r : A) (i : ι) :
    i ∈ (decompose 𝒜 r).support ↔ GradedRing.proj 𝒜 i r ≠ 0 :=
  Dfinsupp.mem_support_iff.trans ZeroMemClass.coe_eq_zero.Not.symm
#align graded_ring.mem_support_iff GradedRing.mem_support_iff

end GradedRing

section AddCancelMonoid

open DirectSum

variable [DecidableEq ι] [Semiring A] [SetLike σ A] [AddSubmonoidClass σ A] (𝒜 : ι → σ)

variable {i j : ι}

namespace DirectSum

theorem coe_decompose_mul_add_of_left_mem [AddLeftCancelMonoid ι] [GradedRing 𝒜] {a b : A}
    (a_mem : a ∈ 𝒜 i) : (decompose 𝒜 (a * b) (i + j) : A) = a * decompose 𝒜 b j :=
  by
  lift a to 𝒜 i using a_mem
  rw [decompose_mul, decompose_coe, coe_of_mul_apply_add]
#align direct_sum.coe_decompose_mul_add_of_left_mem DirectSum.coe_decompose_mul_add_of_left_mem

theorem coe_decompose_mul_add_of_right_mem [AddRightCancelMonoid ι] [GradedRing 𝒜] {a b : A}
    (b_mem : b ∈ 𝒜 j) : (decompose 𝒜 (a * b) (i + j) : A) = decompose 𝒜 a i * b :=
  by
  lift b to 𝒜 j using b_mem
  rw [decompose_mul, decompose_coe, coe_mul_of_apply_add]
#align direct_sum.coe_decompose_mul_add_of_right_mem DirectSum.coe_decompose_mul_add_of_right_mem

theorem decompose_mul_add_left [AddLeftCancelMonoid ι] [GradedRing 𝒜] (a : 𝒜 i) {b : A} :
    decompose 𝒜 (↑a * b) (i + j) =
      @GradedMonoid.GMul.mul ι (fun i => 𝒜 i) _ _ _ _ a (decompose 𝒜 b j) :=
  Subtype.ext <| coe_decompose_mul_add_of_left_mem 𝒜 a.2
#align direct_sum.decompose_mul_add_left DirectSum.decompose_mul_add_left

theorem decompose_mul_add_right [AddRightCancelMonoid ι] [GradedRing 𝒜] {a : A} (b : 𝒜 j) :
    decompose 𝒜 (a * ↑b) (i + j) =
      @GradedMonoid.GMul.mul ι (fun i => 𝒜 i) _ _ _ _ (decompose 𝒜 a i) b :=
  Subtype.ext <| coe_decompose_mul_add_of_right_mem 𝒜 b.2
#align direct_sum.decompose_mul_add_right DirectSum.decompose_mul_add_right

end DirectSum

end AddCancelMonoid

section GradedAlgebra

variable [DecidableEq ι] [AddMonoid ι] [CommSemiring R] [Semiring A] [Algebra R A]

variable (𝒜 : ι → Submodule R A)

/-- A special case of `graded_ring` with `σ = submodule R A`. This is useful both because it
can avoid typeclass search, and because it provides a more concise name. -/
@[reducible]
def GradedAlgebra :=
  GradedRing 𝒜
#align graded_algebra GradedAlgebra

/-- A helper to construct a `graded_algebra` when the `set_like.graded_monoid` structure is already
available. This makes the `left_inv` condition easier to prove, and phrases the `right_inv`
condition in a way that allows custom `@[ext]` lemmas to apply.

See note [reducible non-instances]. -/
@[reducible]
def GradedAlgebra.ofAlgHom [SetLike.GradedMonoid 𝒜] (decompose : A →ₐ[R] ⨁ i, 𝒜 i)
    (right_inv : (DirectSum.coeAlgHom 𝒜).comp decompose = AlgHom.id R A)
    (left_inv : ∀ (i) (x : 𝒜 i), decompose (x : A) = DirectSum.of (fun i => ↥(𝒜 i)) i x) :
    GradedAlgebra 𝒜 where
  decompose' := decompose
  left_inv := AlgHom.congr_fun right_inv
  right_inv := by
    suffices : decompose.comp (DirectSum.coeAlgHom 𝒜) = AlgHom.id _ _
    exact AlgHom.congr_fun this
    ext (i x) : 2
    exact (decompose.congr_arg <| DirectSum.coeAlgHom_of _ _ _).trans (left_inv i x)
#align graded_algebra.of_alg_hom GradedAlgebra.ofAlgHom

variable [GradedAlgebra 𝒜]

namespace DirectSum

/-- If `A` is graded by `ι` with degree `i` component `𝒜 i`, then it is isomorphic as
an algebra to a direct sum of components. -/
@[simps]
def decomposeAlgEquiv : A ≃ₐ[R] ⨁ i, 𝒜 i :=
  AlgEquiv.symm
    { (decomposeAddEquiv 𝒜).symm with
      map_mul' := (coeAlgHom 𝒜).map_mul
      map_add' := (coeAlgHom 𝒜).map_add
      commutes' := (coeAlgHom 𝒜).commutes }
#align direct_sum.decompose_alg_equiv DirectSum.decomposeAlgEquiv

end DirectSum

open DirectSum

/-- The projection maps of graded algebra-/
def GradedAlgebra.proj (𝒜 : ι → Submodule R A) [GradedAlgebra 𝒜] (i : ι) : A →ₗ[R] A :=
  (𝒜 i).Subtype.comp <| (Dfinsupp.lapply i).comp <| (decomposeAlgEquiv 𝒜).toAlgHom.toLinearMap
#align graded_algebra.proj GradedAlgebra.proj

@[simp]
theorem GradedAlgebra.proj_apply (i : ι) (r : A) :
    GradedAlgebra.proj 𝒜 i r = (decompose 𝒜 r : ⨁ i, 𝒜 i) i :=
  rfl
#align graded_algebra.proj_apply GradedAlgebra.proj_apply

theorem GradedAlgebra.proj_recompose (a : ⨁ i, 𝒜 i) (i : ι) :
    GradedAlgebra.proj 𝒜 i ((decompose 𝒜).symm a) = (decompose 𝒜).symm (of _ i (a i)) := by
  rw [GradedAlgebra.proj_apply, decompose_symm_of, Equiv.apply_symm_apply]
#align graded_algebra.proj_recompose GradedAlgebra.proj_recompose

theorem GradedAlgebra.mem_support_iff [DecidableEq A] (r : A) (i : ι) :
    i ∈ (decompose 𝒜 r).support ↔ GradedAlgebra.proj 𝒜 i r ≠ 0 :=
  Dfinsupp.mem_support_iff.trans Submodule.coe_eq_zero.Not.symm
#align graded_algebra.mem_support_iff GradedAlgebra.mem_support_iff

end GradedAlgebra

section CanonicalOrder

open SetLike.GradedMonoid DirectSum

variable [Semiring A] [DecidableEq ι]

variable [CanonicallyOrderedAddMonoid ι]

variable [SetLike σ A] [AddSubmonoidClass σ A] (𝒜 : ι → σ) [GradedRing 𝒜]

/-- If `A` is graded by a canonically ordered add monoid, then the projection map `x ↦ x₀` is a ring
homomorphism.
-/
@[simps]
def GradedRing.projZeroRingHom : A →+* A
    where
  toFun a := decompose 𝒜 a 0
  map_one' := decompose_of_mem_same 𝒜 one_mem
  map_zero' := by
    rw [decompose_zero]
    rfl
  map_add' _ _ := by
    rw [decompose_add]
    rfl
  map_mul' := by
    refine' DirectSum.Decomposition.inductionOn 𝒜 (fun x => _) _ _
    · simp only [MulZeroClass.zero_mul, decompose_zero, zero_apply, ZeroMemClass.coe_zero]
    · rintro i ⟨c, hc⟩
      refine' DirectSum.Decomposition.inductionOn 𝒜 _ _ _
      · simp only [MulZeroClass.mul_zero, decompose_zero, zero_apply, ZeroMemClass.coe_zero]
      · rintro j ⟨c', hc'⟩
        · simp only [Subtype.coe_mk]
          by_cases h : i + j = 0
          ·
            rw [decompose_of_mem_same 𝒜 (show c * c' ∈ 𝒜 0 from h ▸ mul_mem hc hc'),
              decompose_of_mem_same 𝒜 (show c ∈ 𝒜 0 from (add_eq_zero_iff.mp h).1 ▸ hc),
              decompose_of_mem_same 𝒜 (show c' ∈ 𝒜 0 from (add_eq_zero_iff.mp h).2 ▸ hc')]
          · rw [decompose_of_mem_ne 𝒜 (mul_mem hc hc') h]
            cases' show i ≠ 0 ∨ j ≠ 0 by rwa [add_eq_zero_iff, not_and_or] at h with h' h'
            · simp only [decompose_of_mem_ne 𝒜 hc h', MulZeroClass.zero_mul]
            · simp only [decompose_of_mem_ne 𝒜 hc' h', MulZeroClass.mul_zero]
      · intro _ _ hd he
        simp only [mul_add, decompose_add, add_apply, AddMemClass.coe_add, hd, he]
    · rintro _ _ ha hb _
      simp only [add_mul, decompose_add, add_apply, AddMemClass.coe_add, ha, hb]
#align graded_ring.proj_zero_ring_hom GradedRing.projZeroRingHom

variable {a b : A} {n i : ι}

namespace DirectSum

theorem coe_decompose_mul_of_left_mem_of_not_le (a_mem : a ∈ 𝒜 i) (h : ¬i ≤ n) :
    (decompose 𝒜 (a * b) n : A) = 0 :=
  by
  lift a to 𝒜 i using a_mem
  rwa [decompose_mul, decompose_coe, coe_of_mul_apply_of_not_le]
#align direct_sum.coe_decompose_mul_of_left_mem_of_not_le DirectSum.coe_decompose_mul_of_left_mem_of_not_le

theorem coe_decompose_mul_of_right_mem_of_not_le (b_mem : b ∈ 𝒜 i) (h : ¬i ≤ n) :
    (decompose 𝒜 (a * b) n : A) = 0 :=
  by
  lift b to 𝒜 i using b_mem
  rwa [decompose_mul, decompose_coe, coe_mul_of_apply_of_not_le]
#align direct_sum.coe_decompose_mul_of_right_mem_of_not_le DirectSum.coe_decompose_mul_of_right_mem_of_not_le

variable [Sub ι] [OrderedSub ι] [ContravariantClass ι ι (· + ·) (· ≤ ·)]

theorem coe_decompose_mul_of_left_mem_of_le (a_mem : a ∈ 𝒜 i) (h : i ≤ n) :
    (decompose 𝒜 (a * b) n : A) = a * decompose 𝒜 b (n - i) :=
  by
  lift a to 𝒜 i using a_mem
  rwa [decompose_mul, decompose_coe, coe_of_mul_apply_of_le]
#align direct_sum.coe_decompose_mul_of_left_mem_of_le DirectSum.coe_decompose_mul_of_left_mem_of_le

theorem coe_decompose_mul_of_right_mem_of_le (b_mem : b ∈ 𝒜 i) (h : i ≤ n) :
    (decompose 𝒜 (a * b) n : A) = decompose 𝒜 a (n - i) * b :=
  by
  lift b to 𝒜 i using b_mem
  rwa [decompose_mul, decompose_coe, coe_mul_of_apply_of_le]
#align direct_sum.coe_decompose_mul_of_right_mem_of_le DirectSum.coe_decompose_mul_of_right_mem_of_le

theorem coe_decompose_mul_of_left_mem (n) [Decidable (i ≤ n)] (a_mem : a ∈ 𝒜 i) :
    (decompose 𝒜 (a * b) n : A) = if i ≤ n then a * decompose 𝒜 b (n - i) else 0 :=
  by
  lift a to 𝒜 i using a_mem
  rwa [decompose_mul, decompose_coe, coe_of_mul_apply]
#align direct_sum.coe_decompose_mul_of_left_mem DirectSum.coe_decompose_mul_of_left_mem

theorem coe_decompose_mul_of_right_mem (n) [Decidable (i ≤ n)] (b_mem : b ∈ 𝒜 i) :
    (decompose 𝒜 (a * b) n : A) = if i ≤ n then decompose 𝒜 a (n - i) * b else 0 :=
  by
  lift b to 𝒜 i using b_mem
  rwa [decompose_mul, decompose_coe, coe_mul_of_apply]
#align direct_sum.coe_decompose_mul_of_right_mem DirectSum.coe_decompose_mul_of_right_mem

end DirectSum

end CanonicalOrder


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebraic_geometry.presheafed_space.has_colimits
import topology.sheaves.functors

/-!
# Sheafed spaces

Introduces the category of topological spaces equipped with a sheaf (taking values in an
arbitrary target category `C`.)

We further describe how to apply functors and natural transformations to the values of the
presheaves.
-/

universes v u

open category_theory
open Top
open topological_space
open opposite
open category_theory.limits
open category_theory.category category_theory.functor

variables (C : Type u) [category.{v} C] [limits.has_products C]

local attribute [tidy] tactic.op_induction'

namespace algebraic_geometry

/-- A `SheafedSpace C` is a topological space equipped with a sheaf of `C`s. -/
structure SheafedSpace extends PresheafedSpace C :=
(is_sheaf : presheaf.is_sheaf)

variables {C}

namespace SheafedSpace

instance coe_carrier : has_coe (SheafedSpace C) Top :=
{ coe := λ X, X.carrier }

/-- Extract the `sheaf C (X : Top)` from a `SheafedSpace C`. -/
def sheaf (X : SheafedSpace C) : sheaf C (X : Top.{v}) := ⟨X.presheaf, X.is_sheaf⟩

@[simp] lemma as_coe (X : SheafedSpace C) : X.carrier = (X : Top.{v}) := rfl
@[simp] lemma mk_coe (carrier) (presheaf) (h) :
  (({ carrier := carrier, presheaf := presheaf, is_sheaf := h } : SheafedSpace.{v} C) :
  Top.{v}) = carrier :=
rfl

instance (X : SheafedSpace.{v} C) : topological_space X := X.carrier.str

/-- The trivial `punit` valued sheaf on any topological space. -/
def punit (X : Top) : SheafedSpace (discrete punit) :=
{ is_sheaf := presheaf.is_sheaf_punit _,
  ..@PresheafedSpace.const (discrete punit) _ X punit.star }

instance : inhabited (SheafedSpace (discrete _root_.punit)) := ⟨punit (Top.of pempty)⟩

instance : category (SheafedSpace C) :=
show category (induced_category (PresheafedSpace C) SheafedSpace.to_PresheafedSpace),
by apply_instance

/-- Forgetting the sheaf condition is a functor from `SheafedSpace C` to `PresheafedSpace C`. -/
@[derive [full, faithful]]
def forget_to_PresheafedSpace : (SheafedSpace C) ⥤ (PresheafedSpace C) :=
induced_functor _

variables {C}

section
local attribute [simp] id comp

@[simp] lemma id_base (X : SheafedSpace C) :
  ((𝟙 X) : X ⟶ X).base = (𝟙 (X : Top.{v})) := rfl

lemma id_c (X : SheafedSpace C) :
  ((𝟙 X) : X ⟶ X).c = eq_to_hom (presheaf.pushforward.id_eq X.presheaf).symm := rfl

@[simp] lemma id_c_app (X : SheafedSpace C) (U) :
  ((𝟙 X) : X ⟶ X).c.app U = eq_to_hom (by { induction U using opposite.rec, cases U, refl }) :=
by { induction U using opposite.rec, cases U, simp only [id_c], dsimp, simp, }

@[simp] lemma comp_base {X Y Z : SheafedSpace C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).base = f.base ≫ g.base := rfl

@[simp] lemma comp_c_app {X Y Z : SheafedSpace C} (α : X ⟶ Y) (β : Y ⟶ Z) (U) :
  (α ≫ β).c.app U = (β.c).app U ≫ (α.c).app (op ((opens.map (β.base)).obj (unop U)))
:= rfl

variables (C)

/-- The forgetful functor from `SheafedSpace` to `Top`. -/
def forget : SheafedSpace C ⥤ Top :=
{ obj := λ X, (X : Top.{v}),
  map := λ X Y f, f.base }

end

open Top.presheaf

/--
The restriction of a sheafed space along an open embedding into the space.
-/
def restrict {U : Top} (X : SheafedSpace C)
  {f : U ⟶ (X : Top.{v})} (h : open_embedding f) : SheafedSpace C :=
{ is_sheaf := λ ι 𝒰, ⟨is_limit.of_iso_limit
    ((is_limit.postcompose_inv_equiv _ _).inv_fun (X.is_sheaf _).some)
    (sheaf_condition_equalizer_products.fork.iso_of_open_embedding h 𝒰).symm⟩,
  ..X.to_PresheafedSpace.restrict h }

/--
The restriction of a sheafed space `X` to the top subspace is isomorphic to `X` itself.
-/
def restrict_top_iso (X : SheafedSpace C) :
  X.restrict (opens.open_embedding ⊤) ≅ X :=
@preimage_iso _ _ _ _ forget_to_PresheafedSpace _ _
  (X.restrict (opens.open_embedding ⊤)) _
  X.to_PresheafedSpace.restrict_top_iso

/--
The global sections, notated Gamma.
-/
def Γ : (SheafedSpace C)ᵒᵖ ⥤ C :=
forget_to_PresheafedSpace.op ⋙ PresheafedSpace.Γ

lemma Γ_def : (Γ : _ ⥤ C) = forget_to_PresheafedSpace.op ⋙ PresheafedSpace.Γ := rfl

@[simp]

lemma Γ_obj_op (X : SheafedSpace C) : Γ.obj (op X) = X.presheaf.obj (op ⊤) := rfl

@[simp] lemma Γ_map {X Y : (SheafedSpace C)ᵒᵖ} (f : X ⟶ Y) :
  Γ.map f = f.unop.c.app (op ⊤) := rfl

lemma Γ_map_op {X Y : SheafedSpace C} (f : X ⟶ Y) :
  Γ.map f.op = f.c.app (op ⊤) := rfl

noncomputable
instance [has_limits C] : creates_colimits (forget_to_PresheafedSpace : SheafedSpace C ⥤ _) :=
⟨λ J hJ, by exactI ⟨λ K, creates_colimit_of_fully_faithful_of_iso
  ⟨(PresheafedSpace.colimit_cocone (K ⋙ forget_to_PresheafedSpace)).X,
    limit_is_sheaf _ (λ j, sheaf.pushforward_sheaf_of_sheaf _ (K.obj (unop j)).2)⟩
  (colimit.iso_colimit_cocone ⟨_, PresheafedSpace.colimit_cocone_is_colimit _⟩).symm⟩⟩

instance [has_limits C] : has_colimits (SheafedSpace C) :=
has_colimits_of_has_colimits_creates_colimits forget_to_PresheafedSpace

end SheafedSpace

end algebraic_geometry


import Cat.Setoid.Setoid

/-! # Morphisms between setoids, seen as setoids over functions
-/

namespace Cat

/-- Notion of morphism over `Setoid` (`⇒`, `\r=`). -/
structure Morph.{ua, ub}
  (α : Setoid.{ua})
  (β : Setoid.{ub})
: Type (max ua ub) where

  /-- Maps values from `α`'s carrier to values of `β`'s carrier. -/
  map : |α| → |β|

  /-- `map` is proper for setoid equivalence (`≈`). -/
  proper {a₁ a₂ : |α|} :
    a₁ ≈ a₂ → map a₁ ≈ map a₂

infixr:3 " ⇒ " =>
  Morph

section Morph

  universe u_α u_β

  variable
    {α : Setoid.{u_α}}
    {β : Setoid.{u_β}}

  /-- Domain accessor. -/
  def Morph.dom
    (_ : α ⇒ β)
  : Setoid.{u_α} :=
    α
  /-- Codomain accessor. -/
  def Morph.cod
    (_ : α ⇒ β)
  : Setoid.{u_β} :=
    β

  /-- Applies the underlying function. -/
  def Morph.app
    (self : α ⇒ β)
  : |α| → |β| :=
    (self.map ·)

  /-! ## Equivalence relation on morphisms -/
  section equiv

    /-- Equivalence relation (extensional equality, `≈`, `\~~`). -/
    abbrev Morph.equiv
      {α β : Setoid}
      (f g : α ⇒ β)
    : Prop :=
      ∀ (a : |α|), f.map a ≈ g.map a

    /-- Give access to `≈` (`\~~`) equivalence notation. -/
    instance instHasEquivMorph
    : HasEquiv (α ⇒ β) where
      Equiv :=
        Morph.equiv

    /-- `Morph.equiv` is reflexive. -/
    def Morph.equiv.refl
      (m : α ⇒ β)
    : m ≈ m :=
      (m.map · |> β.refl)

    /-- `Morph.equiv` is symmetric. -/
    def Morph.equiv.symm
      {f g : α ⇒ β}
      (h : equiv f g)
    : g ≈ f :=
      (h · |> β.symm)

    /-- `Morph.equiv` is transitive. -/
    def Morph.equiv.trans
      {f g h : α ⇒ β}
      (eqFG : equiv f g)
      (eqGH : equiv g h)
    : f ≈ h :=
      fun a =>
        β.trans (eqFG a) (eqGH a)

    /-- `Morph.equiv` is an equivalence relation. -/
    def Morph.equiv.iseqv
    : @Equivalence (α ⇒ β) Morph.equiv :=
      ⟨refl, symm, trans⟩

    def Morph.equiv.rewrite
      {f g h : α ⇒ β}
      (self : f ≈ g)
      (subgoal : f ≈ h)
    : g ≈ h :=
      self.symm.trans subgoal

    instance instTransMorphTrans
      {α β : Setoid}
    : let I := @instHasEquivMorph α β
      Trans I.Equiv I.Equiv I.Equiv
    where
      trans :=
        Morph.equiv.trans

  end equiv

  /-- Composition of two morphisms, `Morph` version (`∘M`). -/
  def Morph.compose
    (f : β ⇒ γ)
    (g : α ⇒ β)
  : α ⇒ γ where
    map :=
      f.map ∘ g.map
    proper :=
      f.proper ∘ g.proper

  infix:100 " ∘M " =>
    Morph.compose

  /-- Morphism composition (`∘M`) is associative. -/
  theorem Morph.compose.assoc
    (f : γ ⇒ δ)
    (g : β ⇒ γ)
    (h : α ⇒ β)
  : f ∘M (g ∘M h) ≈ (f ∘M g) ∘M h :=
    fun a =>
      by simp [compose, δ.refl]

  /-- Morphism composition (`∘M`) abides by congruence laws. -/
  def Morph.compose.congr
  : Congr (β ⇒ γ) (α ⇒ β) (α ⇒ γ) Morph.compose where
    left g :=
      fun h_f a =>
        g.map a |> h_f
    right f :=
      fun h_g a =>
        h_g a |> f.proper

  /-- Composition of two morphisms, function version (`∘m`). -/
  def Morph.kompose
    (f : β ⇒ γ)
    (g : α ⇒ β)
  : |α| → |γ| :=
    (f.compose g).map

  infix:100 " ∘m " =>
    Morph.kompose

  /-- Identity morphism over an implicit erased setoid `α`. -/
  protected def Morph.id
    {α : Setoid}
  : α ⇒ α where
    map := id
    proper := id

  /-- Identity morphism over an explicit erased setoid `α`. -/
  protected abbrev Morph.id'
    (α : Setoid)
  : α ⇒ α :=
    @Morph.id α

  /-- `Morph.id` is a left-identity for `∘M`. -/
  theorem Morph.id_compose
    (f : α ⇒ β)
  : Morph.id ∘M f ≈ f :=
    fun _a =>
      β.refl _

  /-- `Morph.id` is a right-identity for `∘M`. -/
  theorem Morph.compose_id
    (f : α ⇒ β)
  : f ∘M Morph.id ≈ f :=
    fun _a =>
      β.refl _

  /-! ## `Morph` as a `Setoid` -/
  section MorSet

    /-- `Zetoid` instance so that we can build the actual `Setoid`. -/
    instance instZetoidMorph
    : Zetoid (α ⇒ β) where
      r :=
        Morph.equiv
      iseqv :=
        Morph.equiv.iseqv

    /-- Builds the `Setoid` for `α ⇒ β`, written `α ⇛ β` (`\r==`).

    Note that you should not need to write `|α ⇛ β|` since the carrier of `α ⇛ β` is simply `α ⇒ β`.
    It is however sometimes more readable to write `|α ⇛ β ⇛ γ|` for `α ⇒ β ⇛ γ`.
    -/
    def Morph.mkSetoid
      (α : Setoid.{u_a})
      (β : Setoid.{u_b})
    : Setoid where
      Carrier :=
        α ⇒ β
      instZetoid :=
        instZetoidMorph

    infixr:4 " ⇛ " =>
      Morph.mkSetoid

  end MorSet

  /-! ## More helpers, mostly for defining a first notion of category -/

  /-- Same as `app` but the codomain is a morphism. -/
  def Morph.app2
    {γ : Setoid.{u_γ}}
    (self : α ⇒ β ⇛ γ)
    -- (self : |α ⇛ β ⇛ γ|) -- alternatively, same as the above
    (a : |α|)
  : |β| → |γ| :=
    self.map a
    |>.map

  /-- Takes a composition operation over morphisms and returns the underlying binary function. -/
  @[simp]
  def Morph.komposeExt
    {Obj : Sort u_o}
    {Hom : Obj → Obj → Setoid}
    (compose :
      (α β γ : Obj) → |Hom β γ ⇛ Hom α β ⇛ Hom α γ|)
    {α β γ : outParam Obj}
  : |Hom β γ| → |Hom α β| → |Hom α γ| :=
    compose α β γ
    |>.app2

  macro "⟦ " f:term " ⟧" : term =>
    `(Morph.komposeExt $f)

end Morph

/-! ## Some useful instances -/

/-- Allows using a `Morph` directly as its underlying function. -/
instance instCoeFunMorph
: CoeFun (α ⇒ β) (𝕂 $ |α| → |β|) where
  coe m :=
    m.map
/-- Allows using a `Morph` setoid directly as its underlying function. -/
instance instCoeFunMorphSetoid
: CoeFun (|α ⇛ β|) (𝕂 $ |α| → |β|) where
  coe m :=
    m.map


/-!
# Parametric Higher-Order Abstract Syntax

In contrast to first-order encodings, higher-order encodings avoid explicit modeling of variable identity.
Instead, the binding constructs of an object language (the language being
formalized) can be represented using the binding constructs of the meta language (the language in which the formalization is done).
The best known higher-order encoding is called higher-order abstract syntax (HOAS),
and we can start by attempting to apply it directly in Lean.

Remark: this example is based on an example in the book [Certified Programming with Dependent Types](http://adam.chlipala.net/cpdt/) by Adam Chlipala.
-/

/-!
Here is the definition of the simple type system for our programming language, a simply typed
lambda calculus with natural numbers as the base type.
-/
inductive Ty where
  | nat
  | fn : Ty → Ty → Ty

/-!
We can write a function to translate `Ty` values to a Lean type
— remember that types are first class, so can be calculated just like any other value.
We mark `Ty.denote` as `[reducible]` to make sure the typeclass resolution procedure can
unfold/reduce it. For example, suppose Lean is trying to synthesize a value for the instance
`Add (Ty.denote Ty.nat)`. Since `Ty.denote` is marked as `[reducible]`,
the typeclass resolution procedure can reduce `Ty.denote Ty.nat` to `Nat`, and use
the builtin instance for `Add Nat` as the solution.

Recall that the term `a.denote` is sugar for `denote a` where `denote` is the function being defined.
We call it the "dot notation".
-/
@[reducible] def Ty.denote : Ty → Type
  | nat    => Nat
  | fn a b => a.denote → b.denote

/-!
With HOAS, each object language binding construct is represented with a function of
the meta language. Here is what we get if we apply that idea within an inductive definition
of term syntax. However a naive encondig in Lean fails to meet the strict positivity restrictions
imposed by the Lean kernel. An alternate higher-order encoding is parametric HOAS, as introduced by Washburn
and Weirich for Haskell and tweaked by Adam Chlipala for use in Coq. The key idea is to parameterize the
declaration by a type family `rep` standing for a "representation of variables."
-/
inductive Term' (rep : Ty → Type) : Ty → Type
  | var   : rep ty → Term' rep ty
  | const : Nat → Term' rep .nat
  | plus  : Term' rep .nat → Term' rep .nat → Term' rep .nat
  | lam   : (rep dom → Term' rep ran) → Term' rep (.fn dom ran)
  | app   : Term' rep (.fn dom ran) → Term' rep dom → Term' rep ran
  | let   : Term' rep ty₁ → (rep ty₁ → Term' rep ty₂) → Term' rep ty₂

/-!
Lean accepts this definition because our embedded functions now merely take variables as
arguments, instead of arbitrary terms. One might wonder whether there is an easy loophole
to exploit here, instantiating the parameter `rep` as term itself. However, to do that, we
would need to choose a variable representation for this nested mention of term, and so on
through an infinite descent into term arguments.

We write the final type of a closed term using polymorphic quantification over all possible
choices of `rep` type family
-/

open Ty (nat fn)

namespace FirstTry

def Term (ty : Ty) := (rep : Ty → Type) → Term' rep ty

/-!
In the next two example, note how each is written as a function over a `rep` choice,
such that the specific choice has no impact on the structure of the term.
-/
def add : Term (fn nat (fn nat nat)) := fun _rep =>
  .lam fun x => .lam fun y => .plus (.var x) (.var y)

def three_the_hard_way : Term nat := fun rep =>
  .app (.app (add rep) (.const 1)) (.const 2)

end FirstTry

/-!
The argument `rep` does not even appear in the function body for `add`. How can that be?
By giving our terms expressive types, we allow Lean to infer many arguments for us. In fact,
we do not even need to name the `rep` argument! By using Lean implicit arguments and lambdas,
we can completely hide `rep` in these examples.
-/

def Term (ty : Ty) := {rep : Ty → Type} → Term' rep ty

def add : Term (fn nat (fn nat nat)) :=
  .lam fun x => .lam fun y => .plus (.var x) (.var y)

def three_the_hard_way : Term nat :=
  .app (.app add (.const 1)) (.const 2)

/-!
It may not be at all obvious that the PHOAS representation admits the crucial computable
operations. The key to effective deconstruction of PHOAS terms is one principle: treat
the `rep` parameter as an unconstrained choice of which data should be annotated on each
variable. We will begin with a simple example, that of counting how many variable nodes
appear in a PHOAS term. This operation requires no data annotated on variables, so we
simply annotate variables with `Unit` values. Note that, when we go under binders in the
cases for `lam` and `let`, we must provide the data value to annotate on the new variable we
pass beneath. For our current choice of `Unit` data, we always pass `()`.
-/

def countVars : Term' (fun _ => Unit) ty → Nat
  | .var _    => 1
  | .const _  => 0
  | .plus a b => countVars a + countVars b
  | .app f a  => countVars f + countVars a
  | .lam b    => countVars (b ())
  | .let a b  => countVars a + countVars (b ())

/-! We can now easily prove that `add` has two variables by using reflexivity -/

example : countVars add = 2 :=
  rfl

/-!
Here is another example, translating PHOAS terms into strings giving a first-order rendering.
To implement this translation, the key insight is to tag variables with strings, giving their names.
The function takes as an additional input `i` which is used to create variable names for binders.
We also use the string interpolation available in Lean. For example, `s!"x_{i}"` is expanded to
`"x_" ++ toString i`.
-/
def pretty (e : Term' (fun _ => String) ty) (i : Nat := 1) : String :=
  match e with
  | .var s     => s
  | .const n   => toString n
  | .app f a   => s!"({pretty f i} {pretty a i})"
  | .plus a b  => s!"({pretty a i} + {pretty b i})"
  | .lam f     =>
    let x := s!"x_{i}"
    s!"(fun {x} => {pretty (f x) (i+1)})"
  | .let a b  =>
    let x := s!"x_{i}"
    s!"(let {x} := {pretty a i}; => {pretty (b x) (i+1)}"

#eval pretty three_the_hard_way

/-!
It is not necessary to convert to a different representation to support many common
operations on terms. For instance, we can implement substitution of terms for variables.
The key insight here is to tag variables with terms, so that, on encountering a variable, we
can simply replace it by the term in its tag. We will call this function initially on a term
with exactly one free variable, tagged with the appropriate substitute. During recursion,
new variables are added, but they are only tagged with their own term equivalents. Note
that this function squash is parameterized over a specific `rep` choice.
-/
def squash : Term' (Term' rep) ty → Term' rep ty
 | .var e    => e
 | .const n  => .const n
 | .plus a b => .plus (squash a) (squash b)
 | .lam f    => .lam fun x => squash (f (.var x))
 | .app f a  => .app (squash f) (squash a)
 | .let a b  => .let (squash a) fun x => squash (b (.var x))

/-!
To define the final substitution function over terms with single free variables, we define
`Term1`, an analogue to Term that we defined before for closed terms.
-/
def Term1 (ty1 ty2 : Ty) := {rep : Ty → Type} → rep ty1 → Term' rep ty2

/-!
Substitution is defined by (1) instantiating a `Term1` to tag variables with terms and (2)
applying the result to a specific term to be substituted. Note how the parameter `rep` of
`squash` is instantiated: the body of `subst` is itself a polymorphic quantification over `rep`,
standing for a variable tag choice in the output term; and we use that input to compute a
tag choice for the input term.
-/

def subst (e : Term1 ty1 ty2) (e' : Term ty1) : Term ty2 :=
  squash (e e')

/-!
We can view `Term1` as a term with hole. In the following example,
`(fun x => plus (var x) (const 5))` can be viewed as the term `plus _ (const 5)` where
the hole `_` is instantiated by `subst` with `three_the_hard_way`
-/

#eval pretty <| subst (fun x => .plus (.var x) (.const 5)) three_the_hard_way

/-!
One further development, which may seem surprising at first,
is that we can also implement a usual term denotation function,
when we tag variables with their denotations.

The attribute `[simp]` instructs Lean to always try to unfold `denote` applications when one applies
the `simp` tactic. We also say this is a hint for the Lean term simplifier.
-/
@[simp] def denote : Term' Ty.denote ty → ty.denote
  | .var x    => x
  | .const n  => n
  | .plus a b => denote a + denote b
  | .app f a  => denote f (denote a)
  | .lam f    => fun x => denote (f x)
  | .let a b  => denote (b (denote a))

example : denote three_the_hard_way = 3 :=
  rfl

/-!
To summarize, the PHOAS representation has all the expressive power of more
standard encodings (e.g., using de Bruijn indices), and a variety of translations are actually much more pleasant to
implement than usual, thanks to the novel ability to tag variables with data.
-/

/-!
We now define the constant folding optimization that traverses a term if replaces subterms such as
`plus (const m) (const n)` with `const (n+m)`.
-/
@[simp] def constFold : Term' rep ty → Term' rep ty
  | .var x    => .var x
  | .const n  => .const n
  | .app f a  => .app (constFold f) (constFold a)
  | .lam f    => .lam fun x => constFold (f x)
  | .let a b  => .let (constFold a) fun x => constFold (b x)
  | .plus a b =>
    match constFold a, constFold b with
    | .const n, .const m => .const (n+m)
    | a',       b'       => .plus a' b'

/-!
The correctness of the `constFold` is proved using induction, case-analysis, and the term simplifier.
We prove all cases but the one for `plus` using `simp [*]`. This tactic instructs the term simplifier to
use hypotheses such as `a = b` as rewriting/simplications rules.
We use the `split` to break the nested `match` expression in the `plus` case into two cases.
The local variables `iha` and `ihb` are the induction hypotheses for `a` and `b`.
The modifier `←` in a term simplifier argument instructs the term simplier to use the equation as a rewriting rule in
the "reverse direction. That is, given `h : a = b`, `← h` instructs the term simplifier to rewrite `b` subterms to `a`.
-/
theorem constFold_sound (e : Term' Ty.denote ty) : denote (constFold e) = denote e := by
  induction e with simp [*]
  | plus a b iha ihb =>
    split
    next he₁ he₂ => simp [← iha, ← ihb, he₁, he₂]
    next => simp [iha, ihb]


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Patrick Massot

Theory of uniform spaces.

Uniform spaces are a generalization of metric spaces and topological groups. Many concepts directly
generalize to uniform spaces, e.g.

* completeness
* extension of uniform continuous functions to complete spaces
* uniform contiunuity & embedding
* totally bounded
* totally bounded ∧ complete → compact

The central concept of uniform spaces is its uniformity: a filter relating two elements of the
space. This filter is reflexive, symmetric and transitive. So a set (i.e. a relation) in this filter
represents a 'distance': it is reflexive, symmetric and the uniformity contains a set for which the
`triangular` rule holds.

The formalization is mostly based on the books:
  N. Bourbaki: General Topology
  I. M. James: Topologies and Uniformities
A major difference is that this formalization is heavily based on the filter library.
-/
import order.filter order.filter.lift data.quot topology.constructions

open set lattice filter classical
local attribute [instance, priority 0] prop_decidable

set_option eqn_compiler.zeta true

universes u
section
variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*} {ι : Sort*}

/-- The identity relation, or the graph of the identity function -/
def id_rel {α : Type*} := {p : α × α | p.1 = p.2}

@[simp] theorem mem_id_rel {a b : α} : (a, b) ∈ @id_rel α ↔ a = b := iff.rfl

@[simp] theorem id_rel_subset {s : set (α × α)} : id_rel ⊆ s ↔ ∀ a, (a, a) ∈ s :=
by simp [subset_def]; exact forall_congr (λ a, by simp)

/-- The composition of relations -/
def comp_rel {α : Type u} (r₁ r₂ : set (α×α)) := {p : α × α | ∃z:α, (p.1, z) ∈ r₁ ∧ (z, p.2) ∈ r₂}

@[simp] theorem mem_comp_rel {r₁ r₂ : set (α×α)}
  {x y : α} : (x, y) ∈ comp_rel r₁ r₂ ↔ ∃ z, (x, z) ∈ r₁ ∧ (z, y) ∈ r₂ := iff.rfl

@[simp] theorem swap_id_rel : prod.swap '' id_rel = @id_rel α :=
set.ext $ assume ⟨a, b⟩, by simp [image_swap_eq_preimage_swap]; exact eq_comm

theorem monotone_comp_rel [preorder β] {f g : β → set (α×α)}
  (hf : monotone f) (hg : monotone g) : monotone (λx, comp_rel (f x) (g x)) :=
assume a b h p ⟨z, h₁, h₂⟩, ⟨z, hf h h₁, hg h h₂⟩

lemma prod_mk_mem_comp_rel {a b c : α} {s t : set (α×α)} (h₁ : (a, c) ∈ s) (h₂ : (c, b) ∈ t) :
  (a, b) ∈ comp_rel s t :=
⟨c, h₁, h₂⟩

@[simp] lemma id_comp_rel {r : set (α×α)} : comp_rel id_rel r = r :=
set.ext $ assume ⟨a, b⟩, by simp

lemma comp_rel_assoc {r s t : set (α×α)} :
  comp_rel (comp_rel r s) t = comp_rel r (comp_rel s t) :=
by ext p; cases p; simp only [mem_comp_rel]; tauto

/-- This core description of a uniform space is outside of the type class hierarchy. It is useful
  for constructions of uniform spaces, when the topology is derived from the uniform space. -/
structure uniform_space.core (α : Type u) :=
(uniformity : filter (α × α))
(refl       : principal id_rel ≤ uniformity)
(symm       : tendsto prod.swap uniformity uniformity)
(comp       : uniformity.lift' (λs, comp_rel s s) ≤ uniformity)

def uniform_space.core.mk' {α : Type u} (U : filter (α × α))
  (refl : ∀ (r ∈ U) x, (x, x) ∈ r)
  (symm : ∀ r ∈ U, {p | prod.swap p ∈ r} ∈ U)
  (comp : ∀ r ∈ U, ∃ t ∈ U, comp_rel t t ⊆ r) : uniform_space.core α :=
⟨U, λ r ru, id_rel_subset.2 (refl _ ru), symm,
  begin
    intros r ru,
    rw [mem_lift'_sets],
    exact comp _ ru,
    apply monotone_comp_rel; exact monotone_id,
  end⟩

/-- A uniform space generates a topological space -/
def uniform_space.core.to_topological_space {α : Type u} (u : uniform_space.core α) :
  topological_space α :=
{ is_open        := λs, ∀x∈s, { p : α × α | p.1 = x → p.2 ∈ s } ∈ u.uniformity,
  is_open_univ   := by simp; intro; exact univ_mem_sets,
  is_open_inter  :=
    assume s t hs ht x ⟨xs, xt⟩, by filter_upwards [hs x xs, ht x xt]; simp {contextual := tt},
  is_open_sUnion :=
    assume s hs x ⟨t, ts, xt⟩, by filter_upwards [hs t ts x xt] assume p ph h, ⟨t, ts, ph h⟩ }

lemma uniform_space.core_eq : ∀{u₁ u₂ : uniform_space.core α}, u₁.uniformity = u₂.uniformity → u₁ = u₂
| ⟨u₁, _, _, _⟩  ⟨u₂, _, _, _⟩ h := have u₁ = u₂, from h, by simp [*]

/-- A uniform space is a generalization of the "uniform" topological aspects of a
  metric space. It consists of a filter on `α × α` called the "uniformity", which
  satisfies properties analogous to the reflexivity, symmetry, and triangle properties
  of a metric.

  A metric space has a natural uniformity, and a uniform space has a natural topology.
  A topological group also has a natural uniformity, even when it is not metrizable. -/
class uniform_space (α : Type u) extends topological_space α, uniform_space.core α :=
(is_open_uniformity : ∀s, is_open s ↔ (∀x∈s, { p : α × α | p.1 = x → p.2 ∈ s } ∈ uniformity))

@[pattern] def uniform_space.mk' {α} (t : topological_space α)
  (c : uniform_space.core α)
  (is_open_uniformity : ∀s:set α, t.is_open s ↔
    (∀x∈s, { p : α × α | p.1 = x → p.2 ∈ s } ∈ c.uniformity)) :
  uniform_space α := ⟨c, is_open_uniformity⟩

def uniform_space.of_core {α : Type u} (u : uniform_space.core α) : uniform_space α :=
{ to_core := u,
  to_topological_space := u.to_topological_space,
  is_open_uniformity := assume a, iff.refl _ }

def uniform_space.of_core_eq {α : Type u} (u : uniform_space.core α) (t : topological_space α)
  (h : t = u.to_topological_space) : uniform_space α :=
{ to_core := u,
  to_topological_space := t,
  is_open_uniformity := assume a, h.symm ▸ iff.refl _ }

lemma uniform_space.to_core_to_topological_space (u : uniform_space α) :
  u.to_core.to_topological_space = u.to_topological_space :=
topological_space_eq $ funext $ assume s,
  by rw [uniform_space.core.to_topological_space, uniform_space.is_open_uniformity]

@[extensionality]
lemma uniform_space_eq : ∀{u₁ u₂ : uniform_space α}, u₁.uniformity = u₂.uniformity → u₁ = u₂
| (uniform_space.mk' t₁ u₁ o₁)  (uniform_space.mk' t₂ u₂ o₂) h :=
  have u₁ = u₂, from uniform_space.core_eq h,
  have t₁ = t₂, from topological_space_eq $ funext $ assume s, by rw [o₁, o₂]; simp [this],
  by simp [*]

lemma uniform_space.of_core_eq_to_core
  (u : uniform_space α) (t : topological_space α) (h : t = u.to_core.to_topological_space) :
  uniform_space.of_core_eq u.to_core t h = u :=
uniform_space_eq rfl

section uniform_space
variables [uniform_space α]

/-- The uniformity is a filter on α × α (inferred from an ambient uniform space
  structure on α). -/
def uniformity (α : Type u) [uniform_space α] : filter (α × α) :=
  (@uniform_space.to_core α _).uniformity

local notation `𝓤` := uniformity

lemma is_open_uniformity {s : set α} :
  is_open s ↔ (∀x∈s, { p : α × α | p.1 = x → p.2 ∈ s } ∈ 𝓤 α) :=
uniform_space.is_open_uniformity s

lemma refl_le_uniformity : principal id_rel ≤ 𝓤 α :=
(@uniform_space.to_core α _).refl

lemma refl_mem_uniformity {x : α} {s : set (α × α)} (h : s ∈ 𝓤 α) :
  (x, x) ∈ s :=
refl_le_uniformity h rfl

lemma symm_le_uniformity : map (@prod.swap α α) (𝓤 _) ≤ (𝓤 _) :=
(@uniform_space.to_core α _).symm

lemma comp_le_uniformity : (𝓤 α).lift' (λs:set (α×α), comp_rel s s) ≤ 𝓤 α :=
(@uniform_space.to_core α _).comp

lemma tendsto_swap_uniformity : tendsto (@prod.swap α α) (𝓤 α) (𝓤 α) :=
symm_le_uniformity

lemma tendsto_const_uniformity {a : α} {f : filter β} : tendsto (λ _, (a, a)) f (𝓤 α) :=
assume s hs,
show {x | (a, a) ∈ s} ∈ f,
  from univ_mem_sets' $ assume b, refl_mem_uniformity hs

lemma comp_mem_uniformity_sets {s : set (α × α)} (hs : s ∈ 𝓤 α) :
  ∃ t ∈ 𝓤 α, comp_rel t t ⊆ s :=
have s ∈ (𝓤 α).lift' (λt:set (α×α), comp_rel t t),
  from comp_le_uniformity hs,
(mem_lift'_sets $ monotone_comp_rel monotone_id monotone_id).mp this

lemma symm_of_uniformity {s : set (α × α)} (hs : s ∈ 𝓤 α) :
  ∃ t ∈ 𝓤 α, (∀a b, (a, b) ∈ t → (b, a) ∈ t) ∧ t ⊆ s :=
have preimage prod.swap s ∈ 𝓤 α, from symm_le_uniformity hs,
⟨s ∩ preimage prod.swap s, inter_mem_sets hs this, assume a b ⟨h₁, h₂⟩, ⟨h₂, h₁⟩, inter_subset_left _ _⟩

lemma comp_symm_of_uniformity {s : set (α × α)} (hs : s ∈ 𝓤 α) :
  ∃ t ∈ 𝓤 α, (∀{a b}, (a, b) ∈ t → (b, a) ∈ t) ∧ comp_rel t t ⊆ s :=
let ⟨t, ht₁, ht₂⟩ := comp_mem_uniformity_sets hs in
let ⟨t', ht', ht'₁, ht'₂⟩ := symm_of_uniformity ht₁ in
⟨t', ht', ht'₁, subset.trans (monotone_comp_rel monotone_id monotone_id ht'₂) ht₂⟩

lemma uniformity_le_symm : 𝓤 α ≤ (@prod.swap α α) <$> 𝓤 α :=
by rw [map_swap_eq_comap_swap];
from map_le_iff_le_comap.1 tendsto_swap_uniformity

lemma uniformity_eq_symm : 𝓤 α = (@prod.swap α α) <$> 𝓤 α :=
le_antisymm uniformity_le_symm symm_le_uniformity

theorem uniformity_lift_le_swap {g : set (α×α) → filter β} {f : filter β} (hg : monotone g)
  (h : (𝓤 α).lift (λs, g (preimage prod.swap s)) ≤ f) : (𝓤 α).lift g ≤ f :=
calc (𝓤 α).lift g ≤ (filter.map (@prod.swap α α) $ 𝓤 α).lift g :
    lift_mono uniformity_le_symm (le_refl _)
  ... ≤ _ :
    by rw [map_lift_eq2 hg, image_swap_eq_preimage_swap]; exact h

lemma uniformity_lift_le_comp {f : set (α×α) → filter β} (h : monotone f):
  (𝓤 α).lift (λs, f (comp_rel s s)) ≤ (𝓤 α).lift f :=
calc (𝓤 α).lift (λs, f (comp_rel s s)) =
    ((𝓤 α).lift' (λs:set (α×α), comp_rel s s)).lift f :
  begin
    rw [lift_lift'_assoc],
    exact monotone_comp_rel monotone_id monotone_id,
    exact h
  end
  ... ≤ (𝓤 α).lift f : lift_mono comp_le_uniformity (le_refl _)

lemma comp_le_uniformity3 :
  (𝓤 α).lift' (λs:set (α×α), comp_rel s (comp_rel s s)) ≤ (𝓤 α) :=
calc (𝓤 α).lift' (λd, comp_rel d (comp_rel d d)) =
  (𝓤 α).lift (λs, (𝓤 α).lift' (λt:set(α×α), comp_rel s (comp_rel t t))) :
  begin
    rw [lift_lift'_same_eq_lift'],
    exact (assume x, monotone_comp_rel monotone_const $ monotone_comp_rel monotone_id monotone_id),
    exact (assume x, monotone_comp_rel monotone_id monotone_const),
  end
  ... ≤ (𝓤 α).lift (λs, (𝓤 α).lift' (λt:set(α×α), comp_rel s t)) :
    lift_mono' $ assume s hs, @uniformity_lift_le_comp α _ _ (principal ∘ comp_rel s) $
      monotone_comp (monotone_comp_rel monotone_const monotone_id) monotone_principal
  ... = (𝓤 α).lift' (λs:set(α×α), comp_rel s s) :
    lift_lift'_same_eq_lift'
      (assume s, monotone_comp_rel monotone_const monotone_id)
      (assume s, monotone_comp_rel monotone_id monotone_const)
  ... ≤ (𝓤 α) : comp_le_uniformity

lemma mem_nhds_uniformity_iff {x : α} {s : set α} :
  s ∈ nhds x ↔ {p : α × α | p.1 = x → p.2 ∈ s} ∈ 𝓤 α :=
⟨ begin
    simp only [mem_nhds_sets_iff, is_open_uniformity, and_imp, exists_imp_distrib],
    exact assume t ts ht xt, by filter_upwards [ht x xt] assume ⟨x', y⟩ h eq, ts $ h eq
  end,

  assume hs,
  mem_nhds_sets_iff.mpr ⟨{x | {p : α × α | p.1 = x → p.2 ∈ s} ∈ 𝓤 α},
    assume x' hx', refl_mem_uniformity hx' rfl,
    is_open_uniformity.mpr $ assume x' hx',
      let ⟨t, ht, tr⟩ := comp_mem_uniformity_sets hx' in
      by filter_upwards [ht] assume ⟨a, b⟩ hp' (hax' : a = x'),
      by filter_upwards [ht] assume ⟨a, b'⟩ hp'' (hab : a = b),
      have hp : (x', b) ∈ t, from hax' ▸ hp',
      have (b, b') ∈ t, from hab ▸ hp'',
      have (x', b') ∈ comp_rel t t, from ⟨b, hp, this⟩,
      show b' ∈ s,
        from tr this rfl,
    hs⟩⟩

lemma nhds_eq_comap_uniformity {x : α} : nhds x = (𝓤 α).comap (prod.mk x) :=
by ext s; rw [mem_nhds_uniformity_iff, mem_comap_sets]; from iff.intro
  (assume hs, ⟨_, hs, assume x hx, hx rfl⟩)
  (assume ⟨t, h, ht⟩, (𝓤 α).sets_of_superset h $
    assume ⟨p₁, p₂⟩ hp (h : p₁ = x), ht $ by simp [h.symm, hp])

lemma nhds_eq_uniformity {x : α} : nhds x = (𝓤 α).lift' (λs:set (α×α), {y | (x, y) ∈ s}) :=
begin
  ext s,
  rw [mem_lift'_sets], tactic.swap, apply monotone_preimage,
  simp [mem_nhds_uniformity_iff],
  exact ⟨assume h, ⟨_, h, assume y h, h rfl⟩,
    assume ⟨t, h₁, h₂⟩,
    (𝓤 α).sets_of_superset h₁ $
    assume ⟨x', y⟩ hp (eq : x' = x), h₂ $
    show (x, y) ∈ t, from eq ▸ hp⟩
end

lemma mem_nhds_left (x : α) {s : set (α×α)} (h : s ∈ 𝓤 α) :
  {y : α | (x, y) ∈ s} ∈ nhds x :=
have nhds x ≤ principal {y : α | (x, y) ∈ s},
  by rw [nhds_eq_uniformity]; exact infi_le_of_le s (infi_le _ h),
by simp at this; assumption

lemma mem_nhds_right (y : α) {s : set (α×α)} (h : s ∈ 𝓤 α) :
  {x : α | (x, y) ∈ s} ∈ nhds y :=
mem_nhds_left _ (symm_le_uniformity h)

lemma tendsto_right_nhds_uniformity {a : α} : tendsto (λa', (a', a)) (nhds a) (𝓤 α) :=
assume s, mem_nhds_right a

lemma tendsto_left_nhds_uniformity {a : α} : tendsto (λa', (a, a')) (nhds a) (𝓤 α) :=
assume s, mem_nhds_left a

lemma lift_nhds_left {x : α} {g : set α → filter β} (hg : monotone g) :
  (nhds x).lift g = (𝓤 α).lift (λs:set (α×α), g {y | (x, y) ∈ s}) :=
eq.trans
  begin
    rw [nhds_eq_uniformity],
    exact (filter.lift_assoc $ monotone_comp monotone_preimage $ monotone_comp monotone_preimage monotone_principal)
  end
  (congr_arg _ $ funext $ assume s, filter.lift_principal hg)

lemma lift_nhds_right {x : α} {g : set α → filter β} (hg : monotone g) :
  (nhds x).lift g = (𝓤 α).lift (λs:set (α×α), g {y | (y, x) ∈ s}) :=
calc (nhds x).lift g = (𝓤 α).lift (λs:set (α×α), g {y | (x, y) ∈ s}) : lift_nhds_left hg
  ... = ((@prod.swap α α) <$> (𝓤 α)).lift (λs:set (α×α), g {y | (x, y) ∈ s}) : by rw [←uniformity_eq_symm]
  ... = (𝓤 α).lift (λs:set (α×α), g {y | (x, y) ∈ image prod.swap s}) :
    map_lift_eq2 $ monotone_comp monotone_preimage hg
  ... = _ : by simp [image_swap_eq_preimage_swap]

lemma nhds_nhds_eq_uniformity_uniformity_prod {a b : α} :
  filter.prod (nhds a) (nhds b) =
  (𝓤 α).lift (λs:set (α×α), (𝓤 α).lift' (λt:set (α×α),
    set.prod {y : α | (y, a) ∈ s} {y : α | (b, y) ∈ t})) :=
begin
  rw [prod_def],
  show (nhds a).lift (λs:set α, (nhds b).lift (λt:set α, principal (set.prod s t))) = _,
  rw [lift_nhds_right],
  apply congr_arg, funext s,
  rw [lift_nhds_left],
  refl,
  exact monotone_comp (monotone_prod monotone_const monotone_id) monotone_principal,
  exact (monotone_lift' monotone_const $ monotone_lam $
    assume x, monotone_prod monotone_id monotone_const)
end

lemma nhds_eq_uniformity_prod {a b : α} :
  nhds (a, b) =
  (𝓤 α).lift' (λs:set (α×α), set.prod {y : α | (y, a) ∈ s} {y : α | (b, y) ∈ s}) :=
begin
  rw [nhds_prod_eq, nhds_nhds_eq_uniformity_uniformity_prod, lift_lift'_same_eq_lift'],
  { intro s, exact monotone_prod monotone_const monotone_preimage },
  { intro t, exact monotone_prod monotone_preimage monotone_const }
end

lemma nhdset_of_mem_uniformity {d : set (α×α)} (s : set (α×α)) (hd : d ∈ 𝓤 α) :
  ∃(t : set (α×α)), is_open t ∧ s ⊆ t ∧ t ⊆ {p | ∃x y, (p.1, x) ∈ d ∧ (x, y) ∈ s ∧ (y, p.2) ∈ d} :=
let cl_d := {p:α×α | ∃x y, (p.1, x) ∈ d ∧ (x, y) ∈ s ∧ (y, p.2) ∈ d} in
have ∀p ∈ s, ∃t ⊆ cl_d, is_open t ∧ p ∈ t, from
  assume ⟨x, y⟩ hp, mem_nhds_sets_iff.mp $
  show cl_d ∈ nhds (x, y),
  begin
    rw [nhds_eq_uniformity_prod, mem_lift'_sets],
    exact ⟨d, hd, assume ⟨a, b⟩ ⟨ha, hb⟩, ⟨x, y, ha, hp, hb⟩⟩,
    exact monotone_prod monotone_preimage monotone_preimage
  end,
have ∃t:(Π(p:α×α) (h:p ∈ s), set (α×α)),
    ∀p, ∀h:p ∈ s, t p h ⊆ cl_d ∧ is_open (t p h) ∧ p ∈ t p h,
  by simp [classical.skolem] at this; simp; assumption,
match this with
| ⟨t, ht⟩ :=
  ⟨(⋃ p:α×α, ⋃ h : p ∈ s, t p h : set (α×α)),
    is_open_Union $ assume (p:α×α), is_open_Union $ assume hp, (ht p hp).right.left,
    assume ⟨a, b⟩ hp, begin simp; exact ⟨a, b, hp, (ht (a,b) hp).right.right⟩ end,
    Union_subset $ assume p, Union_subset $ assume hp, (ht p hp).left⟩
end

lemma closure_eq_inter_uniformity {t : set (α×α)} :
  closure t = (⋂ d ∈ 𝓤 α, comp_rel d (comp_rel t d)) :=
set.ext $ assume ⟨a, b⟩,
calc (a, b) ∈ closure t ↔ (nhds (a, b) ⊓ principal t ≠ ⊥) : by simp [closure_eq_nhds]
  ... ↔ (((@prod.swap α α) <$> 𝓤 α).lift'
      (λ (s : set (α × α)), set.prod {x : α | (x, a) ∈ s} {y : α | (b, y) ∈ s}) ⊓ principal t ≠ ⊥) :
    by rw [←uniformity_eq_symm, nhds_eq_uniformity_prod]
  ... ↔ ((map (@prod.swap α α) (𝓤 α)).lift'
      (λ (s : set (α × α)), set.prod {x : α | (x, a) ∈ s} {y : α | (b, y) ∈ s}) ⊓ principal t ≠ ⊥) :
    by refl
  ... ↔ ((𝓤 α).lift'
      (λ (s : set (α × α)), set.prod {y : α | (a, y) ∈ s} {x : α | (x, b) ∈ s}) ⊓ principal t ≠ ⊥) :
  begin
    rw [map_lift'_eq2],
    simp [image_swap_eq_preimage_swap, function.comp],
    exact monotone_prod monotone_preimage monotone_preimage
  end
  ... ↔ (∀s ∈ 𝓤 α, ∃x, x ∈ set.prod {y : α | (a, y) ∈ s} {x : α | (x, b) ∈ s} ∩ t) :
  begin
    rw [lift'_inf_principal_eq, lift'_neq_bot_iff],
    apply forall_congr, intro s, rw [ne_empty_iff_exists_mem],
    exact monotone_inter (monotone_prod monotone_preimage monotone_preimage) monotone_const
  end
  ... ↔ (∀ s ∈ 𝓤 α, (a, b) ∈ comp_rel s (comp_rel t s)) :
    forall_congr $ assume s, forall_congr $ assume hs,
    ⟨assume ⟨⟨x, y⟩, ⟨⟨hx, hy⟩, hxyt⟩⟩, ⟨x, hx, y, hxyt, hy⟩,
      assume ⟨x, hx, y, hxyt, hy⟩, ⟨⟨x, y⟩, ⟨⟨hx, hy⟩, hxyt⟩⟩⟩
  ... ↔ _ : by simp

lemma uniformity_eq_uniformity_closure : 𝓤 α = (𝓤 α).lift' closure :=
le_antisymm
  (le_infi $ assume s, le_infi $ assume hs, by simp; filter_upwards [hs] subset_closure)
  (calc (𝓤 α).lift' closure ≤ (𝓤 α).lift' (λd, comp_rel d (comp_rel d d)) :
      lift'_mono' (by intros s hs; rw [closure_eq_inter_uniformity]; exact bInter_subset_of_mem hs)
    ... ≤ (𝓤 α) : comp_le_uniformity3)

lemma uniformity_eq_uniformity_interior : 𝓤 α = (𝓤 α).lift' interior :=
le_antisymm
  (le_infi $ assume d, le_infi $ assume hd,
    let ⟨s, hs, hs_comp⟩ := (mem_lift'_sets $
      monotone_comp_rel monotone_id $ monotone_comp_rel monotone_id monotone_id).mp (comp_le_uniformity3 hd) in
    let ⟨t, ht, hst, ht_comp⟩ := nhdset_of_mem_uniformity s hs in
    have s ⊆ interior d, from
      calc s ⊆ t : hst
       ... ⊆ interior d : (subset_interior_iff_subset_of_open ht).mpr $
        assume x, assume : x ∈ t, let ⟨x, y, h₁, h₂, h₃⟩ := ht_comp this in hs_comp ⟨x, h₁, y, h₂, h₃⟩,
    have interior d ∈ 𝓤 α, by filter_upwards [hs] this,
    by simp [this])
  (assume s hs, ((𝓤 α).lift' interior).sets_of_superset (mem_lift' hs) interior_subset)

lemma interior_mem_uniformity {s : set (α × α)} (hs : s ∈ 𝓤 α) :
  interior s ∈ 𝓤 α :=
by rw [uniformity_eq_uniformity_interior]; exact mem_lift' hs

lemma mem_uniformity_is_closed [uniform_space α] {s : set (α×α)} (h : s ∈ 𝓤 α) :
  ∃t ∈ 𝓤 α, is_closed t ∧ t ⊆ s :=
have s ∈ (𝓤 α).lift' closure, by rwa [uniformity_eq_uniformity_closure] at h,
have ∃ t ∈ 𝓤 α, closure t ⊆ s,
  by rwa [mem_lift'_sets] at this; apply closure_mono,
let ⟨t, ht, hst⟩ := this in
⟨closure t, (𝓤 α).sets_of_superset ht subset_closure, is_closed_closure, hst⟩

/- uniform continuity -/

def uniform_continuous [uniform_space β] (f : α → β) :=
tendsto (λx:α×α, (f x.1, f x.2)) (𝓤 α) (𝓤 β)

theorem uniform_continuous_def [uniform_space β] {f : α → β} :
  uniform_continuous f ↔ ∀ r ∈ 𝓤 β,
    {x : α × α | (f x.1, f x.2) ∈ r} ∈ 𝓤 α :=
iff.rfl

lemma uniform_continuous_of_const [uniform_space β] {c : α → β} (h : ∀a b, c a = c b) :
  uniform_continuous c :=
have (λ (x : α × α), (c (x.fst), c (x.snd))) ⁻¹' id_rel = univ, from
  eq_univ_iff_forall.2 $ assume ⟨a, b⟩, h a b,
le_trans (map_le_iff_le_comap.2 $ by simp [comap_principal, this, univ_mem_sets]) refl_le_uniformity

lemma uniform_continuous_id : uniform_continuous (@id α) :=
by simp [uniform_continuous]; exact tendsto_id

lemma uniform_continuous_const [uniform_space β] {b : β} : uniform_continuous (λa:α, b) :=
@tendsto_const_uniformity _ _ _ b (𝓤 α)

lemma uniform_continuous.comp [uniform_space β] [uniform_space γ] {f : α → β} {g : β → γ}
  (hf : uniform_continuous f) (hg : uniform_continuous g) : uniform_continuous (g ∘ f) :=
hf.comp hg

lemma uniform_continuous.continuous [uniform_space β] {f : α → β}
  (hf : uniform_continuous f) : continuous f :=
continuous_iff_continuous_at.mpr $ assume a,
calc map f (nhds a) ≤
    (map (λp:α×α, (f p.1, f p.2)) (𝓤 α)).lift' (λs:set (β×β), {y | (f a, y) ∈ s}) :
  begin
    rw [nhds_eq_uniformity, map_lift'_eq, map_lift'_eq2],
    exact (lift'_mono' $ assume s hs b ⟨a', (ha' : (_, a') ∈ s), a'_eq⟩,
      ⟨(a, a'), ha', show (f a, f a') = (f a, b), from a'_eq ▸ rfl⟩),
    exact monotone_preimage,
    exact monotone_preimage
  end
  ... ≤ nhds (f a) :
    by rw [nhds_eq_uniformity]; exact lift'_mono hf (le_refl _)
end uniform_space
end

local notation `𝓤` := uniformity

section constructions
variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*} {ι : Sort*}

instance : partial_order (uniform_space α) :=
{ le          := λt s, s.uniformity ≤ t.uniformity,
  le_antisymm := assume t s h₁ h₂, uniform_space_eq $ le_antisymm h₂ h₁,
  le_refl     := assume t, le_refl _,
  le_trans    := assume a b c h₁ h₂, @le_trans _ _ c.uniformity b.uniformity a.uniformity h₂ h₁ }

instance : has_Sup (uniform_space α) :=
⟨assume s, uniform_space.of_core {
  uniformity := (⨅u∈s, @uniformity α u),
  refl       := le_infi $ assume u, le_infi $ assume hu, u.refl,
  symm       := le_infi $ assume u, le_infi $ assume hu,
    le_trans (map_mono $ infi_le_of_le _ $ infi_le _ hu) u.symm,
  comp       := le_infi $ assume u, le_infi $ assume hu,
    le_trans (lift'_mono (infi_le_of_le _ $ infi_le _ hu) $ le_refl _) u.comp }⟩

private lemma le_Sup {tt : set (uniform_space α)} {t : uniform_space α} (h : t ∈ tt) :
  t ≤ Sup tt :=
show (⨅u∈tt, @uniformity α u) ≤ t.uniformity,
  from infi_le_of_le t $ infi_le _ h

private lemma Sup_le {tt : set (uniform_space α)} {t : uniform_space α} (h : ∀t'∈tt, t' ≤ t) :
  Sup tt ≤ t :=
show t.uniformity ≤ (⨅u∈tt, @uniformity α u),
  from le_infi $ assume t', le_infi $ assume ht', h t' ht'

instance : has_bot (uniform_space α) :=
⟨uniform_space.of_core { uniformity := ⊤, refl := le_top, symm := le_top, comp := le_top }⟩

instance : has_top (uniform_space α) :=
⟨{ to_topological_space := ⊤,
  uniformity  := principal id_rel,
  refl        := le_refl _,
  symm        := by simp [tendsto]; apply subset.refl,
  comp        :=
  begin
    rw [lift'_principal], {simp},
    exact monotone_comp_rel monotone_id monotone_id
  end,
  is_open_uniformity :=
    assume s, by simp [is_open_fold, subset_def, id_rel] {contextual := tt } } ⟩

instance : complete_lattice (uniform_space α) :=
{ sup           := λa b, Sup {a, b},
  le_sup_left   := assume a b, le_Sup $ by simp,
  le_sup_right  := assume a b, le_Sup $ by simp,
  sup_le        := assume a b c h₁ h₂, Sup_le $ assume t',
    begin simp, intro h, cases h with h h, repeat { subst h; assumption } end,
  inf           := λa b, Sup {x | x ≤ a ∧ x ≤ b},
  le_inf        := assume a b c h₁ h₂, le_Sup ⟨h₁, h₂⟩,
  inf_le_left   := assume a b, Sup_le $ assume x ⟨ha, hb⟩, ha,
  inf_le_right  := assume a b, Sup_le $ assume x ⟨ha, hb⟩, hb,
  top           := ⊤,
  le_top        := assume u, u.refl,
  bot           := ⊥,
  bot_le        := assume a, show a.uniformity ≤ ⊤, from le_top,
  Sup           := Sup,
  le_Sup        := assume s u, le_Sup,
  Sup_le        := assume s u, Sup_le,
  Inf           := λtt, Sup {t | ∀t'∈tt, t ≤ t'},
  le_Inf        := assume s a hs, le_Sup hs,
  Inf_le        := assume s a ha, Sup_le $ assume u hs, hs _ ha,
  ..uniform_space.partial_order }

lemma supr_uniformity {ι : Sort*} {u : ι → uniform_space α} :
  (supr u).uniformity = (⨅i, (u i).uniformity) :=
show (⨅a (h : ∃i:ι, u i = a), a.uniformity) = _, from
le_antisymm
  (le_infi $ assume i, infi_le_of_le (u i) $ infi_le _ ⟨i, rfl⟩)
  (le_infi $ assume a, le_infi $ assume ⟨i, (ha : u i = a)⟩, ha ▸ infi_le _ _)

lemma sup_uniformity {u v : uniform_space α} :
  (u ⊔ v).uniformity = u.uniformity ⊓ v.uniformity :=
have (u ⊔ v) = (⨆i (h : i = u ∨ i = v), i), by simp [supr_or, supr_sup_eq],
calc (u ⊔ v).uniformity = ((⨆i (h : i = u ∨ i = v), i) : uniform_space α).uniformity : by rw [this]
  ... = _ : by simp [supr_uniformity, infi_or, infi_inf_eq]

instance inhabited_uniform_space : inhabited (uniform_space α) := ⟨⊤⟩

/-- Given `f : α → β` and a uniformity `u` on `β`, the inverse image of `u` under `f`
  is the inverse image in the filter sense of the induced function `α × α → β × β`. -/
def uniform_space.comap (f : α → β) (u : uniform_space β) : uniform_space α :=
{ uniformity := u.uniformity.comap (λp:α×α, (f p.1, f p.2)),
  to_topological_space := u.to_topological_space.induced f,
  refl := le_trans (by simp; exact assume ⟨a, b⟩ (h : a = b), h ▸ rfl) (comap_mono u.refl),
  symm := by simp [tendsto_comap_iff, prod.swap, (∘)]; exact tendsto_comap.comp tendsto_swap_uniformity,
  comp := le_trans
    begin
      rw [comap_lift'_eq, comap_lift'_eq2],
      exact (lift'_mono' $ assume s hs ⟨a₁, a₂⟩ ⟨x, h₁, h₂⟩, ⟨f x, h₁, h₂⟩),
      repeat { exact monotone_comp_rel monotone_id monotone_id }
    end
    (comap_mono u.comp),
  is_open_uniformity := λ s, begin
    change (@is_open α (u.to_topological_space.induced f) s ↔ _),
    simp [is_open_iff_nhds, nhds_induced_eq_comap, mem_nhds_uniformity_iff, filter.comap, and_comm],
    refine ball_congr (λ x hx, ⟨_, _⟩),
    { rintro ⟨t, hts, ht⟩, refine ⟨_, ht, _⟩,
      rintro ⟨x₁, x₂⟩ h rfl, exact hts (h rfl) },
    { rintro ⟨t, ht, hts⟩,
      exact ⟨{y | (f x, y) ∈ t}, λ y hy, @hts (x, y) hy rfl,
        mem_nhds_uniformity_iff.1 $ mem_nhds_left _ ht⟩ }
  end }

lemma uniform_space_comap_id {α : Type*} : uniform_space.comap (id : α → α) = id :=
by ext u ; dsimp [uniform_space.comap] ; rw [prod.id_prod, filter.comap_id]

lemma uniform_space.comap_comap_comp {α β γ} [uγ : uniform_space γ] {f : α → β} {g : β → γ} :
  uniform_space.comap (g ∘ f) uγ = uniform_space.comap f (uniform_space.comap g uγ) :=
by ext ; dsimp [uniform_space.comap] ; rw filter.comap_comap_comp

lemma uniform_continuous_iff {α β} [uα : uniform_space α] [uβ : uniform_space β] (f : α → β) :
  uniform_continuous f ↔ uβ.comap f ≤ uα :=
filter.map_le_iff_le_comap

lemma uniform_continuous_comap {f : α → β} [u : uniform_space β] :
  @uniform_continuous α β (uniform_space.comap f u) u f :=
tendsto_comap

theorem to_topological_space_comap {f : α → β} {u : uniform_space β} :
  @uniform_space.to_topological_space _ (uniform_space.comap f u) =
  topological_space.induced f (@uniform_space.to_topological_space β u) :=
eq_of_nhds_eq_nhds $ assume a,
begin
  simp [nhds_induced_eq_comap, nhds_eq_uniformity, nhds_eq_uniformity],
  change comap f ((𝓤 β).lift' (preimage (λb, (f a, b)))) =
      (u.uniformity.comap (λp:α×α, (f p.1, f p.2))).lift' (preimage (λa', (a, a'))),
  rw [comap_lift'_eq monotone_preimage, comap_lift'_eq2 monotone_preimage],
  exact rfl
end

lemma uniform_continuous_comap' {f : γ → β} {g : α → γ} [v : uniform_space β] [u : uniform_space α]
  (h : uniform_continuous (f ∘ g)) : @uniform_continuous α γ u (uniform_space.comap f v) g :=
tendsto_comap_iff.2 h

lemma to_topological_space_mono {u₁ u₂ : uniform_space α} (h : u₁ ≤ u₂) :
  @uniform_space.to_topological_space _ u₁ ≤ @uniform_space.to_topological_space _ u₂ :=
le_of_nhds_le_nhds $ assume a,
  by rw [@nhds_eq_uniformity α u₁ a, @nhds_eq_uniformity α u₂ a]; exact (lift'_mono h $ le_refl _)

lemma to_topological_space_top : @uniform_space.to_topological_space α ⊤ = ⊤ := rfl

lemma to_topological_space_bot : @uniform_space.to_topological_space α ⊥ = ⊥ :=
bot_unique $ assume s hs, classical.by_cases
  (assume : s = ∅, this.symm ▸ @is_open_empty _ ⊥)
  (assume : s ≠ ∅,
    let ⟨x, hx⟩ := exists_mem_of_ne_empty this in
    have s = univ, from top_unique $ assume y hy, hs x hx (x, y) rfl,
    this.symm ▸ @is_open_univ _ ⊥)

lemma to_topological_space_supr {ι : Sort*} {u : ι → uniform_space α} :
  @uniform_space.to_topological_space α (supr u) = (⨆i, @uniform_space.to_topological_space α (u i)) :=
classical.by_cases
  (assume h : nonempty ι,
    eq_of_nhds_eq_nhds $ assume a,
    begin
      rw [nhds_supr, nhds_eq_uniformity],
      change _ = (supr u).uniformity.lift' (preimage $ prod.mk a),
      begin
        rw [supr_uniformity, lift'_infi],
        exact (congr_arg _ $ funext $ assume i, @nhds_eq_uniformity α (u i) a),
        exact h,
        exact assume a b, rfl
      end
    end)
  (assume : ¬ nonempty ι,
    le_antisymm
      (have supr u = ⊥, from bot_unique $ supr_le $ assume i, (this ⟨i⟩).elim,
        have @uniform_space.to_topological_space _ (supr u) = ⊥,
          from this.symm ▸ to_topological_space_bot,
        this.symm ▸ bot_le)
      (supr_le $ assume i, to_topological_space_mono $ le_supr _ _))

lemma to_topological_space_Sup {s : set (uniform_space α)} :
  @uniform_space.to_topological_space α (Sup s) = (⨆i∈s, @uniform_space.to_topological_space α i) :=
begin
  rw [Sup_eq_supr, to_topological_space_supr],
  apply congr rfl,
  funext x,
  exact to_topological_space_supr
end

lemma to_topological_space_sup {u v : uniform_space α} :
  @uniform_space.to_topological_space α (u ⊔ v) =
    @uniform_space.to_topological_space α u ⊔ @uniform_space.to_topological_space α v :=
ord_continuous_sup $ assume s, to_topological_space_Sup

instance : uniform_space empty := ⊤
instance : uniform_space unit := ⊤
instance : uniform_space bool := ⊤
instance : uniform_space ℕ := ⊤
instance : uniform_space ℤ := ⊤

instance {p : α → Prop} [t : uniform_space α] : uniform_space (subtype p) :=
uniform_space.comap subtype.val t

lemma uniformity_subtype {p : α → Prop} [t : uniform_space α] :
  𝓤 (subtype p) = comap (λq:subtype p × subtype p, (q.1.1, q.2.1)) (𝓤 α) :=
rfl

lemma uniform_continuous_subtype_val {p : α → Prop} [uniform_space α] :
  uniform_continuous (subtype.val : {a : α // p a} → α) :=
uniform_continuous_comap

lemma uniform_continuous_subtype_mk {p : α → Prop} [uniform_space α] [uniform_space β]
  {f : β → α} (hf : uniform_continuous f) (h : ∀x, p (f x)) :
  uniform_continuous (λx, ⟨f x, h x⟩ : β → subtype p) :=
uniform_continuous_comap' hf

lemma tendsto_of_uniform_continuous_subtype
  [uniform_space α] [uniform_space β] {f : α → β} {s : set α} {a : α}
  (hf : uniform_continuous (λx:s, f x.val)) (ha : s ∈ nhds a) :
  tendsto f (nhds a) (nhds (f a)) :=
by rw [(@map_nhds_subtype_val_eq α _ s a (mem_of_nhds ha) ha).symm]; exact
tendsto_map' (continuous_iff_continuous_at.mp hf.continuous _)

section prod

/- a similar product space is possible on the function space (uniformity of pointwise convergence),
  but we want to have the uniformity of uniform convergence on function spaces -/
instance [u₁ : uniform_space α] [u₂ : uniform_space β] : uniform_space (α × β) :=
uniform_space.of_core_eq
  (u₁.comap prod.fst ⊔ u₂.comap prod.snd).to_core
  prod.topological_space
  (calc prod.topological_space = (u₁.comap prod.fst ⊔ u₂.comap prod.snd).to_topological_space :
      by rw [to_topological_space_sup, to_topological_space_comap, to_topological_space_comap]; refl
    ... = _ : by rw [uniform_space.to_core_to_topological_space])

theorem uniformity_prod [uniform_space α] [uniform_space β] : @uniformity (α × β) _ =
  (𝓤 α).comap (λp:(α × β) × α × β, (p.1.1, p.2.1)) ⊓
  (𝓤 β).comap (λp:(α × β) × α × β, (p.1.2, p.2.2)) :=
sup_uniformity

lemma uniformity_prod_eq_prod [uniform_space α] [uniform_space β] :
  𝓤 (α×β) =
    map (λp:(α×α)×(β×β), ((p.1.1, p.2.1), (p.1.2, p.2.2))) (filter.prod (𝓤 α) (𝓤 β)) :=
have map (λp:(α×α)×(β×β), ((p.1.1, p.2.1), (p.1.2, p.2.2))) =
  comap (λp:(α×β)×(α×β), ((p.1.1, p.2.1), (p.1.2, p.2.2))),
  from funext $ assume f, map_eq_comap_of_inverse
    (funext $ assume ⟨⟨_, _⟩, ⟨_, _⟩⟩, rfl) (funext $ assume ⟨⟨_, _⟩, ⟨_, _⟩⟩, rfl),
by rw [this, uniformity_prod, filter.prod, comap_inf, comap_comap_comp, comap_comap_comp]

lemma mem_map_sets_iff' {α : Type*} {β : Type*} {f : filter α} {m : α → β} {t : set β} :
  t ∈ (map m f).sets ↔ (∃s∈f, m '' s ⊆ t) :=
mem_map_sets_iff

lemma mem_uniformity_of_uniform_continuous_invarant [uniform_space α] {s:set (α×α)} {f : α → α → α}
  (hf : uniform_continuous (λp:α×α, f p.1 p.2)) (hs : s ∈ 𝓤 α) :
  ∃u∈𝓤 α, ∀a b c, (a, b) ∈ u → (f a c, f b c) ∈ s :=
begin
  rw [uniform_continuous, uniformity_prod_eq_prod, tendsto_map'_iff, (∘)] at hf,
  rcases mem_map_sets_iff'.1 (hf hs) with ⟨t, ht, hts⟩, clear hf,
  rcases mem_prod_iff.1 ht with ⟨u, hu, v, hv, huvt⟩, clear ht,
  refine ⟨u, hu, assume a b c hab, hts $ (mem_image _ _ _).2 ⟨⟨⟨a, b⟩, ⟨c, c⟩⟩, huvt ⟨_, _⟩, _⟩⟩,
  exact hab,
  exact refl_mem_uniformity hv,
  refl
end

lemma mem_uniform_prod [t₁ : uniform_space α] [t₂ : uniform_space β] {a : set (α × α)} {b : set (β × β)}
  (ha : a ∈ 𝓤 α) (hb : b ∈ 𝓤 β) :
  {p:(α×β)×(α×β) | (p.1.1, p.2.1) ∈ a ∧ (p.1.2, p.2.2) ∈ b } ∈ (@uniformity (α × β) _) :=
by rw [uniformity_prod]; exact inter_mem_inf_sets (preimage_mem_comap ha) (preimage_mem_comap hb)

lemma tendsto_prod_uniformity_fst [uniform_space α] [uniform_space β] :
  tendsto (λp:(α×β)×(α×β), (p.1.1, p.2.1)) (𝓤 (α × β)) (𝓤 α) :=
le_trans (map_mono (@le_sup_left (uniform_space (α×β)) _ _ _)) map_comap_le

lemma tendsto_prod_uniformity_snd [uniform_space α] [uniform_space β] :
  tendsto (λp:(α×β)×(α×β), (p.1.2, p.2.2)) (𝓤 (α × β)) (𝓤 β) :=
le_trans (map_mono (@le_sup_right (uniform_space (α×β)) _ _ _)) map_comap_le

lemma uniform_continuous_fst [uniform_space α] [uniform_space β] : uniform_continuous (λp:α×β, p.1) :=
tendsto_prod_uniformity_fst

lemma uniform_continuous_snd [uniform_space α] [uniform_space β] : uniform_continuous (λp:α×β, p.2) :=
tendsto_prod_uniformity_snd

variables [uniform_space α] [uniform_space β] [uniform_space γ]
lemma uniform_continuous.prod_mk
  {f₁ : α → β} {f₂ : α → γ} (h₁ : uniform_continuous f₁) (h₂ : uniform_continuous f₂) :
  uniform_continuous (λa, (f₁ a, f₂ a)) :=
by rw [uniform_continuous, uniformity_prod]; exact
tendsto_inf.2 ⟨tendsto_comap_iff.2 h₁, tendsto_comap_iff.2 h₂⟩

lemma uniform_continuous.prod_mk_left {f : α × β → γ} (h : uniform_continuous f) (b) :
  uniform_continuous (λ a, f (a,b)) :=
(uniform_continuous_id.prod_mk uniform_continuous_const).comp h

lemma uniform_continuous.prod_mk_right {f : α × β → γ} (h : uniform_continuous f) (a) :
  uniform_continuous (λ b, f (a,b)) :=
(uniform_continuous_const.prod_mk  uniform_continuous_id).comp h

lemma to_topological_space_prod [u : uniform_space α] [v : uniform_space β] :
  @uniform_space.to_topological_space (α × β) prod.uniform_space =
    @prod.topological_space α β u.to_topological_space v.to_topological_space := rfl

end prod

lemma to_topological_space_subtype [u : uniform_space α] {p : α → Prop} :
  @uniform_space.to_topological_space (subtype p) subtype.uniform_space =
    @subtype.topological_space α p u.to_topological_space := rfl

section sum
variables [uniform_space α] [uniform_space β]
open sum

/-- Uniformity on a disjoint union. Entourages of the diagonal in the union are obtained
by taking independently an entourage of the diagonal in the first part, and an entourage of
the diagonal in the second part. -/
def uniform_space.core.sum : uniform_space.core (α ⊕ β) :=
uniform_space.core.mk'
  (map (λ p : α × α, (inl p.1, inl p.2)) (𝓤 α) ⊔ map (λ p : β × β, (inr p.1, inr p.2)) (𝓤 β))
  (λ r ⟨H₁, H₂⟩ x, by cases x; [apply refl_mem_uniformity H₁, apply refl_mem_uniformity H₂])
  (λ r ⟨H₁, H₂⟩, ⟨symm_le_uniformity H₁, symm_le_uniformity H₂⟩)
  (λ r ⟨Hrα, Hrβ⟩, begin
    rcases comp_mem_uniformity_sets Hrα with ⟨tα, htα, Htα⟩,
    rcases comp_mem_uniformity_sets Hrβ with ⟨tβ, htβ, Htβ⟩,
    refine ⟨_,
      ⟨mem_map_sets_iff.2 ⟨tα, htα, subset_union_left _ _⟩,
       mem_map_sets_iff.2 ⟨tβ, htβ, subset_union_right _ _⟩⟩, _⟩,
    rintros ⟨_, _⟩ ⟨z, ⟨⟨a, b⟩, hab, ⟨⟩⟩ | ⟨⟨a, b⟩, hab, ⟨⟩⟩,
                       ⟨⟨_, c⟩, hbc, ⟨⟩⟩ | ⟨⟨_, c⟩, hbc, ⟨⟩⟩⟩,
    { have A : (a, c) ∈ comp_rel tα tα := ⟨b, hab, hbc⟩,
      exact Htα A },
    { have A : (a, c) ∈ comp_rel tβ tβ := ⟨b, hab, hbc⟩,
      exact Htβ A }
  end)

/-- The union of an entourage of the diagonal in each set of a disjoint union is again an entourage of the diagonal. -/
lemma union_mem_uniformity_sum
  {a : set (α × α)} (ha : a ∈ 𝓤 α) {b : set (β × β)} (hb : b ∈ 𝓤 β) :
  ((λ p : (α × α), (inl p.1, inl p.2)) '' a ∪ (λ p : (β × β), (inr p.1, inr p.2)) '' b) ∈ (@uniform_space.core.sum α β _ _).uniformity :=
⟨mem_map_sets_iff.2 ⟨_, ha, subset_union_left _ _⟩, mem_map_sets_iff.2 ⟨_, hb, subset_union_right _ _⟩⟩

/- To prove that the topology defined by the uniform structure on the disjoint union coincides with
the disjoint union topology, we need two lemmas saying that open sets can be characterized by
the uniform structure -/
lemma uniformity_sum_of_open_aux {s : set (α ⊕ β)} (hs : is_open s) {x : α ⊕ β} (xs : x ∈ s) :
  { p : ((α ⊕ β) × (α ⊕ β)) | p.1 = x → p.2 ∈ s } ∈ (@uniform_space.core.sum α β _ _).uniformity :=
begin
  cases x,
  { refine mem_sets_of_superset
      (union_mem_uniformity_sum (mem_nhds_uniformity_iff.1 (mem_nhds_sets hs.1 xs)) univ_mem_sets)
      (union_subset _ _);
    rintro _ ⟨⟨_, b⟩, h, ⟨⟩⟩ ⟨⟩,
    exact h rfl },
  { refine mem_sets_of_superset
      (union_mem_uniformity_sum univ_mem_sets (mem_nhds_uniformity_iff.1 (mem_nhds_sets hs.2 xs)))
      (union_subset _ _);
    rintro _ ⟨⟨a, _⟩, h, ⟨⟩⟩ ⟨⟩,
    exact h rfl },
end

lemma open_of_uniformity_sum_aux {s : set (α ⊕ β)}
  (hs : ∀x ∈ s, { p : ((α ⊕ β) × (α ⊕ β)) | p.1 = x → p.2 ∈ s } ∈ (@uniform_space.core.sum α β _ _).uniformity) :
  is_open s :=
begin
  split,
  { refine (@is_open_iff_mem_nhds α _ _).2 (λ a ha, mem_nhds_uniformity_iff.2 _),
    rcases mem_map_sets_iff.1 (hs _ ha).1 with ⟨t, ht, st⟩,
    refine mem_sets_of_superset ht _,
    rintro p pt rfl, exact st ⟨_, pt, rfl⟩ rfl },
  { refine (@is_open_iff_mem_nhds β _ _).2 (λ b hb, mem_nhds_uniformity_iff.2 _),
    rcases mem_map_sets_iff.1 (hs _ hb).2 with ⟨t, ht, st⟩,
    refine mem_sets_of_superset ht _,
    rintro p pt rfl, exact st ⟨_, pt, rfl⟩ rfl }
end

/- We can now define the uniform structure on the disjoint union -/
instance sum.uniform_space [u₁ : uniform_space α] [u₂ : uniform_space β] : uniform_space (α ⊕ β) :=
{ to_core := uniform_space.core.sum,
  is_open_uniformity := λ s, ⟨uniformity_sum_of_open_aux, open_of_uniformity_sum_aux⟩ }

lemma sum.uniformity [uniform_space α] [uniform_space β] :
  𝓤 (α ⊕ β) =
    map (λ p : α × α, (inl p.1, inl p.2)) (𝓤 α) ⊔
    map (λ p : β × β, (inr p.1, inr p.2)) (𝓤 β) := rfl

end sum

end constructions

lemma lebesgue_number_lemma {α : Type u} [uniform_space α] {s : set α} {ι} {c : ι → set α}
  (hs : compact s) (hc₁ : ∀ i, is_open (c i)) (hc₂ : s ⊆ ⋃ i, c i) :
  ∃ n ∈ 𝓤 α, ∀ x ∈ s, ∃ i, {y | (x, y) ∈ n} ⊆ c i :=
begin
  let u := λ n, {x | ∃ i (m ∈ 𝓤 α), {y | (x, y) ∈ comp_rel m n} ⊆ c i},
  have hu₁ : ∀ n ∈ 𝓤 α, is_open (u n),
  { refine λ n hn, is_open_uniformity.2 _,
    rintro x ⟨i, m, hm, h⟩,
    rcases comp_mem_uniformity_sets hm with ⟨m', hm', mm'⟩,
    apply (𝓤 α).sets_of_superset hm',
    rintros ⟨x, y⟩ hp rfl,
    refine ⟨i, m', hm', λ z hz, h (monotone_comp_rel monotone_id monotone_const mm' _)⟩,
    dsimp at hz ⊢, rw comp_rel_assoc,
    exact ⟨y, hp, hz⟩ },
  have hu₂ : s ⊆ ⋃ n ∈ 𝓤 α, u n,
  { intros x hx,
    rcases mem_Union.1 (hc₂ hx) with ⟨i, h⟩,
    rcases comp_mem_uniformity_sets (is_open_uniformity.1 (hc₁ i) x h) with ⟨m', hm', mm'⟩,
    exact mem_bUnion hm' ⟨i, _, hm', λ y hy, mm' hy rfl⟩ },
  rcases compact_elim_finite_subcover_image hs hu₁ hu₂ with ⟨b, bu, b_fin, b_cover⟩,
  refine ⟨_, Inter_mem_sets b_fin bu, λ x hx, _⟩,
  rcases mem_bUnion_iff.1 (b_cover hx) with ⟨n, bn, i, m, hm, h⟩,
  refine ⟨i, λ y hy, h _⟩,
  exact prod_mk_mem_comp_rel (refl_mem_uniformity hm) (bInter_subset_of_mem bn hy)
end

lemma lebesgue_number_lemma_sUnion {α : Type u} [uniform_space α] {s : set α} {c : set (set α)}
  (hs : compact s) (hc₁ : ∀ t ∈ c, is_open t) (hc₂ : s ⊆ ⋃₀ c) :
  ∃ n ∈ 𝓤 α, ∀ x ∈ s, ∃ t ∈ c, ∀ y, (x, y) ∈ n → y ∈ t :=
by rw sUnion_eq_Union at hc₂;
   simpa using lebesgue_number_lemma hs (by simpa) hc₂


import linear_algebra.matrix.pos_def

namespace finset
variables {M ι : Type*} [ordered_cancel_comm_monoid M] {f g : ι → M} {s t : finset ι}
open_locale big_operators

--TODO: move
@[to_additive sum_pos'] lemma one_lt_prod' (Hle : ∀ i ∈ s, 1 ≤ f i) (Hlt : ∃ i ∈ s, 1 < f i) :
  1 < (∏ i in s, f i) :=
lt_of_le_of_lt (by rw prod_const_one) $ prod_lt_prod' Hle Hlt

end finset

namespace matrix
variables {𝕜 : Type*} [is_R_or_C 𝕜] {m n : Type*} [fintype m] [fintype n]
open_locale matrix

/-- A matrix `M : matrix n n 𝕜` is positive semidefinite if it is hermitian
   and `xᴴMx` is nonnegative for all `x`. -/
def pos_semidef (M : matrix n n 𝕜) :=
M.is_hermitian ∧ ∀ x : n → 𝕜, 0 ≤ is_R_or_C.re (dot_product (star x) (M.mul_vec x))

lemma pos_def.pos_semidef {M : matrix n n 𝕜} (hM : M.pos_def) : M.pos_semidef :=
begin
  refine ⟨hM.1, _⟩,
  intros x,
  by_cases hx : x = 0,
  { simp only [hx, zero_dot_product, star_zero, is_R_or_C.zero_re'] },
  { exact le_of_lt (hM.2 x hx) }
end

lemma pos_semidef.is_hermitian {M : matrix n n 𝕜} (hM : M.pos_semidef) : M.is_hermitian := hM.1

lemma pos_semidef.transpose {M : matrix n n 𝕜} (hM : M.pos_semidef) : Mᵀ.pos_semidef :=
begin
  refine ⟨is_hermitian.transpose hM.1, λ x, _⟩,
  convert hM.2 (star x) using 2,
  rw [mul_vec_transpose, matrix.dot_product_mul_vec, star_star, dot_product_comm]
end

lemma pos_semidef_diagonal [decidable_eq n] {f : n → ℝ} (hf : ∀ i, 0 ≤ f i) :
  (diagonal f).pos_semidef :=
begin
  refine ⟨is_hermitian_diagonal _, _⟩,
  intro x,
  simp only [star, id.def, is_R_or_C.re_to_real],
  apply finset.sum_nonneg',
  intro i,
  rw [mul_vec_diagonal f x i, mul_comm, mul_assoc],
  exact mul_nonneg (hf i) (mul_self_nonneg (x i))
end

lemma pos_def_diagonal [decidable_eq n] {f : n → ℝ} (hf : ∀ i, 0 < f i) :
  (diagonal f).pos_def :=
begin
  refine ⟨is_hermitian_diagonal _, _⟩,
  intros x hx,
  simp only [star, id.def, is_R_or_C.re_to_real],
  apply finset.sum_pos',
  { intros i _,
    rw [mul_vec_diagonal f x i, mul_comm, mul_assoc],
    exact mul_nonneg (le_of_lt (hf i)) (mul_self_nonneg (x i)) },
  { contrapose! hx,
    ext i,
    have := hx i (finset.mem_univ _),
    rw [mul_vec_diagonal f x i, mul_comm, mul_assoc] at this,
    have := nonpos_of_mul_nonpos_right this (hf i),
    rw mul_self_eq_zero.1 (le_antisymm this (mul_self_nonneg (x i))),
    refl }
end

-- instance : nontrivial 𝕜 := by apply_instance--infinite.nontrivial 𝕜
instance : is_domain 𝕜 := by apply_instance

-- Replace? seems to have fewer assumptions than `eq_zero_of_mul_vec_eq_zero`
lemma eq_zero_of_mul_vec_eq_zero' {R : Type*} [comm_ring R] [decidable_eq n]
  {M : matrix n n R} (hM : is_unit M.det) (x : n → R) (h : M.mul_vec x = 0) : x = 0 :=
calc
  x = (M⁻¹ ⬝ M).mul_vec x : by rw [nonsing_inv_mul M hM, one_mul_vec]
  ... = 0 : by rw [← mul_vec_mul_vec, h, mul_vec_zero]

lemma pos_def.det_ne_zero [decidable_eq n] {M : matrix n n 𝕜} (hM : M.pos_def) : M.det ≠ 0 :=
begin
  rw ← matrix.nondegenerate_iff_det_ne_zero,
  intros v hv,
  have hv' := hv (star v),
  rw [← star_eq_zero],
  by_contra h,
  have := hM.2 (star v) h,
  rw [star_star, hv'] at this,
  simpa using this,
end

lemma is_hermitian.nonsingular_inv [decidable_eq n] {M : matrix n n 𝕜}
  (hM : M.is_hermitian) (hMdet : is_unit M.det):
  M⁻¹.is_hermitian :=
begin
  refine (matrix.inv_eq_right_inv _).symm,
  rw [conj_transpose_nonsing_inv, hM.eq, mul_nonsing_inv _ hMdet]
end

lemma pos_def.nonsingular_inv [decidable_eq n] {M : matrix n n 𝕜} (hM : M.pos_def) :
  M⁻¹.pos_def :=
begin
  refine ⟨is_hermitian.nonsingular_inv hM.1 (is_unit_iff_ne_zero.2 hM.det_ne_zero), _⟩,
  intros x hx,
  have hMMinv := (mul_nonsing_inv _ (is_unit_iff_ne_zero.2 hM.det_ne_zero)),
  have hMinvdet : M⁻¹.det ≠ 0 := det_ne_zero_of_left_inverse hMMinv,
  have := hM.2 (M⁻¹.mul_vec x) (λ h, hx (eq_zero_of_mul_vec_eq_zero hMinvdet h)),
  rw [mul_vec_mul_vec, hMMinv, one_mul_vec, star_dot_product] at this,
  rw [← is_R_or_C.conj_re],
  exact this
end

-- TODO: move
lemma is_hermitian.conj_transpose_mul_mul (M N : matrix n n 𝕜) (hM : M.is_hermitian) :
  (Nᴴ ⬝ M ⬝ N).is_hermitian :=
by simp [is_hermitian, hM.eq, matrix.mul_assoc]

lemma pos_def.conj_transpose_mul_mul [decidable_eq n]
    (M N : matrix n n 𝕜) (hM : M.pos_def) (hN : N.det ≠ 0):
  (Nᴴ ⬝ M ⬝ N).pos_def :=
begin
  refine ⟨hM.1.conj_transpose_mul_mul M N, _⟩,
  intros x hx,
  convert hM.2 (N.mul_vec x) (λ h, hx (eq_zero_of_mul_vec_eq_zero hN h)) using 2,
  rw [matrix.mul_assoc, mul_vec_mul_vec, ←mul_vec_mul_vec, dot_product_mul_vec, star_mul_vec]
end

lemma pos_semidef.conj_transpose_mul_mul (M N : matrix n n 𝕜) (hM : M.pos_semidef) :
  (Nᴴ ⬝ M ⬝ N).pos_semidef :=
begin
  refine ⟨hM.1.conj_transpose_mul_mul M N, _⟩,
  intro x,
  convert hM.2 (N.mul_vec x) using 2,
  rw [matrix.mul_assoc, mul_vec_mul_vec, ←mul_vec_mul_vec, dot_product_mul_vec, star_mul_vec]
end

lemma pos_semidef.mul_mul_of_is_hermitian {M N : matrix n n 𝕜}
    (hM : M.pos_semidef) (hN : N.is_hermitian) :
  (N ⬝ M ⬝ N).pos_semidef :=
by { convert hM.conj_transpose_mul_mul M N, exact hN.symm }

lemma pos_semidef.submatrix {M : matrix n n 𝕜} (hM : M.pos_semidef) (e : m ≃ n):
  (M.submatrix e e).pos_semidef :=
begin
  refine ⟨hM.1.submatrix e, λ x, _⟩,
  have : (M.submatrix ⇑e ⇑e).mul_vec x = M.mul_vec (λ (i : n), x (e.symm i)) ∘ e,
  { ext i,
    dsimp only [(∘), mul_vec, dot_product],
    rw finset.sum_bij' (λ i _, e i) _ _ (λ i _, e.symm i);
    simp only [eq_self_iff_true, implies_true_iff, equiv.symm_apply_apply, finset.mem_univ,
      submatrix_apply, equiv.apply_symm_apply] },
  rw this,
  convert hM.2 (λ i, x (e.symm i)) using 3,
  unfold dot_product,
  rw [finset.sum_bij' (λ i _, e i) _ _ (λ i _, e.symm i)];
  simp only [eq_self_iff_true, implies_true_iff, equiv.symm_apply_apply, finset.mem_univ,
    submatrix_apply, equiv.apply_symm_apply, pi.star_apply],
end

@[simp] lemma pos_semidef_submatrix_equiv {M : matrix n n 𝕜} (e : m ≃ n) :
  (M.submatrix e e).pos_semidef ↔ M.pos_semidef :=
⟨λ h, by simpa using h.submatrix e.symm, λ h, h.submatrix _⟩

lemma pos_semidef.add {M N: matrix n n 𝕜} (hM : M.pos_semidef) (hN : N.pos_semidef) :
  (M + N).pos_semidef :=
begin
  refine ⟨hM.1.add hN.1, λ x, _⟩,
  simp only [add_mul_vec, dot_product_add, map_add],
  apply add_nonneg (hM.2 x) (hN.2 x)
end

namespace pos_def

variables {M : matrix n n ℝ} (hM : M.pos_def)
include hM

--TODO: use in `det_pos`
lemma eigenvalues_pos [decidable_eq n] (i : n) : 0 < hM.1.eigenvalues i :=
begin
  rw hM.is_hermitian.eigenvalues_eq,
  apply hM.2 _ (λ h, _),
  have h_det : (hM.is_hermitian.eigenvector_matrix)ᵀ.det = 0,
    from matrix.det_eq_zero_of_row_eq_zero i (λ j, congr_fun h j),
  simpa only [h_det, not_is_unit_zero] using
    is_unit_det_of_invertible hM.is_hermitian.eigenvector_matrixᵀ,
end

noncomputable instance [decidable_eq n] : invertible M :=
invertible_of_is_unit_det M (is_unit_iff_ne_zero.2 hM.det_ne_zero)

lemma is_unit_det [decidable_eq n]
  {M : matrix n n ℝ} (hM : M.pos_def) : is_unit M.det :=
is_unit_iff_ne_zero.2 hM.det_ne_zero

end pos_def

lemma is_unit_det_of_pos_def_inv [decidable_eq n]
  {M : matrix n n ℝ} (h : M⁻¹.pos_def) :
  is_unit M.det :=
begin
  apply is_unit_iff_ne_zero.2,
  have := h.is_unit_det,
  rw [det_nonsing_inv, is_unit_ring_inverse] at this,
  apply is_unit.ne_zero this,
end

lemma posdef_inv_iff_posdef [decidable_eq n]
  (M : matrix n n ℝ) : M⁻¹.pos_def ↔ M.pos_def :=
begin
  refine ⟨λ hM, _, λ hM, hM.nonsingular_inv⟩,
  rw ← matrix.nonsing_inv_nonsing_inv M (is_unit_det_of_pos_def_inv hM),
  apply hM.nonsingular_inv
end

namespace pos_semidef

variables {M : matrix n n ℝ} (hM : M.pos_semidef)
include hM

lemma eigenvalues_nonneg [decidable_eq n] (i : n) : 0 ≤ hM.1.eigenvalues i :=
by {rw hM.is_hermitian.eigenvalues_eq, apply hM.2}

lemma det_nonneg [decidable_eq n] : 0 ≤ det M :=
begin
  rw [hM.1.det_eq_prod_eigenvalues],
  apply finset.prod_nonneg (λ i hi, _),
  apply eigenvalues_nonneg,
end

end pos_semidef

end matrix


example (u w x y z : ℕ) (h₁ : x = y + z) (h₂ : w = u + x) :
  w = z + y + u :=
  by simp [add_comm, *]
-- lean 3.6 removes simp attributes from add_comm
-- i.e., now it is required to provide that lemma to solve this example.


import LeanExt

namespace Day2

inductive RPS where | rock | paper | scissors
deriving Inhabited, BEq

def RPS.next : RPS → RPS
  | rock => paper
  | paper => scissors
  | scissors => rock

def RPS.prev : RPS → RPS := next ∘ next

theorem RPS.next_eq (rps:RPS) : rps = rps.next.next.next := by
  cases rps <;> simp [next]

theorem RPS.next_eq_prev (rps:RPS) : rps.next = rps.prev.prev := by
  cases rps <;> simp [prev, next]

def RPS.points : RPS → Nat
  | rock => 1
  | paper => 2
  | scissors => 3

inductive Result where | lose | draw | win
deriving Inhabited

open RPS in
def Result.of (l r:RPS) : Result :=
  if l == r then draw
  else if l.next == r then win
  else lose

open RPS in open Result in
def Result.to (l:RPS) : Result → RPS
  | lose => l.prev
  | draw => l
  | win => l.next

def Result.points : Result → Nat
  | lose => 0
  | draw => 3
  | win => 6

namespace Parse
  def rps! : String → RPS
    | "A" | "X" => RPS.rock
    | "B" | "Y" => RPS.paper
    | "C" | "Z" => RPS.scissors
    | _ => panic! "invalid input [they]"

  def result! : String → Result
    | "X" => Result.lose
    | "Y" => Result.draw
    | "Z" => Result.win
    | _ => panic! "invalid input [they]"

  def input! [Inhabited α] [Inhabited β] (fLeft:String → α) (fRight:String → β) (ls:List String) : List (α × β) :=
    ls
    |>.map (fun l => l.split (' ' == ·))
    |>.map (fun ls =>
      match ls with
      | [sLeft, sRight] => (fLeft sLeft, fRight sRight)
      | _ => panic! "invalid input"
    )

  def input1! (ls:List String) := input! rps! rps! ls

  def input2! (ls:List String) := input! rps! result! ls
end Parse

def score (mrs:List (RPS × Result)) :Nat :=
  mrs
  |>.map (fun (me, result) => me.points + result.points)
  |>.sum

def part1 (ls:List String) :=
  ls
  |> Parse.input1!
  |>.map (fun (they, me) =>
      let result := Result.of they me
      (me, result)
  )
  |> score

def part2 (ls:List String) :=
  ls
  |> Parse.input2!
  |>.map (fun (they, result) =>
    let me := result.to they
    (me, result)
  )
  |> score

def testInput :=
  [ "A Y"
  , "B X"
  , "C Z"
  ]
#eval 15 <== part1 testInput
#eval 12 <== part2 testInput

end Day2