/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad, Jakob von Raumer, Floris van Doorn

Ported from Coq HoTT
-/
import .path .meta.rewrite

universes u v w
hott_theory

namespace hott
open function

/- Equivalences -/

-- This is our definition of equivalence. In the HoTT-book it's called
-- ihae (half-adjoint equivalence).
class is_equiv {A : Type u} {B : Type v} (f : A → B) := mk' ::
(inv : B → A)
(right_inv : Πb, f (inv b) = b)
(left_inv : Πa, inv (f a) = a)
(adj : Πx, right_inv (f x) = ap f (left_inv x))

attribute [reducible] is_equiv.inv

-- A more bundled version of equivalence
structure equiv (A : Type u) (B : Type v) :=
  (to_fun : A → B)
  (to_is_equiv : is_equiv to_fun)

namespace is_equiv
  /- Some instances and closure properties of equivalences -/
  postfix `⁻¹ᶠ`:std.prec.max_plus := hott.is_equiv.inv

  section
  variables {A : Type u} {B : Type v} {C : Type w} (g : B → C) (f : A → B) {f' : A → B}

  -- The variant of mk' where f is explicit.
  @[hott, hsimp] protected def mk := @is_equiv.mk' A B f

  -- The identity function is an equivalence.
  @[hott, instance, hsimp] def is_equiv_id (A : Type v) : (is_equiv (id : A → A)) :=
  is_equiv.mk id id (λa, idp) (λa, idp) (λa, idp)

  -- The composition of two equivalences is, again, an equivalence.
  @[hott, instance, hsimp] def is_equiv_compose [Hf : is_equiv f] [Hg : is_equiv g]
    : is_equiv (g ∘ f) :=
  is_equiv.mk (g ∘ f) (f⁻¹ᶠ ∘ g⁻¹ᶠ)
    begin intro c, apply (⬝), tactic.swap,
      apply right_inv g, apply ap g, apply right_inv f end
    begin intro a, dsimp [(∘)], apply (⬝),
      {apply ap (inv f), apply left_inv g}, {apply left_inv} end
    begin abstract { exact  (λa, (whisker_left _ (adj g (f a))) ⬝
        (ap_con g _ _)⁻¹ ⬝
        ap02 g ((ap_con_eq_con (right_inv f) (left_inv g (f a)))⁻¹ ⬝
                (ap_compose f (inv f) _ ◾  adj f a) ⬝
                (ap_con f _ _)⁻¹
                ) ⬝
        (ap_compose g f _)⁻¹) } end

  -- Any function equal to an equivalence is an equivlance as well.
  @[hott] def is_equiv_eq_closed {f : A → B} [Hf : is_equiv f] (Heq : f = f') : is_equiv f' :=
  transport is_equiv Heq Hf
  end

  section
  parameters {A : Type u} {B : Type v} (f : A → B) (g : B → A)
            (ret : Πb, f (g b) = b) (sec : Πa, g (f a) = a)

  @[hott] def adjointify_left_inv' (a : A) : g (f a) = a :=
  ap g (ap f (inverse (sec a))) ⬝ ap g (ret (f a)) ⬝ sec a

  def adjointify_adj' (a : A) : ret (f a) = ap f (adjointify_left_inv' a) :=
  let fgretrfa := ap f (ap g (ret (f a))) in
  let fgfinvsect := ap f (ap g (ap f (sec a)⁻¹)) in
  let fgfa := f (g (f a)) in
  let retrfa := ret (f a) in
  have eq1 : ap f (sec a) = _,
    from calc ap f (sec a)
          = idp ⬝ ap f (sec a)                                     : by rwr idp_con
      ... = (ret (f a) ⬝ (ret (f a))⁻¹) ⬝ ap f (sec a)             : by rwr con.right_inv
      ... = ((ret fgfa)⁻¹ ⬝ ap (f ∘ g) (ret (f a))) ⬝ ap f (sec a) :
          by rwr con_ap_eq_con (λ x, (ret x)⁻¹)
      ... = ((ret fgfa)⁻¹ ⬝ fgretrfa) ⬝ ap f (sec a)               : by rwr ap_compose
      ... = (ret fgfa)⁻¹ ⬝ (fgretrfa ⬝ ap f (sec a))               : by rwr con.assoc,
  have eq2 : ap f (sec a) ⬝ idp = (ret fgfa)⁻¹ ⬝ (fgretrfa ⬝ ap f (sec a)),
    from con_idp _ ⬝ eq1,
  have eq3 : idp = _,
    from calc idp
          = (ap f (sec a))⁻¹ ⬝ ((ret fgfa)⁻¹ ⬝ (fgretrfa ⬝ ap f (sec a))) : eq_inv_con_of_con_eq eq2
      ... = ((ap f (sec a))⁻¹ ⬝ (ret fgfa)⁻¹) ⬝ (fgretrfa ⬝ ap f (sec a)) : by rwr con.assoc'
      ... = (ap f (sec a)⁻¹ ⬝ (ret fgfa)⁻¹) ⬝ (fgretrfa ⬝ ap f (sec a))   : by rwr ap_inv
      ... = ((ap f (sec a)⁻¹ ⬝ (ret fgfa)⁻¹) ⬝ fgretrfa) ⬝ ap f (sec a)   : by rwr con.assoc'
      ... = ((retrfa⁻¹ ⬝ ap (f ∘ g) (ap f (sec a)⁻¹)) ⬝ fgretrfa) ⬝ ap f (sec a) :
         by rwr con_ap_eq_con (λ x, (ret x)⁻¹)
      ... = ((retrfa⁻¹ ⬝ fgfinvsect) ⬝ fgretrfa) ⬝ ap f (sec a)           : by rwr ap_compose
      ... = (retrfa⁻¹ ⬝ (fgfinvsect ⬝ fgretrfa)) ⬝ ap f (sec a)           : by rwr con.assoc'
      ... = retrfa⁻¹ ⬝ ap f (ap g (ap f (sec a)⁻¹) ⬝ ap g (ret (f a))) ⬝ ap f (sec a)   : by rwr ap_con
      ... = retrfa⁻¹ ⬝ (ap f (ap g (ap f (sec a)⁻¹) ⬝ ap g (ret (f a))) ⬝ ap f (sec a)) : by rwr con.assoc'
      ... = retrfa⁻¹ ⬝ ap f ((ap g (ap f (sec a)⁻¹) ⬝ ap g (ret (f a))) ⬝ sec a)        : by rwr ← ap_con,
  show ret (f a) = ap f ((ap g (ap f (sec a)⁻¹) ⬝ ap g (ret (f a))) ⬝ sec a),
    from eq_of_idp_eq_inv_con eq3

  @[hott, hsimp] def adjointify : is_equiv f :=
  is_equiv.mk f g ret adjointify_left_inv' adjointify_adj'
  end

  -- Any function pointwise equal to an equivalence is an equivalence as well.
  @[hott, hsimp] def homotopy_closed {A B : Type _} (f : A → B) {f' : A → B} [Hf : is_equiv f]
    (Hty : f ~ f') : is_equiv f' :=
  adjointify f'
             (inv f)
             (λ b, (Hty (inv f b))⁻¹ ⬝ right_inv f b)
             (λ a, (ap (inv f) (Hty a))⁻¹ ⬝ left_inv f a)

  @[hott, hsimp] def inv_homotopy_closed {A B : Type _} {f : A → B} {f' : B → A}
    [Hf : is_equiv f] (Hty : f⁻¹ᶠ ~ f') : is_equiv f :=
  adjointify f
             f'
             (λ b, ap f (Hty _)⁻¹ᵖ ⬝ right_inv f b)
             (λ a, (Hty _)⁻¹ᵖ ⬝ left_inv f a)

  @[hott] def inv_homotopy_inv {A B : Type _} {f g : A → B} [is_equiv f] [is_equiv g] (p : f ~ g)
    : inv f ~ inv g :=
  λb, (left_inv g (f⁻¹ᶠ b))⁻¹ ⬝ ap g⁻¹ᶠ ((p (f⁻¹ᶠ b))⁻¹ ⬝ right_inv f b)

  @[hott, hsimp] instance is_equiv_up (A : Type _)
    : is_equiv (ulift.up : A → ulift A) :=
  adjointify ulift.up ulift.down (λa, by induction a;reflexivity) (λa, idp)

  section
  variables {A : Type _} {B: Type _} {C : Type _} (f : A → B) {f' : A → B} [Hf : is_equiv f] (g : B → C)
  include Hf

  -- The function equiv_rect says that given an equivalence f : A → B,
  -- and a hypothesis from B, one may always assume that the hypothesis
  -- is in the image of e.

  -- In fibrational terms, if we have a fibration over B which has a section
  -- once pulled back along an equivalence f : A → B, then it has a section
  -- over all of B.

  @[hott] def is_equiv_rect (P : B → Type _) (g : Πa, P (f a)) (b : B) : P b :=
  right_inv f b ▸ g (f⁻¹ᶠ b)

  @[hott] def is_equiv_rect' (P : A → B → Type _) (g : Πb, P (f⁻¹ᶠ b) b) (a : A) : P a (f a) :=
  transport (λ x, P x (f a)) (left_inv f a) (g (f a))

  @[hott, hsimp] def is_equiv_rect_comp (P : B → Type _)
      (df : Π (x : A), P (f x)) (x : A) : is_equiv_rect f P df (f x) = df x :=
  calc
    is_equiv_rect f P df (f x)
          = right_inv f (f x) ▸ df (f⁻¹ᶠ (f x))   : by refl
      ... = ap f (left_inv f x) ▸ df (f⁻¹ᶠ (f x)) : by rwr adj
      ... = transport (P∘f) (left_inv f x) (df (f⁻¹ᶠ (f x))) : by rwr tr_compose
      ... = df x                                 : by rwr (apdt df (left_inv f x))

  @[hott]
  def adj_inv (b : B) : left_inv f (f⁻¹ᶠ b) = ap f⁻¹ᶠ (right_inv f b) :=
  (is_equiv_rect f (λ fa, left_inv f (f⁻¹ᶠ fa) = ap f⁻¹ᶠ (right_inv f fa): _)
    (λa, (eq.cancel_right (left_inv f (id a)): _)
           (whisker_left _ (ap_id _)⁻¹ᵖ ⬝ (ap_con_eq_con_ap (left_inv f) (left_inv f a))⁻¹) ⬝
      ap_compose _ _ _ ⬝ (ap02 f⁻¹ᶠ (adj f a).inverse): _)
    b: _)

  --The inverse of an equivalence is, again, an equivalence.
  @[instance,hott] def is_equiv_inv : is_equiv f⁻¹ᶠ :=
  is_equiv.mk f⁻¹ᶠ f (left_inv f) (right_inv f) (adj_inv f)

  -- The 2-out-of-3 properties
  @[hott, hsimp] def cancel_right (g : B → C) [Hgf : is_equiv (g ∘ f)] : is_equiv g :=
  have Hfinv : is_equiv f⁻¹ᶠ, from is_equiv_inv f,
  @homotopy_closed _ _ _ _ (is_equiv_compose (g ∘ f) f⁻¹ᶠ) (λb, ap g (@right_inv _ _ f _ b))

  @[hott, hsimp] def cancel_left (g : C → A) [Hgf : is_equiv (f ∘ g)] : is_equiv g :=
  have Hfinv : is_equiv f⁻¹ᶠ, from is_equiv_inv f,
  @homotopy_closed _ _ _ _ (is_equiv_compose f⁻¹ᶠ (f ∘ g)) (λa, left_inv f (g a))

  @[hott] def eq_of_fn_eq_fn' {x y : A} (q : f x = f y) : x = y :=
  (left_inv f x)⁻¹ ⬝ ap f⁻¹ᶠ q ⬝ left_inv f y

  @[hott, hsimp] def ap_eq_of_fn_eq_fn' {x y : A} (q : f x = f y) :
    ap f (eq_of_fn_eq_fn' f q) = q :=
  ap_con _ _ _ ⬝ whisker_right _ (ap_con _ _ _)
          ⬝ ((ap_inv _ _ ⬝ inverse2 (adj f _)⁻¹)
            ◾ (inverse (ap_compose f f⁻¹ᶠ _))
            ◾ (adj f _)⁻¹)
          ⬝ con_ap_con_eq_con_con (right_inv f) _ _
          ⬝ whisker_right _ (con.left_inv _)
          ⬝ idp_con _

  @[hott, hsimp] def eq_of_fn_eq_fn'_ap {x y : A} (q : x = y) : eq_of_fn_eq_fn' f (ap f q) = q :=
  by induction q; apply con.left_inv

  @[instance, hott, hsimp] def is_equiv_ap (x y : A) : is_equiv (ap f : x = y → f x = f y) :=
  adjointify
    (ap f)
    (eq_of_fn_eq_fn' f)
    (ap_eq_of_fn_eq_fn' f)
    (eq_of_fn_eq_fn'_ap f)

  end

  section
  variables {A : Type u} {B : Type v} {C : Type w} {f : A → B} [Hf : is_equiv f]
  include Hf

  section rewrite_rules
    variables {a : A} {b : B}
    @[hott] def eq_of_eq_inv (p : a = f⁻¹ᶠ b) : f a = b :=
    ap f p ⬝ right_inv f b

    @[hott] def eq_of_inv_eq (p : f⁻¹ᶠ b = a) : b = f a :=
    (right_inv f b)⁻¹ ⬝ ap f p

    @[hott] def inv_eq_of_eq (p : b = f a) : f⁻¹ᶠ b = a :=
    ap f⁻¹ᶠ p ⬝ left_inv f a

    @[hott] def eq_inv_of_eq (p : f a = b) : a = f⁻¹ᶠ b :=
    (left_inv f a)⁻¹ ⬝ ap f⁻¹ᶠ p
  end rewrite_rules

  variable (f)

  section pre_compose
    variables (α : A → C) (β : B → C)

    @[hott] def homotopy_of_homotopy_inv_pre (p : β ~ α ∘ f⁻¹ᶠ) : β ∘ f ~ α :=
    λ a, p (f a) ⬝ ap α (left_inv f a)

    @[hott] def homotopy_of_inv_homotopy_pre (p : α ∘ f⁻¹ᶠ ~ β) : α ~ β ∘ f :=
    λ a, (ap α (left_inv f a))⁻¹ ⬝ p (f a)

    @[hott] def inv_homotopy_of_homotopy_pre (p : α ~ β ∘ f) : α ∘ f⁻¹ᶠ ~ β :=
    λ b, p (f⁻¹ᶠ b) ⬝ ap β (right_inv f b)

    @[hott] def homotopy_inv_of_homotopy_pre (p : β ∘ f ~ α) : β ~ α ∘ f⁻¹ᶠ  :=
    λ b, (ap β (right_inv f b))⁻¹ ⬝ p (f⁻¹ᶠ b)
  end pre_compose

  section post_compose
    variables (α : C → A) (β : C → B)

    @[hott] def homotopy_of_homotopy_inv_post (p : α ~ f⁻¹ᶠ ∘ β) : f ∘ α ~ β :=
    λ c, ap f (p c) ⬝ right_inv f (β c)

    @[hott] def homotopy_of_inv_homotopy_post (p : f⁻¹ᶠ ∘ β ~ α) : β ~ f ∘ α :=
    λ c, (right_inv f (β c))⁻¹ ⬝ ap f (p c)

    @[hott] def inv_homotopy_of_homotopy_post (p : β ~ f ∘ α) : f⁻¹ᶠ ∘ β ~ α :=
    λ c, ap f⁻¹ᶠ (p c) ⬝ left_inv f (α c)

    @[hott] def homotopy_inv_of_homotopy_post (p : f ∘ α ~ β) : α ~ f⁻¹ᶠ ∘ β :=
    λ c, (left_inv f (α c))⁻¹ ⬝ ap f⁻¹ᶠ (p c)
  end post_compose

  end

  --Transporting is an equivalence
  @[hott] def is_equiv_tr {A : Type u} (P : A → Type v) {x y : A}
    (p : x = y) : (is_equiv (transport P p)) :=
  is_equiv.mk _ (transport P p⁻¹) (tr_inv_tr p) (inv_tr_tr p) (tr_inv_tr_lemma p)

  -- a version where the transport is a cast. Note: A and B live in the same universe here.
  @[hott, instance] def is_equiv_cast {A B : Type _} (H : A = B) : is_equiv (cast H) :=
  is_equiv_tr (λX, X) H

  section
  variables {A : Type _} {B : A → Type _} {C : A → Type _} (f : Π{a}, B a → C a) [H : Πa, is_equiv (@f a)]
            {g : A → A} {g' : A → A} (h : Π{a}, B (g' a) → B (g a)) (h' : Π{a}, C (g' a) → C (g a))

  include H
  @[hott] def inv_commute' (p : Π⦃a : A⦄ (b : B (g' a)), f (h b) = h' (f b)) {a : A}
    (c : C (g' a)) : f⁻¹ᶠ (h' c) = h (f⁻¹ᶠ c) :=
  eq_of_fn_eq_fn' f (right_inv f (h' c) ⬝ ap h' (right_inv f c)⁻¹ ⬝ (p (f⁻¹ᶠ c))⁻¹)

  @[hott] def fun_commute_of_inv_commute' (p : Π⦃a : A⦄ (c : C (g' a)), f⁻¹ᶠ (h' c) = h (f⁻¹ᶠ c))
    {a : A} (b : B (g' a)) : f (h b) = h' (f b) :=
  eq_of_fn_eq_fn' f⁻¹ᶠ (left_inv f (h b) ⬝ ap h (left_inv f b)⁻¹ ⬝ (p (f b))⁻¹)

  @[hott] def ap_inv_commute' (p : Π⦃a : A⦄ (b : B (g' a)), f (h b) = h' (f b)) {a : A}
    (c : C (g' a)) : ap f (inv_commute' @f @h @h' p c)
                       = right_inv f (h' c) ⬝ ap h' (right_inv f c)⁻¹ ⬝ (p (f⁻¹ᶠ c))⁻¹ :=
  ap_eq_of_fn_eq_fn' _ _

  -- inv_commute'_fn is in types.equiv
  end

  -- This is inv_commute' for A ≡ unit
  @[hott] def inv_commute1' {B C : Type _} (f : B → C) [is_equiv f] (h : B → B) (h' : C → C)
    (p : Π(b : B), f (h b) = h' (f b)) (c : C) : f⁻¹ᶠ (h' c) = h (f⁻¹ᶠ c) :=
  eq_of_fn_eq_fn' f (right_inv f (h' c) ⬝ ap h' (right_inv f c)⁻¹ ⬝ (p (f⁻¹ᶠ c))⁻¹)

end is_equiv
open hott.is_equiv

namespace eq
  local attribute [instance] is_equiv_tr

  @[hott] def tr_inv_fn {A : Type _} {B : A → Type _} {a a' : A} (p : a = a') :
    transport B p⁻¹ = (transport B p)⁻¹ᶠ := idp
  @[hott] def tr_inv {A : Type _} {B : A → Type _} {a a' : A} (p : a = a') (b : B a') :
    p⁻¹ ▸ b = (transport B p)⁻¹ᶠ b := idp

  @[hott] def cast_inv_fn {A B : Type _} (p : A = B) : cast p⁻¹ = (cast p)⁻¹ᶠ := idp
  @[hott] def cast_inv {A B : Type _} (p : A = B) (b : B) : cast p⁻¹ b = (cast p)⁻¹ᶠ b := idp
end eq

infix ` ≃ `:25 := equiv
attribute [instance] equiv.to_is_equiv

namespace equiv
  section
  variables {A : Type u} {B : Type v} {C : Type w}

  instance: has_coe_to_fun (A ≃ B) := ⟨_, to_fun⟩

  @[hott, hsimp] def coe_equiv {A B : Type _} (e : A ≃ B) : ⇑e = e.to_fun :=
  idp

  open is_equiv

  @[hott, hsimp] protected def MK (f : A → B) (g : B → A)
    (right_inv : Πb, f (g b) = b) (left_inv : Πa, g (f a) = a) : A ≃ B :=
  equiv.mk f (adjointify f g right_inv left_inv)

  @[hott, hsimp, reducible] def to_inv (f : A ≃ B) : B → A := f.to_fun⁻¹ᶠ

  @[hott, hsimp] def to_right_inv (f : A ≃ B) (b : B) : f (f⁻¹ᶠ b) = b :=
  right_inv f b
  @[hott, hsimp] def to_left_inv (f : A ≃ B) (a : A) : f⁻¹ᶠ (f a) = a :=
  left_inv f a

  @[refl, hott, hsimp]
  protected def rfl : A ≃ A :=
  equiv.mk id (hott.is_equiv.is_equiv_id _)

  @[hott, reducible, hsimp]
  protected def refl (A : Type _) : A ≃ A :=
  @equiv.rfl A

  @[symm, hott]
  protected def symm (f : A ≃ B) : B ≃ A :=
  equiv.mk f⁻¹ᶠ (is_equiv.is_equiv_inv f)

  @[trans, hott]
  protected def trans (f : A ≃ B) (g : B ≃ C) : A ≃ C :=
  equiv.mk (g ∘ f) (is_equiv_compose _ _)

  infixl ` ⬝e `:75 := equiv.trans
  postfix `⁻¹ᵉ`:(max + 1) := equiv.symm
  @[reducible, hott] def erfl := @equiv.rfl

  @[hott, hsimp] def to_fun_symm (f : A ≃ B) (b : B) : f⁻¹ᵉ.to_fun b = to_inv f b :=
  by refl

  @[hott, hsimp] def to_inv_symm (f : A ≃ B) (a : A) : f⁻¹ᵉ.to_fun⁻¹ᶠ a = f a :=
  by refl

  @[hott, hsimp] def to_fun_trans (f : A ≃ B) (g : B ≃ C) (a : A) :
    (f ⬝e g).to_fun a = g (f a) :=
  by refl

  @[hott, hsimp] def to_inv_trans (f : A ≃ B) (g : B ≃ C) (c : C) :
    (f ⬝e g).to_fun⁻¹ᶠ c = f.to_fun⁻¹ᶠ (g.to_fun⁻¹ᶠ c) :=
  by refl

  @[hott] def is_equiv_to_inv (f : A ≃ B) : is_equiv f⁻¹ᶠ :=
  by apply_instance

  @[hott, hsimp] def equiv_change_fun (f : A ≃ B) {f' : A → B} (Heq : f ~ f') : A ≃ B :=
  equiv.mk f' (is_equiv.homotopy_closed f Heq)

  @[hott] def equiv_change_inv (f : A ≃ B) {f' : B → A} (Heq : f⁻¹ᶠ ~ f') : A ≃ B :=
  equiv.mk f (inv_homotopy_closed Heq)

  --rename: eq_equiv_fn_eq_fn_of_is_equiv
  @[hott] def eq_equiv_fn_eq (f : A → B) [H : is_equiv f] (a b : A) : (a = b) ≃ (f a = f b) :=
  equiv.mk (ap f) (is_equiv_ap _ _ _)

  --rename: eq_equiv_fn_eq_fn
  @[hott] def eq_equiv_fn_eq_of_equiv (f : A ≃ B) (a b : A) : (a = b) ≃ (f a = f b) :=
  equiv.mk (ap f) (is_equiv_ap _ _ _)

  @[hott] def equiv_ap (P : A → Type _) {a b : A} (p : a = b) : P a ≃ P b :=
  equiv.mk (transport P p) (is_equiv_tr _ _)

  @[hott] def equiv_of_eq {A B : Type u} (p : A = B) : A ≃ B :=
  equiv.mk (cast p) (is_equiv_tr id _)

  @[hott, hsimp] def equiv_of_eq_refl (A : Type _)
    : equiv_of_eq (refl A) = equiv.refl A :=
  idp

  @[hott] def eq_of_fn_eq_fn (f : A ≃ B) {x y : A} (q : f x = f y) : x = y :=
  (left_inv _ x)⁻¹ ⬝ ap f⁻¹ᶠ q ⬝ left_inv _ y

  @[hott] def eq_of_fn_eq_fn_inv (f : A ≃ B) {x y : B} (q : f⁻¹ᵉ x = f⁻¹ᵉ y) : x = y :=
  (right_inv _ x)⁻¹ ⬝ ap f q ⬝ right_inv f y

  @[hott] def ap_eq_of_fn_eq_fn (f : A ≃ B) {x y : A} (q : f x = f y) : ap f (eq_of_fn_eq_fn f q) = q :=
  ap_eq_of_fn_eq_fn' f q

  @[hott] def eq_of_fn_eq_fn_ap (f : A ≃ B) {x y : A} (q : x = y) : eq_of_fn_eq_fn f (ap f q) = q :=
  eq_of_fn_eq_fn'_ap f q

  @[hott] def to_inv_homotopy_inv {f g : A ≃ B} (p : f ~ g) : f⁻¹ᵉ ~ g⁻¹ᵉ :=
  inv_homotopy_inv p

  --we need this theorem for the funext_of_ua proof
  @[hott] theorem inv_eq {A B : Type _} (eqf eqg : A ≃ B) (p : eqf = eqg) : eqf⁻¹ᶠ = eqg⁻¹ᶠ :=
  eq.rec_on p idp

  @[trans, hott]
  def equiv_of_equiv_of_eq {A B C : Type _} (p : A = B) (q : B ≃ C) : A ≃ C :=
  equiv_of_eq p ⬝e q
  @[trans, hott]
  def equiv_of_eq_of_equiv {A B C : Type _} (p : A ≃ B) (q : B = C) : A ≃ C :=
  p ⬝e equiv_of_eq q

  @[hott] def equiv_ulift (A : Type _) : A ≃ ulift A := equiv.mk ulift.up (by apply_instance)

  @[hott] def equiv_rect (f : A ≃ B) (P : B → Type _) (g : Πa, P (f a)) (b : B) : P b :=
  right_inv f b ▸ g (f⁻¹ᶠ b)

  @[hott] def equiv_rect' (f : A ≃ B) (P : A → B → Type _) (g : Πb, P (f⁻¹ᶠ b) b) (a : A) : P a (f a) :=
  transport (λ x : A, P x (f a)) (left_inv f a) (g (f a))

  @[hott] def equiv_rect_comp (f : A ≃ B) (P : B → Type _)
      (df : Π (x : A), P (f x)) (x : A) : equiv_rect f P df (f x) = df x :=
    calc
      equiv_rect f P df (f x)
            = right_inv f (f x) ▸ df (f⁻¹ᶠ (f x))   : by refl
        ... = ap f (left_inv f x) ▸ df (f⁻¹ᶠ (f x)) : by rwr ← adj
        ... = transport (P∘f) (left_inv f x) (df (f⁻¹ᶠ (f x))) : by rwr tr_compose
        ... = df x                                 : by apply apdt df (left_inv f x)
  end

  section

  variables {A : Type _} {B : Type _} (f : A ≃ B) {a : A} {b : B}
  @[hott] def to_eq_of_eq_inv (p : a = f⁻¹ᶠ b) : f a = b :=
  ap f p ⬝ to_right_inv f b

  @[hott] def to_eq_of_inv_eq (p : f⁻¹ᶠ b = a) : b = f a :=
  (to_right_inv f b)⁻¹ ⬝ ap f p

  @[hott] def to_inv_eq_of_eq (p : b = f a) : f⁻¹ᶠ b = a :=
  ap _ p ⬝ left_inv f a

  @[hott] def to_eq_inv_of_eq (p : f a = b) : a = f⁻¹ᶠ b :=
  (left_inv f a)⁻¹ ⬝ ap _ p

  end

  section

  variables {A : Type _} {B : A → Type _} {C : A → Type _} (f : Π{a}, B a ≃ C a)
            {g : A → A} {g' : A → A} (h : Π{a}, B (g' a) → B (g a)) (h' : Π{a}, C (g' a) → C (g a))

  @[hott] def inv_commute (p : Π⦃a : A⦄ (b : B (g' a)), f.to_fun (h b) = h' (f.to_fun b)) {a : A}
    (c : C (g' a)) : f.to_inv (h' c) = h (f.to_inv c) :=
  @inv_commute' A B C (λ a, f.to_fun) _ g g' @h @h' p _ c

  @[hott] def fun_commute_of_inv_commute (p : Π⦃a : A⦄ (c : C (g' a)), f.to_inv (h' c) = h (f.to_inv c))
    {a : A} (b : B (g' a)) : f.to_fun (h b) = h' (f.to_fun b) :=
  @fun_commute_of_inv_commute' A B C (λ a, f.to_fun) _ g g' @h @h' p _ b

  @[hott] def inv_commute1 {B C : Type _} (f : B ≃ C) (h : B → B) (h' : C → C)
    (p : Π(b : B), f (h b) =   h' (f b)) (c : C) : f⁻¹ᶠ (h' c) = h (f⁻¹ᶠ c) :=
  inv_commute1' f h h' p c

  end

  infixl ` ⬝pe `:75 := equiv_of_equiv_of_eq
  infixl ` ⬝ep `:75 := equiv_of_eq_of_equiv

end equiv

open equiv
namespace is_equiv

  @[hott] def is_equiv_of_equiv_of_homotopy {A B : Type _} (f : A ≃ B)
    {f' : A → B} (Hty : f ~ f') : is_equiv f' :=
  @homotopy_closed _ _ f f' _ Hty

end is_equiv

end hott


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

! This file was ported from Lean 3 source module ring_theory.ideal.norm
! leanprover-community/mathlib commit d3acee0d776b15ffb8318f327325ff343cc8bdcc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.CharP.Quotient
import Mathbin.Data.Finsupp.Fintype
import Mathbin.Data.Int.AbsoluteValue
import Mathbin.Data.Int.Associated
import Mathbin.NumberTheory.RamificationInertia
import Mathbin.LinearAlgebra.FreeModule.Determinant
import Mathbin.LinearAlgebra.FreeModule.IdealQuotient
import Mathbin.RingTheory.DedekindDomain.Pid
import Mathbin.RingTheory.LocalProperties
import Mathbin.RingTheory.Localization.Norm

/-!

# Ideal norms

This file defines the absolute ideal norm `ideal.abs_norm (I : ideal R) : ℕ` as the cardinality of
the quotient `R ⧸ I` (setting it to 0 if the cardinality is infinite),
and the relative ideal norm `ideal.span_norm R (I : ideal S) : ideal S` as the ideal spanned by
the norms of elements in `I`.

## Main definitions

 * `submodule.card_quot (S : submodule R M)`: the cardinality of the quotient `M ⧸ S`, in `ℕ`.
   This maps `⊥` to `0` and `⊤` to `1`.
 * `ideal.abs_norm (I : ideal R)`: the absolute ideal norm, defined as
   the cardinality of the quotient `R ⧸ I`, as a bundled monoid-with-zero homomorphism.
 * `ideal.span_norm R (I : ideal S)`: the ideal spanned by the norms of elements in `I`.
    This is used to define `ideal.rel_norm`.
 * `ideal.rel_norm R (I : ideal S)`: the relative ideal norm as a bundled monoid-with-zero morphism,
   defined as the ideal spanned by the norms of elements in `I`.

## Main results

 * `map_mul ideal.abs_norm`: multiplicativity of the ideal norm is bundled in
   the definition of `ideal.abs_norm`
 * `ideal.nat_abs_det_basis_change`: the ideal norm is given by the determinant
   of the basis change matrix
 * `ideal.abs_norm_span_singleton`: the ideal norm of a principal ideal is the
   norm of its generator
 * `map_mul ideal.rel_norm`: multiplicativity of the relative ideal norm
-/

open BigOperators

open nonZeroDivisors

section AbsNorm

namespace Submodule

variable {R M : Type _} [Ring R] [AddCommGroup M] [Module R M]

section

/-- The cardinality of `(M ⧸ S)`, if `(M ⧸ S)` is finite, and `0` otherwise.
This is used to define the absolute ideal norm `ideal.abs_norm`.
-/
noncomputable def cardQuot (S : Submodule R M) : ℕ :=
  AddSubgroup.index S.toAddSubgroup
#align submodule.card_quot Submodule.cardQuot

@[simp]
theorem cardQuot_apply (S : Submodule R M) [Fintype (M ⧸ S)] : cardQuot S = Fintype.card (M ⧸ S) :=
  AddSubgroup.index_eq_card _
#align submodule.card_quot_apply Submodule.cardQuot_apply

variable (R M)

@[simp]
theorem cardQuot_bot [Infinite M] : cardQuot (⊥ : Submodule R M) = 0 :=
  AddSubgroup.index_bot.trans Nat.card_eq_zero_of_infinite
#align submodule.card_quot_bot Submodule.cardQuot_bot

@[simp]
theorem cardQuot_top : cardQuot (⊤ : Submodule R M) = 1 :=
  AddSubgroup.index_top
#align submodule.card_quot_top Submodule.cardQuot_top

variable {R M}

@[simp]
theorem cardQuot_eq_one_iff {P : Submodule R M} : cardQuot P = 1 ↔ P = ⊤ :=
  AddSubgroup.index_eq_one.trans (by simp [SetLike.ext_iff])
#align submodule.card_quot_eq_one_iff Submodule.cardQuot_eq_one_iff

end

end Submodule

section RingOfIntegers

variable {S : Type _} [CommRing S] [IsDomain S]

open Submodule

/-- Multiplicity of the ideal norm, for coprime ideals.
This is essentially just a repackaging of the Chinese Remainder Theorem.
-/
theorem cardQuot_mul_of_coprime [IsDedekindDomain S] [Module.Free ℤ S] [Module.Finite ℤ S]
    {I J : Ideal S} (coprime : I ⊔ J = ⊤) : cardQuot (I * J) = cardQuot I * cardQuot J :=
  by
  let b := Module.Free.chooseBasis ℤ S
  cases isEmpty_or_nonempty (Module.Free.ChooseBasisIndex ℤ S)
  · haveI : Subsingleton S := Function.Surjective.subsingleton b.repr.to_equiv.symm.surjective
    nontriviality S
    exfalso
    exact not_nontrivial_iff_subsingleton.mpr ‹Subsingleton S› ‹Nontrivial S›
  haveI : Infinite S := Infinite.of_surjective _ b.repr.to_equiv.surjective
  by_cases hI : I = ⊥
  · rw [hI, Submodule.bot_mul, card_quot_bot, MulZeroClass.zero_mul]
  by_cases hJ : J = ⊥
  · rw [hJ, Submodule.mul_bot, card_quot_bot, MulZeroClass.mul_zero]
  have hIJ : I * J ≠ ⊥ := mt ideal.mul_eq_bot.mp (not_or_of_not hI hJ)
  letI := Classical.decEq (Module.Free.ChooseBasisIndex ℤ S)
  letI := I.fintype_quotient_of_free_of_ne_bot hI
  letI := J.fintype_quotient_of_free_of_ne_bot hJ
  letI := (I * J).fintypeQuotientOfFreeOfNeBot hIJ
  rw [card_quot_apply, card_quot_apply, card_quot_apply,
    fintype.card_eq.mpr ⟨(Ideal.quotientMulEquivQuotientProd I J coprime).toEquiv⟩,
    Fintype.card_prod]
#align card_quot_mul_of_coprime cardQuot_mul_of_coprime

/-- If the `d` from `ideal.exists_mul_add_mem_pow_succ` is unique, up to `P`,
then so are the `c`s, up to `P ^ (i + 1)`.
Inspired by [Neukirch], proposition 6.1 -/
theorem Ideal.mul_add_mem_pow_succ_inj (P : Ideal S) {i : ℕ} (a d d' e e' : S) (a_mem : a ∈ P ^ i)
    (e_mem : e ∈ P ^ (i + 1)) (e'_mem : e' ∈ P ^ (i + 1)) (h : d - d' ∈ P) :
    a * d + e - (a * d' + e') ∈ P ^ (i + 1) :=
  by
  have : a * d - a * d' ∈ P ^ (i + 1) := by
    convert Ideal.mul_mem_mul a_mem h <;> simp [mul_sub, pow_succ, mul_comm]
  convert Ideal.add_mem _ this (Ideal.sub_mem _ e_mem e'_mem)
  ring
#align ideal.mul_add_mem_pow_succ_inj Ideal.mul_add_mem_pow_succ_inj

section PPrime

variable {P : Ideal S} [P_prime : P.IsPrime] (hP : P ≠ ⊥)

include P_prime hP

/-- If `a ∈ P^i \ P^(i+1)` and `c ∈ P^i`, then `a * d + e = c` for `e ∈ P^(i+1)`.
`ideal.mul_add_mem_pow_succ_unique` shows the choice of `d` is unique, up to `P`.
Inspired by [Neukirch], proposition 6.1 -/
theorem Ideal.exists_mul_add_mem_pow_succ [IsDedekindDomain S] {i : ℕ} (a c : S) (a_mem : a ∈ P ^ i)
    (a_not_mem : a ∉ P ^ (i + 1)) (c_mem : c ∈ P ^ i) : ∃ d : S, ∃ e ∈ P ^ (i + 1), a * d + e = c :=
  by
  suffices eq_b : P ^ i = Ideal.span {a} ⊔ P ^ (i + 1)
  · rw [eq_b] at c_mem
    simp only [mul_comm a]
    exact ideal.mem_span_singleton_sup.mp c_mem
  refine'
    (Ideal.eq_prime_pow_of_succ_lt_of_le hP (lt_of_le_of_ne le_sup_right _)
        (sup_le (ideal.span_le.mpr (set.singleton_subset_iff.mpr a_mem))
          (Ideal.pow_succ_lt_pow hP i).le)).symm
  contrapose! a_not_mem with this
  rw [this]
  exact mem_sup.mpr ⟨a, mem_span_singleton_self a, 0, by simp, by simp⟩
#align ideal.exists_mul_add_mem_pow_succ Ideal.exists_mul_add_mem_pow_succ

theorem Ideal.mem_prime_of_mul_mem_pow [IsDedekindDomain S] {P : Ideal S} [P_prime : P.IsPrime]
    (hP : P ≠ ⊥) {i : ℕ} {a b : S} (a_not_mem : a ∉ P ^ (i + 1)) (ab_mem : a * b ∈ P ^ (i + 1)) :
    b ∈ P :=
  by
  simp only [← Ideal.span_singleton_le_iff_mem, ← Ideal.dvd_iff_le, pow_succ, ←
    Ideal.span_singleton_mul_span_singleton] at a_not_mem ab_mem⊢
  exact (prime_pow_succ_dvd_mul (Ideal.prime_of_isPrime hP P_prime) ab_mem).resolve_left a_not_mem
#align ideal.mem_prime_of_mul_mem_pow Ideal.mem_prime_of_mul_mem_pow

/-- The choice of `d` in `ideal.exists_mul_add_mem_pow_succ` is unique, up to `P`.
Inspired by [Neukirch], proposition 6.1 -/
theorem Ideal.mul_add_mem_pow_succ_unique [IsDedekindDomain S] {i : ℕ} (a d d' e e' : S)
    (a_not_mem : a ∉ P ^ (i + 1)) (e_mem : e ∈ P ^ (i + 1)) (e'_mem : e' ∈ P ^ (i + 1))
    (h : a * d + e - (a * d' + e') ∈ P ^ (i + 1)) : d - d' ∈ P :=
  by
  have : e' - e ∈ P ^ (i + 1) := Ideal.sub_mem _ e'_mem e_mem
  have h' : a * (d - d') ∈ P ^ (i + 1) :=
    by
    convert Ideal.add_mem _ h (Ideal.sub_mem _ e'_mem e_mem)
    ring
  exact Ideal.mem_prime_of_mul_mem_pow hP a_not_mem h'
#align ideal.mul_add_mem_pow_succ_unique Ideal.mul_add_mem_pow_succ_unique

/-- Multiplicity of the ideal norm, for powers of prime ideals. -/
theorem cardQuot_pow_of_prime [IsDedekindDomain S] [Module.Finite ℤ S] [Module.Free ℤ S] {i : ℕ} :
    cardQuot (P ^ i) = cardQuot P ^ i :=
  by
  let b := Module.Free.chooseBasis ℤ S
  classical
    induction' i with i ih
    · simp
    letI := Ideal.fintypeQuotientOfFreeOfNeBot (P ^ i.succ) (pow_ne_zero _ hP)
    letI := Ideal.fintypeQuotientOfFreeOfNeBot (P ^ i) (pow_ne_zero _ hP)
    letI := Ideal.fintypeQuotientOfFreeOfNeBot P hP
    have : P ^ (i + 1) < P ^ i := Ideal.pow_succ_lt_pow hP i
    suffices hquot : map (P ^ i.succ).mkQ (P ^ i) ≃ S ⧸ P
    · rw [pow_succ (card_quot P), ← ih, card_quot_apply (P ^ i.succ), ←
        card_quotient_mul_card_quotient (P ^ i) (P ^ i.succ) this.le, card_quot_apply (P ^ i),
        card_quot_apply P]
      congr 1
      rw [Fintype.card_eq]
      exact ⟨hquot⟩
    choose a a_mem a_not_mem using SetLike.exists_of_lt this
    choose f g hg hf using fun c (hc : c ∈ P ^ i) =>
      Ideal.exists_mul_add_mem_pow_succ hP a c a_mem a_not_mem hc
    choose k hk_mem hk_eq using fun c' (hc' : c' ∈ map (mkq (P ^ i.succ)) (P ^ i)) =>
      submodule.mem_map.mp hc'
    refine'
      Equiv.ofBijective (fun c' => Quotient.mk'' (f (k c' c'.Prop) (hk_mem c' c'.Prop))) ⟨_, _⟩
    · rintro ⟨c₁', hc₁'⟩ ⟨c₂', hc₂'⟩ h
      rw [Subtype.mk_eq_mk, ← hk_eq _ hc₁', ← hk_eq _ hc₂', mkq_apply, mkq_apply,
        Submodule.Quotient.eq, ← hf _ (hk_mem _ hc₁'), ← hf _ (hk_mem _ hc₂')]
      refine' Ideal.mul_add_mem_pow_succ_inj _ _ _ _ _ _ a_mem (hg _ _) (hg _ _) _
      simpa only [Submodule.Quotient.mk''_eq_mk, Submodule.Quotient.mk''_eq_mk,
        Submodule.Quotient.eq] using h
    · intro d'
      refine' Quotient.inductionOn' d' fun d => _
      have hd' := mem_map.mpr ⟨a * d, Ideal.mul_mem_right d _ a_mem, rfl⟩
      refine' ⟨⟨_, hd'⟩, _⟩
      simp only [Submodule.Quotient.mk''_eq_mk, Ideal.Quotient.mk_eq_mk, Ideal.Quotient.eq,
        Subtype.coe_mk]
      refine'
        Ideal.mul_add_mem_pow_succ_unique hP a _ _ _ _ a_not_mem (hg _ (hk_mem _ hd')) (zero_mem _)
          _
      rw [hf, add_zero]
      exact (Submodule.Quotient.eq _).mp (hk_eq _ hd')
#align card_quot_pow_of_prime cardQuot_pow_of_prime

end PPrime

/-- Multiplicativity of the ideal norm in number rings. -/
theorem cardQuot_mul [IsDedekindDomain S] [Module.Free ℤ S] [Module.Finite ℤ S] (I J : Ideal S) :
    cardQuot (I * J) = cardQuot I * cardQuot J :=
  by
  let b := Module.Free.chooseBasis ℤ S
  cases isEmpty_or_nonempty (Module.Free.ChooseBasisIndex ℤ S)
  · haveI : Subsingleton S := Function.Surjective.subsingleton b.repr.to_equiv.symm.surjective
    nontriviality S
    exfalso
    exact not_nontrivial_iff_subsingleton.mpr ‹Subsingleton S› ‹Nontrivial S›
  haveI : Infinite S := Infinite.of_surjective _ b.repr.to_equiv.surjective
  exact
    UniqueFactorizationMonoid.multiplicative_of_coprime card_quot I J (card_quot_bot _ _)
      (fun I J hI => by simp [ideal.is_unit_iff.mp hI, Ideal.mul_top])
      (fun I i hI =>
        have : Ideal.IsPrime I := Ideal.isPrime_of_prime hI
        cardQuot_pow_of_prime hI.ne_zero)
      fun I J hIJ =>
      cardQuot_mul_of_coprime
        (ideal.is_unit_iff.mp
          (hIJ _ (ideal.dvd_iff_le.mpr le_sup_left) (ideal.dvd_iff_le.mpr le_sup_right)))
#align card_quot_mul cardQuot_mul

/-- The absolute norm of the ideal `I : ideal R` is the cardinality of the quotient `R ⧸ I`. -/
noncomputable def Ideal.absNorm [Infinite S] [IsDedekindDomain S] [Module.Free ℤ S]
    [Module.Finite ℤ S] : Ideal S →*₀ ℕ
    where
  toFun := Submodule.cardQuot
  map_mul' I J := by rw [cardQuot_mul]
  map_one' := by rw [Ideal.one_eq_top, card_quot_top]
  map_zero' := by rw [Ideal.zero_eq_bot, card_quot_bot]
#align ideal.abs_norm Ideal.absNorm

namespace Ideal

variable [Infinite S] [IsDedekindDomain S] [Module.Free ℤ S] [Module.Finite ℤ S]

theorem absNorm_apply (I : Ideal S) : absNorm I = cardQuot I :=
  rfl
#align ideal.abs_norm_apply Ideal.absNorm_apply

@[simp]
theorem absNorm_bot : absNorm (⊥ : Ideal S) = 0 := by rw [← Ideal.zero_eq_bot, _root_.map_zero]
#align ideal.abs_norm_bot Ideal.absNorm_bot

@[simp]
theorem absNorm_top : absNorm (⊤ : Ideal S) = 1 := by rw [← Ideal.one_eq_top, _root_.map_one]
#align ideal.abs_norm_top Ideal.absNorm_top

@[simp]
theorem absNorm_eq_one_iff {I : Ideal S} : absNorm I = 1 ↔ I = ⊤ := by
  rw [abs_norm_apply, card_quot_eq_one_iff]
#align ideal.abs_norm_eq_one_iff Ideal.absNorm_eq_one_iff

theorem absNorm_ne_zero_iff (I : Ideal S) : Ideal.absNorm I ≠ 0 ↔ Finite (S ⧸ I) :=
  ⟨fun h => Nat.finite_of_card_ne_zero h, fun h =>
    (@AddSubgroup.finiteIndex_of_finite_quotient _ _ _ h).FiniteIndex⟩
#align ideal.abs_norm_ne_zero_iff Ideal.absNorm_ne_zero_iff

/-- Let `e : S ≃ I` be an additive isomorphism (therefore a `ℤ`-linear equiv).
Then an alternative way to compute the norm of `I` is given by taking the determinant of `e`.
See `nat_abs_det_basis_change` for a more familiar formulation of this result. -/
theorem natAbs_det_equiv (I : Ideal S) {E : Type _} [AddEquivClass E S I] (e : E) :
    Int.natAbs
        (LinearMap.det
          ((Submodule.subtype I).restrictScalars ℤ ∘ₗ AddMonoidHom.toIntLinearMap (e : S →+ I))) =
      Ideal.absNorm I :=
  by
  -- `S ⧸ I` might be infinite if `I = ⊥`, but then `e` can't be an equiv.
  by_cases hI : I = ⊥
  · subst hI
    have : (1 : S) ≠ 0 := one_ne_zero
    have : (1 : S) = 0 := EquivLike.injective e (Subsingleton.elim _ _)
    contradiction
  let ι := Module.Free.ChooseBasisIndex ℤ S
  let b := Module.Free.chooseBasis ℤ S
  cases isEmpty_or_nonempty ι
  · nontriviality S
    exact
      (not_nontrivial_iff_subsingleton.mpr
          (Function.Surjective.subsingleton b.repr.to_equiv.symm.surjective)
          (by infer_instance)).elim
  -- Thus `(S ⧸ I)` is isomorphic to a product of `zmod`s, so it is a fintype.
  letI := Ideal.fintypeQuotientOfFreeOfNeBot I hI
  -- Use the Smith normal form to choose a nice basis for `I`.
  letI := Classical.decEq ι
  let a := I.smith_coeffs b hI
  let b' := I.ring_basis b hI
  let ab := I.self_basis b hI
  have ab_eq := I.self_basis_def b hI
  let e' : S ≃ₗ[ℤ] I := b'.equiv ab (Equiv.refl _)
  let f : S →ₗ[ℤ] S := (I.subtype.restrict_scalars ℤ).comp (e' : S →ₗ[ℤ] I)
  let f_apply : ∀ x, f x = b'.equiv ab (Equiv.refl _) x := fun x => rfl
  suffices (LinearMap.det f).natAbs = Ideal.absNorm I by
    calc
      (LinearMap.det ((Submodule.subtype I).restrictScalars ℤ ∘ₗ _)).natAbs =
          (LinearMap.det
              ((Submodule.subtype I).restrictScalars ℤ ∘ₗ
                (↑(AddEquiv.toIntLinearEquiv ↑e) : S →ₗ[ℤ] I))).natAbs :=
        rfl
      _ = (LinearMap.det ((Submodule.subtype I).restrictScalars ℤ ∘ₗ _)).natAbs :=
        (int.nat_abs_eq_iff_associated.mpr (LinearMap.associated_det_comp_equiv _ _ _))
      _ = abs_norm I := this

  have ha : ∀ i, f (b' i) = a i • b' i := by
    intro i
    rw [f_apply, b'.equiv_apply, Equiv.refl_apply, ab_eq]
  have mem_I_iff : ∀ x, x ∈ I ↔ ∀ i, a i ∣ b'.repr x i :=
    by
    intro x
    simp_rw [ab.mem_ideal_iff', ab_eq]
    have : ∀ (c : ι → ℤ) (i), b'.repr (∑ j : ι, c j • a j • b' j) i = a i * c i :=
      by
      intro c i
      simp only [← MulAction.mul_smul, b'.repr_sum_self, mul_comm]
    constructor
    · rintro ⟨c, rfl⟩ i
      exact ⟨c i, this c i⟩
    · rintro ha
      choose c hc using ha
      exact ⟨c, b'.ext_elem fun i => trans (hc i) (this c i).symm⟩
  -- `det f` is equal to `∏ i, a i`,
  letI := Classical.decEq ι
  calc
    Int.natAbs (LinearMap.det f) = Int.natAbs (LinearMap.toMatrix b' b' f).det := by
      rw [LinearMap.det_toMatrix]
    _ = Int.natAbs (Matrix.diagonal a).det := _
    _ = Int.natAbs (∏ i, a i) := by rw [Matrix.det_diagonal]
    _ = ∏ i, Int.natAbs (a i) := (map_prod Int.natAbsHom a Finset.univ)
    _ = Fintype.card (S ⧸ I) := _
    _ = abs_norm I := (Submodule.cardQuot_apply _).symm

  -- since `linear_map.to_matrix b' b' f` is the diagonal matrix with `a` along the diagonal.
  · congr
    ext (i j)
    rw [LinearMap.toMatrix_apply, ha, LinearEquiv.map_smul, Basis.repr_self, Finsupp.smul_single,
      smul_eq_mul, mul_one]
    by_cases h : i = j
    · rw [h, Matrix.diagonal_apply_eq, Finsupp.single_eq_same]
    · rw [Matrix.diagonal_apply_ne _ h, Finsupp.single_eq_of_ne (Ne.symm h)]
  -- Now we map everything through the linear equiv `S ≃ₗ (ι → ℤ)`,
  -- which maps `(S ⧸ I)` to `Π i, zmod (a i).nat_abs`.
  haveI : ∀ i, NeZero (a i).natAbs := fun i =>
    ⟨Int.natAbs_ne_zero_of_ne_zero (Ideal.smithCoeffs_ne_zero b I hI i)⟩
  simp_rw [fintype.card_eq.mpr ⟨(Ideal.quotientEquivPiZmod I b hI).toEquiv⟩, Fintype.card_pi,
    ZMod.card]
#align ideal.nat_abs_det_equiv Ideal.natAbs_det_equiv

/-- Let `b` be a basis for `S` over `ℤ` and `bI` a basis for `I` over `ℤ` of the same dimension.
Then an alternative way to compute the norm of `I` is given by taking the determinant of `bI`
over `b`. -/
theorem natAbs_det_basis_change {ι : Type _} [Fintype ι] [DecidableEq ι] (b : Basis ι ℤ S)
    (I : Ideal S) (bI : Basis ι ℤ I) : (b.det (coe ∘ bI)).natAbs = Ideal.absNorm I :=
  by
  let e := b.equiv bI (Equiv.refl _)
  calc
    (b.det ((Submodule.subtype I).restrictScalars ℤ ∘ bI)).natAbs =
        (LinearMap.det ((Submodule.subtype I).restrictScalars ℤ ∘ₗ (e : S →ₗ[ℤ] I))).natAbs :=
      by rw [Basis.det_comp_basis]
    _ = _ := nat_abs_det_equiv I e

#align ideal.nat_abs_det_basis_change Ideal.natAbs_det_basis_change

@[simp]
theorem absNorm_span_singleton (r : S) : absNorm (span ({r} : Set S)) = (Algebra.norm ℤ r).natAbs :=
  by
  rw [Algebra.norm_apply]
  by_cases hr : r = 0
  ·
    simp only [hr, Ideal.span_zero, LinearMap.Algebra.coe_lmul_eq_mul, eq_self_iff_true,
      Ideal.absNorm_bot, LinearMap.det_zero'', Set.singleton_zero, _root_.map_zero, Int.natAbs_zero]
  letI := Ideal.fintypeQuotientOfFreeOfNeBot (span {r}) (mt span_singleton_eq_bot.mp hr)
  let b := Module.Free.chooseBasis ℤ S
  rw [← nat_abs_det_equiv _ (b.equiv (basis_span_singleton b hr) (Equiv.refl _))]
  swap; infer_instance
  congr
  refine' b.ext fun i => _
  simp
#align ideal.abs_norm_span_singleton Ideal.absNorm_span_singleton

theorem absNorm_dvd_absNorm_of_le {I J : Ideal S} (h : J ≤ I) : I.absNorm ∣ J.absNorm :=
  map_dvd absNorm (dvd_iff_le.mpr h)
#align ideal.abs_norm_dvd_abs_norm_of_le Ideal.absNorm_dvd_absNorm_of_le

theorem absNorm_dvd_norm_of_mem {I : Ideal S} {x : S} (h : x ∈ I) : ↑I.absNorm ∣ Algebra.norm ℤ x :=
  by
  rw [← Int.dvd_natAbs, ← abs_norm_span_singleton x, Int.coe_nat_dvd]
  exact abs_norm_dvd_abs_norm_of_le ((span_singleton_le_iff_mem _).mpr h)
#align ideal.abs_norm_dvd_norm_of_mem Ideal.absNorm_dvd_norm_of_mem

@[simp]
theorem absNorm_span_insert (r : S) (s : Set S) :
    absNorm (span (insert r s)) ∣ gcd (absNorm (span s)) (Algebra.norm ℤ r).natAbs :=
  (dvd_gcd_iff _ _ _).mpr
    ⟨absNorm_dvd_absNorm_of_le (span_mono (Set.subset_insert _ _)),
      trans
        (absNorm_dvd_absNorm_of_le (span_mono (Set.singleton_subset_iff.mpr (Set.mem_insert _ _))))
        (by rw [abs_norm_span_singleton])⟩
#align ideal.abs_norm_span_insert Ideal.absNorm_span_insert

theorem irreducible_of_irreducible_absNorm {I : Ideal S} (hI : Irreducible I.absNorm) :
    Irreducible I :=
  irreducible_iff.mpr
    ⟨fun h =>
      hI.not_unit (by simpa only [Ideal.isUnit_iff, Nat.isUnit_iff, abs_norm_eq_one_iff] using h),
      by
      rintro a b rfl <;>
        simpa only [Ideal.isUnit_iff, Nat.isUnit_iff, abs_norm_eq_one_iff] using
          hI.is_unit_or_is_unit (_root_.map_mul abs_norm a b)⟩
#align ideal.irreducible_of_irreducible_abs_norm Ideal.irreducible_of_irreducible_absNorm

theorem isPrime_of_irreducible_absNorm {I : Ideal S} (hI : Irreducible I.absNorm) : I.IsPrime :=
  isPrime_of_prime
    (UniqueFactorizationMonoid.irreducible_iff_prime.mp (irreducible_of_irreducible_absNorm hI))
#align ideal.is_prime_of_irreducible_abs_norm Ideal.isPrime_of_irreducible_absNorm

theorem prime_of_irreducible_absNorm_span {a : S} (ha : a ≠ 0)
    (hI : Irreducible (Ideal.span ({a} : Set S)).absNorm) : Prime a :=
  (Ideal.span_singleton_prime ha).mp (isPrime_of_irreducible_absNorm hI)
#align ideal.prime_of_irreducible_abs_norm_span Ideal.prime_of_irreducible_absNorm_span

theorem absNorm_mem (I : Ideal S) : ↑I.absNorm ∈ I := by
  rw [abs_norm_apply, card_quot, ← Ideal.Quotient.eq_zero_iff_mem, map_natCast,
    quotient.index_eq_zero]
#align ideal.abs_norm_mem Ideal.absNorm_mem

theorem span_singleton_absNorm_le (I : Ideal S) : Ideal.span {(Ideal.absNorm I : S)} ≤ I := by
  simp only [Ideal.span_le, Set.singleton_subset_iff, SetLike.mem_coe, Ideal.absNorm_mem I]
#align ideal.span_singleton_abs_norm_le Ideal.span_singleton_absNorm_le

theorem finite_setOf_absNorm_eq [CharZero S] {n : ℕ} (hn : 0 < n) :
    { I : Ideal S | Ideal.absNorm I = n }.Finite :=
  by
  let f := fun I : Ideal S => Ideal.map (Ideal.Quotient.mk (@Ideal.span S _ {n})) I
  refine' @Set.Finite.of_finite_image _ _ _ f _ _
  · suffices Finite (S ⧸ @Ideal.span S _ {n})
      by
      let g := (coe : Ideal (S ⧸ @Ideal.span S _ {n}) → Set (S ⧸ @Ideal.span S _ {n}))
      refine' @Set.Finite.of_finite_image _ _ _ g _ (set_like.coe_injective.inj_on _)
      exact Set.Finite.subset (@Set.finite_univ _ (@Set.finite' _ this)) (Set.subset_univ _)
    rw [← abs_norm_ne_zero_iff, abs_norm_span_singleton]
    simpa only [Ne.def, Int.natAbs_eq_zero, Algebra.norm_eq_zero_iff, Nat.cast_eq_zero] using
      ne_of_gt hn
  · intro I hI J hJ h
    rw [← comap_map_mk (span_singleton_abs_norm_le I), ← hI.symm, ←
      comap_map_mk (span_singleton_abs_norm_le J), ← hJ.symm]
    exact congr_arg (Ideal.comap (Ideal.Quotient.mk (@Ideal.span S _ {n}))) h
#align ideal.finite_set_of_abs_norm_eq Ideal.finite_setOf_absNorm_eq

end Ideal

end RingOfIntegers

end AbsNorm

section SpanNorm

namespace Ideal

open Submodule

variable (R : Type _) [CommRing R] {S : Type _} [CommRing S] [Algebra R S]

/-- `ideal.span_norm R (I : ideal S)` is the ideal generated by mapping `algebra.norm R` over `I`.

See also `ideal.rel_norm`.
-/
def spanNorm (I : Ideal S) : Ideal R :=
  Ideal.span (Algebra.norm R '' (I : Set S))
#align ideal.span_norm Ideal.spanNorm

@[simp]
theorem spanNorm_bot [Nontrivial S] [Module.Free R S] [Module.Finite R S] :
    spanNorm R (⊥ : Ideal S) = ⊥ :=
  span_eq_bot.mpr fun x hx => by simpa using hx
#align ideal.span_norm_bot Ideal.spanNorm_bot

variable {R}

@[simp]
theorem spanNorm_eq_bot_iff [IsDomain R] [IsDomain S] [Module.Free R S] [Module.Finite R S]
    {I : Ideal S} : spanNorm R I = ⊥ ↔ I = ⊥ :=
  by
  simp only [span_norm, Ideal.span_eq_bot, Set.mem_image, SetLike.mem_coe, forall_exists_index,
    and_imp, forall_apply_eq_imp_iff₂,
    Algebra.norm_eq_zero_iff_of_basis (Module.Free.chooseBasis R S), @eq_bot_iff _ _ _ I,
    SetLike.le_def]
  rfl
#align ideal.span_norm_eq_bot_iff Ideal.spanNorm_eq_bot_iff

variable (R)

theorem norm_mem_spanNorm {I : Ideal S} (x : S) (hx : x ∈ I) : Algebra.norm R x ∈ I.spanNorm R :=
  subset_span (Set.mem_image_of_mem _ hx)
#align ideal.norm_mem_span_norm Ideal.norm_mem_spanNorm

@[simp]
theorem spanNorm_singleton {r : S} : spanNorm R (span ({r} : Set S)) = span {Algebra.norm R r} :=
  le_antisymm
    (span_le.mpr fun x hx =>
      mem_span_singleton.mpr
        (by
          obtain ⟨x, hx', rfl⟩ := (Set.mem_image _ _ _).mp hx
          exact map_dvd _ (mem_span_singleton.mp hx')))
    ((span_singleton_le_iff_mem _).mpr (norm_mem_spanNorm _ _ (mem_span_singleton_self _)))
#align ideal.span_norm_singleton Ideal.spanNorm_singleton

@[simp]
theorem spanNorm_top : spanNorm R (⊤ : Ideal S) = ⊤ := by simp [← Ideal.span_singleton_one]
#align ideal.span_norm_top Ideal.spanNorm_top

theorem map_spanNorm (I : Ideal S) {T : Type _} [CommRing T] (f : R →+* T) :
    map f (spanNorm R I) = span (f ∘ Algebra.norm R '' (I : Set S)) := by
  rw [span_norm, map_span, Set.image_image]
#align ideal.map_span_norm Ideal.map_spanNorm

@[mono]
theorem spanNorm_mono {I J : Ideal S} (h : I ≤ J) : spanNorm R I ≤ spanNorm R J :=
  Ideal.span_mono (Set.monotone_image h)
#align ideal.span_norm_mono Ideal.spanNorm_mono

theorem spanNorm_localization (I : Ideal S) [Module.Finite R S] [Module.Free R S] (M : Submonoid R)
    {Rₘ : Type _} (Sₘ : Type _) [CommRing Rₘ] [Algebra R Rₘ] [CommRing Sₘ] [Algebra S Sₘ]
    [Algebra Rₘ Sₘ] [Algebra R Sₘ] [IsScalarTower R Rₘ Sₘ] [IsScalarTower R S Sₘ]
    [IsLocalization M Rₘ] [IsLocalization (Algebra.algebraMapSubmonoid S M) Sₘ] :
    spanNorm Rₘ (I.map (algebraMap S Sₘ)) = (spanNorm R I).map (algebraMap R Rₘ) :=
  by
  cases h : subsingleton_or_nontrivial R
  · haveI := IsLocalization.unique R Rₘ M
    simp
  let b := Module.Free.chooseBasis R S
  rw [map_span_norm]
  refine' span_eq_span (set.image_subset_iff.mpr _) (set.image_subset_iff.mpr _)
  · rintro a' ha'
    simp only [Set.mem_preimage, submodule_span_eq, ← map_span_norm, SetLike.mem_coe,
      IsLocalization.mem_map_algebraMap_iff (Algebra.algebraMapSubmonoid S M) Sₘ,
      IsLocalization.mem_map_algebraMap_iff M Rₘ, Prod.exists] at ha'⊢
    obtain ⟨⟨a, ha⟩, ⟨_, ⟨s, hs, rfl⟩⟩, has⟩ := ha'
    refine'
      ⟨⟨Algebra.norm R a, norm_mem_span_norm _ _ ha⟩,
        ⟨s ^ Fintype.card (Module.Free.ChooseBasisIndex R S), pow_mem hs _⟩, _⟩
    swap
    simp only [Submodule.coe_mk, Subtype.coe_mk, map_pow] at has⊢
    apply_fun Algebra.norm Rₘ  at has
    rwa [_root_.map_mul, ← IsScalarTower.algebraMap_apply, IsScalarTower.algebraMap_apply R Rₘ,
      Algebra.norm_algebraMap_of_basis (b.localization_localization Rₘ M Sₘ),
      Algebra.norm_localization R M a] at has
    all_goals infer_instance
  · intro a ha
    rw [Set.mem_preimage, Function.comp_apply, ← Algebra.norm_localization R M a]
    exact subset_span (Set.mem_image_of_mem _ (mem_map_of_mem _ ha))
    all_goals infer_instance
#align ideal.span_norm_localization Ideal.spanNorm_localization

theorem spanNorm_mul_spanNorm_le (I J : Ideal S) :
    spanNorm R I * spanNorm R J ≤ spanNorm R (I * J) :=
  by
  rw [span_norm, span_norm, span_norm, Ideal.span_mul_span', ← Set.image_mul]
  refine' Ideal.span_mono (Set.monotone_image _)
  rintro _ ⟨x, y, hxI, hyJ, rfl⟩
  exact Ideal.mul_mem_mul hxI hyJ
#align ideal.span_norm_mul_span_norm_le Ideal.spanNorm_mul_spanNorm_le

/-- This condition `eq_bot_or_top` is equivalent to being a field.
However, `span_norm_mul_of_field` is harder to apply since we'd need to upgrade a `comm_ring R`
instance to a `field R` instance. -/
theorem spanNorm_mul_of_bot_or_top [IsDomain R] [IsDomain S] [Module.Free R S] [Module.Finite R S]
    (eq_bot_or_top : ∀ I : Ideal R, I = ⊥ ∨ I = ⊤) (I J : Ideal S) :
    spanNorm R (I * J) = spanNorm R I * spanNorm R J :=
  by
  refine' le_antisymm _ (span_norm_mul_span_norm_le _ _ _)
  cases' eq_bot_or_top (span_norm R I) with hI hI
  · rw [hI, span_norm_eq_bot_iff.mp hI, bot_mul, span_norm_bot]
    exact bot_le
  rw [hI, Ideal.top_mul]
  cases' eq_bot_or_top (span_norm R J) with hJ hJ
  · rw [hJ, span_norm_eq_bot_iff.mp hJ, mul_bot, span_norm_bot]
    exact bot_le
  rw [hJ]
  exact le_top
#align ideal.span_norm_mul_of_bot_or_top Ideal.spanNorm_mul_of_bot_or_top

@[simp]
theorem spanNorm_mul_of_field {K : Type _} [Field K] [Algebra K S] [IsDomain S] [Module.Finite K S]
    (I J : Ideal S) : spanNorm K (I * J) = spanNorm K I * spanNorm K J :=
  spanNorm_mul_of_bot_or_top K eq_bot_or_top I J
#align ideal.span_norm_mul_of_field Ideal.spanNorm_mul_of_field

variable [IsDomain R] [IsDomain S] [IsDedekindDomain R] [IsDedekindDomain S]

variable [Module.Finite R S] [Module.Free R S]

/-- Multiplicativity of `ideal.span_norm`. simp-normal form is `map_mul (ideal.rel_norm R)`. -/
theorem spanNorm_mul (I J : Ideal S) : spanNorm R (I * J) = spanNorm R I * spanNorm R J :=
  by
  nontriviality R
  cases subsingleton_or_nontrivial S
  · have : ∀ I : Ideal S, I = ⊤ := fun I => Subsingleton.elim I ⊤
    simp [this I, this J, this (I * J)]
  refine' eq_of_localization_maximal _
  intro P hP
  by_cases hP0 : P = ⊥
  · subst hP0
    rw [span_norm_mul_of_bot_or_top]
    intro I
    refine' or_iff_not_imp_right.mpr fun hI => _
    exact (hP.eq_of_le hI bot_le).symm
  let P' := Algebra.algebraMapSubmonoid S P.prime_compl
  letI : Algebra (Localization.AtPrime P) (Localization P') := localizationAlgebra P.prime_compl S
  haveI : IsScalarTower R (Localization.AtPrime P) (Localization P') :=
    IsScalarTower.of_algebraMap_eq fun x => (IsLocalization.map_eq _ _).symm
  have h : P' ≤ S⁰ :=
    map_le_nonZeroDivisors_of_injective _ (NoZeroSMulDivisors.algebraMap_injective _ _)
      P.prime_compl_le_non_zero_divisors
  haveI : IsDomain (Localization P') := IsLocalization.isDomain_localization h
  haveI : IsDedekindDomain (Localization P') := IsLocalization.isDedekindDomain S h _
  letI := Classical.decEq (Ideal (Localization P'))
  haveI : IsPrincipalIdealRing (Localization P') :=
    IsDedekindDomain.isPrincipalIdealRing_localization_over_prime S P hP0
  rw [Ideal.map_mul, ← span_norm_localization R I P.prime_compl (Localization P'), ←
    span_norm_localization R J P.prime_compl (Localization P'), ←
    span_norm_localization R (I * J) P.prime_compl (Localization P'), Ideal.map_mul, ←
    (I.map _).span_singleton_generator, ← (J.map _).span_singleton_generator,
    span_singleton_mul_span_singleton, span_norm_singleton, span_norm_singleton,
    span_norm_singleton, span_singleton_mul_span_singleton, _root_.map_mul]
  repeat' infer_instance
  repeat' assumption
#align ideal.span_norm_mul Ideal.spanNorm_mul

/-- The relative norm `ideal.rel_norm R (I : ideal S)`, where `R` and `S` are Dedekind domains,
and `S` is an extension of `R` that is finite and free as a module. -/
def relNorm : Ideal S →*₀ Ideal R where
  toFun := spanNorm R
  map_zero' := spanNorm_bot R
  map_one' := by rw [one_eq_top, span_norm_top R, one_eq_top]
  map_mul' := spanNorm_mul R
#align ideal.rel_norm Ideal.relNorm

theorem relNorm_apply (I : Ideal S) : relNorm R I = span (Algebra.norm R '' (I : Set S) : Set R) :=
  rfl
#align ideal.rel_norm_apply Ideal.relNorm_apply

@[simp]
theorem spanNorm_eq (I : Ideal S) : spanNorm R I = relNorm R I :=
  rfl
#align ideal.span_norm_eq Ideal.spanNorm_eq

@[simp]
theorem relNorm_bot : relNorm R (⊥ : Ideal S) = ⊥ := by
  simpa only [zero_eq_bot] using map_zero (rel_norm R : Ideal S →*₀ _)
#align ideal.rel_norm_bot Ideal.relNorm_bot

@[simp]
theorem relNorm_top : relNorm R (⊤ : Ideal S) = ⊤ := by
  simpa only [one_eq_top] using map_one (rel_norm R : Ideal S →*₀ _)
#align ideal.rel_norm_top Ideal.relNorm_top

variable {R}

@[simp]
theorem relNorm_eq_bot_iff {I : Ideal S} : relNorm R I = ⊥ ↔ I = ⊥ :=
  spanNorm_eq_bot_iff
#align ideal.rel_norm_eq_bot_iff Ideal.relNorm_eq_bot_iff

variable (R)

theorem norm_mem_relNorm (I : Ideal S) {x : S} (hx : x ∈ I) : Algebra.norm R x ∈ relNorm R I :=
  norm_mem_spanNorm R x hx
#align ideal.norm_mem_rel_norm Ideal.norm_mem_relNorm

@[simp]
theorem relNorm_singleton (r : S) : relNorm R (span ({r} : Set S)) = span {Algebra.norm R r} :=
  spanNorm_singleton R
#align ideal.rel_norm_singleton Ideal.relNorm_singleton

theorem map_relNorm (I : Ideal S) {T : Type _} [CommRing T] (f : R →+* T) :
    map f (relNorm R I) = span (f ∘ Algebra.norm R '' (I : Set S)) :=
  map_spanNorm R I f
#align ideal.map_rel_norm Ideal.map_relNorm

@[mono]
theorem relNorm_mono {I J : Ideal S} (h : I ≤ J) : relNorm R I ≤ relNorm R J :=
  spanNorm_mono R h
#align ideal.rel_norm_mono Ideal.relNorm_mono

end Ideal

end SpanNorm


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton
-/
import topology.category.Top.adjunctions
import category_theory.epi_mono

/-!
# Epi- and monomorphisms in `Top`

This file shows that a continuous function is an epimorphism in the category of topological spaces
if and only if it is surjective, and that a continuous function is a monomorphism in the category of
topological spaces if and only if it is injective.
-/

universe u

open category_theory
open Top

namespace Top

lemma epi_iff_surjective {X Y : Top.{u}} (f : X ⟶ Y) : epi f ↔ function.surjective f :=
begin
  suffices : epi f ↔ epi ((forget Top).map f),
  { rw [this, category_theory.epi_iff_surjective], refl },
  split,
  { apply left_adjoint_preserves_epi adj₂ },
  { apply faithful_reflects_epi }
end

lemma mono_iff_injective {X Y : Top.{u}} (f : X ⟶ Y) : mono f ↔ function.injective f :=
begin
  suffices : mono f ↔ mono ((forget Top).map f),
  { rw [this, category_theory.mono_iff_injective], refl },
  split,
  { apply right_adjoint_preserves_mono adj₁ },
  { apply faithful_reflects_mono }
end

end Top


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta

! This file was ported from Lean 3 source module category_theory.pempty
! leanprover-community/mathlib commit 2738d2ca56cbc63be80c3bd48e9ed90ad94e947d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.DiscreteCategory

/-!
# The empty category

Defines a category structure on `PEmpty`, and the unique functor `PEmpty ⥤ C` for any category `C`.
-/

-- Porting note: this file stressed Lean a good deal despite its length

universe w v u
-- morphism levels before object levels. See note [CategoryTheory universes].
namespace CategoryTheory

namespace Functor

variable (C : Type u) [Category.{v} C]
/- Porting note: `aesop_cat` could not close any of the goals `tidy` did.
Switched to more explict construction -/
/-- Equivalence between two empty categories. -/
def emptyEquivalence : Discrete.{w} PEmpty ≌ Discrete.{v} PEmpty where
  functor :=
    { obj := PEmpty.elim ∘ Discrete.as
      map := fun {X} _ _ => X.as.elim
      map_comp := fun {X} _ _ _ _ => X.as.elim }
  inverse :=
    { obj := PEmpty.elim ∘ Discrete.as
      map := fun {X} _ _ => X.as.elim
      map_comp := fun {X} _ _ _ _ => X.as.elim }
  unitIso :=
    { hom :=
        { app := fun X => X.as.elim
          naturality := fun {X} _ _ => X.as.elim }
      inv :=
        { app := fun X => X.as.elim
          naturality := fun {X} _ _ => X.as.elim } }
  counitIso :=
    { hom :=
        { app := fun X => X.as.elim
          naturality := fun {X} _ _ => X.as.elim }
      inv :=
        { app := fun X => X.as.elim
          naturality := fun {X} _ _ => X.as.elim } }
  functor_unitIso_comp := fun X => X.as.elim
#align category_theory.functor.empty_equivalence CategoryTheory.Functor.emptyEquivalence

/-- The canonical functor out of the empty category. -/
def empty : Discrete.{w} PEmpty ⥤ C :=
  Discrete.functor PEmpty.elim
#align category_theory.functor.empty CategoryTheory.Functor.empty

variable {C}

/-- Any two functors out of the empty category are isomorphic. -/
def emptyExt (F G : Discrete.{w} PEmpty ⥤ C) : F ≅ G :=
  Discrete.natIso fun x => x.as.elim
#align category_theory.functor.empty_ext CategoryTheory.Functor.emptyExt

/-- Any functor out of the empty category is isomorphic to the canonical functor from the empty
category.
-/
def uniqueFromEmpty (F : Discrete.{w} PEmpty ⥤ C) : F ≅ empty C :=
  emptyExt _ _
#align category_theory.functor.unique_from_empty CategoryTheory.Functor.uniqueFromEmpty

/-- Any two functors out of the empty category are *equal*. You probably want to use
`emptyExt` instead of this.
-/
theorem empty_ext' (F G : Discrete.{w} PEmpty ⥤ C) : F = G :=
  Functor.ext (fun x => x.as.elim) fun x _ _ => x.as.elim
#align category_theory.functor.empty_ext' CategoryTheory.Functor.empty_ext'

end Functor

end CategoryTheory


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

Connectedness of types and functions
-/
import ..types.trunc ..types.arrow_2 ..types.lift
universes u v w
hott_theory
namespace hott

open is_trunc hott.is_equiv hott.nat nat hott.equiv trunc hott.function fiber hott.funext hott.pi pointed

@[hott, reducible] def is_conn (n : ℕ₋₂) (A : Type _) : Type _ :=
is_contr (trunc n A)

@[hott, reducible] def is_conn_fun (n : ℕ₋₂) {A B : Type _} (f : A → B) : Type _ :=
Πb : B, is_conn n (fiber f b)

@[hott, reducible] def is_conn_inf (A : Type _) : Type _ := Πn, is_conn n A
@[hott, reducible] def is_conn_fun_inf {A B : Type _} (f : A → B) : Type _ := Πn, is_conn_fun n f

namespace is_conn

  @[hott] def is_conn_equiv_closed (n : ℕ₋₂) {A B : Type _}
    : A ≃ B → is_conn n A → is_conn n B :=
  begin
    intros H C,
    napply @is_contr_equiv_closed (trunc n A) _,
    exact trunc_equiv_trunc n H,
    infer
  end

  @[hott] theorem is_conn_of_le (A : Type _) {n k : ℕ₋₂} (H : n ≤ k) [is_conn k A] : is_conn n A :=
  begin
    napply is_contr_equiv_closed,
    apply trunc_trunc_equiv_left _ H,
    apply_instance
  end

  @[hott] theorem is_conn_fun_of_le {A B : Type _} (f : A → B) {n k : ℕ₋₂} (H : n ≤ k)
    [is_conn_fun k f] : is_conn_fun n f :=
  λb, is_conn_of_le _ H

  @[hott] def is_conn_of_is_conn_succ (n : ℕ₋₂) (A : Type _) [is_conn (n.+1) A] : is_conn n A :=
  is_trunc_trunc_of_le A -2 (trunc_index.self_le_succ n)

  namespace is_conn_fun
  section
    parameters (n : ℕ₋₂) {A : Type _} {B : Type _} {h : A → B}
               (H : is_conn_fun n h) (P : B → Type _) [Πb, is_trunc n (P b)]

    @[hott] private def rec.helper : (Πa : A, P (h a)) → Πb : B, trunc n (fiber h b) → P b :=
    λt b, trunc.rec (λx, point_eq x ▸ t (point x))

    @[hott] private def rec.g : (Πa : A, P (h a)) → (Πb : B, P b) :=
    λt b, rec.helper t b (@center (trunc n (fiber h b)) (H b))

    -- induction principle for n-connected maps (@[hott] lemma 7.5.7)
    @[hott] protected def rec : is_equiv (λs : Πb : B, P b, λa : A, s (h a)) :=
    adjointify (λs a, s (h a)) rec.g
    begin
      intro t, apply eq_of_homotopy, intro a, dsimp [rec.g, rec.helper],
      rwr [@center_eq _ (H (h a)) (tr (fiber.mk a idp))],
    end
    begin
      intro k, apply eq_of_homotopy, intro b, dsimp [rec.g],
      hinduction @center _ (H b) with q p, hinduction p with a p, induction p, refl
    end

    @[hott] protected def elim : (Πa : A, P (h a)) → (Πb : B, P b) :=
    @is_equiv.inv _ _ (λ(s : Πb : B, P b) a, s (h a)) rec

    @[hott] protected def elim_β : Πf : (Πa : A, P (h a)), Πa : A, elim f (h a) = f a :=
    λf, apd10 (@is_equiv.right_inv _ _ (λ(s : Πb : B, P b) a, s (h a)) rec f)

  end

  section
    parameters (n k : ℕ₋₂) {A : Type _} {B : Type _} {f : A → B}
               (H : is_conn_fun n f) (P : B → Type _) [HP : Πb, is_trunc (n +2+ k) (P b)]

    include H HP
    -- @[hott] lemma 8.6.1
    @[hott] lemma elim_general : is_trunc_fun k (pi_functor_left f P) :=
    begin
      unfreezeI, revert P HP,
      induction k with k IH; intros P HP t,
      { napply is_contr_fiber_of_is_equiv, napply is_conn_fun.rec, exact H, exact HP },
      { napply is_trunc_succ_intro,
        intros x y, cases x with g p, cases y with h q,
        have e : fiber (λr : g ~ h, (λa, r (f a))) (apd10 (p ⬝ q⁻¹))
                 ≃ (fiber.mk g p = fiber.mk h q
                     :> fiber (λs : (Πb, P b), (λa, s (f a))) t),
        begin
          apply equiv.trans (fiber.sigma_char _ _),
          have e' : Πr : g ~ h,
                 ((λa, r (f a)) = apd10 (p ⬝ q⁻¹))
               ≃ (ap (λv : Πb, P b, (λa, v (f a))) (eq_of_homotopy r) ⬝ q = p),
          begin
            intro r,
            refine equiv.trans _ (eq_con_inv_equiv_con_eq q p
                                   (ap (λ(v : Πb, P b) a, v (f a)) (eq_of_homotopy r))),
            rwr [←apd10_eq_of_homotopy r],
            rwr [←(apd10_ap_precompose_dependent f (eq_of_homotopy r)), apd10_eq_of_homotopy r],
            symmetry,
            apply eq_equiv_fn_eq (@apd10 A (λa, P (f a)) (λa, g (f a)) (λa, h (f a)))
          end,
          refine sigma.sigma_equiv_sigma_right e' ⬝e _, clear e',
          refine (sigma.sigma_equiv_sigma_left (λr : g = h, ap _ r ⬝ q = p)
            (eq_equiv_homotopy _ _))⁻¹ᵉ ⬝e _,
          symmetry, apply equiv.trans (fiber_eq_equiv _ _),
          apply sigma.sigma_equiv_sigma_right, intro r,
          apply eq_equiv_eq_symm
        end,
        apply @is_trunc_equiv_closed _ _ k e, clear e,
        exact @IH (λb : B, (g b = h b)) (λb, @is_trunc_eq (P b) (n +2+ k) (HP b) (g b) (h b)) _
        }
    end

  end

  section
    parameters (n : ℕ₋₂) {A : Type u} {B : Type v} {h : A → B}
    parameter sec : ΠP : B → trunctype.{max u v} n,
                    is_retraction (λs : (Πb : B, P b), λ a, s (h a))

    @[hott] private abbreviation s := sec (λb, trunctype.mk' n (trunc n (fiber h b)))

    include sec

    -- the other half of @[hott] lemma 7.5.7
    @[hott] def intro : is_conn_fun n h :=
    begin
      intro b,
      apply is_contr.mk (@is_retraction.sect _ _ _ (s n sec) (λa, tr (fiber.mk a idp)) b),
      intro x, dsimp at x, hinduction x with p, hinduction p with a p,
      apply transport
               (λz : (Σy, h a = y), @sect _ _ _ (s n sec) (λa, tr (mk a idp)) (sigma.fst z) =
                                    tr (fiber.mk a (sigma.snd z)))
               (@center_eq _ (is_contr_sigma_eq (h a)) (sigma.mk b p)),

      exact apd10 (@hott.function.right_inverse _ _ _ (s n sec) (λa, tr (fiber.mk a idp))) a
    end
  end
  end is_conn_fun

  -- Connectedness is related to maps to and from the unit type, first to
  section
    parameters (n : ℕ₋₂) (A : Type _)

    @[hott] def is_conn_of_map_to_unit
      : is_conn_fun n (const A unit.star) → is_conn n A :=
    begin
      intro H, dsimp [is_conn_fun] at H,
      exact is_conn_equiv_closed n (fiber.fiber_star_equiv A) (by infer),
    end

    @[hott] def is_conn_fun_to_unit_of_is_conn [H : is_conn n A] :
      is_conn_fun n (const A unit.star) :=
    begin
      intro u, induction u,
      exact is_conn_equiv_closed n (fiber.fiber_star_equiv A)⁻¹ᵉ (by infer),
    end

    -- now maps from unit
    @[hott] def is_conn_of_map_from_unit (a₀ : A) (H : is_conn_fun n (const unit a₀))
      : is_conn n .+1 A :=
    is_contr.mk (tr a₀)
    begin
      apply trunc.rec, intro a,
      exact trunc.elim (λz : fiber (const unit a₀) a, ap tr (point_eq z))
                            (@center _ (H a))
    end

    @[hott] def is_conn_fun_from_unit (a₀ : A) [H : is_conn n .+1 A]
      : is_conn_fun n (const unit a₀) :=
    begin
      intro a,
      apply is_conn_equiv_closed n (equiv.symm (fiber_const_equiv A a₀ a)),
      apply @is_contr_equiv_closed _ _ (tr_eq_tr_equiv n a₀ a),
    end

  end

  -- as special case we get elimination principles for pointed connected types
  namespace is_conn
    open pointed unit
    section
      parameters (n : ℕ₋₂) {A : Type*}
                 [H : is_conn n .+1 A] (P : A → Type _) [Πa, is_trunc n (P a)]

      include H
      @[hott] protected def rec : is_equiv (λs : Πa : A, P a, s (Point A)) :=
      @is_equiv_compose
        (Πa : A, P a) (unit → P (Point A)) (P (Point A))
        (λf, f unit.star) (λs x, s (Point A))
        (is_conn_fun.rec n (is_conn_fun_from_unit n A (Point A)) P)
        (to_is_equiv (arrow_unit_left (P (Point A))))

      @[hott] protected def elim : P (Point A) → (Πa : A, P a) :=
      @is_equiv.inv _ _ (λ(s : Πa : A, P a), s (Point A)) rec

      @[hott] protected def elim_β (p : P (Point A)) : elim p (Point A) = p :=
      @is_equiv.right_inv _ _ (λ(s : Πa : A, P a), s (Point A)) rec p
    end

    section
      parameters (n k : ℕ₋₂) {A : Type*}
                 [H : is_conn n .+1 A] (P : A → Type _) [Πa, is_trunc (n +2+ k) (P a)]

      include H
      @[hott] lemma elim_general (p : P (Point A))
        : is_trunc k (fiber (λs : (Πa : A, P a), s (Point A)) p) :=
      @is_trunc_equiv_closed _ _ k
        (equiv.symm (fiber.equiv_postcompose _ (arrow_unit_left (P (Point A))) _))
        (is_conn_fun.elim_general n k (is_conn_fun_from_unit n A (Point A)) P (λx, p))
    end
  end is_conn

  -- @[hott] lemma 7.5.2
  @[hott] def minus_one_conn_of_surjective {A B : Type _} (f : A → B)
    : is_surjective f → is_conn_fun -1 f :=
  begin
    intro H, intro b,
    exact @is_contr_of_inhabited_prop (∥fiber f b∥) (is_trunc_trunc -1 (fiber f b)) (H b),
  end

  @[hott] def is_surjection_of_minus_one_conn {A B : Type _} (f : A → B)
    : is_conn_fun -1 f → is_surjective f :=
  begin
    intro H, intro b,
    exact @center (∥fiber f b∥) (H b),
  end

  @[hott] def merely_of_minus_one_conn {A : Type _} : is_conn -1 A → ∥A∥ :=
  λH, @center (∥A∥) H

  @[hott] def minus_one_conn_of_merely {A : Type _} : ∥A∥ → is_conn -1 A :=
  @is_contr_of_inhabited_prop (∥A∥) (is_trunc_trunc -1 A)

  section
    open hott.arrow

    variables {f : arrow} {g : arrow}

    -- @[hott] lemma 7.5.4
    @[hott, instance] def retract_of_conn_is_conn (r : arrow_hom f g) [H : arrow.is_retraction r]
      (n : ℕ₋₂) [K : is_conn_fun n f] : is_conn_fun n g :=
    begin
      intro b, dsimp [is_conn],
      apply is_contr_retract (trunc_functor n (retraction_on_fiber r b)),
      exact K (r.sect.on_cod b)
    end

  end

  -- Corollary 7.5.5
  @[hott] def is_conn_homotopy (n : ℕ₋₂) {A B : Type _} {f g : A → B}
    (p : f ~ g) (H : is_conn_fun n f) : is_conn_fun n g :=
  @retract_of_conn_is_conn _ _
    (arrow.arrow_hom_of_homotopy p) (arrow.is_retraction_arrow_hom_of_homotopy p) n H

  -- all types are -2-connected
  @[hott] def is_conn_minus_two (A : Type _) : is_conn -2 A :=
  by apply_instance

  -- merely inhabited types are -1-connected
  @[hott] def is_conn_minus_one (A : Type _) (a : ∥ A ∥) : is_conn -1 A :=
  is_contr.mk a (is_prop.elim _)

  @[hott, instance] def is_conn_minus_one_pointed (A : Type*) : is_conn -1 A :=
  is_conn_minus_one A (tr pt)

  @[hott, instance] def is_conn_trunc (A : Type _) (n k : ℕ₋₂) [H : is_conn n A]
    : is_conn n (trunc k A) :=
  begin
    apply is_trunc_equiv_closed, apply trunc_trunc_equiv_trunc_trunc, apply_instance
  end

  @[hott, instance] def is_conn_eq (n : ℕ₋₂) {A : Type _} (a a' : A) [is_conn (n.+1) A] :
    is_conn n (a = a') :=
  begin
    apply is_trunc_equiv_closed, apply tr_eq_tr_equiv, apply_instance
  end

  @[hott, instance] def is_conn_loop (n : ℕ₋₂) (A : Type*) [is_conn (n.+1) A] : is_conn n (Ω A) :=
  is_conn_eq n pt pt

  open pointed
  @[hott, instance] def is_conn_ptrunc (A : Type*) (n k : ℕ₋₂) [H : is_conn n A]
    : is_conn n (ptrunc k A) :=
  is_conn_trunc A n k

  -- the following trivial cases are solved by type class inference
  @[hott] def is_conn_of_is_contr (k : ℕ₋₂) (A : Type _) [is_contr A] : is_conn k A :=
  by apply_instance
  @[hott] def is_conn_fun_of_is_equiv (k : ℕ₋₂) {A B : Type _} (f : A → B) [is_equiv f] :
    is_conn_fun k f :=
  by apply_instance

  -- @[hott] lemma 7.5.14
  @[hott, instance] theorem is_equiv_trunc_functor_of_is_conn_fun {A B : Type _} (n : ℕ₋₂) (f : A → B)
    [H : is_conn_fun n f] : is_equiv (trunc_functor n f) :=
  begin
    fapply adjointify,
    { intro b, hinduction b with b, exact trunc_functor n point (center (trunc n (fiber f b)))},
    { intro b, hinduction b with b, dsimp, hinduction center (trunc n (fiber f b)) with q v,
      hinduction v with a p, exact ap tr p },
    { intro a, hinduction a with a, dsimp, rwr [center_eq (tr (fiber.mk a idp))]}
  end

  @[hott] theorem trunc_equiv_trunc_of_is_conn_fun {A B : Type _} (n : ℕ₋₂) (f : A → B)
    [H : is_conn_fun n f] : trunc n A ≃ trunc n B :=
  equiv.mk (trunc_functor n f) (is_equiv_trunc_functor_of_is_conn_fun n f)

  @[hott] def is_conn_fun_trunc_functor_of_le {n k : ℕ₋₂} {A B : Type _} (f : A → B) (H : k ≤ n)
    [H2 : is_conn_fun k f] : is_conn_fun k (trunc_functor n f) :=
  begin
    apply is_conn_fun.intro,
    intro P, haveI : Πb, is_trunc n (P b), from λb, is_trunc_of_le _ H,
    fconstructor,
    { intros f' b, resetI, hinduction b with b,
      refine @is_conn_fun.elim k _ _ _ H2 _ _ _ b, intro a, exact f' (tr a) },
    { intro f', apply eq_of_homotopy, intro a, dsimp,
      resetI, hinduction a using trunc.rec with a, dsimp, rwr [is_conn_fun.elim_β] }
  end

  @[hott] def is_conn_fun_trunc_functor_of_ge {n k : ℕ₋₂} {A B : Type _} (f : A → B) (H : n ≤ k)
    [H2 : is_conn_fun k f] : is_conn_fun k (trunc_functor n f) :=
  begin
    napply is_conn_fun_of_is_equiv,
    apply is_equiv_trunc_functor_of_le f H
  end

  -- Exercise 7.18
  @[hott] def is_conn_fun_trunc_functor {n k : ℕ₋₂} {A B : Type _} (f : A → B)
    [H2 : is_conn_fun k f] : is_conn_fun k (trunc_functor n f) :=
  begin
    eapply algebra.le_by_cases k n; intro H,
    { exact is_conn_fun_trunc_functor_of_le f H},
    { exact is_conn_fun_trunc_functor_of_ge f H}
  end

  open hott.ulift
  @[hott] def is_conn_fun_lift_functor (n : ℕ₋₂) {A B : Type _} (f : A → B) [is_conn_fun n f] :
    is_conn_fun n (ulift_functor f) :=
  begin
    intro b, cases b with b, apply is_trunc_equiv_closed_rev,
    { apply trunc_equiv_trunc, apply fiber_ulift_functor },
    apply_instance
  end

  open trunc_index
  @[hott] def is_conn_fun_inf.mk_nat {A B : Type _} {f : A → B} (H : Π(n : ℕ), is_conn_fun n f)
    : is_conn_fun_inf f :=
  begin
    intro n,
    cases n with n, { apply_instance },
    cases n with n, { have : -1 ≤ ↑0, from dec_star, exact is_conn_fun_of_le f this },
    change is_conn_fun (n.+2) f, rwr [←of_nat_add_two n], apply_instance
  end

  @[hott] def is_conn_inf.mk_nat {A : Type _} (H : Π(n : ℕ), is_conn n A) : is_conn_inf A :=
  begin
    intro n,
    cases n with n, { apply_instance },
    cases n with n, { have : -1 ≤ ↑0, from dec_star, apply is_conn_of_le A this},
    change is_conn (n.+2) A, rwr ←of_nat_add_two, apply_instance
  end

  @[hott] def is_conn_equiv_closed_rev (n : ℕ₋₂) {A B : Type _} (f : A ≃ B) (H : is_conn n B) :
    is_conn n A :=
  is_conn_equiv_closed n f⁻¹ᵉ (by apply_instance)

  @[hott] def is_conn_succ_intro {n : ℕ₋₂} {A : Type _} (a : trunc (n.+1) A)
    (H2 : Π(a a' : A), is_conn n (a = a')) : is_conn (n.+1) A :=
  begin
    napply is_contr_of_inhabited_prop,
    { apply is_trunc_succ_intro,
      refine trunc.rec _, intro a, refine trunc.rec _, intro a',
      apply is_contr_equiv_closed (tr_eq_tr_equiv _ _ _)⁻¹ᵉ, apply_instance },
    exact a
  end

  @[hott] def is_conn_pathover (n : ℕ₋₂) {A : Type _} {B : A → Type _} {a a' : A} (p : a = a') (b : B a)
    (b' : B a') [is_conn (n.+1) (B a')] : is_conn n (b =[p] b') :=
  is_conn_equiv_closed_rev n (pathover_equiv_tr_eq _ _ _) (by apply_instance)

  open hott.sigma
  @[hott, instance] lemma is_conn_sigma {A : Type _} (B : A → Type _) (n : ℕ₋₂)
    [HA : is_conn n A] [HB : Πa, is_conn n (B a)] : is_conn n (Σa, B a) :=
  begin
    unfreezeI, induction n with n IH generalizing A B HA HB,
    { apply is_conn_minus_two },
    apply is_conn_succ_intro,
    { resetI, hinduction center (trunc (n.+1) A) with q a,
      hinduction center (trunc (n.+1) (B a)) with q' b,
      exact tr ⟨a, b⟩ },
    intros a a', refine is_conn_equiv_closed_rev n (sigma_eq_equiv _ _) _,
    napply IH, apply is_conn_eq, intro p, apply is_conn_pathover
    /- an alternative proof of the successor case -/
    -- induction center (trunc (n.+1) A) with a₀,
    -- induction center (trunc (n.+1) (B a₀)) with b₀,
    -- apply is_contr.mk (tr ⟨a₀, b₀⟩),
    -- intro ab, induction ab with ab, induction ab with a b,
    -- induction tr_eq_tr_equiv n a₀ a !is_prop.elim with p, induction p,
    -- induction tr_eq_tr_equiv n b₀ b !is_prop.elim with q, induction q,
    -- reflexivity
  end

  @[hott, instance] lemma is_conn_prod (A B : Type _) (n : ℕ₋₂) [is_conn n A] [is_conn n B] :
    is_conn n (A × B) :=
  is_conn_equiv_closed n (sigma.equiv_prod _ _) (by apply_instance)

  @[hott] lemma is_conn_fun_of_is_conn {A B : Type _} (n : ℕ₋₂) (f : A → B)
    [HA : is_conn n A] [HB : is_conn (n.+1) B] : is_conn_fun n f :=
  λb, is_conn_equiv_closed_rev n (fiber.sigma_char _ _) (by apply_instance)

  @[hott] lemma is_conn_pfiber {A B : Type*} (n : ℕ₋₂) (f : A →* B)
    [HA : is_conn n A] [HB : is_conn (n.+1) B] : is_conn n (pfiber f) :=
  is_conn_fun_of_is_conn n f pt

  @[hott] def is_conn_fun_trunc_elim_of_le {n k : ℕ₋₂} {A B : Type _} [is_trunc n B] (f : A → B)
    (H : k ≤ n) [H2 : is_conn_fun k f] : is_conn_fun k (trunc.elim f : trunc n A → B) :=
  begin
    apply is_conn_fun.intro,
    intro P, have : Πb, is_trunc n (P b), from (λb, is_trunc_of_le _ H),
    fconstructor,
    { intros f' b,
      refine @is_conn_fun.elim k _ _ _ H2 _ _ _ b, intro a, exact f' (tr a) },
    { intro f', apply eq_of_homotopy, intro a, resetI,
      hinduction a with a, dsimp, rwr [is_conn_fun.elim_β] }
  end

  @[hott] def is_conn_fun_trunc_elim_of_ge {n k : ℕ₋₂} {A B : Type _} [is_trunc n B] (f : A → B)
    (H : n ≤ k) [H2 : is_conn_fun k f] : is_conn_fun k (trunc.elim f : trunc n A → B) :=
  begin
   napply is_conn_fun_of_is_equiv,
   have H3 : is_equiv (trunc_functor k f), from is_equiv_trunc_functor_of_is_conn_fun _ _,
   have H4 : is_equiv (trunc_functor n f), from is_equiv_trunc_functor_of_le _ H,
   apply is_equiv_of_equiv_of_homotopy (equiv.mk (trunc_functor n f) _ ⬝e trunc_equiv _ _),
   intro x, dsimp, hinduction x, refl,
   infer
  end

  @[hott] def is_conn_fun_trunc_elim {n k : ℕ₋₂} {A B : Type _} [is_trunc n B] (f : A → B)
    [H2 : is_conn_fun k f] : is_conn_fun k (trunc.elim f : trunc n A → B) :=
  begin
    eapply algebra.le_by_cases k n; intro H,
    { exact is_conn_fun_trunc_elim_of_le f H },
    { exact is_conn_fun_trunc_elim_of_ge f H }
  end

  @[hott] lemma is_conn_fun_tr (n : ℕ₋₂) (A : Type _) : is_conn_fun n (tr : A → trunc n A) :=
  begin
    apply is_conn_fun.intro,
    intro P,
    fconstructor,
    { intros f' b, hinduction b with a, exact f' a },
    { intro f', reflexivity }
  end

  @[hott] def is_contr_of_is_conn_of_is_trunc {n : ℕ₋₂} {A : Type _} (H : is_trunc n A)
    (K : is_conn n A) : is_contr A :=
  is_contr_equiv_closed (trunc_equiv n A)

end is_conn

/-
  (bundled) connected types, possibly also truncated or with a point
  The notation is n-Type*[k] for k-connected n-truncated pointed types, and you can remove
  `n-`, `[k]` or `*` in any combination to remove some conditions
-/

@[hott] structure conntype (n : ℕ₋₂) :=
  (carrier : Type _)
  (struct : is_conn n carrier)

notation `Type[`:95  n:0 `]`:0 := conntype n

@[hott] instance conntype_coe (n): has_coe_to_sort (conntype n) :=
⟨Type _ , conntype.carrier⟩

attribute [instance] [priority 1300] conntype.struct

section

  structure pconntype (n : ℕ₋₂) :=
    (pcarrier : Type*)
    (struct : is_conn n pcarrier)

  notation `Type*[`:95  n:0 `]`:0 := pconntype n

  /-
    There are multiple coercions from pconntype to Type. Type _ class inference doesn't recognize
    that all of them are definitionally equal (for performance reasons). One instance is
    automatically generated, and we manually add the missing instances.
  -/

  @[hott] instance pType_of_pconntype (n : ℕ₋₂) : has_coe Type*[n] Type* :=
  ⟨λx, x.pcarrier⟩

  @[hott] instance is_conn_pconntype {n : ℕ₋₂} (X : Type*[n]) : is_conn n X :=
  X.struct

  @[hott] def pconntype.to_conntype {n : ℕ₋₂} (X : Type*[n]) : Type[n] :=
  ⟨X, X.struct⟩

  @[hott] structure truncconntype (n k : ℕ₋₂) :=
    (carrier : Type u)
    (struct : is_trunc n carrier)
    (conn_struct : is_conn k carrier)

  notation n `-Type[`:95  k:0 `]`:0 := truncconntype n k

  @[hott] instance truncconntype_to_trunctype (n k : ℕ₋₂) : has_coe (n-Type[k]) (n-Type) :=
  ⟨λX, ⟨X.carrier, X.struct⟩⟩

  @[hott] instance truncconntype_to_conntype (n k : ℕ₋₂) : has_coe (n-Type[k]) (Type[k]) :=
  ⟨λX, ⟨X.carrier, X.conn_struct⟩⟩

  @[hott, reducible] def truncconntype.to_trunctype {n k : ℕ₋₂} (X : truncconntype.{u} n k) :
    trunctype.{u} n := ↑X
  @[hott, reducible] def truncconntype.to_conntype {n k : ℕ₋₂} (X : truncconntype.{u} n k) :
    conntype.{u} k := ↑X

  @[hott] def is_conn_truncconntype {n k : ℕ₋₂} (X : n-Type[k]) : is_conn k X :=
  by apply_instance

  @[hott, instance] def is_trunc_truncconntype {n k : ℕ₋₂} (X : n-Type[k]) : is_trunc n X :=
  X.struct

  @[hott] def is_trunc_truncconntype' {n k : ℕ₋₂} (X : n-Type[k]) :
    is_trunc n (X.to_trunctype) :=
  by apply_instance

  @[hott, instance] def is_conn_truncconntype' {n k : ℕ₋₂} (X : n-Type[k]) :
    is_conn k (X.to_trunctype) :=
  X.conn_struct

  @[hott, instance] def is_trunc_truncconntype'' {n k : ℕ₋₂} (X : n-Type[k]) :
    is_trunc n (X.to_conntype) :=
  X.struct

  @[hott] def is_conn_truncconntype'' {n k : ℕ₋₂} (X : n-Type[k]) :
    is_conn k (X.to_conntype) :=
  by apply_instance

  @[hott] structure ptruncconntype (n k : ℕ₋₂) :=
    (pcarrier : Type*)
    (struct : is_trunc n pcarrier)
    (conn_struct : is_conn k pcarrier)

  notation n `-Type*[`:95  k:0 `]`:0 := ptruncconntype n k

  @[hott] instance ptruncconntype_to_ptrunctype (n k : ℕ₋₂) : has_coe (n-Type*[k]) (n-Type*) :=
  ⟨λX, ⟨X.pcarrier, X.struct⟩⟩

  @[hott] instance ptruncconntype_to_pconntype (n k : ℕ₋₂) : has_coe (n-Type*[k]) (Type*[k]) :=
  ⟨λX, ⟨X.pcarrier, X.conn_struct⟩⟩

  @[hott] instance ptruncconntype_to_truncconntype (n k : ℕ₋₂) :
    has_coe (n-Type*[k]) (n-Type[k]) :=
  ⟨λX, ⟨X, X.struct, X.conn_struct⟩⟩

  @[hott, reducible] def ptruncconntype.to_ptrunctype {n k : ℕ₋₂} (X : ptruncconntype.{u} n k) :
    ptrunctype.{u} n := X
  @[hott, reducible] def ptruncconntype.to_pconntype {n k : ℕ₋₂} (X : ptruncconntype.{u} n k) :
    pconntype.{u} k := X
  @[hott, reducible] def ptruncconntype.to_truncconntype {n k : ℕ₋₂} (X : ptruncconntype.{u} n k) :
    truncconntype.{u} n k := X

  @[hott, reducible] def ptruncconntype.to_pType {n k : ℕ₋₂} (X : ptruncconntype.{u} n k) :
    pType.{u} := X
  @[hott, reducible] def ptruncconntype.to_conntype {n k : ℕ₋₂} (X : ptruncconntype.{u} n k) :
    conntype.{u} k := X
  @[hott, reducible] def ptruncconntype.to_trunctype {n k : ℕ₋₂} (X : ptruncconntype.{u} n k) :
    trunctype.{u} n := X

  @[hott] def is_conn_ptruncconntype {n k : ℕ₋₂} (X : n-Type*[k]) : is_conn k X :=
  by apply_instance

  @[hott] def is_trunc_ptruncconntype {n k : ℕ₋₂} (X : n-Type*[k]) : is_trunc n X :=
  by apply_instance

  @[hott] def is_trunc_ptruncconntype' {n k : ℕ₋₂} (X : n-Type*[k]) :
    is_trunc n (X.to_ptrunctype) :=
  by apply_instance

  @[hott, instance] def is_conn_ptruncconntype' {n k : ℕ₋₂} (X : n-Type*[k]) :
    is_conn k (X.to_ptrunctype) :=
  X.conn_struct

  @[hott, hsimp] def ptruncconntype.to_pType_mk {n k : ℕ₋₂} (X : Type*) (H : is_trunc n X)
    (H' : is_conn k X) : ptruncconntype.to_pType ⟨X, H, H'⟩ = X :=
  by refl

  @[hott] def ptruncconntype_eq {n k : ℕ₋₂} {X Y : n-Type*[k]} (p : X.to_pType ≃* Y.to_pType) :
    X = Y :=
  begin
    induction X with X Xt Xp Xc, induction Y with Y Yt Yp Yc,
    dsimp at p, hinduction eq_of_pequiv p,
    exact ap011 (ptruncconntype.mk X) (is_prop.elim _ _) (is_prop.elim _ _)
  end
end
end hott


/-
Copyright (c) 2021 Justus Springer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Justus Springer
-/
import algebra.category.Group.filtered_colimits
import algebra.category.Module.basic

/-!
# The forgetful functor from `R`-modules preserves filtered colimits.

Forgetful functors from algebraic categories usually don't preserve colimits. However, they tend
to preserve _filtered_ colimits.

In this file, we start with a ring `R`, a small filtered category `J` and a functor
`F : J ⥤ Module R`. We show that the colimit of `F ⋙ forget₂ (Module R) AddCommGroup`
(in `AddCommGroup`) carries the structure of an `R`-module, thereby showing that the forgetful
functor `forget₂ (Module R) AddCommGroup` preserves filtered colimits. In particular, this implies
that `forget (Module R)` preserves filtered colimits.

-/

universes u v

noncomputable theory
open_locale classical

open category_theory
open category_theory.limits
open category_theory.is_filtered (renaming max → max') -- avoid name collision with `_root_.max`.

open AddMon.filtered_colimits (colimit_zero_eq colimit_add_mk_eq)

namespace Module.filtered_colimits

section

-- We use parameters here, mainly so we can have the abbreviations `M` and `M.mk` below, without
-- passing around `F` all the time.
parameters {R : Type u} [ring R] {J : Type v} [small_category J] [is_filtered J]
parameters (F : J ⥤ Module.{v} R)

/--
The colimit of `F ⋙ forget₂ (Module R) AddCommGroup` in the category `AddCommGroup`.
In the following, we will show that this has the structure of an `R`-module.
-/
abbreviation M : AddCommGroup :=
AddCommGroup.filtered_colimits.colimit (F ⋙ forget₂ (Module R) AddCommGroup)

/-- The canonical projection into the colimit, as a quotient type. -/
abbreviation M.mk : (Σ j, F.obj j) → M := quot.mk (types.quot.rel (F ⋙ forget (Module R)))

lemma M.mk_eq (x y : Σ j, F.obj j)
  (h : ∃ (k : J) (f : x.1 ⟶ k) (g : y.1 ⟶ k), F.map f x.2 = F.map g y.2) :
  M.mk x = M.mk y :=
quot.eqv_gen_sound (types.filtered_colimit.eqv_gen_quot_rel_of_rel (F ⋙ forget (Module R)) x y h)

/-- The "unlifted" version of scalar multiplication in the colimit. -/
def colimit_smul_aux (r : R) (x : Σ j, F.obj j) : M :=
M.mk ⟨x.1, r • x.2⟩

lemma colimit_smul_aux_eq_of_rel (r : R) (x y : Σ j, F.obj j)
  (h : types.filtered_colimit.rel (F ⋙ forget (Module R)) x y) :
  colimit_smul_aux r x = colimit_smul_aux r y :=
begin
  apply M.mk_eq,
  obtain ⟨k, f, g, hfg⟩ := h,
  use [k, f, g],
  simp only [category_theory.functor.comp_map, forget_map_eq_coe] at hfg,
  rw [linear_map.map_smul, linear_map.map_smul, hfg],
end

/-- Scalar multiplication in the colimit. See also `colimit_smul_aux`. -/
instance colimit_has_scalar : has_scalar R M :=
{ smul := λ r x, begin
    refine quot.lift (colimit_smul_aux F r) _ x,
    intros x y h,
    apply colimit_smul_aux_eq_of_rel,
    apply types.filtered_colimit.rel_of_quot_rel,
    exact h,
  end }

@[simp]
lemma colimit_smul_mk_eq (r : R) (x : Σ j, F.obj j) : r • M.mk x = M.mk ⟨x.1, r • x.2⟩ := rfl

instance colimit_module : module R M :=
{ one_smul := λ x, begin
    apply quot.induction_on x, clear x, intro x, cases x with j x,
    erw [colimit_smul_mk_eq F 1 ⟨j, x⟩, one_smul],
    refl,
  end,
  mul_smul := λ r s x, begin
    apply quot.induction_on x, clear x, intro x, cases x with j x,
    erw [colimit_smul_mk_eq F (r * s) ⟨j, x⟩, colimit_smul_mk_eq F s ⟨j, x⟩,
      colimit_smul_mk_eq F r ⟨j, _⟩, mul_smul],
  end,
  smul_add := λ r x y, begin
    apply quot.induction_on₂ x y, clear x y, intros x y, cases x with i x, cases y with j y,
    erw [colimit_add_mk_eq _ ⟨i, x⟩ ⟨j, y⟩ (max' i j) (left_to_max i j) (right_to_max i j),
      colimit_smul_mk_eq, smul_add, colimit_smul_mk_eq, colimit_smul_mk_eq,
      colimit_add_mk_eq _ ⟨i, _⟩ ⟨j, _⟩ (max' i j) (left_to_max i j) (right_to_max i j),
      linear_map.map_smul, linear_map.map_smul],
    refl,
  end,
  smul_zero := λ r, begin
    erw [colimit_zero_eq _ (is_filtered.nonempty.some : J), colimit_smul_mk_eq, smul_zero],
    refl,
  end,
  zero_smul := λ x, begin
    apply quot.induction_on x, clear x, intro x, cases x with j x,
    erw [colimit_smul_mk_eq, zero_smul, colimit_zero_eq _ j],
    refl,
  end,
  add_smul := λ r s x, begin
    apply quot.induction_on x, clear x, intro x, cases x with j x,
    erw [colimit_smul_mk_eq, add_smul, colimit_smul_mk_eq, colimit_smul_mk_eq,
      colimit_add_mk_eq _ ⟨j, _⟩ ⟨j, _⟩ j (𝟙 j) (𝟙 j), category_theory.functor.map_id,
      id_apply, id_apply],
    refl,
  end }

/-- The bundled `R`-module giving the filtered colimit of a diagram. -/
def colimit : Module R := Module.of R M

/-- The linear map from a given `R`-module in the diagram to the colimit module. -/
def cocone_morphism (j : J) : F.obj j ⟶ colimit :=
{ map_smul' := λ r x, begin erw colimit_smul_mk_eq F r ⟨j, x⟩, refl, end,
.. (AddCommGroup.filtered_colimits.colimit_cocone (F ⋙ forget₂ (Module R) AddCommGroup)).ι.app j }

/-- The cocone over the proposed colimit module. -/
def colimit_cocone : cocone F :=
{ X := colimit,
  ι :=
  { app := cocone_morphism,
    naturality' := λ j j' f,
      linear_map.coe_injective ((types.colimit_cocone (F ⋙ forget (Module R))).ι.naturality f) } }

/--
Given a cocone `t` of `F`, the induced monoid linear map from the colimit to the cocone point.
We already know that this is a morphism between additive groups. The only thing left to see is that
it is a linear map, i.e. preserves scalar multiplication.
-/
def colimit_desc (t : cocone F) : colimit ⟶ t.X :=
{ map_smul' := λ r x, begin
    apply quot.induction_on x, clear x, intro x, cases x with j x,
    erw colimit_smul_mk_eq,
    exact linear_map.map_smul (t.ι.app j) r x,
  end,
  .. (AddCommGroup.filtered_colimits.colimit_cocone_is_colimit
      (F ⋙ forget₂ (Module R) AddCommGroup)).desc
      ((forget₂ (Module R) AddCommGroup.{v}).map_cocone t) }

/-- The proposed colimit cocone is a colimit in `Module R`. -/
def colimit_cocone_is_colimit : is_colimit colimit_cocone :=
{ desc := colimit_desc,
  fac' := λ t j, linear_map.coe_injective $
    (types.colimit_cocone_is_colimit (F ⋙ forget (Module R))).fac
    ((forget (Module R)).map_cocone t) j,
  uniq' := λ t m h, linear_map.coe_injective $
    (types.colimit_cocone_is_colimit (F ⋙ forget (Module R))).uniq
    ((forget (Module R)).map_cocone t) m ((λ j, funext $ λ x, linear_map.congr_fun (h j) x)) }

instance forget₂_AddCommGroup_preserves_filtered_colimits :
  preserves_filtered_colimits (forget₂ (Module R) AddCommGroup.{v}) :=
{ preserves_filtered_colimits := λ J _ _, by exactI
  { preserves_colimit := λ F, preserves_colimit_of_preserves_colimit_cocone
      (colimit_cocone_is_colimit F)
      (AddCommGroup.filtered_colimits.colimit_cocone_is_colimit
        (F ⋙ forget₂ (Module R) AddCommGroup.{v})) } }

instance forget_preserves_filtered_colimits : preserves_filtered_colimits (forget (Module R)) :=
limits.comp_preserves_filtered_colimits (forget₂ (Module R) AddCommGroup) (forget AddCommGroup)

end

end Module.filtered_colimits


/-
Copyright (c) 2020 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Robert Y. Lewis
-/

import tactic.core
import mathematica
import tactic.linarith

/-!
This demo shows how we can use Mathematica as a certificate oracle for mathlib's `linarith` tactic.
`linarith` implements a certificate checker, and it doesn't matter where this certificate comes from.
If the checker succeeds then we have a complete proof (with no new axioms).
-/

section
open native tactic tactic.mathematica mathematica linarith

/-- Auxiliary function that produces a string to pass to Mathematica. -/
meta def sum_for_var_i (l : list (ℕ × comp)) (i : ℕ) : string :=
let ls : list string := l.map $ λ ⟨hs, c⟩, to_string (c.coeffs.zfind i) ++ "* x" ++ to_string hs in
" + ".intercalate ls ++ " == 0"

/--
A `linarith.certificate_oracle` is a function `list_comp → ℕ → rb_map ℕ ℕ`.
Given a list of comparisons, it tries to find a coefficient for each comparison
such that summing together the linear combination of these comparisons
gives a proof of `0 < 0`.
-/
meta def mm_oracle : linarith.certificate_oracle :=
λ hs max_var,
let cstrs := (list.range max_var.succ).map (λ i, (sum_for_var_i hs.enum i)),
    cstrs := " && ".intercalate cstrs,
    nngs := (list.range hs.length).map $ λ i, "x" ++ to_string i ++ " >= 0",
    nngs := " && ".intercalate nngs,
    poss := hs.enum.filter_map $ λ ⟨i, c⟩,
      if c.str = ineq.lt then some ("x" ++ to_string i) else none,
    poss := " + ".intercalate poss ++ " > 0",
    vars := ", ".intercalate $ (list.range hs.length).map (λ i, "x" ++ to_string i),
    cmd := to_string $ format!"L = Part[#, 2] & /@ FindInstance[{cstrs} && {nngs} && {poss}, " ++ "{" ++ vars ++ "}, Rationals][[1]]; (LCM @@ Denominator@L)*L" in
do v ← execute_and_eval cmd,
   e ← pexpr_of_mmexpr trans_env.empty v,
   e ← to_expr e,
   e ← eval_expr (list ℕ) e,
   return $ rb_map.of_list e.enum

end

/- A simple example of `linarith` using our new oracle. -/
example (x y z : ℚ) (h1 : 2*x  < 3*y) (h2 : -4*x + 2*z < 0)
        (h3 : 12*y - 4* z < 0)  : false :=
by linarith {oracle := mm_oracle}

/- The `nlinarith` variant creates bigger problems,
where more efficient algorithms in Mathematica can shine. -/
example (u v x y A B : ℚ) : (0 < A) → (A ≤ 1) → (1 ≤ B)
→ (x ≤ B) → ( y ≤ B)
→ (0 ≤ u ) → (0 ≤ v )
→ (u < A) → ( v < A)
→ (u * y + v * x + u * v < 3 * A * B) :=
begin
  intros,
  nlinarith {oracle := mm_oracle}
 end

/- `linarith` works over arbitrary types with the right algebraic and order structure. -/
example {α : Type}
  [linear_ordered_field α]
  {a b c : α}
  (ha : a < 0)
  (hb : ¬b = 0)
  (hc' : c = 0)
  (h : (1 - a) * (b * b) ≤ 0)
  (hc : 0 ≤ 0)
  (this : -(a * -b * -b + b * -b + 0) = (1 - a) * (b * b))
  (h : (1 - a) * (b * b) ≤ 0) :
  0 < 1 - a :=
begin
  linarith {oracle := mm_oracle}
end


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Eric Wieser

! This file was ported from Lean 3 source module data.real.pointwise
! leanprover-community/mathlib commit dde670c9a3f503647fd5bfdf1037bad526d3397a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Order.Module
import Mathlib.Data.Real.Basic

/-!
# Pointwise operations on sets of reals

This file relates `Inf (a • s)`/`Sup (a • s)` with `a • Inf s`/`a • Sup s` for `s : Set ℝ`.

From these, it relates `⨅ i, a • f i` / `⨆ i, a • f i` with `a • (⨅ i, f i)` / `a • (⨆ i, f i)`,
and provides lemmas about distributing `*` over `⨅` and `⨆`.

# TODO

This is true more generally for conditionally complete linear order whose default value is `0`. We
don't have those yet.
-/

open Set

open Pointwise

variable {ι : Sort _} {α : Type _} [LinearOrderedField α]

section MulActionWithZero

variable [MulActionWithZero α ℝ] [OrderedSMul α ℝ] {a : α}

theorem Real.infₛ_smul_of_nonneg (ha : 0 ≤ a) (s : Set ℝ) : infₛ (a • s) = a • infₛ s := by
  obtain rfl | hs := s.eq_empty_or_nonempty
  · rw [smul_set_empty, Real.infₛ_empty, smul_zero]
  obtain rfl | ha' := ha.eq_or_lt
  · rw [zero_smul_set hs, zero_smul]
    exact cinfₛ_singleton 0
  by_cases h : BddBelow s
  · exact ((OrderIso.smulLeft ℝ ha').map_cinfₛ' hs h).symm
  · rw [Real.infₛ_of_not_bddBelow (mt (bddBelow_smul_iff_of_pos ha').1 h),
        Real.infₛ_of_not_bddBelow h, smul_zero]
#align real.Inf_smul_of_nonneg Real.infₛ_smul_of_nonneg

theorem Real.smul_infᵢ_of_nonneg (ha : 0 ≤ a) (f : ι → ℝ) : (a • ⨅ i, f i) = ⨅ i, a • f i :=
  (Real.infₛ_smul_of_nonneg ha _).symm.trans <| congr_arg infₛ <| (range_comp _ _).symm
#align real.smul_infi_of_nonneg Real.smul_infᵢ_of_nonneg

theorem Real.supₛ_smul_of_nonneg (ha : 0 ≤ a) (s : Set ℝ) : supₛ (a • s) = a • supₛ s := by
  obtain rfl | hs := s.eq_empty_or_nonempty
  · rw [smul_set_empty, Real.supₛ_empty, smul_zero]
  obtain rfl | ha' := ha.eq_or_lt
  · rw [zero_smul_set hs, zero_smul]
    exact csupₛ_singleton 0
  by_cases h : BddAbove s
  · exact ((OrderIso.smulLeft ℝ ha').map_csupₛ' hs h).symm
  · rw [Real.supₛ_of_not_bddAbove (mt (bddAbove_smul_iff_of_pos ha').1 h),
        Real.supₛ_of_not_bddAbove h, smul_zero]
#align real.Sup_smul_of_nonneg Real.supₛ_smul_of_nonneg

theorem Real.smul_supᵢ_of_nonneg (ha : 0 ≤ a) (f : ι → ℝ) : (a • ⨆ i, f i) = ⨆ i, a • f i :=
  (Real.supₛ_smul_of_nonneg ha _).symm.trans <| congr_arg supₛ <| (range_comp _ _).symm
#align real.smul_supr_of_nonneg Real.smul_supᵢ_of_nonneg

end MulActionWithZero

section Module

variable [Module α ℝ] [OrderedSMul α ℝ] {a : α}

theorem Real.infₛ_smul_of_nonpos (ha : a ≤ 0) (s : Set ℝ) : infₛ (a • s) = a • supₛ s := by
  obtain rfl | hs := s.eq_empty_or_nonempty
  · rw [smul_set_empty, Real.infₛ_empty, Real.supₛ_empty, smul_zero]
  obtain rfl | ha' := ha.eq_or_lt
  · rw [zero_smul_set hs, zero_smul]
    exact cinfₛ_singleton 0
  by_cases h : BddAbove s
  · exact ((OrderIso.smulLeftDual ℝ ha').map_csupₛ' hs h).symm
  · rw [Real.infₛ_of_not_bddBelow (mt (bddBelow_smul_iff_of_neg ha').1 h),
        Real.supₛ_of_not_bddAbove h, smul_zero]
#align real.Inf_smul_of_nonpos Real.infₛ_smul_of_nonpos

theorem Real.smul_supᵢ_of_nonpos (ha : a ≤ 0) (f : ι → ℝ) : (a • ⨆ i, f i) = ⨅ i, a • f i :=
  (Real.infₛ_smul_of_nonpos ha _).symm.trans <| congr_arg infₛ <| (range_comp _ _).symm
#align real.smul_supr_of_nonpos Real.smul_supᵢ_of_nonpos

theorem Real.supₛ_smul_of_nonpos (ha : a ≤ 0) (s : Set ℝ) : supₛ (a • s) = a • infₛ s := by
  obtain rfl | hs := s.eq_empty_or_nonempty
  · rw [smul_set_empty, Real.supₛ_empty, Real.infₛ_empty, smul_zero]
  obtain rfl | ha' := ha.eq_or_lt
  · rw [zero_smul_set hs, zero_smul]
    exact csupₛ_singleton 0
  by_cases h : BddBelow s
  · exact ((OrderIso.smulLeftDual ℝ ha').map_cinfₛ' hs h).symm
  · rw [Real.supₛ_of_not_bddAbove (mt (bddAbove_smul_iff_of_neg ha').1 h),
        Real.infₛ_of_not_bddBelow h, smul_zero]
#align real.Sup_smul_of_nonpos Real.supₛ_smul_of_nonpos

theorem Real.smul_infᵢ_of_nonpos (ha : a ≤ 0) (f : ι → ℝ) : (a • ⨅ i, f i) = ⨆ i, a • f i :=
  (Real.supₛ_smul_of_nonpos ha _).symm.trans <| congr_arg supₛ <| (range_comp _ _).symm
#align real.smul_infi_of_nonpos Real.smul_infᵢ_of_nonpos

end Module

/-! ## Special cases for real multiplication -/

section Mul

variable {r : ℝ}

theorem Real.mul_infᵢ_of_nonneg (ha : 0 ≤ r) (f : ι → ℝ) : (r * ⨅ i, f i) = ⨅ i, r * f i :=
  Real.smul_infᵢ_of_nonneg ha f
#align real.mul_infi_of_nonneg Real.mul_infᵢ_of_nonneg

theorem Real.mul_supᵢ_of_nonneg (ha : 0 ≤ r) (f : ι → ℝ) : (r * ⨆ i, f i) = ⨆ i, r * f i :=
  Real.smul_supᵢ_of_nonneg ha f
#align real.mul_supr_of_nonneg Real.mul_supᵢ_of_nonneg

theorem Real.mul_infᵢ_of_nonpos (ha : r ≤ 0) (f : ι → ℝ) : (r * ⨅ i, f i) = ⨆ i, r * f i :=
  Real.smul_infᵢ_of_nonpos ha f
#align real.mul_infi_of_nonpos Real.mul_infᵢ_of_nonpos

theorem Real.mul_supᵢ_of_nonpos (ha : r ≤ 0) (f : ι → ℝ) : (r * ⨆ i, f i) = ⨅ i, r * f i :=
  Real.smul_supᵢ_of_nonpos ha f
#align real.mul_supr_of_nonpos Real.mul_supᵢ_of_nonpos

theorem Real.infᵢ_mul_of_nonneg (ha : 0 ≤ r) (f : ι → ℝ) : (⨅ i, f i) * r = ⨅ i, f i * r := by
  simp only [Real.mul_infᵢ_of_nonneg ha, mul_comm]
#align real.infi_mul_of_nonneg Real.infᵢ_mul_of_nonneg

theorem Real.supᵢ_mul_of_nonneg (ha : 0 ≤ r) (f : ι → ℝ) : (⨆ i, f i) * r = ⨆ i, f i * r := by
  simp only [Real.mul_supᵢ_of_nonneg ha, mul_comm]
#align real.supr_mul_of_nonneg Real.supᵢ_mul_of_nonneg

theorem Real.infᵢ_mul_of_nonpos (ha : r ≤ 0) (f : ι → ℝ) : (⨅ i, f i) * r = ⨆ i, f i * r := by
  simp only [Real.mul_infᵢ_of_nonpos ha, mul_comm]
#align real.infi_mul_of_nonpos Real.infᵢ_mul_of_nonpos

theorem Real.supᵢ_mul_of_nonpos (ha : r ≤ 0) (f : ι → ℝ) : (⨆ i, f i) * r = ⨅ i, f i * r := by
  simp only [Real.mul_supᵢ_of_nonpos ha, mul_comm]
#align real.supr_mul_of_nonpos Real.supᵢ_mul_of_nonpos

end Mul