/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import geometry.manifold.charted_space

/-!
# Local properties invariant under a groupoid

We study properties of a triple `(g, s, x)` where `g` is a function between two spaces `H` and `H'`,
`s` is a subset of `H` and `x` is a point of `H`. Our goal is to register how such a property
should behave to make sense in charted spaces modelled on `H` and `H'`.

The main examples we have in mind are the properties "`g` is differentiable at `x` within `s`", or
"`g` is smooth at `x` within `s`". We want to develop general results that, when applied in these
specific situations, say that the notion of smooth function in a manifold behaves well under
restriction, intersection, is local, and so on.

## Main definitions

* `local_invariant_prop G G' P` says that a property `P` of a triple `(g, s, x)` is local, and
  invariant under composition by elements of the groupoids `G` and `G'` of `H` and `H'`
  respectively.
* `charted_space.lift_prop_within_at` (resp. `lift_prop_at`, `lift_prop_on` and `lift_prop`):
  given a property `P` of `(g, s, x)` where `g : H → H'`, define the corresponding property
  for functions `M → M'` where `M` and `M'` are charted spaces modelled respectively on `H` and
  `H'`. We define these properties within a set at a point, or at a point, or on a set, or in the
  whole space. This lifting process (obtained by restricting to suitable chart domains) can always
  be done, but it only behaves well under locality and invariance assumptions.

Given `hG : local_invariant_prop G G' P`, we deduce many properties of the lifted property on the
charted spaces. For instance, `hG.lift_prop_within_at_inter` says that `P g s x` is equivalent to
`P g (s ∩ t) x` whenever `t` is a neighborhood of `x`.

## Implementation notes

We do not use dot notation for properties of the lifted property. For instance, we have
`hG.lift_prop_within_at_congr` saying that if `lift_prop_within_at P g s x` holds, and `g` and `g'`
coincide on `s`, then `lift_prop_within_at P g' s x` holds. We can't call it
`lift_prop_within_at.congr` as it is in the namespace associated to `local_invariant_prop`, not
in the one for `lift_prop_within_at`.
-/

noncomputable theory
open_locale classical manifold topological_space

open set

variables {H : Type*} {M : Type*} [topological_space H] [topological_space M] [charted_space H M]
{H' : Type*} {M' : Type*} [topological_space H'] [topological_space M'] [charted_space H' M']

namespace structure_groupoid

variables (G : structure_groupoid H) (G' : structure_groupoid H')

/-- Structure recording good behavior of a property of a triple `(f, s, x)` where `f` is a function,
`s` a set and `x` a point. Good behavior here means locality and invariance under given groupoids
(both in the source and in the target). Given such a good behavior, the lift of this property
to charted spaces admitting these groupoids will inherit the good behavior. -/
structure local_invariant_prop (P : (H → H') → (set H) → H → Prop) : Prop :=
(is_local : ∀ {s x u} {f : H → H'}, is_open u → x ∈ u → (P f s x ↔ P f (s ∩ u) x))
(right_invariance : ∀ {s x f} {e : local_homeomorph H H}, e ∈ G → x ∈ e.source → P f s x →
                      P (f ∘ e.symm) (e.target ∩ e.symm ⁻¹' s) (e x))
(congr : ∀ {s x} {f g : H → H'}, (∀ y ∈ s, f y = g y) → (f x = g x) → P f s x → P g s x)
(left_invariance : ∀ {s x f} {e' : local_homeomorph H' H'}, e' ∈ G' → s ⊆ f ⁻¹' (e'.source) →
                     f x ∈ e'.source → P f s x → P (e' ∘ f) s x)

end structure_groupoid

/-- Given a property of germs of functions and sets in the model space, then one defines
a corresponding property in a charted space, by requiring that it holds at the preferred chart at
this point. (When the property is local and invariant, it will in fact hold using any chart, see
`lift_prop_within_at_indep_chart`). We require continuity in the lifted property, as otherwise one
single chart might fail to capture the behavior of the function.
-/
def charted_space.lift_prop_within_at (P : (H → H') → set H → H → Prop)
  (f : M → M') (s : set M) (x : M) : Prop :=
continuous_within_at f s x ∧
P ((chart_at H' (f x)) ∘ f ∘ (chart_at H x).symm)
  ((chart_at H x).target ∩ (chart_at H x).symm ⁻¹' (s ∩ f ⁻¹' (chart_at H' (f x)).source))
  (chart_at H x x)

/-- Given a property of germs of functions and sets in the model space, then one defines
a corresponding property of functions on sets in a charted space, by requiring that it holds
around each point of the set, in the preferred charts. -/
def charted_space.lift_prop_on (P : (H → H') → set H → H → Prop) (f : M → M') (s : set M) :=
∀ x ∈ s, charted_space.lift_prop_within_at P f s x

/-- Given a property of germs of functions and sets in the model space, then one defines
a corresponding property of a function at a point in a charted space, by requiring that it holds
in the preferred chart. -/
def charted_space.lift_prop_at (P : (H → H') → set H → H → Prop) (f : M → M') (x : M) :=
charted_space.lift_prop_within_at P f univ x

/-- Given a property of germs of functions and sets in the model space, then one defines
a corresponding property of a function in a charted space, by requiring that it holds
in the preferred chart around every point. -/
def charted_space.lift_prop (P : (H → H') → set H → H → Prop) (f : M → M') :=
∀ x, charted_space.lift_prop_at P f x

open charted_space

namespace structure_groupoid

variables {G : structure_groupoid H} {G' : structure_groupoid H'}
{e e' : local_homeomorph M H} {f f' : local_homeomorph M' H'}
{P : (H → H') → set H → H → Prop} {g g' : M → M'} {s t : set M} {x : M}
{Q : (H → H) → set H → H → Prop}

lemma lift_prop_within_at_univ :
  lift_prop_within_at P g univ x ↔ lift_prop_at P g x :=
iff.rfl

lemma lift_prop_on_univ :
  lift_prop_on P g univ ↔ lift_prop P g :=
by simp [lift_prop_on, lift_prop, lift_prop_at]

namespace local_invariant_prop

variable (hG : G.local_invariant_prop G' P)
include hG

/-- If a property of a germ of function `g` on a pointed set `(s, x)` is invariant under the
structure groupoid (by composition in the source space and in the target space), then
expressing it in charted spaces does not depend on the element of the maximal atlas one uses
both in the source and in the target manifolds, provided they are defined around `x` and `g x`
respectively, and provided `g` is continuous within `s` at `x` (otherwise, the local behavior
of `g` at `x` can not be captured with a chart in the target). -/
lemma lift_prop_within_at_indep_chart_aux
  (he : e ∈ G.maximal_atlas M) (xe : x ∈ e.source)
  (he' : e' ∈ G.maximal_atlas M) (xe' : x ∈ e'.source)
  (hf : f ∈ G'.maximal_atlas M') (xf : g x ∈ f.source)
  (hf' : f' ∈ G'.maximal_atlas M') (xf' : g x ∈ f'.source)
  (hgs : continuous_within_at g s x)
  (h : P (f ∘ g ∘ e.symm) (e.target ∩ e.symm ⁻¹' (s ∩ g⁻¹' f.source)) (e x)) :
  P (f' ∘ g ∘ e'.symm) (e'.target ∩ e'.symm ⁻¹' (s ∩ g⁻¹' f'.source)) (e' x) :=
begin
  obtain ⟨o, o_open, xo, oe, oe', of, of'⟩ :
    ∃ (o : set M), is_open o ∧ x ∈ o ∧ o ⊆ e.source ∧ o ⊆ e'.source ∧
      o ∩ s ⊆ g ⁻¹' f.source ∧ o ∩ s ⊆  g⁻¹' f'.to_local_equiv.source,
  { have : f.source ∩ f'.source ∈ 𝓝 (g x) :=
      is_open.mem_nhds (is_open.inter f.open_source f'.open_source) ⟨xf, xf'⟩,
    rcases mem_nhds_within.1 (hgs.preimage_mem_nhds_within this) with ⟨u, u_open, xu, hu⟩,
    refine ⟨u ∩ e.source ∩ e'.source, _, ⟨⟨xu, xe⟩, xe'⟩, _, _, _, _⟩,
    { exact is_open.inter (is_open.inter u_open e.open_source) e'.open_source },
    { assume x hx, exact hx.1.2 },
    { assume x hx, exact hx.2 },
    { assume x hx, exact (hu ⟨hx.1.1.1, hx.2⟩).1 },
    { assume x hx, exact (hu ⟨hx.1.1.1, hx.2⟩).2 } },
  have A : P (f ∘ g ∘ e.symm)
             (e.target ∩ e.symm ⁻¹' (s ∩ g⁻¹' f.source) ∩ (e.target ∩ e.symm ⁻¹' o)) (e x),
  { apply (hG.is_local _ _).1 h,
    { exact e.continuous_on_symm.preimage_open_of_open e.open_target o_open },
    { simp only [xe, xo] with mfld_simps} },
  have B : P ((f.symm ≫ₕ f') ∘ (f ∘ g ∘ e.symm))
             (e.target ∩ e.symm ⁻¹' (s ∩ g⁻¹' f.source) ∩ (e.target ∩ e.symm ⁻¹' o)) (e x),
  { refine hG.left_invariance (compatible_of_mem_maximal_atlas hf hf') (λ y hy, _)
      (by simp only [xe, xf, xf'] with mfld_simps) A,
    simp only with mfld_simps at hy,
    have : e.symm y ∈ o ∩ s, by simp only [hy] with mfld_simps,
    simpa only [hy] with mfld_simps using of' this },
  have C : P (f' ∘ g ∘ e.symm)
             (e.target ∩ e.symm ⁻¹' (s ∩ g⁻¹' f.source) ∩ (e.target ∩ e.symm ⁻¹' o)) (e x),
  { refine hG.congr (λ y hy, _) (by simp only [xe, xf] with mfld_simps) B,
    simp only [local_homeomorph.coe_trans, function.comp_app],
    rw f.left_inv,
    apply of,
    simp only with mfld_simps at hy,
    simp only [hy] with mfld_simps },
  let w := e.symm ≫ₕ e',
  let ow := w.target ∩ w.symm ⁻¹'
    (e.target ∩ e.symm ⁻¹' (s ∩ g⁻¹' f.source) ∩ (e.target ∩ e.symm ⁻¹' o)),
  have wG : w ∈ G := compatible_of_mem_maximal_atlas he he',
  have D : P ((f' ∘ g ∘ e.symm) ∘ w.symm) ow (w (e x)) :=
    hG.right_invariance wG (by simp only [w, xe, xe'] with mfld_simps) C,
  have E : P (f' ∘ g ∘ e'.symm) ow (w (e x)),
  { refine hG.congr _ (by simp only [xe, xe'] with mfld_simps) D,
    assume y hy,
    simp only with mfld_simps,
    rw e.left_inv,
    simp only with mfld_simps at hy,
    simp only [hy] with mfld_simps },
  have : w (e x) = e' x, by simp only [w, xe] with mfld_simps,
  rw this at E,
  have : ow = (e'.target ∩ e'.symm ⁻¹' (s ∩ g⁻¹' f'.source))
               ∩ (w.target ∩ (e'.target ∩ e'.symm ⁻¹' o)),
  { ext y,
    split,
    { assume hy,
      have : e.symm (e ((e'.symm) y)) = e'.symm y,
        by { simp only with mfld_simps at hy, simp only [hy] with mfld_simps },
      simp only [this] with mfld_simps at hy,
      have : g (e'.symm y) ∈ f'.source, by { apply of', simp only [hy] with mfld_simps },
      simp only [hy, this] with mfld_simps },
    { assume hy,
      simp only with mfld_simps at hy,
      have : g (e'.symm y) ∈ f.source, by { apply of, simp only [hy] with mfld_simps },
      simp only [this, hy] with mfld_simps } },
  rw this at E,
  apply (hG.is_local _ _).2 E,
  { exact is_open.inter w.open_target
      (e'.continuous_on_symm.preimage_open_of_open e'.open_target o_open) },
  { simp only [xe', xe, xo] with mfld_simps },
end

lemma lift_prop_within_at_indep_chart [has_groupoid M G] [has_groupoid M' G']
  (he : e ∈ G.maximal_atlas M) (xe : x ∈ e.source)
  (hf : f ∈ G'.maximal_atlas M') (xf : g x ∈ f.source) :
  lift_prop_within_at P g s x ↔
    continuous_within_at g s x ∧ P (f ∘ g ∘ e.symm)
      (e.target ∩ e.symm ⁻¹' (s ∩ g⁻¹' f.source)) (e x) :=
⟨λ H, ⟨H.1,
  hG.lift_prop_within_at_indep_chart_aux (chart_mem_maximal_atlas _ _) (mem_chart_source _ _) he xe
  (chart_mem_maximal_atlas _ _) (mem_chart_source _ _) hf xf H.1 H.2⟩,
λ H, ⟨H.1,
  hG.lift_prop_within_at_indep_chart_aux he xe (chart_mem_maximal_atlas _ _) (mem_chart_source _ _)
    hf xf (chart_mem_maximal_atlas _ _) (mem_chart_source _ _) H.1 H.2⟩⟩

lemma lift_prop_on_indep_chart [has_groupoid M G] [has_groupoid M' G']
  (he : e ∈ G.maximal_atlas M) (hf : f ∈ G'.maximal_atlas M') (h : lift_prop_on P g s) :
  ∀ y ∈ e.target ∩ e.symm ⁻¹' (s ∩ g ⁻¹' f.source),
  P (f ∘ g ∘ e.symm) (e.target ∩ e.symm ⁻¹' (s ∩ g ⁻¹' f.source)) y :=
begin
  assume y hy,
  simp only with mfld_simps at hy,
  have : e.symm y ∈ s, by simp only [hy] with mfld_simps,
  convert ((hG.lift_prop_within_at_indep_chart he _ hf _).1 (h _ this)).2,
  repeat { simp only [hy] with mfld_simps },
end

lemma lift_prop_within_at_inter' (ht : t ∈ 𝓝[s] x) :
  lift_prop_within_at P g (s ∩ t) x ↔ lift_prop_within_at P g s x :=
begin
  by_cases hcont : ¬ (continuous_within_at g s x),
  { have : ¬ (continuous_within_at g (s ∩ t) x), by rwa [continuous_within_at_inter' ht],
    simp only [lift_prop_within_at, hcont, this, false_and] },
  push_neg at hcont,
  have A : continuous_within_at g (s ∩ t) x, by rwa [continuous_within_at_inter' ht],
  obtain ⟨o, o_open, xo, oc, oc', ost⟩ :
    ∃ (o : set M), is_open o ∧ x ∈ o ∧ o ⊆ (chart_at H x).source ∧
      o ∩ s ⊆ g ⁻¹' (chart_at H' (g x)).source ∧ o ∩ s ⊆ t,
  { rcases mem_nhds_within.1 ht with ⟨u, u_open, xu, ust⟩,
    have : (chart_at H' (g x)).source ∈ 𝓝 (g x) :=
      is_open.mem_nhds ((chart_at H' (g x))).open_source (mem_chart_source H' (g x)),
    rcases mem_nhds_within.1 (hcont.preimage_mem_nhds_within this) with ⟨v, v_open, xv, hv⟩,
    refine ⟨u ∩ v ∩ (chart_at H x).source, _, ⟨⟨xu, xv⟩, mem_chart_source _ _⟩, _, _, _⟩,
    { exact is_open.inter (is_open.inter u_open v_open) (chart_at H x).open_source },
    { assume y hy, exact hy.2 },
    { assume y hy, exact hv ⟨hy.1.1.2, hy.2⟩ },
    { assume y hy, exact ust ⟨hy.1.1.1, hy.2⟩ } },
  simp only [lift_prop_within_at, A, hcont, true_and, preimage_inter],
  have B : is_open ((chart_at H x).target ∩ (chart_at H x).symm⁻¹' o) :=
    (chart_at H x).preimage_open_of_open_symm o_open,
  have C : (chart_at H x) x ∈ (chart_at H x).target ∩ (chart_at H x).symm⁻¹' o,
    by simp only [xo] with mfld_simps,
  conv_lhs { rw hG.is_local B C },
  conv_rhs { rw hG.is_local B C },
  congr' 2,
  have : ∀ y, y ∈ o ∩ s → y ∈ t := ost,
  mfld_set_tac
end

lemma lift_prop_within_at_inter (ht : t ∈ 𝓝 x) :
  lift_prop_within_at P g (s ∩ t) x ↔ lift_prop_within_at P g s x :=
hG.lift_prop_within_at_inter' (mem_nhds_within_of_mem_nhds ht)

lemma lift_prop_at_of_lift_prop_within_at (h : lift_prop_within_at P g s x) (hs : s ∈ 𝓝 x) :
  lift_prop_at P g x :=
begin
  have : s = univ ∩ s, by rw univ_inter,
  rwa [this, hG.lift_prop_within_at_inter hs] at h,
end

lemma lift_prop_within_at_of_lift_prop_at_of_mem_nhds (h : lift_prop_at P g x) (hs : s ∈ 𝓝 x) :
  lift_prop_within_at P g s x :=
begin
  have : s = univ ∩ s, by rw univ_inter,
  rwa [this, hG.lift_prop_within_at_inter hs],
end

lemma lift_prop_on_of_locally_lift_prop_on
  (h : ∀x∈s, ∃u, is_open u ∧ x ∈ u ∧ lift_prop_on P g (s ∩ u)) :
  lift_prop_on P g s :=
begin
  assume x hx,
  rcases h x hx with ⟨u, u_open, xu, hu⟩,
  have := hu x ⟨hx, xu⟩,
  rwa hG.lift_prop_within_at_inter at this,
  exact is_open.mem_nhds u_open xu,
end

lemma lift_prop_of_locally_lift_prop_on
  (h : ∀x, ∃u, is_open u ∧ x ∈ u ∧ lift_prop_on P g u) :
  lift_prop P g :=
begin
  rw ← lift_prop_on_univ,
  apply hG.lift_prop_on_of_locally_lift_prop_on (λ x hx, _),
  simp [h x],
end

lemma lift_prop_within_at_congr
  (h : lift_prop_within_at P g s x) (h₁ : ∀ y ∈ s, g' y = g y) (hx : g' x = g x) :
  lift_prop_within_at P g' s x :=
begin
  refine ⟨h.1.congr h₁ hx, _⟩,
  have A : s ∩ g' ⁻¹' (chart_at H' (g' x)).source = s ∩ g ⁻¹' (chart_at H' (g' x)).source,
  { ext y,
    split,
    { assume hy,
      simp only with mfld_simps at hy,
      simp only [hy, ← h₁ _ hy.1] with mfld_simps },
    { assume hy,
      simp only with mfld_simps at hy,
      simp only [hy, h₁ _ hy.1] with mfld_simps } },
  have := h.2,
  rw [← hx, ← A] at this,
  convert hG.congr _ _ this using 2,
  { assume y hy,
    simp only with mfld_simps at hy,
    have : (chart_at H x).symm y ∈ s, by simp only [hy],
    simp only [hy, h₁ _ this] with mfld_simps },
  { simp only [hx] with mfld_simps }
end

lemma lift_prop_within_at_congr_iff (h₁ : ∀ y ∈ s, g' y = g y) (hx : g' x = g x) :
  lift_prop_within_at P g' s x ↔ lift_prop_within_at P g s x :=
⟨λ h, hG.lift_prop_within_at_congr h (λ y hy, (h₁ y hy).symm) hx.symm,
 λ h, hG.lift_prop_within_at_congr h h₁ hx⟩

lemma lift_prop_within_at_congr_of_eventually_eq
  (h : lift_prop_within_at P g s x) (h₁ : g' =ᶠ[𝓝[s] x] g) (hx : g' x = g x) :
  lift_prop_within_at P g' s x :=
begin
  rcases h₁.exists_mem with ⟨t, t_nhd, ht⟩,
  rw ← hG.lift_prop_within_at_inter' t_nhd at h ⊢,
  exact hG.lift_prop_within_at_congr h (λ y hy, ht hy.2) hx
end

lemma lift_prop_within_at_congr_iff_of_eventually_eq
  (h₁ : g' =ᶠ[𝓝[s] x] g) (hx : g' x = g x) :
  lift_prop_within_at P g' s x ↔ lift_prop_within_at P g s x :=
⟨λ h, hG.lift_prop_within_at_congr_of_eventually_eq h h₁.symm hx.symm,
 λ h, hG.lift_prop_within_at_congr_of_eventually_eq h h₁ hx⟩

lemma lift_prop_at_congr_of_eventually_eq (h : lift_prop_at P g x) (h₁ : g' =ᶠ[𝓝 x] g) :
  lift_prop_at P g' x :=
begin
  apply hG.lift_prop_within_at_congr_of_eventually_eq h _ h₁.eq_of_nhds,
  convert h₁,
  rw nhds_within_univ
end

lemma lift_prop_at_congr_iff_of_eventually_eq
  (h₁ : g' =ᶠ[𝓝 x] g) : lift_prop_at P g' x ↔ lift_prop_at P g x :=
⟨λ h, hG.lift_prop_at_congr_of_eventually_eq h h₁.symm,
 λ h, hG.lift_prop_at_congr_of_eventually_eq h h₁⟩

lemma lift_prop_on_congr (h : lift_prop_on P g s) (h₁ : ∀ y ∈ s, g' y = g y) :
  lift_prop_on P g' s :=
λ x hx, hG.lift_prop_within_at_congr (h x hx) h₁ (h₁ x hx)

lemma lift_prop_on_congr_iff (h₁ : ∀ y ∈ s, g' y = g y) :
  lift_prop_on P g' s ↔ lift_prop_on P g s :=
⟨λ h, hG.lift_prop_on_congr h (λ y hy, (h₁ y hy).symm), λ h, hG.lift_prop_on_congr h h₁⟩

omit hG

lemma lift_prop_within_at_mono
  (mono : ∀ ⦃s x t⦄ ⦃f : H → H'⦄, t ⊆ s → P f s x → P f t x)
  (h : lift_prop_within_at P g t x) (hst : s ⊆ t) :
  lift_prop_within_at P g s x :=
begin
  refine ⟨h.1.mono hst, _⟩,
  apply mono (λ y hy, _) h.2,
  simp only with mfld_simps at hy,
  simp only [hy, hst _] with mfld_simps,
end

lemma lift_prop_within_at_of_lift_prop_at
  (mono : ∀ ⦃s x t⦄ ⦃f : H → H'⦄, t ⊆ s → P f s x → P f t x) (h : lift_prop_at P g x) :
  lift_prop_within_at P g s x :=
begin
  rw ← lift_prop_within_at_univ at h,
  exact lift_prop_within_at_mono mono h (subset_univ _),
end

lemma lift_prop_on_mono (mono : ∀ ⦃s x t⦄ ⦃f : H → H'⦄, t ⊆ s → P f s x → P f t x)
  (h : lift_prop_on P g t) (hst : s ⊆ t) :
  lift_prop_on P g s :=
λ x hx, lift_prop_within_at_mono mono (h x (hst hx)) hst

lemma lift_prop_on_of_lift_prop
  (mono : ∀ ⦃s x t⦄ ⦃f : H → H'⦄, t ⊆ s → P f s x → P f t x) (h : lift_prop P g) :
  lift_prop_on P g s :=
begin
  rw ← lift_prop_on_univ at h,
  exact lift_prop_on_mono mono h (subset_univ _)
end

lemma lift_prop_at_of_mem_maximal_atlas [has_groupoid M G]
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y)
  (he : e ∈ maximal_atlas M G) (hx : x ∈ e.source) : lift_prop_at Q e x :=
begin
  suffices h : Q (e ∘ e.symm) e.target (e x),
  { rw [lift_prop_at, hG.lift_prop_within_at_indep_chart he hx G.id_mem_maximal_atlas (mem_univ _)],
    refine ⟨(e.continuous_at hx).continuous_within_at, _⟩,
    simpa only with mfld_simps },
  have A : Q id e.target (e x),
  { have : e x ∈ e.target, by simp only [hx] with mfld_simps,
    simpa only with mfld_simps using (hG.is_local e.open_target this).1 (hQ (e x)) },
  apply hG.congr _ _ A;
  simp only [hx] with mfld_simps {contextual := tt}
end

lemma lift_prop_at_symm_of_mem_maximal_atlas [has_groupoid M G] {x : H}
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y)
  (he : e ∈ maximal_atlas M G) (hx : x ∈ e.target) : lift_prop_at Q e.symm x :=
begin
  suffices h : Q (e ∘ e.symm) e.target x,
  { have A : e.symm ⁻¹' e.source ∩ e.target = e.target,
      by mfld_set_tac,
    have : e.symm x ∈ e.source, by simp only [hx] with mfld_simps,
    rw [lift_prop_at,
      hG.lift_prop_within_at_indep_chart G.id_mem_maximal_atlas (mem_univ _) he this],
    refine ⟨(e.symm.continuous_at hx).continuous_within_at, _⟩,
    simp only with mfld_simps,
    rwa [hG.is_local e.open_target hx, A] },
  have A : Q id e.target x,
    by simpa only with mfld_simps using (hG.is_local e.open_target hx).1 (hQ x),
  apply hG.congr _ _ A;
  simp only [hx] with mfld_simps {contextual := tt}
end

lemma lift_prop_on_symm_of_mem_maximal_atlas [has_groupoid M G]
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y) (he : e ∈ maximal_atlas M G) :
  lift_prop_on Q e.symm e.target :=
begin
  assume x hx,
  apply hG.lift_prop_within_at_of_lift_prop_at_of_mem_nhds
    (hG.lift_prop_at_symm_of_mem_maximal_atlas hQ he hx),
  apply is_open.mem_nhds e.open_target hx,
end

lemma lift_prop_at_chart [has_groupoid M G]
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y) : lift_prop_at Q (chart_at H x) x :=
hG.lift_prop_at_of_mem_maximal_atlas hQ (chart_mem_maximal_atlas G x) (mem_chart_source H x)

lemma lift_prop_on_chart [has_groupoid M G]
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y) :
  lift_prop_on Q (chart_at H x) (chart_at H x).source :=
hG.lift_prop_on_of_mem_maximal_atlas hQ (chart_mem_maximal_atlas G x)

lemma lift_prop_at_chart_symm [has_groupoid M G]
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y) :
  lift_prop_at Q (chart_at H x).symm ((chart_at H x) x) :=
hG.lift_prop_at_symm_of_mem_maximal_atlas hQ (chart_mem_maximal_atlas G x) (by simp)

lemma lift_prop_on_chart_symm [has_groupoid M G]
  (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y) :
  lift_prop_on Q (chart_at H x).symm (chart_at H x).target :=
hG.lift_prop_on_symm_of_mem_maximal_atlas hQ (chart_mem_maximal_atlas G x)

lemma lift_prop_id (hG : G.local_invariant_prop G Q) (hQ : ∀ y, Q id univ y) :
  lift_prop Q (id : M → M) :=
begin
  assume x,
  dsimp [lift_prop_at, lift_prop_within_at],
  refine ⟨continuous_within_at_id, _⟩,
  let t := ((chart_at H x).target ∩ (chart_at H x).symm ⁻¹' (chart_at H x).source),
  suffices H : Q id t ((chart_at H x) x),
  { simp only with mfld_simps,
    refine hG.congr (λ y hy, _) (by simp) H,
    simp only with mfld_simps at hy,
    simp only [hy] with mfld_simps },
  have : t = univ ∩ (chart_at H x).target, by mfld_set_tac,
  rw this,
  exact (hG.is_local (chart_at H x).open_target (by simp)).1 (hQ _)
end

end local_invariant_prop

section local_structomorph

variables (G)
open local_homeomorph

/-- A function from a model space `H` to itself is a local structomorphism, with respect to a
structure groupoid `G` for `H`, relative to a set `s` in `H`, if for all points `x` in the set, the
function agrees with a `G`-structomorphism on `s` in a neighbourhood of `x`. -/
def is_local_structomorph_within_at (f : H → H) (s : set H) (x : H) : Prop :=
(x ∈ s) → ∃ (e : local_homeomorph H H), e ∈ G ∧ eq_on f e.to_fun (s ∩ e.source) ∧ x ∈ e.source

/-- For a groupoid `G` which is `closed_under_restriction`, being a local structomorphism is a local
invariant property. -/
lemma is_local_structomorph_within_at_local_invariant_prop [closed_under_restriction G] :
  local_invariant_prop G G (is_local_structomorph_within_at G) :=
{ is_local := begin
    intros s x u f hu hux,
    split,
    { rintros h hx,
      rcases h hx.1 with ⟨e, heG, hef, hex⟩,
      have : s ∩ u ∩ e.source ⊆ s ∩ e.source := by mfld_set_tac,
      exact ⟨e, heG, hef.mono this, hex⟩ },
    { rintros h hx,
      rcases h ⟨hx, hux⟩ with ⟨e, heG, hef, hex⟩,
      refine ⟨e.restr (interior u), _, _, _⟩,
      { exact closed_under_restriction' heG (is_open_interior) },
      { have : s ∩ u ∩ e.source = s ∩ (e.source ∩ u) := by mfld_set_tac,
        simpa only [this, interior_interior, hu.interior_eq] with mfld_simps using hef },
      { simp only [*, interior_interior, hu.interior_eq] with mfld_simps } }
  end,
  right_invariance := begin
    intros s x f e' he'G he'x h hx,
    have hxs : x ∈ s := by simpa only [e'.left_inv he'x] with mfld_simps using hx.2,
    rcases h hxs with ⟨e, heG, hef, hex⟩,
    refine ⟨e'.symm.trans e, G.trans (G.symm he'G) heG, _, _⟩,
    { intros y hy,
      simp only with mfld_simps at hy,
      simp only [hef ⟨hy.1.2, hy.2.2⟩] with mfld_simps },
    { simp only [hex, he'x] with mfld_simps }
  end,
  congr := begin
    intros s x f g hfgs hfg' h hx,
    rcases h hx with ⟨e, heG, hef, hex⟩,
    refine ⟨e, heG, _, hex⟩,
    intros y hy,
    rw [← hef hy, hfgs y hy.1]
  end,
  left_invariance := begin
    intros s x f e' he'G he' hfx h hx,
    rcases h hx with ⟨e, heG, hef, hex⟩,
    refine ⟨e.trans e', G.trans heG he'G, _, _⟩,
    { intros y hy,
      simp only with mfld_simps at hy,
      simp only [hef ⟨hy.1, hy.2.1⟩] with mfld_simps },
    { simpa only [hex, hef ⟨hx, hex⟩] with mfld_simps using hfx }
  end }

end local_structomorph

end structure_groupoid


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
universes u
/--
A difference list is a function that, given a list, returns the original
contents of the difference list prepended to the given list.

This structure supports `O(1)` `append` and `concat` operations on lists, making it
useful for append-heavy uses such as logging and pretty printing.
-/
structure dlist (α : Type u) :=
(apply     : list α → list α)
(invariant : ∀ l, apply l = apply [] ++ l)

namespace dlist
open function
variables {α : Type u}

local notation `♯`:max := by abstract { intros, simp }

/-- Convert a list to a dlist -/
def of_list (l : list α) : dlist α :=
⟨append l, ♯⟩

/-- Convert a lazily-evaluated list to a dlist -/
def lazy_of_list (l : thunk (list α)) : dlist α :=
⟨λ xs, l () ++ xs, ♯⟩

/-- Convert a dlist to a list -/
def to_list : dlist α → list α
| ⟨xs, _⟩ := xs []

/--  Create a dlist containing no elements -/
def empty : dlist α :=
⟨id, ♯⟩

local notation a `::_`:max := list.cons a

/-- Create dlist with a single element -/
def singleton (x : α) : dlist α :=
⟨x::_, ♯⟩

local attribute [simp] function.comp

/-- `O(1)` Prepend a single element to a dlist -/
def cons (x : α) : dlist α →  dlist α
| ⟨xs, h⟩ := ⟨x::_ ∘ xs, by abstract { intros, simp, rw [←h] }⟩

/-- `O(1)` Append a single element to a dlist -/
def concat (x : α) : dlist α → dlist α
| ⟨xs, h⟩ := ⟨xs ∘ x::_, by abstract { intros, simp, rw [h, h [x]], simp }⟩

/-- `O(1)` Append dlists -/
protected def append : dlist α → dlist α → dlist α
| ⟨xs, h₁⟩ ⟨ys, h₂⟩ := ⟨xs ∘ ys, by { intros, simp, rw [h₂, h₁, h₁ (ys list.nil)], simp } ⟩

instance : has_append (dlist α) :=
⟨dlist.append⟩

local attribute [simp] of_list to_list empty singleton cons concat dlist.append

lemma to_list_of_list (l : list α) : to_list (of_list l) = l :=
by cases l; simp

lemma of_list_to_list (l : dlist α) : of_list (to_list l) = l :=
begin
   cases l with xs,
   have h : append (xs []) = xs,
   { intros, funext x, simp [l_invariant x] },
   simp [h]
end

lemma to_list_empty : to_list (@empty α) = [] :=
by simp

lemma to_list_singleton (x : α) : to_list (singleton x) = [x] :=
by simp

lemma to_list_append (l₁ l₂ : dlist α) : to_list (l₁ ++ l₂) = to_list l₁ ++ to_list l₂ :=
show to_list (dlist.append l₁ l₂) = to_list l₁ ++ to_list l₂, from
by cases l₁; cases l₂; simp; rw l₁_invariant

lemma to_list_cons (x : α) (l : dlist α) : to_list (cons x l) = x :: to_list l :=
by cases l; simp

lemma to_list_concat (x : α) (l : dlist α) : to_list (concat x l) = to_list l ++ [x] :=
by cases l; simp; rw [l_invariant]

end dlist


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

import order.category.PartialOrder

/-!
# Category of linear orders

This defines `LinearOrder`, the category of linear orders with monotone maps.
-/

open category_theory

universe u

/-- The category of linear orders. -/
def LinearOrder := bundled linear_order

namespace LinearOrder

instance : bundled_hom.parent_projection @linear_order.to_partial_order := ⟨⟩

attribute [derive [large_category, concrete_category]] LinearOrder

instance : has_coe_to_sort LinearOrder Type* := bundled.has_coe_to_sort

/-- Construct a bundled `LinearOrder` from the underlying type and typeclass. -/
def of (α : Type*) [linear_order α] : LinearOrder := bundled.of α

instance : inhabited LinearOrder := ⟨of punit⟩

instance (α : LinearOrder) : linear_order α := α.str

instance has_forget_to_PartialOrder : has_forget₂ LinearOrder PartialOrder :=
bundled_hom.forget₂ _ _

/-- Constructs an equivalence between linear orders from an order isomorphism between them. -/
@[simps] def iso.mk {α β : LinearOrder.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply x },
  inv_hom_id' := by { ext, exact e.apply_symm_apply x } }

/-- `order_dual` as a functor. -/
@[simps] def to_dual : LinearOrder ⥤ LinearOrder :=
{ obj := λ X, of (order_dual X), map := λ X Y, order_hom.dual }

/-- The equivalence between `PartialOrder` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : LinearOrder ≌ LinearOrder :=
equivalence.mk to_dual to_dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end LinearOrder

lemma LinearOrder_dual_equiv_comp_forget_to_PartialOrder :
  LinearOrder.dual_equiv.functor ⋙ forget₂ LinearOrder PartialOrder
  = forget₂ LinearOrder PartialOrder ⋙ PartialOrder.dual_equiv.functor := rfl


example (p q : Prop) (hp : p) : p ∨ q :=
  by { left, assumption } <|> { right, assumption }

example (p q : Prop) (hq : q) : p ∨ q :=
  by { left, assumption } <|> { right, assumption }


/-
Copyright (c) 2021 Ashvni Narayanan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ashvni Narayanan
-/
import dirichlet_character.basic
import zmod.properties
import analysis.normed_space.basic
import topology.algebra.group
import topology.continuous_function.compact
import nat_properties

/-!
# Dirichlet characters
This file defines properties of Dirichlet characters.

# Main Definitions
 * `lev` : The level of a Dirichlet character
 * `bound` : The bound of the norm of a Dirichlet character

## Tags
p-adic, L-function, Bernoulli measure, Dirichlet character
-/

local attribute [instance] zmod.topological_space
open_locale big_operators

namespace dirichlet_character
lemma continuous {R : Type*} [monoid R] [topological_space R]
  {n : ℕ} (χ : dirichlet_character R n) : continuous χ := continuous_of_discrete_topology

open dirichlet_character
lemma asso_dirichlet_character_continuous {R : Type*} [monoid_with_zero R] [topological_space R]
  {n : ℕ} (χ : dirichlet_character R n) : _root_.continuous (asso_dirichlet_character χ) :=
begin
  convert continuous_of_discrete_topology,
  apply_instance,
end

lemma asso_dirichlet_character_bounded {R : Type*} [monoid_with_zero R]
  [normed_group R] {n : ℕ} [fact (0 < n)] (χ : dirichlet_character R n) : ∃ M : ℝ,
  ∥ (⟨asso_dirichlet_character χ,
    dirichlet_character.asso_dirichlet_character_continuous χ⟩ : C(zmod n, R)) ∥ < M :=
begin
  refine ⟨(⨆ i : zmod n, ∥asso_dirichlet_character χ i∥) + 1, _⟩,
  apply lt_of_le_of_lt _ (lt_add_one _),
  { convert le_refl _,
    rw continuous_map.norm_eq_supr_norm,
    simp only [continuous_map.coe_mk], },
  { apply_instance, },
end

lemma asso_dirichlet_character_zero_range {R : Type*} [monoid_with_zero R] [normed_group R]
  (χ : dirichlet_character R 0) : (set.range (λ (i : zmod 0), ∥(asso_dirichlet_character χ) i∥)) =
    {∥asso_dirichlet_character χ 0∥, ∥asso_dirichlet_character χ 1∥,
      ∥asso_dirichlet_character χ (-1)∥} :=
begin
  ext,
  simp only [set.mem_insert_iff, set.mem_range, set.mem_singleton_iff],
  refine ⟨λ h, _, λ h, _⟩,
  { cases h with y hy,
    by_cases is_unit y,
    { suffices h' : y = 1 ∨ y = -1,
      { cases h',
        { rw h' at hy,
          right, left, rw ←hy, },
        { rw h' at hy,
          right, right, rw hy, }, },
      { apply int.is_unit_eq_one_or h, }, },
    rw asso_dirichlet_character_eq_zero _ h at hy,
    left, rw ←hy,
    rw asso_dirichlet_character_eq_zero _,
    apply @not_is_unit_zero _ _ infer_instance,
    change nontrivial ℤ, apply_instance, },
  { cases h,
    { refine ⟨0, _⟩, rw h, },
    { cases h,
      { rw h, refine ⟨1, rfl⟩, },
      { rw h, refine ⟨-1, rfl⟩, }, }, },
end

lemma asso_dirichlet_character_zero_range_fin {R : Type*} [monoid_with_zero R] [normed_group R]
  (χ : dirichlet_character R 0) :
  (set.range (λ (i : zmod 0), ∥(asso_dirichlet_character χ) i∥)).finite :=
begin
  rw asso_dirichlet_character_zero_range,
  simp only [set.finite_singleton, set.finite.insert],
end

lemma asso_dirichlet_character_range_fin {R : Type*} [monoid_with_zero R] [normed_group R] {n : ℕ}
  (χ : dirichlet_character R n) :
  (set.range (λ (i : zmod n), ∥(asso_dirichlet_character χ) i∥)).finite :=
begin
  cases n, -- big improvement over by_cases n!
  { apply asso_dirichlet_character_zero_range_fin _, },
  { haveI : fact (0 < n.succ) := fact_iff.2 (nat.succ_pos _),
    exact set.finite_range (λ (i : zmod n.succ), ∥(asso_dirichlet_character χ) i∥), },
end

lemma asso_dirichlet_character_range_bdd_above {R : Type*} [monoid_with_zero R] [normed_group R]
  {n : ℕ} (χ : dirichlet_character R n) :
  bdd_above (set.range (λ (i : zmod n), ∥(asso_dirichlet_character χ) i∥)) :=
set.finite.bdd_above (asso_dirichlet_character_range_fin _)

lemma asso_dirichlet_character_bounded_spec {R : Type*} [monoid_with_zero R] [normed_group R]
  {n : ℕ} (χ : dirichlet_character R n) :
  ∃ M : ℝ, (∀ a, ∥asso_dirichlet_character χ a∥ < M) ∧ 0 < M :=
begin
  refine ⟨(⨆ i : zmod n, ∥asso_dirichlet_character χ i∥) + 1, λ a, lt_of_le_of_lt _
    (lt_add_one _), (lt_add_of_le_of_pos _ _)⟩,
  { apply le_cSup (asso_dirichlet_character_range_bdd_above _) (⟨a, rfl⟩), },
  { apply le_csupr_of_le _ _,
    swap 3, { exact 1, },
    { apply norm_nonneg _, },
    { apply asso_dirichlet_character_range_bdd_above, }, },
  { norm_num, },
end

/-- Every Dirichlet character is bounded above. -/
noncomputable abbreviation bound {R : Type*} [monoid_with_zero R] [normed_group R] {n : ℕ}
  (χ : dirichlet_character R n) : ℝ :=
classical.some (dirichlet_character.asso_dirichlet_character_bounded_spec χ)

lemma lt_bound {R : Type*} [monoid_with_zero R] [normed_group R] {n : ℕ}
  (χ : dirichlet_character R n) (a : zmod n) :
  ∥asso_dirichlet_character χ a∥ < dirichlet_character.bound χ :=
(classical.some_spec (dirichlet_character.asso_dirichlet_character_bounded_spec χ)).1 a

lemma bound_pos {R : Type*} [monoid_with_zero R] [normed_group R] {n : ℕ}
  (χ : dirichlet_character R n) : 0 < dirichlet_character.bound χ :=
(classical.some_spec (dirichlet_character.asso_dirichlet_character_bounded_spec χ)).2

open zmod
lemma mul_eval_of_coprime {R : Type*} [comm_monoid_with_zero R] {n m : ℕ}
  (χ : dirichlet_character R n) (ψ : dirichlet_character R m) {a : ℕ} (ha : a.coprime (n * m)) :
  asso_dirichlet_character (dirichlet_character.mul χ ψ) a =
  asso_dirichlet_character χ a * (asso_dirichlet_character ψ a) :=
begin
  rw [mul, ←(zmod.cast_nat_cast (conductor.dvd_lev (change_level (dvd_lcm_left n m) χ *
    change_level (dvd_lcm_right n m) ψ)) a)],
  { have dvd : lcm n m ∣ n * m := lcm_dvd_iff.2 ⟨(dvd_mul_right _ _), (dvd_mul_left _ _)⟩,
    have := zmod.is_unit_of_is_coprime_dvd dvd ha,
    rw ←change_level.asso_dirichlet_character_eq' _ (conductor.dvd_lev _) this,
    delta asso_primitive_character,
    rw [←(factors_through.spec _ (conductor.factors_through (change_level _ χ * change_level _ ψ))),
      asso_dirichlet_character_mul, monoid_hom.mul_apply, change_level.asso_dirichlet_character_eq'
      _ _ this, change_level.asso_dirichlet_character_eq' _ _ this, zmod.cast_nat_cast
      (dvd_lcm_left n m), zmod.cast_nat_cast (dvd_lcm_right n m)],
    any_goals { refine zmod.char_p _, }, },
  { refine zmod.char_p _, },
end

namespace asso_dirichlet_character
lemma eval_mul_sub {R : Type*} [monoid_with_zero R] {n : ℕ} (χ : dirichlet_character R n)
  (k x : ℕ) : asso_dirichlet_character χ (k * n - x) = asso_dirichlet_character χ (-1) *
  (asso_dirichlet_character χ x) :=
by { rw [zmod.nat_cast_self, mul_zero, zero_sub, neg_eq_neg_one_mul, monoid_hom.map_mul], }

lemma eval_mul_sub' {R : Type*} [monoid_with_zero R] {n k : ℕ} (χ : dirichlet_character R n)
  (hk : n ∣ k) (x : ℕ) : asso_dirichlet_character χ (k - x) = asso_dirichlet_character χ (-1) *
  (asso_dirichlet_character χ x) :=
begin
  have : (k : zmod n) = 0,
  { rw [←zmod.nat_cast_mod, nat.mod_eq_zero_of_dvd hk, nat.cast_zero], },
  rw [this, zero_sub, neg_eq_neg_one_mul, monoid_hom.map_mul],
end

--`asso_dirichlet_character_equiv` changed to `asso_dirichlet_character.asso_primitive_character`
lemma asso_primitive_character {S : Type*} [comm_monoid_with_zero S] {m : ℕ}
  (ψ : dirichlet_character S m) (h : is_primitive ψ) (a : ℕ) :
  asso_dirichlet_character ψ.asso_primitive_character a = asso_dirichlet_character ψ a :=
begin
  by_cases h' : is_unit (a : zmod m),
  { conv_rhs { rw factors_through.spec ψ (conductor.factors_through ψ), },
    rw change_level.asso_dirichlet_character_eq' _ _ h',
    apply congr,
    { congr, },
    { rw zmod.cast_nat_cast _,
      swap, { refine zmod.char_p _, },
      { apply conductor.dvd_lev _, }, }, },
  { repeat { rw asso_dirichlet_character_eq_zero, },
    { assumption, },
    rw (is_primitive_def _).1 h, apply h', },
end
end asso_dirichlet_character

/-- The level at which the Dirichlet character is defined. -/
abbreviation lev {R : Type*} [monoid R] {n : ℕ} (χ : dirichlet_character R n) : ℕ := n
-- dont know how to remove this linting error

lemma lev_mul_dvd_lcm {R : Type*} [comm_monoid_with_zero R] {n k : ℕ} (χ : dirichlet_character R n)
  (ψ : dirichlet_character R k) : lev (mul χ ψ) ∣ lcm n k := dvd_trans (conductor.dvd_lev _) dvd_rfl

lemma lev_mul_dvd_mul_lev {R : Type*} [comm_monoid_with_zero R] {n k : ℕ} (χ : dirichlet_character R n)
  (ψ : dirichlet_character R k) : lev (mul χ ψ) ∣ n * k :=
dvd_trans (conductor.dvd_lev _) (nat.lcm_dvd_mul _ _)

open dirichlet_character
lemma mul_eval_neg_one {R : Type*} [comm_monoid_with_zero R] {n m : ℕ} [fact (0 < n)] [fact (0 < m)]
  (χ : dirichlet_character R n) (ψ : dirichlet_character R m) :
  asso_dirichlet_character (dirichlet_character.mul χ ψ) (-1 : ℤ) =
  asso_dirichlet_character χ (-1) * asso_dirichlet_character ψ (-1) :=
begin
  have one_le : 1 ≤ n * m := nat.succ_le_iff.2 (nat.mul_pos (fact.out _) (fact.out _)),
  have f1 : (-1 : zmod (lev (χ.mul ψ))) = ↑((n * m - 1) : ℕ),
  { rw [nat.cast_sub one_le, (zmod.nat_coe_zmod_eq_zero_iff_dvd _ _).2 (dvd_trans (conductor.dvd_lev _)
      (lcm_dvd (dvd_mul_right _ _) (dvd_mul_left _ _))), zero_sub, nat.cast_one], },
  rw [int.cast_neg, int.cast_one, f1,
    mul_eval_of_coprime _ _ (nat.coprime_sub (nat.coprime_one_right _) one_le)],
  simp only [nat.cast_sub one_le, nat.cast_sub one_le, nat.cast_mul, zmod.nat_cast_self, zero_mul,
    nat.cast_one, zero_sub, mul_zero],
end

lemma mul_eval_int {R : Type*} [comm_monoid_with_zero R] {n m : ℕ} [fact (0 < n)] [fact (0 < m)]
  (χ : dirichlet_character R n) (ψ : dirichlet_character R m) {a : ℤ}
  (ha : is_coprime a (n * m : ℤ)) : asso_dirichlet_character (dirichlet_character.mul χ ψ) a =
  asso_dirichlet_character χ a * asso_dirichlet_character ψ a :=
begin
  cases a,
  { change asso_dirichlet_character (dirichlet_character.mul χ ψ) a =
      asso_dirichlet_character χ a * asso_dirichlet_character ψ a,
    rw mul_eval_of_coprime χ ψ (nat.is_coprime_iff_coprime.1 ha), },
  { rw [int.neg_succ_of_nat_coe, ←neg_one_mul, int.cast_mul, monoid_hom.map_mul, mul_eval_neg_one],
    rw [int.neg_succ_of_nat_coe, is_coprime.neg_left_iff] at ha,
    rw [int.cast_coe_nat, mul_eval_of_coprime χ ψ (nat.is_coprime_iff_coprime.1 ha),
      mul_mul_mul_comm],
    simp_rw [←monoid_hom.map_mul, int.cast_mul],
    norm_cast, },
end

instance {R : Type*} [comm_monoid_with_zero R] {n : ℕ} : has_pow (dirichlet_character R n) ℕ :=
monoid.has_pow

lemma pow_apply {R : Type*} [comm_monoid_with_zero R] {n : ℕ} (k : ℕ)
  (χ : dirichlet_character R n) (a : (zmod n)ˣ) :
  ((χ: monoid_hom (units (zmod n)) (units R))^k) a = (χ a)^k := rfl
end dirichlet_character


variables (f : ℕ → ℕ) (a : ℕ)

example (h : a + 0 = 0) : f a = f 0 :=
  by { rw add_zero at h, rw h }


example (P Q : Prop) (p : P) (h : P → Q) : Q :=
begin
    exact h(p),
end


/-
Copyright (c) 2022 Yakov Pechersky. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Kenny Lau, Johan Commelin, Mario Carneiro, Kevin Buzzard,
Amelia Livingston, Yury Kudryashov, Yakov Pechersky, Jireh Loreaux
-/
import group_theory.subsemigroup.basic
import algebra.group.prod
import algebra.group.type_tags

/-!
# Operations on `subsemigroup`s

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

In this file we define various operations on `subsemigroup`s and `mul_hom`s.

## Main definitions

### Conversion between multiplicative and additive definitions

* `subsemigroup.to_add_subsemigroup`, `subsemigroup.to_add_subsemigroup'`,
  `add_subsemigroup.to_subsemigroup`, `add_subsemigroup.to_subsemigroup'`:
  convert between multiplicative and additive subsemigroups of `M`,
  `multiplicative M`, and `additive M`. These are stated as `order_iso`s.

### (Commutative) semigroup structure on a subsemigroup

* `subsemigroup.to_semigroup`, `subsemigroup.to_comm_semigroup`: a subsemigroup inherits a
  (commutative) semigroup structure.

### Operations on subsemigroups

* `subsemigroup.comap`: preimage of a subsemigroup under a semigroup homomorphism as a subsemigroup
  of the domain;
* `subsemigroup.map`: image of a subsemigroup under a semigroup homomorphism as a subsemigroup of
  the codomain;
* `subsemigroup.prod`: product of two subsemigroups `s : subsemigroup M` and `t : subsemigroup N`
  as a subsemigroup of `M × N`;

### Semigroup homomorphisms between subsemigroups

* `subsemigroup.subtype`: embedding of a subsemigroup into the ambient semigroup.
* `subsemigroup.inclusion`: given two subsemigroups `S`, `T` such that `S ≤ T`, `S.inclusion T` is
  the inclusion of `S` into `T` as a semigroup homomorphism;
* `mul_equiv.subsemigroup_congr`: converts a proof of `S = T` into a semigroup isomorphism between
  `S` and `T`.
* `subsemigroup.prod_equiv`: semigroup isomorphism between `s.prod t` and `s × t`;

### Operations on `mul_hom`s

* `mul_hom.srange`: range of a semigroup homomorphism as a subsemigroup of the codomain;
* `mul_hom.restrict`: restrict a semigroup homomorphism to a subsemigroup;
* `mul_hom.cod_restrict`: restrict the codomain of a semigroup homomorphism to a subsemigroup;
* `mul_hom.srange_restrict`: restrict a semigroup homomorphism to its range;

### Implementation notes

This file follows closely `group_theory/submonoid/operations.lean`, omitting only that which is
necessary.

## Tags

subsemigroup, range, product, map, comap
-/

variables {M N P σ : Type*}

/-!
### Conversion to/from `additive`/`multiplicative`
-/

section

variables [has_mul M]

/-- Subsemigroups of semigroup `M` are isomorphic to additive subsemigroups of `additive M`. -/
@[simps]
def subsemigroup.to_add_subsemigroup : subsemigroup M ≃o add_subsemigroup (additive M) :=
{ to_fun := λ S,
  { carrier := additive.to_mul ⁻¹' S,
    add_mem' := λ _ _, S.mul_mem' },
  inv_fun := λ S,
  { carrier := additive.of_mul ⁻¹' S,
    mul_mem' := λ _ _, S.add_mem' },
  left_inv := λ x, by cases x; refl,
  right_inv := λ x, by cases x; refl,
  map_rel_iff' := λ a b, iff.rfl, }

/-- Additive subsemigroups of an additive semigroup `additive M` are isomorphic to subsemigroups
of `M`. -/
abbreviation add_subsemigroup.to_subsemigroup' : add_subsemigroup (additive M) ≃o subsemigroup M :=
subsemigroup.to_add_subsemigroup.symm

lemma subsemigroup.to_add_subsemigroup_closure (S : set M) :
  (subsemigroup.closure S).to_add_subsemigroup = add_subsemigroup.closure (additive.to_mul ⁻¹' S) :=
le_antisymm
  (subsemigroup.to_add_subsemigroup.le_symm_apply.1 $
    subsemigroup.closure_le.2 add_subsemigroup.subset_closure)
  (add_subsemigroup.closure_le.2 subsemigroup.subset_closure)

lemma add_subsemigroup.to_subsemigroup'_closure (S : set (additive M)) :
  (add_subsemigroup.closure S).to_subsemigroup' =
    subsemigroup.closure (multiplicative.of_add ⁻¹' S) :=
le_antisymm
  (add_subsemigroup.to_subsemigroup'.le_symm_apply.1 $
    add_subsemigroup.closure_le.2 subsemigroup.subset_closure)
  (subsemigroup.closure_le.2 add_subsemigroup.subset_closure)

end

section

variables {A : Type*} [has_add A]

/-- Additive subsemigroups of an additive semigroup `A` are isomorphic to
multiplicative subsemigroups of `multiplicative A`. -/
@[simps]
def add_subsemigroup.to_subsemigroup : add_subsemigroup A ≃o subsemigroup (multiplicative A) :=
{ to_fun := λ S,
  { carrier := multiplicative.to_add ⁻¹' S,
    mul_mem' := λ _ _, S.add_mem' },
  inv_fun := λ S,
  { carrier := multiplicative.of_add ⁻¹' S,
    add_mem' := λ _ _, S.mul_mem' },
  left_inv := λ x, by cases x; refl,
  right_inv := λ x, by cases x; refl,
  map_rel_iff' := λ a b, iff.rfl, }

/-- Subsemigroups of a semigroup `multiplicative A` are isomorphic to additive subsemigroups
of `A`. -/
abbreviation subsemigroup.to_add_subsemigroup' :
  subsemigroup (multiplicative A) ≃o add_subsemigroup A :=
add_subsemigroup.to_subsemigroup.symm

lemma add_subsemigroup.to_subsemigroup_closure (S : set A) :
  (add_subsemigroup.closure S).to_subsemigroup =
    subsemigroup.closure (multiplicative.to_add ⁻¹' S) :=
le_antisymm
  (add_subsemigroup.to_subsemigroup.to_galois_connection.l_le $
    add_subsemigroup.closure_le.2 subsemigroup.subset_closure)
  (subsemigroup.closure_le.2 add_subsemigroup.subset_closure)

lemma subsemigroup.to_add_subsemigroup'_closure (S : set (multiplicative A)) :
  (subsemigroup.closure S).to_add_subsemigroup' =
    add_subsemigroup.closure (additive.of_mul ⁻¹' S) :=
le_antisymm
  (subsemigroup.to_add_subsemigroup'.to_galois_connection.l_le $
    subsemigroup.closure_le.2 add_subsemigroup.subset_closure)
  (add_subsemigroup.closure_le.2 subsemigroup.subset_closure)

end

namespace subsemigroup

open set

/-!
### `comap` and `map`
-/

variables [has_mul M] [has_mul N] [has_mul P] (S : subsemigroup M)

/-- The preimage of a subsemigroup along a semigroup homomorphism is a subsemigroup. -/
@[to_additive "The preimage of an `add_subsemigroup` along an `add_semigroup` homomorphism is an
`add_subsemigroup`."]
def comap (f : M →ₙ* N) (S : subsemigroup N) : subsemigroup M :=
{ carrier := (f ⁻¹' S),
  mul_mem' := λ a b ha hb,
    show f (a * b) ∈ S, by rw map_mul; exact mul_mem ha hb }

@[simp, to_additive]
lemma coe_comap (S : subsemigroup N) (f : M →ₙ* N) : (S.comap f : set M) = f ⁻¹' S := rfl

@[simp, to_additive]
lemma mem_comap {S : subsemigroup N} {f : M →ₙ* N} {x : M} : x ∈ S.comap f ↔ f x ∈ S := iff.rfl

@[to_additive]
lemma comap_comap (S : subsemigroup P) (g : N →ₙ* P) (f : M →ₙ* N) :
  (S.comap g).comap f = S.comap (g.comp f) :=
rfl

@[simp, to_additive]
lemma comap_id (S : subsemigroup P) : S.comap (mul_hom.id _) = S :=
ext (by simp)

/-- The image of a subsemigroup along a semigroup homomorphism is a subsemigroup. -/
@[to_additive "The image of an `add_subsemigroup` along an `add_semigroup` homomorphism is
an `add_subsemigroup`."]
def map (f : M →ₙ* N) (S : subsemigroup M) : subsemigroup N :=
{ carrier := (f '' S),
  mul_mem' := begin rintros _ _ ⟨x, hx, rfl⟩ ⟨y, hy, rfl⟩,
    exact ⟨x * y, @mul_mem (subsemigroup M) M _ _ _ _ _ _ hx hy, by rw map_mul; refl⟩ end }

@[simp, to_additive]
lemma coe_map (f : M →ₙ* N) (S : subsemigroup M) :
  (S.map f : set N) = f '' S := rfl

@[simp, to_additive]
lemma mem_map {f : M →ₙ* N} {S : subsemigroup M} {y : N} :
  y ∈ S.map f ↔ ∃ x ∈ S, f x = y :=
mem_image_iff_bex

@[to_additive]
lemma mem_map_of_mem (f : M →ₙ* N) {S : subsemigroup M} {x : M} (hx : x ∈ S) : f x ∈ S.map f :=
mem_image_of_mem f hx

@[to_additive]
lemma apply_coe_mem_map (f : M →ₙ* N) (S : subsemigroup M) (x : S) : f x ∈ S.map f :=
mem_map_of_mem f x.prop

@[to_additive]
lemma map_map (g : N →ₙ* P) (f : M →ₙ* N) : (S.map f).map g = S.map (g.comp f) :=
set_like.coe_injective $ image_image _ _ _

@[to_additive]
lemma mem_map_iff_mem {f : M →ₙ* N} (hf : function.injective f) {S : subsemigroup M} {x : M} :
  f x ∈ S.map f ↔ x ∈ S :=
hf.mem_set_image

@[to_additive]
lemma map_le_iff_le_comap {f : M →ₙ* N} {S : subsemigroup M} {T : subsemigroup N} :
  S.map f ≤ T ↔ S ≤ T.comap f :=
image_subset_iff

@[to_additive]
lemma gc_map_comap (f : M →ₙ* N) : galois_connection (map f) (comap f) :=
λ S T, map_le_iff_le_comap

@[to_additive]
lemma map_le_of_le_comap {T : subsemigroup N} {f : M →ₙ* N} : S ≤ T.comap f → S.map f ≤ T :=
(gc_map_comap f).l_le

@[to_additive]
lemma le_comap_of_map_le {T : subsemigroup N} {f : M →ₙ* N} : S.map f ≤ T → S ≤ T.comap f :=
(gc_map_comap f).le_u

@[to_additive]
lemma le_comap_map {f : M →ₙ* N} : S ≤ (S.map f).comap f :=
(gc_map_comap f).le_u_l _

@[to_additive]
lemma map_comap_le {S : subsemigroup N} {f : M →ₙ* N} : (S.comap f).map f ≤ S :=
(gc_map_comap f).l_u_le _

@[to_additive]
lemma monotone_map {f : M →ₙ* N} : monotone (map f) :=
(gc_map_comap f).monotone_l

@[to_additive]
lemma monotone_comap {f : M →ₙ* N} : monotone (comap f) :=
(gc_map_comap f).monotone_u

@[simp, to_additive]
lemma map_comap_map {f : M →ₙ* N} : ((S.map f).comap f).map f = S.map f :=
(gc_map_comap f).l_u_l_eq_l _

@[simp, to_additive]
lemma comap_map_comap {S : subsemigroup N} {f : M →ₙ* N} :
  ((S.comap f).map f).comap f = S.comap f :=
(gc_map_comap f).u_l_u_eq_u _

@[to_additive]
lemma map_sup (S T : subsemigroup M) (f : M →ₙ* N) : (S ⊔ T).map f = S.map f ⊔ T.map f :=
(gc_map_comap f).l_sup

@[to_additive]
lemma map_supr {ι : Sort*} (f : M →ₙ* N) (s : ι → subsemigroup M) :
  (supr s).map f = ⨆ i, (s i).map f :=
(gc_map_comap f).l_supr

@[to_additive]
lemma comap_inf (S T : subsemigroup N) (f : M →ₙ* N) : (S ⊓ T).comap f = S.comap f ⊓ T.comap f :=
(gc_map_comap f).u_inf

@[to_additive]
lemma comap_infi {ι : Sort*} (f : M →ₙ* N) (s : ι → subsemigroup N) :
  (infi s).comap f = ⨅ i, (s i).comap f :=
(gc_map_comap f).u_infi

@[simp, to_additive] lemma map_bot (f : M →ₙ* N) : (⊥ : subsemigroup M).map f = ⊥ :=
(gc_map_comap f).l_bot

@[simp, to_additive] lemma comap_top (f : M →ₙ* N) : (⊤ : subsemigroup N).comap f = ⊤ :=
(gc_map_comap f).u_top

@[simp, to_additive] lemma map_id (S : subsemigroup M) : S.map (mul_hom.id M) = S :=
ext (λ x, ⟨λ ⟨_, h, rfl⟩, h, λ h, ⟨_, h, rfl⟩⟩)

section galois_coinsertion

variables {ι : Type*} {f : M →ₙ* N} (hf : function.injective f)

include hf

/-- `map f` and `comap f` form a `galois_coinsertion` when `f` is injective. -/
@[to_additive /-" `map f` and `comap f` form a `galois_coinsertion` when `f` is injective. "-/]
def gci_map_comap : galois_coinsertion (map f) (comap f) :=
(gc_map_comap f).to_galois_coinsertion
  (λ S x, by simp [mem_comap, mem_map, hf.eq_iff])

@[to_additive]
lemma comap_map_eq_of_injective (S : subsemigroup M) : (S.map f).comap f = S :=
(gci_map_comap hf).u_l_eq _

@[to_additive]
lemma comap_surjective_of_injective : function.surjective (comap f) :=
(gci_map_comap hf).u_surjective

@[to_additive]
lemma map_injective_of_injective : function.injective (map f) :=
(gci_map_comap hf).l_injective

@[to_additive]
lemma comap_inf_map_of_injective (S T : subsemigroup M) : (S.map f ⊓ T.map f).comap f = S ⊓ T :=
(gci_map_comap hf).u_inf_l _ _

@[to_additive]
lemma comap_infi_map_of_injective (S : ι → subsemigroup M) : (⨅ i, (S i).map f).comap f = infi S :=
(gci_map_comap hf).u_infi_l _

@[to_additive]
lemma comap_sup_map_of_injective (S T : subsemigroup M) : (S.map f ⊔ T.map f).comap f = S ⊔ T :=
(gci_map_comap hf).u_sup_l _ _

@[to_additive]
lemma comap_supr_map_of_injective (S : ι → subsemigroup M) : (⨆ i, (S i).map f).comap f = supr S :=
(gci_map_comap hf).u_supr_l _

@[to_additive]
lemma map_le_map_iff_of_injective {S T : subsemigroup M} : S.map f ≤ T.map f ↔ S ≤ T :=
(gci_map_comap hf).l_le_l_iff

@[to_additive]
lemma map_strict_mono_of_injective : strict_mono (map f) :=
(gci_map_comap hf).strict_mono_l

end galois_coinsertion

section galois_insertion

variables {ι : Type*} {f : M →ₙ* N} (hf : function.surjective f)

include hf

/-- `map f` and `comap f` form a `galois_insertion` when `f` is surjective. -/
@[to_additive /-" `map f` and `comap f` form a `galois_insertion` when `f` is surjective. "-/]
def gi_map_comap : galois_insertion (map f) (comap f) :=
(gc_map_comap f).to_galois_insertion
  (λ S x h, let ⟨y, hy⟩ := hf x in mem_map.2 ⟨y, by simp [hy, h]⟩)

@[to_additive]
lemma map_comap_eq_of_surjective (S : subsemigroup N) : (S.comap f).map f = S :=
(gi_map_comap hf).l_u_eq _

@[to_additive]
lemma map_surjective_of_surjective : function.surjective (map f) :=
(gi_map_comap hf).l_surjective

@[to_additive]
lemma comap_injective_of_surjective : function.injective (comap f) :=
(gi_map_comap hf).u_injective

@[to_additive]
lemma map_inf_comap_of_surjective (S T : subsemigroup N) : (S.comap f ⊓ T.comap f).map f = S ⊓ T :=
(gi_map_comap hf).l_inf_u _ _

@[to_additive]
lemma map_infi_comap_of_surjective (S : ι → subsemigroup N) : (⨅ i, (S i).comap f).map f = infi S :=
(gi_map_comap hf).l_infi_u _

@[to_additive]
lemma map_sup_comap_of_surjective (S T : subsemigroup N) : (S.comap f ⊔ T.comap f).map f = S ⊔ T :=
(gi_map_comap hf).l_sup_u _ _

@[to_additive]
lemma map_supr_comap_of_surjective (S : ι → subsemigroup N) : (⨆ i, (S i).comap f).map f = supr S :=
(gi_map_comap hf).l_supr_u _

@[to_additive]
lemma comap_le_comap_iff_of_surjective {S T : subsemigroup N} : S.comap f ≤ T.comap f ↔ S ≤ T :=
(gi_map_comap hf).u_le_u_iff

@[to_additive]
lemma comap_strict_mono_of_surjective : strict_mono (comap f) :=
(gi_map_comap hf).strict_mono_u

end galois_insertion

end subsemigroup

namespace mul_mem_class

variables {A : Type*} [has_mul M] [set_like A M] [hA : mul_mem_class A M] (S' : A)
include hA

/-- A submagma of a magma inherits a multiplication. -/
@[to_additive "An additive submagma of an additive magma inherits an addition.",
priority 900] -- lower priority so other instances are found first
instance has_mul : has_mul S' := ⟨λ a b, ⟨a.1 * b.1, mul_mem a.2 b.2⟩⟩

@[simp, norm_cast, to_additive, priority 900]
-- lower priority so later simp lemmas are used first; to appease simp_nf
lemma coe_mul (x y : S') : (↑(x * y) : M) = ↑x * ↑y := rfl

@[simp, to_additive, priority 900]
-- lower priority so later simp lemmas are used first; to appease simp_nf
lemma mk_mul_mk (x y : M) (hx : x ∈ S') (hy : y ∈ S') :
  (⟨x, hx⟩ : S') * ⟨y, hy⟩ = ⟨x * y, mul_mem hx hy⟩ := rfl

@[to_additive] lemma mul_def (x y : S') : x * y = ⟨x * y, mul_mem x.2 y.2⟩ := rfl

omit hA

/-- A subsemigroup of a semigroup inherits a semigroup structure. -/
@[to_additive "An `add_subsemigroup` of an `add_semigroup` inherits an `add_semigroup` structure."]
instance to_semigroup {M : Type*} [semigroup M] {A : Type*} [set_like A M] [mul_mem_class A M]
  (S : A) : semigroup S :=
subtype.coe_injective.semigroup coe (λ _ _, rfl)

/-- A subsemigroup of a `comm_semigroup` is a `comm_semigroup`. -/
@[to_additive "An `add_subsemigroup` of an `add_comm_semigroup` is an `add_comm_semigroup`."]
instance to_comm_semigroup {M} [comm_semigroup M] {A : Type*} [set_like A M] [mul_mem_class A M]
  (S : A) : comm_semigroup S :=
subtype.coe_injective.comm_semigroup coe (λ _ _, rfl)

include hA

/-- The natural semigroup hom from a subsemigroup of semigroup `M` to `M`. -/
@[to_additive "The natural semigroup hom from an `add_subsemigroup` of `add_semigroup` `M` to `M`."]
def subtype : S' →ₙ* M := ⟨coe, λ _ _, rfl⟩

@[simp, to_additive]

end mul_mem_class

namespace subsemigroup

variables [has_mul M] [has_mul N] [has_mul P] (S : subsemigroup M)

/-- The top subsemigroup is isomorphic to the semigroup. -/
@[to_additive "The top additive subsemigroup is isomorphic to the additive semigroup.", simps]
def top_equiv : (⊤ : subsemigroup M) ≃* M :=
{ to_fun    := λ x, x,
  inv_fun   := λ x, ⟨x, mem_top x⟩,
  left_inv  := λ x, x.eta _,
  right_inv := λ _, rfl,
  map_mul'  := λ _ _, rfl }

@[simp, to_additive] lemma top_equiv_to_mul_hom :
  (top_equiv : _ ≃* M).to_mul_hom = mul_mem_class.subtype (⊤ : subsemigroup M) :=
rfl

/-- A subsemigroup is isomorphic to its image under an injective function -/
@[to_additive "An additive subsemigroup is isomorphic to its image under an injective function"]
noncomputable def equiv_map_of_injective
  (f : M →ₙ* N) (hf : function.injective f) : S ≃* S.map f :=
{ map_mul' := λ _ _, subtype.ext (map_mul f _ _), ..equiv.set.image f S hf }

@[simp, to_additive] lemma coe_equiv_map_of_injective_apply
  (f : M →ₙ* N) (hf : function.injective f) (x : S) :
  (equiv_map_of_injective S f hf x : N) = f x := rfl

@[simp, to_additive]
lemma closure_closure_coe_preimage {s : set M} : closure ((coe : closure s → M) ⁻¹' s) = ⊤ :=
eq_top_iff.2 $ λ x, subtype.rec_on x $ λ x hx _, begin
  refine closure_induction' _ (λ g hg, _) (λ g₁ g₂ hg₁ hg₂, _) hx,
  { exact subset_closure hg },
  { exact subsemigroup.mul_mem _ },
end

/-- Given `subsemigroup`s `s`, `t` of semigroups `M`, `N` respectively, `s × t` as a subsemigroup
of `M × N`. -/
@[to_additive prod "Given `add_subsemigroup`s `s`, `t` of `add_semigroup`s `A`, `B` respectively,
`s × t` as an `add_subsemigroup` of `A × B`."]
def prod (s : subsemigroup M) (t : subsemigroup N) : subsemigroup (M × N) :=
{ carrier := s ×ˢ t,
  mul_mem' := λ p q hp hq, ⟨s.mul_mem hp.1 hq.1, t.mul_mem hp.2 hq.2⟩ }

@[to_additive coe_prod]
lemma coe_prod (s : subsemigroup M) (t : subsemigroup N) : (s.prod t : set (M × N)) = s ×ˢ t := rfl

@[to_additive mem_prod]
lemma mem_prod {s : subsemigroup M} {t : subsemigroup N} {p : M × N} :
  p ∈ s.prod t ↔ p.1 ∈ s ∧ p.2 ∈ t := iff.rfl

@[to_additive prod_mono]
lemma prod_mono {s₁ s₂ : subsemigroup M} {t₁ t₂ : subsemigroup N} (hs : s₁ ≤ s₂) (ht : t₁ ≤ t₂) :
  s₁.prod t₁ ≤ s₂.prod t₂ :=
set.prod_mono hs ht

@[to_additive prod_top]
lemma prod_top (s : subsemigroup M) :
  s.prod (⊤ : subsemigroup N) = s.comap (mul_hom.fst M N) :=
ext $ λ x, by simp [mem_prod, mul_hom.coe_fst]

@[to_additive top_prod]
lemma top_prod (s : subsemigroup N) :
  (⊤ : subsemigroup M).prod s = s.comap (mul_hom.snd M N) :=
ext $ λ x, by simp [mem_prod, mul_hom.coe_snd]

@[simp, to_additive top_prod_top]
lemma top_prod_top : (⊤ : subsemigroup M).prod (⊤ : subsemigroup N) = ⊤ :=
(top_prod _).trans $ comap_top _

@[to_additive] lemma bot_prod_bot : (⊥ : subsemigroup M).prod (⊥ : subsemigroup N) = ⊥ :=
set_like.coe_injective $ by simp [coe_prod, prod.one_eq_mk]

/-- The product of subsemigroups is isomorphic to their product as semigroups. -/
@[to_additive prod_equiv "The product of additive subsemigroups is isomorphic to their product
as additive semigroups"]
def prod_equiv (s : subsemigroup M) (t : subsemigroup N) : s.prod t ≃* s × t :=
{ map_mul' := λ x y, rfl, .. equiv.set.prod ↑s ↑t }

open mul_hom

@[to_additive]
lemma mem_map_equiv {f : M ≃* N} {K : subsemigroup M} {x : N} :
  x ∈ K.map f.to_mul_hom ↔ f.symm x ∈ K :=
@set.mem_image_equiv _ _ ↑K f.to_equiv x

@[to_additive]
lemma map_equiv_eq_comap_symm (f : M ≃* N) (K : subsemigroup M) :
  K.map f.to_mul_hom = K.comap f.symm.to_mul_hom :=
set_like.coe_injective (f.to_equiv.image_eq_preimage K)

@[to_additive]
lemma comap_equiv_eq_map_symm (f : N ≃* M) (K : subsemigroup M) :
  K.comap f.to_mul_hom = K.map f.symm.to_mul_hom :=
(map_equiv_eq_comap_symm f.symm K).symm

@[simp, to_additive]
lemma map_equiv_top (f : M ≃* N) : (⊤ : subsemigroup M).map f.to_mul_hom = ⊤ :=
set_like.coe_injective $ set.image_univ.trans f.surjective.range_eq

@[to_additive le_prod_iff]
lemma le_prod_iff {s : subsemigroup M} {t : subsemigroup N} {u : subsemigroup (M × N)} :
  u ≤ s.prod t ↔ u.map (fst M N) ≤ s ∧ u.map (snd M N) ≤ t :=
begin
  split,
  { intros h,
    split,
    { rintros x ⟨⟨y1,y2⟩, ⟨hy1,rfl⟩⟩, exact (h hy1).1 },
    { rintros x ⟨⟨y1,y2⟩, ⟨hy1,rfl⟩⟩, exact (h hy1).2 }, },
  { rintros ⟨hH, hK⟩ ⟨x1, x2⟩ h, exact ⟨hH ⟨_ , h, rfl⟩, hK ⟨ _, h, rfl⟩⟩, }
end

end subsemigroup

namespace mul_hom

open subsemigroup

variables [has_mul M] [has_mul N] [has_mul P] (S : subsemigroup M)

/-- The range of a semigroup homomorphism is a subsemigroup. See Note [range copy pattern]. -/
@[to_additive "The range of an `add_hom` is an `add_subsemigroup`."]
def srange (f : M →ₙ* N) : subsemigroup N :=
((⊤ : subsemigroup M).map f).copy (set.range f) set.image_univ.symm

@[simp, to_additive]
lemma coe_srange (f : M →ₙ* N) :
  (f.srange : set N) = set.range f :=
rfl

@[simp, to_additive] lemma mem_srange {f : M →ₙ* N} {y : N} :
  y ∈ f.srange ↔ ∃ x, f x = y :=
iff.rfl

@[to_additive] lemma srange_eq_map (f : M →ₙ* N) : f.srange = (⊤ : subsemigroup M).map f :=
copy_eq _

@[to_additive]
lemma map_srange (g : N →ₙ* P) (f : M →ₙ* N) : f.srange.map g = (g.comp f).srange :=
by simpa only [srange_eq_map] using (⊤ : subsemigroup M).map_map g f

@[to_additive]
lemma srange_top_iff_surjective {N} [has_mul N] {f : M →ₙ* N} :
  f.srange = (⊤ : subsemigroup N) ↔ function.surjective f :=
set_like.ext'_iff.trans $ iff.trans (by rw [coe_srange, coe_top]) set.range_iff_surjective

/-- The range of a surjective semigroup hom is the whole of the codomain. -/
@[to_additive "The range of a surjective `add_semigroup` hom is the whole of the codomain."]
lemma srange_top_of_surjective {N} [has_mul N] (f : M →ₙ* N) (hf : function.surjective f) :
  f.srange = (⊤ : subsemigroup N) :=
srange_top_iff_surjective.2 hf

@[to_additive]
lemma mclosure_preimage_le (f : M →ₙ* N) (s : set N) :
  closure (f ⁻¹' s) ≤ (closure s).comap f :=
closure_le.2 $ λ x hx, set_like.mem_coe.2 $ mem_comap.2 $ subset_closure hx

/-- The image under a semigroup hom of the subsemigroup generated by a set equals the subsemigroup
generated by the image of the set. -/
@[to_additive "The image under an `add_semigroup` hom of the `add_subsemigroup` generated by a set
equals the `add_subsemigroup` generated by the image of the set."]
lemma map_mclosure (f : M →ₙ* N) (s : set M) :
  (closure s).map f = closure (f '' s) :=
le_antisymm
  (map_le_iff_le_comap.2 $ le_trans (closure_mono $ set.subset_preimage_image _ _)
    (mclosure_preimage_le _ _))
  (closure_le.2 $ set.image_subset _ subset_closure)

/-- Restriction of a semigroup hom to a subsemigroup of the domain. -/
@[to_additive "Restriction of an add_semigroup hom to an `add_subsemigroup` of the domain."]
def restrict {N : Type*} [has_mul N] [set_like σ M] [mul_mem_class σ M] (f : M →ₙ* N) (S : σ) :
  S →ₙ* N :=
f.comp (mul_mem_class.subtype S)

@[simp, to_additive]
lemma restrict_apply {N : Type*} [has_mul N] [set_like σ M] [mul_mem_class σ M] (f : M →ₙ* N)
  {S : σ} (x : S) : f.restrict S x = f x :=
rfl

/-- Restriction of a semigroup hom to a subsemigroup of the codomain. -/
@[to_additive "Restriction of an `add_semigroup` hom to an `add_subsemigroup` of the
codomain.", simps]
def cod_restrict [set_like σ N] [mul_mem_class σ N] (f : M →ₙ* N) (S : σ) (h : ∀ x, f x ∈ S) :
  M →ₙ* S :=
{ to_fun := λ n, ⟨f n, h n⟩,
  map_mul' := λ x y, subtype.eq (map_mul f x y) }

/-- Restriction of a semigroup hom to its range interpreted as a subsemigroup. -/
@[to_additive "Restriction of an `add_semigroup` hom to its range interpreted as a subsemigroup."]
def srange_restrict {N} [has_mul N] (f : M →ₙ* N) : M →ₙ* f.srange :=
f.cod_restrict f.srange $ λ x, ⟨x, rfl⟩

@[simp, to_additive]
lemma coe_srange_restrict {N} [has_mul N] (f : M →ₙ* N) (x : M) :
  (f.srange_restrict x : N) = f x :=
rfl

@[to_additive]
lemma srange_restrict_surjective (f : M →ₙ* N) : function.surjective f.srange_restrict :=
λ ⟨_, ⟨x, rfl⟩⟩, ⟨x, rfl⟩

@[to_additive]
lemma prod_map_comap_prod' {M' : Type*} {N' : Type*} [has_mul M'] [has_mul N']
  (f : M →ₙ* N) (g : M' →ₙ* N') (S : subsemigroup N) (S' : subsemigroup N') :
  (S.prod S').comap (prod_map f g) = (S.comap f).prod (S'.comap g) :=
set_like.coe_injective $ set.preimage_prod_map_prod f g _ _

/-- The `mul_hom` from the preimage of a subsemigroup to itself. -/
@[to_additive "the `add_hom` from the preimage of an additive subsemigroup to itself.", simps]
def subsemigroup_comap (f : M →ₙ* N) (N' : subsemigroup N) :
  N'.comap f →ₙ* N' :=
{ to_fun := λ x, ⟨f x, x.prop⟩,
  map_mul' := λ x y, subtype.eq (@map_mul M N _ _ _ _ f x y) }

/-- The `mul_hom` from a subsemigroup to its image.
See `mul_equiv.subsemigroup_map` for a variant for `mul_equiv`s. -/
@[to_additive "the `add_hom` from an additive subsemigroup to its image. See
`add_equiv.add_subsemigroup_map` for a variant for `add_equiv`s.", simps]
def subsemigroup_map (f : M →ₙ* N) (M' : subsemigroup M) :
  M' →ₙ* M'.map f :=
{ to_fun := λ x, ⟨f x, ⟨x, x.prop, rfl⟩⟩,
  map_mul' := λ x y, subtype.eq $ @map_mul M N _ _ _ _ f x y }

@[to_additive]
lemma subsemigroup_map_surjective (f : M →ₙ* N) (M' : subsemigroup M) :
  function.surjective (f.subsemigroup_map M') :=
by { rintro ⟨_, x, hx, rfl⟩, exact ⟨⟨x, hx⟩, rfl⟩ }

end mul_hom

namespace subsemigroup
open mul_hom

variables [has_mul M] [has_mul N] [has_mul P] (S : subsemigroup M)

@[simp, to_additive]
lemma srange_fst [nonempty N] : (fst M N).srange = ⊤ :=
(fst M N).srange_top_of_surjective $ prod.fst_surjective

@[simp, to_additive]
lemma srange_snd [nonempty M] : (snd M N).srange = ⊤ :=
(snd M N).srange_top_of_surjective $ prod.snd_surjective

@[to_additive]
lemma prod_eq_top_iff [nonempty M] [nonempty N] {s : subsemigroup M} {t : subsemigroup N} :
  s.prod t = ⊤ ↔ s = ⊤ ∧ t = ⊤ :=
by simp only [eq_top_iff, le_prod_iff, ← (gc_map_comap _).le_iff_le, ← srange_eq_map,
  srange_fst, srange_snd]

/-- The semigroup hom associated to an inclusion of subsemigroups. -/
@[to_additive "The `add_semigroup` hom associated to an inclusion of subsemigroups."]
def inclusion {S T : subsemigroup M} (h : S ≤ T) : S →ₙ* T :=
(mul_mem_class.subtype S).cod_restrict _ (λ x, h x.2)

@[simp, to_additive]
lemma range_subtype (s : subsemigroup M) : (mul_mem_class.subtype s).srange = s :=
set_like.coe_injective $ (coe_srange _).trans $ subtype.range_coe

@[to_additive] lemma eq_top_iff' : S = ⊤ ↔ ∀ x : M, x ∈ S :=
eq_top_iff.trans ⟨λ h m, h $ mem_top m, λ h m _, h m⟩

end subsemigroup

namespace mul_equiv

variables [has_mul M] [has_mul N] {S T : subsemigroup M}

/-- Makes the identity isomorphism from a proof that two subsemigroups of a multiplicative
    semigroup are equal. -/
@[to_additive "Makes the identity additive isomorphism from a proof two
subsemigroups of an additive semigroup are equal."]
def subsemigroup_congr (h : S = T) : S ≃* T :=
{ map_mul' :=  λ _ _, rfl, ..equiv.set_congr $ congr_arg _ h }

-- this name is primed so that the version to `f.range` instead of `f.srange` can be unprimed.
/-- A semigroup homomorphism `f : M →ₙ* N` with a left-inverse `g : N → M` defines a multiplicative
equivalence between `M` and `f.srange`.

This is a bidirectional version of `mul_hom.srange_restrict`. -/
@[to_additive /-"
An additive semigroup homomorphism `f : M →+ N` with a left-inverse `g : N → M` defines an additive
equivalence between `M` and `f.srange`.

This is a bidirectional version of `add_hom.srange_restrict`. "-/, simps {simp_rhs := tt}]
def of_left_inverse (f : M →ₙ* N) {g : N → M} (h : function.left_inverse g f) : M ≃* f.srange :=
{ to_fun := f.srange_restrict,
  inv_fun := g ∘ (mul_mem_class.subtype f.srange),
  left_inv := h,
  right_inv := λ x, subtype.ext $
    let ⟨x', hx'⟩ := mul_hom.mem_srange.mp x.prop in
    show f (g x) = x, by rw [←hx', h x'],
  .. f.srange_restrict }

/-- A `mul_equiv` `φ` between two semigroups `M` and `N` induces a `mul_equiv` between
a subsemigroup `S ≤ M` and the subsemigroup `φ(S) ≤ N`.
See `mul_hom.subsemigroup_map` for a variant for `mul_hom`s. -/
@[to_additive "An `add_equiv` `φ` between two additive semigroups `M` and `N` induces an `add_equiv`
between a subsemigroup `S ≤ M` and the subsemigroup `φ(S) ≤ N`. See `add_hom.add_subsemigroup_map`
for a variant for `add_hom`s.", simps]
def subsemigroup_map (e : M ≃* N) (S : subsemigroup M) : S ≃* S.map e.to_mul_hom :=
{ to_fun := λ x, ⟨e x, _⟩,
  inv_fun := λ x, ⟨e.symm x, _⟩, -- we restate this for `simps` to avoid `⇑e.symm.to_equiv x`
  ..e.to_mul_hom.subsemigroup_map S,
  ..e.to_equiv.image S }

end mul_equiv


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import ring_theory.ring_hom_properties

/-!

# The meta properties of integral ring homomorphisms.

-/

namespace ring_hom

open_locale tensor_product

open tensor_product algebra.tensor_product

lemma is_integral_stable_under_composition :
  stable_under_composition (λ R S _ _ f, by exactI f.is_integral) :=
by { introv R hf hg, exactI ring_hom.is_integral_trans _ _ hf hg }

lemma is_integral_respects_iso :
  respects_iso (λ R S _ _ f, by exactI f.is_integral) :=
begin
  apply is_integral_stable_under_composition.respects_iso,
  introv x,
  resetI,
  rw ← e.apply_symm_apply x,
  apply ring_hom.is_integral_map
end

lemma is_integral_stable_under_base_change :
  stable_under_base_change (λ R S _ _ f, by exactI f.is_integral) :=
begin
  refine stable_under_base_change.mk _ is_integral_respects_iso _,
  introv h x,
  resetI,
  apply tensor_product.induction_on x,
  { apply is_integral_zero },
  { intros x y, exact is_integral.tmul x (h y) },
  { intros x y hx hy, exact is_integral_add _ hx hy }
end

end ring_hom


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau

Free abelian groups as abelianization of free groups.

-- TODO: rewrite in terms of finsupp
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.group.pi
import Mathlib.group_theory.free_group
import Mathlib.group_theory.abelianization
import Mathlib.PostPort

universes u v u_1 u_2 u_3

namespace Mathlib

def free_abelian_group (α : Type u) := additive (abelianization (free_group α))

protected instance free_abelian_group.add_comm_group (α : Type u) :
    add_comm_group (free_abelian_group α) :=
  additive.add_comm_group

protected instance free_abelian_group.inhabited (α : Type u) : Inhabited (free_abelian_group α) :=
  { default := 0 }

namespace free_abelian_group

def of {α : Type u} (x : α) : free_abelian_group α := coe_fn abelianization.of (free_group.of x)

def lift {α : Type u} {β : Type v} [add_comm_group β] (f : α → β) : free_abelian_group α →+ β :=
  coe_fn monoid_hom.to_additive (abelianization.lift (monoid_hom.of ⇑(free_group.to_group f)))

namespace lift

@[simp] protected theorem add {α : Type u} {β : Type v} [add_comm_group β] (f : α → β)
    (x : free_abelian_group α) (y : free_abelian_group α) :
    coe_fn (lift f) (x + y) = coe_fn (lift f) x + coe_fn (lift f) y :=
  is_add_hom.map_add (⇑(lift f)) x y

@[simp] protected theorem neg {α : Type u} {β : Type v} [add_comm_group β] (f : α → β)
    (x : free_abelian_group α) : coe_fn (lift f) (-x) = -coe_fn (lift f) x :=
  is_add_group_hom.map_neg (⇑(lift f)) x

@[simp] protected theorem sub {α : Type u} {β : Type v} [add_comm_group β] (f : α → β)
    (x : free_abelian_group α) (y : free_abelian_group α) :
    coe_fn (lift f) (x - y) = coe_fn (lift f) x - coe_fn (lift f) y :=
  sorry

@[simp] protected theorem zero {α : Type u} {β : Type v} [add_comm_group β] (f : α → β) :
    coe_fn (lift f) 0 = 0 :=
  is_add_group_hom.map_zero ⇑(lift f)

@[simp] protected theorem of {α : Type u} {β : Type v} [add_comm_group β] (f : α → β) (x : α) :
    coe_fn (lift f) (of x) = f x :=
  sorry

protected theorem unique {α : Type u} {β : Type v} [add_comm_group β] (f : α → β)
    (g : free_abelian_group α →+ β) (hg : ∀ (x : α), coe_fn g (of x) = f x)
    {x : free_abelian_group α} : coe_fn g x = coe_fn (lift f) x :=
  abelianization.lift.unique (monoid_hom.of ⇑(free_group.to_group f))
    (coe_fn add_monoid_hom.to_multiplicative g)
    fun (x : free_group α) =>
      free_group.to_group.unique
        (monoid_hom.comp (coe_fn add_monoid_hom.to_multiplicative' g) abelianization.of) hg

/-- See note [partially-applied ext lemmas]. -/
protected theorem ext {α : Type u} {β : Type v} [add_comm_group β] (g : free_abelian_group α →+ β)
    (h : free_abelian_group α →+ β) (H : ∀ (x : α), coe_fn g (of x) = coe_fn h (of x)) : g = h :=
  sorry

theorem map_hom {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group β] [add_comm_group γ]
    (a : free_abelian_group α) (f : α → β) (g : β →+ γ) :
    coe_fn g (coe_fn (lift f) a) = coe_fn (lift (⇑g ∘ f)) a :=
  sorry

end lift

theorem of_injective {α : Type u} : function.injective of := sorry

/-- The bijection underlying the free-forgetful adjunction for abelian groups.-/
def hom_equiv (X : Type u_1) (G : Type u_2) [add_comm_group G] :
    (free_abelian_group X →+ G) ≃ (X → G) :=
  equiv.mk (fun (f : free_abelian_group X →+ G) => add_monoid_hom.to_fun f ∘ of)
    (fun (f : X → G) => add_monoid_hom.of ⇑(lift f)) sorry sorry

@[simp] theorem hom_equiv_apply (X : Type u_1) (G : Type u_2) [add_comm_group G]
    (f : free_abelian_group X →+ G) (x : X) : coe_fn (hom_equiv X G) f x = coe_fn f (of x) :=
  rfl

@[simp] theorem hom_equiv_symm_apply (X : Type u_1) (G : Type u_2) [add_comm_group G] (f : X → G)
    (x : free_abelian_group X) :
    coe_fn (coe_fn (equiv.symm (hom_equiv X G)) f) x = coe_fn (lift f) x :=
  rfl

protected theorem induction_on {α : Type u} {C : free_abelian_group α → Prop}
    (z : free_abelian_group α) (C0 : C 0) (C1 : ∀ (x : α), C (of x))
    (Cn : ∀ (x : α), C (of x) → C (-of x))
    (Cp : ∀ (x y : free_abelian_group α), C x → C y → C (x + y)) : C z :=
  sorry

theorem lift.add' {α : Type u_1} {β : Type u_2} [add_comm_group β] (a : free_abelian_group α)
    (f : α → β) (g : α → β) : coe_fn (lift (f + g)) a = coe_fn (lift f) a + coe_fn (lift g) a :=
  sorry

protected instance is_add_group_hom_lift' {α : Type u_1} (β : Type u_2) [add_comm_group β]
    (a : free_abelian_group α) : is_add_group_hom fun (f : α → β) => coe_fn (lift f) a :=
  is_add_group_hom.mk

protected instance monad : Monad free_abelian_group := sorry

protected theorem induction_on' {α : Type u} {C : free_abelian_group α → Prop}
    (z : free_abelian_group α) (C0 : C 0) (C1 : ∀ (x : α), C (pure x))
    (Cn : ∀ (x : α), C (pure x) → C (-pure x))
    (Cp : ∀ (x y : free_abelian_group α), C x → C y → C (x + y)) : C z :=
  free_abelian_group.induction_on z C0 C1 Cn Cp

@[simp] theorem map_pure {α : Type u} {β : Type u} (f : α → β) (x : α) :
    f <$> pure x = pure (f x) :=
  lift.of (of ∘ f) x

@[simp] theorem map_zero {α : Type u} {β : Type u} (f : α → β) : f <$> 0 = 0 := lift.zero (of ∘ f)

@[simp] theorem map_add {α : Type u} {β : Type u} (f : α → β) (x : free_abelian_group α)
    (y : free_abelian_group α) : f <$> (x + y) = f <$> x + f <$> y :=
  lift.add (of ∘ f) x y

@[simp] theorem map_neg {α : Type u} {β : Type u} (f : α → β) (x : free_abelian_group α) :
    f <$> (-x) = -f <$> x :=
  lift.neg (of ∘ f) x

@[simp] theorem map_sub {α : Type u} {β : Type u} (f : α → β) (x : free_abelian_group α)
    (y : free_abelian_group α) : f <$> (x - y) = f <$> x - f <$> y :=
  lift.sub (of ∘ f) x y

@[simp] theorem map_of {α : Type u} {β : Type u} (f : α → β) (y : α) : f <$> of y = of (f y) := rfl

/-- The additive group homomorphism `free_abelian_group α →+ free_abelian_group β` induced from a
  map `α → β` -/
def map {α : Type u} {β : Type u} (f : α → β) : free_abelian_group α →+ free_abelian_group β :=
  add_monoid_hom.mk' (fun (x : free_abelian_group α) => f <$> x) (map_add f)

theorem lift_comp {α : Type u_1} {β : Type u_1} {γ : Type u_2} [add_comm_group γ] (f : α → β)
    (g : β → γ) (x : free_abelian_group α) : coe_fn (lift (g ∘ f)) x = coe_fn (lift g) (f <$> x) :=
  sorry

@[simp] theorem pure_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β) (x : α) :
    pure x >>= f = f x :=
  lift.of f x

@[simp] theorem zero_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β) : 0 >>= f = 0 :=
  lift.zero f

@[simp] theorem add_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β)
    (x : free_abelian_group α) (y : free_abelian_group α) : x + y >>= f = (x >>= f) + (y >>= f) :=
  lift.add f x y

@[simp] theorem neg_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β)
    (x : free_abelian_group α) : -x >>= f = -(x >>= f) :=
  lift.neg f x

@[simp] theorem sub_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β)
    (x : free_abelian_group α) (y : free_abelian_group α) : x - y >>= f = (x >>= f) - (y >>= f) :=
  lift.sub f x y

@[simp] theorem pure_seq {α : Type u} {β : Type u} (f : α → β) (x : free_abelian_group α) :
    pure f <*> x = f <$> x :=
  pure_bind
    (fun (_x : α → β) =>
      (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x
        x)
    f

@[simp] theorem zero_seq {α : Type u} {β : Type u} (x : free_abelian_group α) : 0 <*> x = 0 :=
  zero_bind
    fun (_x : α → β) =>
      (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x
        x

@[simp] theorem add_seq {α : Type u} {β : Type u} (f : free_abelian_group (α → β))
    (g : free_abelian_group (α → β)) (x : free_abelian_group α) :
    f + g <*> x = (f <*> x) + (g <*> x) :=
  add_bind
    (fun (_x : α → β) =>
      (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x
        x)
    f g

@[simp] theorem neg_seq {α : Type u} {β : Type u} (f : free_abelian_group (α → β))
    (x : free_abelian_group α) : -f <*> x = -(f <*> x) :=
  neg_bind
    (fun (_x : α → β) =>
      (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x
        x)
    f

@[simp] theorem sub_seq {α : Type u} {β : Type u} (f : free_abelian_group (α → β))
    (g : free_abelian_group (α → β)) (x : free_abelian_group α) :
    f - g <*> x = (f <*> x) - (g <*> x) :=
  sub_bind
    (fun (_x : α → β) =>
      (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x
        x)
    f g

protected instance is_add_group_hom_seq {α : Type u} {β : Type u} (f : free_abelian_group (α → β)) :
    is_add_group_hom (Seq.seq f) :=
  is_add_group_hom.mk

@[simp] theorem seq_zero {α : Type u} {β : Type u} (f : free_abelian_group (α → β)) : f <*> 0 = 0 :=
  is_add_group_hom.map_zero (Seq.seq f)

@[simp] theorem seq_add {α : Type u} {β : Type u} (f : free_abelian_group (α → β))
    (x : free_abelian_group α) (y : free_abelian_group α) : f <*> x + y = (f <*> x) + (f <*> y) :=
  is_add_hom.map_add (Seq.seq f) x y

@[simp] theorem seq_neg {α : Type u} {β : Type u} (f : free_abelian_group (α → β))
    (x : free_abelian_group α) : f <*> -x = -(f <*> x) :=
  is_add_group_hom.map_neg (Seq.seq f) x

@[simp] theorem seq_sub {α : Type u} {β : Type u} (f : free_abelian_group (α → β))
    (x : free_abelian_group α) (y : free_abelian_group α) : f <*> x - y = (f <*> x) - (f <*> y) :=
  is_add_group_hom.map_sub (Seq.seq f) x y

protected instance is_lawful_monad : is_lawful_monad free_abelian_group := sorry

protected instance is_comm_applicative : is_comm_applicative free_abelian_group := sorry

protected instance semigroup (α : Type u) [monoid α] : semigroup (free_abelian_group α) :=
  semigroup.mk
    (fun (x : free_abelian_group α) =>
      ⇑(lift fun (x₂ : α) => coe_fn (lift fun (x₁ : α) => of (x₁ * x₂)) x))
    sorry

theorem mul_def (α : Type u) [monoid α] (x : free_abelian_group α) (y : free_abelian_group α) :
    x * y = coe_fn (lift fun (x₂ : α) => coe_fn (lift fun (x₁ : α) => of (x₁ * x₂)) x) y :=
  rfl

theorem of_mul_of (α : Type u) [monoid α] (x : α) (y : α) : of x * of y = of (x * y) := rfl

theorem of_mul (α : Type u) [monoid α] (x : α) (y : α) : of (x * y) = of x * of y := rfl

protected instance ring (α : Type u) [monoid α] : ring (free_abelian_group α) :=
  ring.mk add_comm_group.add sorry add_comm_group.zero sorry sorry add_comm_group.neg
    add_comm_group.sub sorry sorry semigroup.mul sorry (of 1) sorry sorry sorry sorry

theorem one_def (α : Type u) [monoid α] : 1 = of 1 := rfl

theorem of_one (α : Type u) [monoid α] : of 1 = 1 := rfl

protected instance comm_ring (α : Type u) [comm_monoid α] : comm_ring (free_abelian_group α) :=
  comm_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry
    ring.one sorry sorry sorry sorry sorry

end Mathlib


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.semiquot
import data.rat.floor
/-!
# Implementation of floating-point numbers (experimental).

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

def int.shift2 (a b : ℕ) : ℤ → ℕ × ℕ
| (int.of_nat e) := (a.shiftl e, b)
| -[1+ e] := (a, b.shiftl e.succ)

namespace fp

@[derive inhabited]
inductive rmode
| NE -- round to nearest even

class float_cfg :=
(prec emax : ℕ)
(prec_pos : 0 < prec)
(prec_max : prec ≤ emax)

variable [C : float_cfg]
include C

def prec := C.prec
def emax := C.emax
def emin : ℤ := 1 - C.emax

def valid_finite (e : ℤ) (m : ℕ) : Prop :=
emin ≤ e + prec - 1 ∧ e + prec - 1 ≤ emax ∧ e = max (e + m.size - prec) emin

instance dec_valid_finite (e m) : decidable (valid_finite e m) :=
by unfold valid_finite; apply_instance

inductive float
| inf : bool → float
| nan : float
| finite : bool → Π e m, valid_finite e m → float

def float.is_finite : float → bool
| (float.finite s e m f) := tt
| _ := ff

def to_rat : Π (f : float), f.is_finite → ℚ
| (float.finite s e m f) _ :=
  let (n, d) := int.shift2 m 1 e,
      r := rat.mk_nat n d in
  if s then -r else r

theorem float.zero.valid : valid_finite emin 0 :=
⟨begin
  rw add_sub_assoc,
  apply le_add_of_nonneg_right,
  apply sub_nonneg_of_le,
  apply int.coe_nat_le_coe_nat_of_le,
  exact C.prec_pos
end,
suffices prec ≤ 2 * emax,
begin
  rw ← int.coe_nat_le at this,
  rw ← sub_nonneg at *,
  simp only [emin, emax] at *,
  ring_nf,
  assumption
end, le_trans C.prec_max (nat.le_mul_of_pos_left dec_trivial),
by rw max_eq_right; simp [sub_eq_add_neg]⟩

def float.zero (s : bool) : float :=
float.finite s emin 0 float.zero.valid

instance : inhabited float := ⟨float.zero tt⟩

protected def float.sign' : float → semiquot bool
| (float.inf s) := pure s
| float.nan := ⊤
| (float.finite s e m f) := pure s

protected def float.sign : float → bool
| (float.inf s) := s
| float.nan := ff
| (float.finite s e m f) := s

protected def float.is_zero : float → bool
| (float.finite s e 0 f) := tt
| _ := ff

protected def float.neg : float → float
| (float.inf s) := float.inf (bnot s)
| float.nan := float.nan
| (float.finite s e m f) := float.finite (bnot s) e m f

def div_nat_lt_two_pow (n d : ℕ) : ℤ → bool
| (int.of_nat e) := n < d.shiftl e
| -[1+ e] := n.shiftl e.succ < d

-- TODO(Mario): Prove these and drop 'meta'
meta def of_pos_rat_dn (n : ℕ+) (d : ℕ+) : float × bool :=
begin
  let e₁ : ℤ := n.1.size - d.1.size - prec,
  cases h₁ : int.shift2 d.1 n.1 (e₁ + prec) with d₁ n₁,
  let e₂ := if n₁ < d₁ then e₁ - 1 else e₁,
  let e₃ := max e₂ emin,
  cases h₂ : int.shift2 d.1 n.1 (e₃ + prec) with d₂ n₂,
  let r := rat.mk_nat n₂ d₂,
  let m := r.floor,
  refine (float.finite ff e₃ (int.to_nat m) _, r.denom = 1),
  { exact undefined }
end

meta def next_up_pos (e m) (v : valid_finite e m) : float :=
let m' := m.succ in
if ss : m'.size = m.size then
  float.finite ff e m' (by unfold valid_finite at *; rw ss; exact v)
else if h : e = emax then
  float.inf ff
else
  float.finite ff e.succ (nat.div2 m') undefined

meta def next_dn_pos (e m) (v : valid_finite e m) : float :=
match m with
| 0 := next_up_pos _ _ float.zero.valid
| nat.succ m' :=
  if ss : m'.size = m.size then
    float.finite ff e m' (by unfold valid_finite at *; rw ss; exact v)
  else if h : e = emin then
    float.finite ff emin m' undefined
  else
    float.finite ff e.pred (bit1 m') undefined
end

meta def next_up : float → float
| (float.finite ff e m f) := next_up_pos e m f
| (float.finite tt e m f) := float.neg $ next_dn_pos e m f
| f := f

meta def next_dn : float → float
| (float.finite ff e m f) := next_dn_pos e m f
| (float.finite tt e m f) := float.neg $ next_up_pos e m f
| f := f

meta def of_rat_up : ℚ → float
| ⟨0, _, _, _⟩          := float.zero ff
| ⟨nat.succ n, d, h, _⟩ :=
  let (f, exact) := of_pos_rat_dn n.succ_pnat ⟨d, h⟩ in
  if exact then f else next_up f
| ⟨-[1+n], d, h, _⟩     := float.neg (of_pos_rat_dn n.succ_pnat ⟨d, h⟩).1

meta def of_rat_dn (r : ℚ) : float :=
float.neg $ of_rat_up (-r)

meta def of_rat : rmode → ℚ → float
| rmode.NE r :=
  let low := of_rat_dn r, high := of_rat_up r in
  if hf : high.is_finite then
    if r = to_rat _ hf then high else
    if lf : low.is_finite then
      if r - to_rat _ lf > to_rat _ hf - r then high else
      if r - to_rat _ lf < to_rat _ hf - r then low else
      match low, lf with float.finite s e m f, _ :=
        if 2 ∣ m then low else high
      end
    else float.inf tt
  else float.inf ff

namespace float

instance : has_neg float := ⟨float.neg⟩

meta def add (mode : rmode) : float → float → float
| nan      _        := nan
| _        nan      := nan
| (inf tt) (inf ff) := nan
| (inf ff) (inf tt) := nan
| (inf s₁) _        := inf s₁
| _        (inf s₂) := inf s₂
| (finite s₁ e₁ m₁ v₁) (finite s₂ e₂ m₂ v₂) :=
  let f₁ := finite s₁ e₁ m₁ v₁, f₂ := finite s₂ e₂ m₂ v₂ in
  of_rat mode (to_rat f₁ rfl + to_rat f₂ rfl)

meta instance : has_add float := ⟨float.add rmode.NE⟩

meta def sub (mode : rmode) (f1 f2 : float) : float :=
add mode f1 (-f2)

meta instance : has_sub float := ⟨float.sub rmode.NE⟩

meta def mul (mode : rmode) : float → float → float
| nan      _        := nan
| _        nan      := nan
| (inf s₁) f₂       := if f₂.is_zero then nan else inf (bxor s₁ f₂.sign)
| f₁       (inf s₂) := if f₁.is_zero then nan else inf (bxor f₁.sign s₂)
| (finite s₁ e₁ m₁ v₁) (finite s₂ e₂ m₂ v₂) :=
  let f₁ := finite s₁ e₁ m₁ v₁, f₂ := finite s₂ e₂ m₂ v₂ in
  of_rat mode (to_rat f₁ rfl * to_rat f₂ rfl)

meta def div (mode : rmode) : float → float → float
| nan      _        := nan
| _        nan      := nan
| (inf s₁) (inf s₂) := nan
| (inf s₁) f₂       := inf (bxor s₁ f₂.sign)
| f₁       (inf s₂) := zero (bxor f₁.sign s₂)
| (finite s₁ e₁ m₁ v₁) (finite s₂ e₂ m₂ v₂) :=
  let f₁ := finite s₁ e₁ m₁ v₁, f₂ := finite s₂ e₂ m₂ v₂ in
  if f₂.is_zero then inf (bxor s₁ s₂) else
  of_rat mode (to_rat f₁ rfl / to_rat f₂ rfl)

end float

end fp