import tactic
import group_theory.subgroup.basic

variables {M : Type} [comm_monoid M] (a b : submonoid M)

include a

constant localization : Type

omit a

namespace localization

@[instance] protected constant comm_monoid : comm_monoid (localization a)

constant of : M →* localization a

constant is_unit_of (x : M) (hx : x ∈ a) : is_unit (of a x)

variables {N : Type} [comm_monoid N]

constant desc (f : M →* N) (hf : ∀ x ∈ a, is_unit (f x)) : localization a →* N

@[simp] constant desc_comp_of (f : M →* N) (hf : ∀ x ∈ a, is_unit (f x)) :
  (desc a f hf).comp (of a) = f

@[simp] constant desc_of (f : M →* N) (hf : ∀ x ∈ a, is_unit (f x)) (x : M):
  desc a f hf (of a x) = f x

@[ext] constant hom_ext {f g : localization a →* N}
  (h : f.comp (of a) = g.comp (of a)) : f = g

end localization

open localization

noncomputable def iso : localization (b.map (of a)) ≃* localization (a ⊔ b) :=
monoid_hom.to_mul_equiv
  (desc _ (desc _ (of (a ⊔ b))
    (λ x hx, is_unit_of _ _ (submonoid.mem_sup_left hx)))
    (λ x hx, begin
      rw [submonoid.mem_map] at hx,
      rcases hx with ⟨y, hy, rfl⟩,
      rw [desc_of],
      exact is_unit_of _ _ (submonoid.mem_sup_right hy)
    end))
  (desc _ ((of _).comp (of _))
    (λ x hx, begin
      rw [submonoid.mem_sup] at hx,
      rcases hx with ⟨y, hy, z, hz, rfl⟩,
      rw [map_mul],
      refine is_unit.mul _ _,
      { rw [monoid_hom.comp_apply],
        refine is_unit.map _ (is_unit_of _ _ hy), },
      { refine is_unit_of _ _ (submonoid.mem_map_of_mem _ hz) }
    end))
  (by ext; simp)
  (by ext; simp)

lemma iso_commutes : (iso a b).to_monoid_hom.comp ((of (b.map (of a))).comp (of a)) = of (a ⊔ b) :=
by ext; simp [iso]


/-
Copyright (c) 2022 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.calculus.fderiv_analytic
import analysis.asymptotics.specific_asymptotics
import analysis.complex.cauchy_integral

/-!
# Removable singularity theorem

In this file we prove Riemann's removable singularity theorem: if `f : ℂ → E` is complex
differentiable in a punctured neighborhood of a point `c` and is bounded in a punctured neighborhood
of `c` (or, more generally, $f(z) - f(c)=o((z-c)^{-1})$), then it has a limit at `c` and the
function `function.update f c (lim (𝓝[≠] c) f)` is complex differentiable in a neighborhood of `c`.
-/

open topological_space metric set filter asymptotics function
open_locale topological_space filter nnreal

universe u
variables {E : Type u} [normed_group E] [normed_space ℂ E] [measurable_space E] [borel_space E]
  [second_countable_topology E] [complete_space E]

namespace complex

/-- **Removable singularity** theorem, weak version. If `f : ℂ → E` is differentiable in a punctured
neighborhood of a point and is continuous at this point, then it is analytic at this point. -/
lemma analytic_at_of_differentiable_on_punctured_nhds_of_continuous_at {f : ℂ → E} {c : ℂ}
  (hd : ∀ᶠ z in 𝓝[≠] c, differentiable_at ℂ f z) (hc : continuous_at f c) :
  analytic_at ℂ f c :=
begin
  rcases (nhds_within_has_basis nhds_basis_closed_ball _).mem_iff.1 hd with ⟨R, hR0, hRs⟩,
  lift R to ℝ≥0 using hR0.le,
  replace hc : continuous_on f (closed_ball c R),
  { refine λ z hz, continuous_at.continuous_within_at _,
    rcases eq_or_ne z c with rfl | hne,
    exacts [hc, (hRs ⟨hz, hne⟩).continuous_at] },
  exact (has_fpower_series_on_ball_of_differentiable_off_countable (countable_singleton c) hc
    (λ z hz, hRs (diff_subset_diff_left ball_subset_closed_ball hz)) hR0).analytic_at
end

lemma differentiable_on_compl_singleton_and_continuous_at_iff {f : ℂ → E} {s : set ℂ} {c : ℂ}
  (hs : s ∈ 𝓝 c) : differentiable_on ℂ f (s \ {c}) ∧ continuous_at f c ↔ differentiable_on ℂ f s :=
begin
  refine ⟨_, λ hd, ⟨hd.mono (diff_subset _ _), (hd.differentiable_at hs).continuous_at⟩⟩,
  rintro ⟨hd, hc⟩ x hx,
  rcases eq_or_ne x c with rfl | hne,
  { refine (analytic_at_of_differentiable_on_punctured_nhds_of_continuous_at _ hc)
      .differentiable_at.differentiable_within_at,
    refine eventually_nhds_within_iff.2 ((eventually_mem_nhds.2 hs).mono $ λ z hz hzx, _),
    exact hd.differentiable_at (inter_mem hz (is_open_ne.mem_nhds hzx)) },
  { simpa only [differentiable_within_at, has_fderiv_within_at, hne.nhds_within_diff_singleton]
      using hd x ⟨hx, hne⟩ }
end

lemma differentiable_on_dslope {f : ℂ → E} {s : set ℂ} {c : ℂ} (hc : s ∈ 𝓝 c) :
  differentiable_on ℂ (dslope f c) s ↔ differentiable_on ℂ f s :=
⟨λ h, h.of_dslope, λ h, (differentiable_on_compl_singleton_and_continuous_at_iff hc).mp $
  ⟨iff.mpr (differentiable_on_dslope_of_nmem $ λ h, h.2 rfl) (h.mono $ diff_subset _ _),
    continuous_at_dslope_same.2 $ h.differentiable_at hc⟩⟩

/-- **Removable singularity** theorem: if `s` is a neighborhood of `c : ℂ`, a function `f : ℂ → E`
is complex differentiable on `s \ {c}`, and $f(z) - f(c)=o((z-c)^{-1})$, then `f` redefined to be
equal to `lim (𝓝[≠] c) f` at `c` is complex differentiable on `s`. -/
lemma differentiable_on_update_lim_of_is_o {f : ℂ → E} {s : set ℂ} {c : ℂ}
  (hc : s ∈ 𝓝 c) (hd : differentiable_on ℂ f (s \ {c}))
  (ho : is_o (λ z, f z - f c) (λ z, (z - c)⁻¹) (𝓝[≠] c)) :
  differentiable_on ℂ (update f c (lim (𝓝[≠] c) f)) s :=
begin
  set F : ℂ → E := λ z, (z - c) • f z with hF,
  suffices : differentiable_on ℂ F (s \ {c}) ∧ continuous_at F c,
  { rw [differentiable_on_compl_singleton_and_continuous_at_iff hc, ← differentiable_on_dslope hc,
      dslope_sub_smul] at this; try { apply_instance },
    have hc : tendsto f (𝓝[≠] c) (𝓝 (deriv F c)),
      from continuous_at_update_same.mp (this.continuous_on.continuous_at hc),
    rwa hc.lim_eq },
  refine ⟨(differentiable_on_id.sub_const _).smul hd, _⟩,
  rw ← continuous_within_at_compl_self,
  have H := ho.tendsto_inv_smul_nhds_zero,
  have H' : tendsto (λ z, (z - c) • f c) (𝓝[≠] c) (𝓝 (F c)),
    from (continuous_within_at_id.tendsto.sub tendsto_const_nhds).smul tendsto_const_nhds,
  simpa [← smul_add, continuous_within_at] using H.add H'
end

/-- **Removable singularity** theorem: if `s` is a punctured neighborhood of `c : ℂ`, a function
`f : ℂ → E` is complex differentiable on `s`, and $f(z) - f(c)=o((z-c)^{-1})$, then `f` redefined to
be equal to `lim (𝓝[≠] c) f` at `c` is complex differentiable on `{c} ∪ s`. -/
lemma differentiable_on_update_lim_insert_of_is_o {f : ℂ → E} {s : set ℂ} {c : ℂ}
  (hc : s ∈ 𝓝[≠] c) (hd : differentiable_on ℂ f s)
  (ho : is_o (λ z, f z - f c) (λ z, (z - c)⁻¹) (𝓝[≠] c)) :
  differentiable_on ℂ (update f c (lim (𝓝[≠] c) f)) (insert c s) :=
differentiable_on_update_lim_of_is_o (insert_mem_nhds_iff.2 hc)
  (hd.mono $ λ z hz, hz.1.resolve_left hz.2) ho

/-- **Removable singularity** theorem: if `s` is a neighborhood of `c : ℂ`, a function `f : ℂ → E`
is complex differentiable and is bounded on `s \ {c}`, then `f` redefined to be equal to
`lim (𝓝[≠] c) f` at `c` is complex differentiable on `s`. -/
lemma differentiable_on_update_lim_of_bdd_above {f : ℂ → E} {s : set ℂ} {c : ℂ}
  (hc : s ∈ 𝓝 c) (hd : differentiable_on ℂ f (s \ {c}))
  (hb : bdd_above (norm ∘ f '' (s \ {c}))) :
  differentiable_on ℂ (update f c (lim (𝓝[≠] c) f)) s :=
differentiable_on_update_lim_of_is_o hc hd $ is_bounded_under.is_o_sub_self_inv $
  let ⟨C, hC⟩ := hb in ⟨C + ∥f c∥, eventually_map.2 $ mem_nhds_within_iff_exists_mem_nhds_inter.2
    ⟨s, hc, λ z hz, norm_sub_le_of_le (hC $ mem_image_of_mem _ hz) le_rfl⟩⟩

/-- **Removable singularity** theorem: if a function `f : ℂ → E` is complex differentiable on a
punctured neighborhood of `c` and $f(z) - f(c)=o((z-c)^{-1})$, then `f` has a limit at `c`. -/
lemma tendsto_lim_of_differentiable_on_punctured_nhds_of_is_o {f : ℂ → E} {c : ℂ}
  (hd : ∀ᶠ z in 𝓝[≠] c, differentiable_at ℂ f z)
  (ho : is_o (λ z, f z - f c) (λ z, (z - c)⁻¹) (𝓝[≠] c)) :
  tendsto f (𝓝[≠] c) (𝓝 $ lim (𝓝[≠] c) f) :=
begin
  rw eventually_nhds_within_iff at hd,
  have : differentiable_on ℂ f ({z | z ≠ c → differentiable_at ℂ f z} \ {c}),
    from λ z hz, (hz.1 hz.2).differentiable_within_at,
  have H := differentiable_on_update_lim_of_is_o hd this ho,
  exact continuous_at_update_same.1 (H.differentiable_at hd).continuous_at
end

/-- **Removable singularity** theorem: if a function `f : ℂ → E` is complex differentiable and
bounded on a punctured neighborhood of `c`, then `f` has a limit at `c`. -/
lemma tendsto_lim_of_differentiable_on_punctured_nhds_of_bounded_under {f : ℂ → E}
  {c : ℂ} (hd : ∀ᶠ z in 𝓝[≠] c, differentiable_at ℂ f z)
  (hb : is_bounded_under (≤) (𝓝[≠] c) (λ z, ∥f z - f c∥)) :
  tendsto f (𝓝[≠] c) (𝓝 $ lim (𝓝[≠] c) f) :=
tendsto_lim_of_differentiable_on_punctured_nhds_of_is_o hd hb.is_o_sub_self_inv

end complex


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import set_theory.game.state

/-!
# Domineering as a combinatorial game.

We define the game of Domineering, played on a chessboard of arbitrary shape
(possibly even disconnected).
Left moves by placing a domino vertically, while Right moves by placing a domino horizontally.

This is only a fragment of a full development;
in order to successfully analyse positions we would need some more theorems.
Most importantly, we need a general statement that allows us to discard irrelevant moves.
Specifically to domineering, we need the fact that
disjoint parts of the chessboard give sums of games.
-/

namespace pgame

namespace domineering

open function

/-- The equivalence `(x, y) ↦ (x, y+1)`. -/
@[simps]
def shift_up : ℤ × ℤ ≃ ℤ × ℤ :=
(equiv.refl ℤ).prod_congr (equiv.add_right (1 : ℤ))
/-- The equivalence `(x, y) ↦ (x+1, y)`. -/
@[simps]
def shift_right : ℤ × ℤ ≃ ℤ × ℤ :=
(equiv.add_right (1 : ℤ)).prod_congr (equiv.refl ℤ)

/-- A Domineering board is an arbitrary finite subset of `ℤ × ℤ`. -/
@[derive inhabited]
def board := finset (ℤ × ℤ)
local attribute [reducible] board

/-- Left can play anywhere that a square and the square below it are open. -/
def left  (b : board) : finset (ℤ × ℤ) := b ∩ b.map shift_up
/-- Right can play anywhere that a square and the square to the left are open. -/
def right (b : board) : finset (ℤ × ℤ) := b ∩ b.map shift_right

lemma mem_left {b : board} (x : ℤ × ℤ) : x ∈ left b ↔ x ∈ b ∧ (x.1, x.2 - 1) ∈ b :=
finset.mem_inter.trans (and_congr iff.rfl finset.mem_map_equiv)

lemma mem_right {b : board} (x : ℤ × ℤ) : x ∈ right b ↔ x ∈ b ∧ (x.1 - 1, x.2) ∈ b :=
finset.mem_inter.trans (and_congr iff.rfl finset.mem_map_equiv)

/-- After Left moves, two vertically adjacent squares are removed from the board. -/
def move_left (b : board) (m : ℤ × ℤ) : board :=
(b.erase m).erase (m.1, m.2 - 1)
/-- After Left moves, two horizontally adjacent squares are removed from the board. -/
def move_right (b : board) (m : ℤ × ℤ) : board :=
(b.erase m).erase (m.1 - 1, m.2)

lemma fst_pred_mem_erase_of_mem_right {b : board} {m : ℤ × ℤ} (h : m ∈ right b) :
  (m.1 - 1, m.2) ∈ b.erase m :=
begin
  rw mem_right at h,
  apply finset.mem_erase_of_ne_of_mem _ h.2,
  exact ne_of_apply_ne prod.fst (pred_ne_self m.1),
end

lemma snd_pred_mem_erase_of_mem_left {b : board} {m : ℤ × ℤ} (h : m ∈ left b) :
  (m.1, m.2 - 1) ∈ b.erase m :=
begin
  rw mem_left at h,
  apply finset.mem_erase_of_ne_of_mem _ h.2,
  exact ne_of_apply_ne prod.snd (pred_ne_self m.2),
end

lemma card_of_mem_left {b : board} {m : ℤ × ℤ} (h : m ∈ left b) : 2 ≤ finset.card b :=
begin
  have w₁ : m ∈ b := (finset.mem_inter.1 h).1,
  have w₂ : (m.1, m.2 - 1) ∈ b.erase m := snd_pred_mem_erase_of_mem_left h,
  have i₁ := finset.card_erase_lt_of_mem w₁,
  have i₂ := nat.lt_of_le_of_lt (nat.zero_le _) (finset.card_erase_lt_of_mem w₂),
  exact nat.lt_of_le_of_lt i₂ i₁,
end

lemma card_of_mem_right {b : board} {m : ℤ × ℤ} (h : m ∈ right b) : 2 ≤ finset.card b :=
begin
  have w₁ : m ∈ b := (finset.mem_inter.1 h).1,
  have w₂ := fst_pred_mem_erase_of_mem_right h,
  have i₁ := finset.card_erase_lt_of_mem w₁,
  have i₂ := nat.lt_of_le_of_lt (nat.zero_le _) (finset.card_erase_lt_of_mem w₂),
  exact nat.lt_of_le_of_lt i₂ i₁,
end

lemma move_left_card {b : board} {m : ℤ × ℤ} (h : m ∈ left b) :
  finset.card (move_left b m) + 2 = finset.card b :=
begin
  dsimp [move_left],
  rw finset.card_erase_of_mem (snd_pred_mem_erase_of_mem_left h),
  rw finset.card_erase_of_mem (finset.mem_of_mem_inter_left h),
  exact tsub_add_cancel_of_le (card_of_mem_left h),
end

lemma move_right_card {b : board} {m : ℤ × ℤ} (h : m ∈ right b) :
  finset.card (move_right b m) + 2 = finset.card b :=
begin
  dsimp [move_right],
  rw finset.card_erase_of_mem (fst_pred_mem_erase_of_mem_right h),
  rw finset.card_erase_of_mem (finset.mem_of_mem_inter_left h),
  exact tsub_add_cancel_of_le (card_of_mem_right h),
end

lemma move_left_smaller {b : board} {m : ℤ × ℤ} (h : m ∈ left b) :
  finset.card (move_left b m) / 2 < finset.card b / 2 :=
by simp [←move_left_card h, lt_add_one]
lemma move_right_smaller {b : board} {m : ℤ × ℤ} (h : m ∈ right b) :
  finset.card (move_right b m) / 2 < finset.card b / 2 :=
by simp [←move_right_card h, lt_add_one]

/-- The instance describing allowed moves on a Domineering board. -/
instance state : state board :=
{ turn_bound := λ s, s.card / 2,
  L := λ s, (left s).image (move_left s),
  R := λ s, (right s).image (move_right s),
  left_bound := λ s t m,
  begin
    simp only [finset.mem_image, prod.exists] at m,
    rcases m with ⟨_, _, ⟨h, rfl⟩⟩,
    exact move_left_smaller h
  end,
  right_bound := λ s t m,
  begin
    simp only [finset.mem_image, prod.exists] at m,
    rcases m with ⟨_, _, ⟨h, rfl⟩⟩,
    exact move_right_smaller h
  end, }

end domineering

/-- Construct a pre-game from a Domineering board. -/
def domineering (b : domineering.board) : pgame := pgame.of_state b

/-- All games of Domineering are short, because each move removes two squares. -/
instance short_domineering (b : domineering.board) : short (domineering b) :=
by { dsimp [domineering], apply_instance }

/-- The Domineering board with two squares arranged vertically, in which Left has the only move. -/
def domineering.one := domineering ([(0,0), (0,1)].to_finset)

/-- The `L` shaped Domineering board, in which Left is exactly half a move ahead. -/
def domineering.L := domineering ([(0,2), (0,1), (0,0), (1,0)].to_finset)

instance short_one : short domineering.one := by { dsimp [domineering.one], apply_instance }
instance short_L : short domineering.L := by { dsimp [domineering.L], apply_instance }

-- The VM can play small games successfully:
-- #eval to_bool (domineering.one ≈ 1)
-- #eval to_bool (domineering.L + domineering.L ≈ 1)

-- The following no longer works since Lean 3.29, since definitions by well-founded
-- recursion no longer reduce definitionally.

-- We can check that `decidable` instances reduce as expected,
-- and so our implementation of domineering is computable.
-- run_cmd tactic.whnf `(by apply_instance : decidable (domineering.one ≤ 1)) >>= tactic.trace

-- dec_trivial can handle most of the dictionary of small games described in [conway2001]
-- example : domineering.one ≈ 1 := dec_trivial
-- example : domineering.L + domineering.L ≈ 1 := dec_trivial
-- example : domineering.L ≈ pgame.of_lists [0] [1] := dec_trivial
-- example : (domineering ([(0,0), (0,1), (0,2), (0,3)].to_finset) ≈ 2) := dec_trivial
-- example : (domineering ([(0,0), (0,1), (1,0), (1,1)].to_finset) ≈ pgame.of_lists [1] [-1]) :=
--   dec_trivial.

-- The 3x3 grid is doable, but takes a minute...
-- example :
--   (domineering ([(0,0), (0,1), (0,2), (1,0), (1,1), (1,2), (2,0), (2,1), (2,2)].to_finset) ≈
--     pgame.of_lists [1] [-1]) := dec_trivial

-- The 5x5 grid is actually 0, but brute-forcing this is too challenging even for the VM.
-- #eval to_bool (domineering ([
--   (0,0), (0,1), (0,2), (0,3), (0,4),
--   (1,0), (1,1), (1,2), (1,3), (1,4),
--   (2,0), (2,1), (2,2), (2,3), (2,4),
--   (3,0), (3,1), (3,2), (3,3), (3,4),
--   (4,0), (4,1), (4,2), (4,3), (4,4)
--   ].to_finset) ≈ 0)

end pgame


import hilbert.wr.dc_neg
import hilbert.wr.proofs.dc

namespace clfrags
    namespace hilbert
        namespace wr
            namespace dc_neg

                theorem dcn₁_dc {a b c d e f : Prop} (h₁ : dc e f (dc c d (dc b a (neg a))))
                : dc e f (dc c d b) :=
                    have h₂ : dc (dc e f c) (dc e f d) (dc b a (neg a)), from dc.dc₆' h₁,
                    have h₃ : dc (dc e f c) (dc e f d) b, from dcn₁ h₂,
                    show dc e f (dc c d b), from dc.dc₇' h₃

                theorem dcn₂_dc {a b c d e f : Prop} (h₁ : dc e f (dc c d b))
                : dc e f (dc c d (dc b a (neg a))) :=
                    have h₂ : dc (dc e f c) (dc e f d) b, from dc.dc₆' h₁,
                    have h₃ : dc (dc e f c) (dc e f d) (dc b a (neg a)), from dcn₂ h₂,
                    show dc e f (dc c d (dc b a (neg a))), from dc.dc₇' h₃

                theorem n₁ {a b : Prop} (h₁ : a) (h₂ : neg a) : b :=
                    have h₂ : dc a (neg a) b, from dc.dc₁ h₁ h₂,
                    have h₃ : dc (dc a (neg a) b) a b, from dc.dc₁ h₂ h₁,
                    have h₄ : dc a b (dc a (neg a) b), from dc.dc₅' (dc.dc₄' h₃),
                    have h₅ : dc a b (dc b a (neg a)), from dc.dc₄ (dc.dc₅ h₄),
                    have h₆ : dc a b b, from dcn₁ h₅,
                    show b, from dc.dc₂ h₆

                theorem dcn₃ {a b : Prop} (h₁ : b) : dc b a (neg a) :=
                    have h₂ : dc a b b, from dc.dc₃ h₁,
                    have h₃ : dc a b (dc b a (neg a)), from dcn₂ h₂,
                    have h₄ : dc (dc a b b) (dc a b a) (neg a), from dc.dc₆' h₃,
                    have h₅ : dc (neg a) (dc a b b) (dc a b a), from dc.dc₄' (dc.dc₅' h₄),
                    have h₆ : dc (neg a) (dc a b b) (dc b a a), from dc.dc₅ (dc.dc₄ h₅),
                    have h₇ : dc (neg a) (dc a b b) a, from dc.dc₂_dc h₆,
                    have h₈ : dc (neg a) a (dc a b b), from dc.dc₅' h₇,
                    have h₉ : dc (neg a) a b, from dc.dc₂_dc h₈,
                    show dc b a (neg a), from dc.dc₅' (dc.dc₄' (dc.dc₅' h₉))

            end dc_neg
        end wr
    end hilbert
end clfrags


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.Group.preadditive
import group_theory.quotient_group
import category_theory.limits.shapes.kernels
import category_theory.concrete_category.elementwise

/-!
# The category of additive commutative groups has all colimits.

This file uses a "pre-automated" approach, just as for `Mon/colimits.lean`.
It is a very uniform approach, that conceivably could be synthesised directly
by a tactic that analyses the shape of `add_comm_group` and `monoid_hom`.

TODO:
In fact, in `AddCommGroup` there is a much nicer model of colimits as quotients
of finitely supported functions, and we really should implement this as well (or instead).
-/

universes u v

open category_theory
open category_theory.limits

-- [ROBOT VOICE]:
-- You should pretend for now that this file was automatically generated.
-- It follows the same template as colimits in Mon.

namespace AddCommGroup.colimits
/-!
We build the colimit of a diagram in `AddCommGroup` by constructing the
free group on the disjoint union of all the abelian groups in the diagram,
then taking the quotient by the abelian group laws within each abelian group,
and the identifications given by the morphisms in the diagram.
-/

variables {J : Type v} [small_category J] (F : J ⥤ AddCommGroup.{v})

/--
An inductive type representing all group expressions (without relations)
on a collection of types indexed by the objects of `J`.
-/
inductive prequotient
-- There's always `of`
| of : Π (j : J) (x : F.obj j), prequotient
-- Then one generator for each operation
| zero : prequotient
| neg : prequotient → prequotient
| add : prequotient → prequotient → prequotient

instance : inhabited (prequotient F) := ⟨prequotient.zero⟩

open prequotient

/--
The relation on `prequotient` saying when two expressions are equal
because of the abelian group laws, or
because one element is mapped to another by a morphism in the diagram.
-/
inductive relation : prequotient F → prequotient F → Prop
-- Make it an equivalence relation:
| refl : Π (x), relation x x
| symm : Π (x y) (h : relation x y), relation y x
| trans : Π (x y z) (h : relation x y) (k : relation y z), relation x z
-- There's always a `map` relation
| map : Π (j j' : J) (f : j ⟶ j') (x : F.obj j), relation (of j' (F.map f x)) (of j x)
-- Then one relation per operation, describing the interaction with `of`
| zero : Π (j), relation (of j 0) zero
| neg : Π (j) (x : F.obj j), relation (of j (-x)) (neg (of j x))
| add : Π (j) (x y : F.obj j), relation (of j (x + y)) (add (of j x) (of j y))
-- Then one relation per argument of each operation
| neg_1 : Π (x x') (r : relation x x'), relation (neg x) (neg x')
| add_1 : Π (x x' y) (r : relation x x'), relation (add x y) (add x' y)
| add_2 : Π (x y y') (r : relation y y'), relation (add x y) (add x y')
-- And one relation per axiom
| zero_add      : Π (x), relation (add zero x) x
| add_zero      : Π (x), relation (add x zero) x
| add_left_neg  : Π (x), relation (add (neg x) x) zero
| add_comm      : Π (x y), relation (add x y) (add y x)
| add_assoc     : Π (x y z), relation (add (add x y) z) (add x (add y z))

/--
The setoid corresponding to group expressions modulo abelian group relations and identifications.
-/
def colimit_setoid : setoid (prequotient F) :=
{ r := relation F, iseqv := ⟨relation.refl, relation.symm, relation.trans⟩ }
attribute [instance] colimit_setoid

/--
The underlying type of the colimit of a diagram in `AddCommGroup`.
-/
@[derive inhabited]
def colimit_type : Type v := quotient (colimit_setoid F)

instance : add_comm_group (colimit_type F) :=
{ zero :=
  begin
    exact quot.mk _ zero
  end,
  neg :=
  begin
    fapply @quot.lift,
    { intro x,
      exact quot.mk _ (neg x) },
    { intros x x' r,
      apply quot.sound,
      exact relation.neg_1 _ _ r },
  end,
  add :=
  begin
    fapply @quot.lift _ _ ((colimit_type F) → (colimit_type F)),
    { intro x,
      fapply @quot.lift,
      { intro y,
        exact quot.mk _ (add x y) },
      { intros y y' r,
        apply quot.sound,
        exact relation.add_2 _ _ _ r } },
    { intros x x' r,
      funext y,
      induction y,
      dsimp,
      apply quot.sound,
      { exact relation.add_1 _ _ _ r },
      { refl } },
  end,
  zero_add := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.zero_add,
    refl,
  end,
  add_zero := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.add_zero,
    refl,
  end,
  add_left_neg := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.add_left_neg,
    refl,
  end,
  add_comm := λ x y,
  begin
    induction x,
    induction y,
    dsimp,
    apply quot.sound,
    apply relation.add_comm,
    refl,
    refl,
  end,
  add_assoc := λ x y z,
  begin
    induction x,
    induction y,
    induction z,
    dsimp,
    apply quot.sound,
    apply relation.add_assoc,
    refl,
    refl,
    refl,
  end, }

@[simp] lemma quot_zero : quot.mk setoid.r zero = (0 : colimit_type F) := rfl
@[simp] lemma quot_neg (x) :
  quot.mk setoid.r (neg x) = (-(quot.mk setoid.r x) : colimit_type F) := rfl
@[simp] lemma quot_add (x y) :
  quot.mk setoid.r (add x y) = ((quot.mk setoid.r x) + (quot.mk setoid.r y) : colimit_type F) := rfl

/-- The bundled abelian group giving the colimit of a diagram. -/
def colimit : AddCommGroup := AddCommGroup.of (colimit_type F)

/-- The function from a given abelian group in the diagram to the colimit abelian group. -/
def cocone_fun (j : J) (x : F.obj j) : colimit_type F :=
quot.mk _ (of j x)

/-- The group homomorphism from a given abelian group in the diagram to the colimit abelian
group. -/
def cocone_morphism (j : J) : F.obj j ⟶ colimit F :=
{ to_fun := cocone_fun F j,
  map_zero' := by apply quot.sound; apply relation.zero,
  map_add' := by intros; apply quot.sound; apply relation.add }

@[simp] lemma cocone_naturality {j j' : J} (f : j ⟶ j') :
  F.map f ≫ (cocone_morphism F j') = cocone_morphism F j :=
begin
  ext,
  apply quot.sound,
  apply relation.map,
end

@[simp] lemma cocone_naturality_components (j j' : J) (f : j ⟶ j') (x : F.obj j):
  (cocone_morphism F j') (F.map f x) = (cocone_morphism F j) x :=
by { rw ←cocone_naturality F f, refl }

/-- The cocone over the proposed colimit abelian group. -/
def colimit_cocone : cocone F :=
{ X := colimit F,
  ι :=
  { app := cocone_morphism F } }.

/-- The function from the free abelian group on the diagram to the cone point of any other
cocone. -/
@[simp] def desc_fun_lift (s : cocone F) : prequotient F → s.X
| (of j x)  := (s.ι.app j) x
| zero      := 0
| (neg x)   := -(desc_fun_lift x)
| (add x y) := desc_fun_lift x + desc_fun_lift y

/-- The function from the colimit abelian group to the cone point of any other cocone. -/
def desc_fun (s : cocone F) : colimit_type F → s.X :=
begin
  fapply quot.lift,
  { exact desc_fun_lift F s },
  { intros x y r,
    induction r; try { dsimp },
    -- refl
    { refl },
    -- symm
    { exact r_ih.symm },
    -- trans
    { exact eq.trans r_ih_h r_ih_k },
    -- map
    { simp, },
    -- zero
    { simp, },
    -- neg
    { simp, },
    -- add
    { simp, },
    -- neg_1
    { rw r_ih, },
    -- add_1
    { rw r_ih, },
    -- add_2
    { rw r_ih, },
    -- zero_add
    { rw zero_add, },
    -- add_zero
    { rw add_zero, },
    -- add_left_neg
    { rw add_left_neg, },
    -- add_comm
    { rw add_comm, },
    -- add_assoc
    { rw add_assoc, } }
end

/-- The group homomorphism from the colimit abelian group to the cone point of any other cocone. -/
def desc_morphism (s : cocone F) : colimit F ⟶ s.X :=
{ to_fun := desc_fun F s,
  map_zero' := rfl,
  map_add' := λ x y, by { induction x; induction y; refl }, }

/-- Evidence that the proposed colimit is the colimit. -/
def colimit_cocone_is_colimit : is_colimit (colimit_cocone F) :=
{ desc := λ s, desc_morphism F s,
  uniq' := λ s m w,
  begin
    ext,
    induction x,
    induction x,
    { have w' := congr_fun (congr_arg (λ f : F.obj x_j ⟶ s.X, (f : F.obj x_j → s.X)) (w x_j)) x_x,
      erw w',
      refl, },
    { simp *, },
    { simp *, },
    { simp *, },
    refl
  end }.

instance has_colimits_AddCommGroup : has_colimits AddCommGroup :=
{ has_colimits_of_shape := λ J 𝒥, by exactI
  { has_colimit := λ F, has_colimit.mk
    { cocone := colimit_cocone F,
      is_colimit := colimit_cocone_is_colimit F } } }

end AddCommGroup.colimits

namespace AddCommGroup

open quotient_add_group

/--
The categorical cokernel of a morphism in `AddCommGroup`
agrees with the usual group-theoretical quotient.
-/
noncomputable def cokernel_iso_quotient {G H : AddCommGroup.{u}} (f : G ⟶ H) :
  cokernel f ≅ AddCommGroup.of (H ⧸ (add_monoid_hom.range f)) :=
{ hom := cokernel.desc f (mk' _)
    (by { ext, apply quotient.sound, apply left_rel_apply.mpr, fsplit, exact -x,
          simp only [add_zero, add_monoid_hom.map_neg], }),
  inv := quotient_add_group.lift _ (cokernel.π f)
    (by { intros x H_1, cases H_1, induction H_1_h,
          simp only [cokernel.condition_apply, zero_apply]}),
  -- obviously can take care of the next goals, but it is really slow
  hom_inv_id' := begin
    ext1, simp only [coequalizer_as_cokernel, category.comp_id, cokernel.π_desc_assoc], ext1, refl,
  end,
  inv_hom_id' := begin
    ext x : 2,
    simp only [add_monoid_hom.coe_comp, function.comp_app, comp_apply, lift_mk,
      cokernel.π_desc_apply, mk'_apply, id_apply],
  end, }

end AddCommGroup


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.homeomorph
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Compact sets

## Summary

We define the subtype of compact sets in a topological space.

## Main Definitions

- `closeds α` is the type of closed subsets of a topological space `α`.
- `compacts α` is the type of compact subsets of a topological space `α`.
- `nonempty_compacts α` is the type of non-empty compact subsets.
- `positive_compacts α` is the type of compact subsets with non-empty interior.
-/

namespace topological_space

/-- The type of closed subsets of a topological space. -/
def closeds (α : Type u_1) [topological_space α] :=
  Subtype fun (s : set α) => is_closed s

/-- The type of closed subsets is inhabited, with default element the empty set. -/
protected instance closeds.inhabited (α : Type u_1) [topological_space α] : Inhabited (closeds α) :=
  { default := { val := ∅, property := is_closed_empty } }

/-- The compact sets of a topological space. See also `nonempty_compacts`. -/
def compacts (α : Type u_1) [topological_space α] :=
  Subtype fun (s : set α) => is_compact s

/-- The type of non-empty compact subsets of a topological space. The
non-emptiness will be useful in metric spaces, as we will be able to put
a distance (and not merely an edistance) on this space. -/
def nonempty_compacts (α : Type u_1) [topological_space α] :=
  Subtype fun (s : set α) => set.nonempty s ∧ is_compact s

/-- In an inhabited space, the type of nonempty compact subsets is also inhabited, with
default element the singleton set containing the default element. -/
protected instance nonempty_compacts_inhabited (α : Type u_1) [topological_space α] [Inhabited α] : Inhabited (nonempty_compacts α) :=
  { default := { val := singleton Inhabited.default, property := sorry } }

/-- The compact sets with nonempty interior of a topological space. See also `compacts` and
  `nonempty_compacts`. -/
def positive_compacts (α : Type u_1) [topological_space α] :=
  Subtype fun (s : set α) => is_compact s ∧ set.nonempty (interior s)

namespace compacts

protected instance semilattice_sup_bot {α : Type u_1} [topological_space α] : semilattice_sup_bot (compacts α) :=
  subtype.semilattice_sup_bot compact_empty sorry

protected instance semilattice_inf_bot {α : Type u_1} [topological_space α] [t2_space α] : semilattice_inf_bot (compacts α) :=
  subtype.semilattice_inf_bot compact_empty sorry

protected instance lattice {α : Type u_1} [topological_space α] [t2_space α] : lattice (compacts α) :=
  subtype.lattice sorry sorry

@[simp] theorem bot_val {α : Type u_1} [topological_space α] : subtype.val ⊥ = ∅ :=
  rfl

@[simp] theorem sup_val {α : Type u_1} [topological_space α] {K₁ : compacts α} {K₂ : compacts α} : subtype.val (K₁ ⊔ K₂) = subtype.val K₁ ∪ subtype.val K₂ :=
  rfl

protected theorem ext {α : Type u_1} [topological_space α] {K₁ : compacts α} {K₂ : compacts α} (h : subtype.val K₁ = subtype.val K₂) : K₁ = K₂ :=
  subtype.eq h

@[simp] theorem finset_sup_val {α : Type u_1} [topological_space α] {β : Type u_2} {K : β → compacts α} {s : finset β} : subtype.val (finset.sup s K) = finset.sup s fun (x : β) => subtype.val (K x) :=
  finset.sup_coe s K

protected instance inhabited {α : Type u_1} [topological_space α] : Inhabited (compacts α) :=
  { default := ⊥ }

/-- The image of a compact set under a continuous function. -/
protected def map {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (f : α → β) (hf : continuous f) (K : compacts α) : compacts β :=
  { val := f '' subtype.val K, property := sorry }

@[simp] theorem map_val {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] {f : α → β} (hf : continuous f) (K : compacts α) : subtype.val (compacts.map f hf K) = f '' subtype.val K :=
  rfl

/-- A homeomorphism induces an equivalence on compact sets, by taking the image. -/
@[simp] protected def equiv {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (f : α ≃ₜ β) : compacts α ≃ compacts β :=
  equiv.mk (compacts.map (⇑f) (homeomorph.continuous f)) (compacts.map ⇑(homeomorph.symm f) sorry) sorry sorry

/-- The image of a compact set under a homeomorphism can also be expressed as a preimage. -/
theorem equiv_to_fun_val {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (f : α ≃ₜ β) (K : compacts α) : subtype.val (coe_fn (compacts.equiv f) K) = ⇑(homeomorph.symm f) ⁻¹' subtype.val K :=
  congr_fun
    (set.image_eq_preimage_of_inverse (equiv.left_inv (homeomorph.to_equiv f)) (equiv.right_inv (homeomorph.to_equiv f)))
    (subtype.val K)

end compacts

protected instance nonempty_compacts.to_compact_space {α : Type u_1} [topological_space α] {p : nonempty_compacts α} : compact_space ↥(subtype.val p) :=
  compact_space.mk (iff.mp compact_iff_compact_univ (and.right (subtype.property p)))

protected instance nonempty_compacts.to_nonempty {α : Type u_1} [topological_space α] {p : nonempty_compacts α} : Nonempty ↥(subtype.val p) :=
  set.nonempty.to_subtype (and.left (subtype.property p))

/-- Associate to a nonempty compact subset the corresponding closed subset -/
def nonempty_compacts.to_closeds {α : Type u_1} [topological_space α] [t2_space α] : nonempty_compacts α → closeds α :=
  set.inclusion sorry


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

import algebraic_topology.dold_kan.functor_n

/-!

# Comparison with the normalized Moore complex functor

TODO (@joelriou) continue adding the various files referenced below

In this file, we show that when the category `A` is abelian,
there is an isomorphism `N₁_iso_normalized_Moore_complex_comp_to_karoubi` between
the functor `N₁ : simplicial_object A ⥤ karoubi (chain_complex A ℕ)`
defined in `functor_n.lean` and the composition of
`normalized_Moore_complex A` with the inclusion
`chain_complex A ℕ ⥤ karoubi (chain_complex A ℕ)`.

This isomorphism shall be used in `equivalence.lean` in order to obtain
the Dold-Kan equivalence
`category_theory.abelian.dold_kan.equivalence : simplicial_object A ≌ chain_complex A ℕ`
with a functor (definitionally) equal to `normalized_Moore_complex A`.

-/

open category_theory category_theory.category category_theory.limits
  category_theory.subobject category_theory.idempotents
open_locale dold_kan

noncomputable theory

namespace algebraic_topology

namespace dold_kan

universe v

variables {A : Type*} [category A] [abelian A] {X : simplicial_object A}

lemma higher_faces_vanish.inclusion_of_Moore_complex_map (n : ℕ) :
  higher_faces_vanish (n+1) ((inclusion_of_Moore_complex_map X).f (n+1)) := λ j hj,
begin
  dsimp [inclusion_of_Moore_complex_map],
  rw [← factor_thru_arrow _ _ (finset_inf_arrow_factors finset.univ
    _ j (by simp only [finset.mem_univ])), assoc, kernel_subobject_arrow_comp, comp_zero],
end

lemma factors_normalized_Moore_complex_P_infty (n : ℕ) :
  subobject.factors (normalized_Moore_complex.obj_X X n) (P_infty.f n) :=
begin
  cases n,
  { apply top_factors, },
  { rw [P_infty_f, normalized_Moore_complex.obj_X, finset_inf_factors],
    intros i hi,
    apply kernel_subobject_factors,
    exact (higher_faces_vanish.of_P (n+1) n) i (le_add_self), }
end

/-- P_infty factors through the normalized Moore complex -/
@[simps]
def P_infty_to_normalized_Moore_complex (X : simplicial_object A) : K[X] ⟶ N[X] :=
chain_complex.of_hom _ _ _ _ _ _
  (λ n, factor_thru _ _ (factors_normalized_Moore_complex_P_infty n))
  (λ n, begin
    rw [← cancel_mono (normalized_Moore_complex.obj_X X n).arrow, assoc, assoc,
      factor_thru_arrow, ← inclusion_of_Moore_complex_map_f,
      ← normalized_Moore_complex_obj_d, ← (inclusion_of_Moore_complex_map X).comm' (n+1) n rfl,
      inclusion_of_Moore_complex_map_f, factor_thru_arrow_assoc,
      ← alternating_face_map_complex_obj_d],
    exact P_infty.comm' (n+1) n rfl,
  end)

@[simp, reassoc]
lemma P_infty_to_normalized_Moore_complex_comp_inclusion_of_Moore_complex_map
  (X : simplicial_object A) :
  P_infty_to_normalized_Moore_complex X ≫ inclusion_of_Moore_complex_map X = P_infty := by tidy

@[simp, reassoc]
lemma P_infty_to_normalized_Moore_complex_naturality {X Y : simplicial_object A} (f : X ⟶ Y) :
  alternating_face_map_complex.map f ≫ P_infty_to_normalized_Moore_complex Y =
    P_infty_to_normalized_Moore_complex X ≫ normalized_Moore_complex.map f := by tidy

@[simp, reassoc]
lemma P_infty_comp_P_infty_to_normalized_Moore_complex (X : simplicial_object A) :
  P_infty ≫ P_infty_to_normalized_Moore_complex X = P_infty_to_normalized_Moore_complex X :=
by tidy

@[simp, reassoc]
lemma inclusion_of_Moore_complex_map_comp_P_infty (X : simplicial_object A) :
  inclusion_of_Moore_complex_map X ≫ P_infty = inclusion_of_Moore_complex_map X :=
begin
  ext n,
  cases n,
  { dsimp, simp only [comp_id], },
  { exact (higher_faces_vanish.inclusion_of_Moore_complex_map n).comp_P_eq_self, },
end

instance : mono (inclusion_of_Moore_complex_map X) :=
⟨λ Y f₁ f₂ hf, by { ext n, exact homological_complex.congr_hom hf n, }⟩

/-- `inclusion_of_Moore_complex_map X` is a split mono. -/
def split_mono_inclusion_of_Moore_complex_map (X : simplicial_object A) :
  split_mono (inclusion_of_Moore_complex_map X) :=
{ retraction := P_infty_to_normalized_Moore_complex X,
  id' := by simp only [← cancel_mono (inclusion_of_Moore_complex_map X), assoc, id_comp,
    P_infty_to_normalized_Moore_complex_comp_inclusion_of_Moore_complex_map,
    inclusion_of_Moore_complex_map_comp_P_infty], }

variable (A)

/-- When the category `A` is abelian,
the functor `N₁ : simplicial_object A ⥤ karoubi (chain_complex A ℕ)` defined
using `P_infty` identifies to the composition of the normalized Moore complex functor
and the inclusion in the Karoubi envelope. -/
def N₁_iso_normalized_Moore_complex_comp_to_karoubi :
  N₁ ≅ (normalized_Moore_complex A ⋙ to_karoubi _) :=
{ hom :=
  { app := λ X,
    { f := P_infty_to_normalized_Moore_complex X,
      comm := by erw [comp_id, P_infty_comp_P_infty_to_normalized_Moore_complex] },
    naturality' := λ X Y f, by simp only [functor.comp_map, normalized_Moore_complex_map,
      P_infty_to_normalized_Moore_complex_naturality, karoubi.hom_ext, karoubi.comp_f, N₁_map_f,
      P_infty_comp_P_infty_to_normalized_Moore_complex_assoc, to_karoubi_map_f, assoc] },
  inv :=
  { app := λ X,
    { f := inclusion_of_Moore_complex_map X,
      comm := by erw [inclusion_of_Moore_complex_map_comp_P_infty, id_comp] },
    naturality' := λ X Y f, by { ext, simp only [functor.comp_map, normalized_Moore_complex_map,
      karoubi.comp_f, to_karoubi_map_f, homological_complex.comp_f, normalized_Moore_complex.map_f,
      inclusion_of_Moore_complex_map_f, factor_thru_arrow, N₁_map_f,
      inclusion_of_Moore_complex_map_comp_P_infty_assoc, alternating_face_map_complex.map_f] } },
  hom_inv_id' := begin
    ext X : 3,
    simp only [P_infty_to_normalized_Moore_complex_comp_inclusion_of_Moore_complex_map,
      nat_trans.comp_app, karoubi.comp_f, N₁_obj_p, nat_trans.id_app, karoubi.id_eq],
  end,
  inv_hom_id' := begin
    ext X : 3,
    simp only [← cancel_mono (inclusion_of_Moore_complex_map X),
      nat_trans.comp_app, karoubi.comp_f, assoc, nat_trans.id_app, karoubi.id_eq,
      P_infty_to_normalized_Moore_complex_comp_inclusion_of_Moore_complex_map,
      inclusion_of_Moore_complex_map_comp_P_infty],
    dsimp only [functor.comp_obj, to_karoubi],
    rw id_comp,
  end }

end dold_kan

end algebraic_topology


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.ring.ulift
import algebra.module.equiv

/-!
# `ulift` instances for module and multiplicative actions

This file defines instances for module, mul_action and related structures on `ulift` types.

(Recall `ulift α` is just a "copy" of a type `α` in a higher universe.)

We also provide `ulift.module_equiv : ulift M ≃ₗ[R] M`.

-/

namespace ulift
universes u v w
variable {R : Type u}
variable {M : Type v}
variable {N : Type w}

instance has_scalar_left [has_scalar R M] :
  has_scalar (ulift R) M :=
⟨λ s x, s.down • x⟩

@[simp] lemma smul_down [has_scalar R M] (s : ulift R) (x : M) : (s • x) = s.down • x := rfl

@[simp]
lemma smul_down' [has_scalar R M] (s : R) (x : ulift M) :
  (s • x).down = s • x.down :=
rfl

instance is_scalar_tower [has_scalar R M] [has_scalar M N] [has_scalar R N]
  [is_scalar_tower R M N] : is_scalar_tower (ulift R) M N :=
⟨λ x y z, show (x.down • y) • z = x.down • y • z, from smul_assoc _ _ _⟩

instance is_scalar_tower' [has_scalar R M] [has_scalar M N] [has_scalar R N]
  [is_scalar_tower R M N] : is_scalar_tower R (ulift M) N :=
⟨λ x y z, show (x • y.down) • z = x • y.down • z, from smul_assoc _ _ _⟩

instance is_scalar_tower'' [has_scalar R M] [has_scalar M N] [has_scalar R N]
  [is_scalar_tower R M N] : is_scalar_tower R M (ulift N) :=
⟨λ x y z, show up ((x • y) • z.down) = ⟨x • y • z.down⟩, by rw smul_assoc⟩

instance [has_scalar R M] [has_scalar Rᵐᵒᵖ M] [is_central_scalar R M] :
  is_central_scalar R (ulift M) :=
⟨λ r m, congr_arg up $ op_smul_eq_smul r m.down⟩

instance mul_action [monoid R] [mul_action R M] : mul_action (ulift R) M :=
{ smul := (•),
  mul_smul := λ _ _, mul_smul _ _,
  one_smul := one_smul _ }

instance mul_action' [monoid R] [mul_action R M] :
  mul_action R (ulift M) :=
{ smul := (•),
  mul_smul := λ r s f, by { cases f, ext, simp [mul_smul], },
  one_smul := λ f, by { ext, simp [one_smul], } }

instance distrib_mul_action [monoid R] [add_monoid M] [distrib_mul_action R M] :
  distrib_mul_action (ulift R) M :=
{ smul_zero := λ _, smul_zero _,
  smul_add := λ _, smul_add _ }

instance distrib_mul_action' [monoid R] [add_monoid M] [distrib_mul_action R M] :
  distrib_mul_action R (ulift M) :=
{ smul_zero := λ c, by { ext, simp [smul_zero], },
  smul_add := λ c f g, by { ext, simp [smul_add], },
  ..ulift.mul_action' }

instance mul_distrib_mul_action [monoid R] [monoid M] [mul_distrib_mul_action R M] :
  mul_distrib_mul_action (ulift R) M :=
{ smul_one := λ _, smul_one _,
  smul_mul := λ _, smul_mul' _ }

instance mul_distrib_mul_action' [monoid R] [monoid M] [mul_distrib_mul_action R M] :
  mul_distrib_mul_action R (ulift M) :=
{ smul_one := λ _, by { ext, simp [smul_one], },
  smul_mul := λ c f g, by { ext, simp [smul_mul'], },
  ..ulift.mul_action' }

instance smul_with_zero [has_zero R] [has_zero M] [smul_with_zero R M] :
  smul_with_zero (ulift R) M :=
{ smul_zero := λ _, smul_zero' _ _,
  zero_smul := zero_smul _,
  ..ulift.has_scalar_left }

instance smul_with_zero' [has_zero R] [has_zero M] [smul_with_zero R M] :
  smul_with_zero R (ulift M) :=
{ smul_zero := λ _, ulift.ext _ _ $ smul_zero' _ _,
  zero_smul := λ _, ulift.ext _ _ $ zero_smul _ _ }

instance mul_action_with_zero [monoid_with_zero R] [has_zero M] [mul_action_with_zero R M] :
  mul_action_with_zero (ulift R) M :=
{ ..ulift.smul_with_zero }

instance mul_action_with_zero' [monoid_with_zero R] [has_zero M] [mul_action_with_zero R M] :
  mul_action_with_zero R (ulift M) :=
{ ..ulift.smul_with_zero' }

instance module [semiring R] [add_comm_monoid M] [module R M] : module (ulift R) M :=
{ add_smul := λ _ _, add_smul _ _,
  ..ulift.smul_with_zero }

instance module' [semiring R] [add_comm_monoid M] [module R M] : module R (ulift M) :=
{ add_smul := λ _ _ _, ulift.ext _ _ $ add_smul _ _ _,
  ..ulift.smul_with_zero' }

/--
The `R`-linear equivalence between `ulift M` and `M`.
-/
def module_equiv [semiring R] [add_comm_monoid M] [module R M] : ulift M ≃ₗ[R] M :=
{ to_fun := ulift.down,
  inv_fun := ulift.up,
  map_smul' := λ r x, rfl,
  map_add' := λ x y, rfl,
  left_inv := by tidy,
  right_inv := by tidy, }

end ulift


/-
Copyright (c) 2023 Paul Reichert. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul Reichert, Yaël Dillies
-/
import analysis.normed_space.add_torsor_bases
import analysis.normed_space.linear_isometry

/-!
# Intrinsic frontier and interior

This file defines the intrinsic frontier, interior and closure of a set in a normed additive torsor.
These are also known as relative frontier, interior, closure.

The intrinsic frontier/interior/closure of a set `s` is the frontier/interior/closure of `s`
considered as a set in its affine span.

The intrinsic interior is in general greater than the topological interior, the intrinsic frontier
in general less than the topological frontier, and the intrinsic closure in cases of interest the
same as the topological closure.

## Definitions

* `intrinsic_interior`: Intrinsic interior
* `intrinsic_frontier`: Intrinsic frontier
* `intrinsic_closure`: Intrinsic closure

## Results

The main results are:
* `affine_isometry.image_intrinsic_interior`/`affine_isometry.image_intrinsic_frontier`/
  `affine_isometry.image_intrinsic_closure`: Intrinsic interiors/frontiers/closures commute with
  taking the image under an affine isometry.
* `set.nonempty.intrinsic_interior`: The intrinsic interior of a nonempty convex set is nonempty.

## References

* Chapter 8 of [Barry Simon, *Convexity*][simon2011]
* Chapter 1 of [Rolf Schneider, *Convex Bodies: The Brunn-Minkowski theory*][schneider2013].

## TODO

* `is_closed s → is_extreme 𝕜 s (intrinsic_frontier 𝕜 s)`
* `x ∈ s → y ∈ intrinsic_interior 𝕜 s → open_segment 𝕜 x y ⊆ intrinsic_interior 𝕜 s`
-/

open affine_subspace set
open_locale pointwise

variables {𝕜 V W Q P : Type*}

section add_torsor
variables (𝕜) [ring 𝕜] [add_comm_group V] [module 𝕜 V] [topological_space P] [add_torsor V P]
  {s t : set P} {x : P}
include V

/-- The intrinsic interior of a set is its interior considered as a set in its affine span. -/
def intrinsic_interior (s : set P) : set P := coe '' interior (coe ⁻¹' s : set $ affine_span 𝕜 s)

/-- The intrinsic frontier of a set is its frontier considered as a set in its affine span. -/
def intrinsic_frontier (s : set P) : set P := coe '' frontier (coe ⁻¹' s : set $ affine_span 𝕜 s)

/-- The intrinsic closure of a set is its closure considered as a set in its affine span. -/
def intrinsic_closure (s : set P) : set P := coe '' closure (coe ⁻¹' s : set $ affine_span 𝕜 s)

variables {𝕜}

@[simp] lemma mem_intrinsic_interior :
  x ∈ intrinsic_interior 𝕜 s ↔ ∃ y, y ∈ interior (coe ⁻¹' s : set $ affine_span 𝕜 s) ∧ ↑y = x :=
mem_image _ _ _

@[simp] lemma mem_intrinsic_frontier :
  x ∈ intrinsic_frontier 𝕜 s ↔ ∃ y, y ∈ frontier (coe ⁻¹' s : set $ affine_span 𝕜 s) ∧ ↑y = x :=
mem_image _ _ _

@[simp] lemma mem_intrinsic_closure :
  x ∈ intrinsic_closure 𝕜 s ↔ ∃ y, y ∈ closure (coe ⁻¹' s : set $ affine_span 𝕜 s) ∧ ↑y = x :=
mem_image _ _ _

lemma intrinsic_interior_subset : intrinsic_interior 𝕜 s ⊆ s := image_subset_iff.2 interior_subset

lemma intrinsic_frontier_subset (hs : is_closed s) : intrinsic_frontier 𝕜 s ⊆ s :=
image_subset_iff.2 (hs.preimage continuous_induced_dom).frontier_subset

lemma intrinsic_frontier_subset_intrinsic_closure :
  intrinsic_frontier 𝕜 s ⊆ intrinsic_closure 𝕜 s :=
image_subset _ frontier_subset_closure

lemma subset_intrinsic_closure : s ⊆ intrinsic_closure 𝕜 s :=
λ x hx, ⟨⟨x, subset_affine_span _ _ hx⟩, subset_closure hx, rfl⟩

@[simp] lemma intrinsic_interior_empty : intrinsic_interior 𝕜 (∅ : set P) = ∅ :=
by simp [intrinsic_interior]

@[simp] lemma intrinsic_frontier_empty : intrinsic_frontier 𝕜 (∅ : set P) = ∅ :=
by simp [intrinsic_frontier]

@[simp] lemma intrinsic_closure_empty : intrinsic_closure 𝕜 (∅ : set P) = ∅ :=
by simp [intrinsic_closure]

@[simp] lemma intrinsic_closure_nonempty : (intrinsic_closure 𝕜 s).nonempty ↔ s.nonempty :=
⟨by { simp_rw nonempty_iff_ne_empty, rintro h rfl, exact h intrinsic_closure_empty },
  nonempty.mono subset_intrinsic_closure⟩

alias intrinsic_closure_nonempty ↔ set.nonempty.of_intrinsic_closure set.nonempty.intrinsic_closure

attribute [protected] set.nonempty.intrinsic_closure

@[simp] lemma intrinsic_interior_singleton (x : P) : intrinsic_interior 𝕜 ({x} : set P) = {x} :=
by simpa only [intrinsic_interior, preimage_coe_affine_span_singleton, interior_univ, image_univ,
  subtype.range_coe] using coe_affine_span_singleton _ _ _

@[simp] lemma intrinsic_frontier_singleton (x : P) : intrinsic_frontier 𝕜 ({x} : set P) = ∅ :=
by rw [intrinsic_frontier, preimage_coe_affine_span_singleton, frontier_univ, image_empty]

@[simp] lemma intrinsic_closure_singleton (x : P) : intrinsic_closure 𝕜 ({x} : set P) = {x} :=
by simpa only [intrinsic_closure, preimage_coe_affine_span_singleton, closure_univ, image_univ,
  subtype.range_coe] using coe_affine_span_singleton _ _ _

/-!
Note that neither `intrinsic_interior` nor `intrinsic_frontier` is monotone.
-/

lemma intrinsic_closure_mono (h : s ⊆ t) : intrinsic_closure 𝕜 s ⊆ intrinsic_closure 𝕜 t :=
begin
  refine image_subset_iff.2 (λ x hx, ⟨set.inclusion (affine_span_mono _ h) x,
    (continuous_inclusion _).closure_preimage_subset _ $ closure_mono _ hx, rfl⟩),
  exact λ y hy, h hy,
end

lemma interior_subset_intrinsic_interior : interior s ⊆ intrinsic_interior 𝕜 s :=
λ x hx, ⟨⟨x, subset_affine_span _ _ $ interior_subset hx⟩,
  preimage_interior_subset_interior_preimage continuous_subtype_coe hx, rfl⟩

lemma intrinsic_closure_subset_closure : intrinsic_closure 𝕜 s ⊆ closure s :=
image_subset_iff.2 $ continuous_subtype_coe.closure_preimage_subset _

lemma intrinsic_frontier_subset_frontier : intrinsic_frontier 𝕜 s ⊆ frontier s :=
image_subset_iff.2 $ continuous_subtype_coe.frontier_preimage_subset _

lemma intrinsic_closure_subset_affine_span : intrinsic_closure 𝕜 s ⊆ affine_span 𝕜 s :=
(image_subset_range _ _).trans subtype.range_coe.subset

@[simp] lemma intrinsic_closure_diff_intrinsic_frontier (s : set P) :
  intrinsic_closure 𝕜 s \ intrinsic_frontier 𝕜 s = intrinsic_interior 𝕜 s :=
(image_diff subtype.coe_injective _ _).symm.trans $
  by rw [closure_diff_frontier, intrinsic_interior]

@[simp] lemma intrinsic_closure_diff_intrinsic_interior (s : set P) :
  intrinsic_closure 𝕜 s \ intrinsic_interior 𝕜 s = intrinsic_frontier 𝕜 s :=
(image_diff subtype.coe_injective _ _).symm

@[simp] lemma intrinsic_interior_union_intrinsic_frontier (s : set P) :
  intrinsic_interior 𝕜 s ∪ intrinsic_frontier 𝕜 s = intrinsic_closure 𝕜 s :=
by simp [intrinsic_closure, intrinsic_interior, intrinsic_frontier,
  closure_eq_interior_union_frontier, image_union]

@[simp] lemma intrinsic_frontier_union_intrinsic_interior (s : set P) :
  intrinsic_frontier 𝕜 s ∪ intrinsic_interior 𝕜 s = intrinsic_closure 𝕜 s :=
by rw [union_comm, intrinsic_interior_union_intrinsic_frontier]

lemma is_closed_intrinsic_closure (hs : is_closed (affine_span 𝕜 s : set P)) :
  is_closed (intrinsic_closure 𝕜 s) :=
(closed_embedding_subtype_coe hs).is_closed_map _ is_closed_closure

lemma is_closed_intrinsic_frontier (hs : is_closed (affine_span 𝕜 s : set P)) :
  is_closed (intrinsic_frontier 𝕜 s) :=
(closed_embedding_subtype_coe hs).is_closed_map _ is_closed_frontier

@[simp] lemma affine_span_intrinsic_closure (s : set P) :
  affine_span 𝕜 (intrinsic_closure 𝕜 s) = affine_span 𝕜 s :=
(affine_span_le.2 intrinsic_closure_subset_affine_span).antisymm $
  affine_span_mono _ subset_intrinsic_closure

protected lemma is_closed.intrinsic_closure (hs : is_closed (coe ⁻¹' s : set $ affine_span 𝕜 s)) :
  intrinsic_closure 𝕜 s = s :=
begin
  rw [intrinsic_closure, hs.closure_eq, image_preimage_eq_of_subset],
  exact (subset_affine_span _ _).trans subtype.range_coe.superset,
end

@[simp] lemma intrinsic_closure_idem (s : set P) :
  intrinsic_closure 𝕜 (intrinsic_closure 𝕜 s) = intrinsic_closure 𝕜 s :=
begin
  refine is_closed.intrinsic_closure _,
  set t := affine_span 𝕜 (intrinsic_closure 𝕜 s) with ht,
  clear_value t,
  obtain rfl := ht.trans (affine_span_intrinsic_closure _),
  rw [intrinsic_closure, preimage_image_eq _ subtype.coe_injective],
  exact is_closed_closure,
end

end add_torsor

namespace affine_isometry
variables [normed_field 𝕜] [seminormed_add_comm_group V] [seminormed_add_comm_group W]
  [normed_space 𝕜 V] [normed_space 𝕜 W] [metric_space P] [pseudo_metric_space Q]
  [normed_add_torsor V P] [normed_add_torsor W Q]
include V W

local attribute [instance, nolint fails_quickly] affine_subspace.to_normed_add_torsor
  affine_subspace.nonempty_map

@[simp]

@[simp] lemma image_intrinsic_frontier (φ : P →ᵃⁱ[𝕜] Q) (s : set P) :
  intrinsic_frontier 𝕜 (φ '' s) = φ '' intrinsic_frontier 𝕜 s :=
begin
  obtain rfl | hs := s.eq_empty_or_nonempty,
  { simp },
  haveI : nonempty s := hs.to_subtype,
  let f := ((affine_span 𝕜 s).isometry_equiv_map φ).to_homeomorph,
  have : φ.to_affine_map ∘ coe ∘ f.symm = coe := funext isometry_equiv_map.apply_symm_apply,
  rw [intrinsic_frontier, intrinsic_frontier, ←φ.coe_to_affine_map, ←map_span φ.to_affine_map s,
    ←this, ←function.comp.assoc, image_comp, image_comp, f.symm.image_frontier, f.image_symm,
    ←preimage_comp, function.comp.assoc, f.symm_comp_self, affine_isometry.coe_to_affine_map,
    function.comp.right_id, preimage_comp, φ.injective.preimage_image],
end

@[simp] lemma image_intrinsic_closure (φ : P →ᵃⁱ[𝕜] Q) (s : set P) :
  intrinsic_closure 𝕜 (φ '' s) = φ '' intrinsic_closure 𝕜 s :=
begin
  obtain rfl | hs := s.eq_empty_or_nonempty,
  { simp },
  haveI : nonempty s := hs.to_subtype,
  let f := ((affine_span 𝕜 s).isometry_equiv_map φ).to_homeomorph,
  have : φ.to_affine_map ∘ coe ∘ f.symm = coe := funext isometry_equiv_map.apply_symm_apply,
  rw [intrinsic_closure, intrinsic_closure, ←φ.coe_to_affine_map, ←map_span φ.to_affine_map s,
    ←this, ←function.comp.assoc, image_comp, image_comp, f.symm.image_closure, f.image_symm,
    ←preimage_comp, function.comp.assoc, f.symm_comp_self, affine_isometry.coe_to_affine_map,
    function.comp.right_id, preimage_comp, φ.injective.preimage_image],
end

end affine_isometry

section normed_add_torsor
variables (𝕜) [nontrivially_normed_field 𝕜] [complete_space 𝕜] [normed_add_comm_group V]
  [normed_space 𝕜 V] [finite_dimensional 𝕜 V] [metric_space P] [normed_add_torsor V P] (s : set P)
include V

@[simp] lemma intrinsic_closure_eq_closure : intrinsic_closure 𝕜 s = closure s :=
begin
  ext x,
  simp only [mem_closure_iff, mem_intrinsic_closure],
  refine ⟨_, λ h, ⟨⟨x, _⟩, _, subtype.coe_mk _ _⟩⟩,
  { rintro ⟨x, h, rfl⟩ t ht hx,
    obtain ⟨z, hz₁, hz₂⟩ := h _ (continuous_induced_dom.is_open_preimage t ht) hx,
    exact ⟨z, hz₁, hz₂⟩ },
  { by_contradiction hc,
    obtain ⟨z, hz₁, hz₂⟩ := h _ (affine_span 𝕜 s).closed_of_finite_dimensional.is_open_compl hc,
    exact hz₁ (subset_affine_span 𝕜 s hz₂) },
  { rintro _ ⟨t, ht, rfl⟩ hx,
    obtain ⟨y, hyt, hys⟩ := h _ ht hx,
    exact ⟨⟨_, subset_affine_span 𝕜 s hys⟩, hyt, hys⟩ }
end

variables {𝕜}

@[simp] lemma closure_diff_intrinsic_interior (s : set P) :
  closure s \ intrinsic_interior 𝕜 s = intrinsic_frontier 𝕜 s :=
intrinsic_closure_eq_closure 𝕜 s ▸ intrinsic_closure_diff_intrinsic_interior s

@[simp] lemma closure_diff_intrinsic_frontier (s : set P) :
  closure s \ intrinsic_frontier 𝕜 s = intrinsic_interior 𝕜 s :=
intrinsic_closure_eq_closure 𝕜 s ▸ intrinsic_closure_diff_intrinsic_frontier s

end normed_add_torsor

private lemma aux {α β : Type*} [topological_space α] [topological_space β] (φ : α ≃ₜ β)
  (s : set β) :
  (interior s).nonempty ↔ (interior (φ ⁻¹' s)).nonempty :=
by rw [←φ.image_symm, ←φ.symm.image_interior, nonempty_image_iff]

variables [normed_add_comm_group V] [normed_space ℝ V] [finite_dimensional ℝ V] {s : set V}

/-- The intrinsic interior of a nonempty convex set is nonempty. -/
protected lemma set.nonempty.intrinsic_interior (hscv : convex ℝ s) (hsne : s.nonempty) :
  (intrinsic_interior ℝ s).nonempty :=
begin
  haveI := hsne.coe_sort,
  obtain ⟨p, hp⟩ := hsne,
  let p' : affine_span ℝ s := ⟨p, subset_affine_span _ _ hp⟩,
  rw [intrinsic_interior, nonempty_image_iff,
    aux (affine_isometry_equiv.const_vsub ℝ p').symm.to_homeomorph,
    convex.interior_nonempty_iff_affine_span_eq_top, affine_isometry_equiv.coe_to_homeomorph,
    ←affine_isometry_equiv.coe_to_affine_equiv, ←comap_span, affine_span_coe_preimage_eq_top,
    comap_top],
  exact hscv.affine_preimage ((affine_span ℝ s).subtype.comp
    (affine_isometry_equiv.const_vsub ℝ p').symm.to_affine_equiv.to_affine_map),
end

lemma intrinsic_interior_nonempty (hs : convex ℝ s) :
  (intrinsic_interior ℝ s).nonempty ↔ s.nonempty :=
⟨by { simp_rw nonempty_iff_ne_empty, rintro h rfl, exact h intrinsic_interior_empty },
  set.nonempty.intrinsic_interior hs⟩


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.CommRing.basic
import topology.category.Top.basic
import topology.algebra.ring

/-!
# Category of topological commutative rings

We introduce the category `TopCommRing` of topological commutative rings together with the relevant
forgetful functors to topological spaces and commutative rings.
-/

universes u

open category_theory

/-- A bundled topological commutative ring. -/
structure TopCommRing :=
(α : Type u)
[is_comm_ring : comm_ring α]
[is_topological_space : topological_space α]
[is_topological_ring : topological_ring α]

namespace TopCommRing

instance : has_coe_to_sort TopCommRing :=
{ S := Type u, coe := TopCommRing.α }

attribute [instance] is_comm_ring is_topological_space is_topological_ring

instance : category TopCommRing.{u} :=
{ hom   := λ R S, {f : R →+* S // continuous f },
  id    := λ R, ⟨ring_hom.id R, by obviously⟩, -- TODO remove obviously?
  comp  := λ R S T f g, ⟨g.val.comp f.val,
    begin -- TODO automate
      cases f, cases g,
      dsimp, apply continuous.comp ; assumption
    end⟩ }

instance : concrete_category TopCommRing.{u} :=
{ forget := { obj := λ R, R, map := λ R S f, f.val },
  forget_faithful := { } }

/-- Construct a bundled `TopCommRing` from the underlying type and the appropriate typeclasses. -/
def of (X : Type u) [comm_ring X] [topological_space X] [topological_ring X] : TopCommRing := ⟨X⟩

@[simp] lemma coe_of (X : Type u) [comm_ring X] [topological_space X] [topological_ring X] :
  (of X : Type u) = X := rfl

instance forget_topological_space (R : TopCommRing) :
  topological_space ((forget TopCommRing).obj R) :=
R.is_topological_space
instance forget_comm_ring (R : TopCommRing) :
  comm_ring ((forget TopCommRing).obj R) :=
R.is_comm_ring
instance forget_topological_ring (R : TopCommRing) :
  topological_ring ((forget TopCommRing).obj R) :=
R.is_topological_ring

instance has_forget_to_CommRing : has_forget₂ TopCommRing CommRing :=
has_forget₂.mk'
  (λ R, CommRing.of R)
  (λ x, rfl)
  (λ R S f, f.val)
  (λ R S f, heq.rfl)

instance forget_to_CommRing_topological_space (R : TopCommRing) :
  topological_space ((forget₂ TopCommRing CommRing).obj R) :=
R.is_topological_space

/-- The forgetful functor to Top. -/
instance has_forget_to_Top : has_forget₂ TopCommRing Top :=
has_forget₂.mk'
  (λ R, Top.of R)
  (λ x, rfl)
  (λ R S f, ⟨⇑f.1, f.2⟩)
  (λ R S f, heq.rfl)

instance forget_to_Top_comm_ring (R : TopCommRing) :
  comm_ring ((forget₂ TopCommRing Top).obj R) :=
R.is_comm_ring

instance forget_to_Top_topological_ring (R : TopCommRing) :
  topological_ring ((forget₂ TopCommRing Top).obj R) :=
R.is_topological_ring

/--
The forgetful functors to `Type` do not reflect isomorphisms,
but the forgetful functor from `TopCommRing` to `Top` does.
-/
instance : reflects_isomorphisms (forget₂ TopCommRing Top) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    -- We have an isomorphism in `Top`,
    let i_Top := as_iso ((forget₂ TopCommRing Top).map f),

    -- and a `ring_equiv`.
    let e_Ring : X ≃+* Y := { ..f.1, ..((forget Top).map_iso i_Top).to_equiv },

    -- Putting these together we obtain the isomorphism we're after:
    exact
    ⟨⟨⟨e_Ring.symm, i_Top.inv.2⟩,
      ⟨by { ext x, exact e_Ring.left_inv x, }, by { ext x, exact e_Ring.right_inv x, }⟩⟩⟩
  end }

end TopCommRing