/-
Copyright (c) 2020 Fox Thomson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Fox Thomson, Markus Himmel
-/
import data.nat.bitwise
import set_theory.game.impartial
import set_theory.ordinal_arithmetic

/-!
# Nim and the Sprague-Grundy theorem

This file contains the definition for nim for any ordinal `O`. In the game of `nim O₁` both players
may move to `nim O₂` for any `O₂ < O₁`.
We also define a Grundy value for an impartial game `G` and prove the Sprague-Grundy theorem, that
`G` is equivalent to `nim (grundy_value G)`.
Finally, we compute the sum of finite Grundy numbers: if `G` and `H` have Grundy values `n` and `m`,
where `n` and `m` are natural numbers, then `G + H` has the Grundy value `n xor m`.

## Implementation details

The pen-and-paper definition of nim defines the possible moves of `nim O` to be `{O' | O' < O}`.
However, this definition does not work for us because it would make the type of nim
`ordinal.{u} → pgame.{u + 1}`, which would make it impossible for us to state the Sprague-Grundy
theorem, since that requires the type of `nim` to be `ordinal.{u} → pgame.{u}`. For this reason, we
instead use `O.out.α` for the possible moves, which makes proofs significantly more messy and
tedious, but avoids the universe bump.

The lemma `nim_def` is somewhat prone to produce "motive is not type correct" errors. If you run
into this problem, you may find the lemmas `exists_ordinal_move_left_eq` and `exists_move_left_eq`
useful.

-/
universes u

/-- `ordinal.out` and `ordinal.type_out'` are required to make the definition of nim computable.
 `ordinal.out` performs the same job as `quotient.out` but is specific to ordinals. -/
def ordinal.out (o : ordinal) : Well_order :=
⟨o.out.α, λ x y, o.out.r x y, o.out.wo⟩

/-- This is the same as `ordinal.type_out` but defined to use `ordinal.out`. -/
theorem ordinal.type_out' : ∀ (o : ordinal), ordinal.type (ordinal.out o).r = o := ordinal.type_out

/-- The definition of single-heap nim, which can be viewed as a pile of stones where each player can
 take a positive number of stones from it on their turn. -/
def nim : ordinal → pgame
| O₁ := ⟨ O₁.out.α, O₁.out.α,
  λ O₂, have hwf : (ordinal.typein O₁.out.r O₂) < O₁,
    from begin nth_rewrite_rhs 0 ←ordinal.type_out' O₁, exact ordinal.typein_lt_type _ _ end,
    nim (ordinal.typein O₁.out.r O₂),
  λ O₂, have hwf : (ordinal.typein O₁.out.r O₂) < O₁,
    from begin nth_rewrite_rhs 0 ←ordinal.type_out' O₁, exact ordinal.typein_lt_type _ _ end,
    nim (ordinal.typein O₁.out.r O₂)⟩
using_well_founded { dec_tac := tactic.assumption }

namespace pgame

local infix ` ≈ ` := equiv

namespace nim

open ordinal

lemma nim_def (O : ordinal) : nim O = pgame.mk O.out.α O.out.α
  (λ O₂, nim (ordinal.typein O.out.r O₂))
  (λ O₂, nim (ordinal.typein O.out.r O₂)) :=
by rw nim

lemma nim_wf_lemma {O₁ : ordinal} (O₂ : O₁.out.α) : (ordinal.typein O₁.out.r O₂) < O₁ :=
begin
  nth_rewrite_rhs 0 ← ordinal.type_out O₁,
  exact ordinal.typein_lt_type _ _
end

instance nim_impartial : ∀ (O : ordinal), impartial (nim O)
| O :=
begin
  rw [impartial_def, nim_def, neg_def],
  split,
  split,
  { rw pgame.le_def,
    split,
    { intro i,
      let hwf : (typein O.out.r i) < O := nim_wf_lemma i,
      exact or.inl ⟨i, (@impartial.neg_equiv_self _ $ nim_impartial $ typein O.out.r i).1⟩ },
    { intro j,
      let hwf : (typein O.out.r j) < O := nim_wf_lemma j,
      exact or.inr ⟨j, (@impartial.neg_equiv_self _ $ nim_impartial $ typein O.out.r j).1⟩ } },
  { rw pgame.le_def,
    split,
    { intro i,
      let hwf : (typein O.out.r i) < O := nim_wf_lemma i,
      exact or.inl ⟨i, (@impartial.neg_equiv_self _ $ nim_impartial $ typein O.out.r i).2⟩ },
    { intro j,
      let hwf : (typein O.out.r j) < O := nim_wf_lemma j,
      exact or.inr ⟨j, (@impartial.neg_equiv_self _ $ nim_impartial $ typein O.out.r j).2⟩ } },
  split,
  { intro i,
    let hwf : (typein O.out.r i) < O := nim_wf_lemma i,
    simpa using nim_impartial (typein O.out.r i) },
  { intro j,
    let hwf : (typein O.out.r j) < O := nim_wf_lemma j,
    simpa using nim_impartial (typein O.out.r j) }
end
using_well_founded { dec_tac := tactic.assumption }

lemma exists_ordinal_move_left_eq (O : ordinal) : ∀ i, ∃ O' < O, (nim O).move_left i = nim O' :=
by { rw nim_def, exact λ i, ⟨ordinal.typein O.out.r i, ⟨nim_wf_lemma _, rfl⟩⟩ }

lemma exists_move_left_eq (O : ordinal) : ∀ O' < O, ∃ i, (nim O).move_left i = nim O' :=
by { rw nim_def, exact λ _ h, ⟨(ordinal.principal_seg_out h).top, by simp⟩ }

lemma zero_first_loses : (nim (0 : ordinal)).first_loses :=
begin
  rw [impartial.first_loses_symm, nim_def, le_def_lt],
  split,
  { rintro (i : (0 : ordinal).out.α),
    have h := ordinal.typein_lt_type _ i,
    rw ordinal.type_out at h,
    exact false.elim (not_le_of_lt h (ordinal.zero_le (ordinal.typein _ i))) },
  { tidy }
end

lemma non_zero_first_wins (O : ordinal) (hO : O ≠ 0) : (nim O).first_wins :=
begin
  rw [impartial.first_wins_symm, nim_def, lt_def_le],
  rw ←ordinal.pos_iff_ne_zero at hO,
  exact or.inr ⟨(ordinal.principal_seg_out hO).top, by simpa using zero_first_loses.1⟩
end

lemma sum_first_loses_iff_eq (O₁ O₂ : ordinal) : (nim O₁ + nim O₂).first_loses ↔ O₁ = O₂ :=
begin
  split,
  { contrapose,
    intro h,
    rw [impartial.not_first_loses],
    wlog h' : O₁ ≤ O₂ using [O₁ O₂, O₂ O₁],
    { exact ordinal.le_total O₁ O₂ },
    { have h : O₁ < O₂ := lt_of_le_of_ne h' h,
      rw [impartial.first_wins_symm', lt_def_le, nim_def O₂],
      refine or.inl ⟨(left_moves_add (nim O₁) _).symm (sum.inr _), _⟩,
      { exact (ordinal.principal_seg_out h).top },
      { simpa using (impartial.add_self (nim O₁)).2 } },
    { exact first_wins_of_equiv add_comm_equiv (this (ne.symm h)) } },
  { rintro rfl,
    exact impartial.add_self (nim O₁) }
end

lemma sum_first_wins_iff_neq (O₁ O₂ : ordinal) : (nim O₁ + nim O₂).first_wins ↔ O₁ ≠ O₂ :=
by rw [iff_not_comm, impartial.not_first_wins, sum_first_loses_iff_eq]

lemma equiv_iff_eq (O₁ O₂ : ordinal) : nim O₁ ≈ nim O₂ ↔ O₁ = O₂ :=
⟨λ h, (sum_first_loses_iff_eq _ _).1 $
  by rw [first_loses_of_equiv_iff (add_congr h (equiv_refl _)), sum_first_loses_iff_eq],
 by { rintro rfl, refl }⟩

end nim

/-- This definition will be used in the proof of the Sprague-Grundy theorem. It takes a function
  from some type to ordinals and returns a nonempty set of ordinals with empty intersection with
  the image of the function. It is guaranteed that the smallest ordinal not in the image will be
  in the set, i.e. we can use this to find the mex. -/
def nonmoves {α : Type u} (M : α → ordinal.{u}) : set ordinal.{u} :=
  { O : ordinal | ¬ ∃ a : α, M a = O }

lemma nonmoves_nonempty {α : Type u} (M : α → ordinal.{u}) : ∃ O : ordinal, O ∈ nonmoves M :=
begin
  classical,
  by_contra h,
  simp only [nonmoves, not_exists, not_forall, set.mem_set_of_eq, not_not] at h,

  have hle : cardinal.univ.{u (u+1)} ≤ cardinal.lift.{u (u+1)} (cardinal.mk α),
  { refine ⟨⟨λ ⟨O⟩, ⟨classical.some (h O)⟩, _⟩⟩,
    rintros ⟨O₁⟩ ⟨O₂⟩ heq,
    ext,
    refine eq.trans (classical.some_spec (h O₁)).symm _,
    injection heq with heq,
    rw heq,
    exact classical.some_spec (h O₂) },

  have hlt : cardinal.lift.{u (u+1)} (cardinal.mk α) < cardinal.univ.{u (u+1)} :=
    cardinal.lt_univ.2 ⟨cardinal.mk α, rfl⟩,

  cases hlt,
  contradiction
end

/-- The Grundy value of an impartial game, the ordinal which corresponds to the game of nim that the
 game is equivalent to -/
noncomputable def grundy_value : Π (G : pgame.{u}) [G.impartial], ordinal.{u}
| G := λ hG, by exactI
    ordinal.omin (nonmoves (λ i, grundy_value (G.move_left i))) (nonmoves_nonempty _)
using_well_founded { dec_tac := pgame_wf_tac }

lemma grundy_value_def (G : pgame) [G.impartial] :
grundy_value G = ordinal.omin (nonmoves (λ i, (grundy_value (G.move_left i))))
  (nonmoves_nonempty _) :=
by { rw grundy_value, refl }

/-- The Sprague-Grundy theorem which states that every impartial game is equivalent to a game of
 nim, namely the game of nim corresponding to the games Grundy value -/
theorem equiv_nim_grundy_value : ∀ (G : pgame.{u}) [G.impartial], by exactI G ≈ nim (grundy_value G)
| G :=
begin
  classical,
  introI hG,
  rw [impartial.equiv_iff_sum_first_loses, ←impartial.no_good_left_moves_iff_first_loses],
  intro i,
  equiv_rw left_moves_add G (nim (grundy_value G)) at i,
  cases i with i₁ i₂,
  { rw add_move_left_inl,
    apply first_wins_of_equiv
     (add_congr (equiv_nim_grundy_value (G.move_left i₁)).symm (equiv_refl _)),
    rw nim.sum_first_wins_iff_neq,
    intro heq,
    rw [eq_comm, grundy_value_def G] at heq,
    have h := ordinal.omin_mem
      (nonmoves (λ (i : G.left_moves), grundy_value (G.move_left i))) (nonmoves_nonempty _),
    rw heq at h,
    have hcontra : ∃ (i' : G.left_moves),
      (λ (i'' : G.left_moves), grundy_value (G.move_left i'')) i' = grundy_value (G.move_left i₁) :=
      ⟨i₁, rfl⟩,
    contradiction },
  { rw [add_move_left_inr, ←impartial.good_left_move_iff_first_wins],
    revert i₂,
    rw nim.nim_def,
    intro i₂,

    have h' : ∃ i : G.left_moves, (grundy_value (G.move_left i)) =
      ordinal.typein (quotient.out (grundy_value G)).r i₂,
    { have hlt : ordinal.typein (quotient.out (grundy_value G)).r i₂ <
        ordinal.type (quotient.out (grundy_value G)).r := ordinal.typein_lt_type _ _,
      rw ordinal.type_out at hlt,
      revert i₂ hlt,
      rw grundy_value_def,
      intros i₂ hlt,
      have hnotin : ordinal.typein (quotient.out (ordinal.omin
          (nonmoves (λ i, grundy_value (G.move_left i))) _)).r i₂ ∉
        (nonmoves (λ (i : G.left_moves), grundy_value (G.move_left i))),
      { intro hin,
        have hge := ordinal.omin_le hin,
        have hcontra := (le_not_le_of_lt hlt).2,
        contradiction },
      simpa [nonmoves] using hnotin },

    cases h' with i hi,
    use (left_moves_add _ _).symm (sum.inl i),
    rw [add_move_left_inl, move_left_mk],
    apply first_loses_of_equiv
      (add_congr (equiv_symm (equiv_nim_grundy_value (G.move_left i))) (equiv_refl _)),
    simpa only [hi] using impartial.add_self (nim (grundy_value (G.move_left i))) }
end
using_well_founded { dec_tac := pgame_wf_tac }

lemma equiv_nim_iff_grundy_value_eq (G : pgame) [G.impartial] (O : ordinal) :
  G ≈ nim O ↔ grundy_value G = O :=
⟨by { intro h, rw ←nim.equiv_iff_eq, exact equiv_trans (equiv_symm (equiv_nim_grundy_value G)) h },
 by { rintro rfl, exact equiv_nim_grundy_value G }⟩

lemma nim.grundy_value (O : ordinal.{u}) : grundy_value (nim O) = O :=
by rw ←equiv_nim_iff_grundy_value_eq

lemma equiv_iff_grundy_value_eq (G H : pgame) [G.impartial] [H.impartial] :
  G ≈ H ↔ grundy_value G = grundy_value H :=
(equiv_congr_left.1 (equiv_nim_grundy_value H) _).trans $ equiv_nim_iff_grundy_value_eq _ _

lemma grundy_value_zero : grundy_value 0 = 0 :=
by rw [(equiv_iff_grundy_value_eq 0 (nim 0)).1 (equiv_symm nim.zero_first_loses), nim.grundy_value]

lemma equiv_zero_iff_grundy_value (G : pgame) [G.impartial] : G ≈ 0 ↔ grundy_value G = 0 :=
by rw [equiv_iff_grundy_value_eq, grundy_value_zero]

lemma grundy_value_nim_add_nim (n m : ℕ) : grundy_value (nim n + nim m) = nat.lxor n m :=
begin
  induction n using nat.strong_induction_on with n hn generalizing m,
  induction m using nat.strong_induction_on with m hm,
  rw [grundy_value_def],

  -- We want to show that `n xor m` is the smallest unreachable Grundy value. We will do this in two
  -- steps:
  -- h₀: `n xor m` is not a reachable grundy number.
  -- h₁: every Grundy number strictly smaller than `n xor m` is reachable.

  have h₀ : (nat.lxor n m : ordinal) ∈ nonmoves (λ i, grundy_value ((nim n + nim m).move_left i)),
  { -- To show that `n xor m` is unreachable, we show that every move produces a Grundy number
    -- different from `n xor m`.
    simp only [nonmoves, not_exists, set.mem_set_of_eq],
    equiv_rw left_moves_add _ _,

    -- The move operates either on the left pile or on the right pile.
    rintro (a|a),

    all_goals
    { -- One of the piles is reduced to `k` stones, with `k < n` or `k < m`.
      obtain ⟨ok, ⟨hk, hk'⟩⟩ := nim.exists_ordinal_move_left_eq _ a,
      obtain ⟨k, rfl⟩ := ordinal.lt_omega.1 (lt_trans hk (ordinal.nat_lt_omega _)),
      replace hk := ordinal.nat_cast_lt.1 hk,

      -- Thus, the problem is reduced to computing the Grundy value of `nim n + nim k` or
      -- `nim k + nim m`, both of which can be dealt with using an inductive hypothesis.
      simp only [hk', add_move_left_inl, add_move_left_inr, id],
      rw hn _ hk <|> rw hm _ hk,

      -- But of course xor is injective, so if we change one of the arguments, we will not get the
      -- same value again.
      intro h,
      rw ordinal.nat_cast_inj at h,
      try { rw [nat.lxor_comm n k, nat.lxor_comm n m] at h },
      exact _root_.ne_of_lt hk (nat.lxor_left_inj h) } },

  have h₁ : ∀ (u : ordinal), u < nat.lxor n m →
    u ∉ nonmoves (λ i, grundy_value ((nim n + nim m).move_left i)),
  { -- Take any natural number `u` less than `n xor m`.
    intros ou hu,
    obtain ⟨u, rfl⟩ := ordinal.lt_omega.1 (lt_trans hu (ordinal.nat_lt_omega _)),
    replace hu := ordinal.nat_cast_lt.1 hu,

    -- Our goal is to produce a move that gives the Grundy value `u`.
    simp only [nonmoves, not_exists, not_not, set.mem_set_of_eq, not_forall],

    -- By a lemma about xor, either `u xor m < n` or `u xor n < m`.
    have : nat.lxor u (nat.lxor n m) ≠ 0,
    { intro h, rw nat.lxor_eq_zero at h, linarith },
    rcases nat.lxor_trichotomy this with h|h|h,
    { linarith },

    -- Therefore, we can play the corresponding move, and by the inductive hypothesis the new state
    -- is `(u xor m) xor m = u` or `n xor (u xor n) = u` as required.
    { obtain ⟨i, hi⟩ := nim.exists_move_left_eq _ _ (ordinal.nat_cast_lt.2 h),
      refine ⟨(left_moves_add _ _).symm (sum.inl i), _⟩,
      simp only [hi, add_move_left_inl],
      rw [hn _ h, nat.lxor_assoc, nat.lxor_self, nat.lxor_zero] },
    { obtain ⟨i, hi⟩ := nim.exists_move_left_eq _ _ (ordinal.nat_cast_lt.2 h),
      refine ⟨(left_moves_add _ _).symm (sum.inr i), _⟩,
      simp only [hi, add_move_left_inr],
      rw [hm _ h, nat.lxor_comm, nat.lxor_assoc, nat.lxor_self, nat.lxor_zero] } },

  -- We are done!
  apply le_antisymm (ordinal.omin_le h₀),
  contrapose! h₁,
  exact ⟨_, ⟨h₁, ordinal.omin_mem _ _⟩⟩
end

lemma nim_add_nim_equiv {n m : ℕ} : nim n + nim m ≈ nim (nat.lxor n m) :=
by rw [equiv_nim_iff_grundy_value_eq, grundy_value_nim_add_nim]

lemma grundy_value_add (G H : pgame) [G.impartial] [H.impartial] {n m : ℕ} (hG : grundy_value G = n)
  (hH : grundy_value H = m) : grundy_value (G + H) = nat.lxor n m :=
begin
  rw [←nim.grundy_value (nat.lxor n m), ←equiv_iff_grundy_value_eq],
  refine equiv_trans _ nim_add_nim_equiv,
  convert add_congr (equiv_nim_grundy_value G) (equiv_nim_grundy_value H);
  simp only [hG, hH]
end

end pgame


-- Int

theorem Int.n_sub_0 (n: Int): n - 0 = n := by
  cases n <;> rfl

theorem Int.ge_0_NonNeg (n: Int): n ≥ 0 ↔ Int.NonNeg n := by
  simp [GE.ge, LE.le, Int.le]
  simp [Int.n_sub_0]

theorem Int.mul_ge_0 (n m: Int): n ≥ 0 → m ≥ 0 → n * m ≥ 0 := by
  rw [Int.ge_0_NonNeg, Int.ge_0_NonNeg, Int.ge_0_NonNeg]
  intros hn hm;
  cases hn; cases hm; constructor

theorem Int.mul_comm (n m: Int): n * m = m * n := by
  sorry

-- Nat

theorem Nat.lt_of_add_lt_add_right {a b c: Nat} (h: a + c < b + c):
    a < b := by
  sorry

theorem Nat.minus_plus_one {a: Nat} (h: a > 0):
    a - 1 + 1 = a := by
  sorry


/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import data.set.basic

/-!

# Partial Equivalences

In this file, we define partial equivalences `pequiv`, which are a bijection between a subset of `α`
and a subset of `β`. Notationally, a `pequiv` is denoted by "`≃.`" (note that the full stop is part
of the notation). The way we store these internally is with two functions `f : α → option β` and
the reverse function `g : β → option α`, with the condition that if `f a` is `option.some b`,
then `g b` is `option.some a`.

## Main results

- `pequiv.of_set`: creates a `pequiv` from a set `s`,
  which sends an element to itself if it is in `s`.
- `pequiv.single`: given two elements `a : α` and `b : β`, create a `pequiv` that sends them to
  each other, and ignores all other elements.
- `pequiv.injective_of_forall_ne_is_some`/`injective_of_forall_is_some`: If the domain of a `pequiv`
  is all of `α` (except possibly one point), its `to_fun` is injective.

## Canonical order

`pequiv` is canonically ordered by inclusion; that is, if a function `f` defined on a subset `s`
is equal to `g` on that subset, but `g` is also defined on a larger set, then `f ≤ g`. We also have
a definition of `⊥`, which is the empty `pequiv` (sends all to `none`), which in the end gives us a
`semilattice_inf` with an `order_bot` instance.

## Tags

pequiv, partial equivalence

-/

universes u v w x

/-- A `pequiv` is a partial equivalence, a representation of a bijection between a subset
  of `α` and a subset of `β`. See also `local_equiv` for a version that requires `to_fun` and
`inv_fun` to be globally defined functions and has `source` and `target` sets as extra fields. -/
structure pequiv (α : Type u) (β : Type v) :=
(to_fun : α → option β)
(inv_fun : β → option α)
(inv : ∀ (a : α) (b : β), a ∈ inv_fun b ↔ b ∈ to_fun a)

infixr ` ≃. `:25 := pequiv

namespace pequiv
variables {α : Type u} {β : Type v} {γ : Type w} {δ : Type x}
open function option

instance : has_coe_to_fun (α ≃. β) (λ _, α → option β) := ⟨to_fun⟩

@[simp] lemma coe_mk_apply (f₁ : α → option β) (f₂ : β → option α) (h) (x : α) :
  (pequiv.mk f₁ f₂ h : α → option β) x = f₁ x := rfl

@[ext] lemma ext : ∀ {f g : α ≃. β} (h : ∀ x, f x = g x), f = g
| ⟨f₁, f₂, hf⟩ ⟨g₁, g₂, hg⟩ h :=
have h : f₁ = g₁, from funext h,
have ∀ b, f₂ b = g₂ b,
  begin
    subst h,
    assume b,
    have hf := λ a, hf a b,
    have hg := λ a, hg a b,
    cases h : g₂ b with a,
    { simp only [h, option.not_mem_none, false_iff] at hg,
      simp only [hg, iff_false] at hf,
      rwa [option.eq_none_iff_forall_not_mem] },
    { rw [← option.mem_def, hf, ← hg, h, option.mem_def] }
  end,
by simp [*, funext_iff]

lemma ext_iff {f g : α ≃. β} : f = g ↔ ∀ x, f x = g x :=
⟨congr_fun ∘ congr_arg _, ext⟩

/-- The identity map as a partial equivalence. -/
@[refl] protected def refl (α : Type*) : α ≃. α :=
{ to_fun := some,
  inv_fun := some,
  inv := λ _ _, eq_comm }

/-- The inverse partial equivalence. -/
@[symm] protected def symm (f : α ≃. β) : β ≃. α :=
{ to_fun := f.2,
  inv_fun := f.1,
  inv := λ _ _, (f.inv _ _).symm }

lemma mem_iff_mem (f : α ≃. β) : ∀ {a : α} {b : β}, a ∈ f.symm b ↔ b ∈ f a := f.3

lemma eq_some_iff (f : α ≃. β) : ∀ {a : α} {b : β}, f.symm b = some a ↔ f a = some b := f.3

/-- Composition of partial equivalences `f : α ≃. β` and `g : β ≃. γ`. -/
@[trans] protected def trans (f : α ≃. β) (g : β ≃. γ) : α ≃. γ :=
{ to_fun := λ a, (f a).bind g,
  inv_fun := λ a, (g.symm a).bind f.symm,
  inv := λ a b, by simp [*, and.comm, eq_some_iff f, eq_some_iff g] at * }

@[simp] lemma refl_apply (a : α) : pequiv.refl α a = some a := rfl

@[simp] lemma symm_refl : (pequiv.refl α).symm = pequiv.refl α := rfl

@[simp] lemma symm_symm (f : α ≃. β) : f.symm.symm = f := by cases f; refl

lemma symm_injective : function.injective (@pequiv.symm α β) :=
left_inverse.injective symm_symm

lemma trans_assoc (f : α ≃. β) (g : β ≃. γ) (h : γ ≃. δ) :
  (f.trans g).trans h = f.trans (g.trans h) :=
ext (λ _, option.bind_assoc _ _ _)

lemma mem_trans (f : α ≃. β) (g : β ≃. γ) (a : α) (c : γ) :
  c ∈ f.trans g a ↔ ∃ b, b ∈ f a ∧ c ∈ g b := option.bind_eq_some'

lemma trans_eq_some (f : α ≃. β) (g : β ≃. γ) (a : α) (c : γ) :
  f.trans g a = some c ↔ ∃ b, f a = some b ∧ g b = some c := option.bind_eq_some'

lemma trans_eq_none (f : α ≃. β) (g : β ≃. γ) (a : α) :
  f.trans g a = none ↔ (∀ b c, b ∉ f a ∨ c ∉ g b) :=
begin
  simp only [eq_none_iff_forall_not_mem, mem_trans, imp_iff_not_or.symm],
  push_neg, tauto
end

@[simp] lemma refl_trans (f : α ≃. β) : (pequiv.refl α).trans f = f :=
by ext; dsimp [pequiv.trans]; refl

@[simp] lemma trans_refl (f : α ≃. β) : f.trans (pequiv.refl β) = f :=
by ext; dsimp [pequiv.trans]; simp

protected lemma inj (f : α ≃. β) {a₁ a₂ : α} {b : β} (h₁ : b ∈ f a₁) (h₂ : b ∈ f a₂) : a₁ = a₂ :=
by rw ← mem_iff_mem at *; cases h : f.symm b; simp * at *

/-- If the domain of a `pequiv` is `α` except a point, its forward direction is injective. -/
lemma injective_of_forall_ne_is_some (f : α ≃. β) (a₂ : α)
  (h : ∀ (a₁ : α), a₁ ≠ a₂ → is_some (f a₁)) : injective f :=
has_left_inverse.injective
  ⟨λ b, option.rec_on b a₂ (λ b', option.rec_on (f.symm b') a₂ id),
    λ x, begin
      classical,
      cases hfx : f x,
      { have : x = a₂, from not_imp_comm.1 (h x) (hfx.symm ▸ by simp), simp [this] },
      { simp only [hfx], rw [(eq_some_iff f).2 hfx], refl }
    end⟩

/-- If the domain of a `pequiv` is all of `α`, its forward direction is injective. -/
lemma injective_of_forall_is_some {f : α ≃. β}
  (h : ∀ (a : α), is_some (f a)) : injective f :=
(classical.em (nonempty α)).elim
  (λ hn, injective_of_forall_ne_is_some f (classical.choice hn)
    (λ a _, h a))
  (λ hn x, (hn ⟨x⟩).elim)

section of_set
variables (s : set α) [decidable_pred (∈ s)]

/-- Creates a `pequiv` that is the identity on `s`, and `none` outside of it. -/
def of_set (s : set α) [decidable_pred (∈ s)] : α ≃. α :=
{ to_fun := λ a, if a ∈ s then some a else none,
  inv_fun := λ a, if a ∈ s then some a else none,
  inv := λ a b, by
  { split_ifs with hb ha ha,
    { simp [eq_comm] },
    { simp [ne_of_mem_of_not_mem hb ha] },
    { simp [ne_of_mem_of_not_mem ha hb] },
    { simp } } }

lemma mem_of_set_self_iff {s : set α} [decidable_pred (∈ s)] {a : α} : a ∈ of_set s a ↔ a ∈ s :=
by dsimp [of_set]; split_ifs; simp *

lemma mem_of_set_iff {s : set α} [decidable_pred (∈ s)] {a b : α} :
  a ∈ of_set s b ↔ a = b ∧ a ∈ s :=
begin
  dsimp [of_set],
  split_ifs,
  { simp only [iff_self_and, option.mem_def, eq_comm],
    rintro rfl,
    exact h, },
  { simp only [false_iff, not_and, option.not_mem_none],
    rintro rfl,
    exact h, }
end

@[simp] lemma of_set_eq_some_iff {s : set α} {h : decidable_pred (∈ s)} {a b : α} :
  of_set s b = some a ↔ a = b ∧ a ∈ s := mem_of_set_iff

@[simp] lemma of_set_eq_some_self_iff {s : set α} {h : decidable_pred (∈ s)} {a : α} :
  of_set s a = some a ↔ a ∈ s := mem_of_set_self_iff

@[simp] lemma of_set_symm : (of_set s).symm = of_set s := rfl

@[simp] lemma of_set_univ : of_set set.univ = pequiv.refl α := rfl

@[simp]

end of_set

lemma symm_trans_rev (f : α ≃. β) (g : β ≃. γ) : (f.trans g).symm = g.symm.trans f.symm := rfl

lemma self_trans_symm (f : α ≃. β) : f.trans f.symm = of_set {a | (f a).is_some} :=
begin
  ext,
  dsimp [pequiv.trans],
  simp only [eq_some_iff f, option.is_some_iff_exists, option.mem_def, bind_eq_some',
    of_set_eq_some_iff],
  split,
  { rintros ⟨b, hb₁, hb₂⟩,
    exact ⟨pequiv.inj _ hb₂ hb₁, b, hb₂⟩ },
  { simp {contextual := tt} }
end

lemma symm_trans_self (f : α ≃. β) : f.symm.trans f = of_set {b | (f.symm b).is_some} :=
symm_injective $ by simp [symm_trans_rev, self_trans_symm, -symm_symm]

lemma trans_symm_eq_iff_forall_is_some {f : α ≃. β} :
  f.trans f.symm = pequiv.refl α ↔ ∀ a, is_some (f a) :=
by rw [self_trans_symm, of_set_eq_refl, set.eq_univ_iff_forall]; refl

instance : has_bot (α ≃. β) :=
⟨{ to_fun := λ _, none,
   inv_fun := λ _, none,
   inv := by simp }⟩

instance : inhabited (α ≃. β) := ⟨⊥⟩

@[simp] lemma bot_apply (a : α) : (⊥ : α ≃. β) a = none := rfl

@[simp] lemma symm_bot : (⊥ : α ≃. β).symm = ⊥ := rfl

@[simp] lemma trans_bot (f : α ≃. β) : f.trans (⊥ : β ≃. γ) = ⊥ :=
by ext; dsimp [pequiv.trans]; simp

@[simp] lemma bot_trans (f : β ≃. γ) : (⊥ : α ≃. β).trans f = ⊥ :=
by ext; dsimp [pequiv.trans]; simp

lemma is_some_symm_get (f : α ≃. β) {a : α} (h : is_some (f a)) :
  is_some (f.symm (option.get h)) :=
is_some_iff_exists.2 ⟨a, by rw [f.eq_some_iff, some_get]⟩

section single
variables [decidable_eq α] [decidable_eq β] [decidable_eq γ]

/-- Create a `pequiv` which sends `a` to `b` and `b` to `a`, but is otherwise `none`. -/
def single (a : α) (b : β) : α ≃. β :=
{ to_fun := λ x, if x = a then some b else none,
  inv_fun := λ x, if x = b then some a else none,
  inv := λ _ _, by simp; split_ifs; cc }

lemma mem_single (a : α) (b : β) : b ∈ single a b a := if_pos rfl

lemma mem_single_iff (a₁ a₂ : α) (b₁ b₂ : β) : b₁ ∈ single a₂ b₂ a₁ ↔ a₁ = a₂ ∧ b₁ = b₂ :=
by dsimp [single]; split_ifs; simp [*, eq_comm]

@[simp] lemma symm_single (a : α) (b : β) : (single a b).symm = single b a := rfl

@[simp] lemma single_apply (a : α) (b : β) : single a b a = some b := if_pos rfl

lemma single_apply_of_ne {a₁ a₂ : α} (h : a₁ ≠ a₂) (b : β) : single a₁ b a₂ = none := if_neg h.symm

lemma single_trans_of_mem (a : α) {b : β} {c : γ} {f : β ≃. γ} (h : c ∈ f b) :
  (single a b).trans f = single a c :=
begin
  ext,
  dsimp [single, pequiv.trans],
  split_ifs; simp * at *
end

lemma trans_single_of_mem {a : α} {b : β} (c : γ) {f : α ≃. β} (h : b ∈ f a) :
  f.trans (single b c) = single a c :=
symm_injective $ single_trans_of_mem _ ((mem_iff_mem f).2 h)

@[simp]
lemma single_trans_single (a : α) (b : β) (c : γ) : (single a b).trans (single b c) = single a c :=
single_trans_of_mem _ (mem_single _ _)

@[simp] lemma single_subsingleton_eq_refl [subsingleton α] (a b : α) : single a b = pequiv.refl α :=
begin
  ext i j,
  dsimp [single],
  rw [if_pos (subsingleton.elim i a), subsingleton.elim i j, subsingleton.elim b j]
end

lemma trans_single_of_eq_none {b : β} (c : γ) {f : δ ≃. β} (h : f.symm b = none) :
  f.trans (single b c) = ⊥ :=
begin
  ext,
  simp only [eq_none_iff_forall_not_mem, option.mem_def, f.eq_some_iff] at h,
  dsimp [pequiv.trans, single],
  simp,
  intros,
  split_ifs;
  simp * at *
end

lemma single_trans_of_eq_none (a : α) {b : β} {f : β ≃. δ} (h : f b = none) :
  (single a b).trans f = ⊥ :=
symm_injective $ trans_single_of_eq_none _ h

lemma single_trans_single_of_ne {b₁ b₂ : β} (h : b₁ ≠ b₂) (a : α) (c : γ) :
  (single a b₁).trans (single b₂ c) = ⊥ :=
single_trans_of_eq_none _ (single_apply_of_ne h.symm _)

end single

section order

instance : partial_order (α ≃. β) :=
{ le := λ f g, ∀ (a : α) (b : β), b ∈ f a → b ∈ g a,
  le_refl := λ _ _ _, id,
  le_trans := λ f g h fg gh a b, (gh a b) ∘ (fg a b),
  le_antisymm := λ f g fg gf, ext begin
    assume a,
    cases h : g a with b,
    { exact eq_none_iff_forall_not_mem.2
       (λ b hb, option.not_mem_none b $ h ▸ fg a b hb) },
    { exact gf _ _ h }
  end }

lemma le_def {f g : α ≃. β} : f ≤ g ↔ (∀ (a : α) (b : β), b ∈ f a → b ∈ g a) := iff.rfl

instance : order_bot (α ≃. β) :=
{ bot_le := λ _ _  _ h, (not_mem_none _ h).elim,
  ..pequiv.has_bot }

instance [decidable_eq α] [decidable_eq β] : semilattice_inf (α ≃. β) :=
{ inf := λ f g,
  { to_fun := λ a, if f a = g a then f a else none,
    inv_fun := λ b, if f.symm b = g.symm b then f.symm b else none,
    inv := λ a b, begin
      have := @mem_iff_mem _ _ f a b,
      have := @mem_iff_mem _ _ g a b,
      split_ifs; finish
    end },
  inf_le_left := λ _ _ _ _, by simp; split_ifs; cc,
  inf_le_right := λ _ _ _ _, by simp; split_ifs; cc,
  le_inf := λ f g h fg gh a b, begin
    have := fg a b,
    have := gh a b,
    simp [le_def],
    split_ifs; finish
  end,
  ..pequiv.partial_order }

end order

end pequiv

namespace equiv
variables {α : Type*} {β : Type*} {γ : Type*}

/-- Turns an `equiv` into a `pequiv` of the whole type. -/
def to_pequiv (f : α ≃ β) : α ≃. β :=
{ to_fun := some ∘ f,
  inv_fun := some ∘ f.symm,
  inv := by simp [equiv.eq_symm_apply, eq_comm] }

@[simp] lemma to_pequiv_refl : (equiv.refl α).to_pequiv = pequiv.refl α := rfl

lemma to_pequiv_trans (f : α ≃ β) (g : β ≃ γ) : (f.trans g).to_pequiv =
  f.to_pequiv.trans g.to_pequiv := rfl

lemma to_pequiv_symm (f : α ≃ β) : f.symm.to_pequiv = f.to_pequiv.symm := rfl

lemma to_pequiv_apply (f : α ≃ β) (x : α) : f.to_pequiv x = some (f x) := rfl

end equiv


/-
Copyright (c) 2021 Alex Kontorovich and Heather Macbeth and Marc Masdeu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alex Kontorovich, Heather Macbeth, Marc Masdeu

! This file was ported from Lean 3 source module analysis.complex.upper_half_plane.basic
! leanprover-community/mathlib commit 34d3797325d202bd7250431275bb871133cdb611
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fintype.Parity
import Mathbin.LinearAlgebra.Matrix.SpecialLinearGroup
import Mathbin.Analysis.Complex.Basic
import Mathbin.GroupTheory.GroupAction.Defs
import Mathbin.LinearAlgebra.Matrix.GeneralLinearGroup
import Mathbin.Tactic.LinearCombination

/-!
# The upper half plane and its automorphisms

This file defines `upper_half_plane` to be the upper half plane in `ℂ`.

We furthermore equip it with the structure of an `GL_pos 2 ℝ` action by
fractional linear transformations.

We define the notation `ℍ` for the upper half plane available in the locale
`upper_half_plane` so as not to conflict with the quaternions.
-/

noncomputable section

open Matrix Matrix.SpecialLinearGroup

open Classical BigOperators MatrixGroups

attribute [local instance] Fintype.card_fin_even

/- Disable these instances as they are not the simp-normal form, and having them disabled ensures
we state lemmas in this file without spurious `coe_fn` terms. -/
attribute [-instance] Matrix.SpecialLinearGroup.hasCoeToFun

attribute [-instance] Matrix.GeneralLinearGroup.hasCoeToFun

-- mathport name: «expr↑ₘ »
local prefix:1024 "↑ₘ" => @coe _ (Matrix (Fin 2) (Fin 2) _) _

-- mathport name: «expr↑ₘ[ ]»
local notation:1024 "↑ₘ[" R "]" => @coe _ (Matrix (Fin 2) (Fin 2) R) _

-- mathport name: «exprGL( , )⁺»
local notation "GL(" n ", " R ")" "⁺" => Matrix.gLPos (Fin n) R

/- ./././Mathport/Syntax/Translate/Command.lean:42:9: unsupported derive handler λ α,
has_coe[has_coe] α exprℂ() -/
/-- The open upper half plane -/
def UpperHalfPlane :=
  { point : ℂ // 0 < point.im }deriving
  «./././Mathport/Syntax/Translate/Command.lean:42:9: unsupported derive handler λ α,
  has_coe[has_coe] α exprℂ()»
#align upper_half_plane UpperHalfPlane

-- mathport name: upper_half_plane
scoped[UpperHalfPlane] notation "ℍ" => UpperHalfPlane

namespace UpperHalfPlane

instance : Inhabited ℍ :=
  ⟨⟨Complex.I, by simp⟩⟩

instance canLift : CanLift ℂ ℍ coe fun z => 0 < z.im :=
  Subtype.canLift fun z => 0 < z.im
#align upper_half_plane.can_lift UpperHalfPlane.canLift

/-- Imaginary part -/
def im (z : ℍ) :=
  (z : ℂ).im
#align upper_half_plane.im UpperHalfPlane.im

/-- Real part -/
def re (z : ℍ) :=
  (z : ℂ).re
#align upper_half_plane.re UpperHalfPlane.re

/-- Constructor for `upper_half_plane`. It is useful if `⟨z, h⟩` makes Lean use a wrong
typeclass instance. -/
def mk (z : ℂ) (h : 0 < z.im) : ℍ :=
  ⟨z, h⟩
#align upper_half_plane.mk UpperHalfPlane.mk

@[simp]
theorem coe_im (z : ℍ) : (z : ℂ).im = z.im :=
  rfl
#align upper_half_plane.coe_im UpperHalfPlane.coe_im

@[simp]
theorem coe_re (z : ℍ) : (z : ℂ).re = z.re :=
  rfl
#align upper_half_plane.coe_re UpperHalfPlane.coe_re

@[simp]
theorem mk_re (z : ℂ) (h : 0 < z.im) : (mk z h).re = z.re :=
  rfl
#align upper_half_plane.mk_re UpperHalfPlane.mk_re

@[simp]
theorem mk_im (z : ℂ) (h : 0 < z.im) : (mk z h).im = z.im :=
  rfl
#align upper_half_plane.mk_im UpperHalfPlane.mk_im

@[simp]
theorem coe_mk (z : ℂ) (h : 0 < z.im) : (mk z h : ℂ) = z :=
  rfl
#align upper_half_plane.coe_mk UpperHalfPlane.coe_mk

@[simp]
theorem mk_coe (z : ℍ) (h : 0 < (z : ℂ).im := z.2) : mk z h = z :=
  Subtype.eta z h
#align upper_half_plane.mk_coe UpperHalfPlane.mk_coe

theorem re_add_im (z : ℍ) : (z.re + z.im * Complex.I : ℂ) = z :=
  Complex.re_add_im z
#align upper_half_plane.re_add_im UpperHalfPlane.re_add_im

theorem im_pos (z : ℍ) : 0 < z.im :=
  z.2
#align upper_half_plane.im_pos UpperHalfPlane.im_pos

theorem im_ne_zero (z : ℍ) : z.im ≠ 0 :=
  z.im_pos.ne'
#align upper_half_plane.im_ne_zero UpperHalfPlane.im_ne_zero

theorem ne_zero (z : ℍ) : (z : ℂ) ≠ 0 :=
  mt (congr_arg Complex.im) z.im_ne_zero
#align upper_half_plane.ne_zero UpperHalfPlane.ne_zero

theorem normSq_pos (z : ℍ) : 0 < Complex.normSq (z : ℂ) :=
  by
  rw [Complex.normSq_pos]
  exact z.ne_zero
#align upper_half_plane.norm_sq_pos UpperHalfPlane.normSq_pos

theorem normSq_ne_zero (z : ℍ) : Complex.normSq (z : ℂ) ≠ 0 :=
  (normSq_pos z).ne'
#align upper_half_plane.norm_sq_ne_zero UpperHalfPlane.normSq_ne_zero

theorem im_inv_neg_coe_pos (z : ℍ) : 0 < (-z : ℂ)⁻¹.im := by
  simpa using div_pos z.property (norm_sq_pos z)
#align upper_half_plane.im_inv_neg_coe_pos UpperHalfPlane.im_inv_neg_coe_pos

/-- Numerator of the formula for a fractional linear transformation -/
@[simp]
def num (g : GL(2, ℝ)⁺) (z : ℍ) : ℂ :=
  (↑ₘg 0 0 : ℝ) * z + (↑ₘg 0 1 : ℝ)
#align upper_half_plane.num UpperHalfPlane.num

/-- Denominator of the formula for a fractional linear transformation -/
@[simp]
def denom (g : GL(2, ℝ)⁺) (z : ℍ) : ℂ :=
  (↑ₘg 1 0 : ℝ) * z + (↑ₘg 1 1 : ℝ)
#align upper_half_plane.denom UpperHalfPlane.denom

theorem linear_ne_zero (cd : Fin 2 → ℝ) (z : ℍ) (h : cd ≠ 0) : (cd 0 : ℂ) * z + cd 1 ≠ 0 :=
  by
  contrapose! h
  have : cd 0 = 0 :=
    by
    -- we will need this twice
    apply_fun Complex.im  at h
    simpa only [z.im_ne_zero, Complex.add_im, add_zero, coe_im, MulZeroClass.zero_mul, or_false_iff,
      Complex.ofReal_im, Complex.zero_im, Complex.mul_im, mul_eq_zero] using h
  simp only [this, MulZeroClass.zero_mul, Complex.ofReal_zero, zero_add, Complex.ofReal_eq_zero] at
    h
  ext i
  fin_cases i <;> assumption
#align upper_half_plane.linear_ne_zero UpperHalfPlane.linear_ne_zero

theorem denom_ne_zero (g : GL(2, ℝ)⁺) (z : ℍ) : denom g z ≠ 0 :=
  by
  intro H
  have DET := (mem_GL_pos _).1 g.prop
  have hz := z.prop
  simp only [general_linear_group.coe_det_apply] at DET
  have H1 : (↑ₘg 1 0 : ℝ) = 0 ∨ z.im = 0 := by simpa using congr_arg Complex.im H
  cases H1
  · simp only [H1, Complex.ofReal_zero, denom, coe_fn_eq_coe, MulZeroClass.zero_mul, zero_add,
      Complex.ofReal_eq_zero] at H
    rw [← coe_coe, Matrix.det_fin_two (↑g : Matrix (Fin 2) (Fin 2) ℝ)] at DET
    simp only [coe_coe, H, H1, MulZeroClass.mul_zero, sub_zero, lt_self_iff_false] at DET
    exact DET
  · change z.im > 0 at hz
    linarith
#align upper_half_plane.denom_ne_zero UpperHalfPlane.denom_ne_zero

theorem normSq_denom_pos (g : GL(2, ℝ)⁺) (z : ℍ) : 0 < Complex.normSq (denom g z) :=
  Complex.normSq_pos.mpr (denom_ne_zero g z)
#align upper_half_plane.norm_sq_denom_pos UpperHalfPlane.normSq_denom_pos

theorem normSq_denom_ne_zero (g : GL(2, ℝ)⁺) (z : ℍ) : Complex.normSq (denom g z) ≠ 0 :=
  ne_of_gt (normSq_denom_pos g z)
#align upper_half_plane.norm_sq_denom_ne_zero UpperHalfPlane.normSq_denom_ne_zero

/-- Fractional linear transformation, also known as the Moebius transformation -/
def smulAux' (g : GL(2, ℝ)⁺) (z : ℍ) : ℂ :=
  num g z / denom g z
#align upper_half_plane.smul_aux' UpperHalfPlane.smulAux'

theorem smulAux'_im (g : GL(2, ℝ)⁺) (z : ℍ) :
    (smulAux' g z).im = det ↑ₘg * z.im / (denom g z).normSq :=
  by
  rw [smul_aux', Complex.div_im]
  set NsqBot := (denom g z).normSq
  have : NsqBot ≠ 0 := by simp only [denom_ne_zero g z, map_eq_zero, Ne.def, not_false_iff]
  field_simp [smul_aux', -coe_coe]
  rw [Matrix.det_fin_two ↑ₘg]
  ring
#align upper_half_plane.smul_aux'_im UpperHalfPlane.smulAux'_im

/-- Fractional linear transformation, also known as the Moebius transformation -/
def smulAux (g : GL(2, ℝ)⁺) (z : ℍ) : ℍ :=
  ⟨smulAux' g z, by
    rw [smul_aux'_im]
    convert mul_pos ((mem_GL_pos _).1 g.prop)
        (div_pos z.im_pos (complex.norm_sq_pos.mpr (denom_ne_zero g z)))
    simp only [general_linear_group.coe_det_apply, coe_coe]
    ring⟩
#align upper_half_plane.smul_aux UpperHalfPlane.smulAux

theorem denom_cocycle (x y : GL(2, ℝ)⁺) (z : ℍ) :
    denom (x * y) z = denom x (smulAux y z) * denom y z :=
  by
  change _ = (_ * (_ / _) + _) * _
  field_simp [denom_ne_zero, -denom, -Num]
  simp only [Matrix.mul, dot_product, Fin.sum_univ_succ, denom, Num, coe_coe, Subgroup.coe_mul,
    general_linear_group.coe_mul, Fintype.univ_ofSubsingleton, Fin.mk_zero, Finset.sum_singleton,
    Fin.succ_zero_eq_one, Complex.ofReal_add, Complex.ofReal_mul]
  ring
#align upper_half_plane.denom_cocycle UpperHalfPlane.denom_cocycle

theorem mul_smul' (x y : GL(2, ℝ)⁺) (z : ℍ) : smulAux (x * y) z = smulAux x (smulAux y z) :=
  by
  ext1
  change _ / _ = (_ * (_ / _) + _) * _
  rw [denom_cocycle]
  field_simp [denom_ne_zero, -denom, -Num]
  simp only [Matrix.mul, dot_product, Fin.sum_univ_succ, Num, denom, coe_coe, Subgroup.coe_mul,
    general_linear_group.coe_mul, Fintype.univ_ofSubsingleton, Fin.mk_zero, Finset.sum_singleton,
    Fin.succ_zero_eq_one, Complex.ofReal_add, Complex.ofReal_mul]
  ring
#align upper_half_plane.mul_smul' UpperHalfPlane.mul_smul'

/-- The action of ` GL_pos 2 ℝ` on the upper half-plane by fractional linear transformations. -/
instance : MulAction GL(2, ℝ)⁺ ℍ where
  smul := smulAux
  one_smul z := by
    ext1
    change _ / _ = _
    simp [coeFn_coe_base']
  mul_smul := mul_smul'

section ModularScalarTowers

variable (Γ : Subgroup (SpecialLinearGroup (Fin 2) ℤ))

instance sLAction {R : Type _} [CommRing R] [Algebra R ℝ] : MulAction SL(2, R) ℍ :=
  MulAction.compHom ℍ <| SpecialLinearGroup.toGLPos.comp <| map (algebraMap R ℝ)
#align upper_half_plane.SL_action UpperHalfPlane.sLAction

instance : Coe SL(2, ℤ) GL(2, ℝ)⁺ :=
  ⟨fun g => ((g : SL(2, ℝ)) : GL(2, ℝ)⁺)⟩

instance sLOnGLPos : SMul SL(2, ℤ) GL(2, ℝ)⁺ :=
  ⟨fun s g => s * g⟩
#align upper_half_plane.SL_on_GL_pos UpperHalfPlane.sLOnGLPos

theorem sLOnGLPos_smul_apply (s : SL(2, ℤ)) (g : GL(2, ℝ)⁺) (z : ℍ) :
    (s • g) • z = ((s : GL(2, ℝ)⁺) * g) • z :=
  rfl
#align upper_half_plane.SL_on_GL_pos_smul_apply UpperHalfPlane.sLOnGLPos_smul_apply

instance SL_to_GL_tower : IsScalarTower SL(2, ℤ) GL(2, ℝ)⁺ ℍ
    where smul_assoc := by
    intro s g z
    simp only [SL_on_GL_pos_smul_apply, coe_coe]
    apply mul_smul'
#align upper_half_plane.SL_to_GL_tower UpperHalfPlane.SL_to_GL_tower

instance subgroupGLPos : SMul Γ GL(2, ℝ)⁺ :=
  ⟨fun s g => s * g⟩
#align upper_half_plane.subgroup_GL_pos UpperHalfPlane.subgroupGLPos

theorem subgroup_on_gLPos_smul_apply (s : Γ) (g : GL(2, ℝ)⁺) (z : ℍ) :
    (s • g) • z = ((s : GL(2, ℝ)⁺) * g) • z :=
  rfl
#align upper_half_plane.subgroup_on_GL_pos_smul_apply UpperHalfPlane.subgroup_on_gLPos_smul_apply

instance subgroup_on_gLPos : IsScalarTower Γ GL(2, ℝ)⁺ ℍ
    where smul_assoc := by
    intro s g z
    simp only [subgroup_on_GL_pos_smul_apply, coe_coe]
    apply mul_smul'
#align upper_half_plane.subgroup_on_GL_pos UpperHalfPlane.subgroup_on_gLPos

instance subgroupSL : SMul Γ SL(2, ℤ) :=
  ⟨fun s g => s * g⟩
#align upper_half_plane.subgroup_SL UpperHalfPlane.subgroupSL

theorem subgroup_on_SL_apply (s : Γ) (g : SL(2, ℤ)) (z : ℍ) :
    (s • g) • z = ((s : SL(2, ℤ)) * g) • z :=
  rfl
#align upper_half_plane.subgroup_on_SL_apply UpperHalfPlane.subgroup_on_SL_apply

instance subgroup_to_SL_tower : IsScalarTower Γ SL(2, ℤ) ℍ
    where smul_assoc s g z := by
    rw [subgroup_on_SL_apply]
    apply MulAction.mul_smul
#align upper_half_plane.subgroup_to_SL_tower UpperHalfPlane.subgroup_to_SL_tower

end ModularScalarTowers

theorem specialLinearGroup_apply {R : Type _} [CommRing R] [Algebra R ℝ] (g : SL(2, R)) (z : ℍ) :
    g • z =
      mk
        ((((↑(↑ₘ[R] g 0 0) : ℝ) : ℂ) * z + ((↑(↑ₘ[R] g 0 1) : ℝ) : ℂ)) /
          (((↑(↑ₘ[R] g 1 0) : ℝ) : ℂ) * z + ((↑(↑ₘ[R] g 1 1) : ℝ) : ℂ)))
        (g • z).property :=
  rfl
#align upper_half_plane.special_linear_group_apply UpperHalfPlane.specialLinearGroup_apply

@[simp]
theorem coe_smul (g : GL(2, ℝ)⁺) (z : ℍ) : ↑(g • z) = num g z / denom g z :=
  rfl
#align upper_half_plane.coe_smul UpperHalfPlane.coe_smul

@[simp]
theorem re_smul (g : GL(2, ℝ)⁺) (z : ℍ) : (g • z).re = (num g z / denom g z).re :=
  rfl
#align upper_half_plane.re_smul UpperHalfPlane.re_smul

theorem im_smul (g : GL(2, ℝ)⁺) (z : ℍ) : (g • z).im = (num g z / denom g z).im :=
  rfl
#align upper_half_plane.im_smul UpperHalfPlane.im_smul

theorem im_smul_eq_div_normSq (g : GL(2, ℝ)⁺) (z : ℍ) :
    (g • z).im = det ↑ₘg * z.im / Complex.normSq (denom g z) :=
  smulAux'_im g z
#align upper_half_plane.im_smul_eq_div_norm_sq UpperHalfPlane.im_smul_eq_div_normSq

@[simp]
theorem neg_smul (g : GL(2, ℝ)⁺) (z : ℍ) : -g • z = g • z :=
  by
  ext1
  change _ / _ = _ / _
  field_simp [denom_ne_zero, -denom, -Num]
  simp only [Num, denom, coe_coe, Complex.ofReal_neg, neg_mul, GL_pos.coe_neg_GL, Units.val_neg,
    Pi.neg_apply]
  ring_nf
#align upper_half_plane.neg_smul UpperHalfPlane.neg_smul

section SLModularAction

variable (g : SL(2, ℤ)) (z : ℍ) (Γ : Subgroup SL(2, ℤ))

@[simp]
theorem sl_moeb (A : SL(2, ℤ)) (z : ℍ) : A • z = (A : GL(2, ℝ)⁺) • z :=
  rfl
#align upper_half_plane.sl_moeb UpperHalfPlane.sl_moeb

theorem subgroup_moeb (A : Γ) (z : ℍ) : A • z = (A : GL(2, ℝ)⁺) • z :=
  rfl
#align upper_half_plane.subgroup_moeb UpperHalfPlane.subgroup_moeb

@[simp]
theorem subgroup_to_sl_moeb (A : Γ) (z : ℍ) : A • z = (A : SL(2, ℤ)) • z :=
  rfl
#align upper_half_plane.subgroup_to_sl_moeb UpperHalfPlane.subgroup_to_sl_moeb

@[simp]
theorem SL_neg_smul (g : SL(2, ℤ)) (z : ℍ) : -g • z = g • z := by
  simp only [coe_GL_pos_neg, sl_moeb, coe_coe, coe_int_neg, neg_smul]
#align upper_half_plane.SL_neg_smul UpperHalfPlane.SL_neg_smul

theorem c_mul_im_sq_le_normSq_denom (z : ℍ) (g : SL(2, ℝ)) :
    ((↑ₘg 1 0 : ℝ) * z.im) ^ 2 ≤ Complex.normSq (denom g z) :=
  by
  let c := (↑ₘg 1 0 : ℝ)
  let d := (↑ₘg 1 1 : ℝ)
  calc
    (c * z.im) ^ 2 ≤ (c * z.im) ^ 2 + (c * z.re + d) ^ 2 := by nlinarith
    _ = Complex.normSq (denom g z) := by simp [Complex.normSq] <;> ring

#align upper_half_plane.c_mul_im_sq_le_norm_sq_denom UpperHalfPlane.c_mul_im_sq_le_normSq_denom

theorem SpecialLinearGroup.im_smul_eq_div_normSq : (g • z).im = z.im / Complex.normSq (denom g z) :=
  by
  convert im_smul_eq_div_norm_sq g z
  simp only [coe_coe, general_linear_group.coe_det_apply, coe_GL_pos_coe_GL_coe_matrix,
    Int.coe_castRingHom, (g : SL(2, ℝ)).Prop, one_mul]
#align upper_half_plane.special_linear_group.im_smul_eq_div_norm_sq UpperHalfPlane.SpecialLinearGroup.im_smul_eq_div_normSq

theorem denom_apply (g : SL(2, ℤ)) (z : ℍ) :
    denom g z = (↑g : Matrix (Fin 2) (Fin 2) ℤ) 1 0 * z + (↑g : Matrix (Fin 2) (Fin 2) ℤ) 1 1 := by
  simp
#align upper_half_plane.denom_apply UpperHalfPlane.denom_apply

end SLModularAction

section PosRealAction

instance posRealAction : MulAction { x : ℝ // 0 < x } ℍ
    where
  smul x z := mk ((x : ℝ) • z) <| by simpa using mul_pos x.2 z.2
  one_smul z := Subtype.ext <| one_smul _ _
  mul_smul x y z := Subtype.ext <| mul_smul (x : ℝ) y (z : ℂ)
#align upper_half_plane.pos_real_action UpperHalfPlane.posRealAction

variable (x : { x : ℝ // 0 < x }) (z : ℍ)

@[simp]
theorem coe_pos_real_smul : ↑(x • z) = (x : ℝ) • (z : ℂ) :=
  rfl
#align upper_half_plane.coe_pos_real_smul UpperHalfPlane.coe_pos_real_smul

@[simp]
theorem pos_real_im : (x • z).im = x * z.im :=
  Complex.smul_im _ _
#align upper_half_plane.pos_real_im UpperHalfPlane.pos_real_im

@[simp]
theorem pos_real_re : (x • z).re = x * z.re :=
  Complex.smul_re _ _
#align upper_half_plane.pos_real_re UpperHalfPlane.pos_real_re

end PosRealAction

section RealAddAction

instance : AddAction ℝ ℍ
    where
  vadd x z := mk (x + z) <| by simpa using z.im_pos
  zero_vadd z := Subtype.ext <| by simp
  add_vadd x y z := Subtype.ext <| by simp [add_assoc]

variable (x : ℝ) (z : ℍ)

@[simp]
theorem coe_vadd : ↑(x +ᵥ z) = (x + z : ℂ) :=
  rfl
#align upper_half_plane.coe_vadd UpperHalfPlane.coe_vadd

@[simp]
theorem vadd_re : (x +ᵥ z).re = x + z.re :=
  rfl
#align upper_half_plane.vadd_re UpperHalfPlane.vadd_re

@[simp]
theorem vadd_im : (x +ᵥ z).im = z.im :=
  zero_add _
#align upper_half_plane.vadd_im UpperHalfPlane.vadd_im

end RealAddAction

/- these next few lemmas are *not* flagged `@simp` because of the constructors on the RHS;
instead we use the versions with coercions to `ℂ` as simp lemmas instead. -/
theorem modular_s_smul (z : ℍ) : ModularGroup.s • z = mk (-z : ℂ)⁻¹ z.im_inv_neg_coe_pos :=
  by
  rw [special_linear_group_apply]
  simp [ModularGroup.s, neg_div, inv_neg]
#align upper_half_plane.modular_S_smul UpperHalfPlane.modular_s_smul

theorem modular_t_zpow_smul (z : ℍ) (n : ℤ) : ModularGroup.t ^ n • z = (n : ℝ) +ᵥ z :=
  by
  rw [← Subtype.coe_inj, coe_vadd, add_comm, special_linear_group_apply, coe_mk,
    ModularGroup.coe_t_zpow]
  simp only [of_apply, cons_val_zero, algebraMap.coe_one, Complex.ofReal_one, one_mul, cons_val_one,
    head_cons, algebraMap.coe_zero, MulZeroClass.zero_mul, zero_add, div_one]
#align upper_half_plane.modular_T_zpow_smul UpperHalfPlane.modular_t_zpow_smul

theorem modular_t_smul (z : ℍ) : ModularGroup.t • z = (1 : ℝ) +ᵥ z := by
  simpa only [algebraMap.coe_one] using modular_T_zpow_smul z 1
#align upper_half_plane.modular_T_smul UpperHalfPlane.modular_t_smul

theorem exists_SL2_smul_eq_of_apply_zero_one_eq_zero (g : SL(2, ℝ)) (hc : ↑ₘ[ℝ] g 1 0 = 0) :
    ∃ (u : { x : ℝ // 0 < x })(v : ℝ), ((· • ·) g : ℍ → ℍ) = (fun z => v +ᵥ z) ∘ fun z => u • z :=
  by
  obtain ⟨a, b, ha, rfl⟩ := g.fin_two_exists_eq_mk_of_apply_zero_one_eq_zero hc
  refine' ⟨⟨_, mul_self_pos.mpr ha⟩, b * a, _⟩
  ext1 ⟨z, hz⟩
  ext1
  suffices ↑a * z * a + b * a = b * a + a * a * z
    by
    rw [special_linear_group_apply]
    simpa [add_mul]
  ring
#align upper_half_plane.exists_SL2_smul_eq_of_apply_zero_one_eq_zero UpperHalfPlane.exists_SL2_smul_eq_of_apply_zero_one_eq_zero

theorem exists_SL2_smul_eq_of_apply_zero_one_ne_zero (g : SL(2, ℝ)) (hc : ↑ₘ[ℝ] g 1 0 ≠ 0) :
    ∃ (u : { x : ℝ // 0 < x })(v w : ℝ),
      ((· • ·) g : ℍ → ℍ) =
        ((· +ᵥ ·) w : ℍ → ℍ) ∘
          ((· • ·) ModularGroup.s : ℍ → ℍ) ∘ ((· +ᵥ ·) v : ℍ → ℍ) ∘ ((· • ·) u : ℍ → ℍ) :=
  by
  have h_denom := denom_ne_zero g
  induction' g using Matrix.SpecialLinearGroup.fin_two_induction with a b c d h
  replace hc : c ≠ 0
  · simpa using hc
  refine' ⟨⟨_, mul_self_pos.mpr hc⟩, c * d, a / c, _⟩
  ext1 ⟨z, hz⟩
  ext1
  suffices (↑a * z + b) / (↑c * z + d) = a / c - (c * d + ↑c * ↑c * z)⁻¹
    by
    rw [special_linear_group_apply]
    simpa only [inv_neg, modular_S_smul, Subtype.coe_mk, coe_vadd, Complex.ofReal_mul,
      coe_pos_real_smul, Complex.real_smul, Function.comp_apply, Complex.ofReal_div]
  replace hc : (c : ℂ) ≠ 0
  · norm_cast
    assumption
  replace h_denom : ↑c * z + d ≠ 0
  · simpa using h_denom ⟨z, hz⟩
  have h_aux : (c : ℂ) * d + ↑c * ↑c * z ≠ 0 :=
    by
    rw [mul_assoc, ← mul_add, add_comm]
    exact mul_ne_zero hc h_denom
  replace h : (a * d - b * c : ℂ) = (1 : ℂ)
  · norm_cast
    assumption
  field_simp
  linear_combination (-(z * ↑c ^ 2) - ↑c * ↑d) * h
#align upper_half_plane.exists_SL2_smul_eq_of_apply_zero_one_ne_zero UpperHalfPlane.exists_SL2_smul_eq_of_apply_zero_one_ne_zero

end UpperHalfPlane


import local.ample_set
import local.dual_pair
import local.relation

/-! # Slices of first order relations

Recal that a first order partial differential relation for maps between real normed vector spaces
`E` and `F` is a set `R` in `one_jet E F := E × F × (E →L[ℝ] F)`. In this file we study slices
of such relations. The word slice is meant to convey the idea of intersecting with an affine
subspace. Here we fix `(x, y, φ) : one_jet E F` and some hyperplane `H` in `E`. The points
`x` and `y` are fixed and we will take a slice in `E →L[ℝ] F` by intersecting `R` with the affine
subspace of linear maps that coincide with `φ` on `H`.

It will be convenient for convex integration purposes to identify this slice with `F`. There is
no natural identification but we can build one by fixing more data that a hyperplane in `E`.
Namely we fix `p : dual_pair E` (where `ker p.π` is the relevant hyperplane) and reformulate
"linear map that coincides with `φ` on `H`" as `p.update φ w` for some `w : F`.

This `slice` definition allows to define `rel_loc.is_ample`, the ampleness condition for first
order relations: a relation is ample if all its slices are ample sets.

At the end of the file we consider 1-jet sections and slices corresponding to points in their image.
-/

variables {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
variables {F : Type*} [normed_add_comm_group F] [normed_space ℝ F]
variables {X : Type*} [normed_add_comm_group X] [inner_product_space ℝ X]
variables {R : rel_loc E F}
open set

/-! ## Slices and ampleness -/
namespace rel_loc

/-- The slice of a local relation `R : rel_loc E F` for a dual pair `p` at a jet `θ` is
the set of `w` in `F` such that updating `θ` using `p` and `w` leads to a jet in `R`. -/
def slice (R : rel_loc E F) (p : dual_pair E) (θ : E × F × (E →L[ℝ] F)) : set F :=
{w | (θ.1, θ.2.1, p.update θ.2.2 w) ∈ R}

lemma mem_slice (R : rel_loc E F) {p : dual_pair E} {θ : E × F × (E →L[ℝ] F)} {w : F} :
  w ∈ R.slice p θ ↔ (θ.1, θ.2.1, p.update θ.2.2 w) ∈ R :=
iff.rfl

/-- A relation is ample if all its slices are ample. -/
def is_ample (R : rel_loc E F) : Prop := ∀ (p : dual_pair E) (θ : E × F × (E →L[ℝ] F)),
ample_set (R.slice p θ)

lemma is_ample.mem_hull (h : is_ample R) {θ : E × F × (E →L[ℝ] F)}
  (hθ : θ ∈ R) (v : F) (p) : v ∈ hull (connected_component_in (R.slice p θ) (θ.2.2 p.v)) :=
begin
  rw h p θ (θ.2.2 p.v),
  exact mem_univ _,
  rw [mem_slice, p.update_self, prod.mk.eta, prod.mk.eta],
  exact hθ
end

lemma slice_update {θ : E × F × (E →L[ℝ] F)}
  {p : dual_pair E} (x : F) :
  R.slice p (θ.1, θ.2.1, (p.update θ.2.2 x)) = R.slice p θ :=
begin
  ext1 w,
  dsimp [slice],
  rw [p.update_update]
end

/-- In order to check ampleness, it suffices to consider slices through elements of the relation. -/
lemma is_ample_iff : R.is_ample ↔
  ∀ ⦃θ : one_jet E F⦄ (p : dual_pair E), θ ∈ R → ample_set (R.slice p θ) :=
begin
  simp_rw [is_ample],
  refine ⟨λ h θ p hθ, h p θ, λ h p θ w hw, _⟩,
  dsimp [slice] at hw,
  have := h p hw,
  rw [slice_update] at this,
  exact this w hw
end

open_locale pointwise

lemma slice_of_ker_eq_ker {θ : one_jet E F}
  {p p' : dual_pair E} (hpp' : p.π = p'.π) :
  R.slice p θ = θ.2.2 (p.v - p'.v) +ᵥ R.slice p' θ :=
begin
  rcases θ with ⟨x, y, φ⟩,
  have key : ∀ w, p'.update φ w = p.update φ (w + φ (p.v - p'.v)),
  { intros w,
    simp only [dual_pair.update, hpp', map_sub, add_right_inj],
    congr' 2,
    abel },
  ext w,
  simp only [slice, mem_set_of_eq, map_sub, vadd_eq_add, mem_vadd_set_iff_neg_vadd_mem, key],
  have : -(φ p.v - φ p'.v) + w + (φ p.v - φ p'.v) = w,
  abel,
  rw this,
end

lemma ample_slice_of_ample_slice {θ : one_jet E F}
  {p p' : dual_pair E} (hpp' : p.π = p'.π) (h : ample_set (R.slice p θ)) :
  ample_set (R.slice p' θ) :=
begin
  rw slice_of_ker_eq_ker hpp'.symm,
  exact ample_set.vadd h
end

lemma ample_slice_of_forall (R : rel_loc E F) {x y φ} (p : dual_pair E)
  (h : ∀ w, (x, y, p.update φ w) ∈ R) : ample_set (R.slice p (x, y, φ)) :=
begin
  rw show R.slice p (x, y, φ) = univ, from eq_univ_of_forall h,
  exact ample_set_univ
end

end rel_loc

open rel_loc

/-! ## Slices for 1-jet sections and formal solutions. -/

namespace jet_sec

/-- The slice associated to a jet section and a dual pair at some point. -/
def slice_at (𝓕 : jet_sec E F) (R : rel_loc E F) (p : dual_pair E) (x : E) : set F :=
R.slice p (x, 𝓕.f x, 𝓕.φ x)

/-- A 1-jet section `𝓕` is short for a dual pair `p` at a point `x` if the derivative of
the function `𝓕.f` at `x` is in the convex hull of the relevant connected component of the
corresponding slice. -/
def is_short_at (𝓕 : jet_sec E F) (R : rel_loc E F) (p : dual_pair E) (x : E) : Prop :=
D 𝓕.f x p.v ∈ hull (connected_component_in (𝓕.slice_at R p x) $ 𝓕.φ x p.v)

end jet_sec

namespace rel_loc.formal_sol

/-- The slice associated to a formal solution and a dual pair at some point. -/
def slice_at (𝓕 : formal_sol R) (p : dual_pair E) (x : E) : set F :=
R.slice p (x, 𝓕.f x, 𝓕.φ x)

/-- A formal solution `𝓕` is short for a dual pair `p` at a point `x` if the derivative of
the function `𝓕.f` at `x` is in the convex hull of the relevant connected component of the
corresponding slice. -/
def is_short_at (𝓕 : formal_sol R) (p : dual_pair E) (x : E) : Prop :=
D 𝓕.f x p.v ∈ hull (connected_component_in (𝓕.slice_at p x) $ 𝓕.φ x p.v)

end rel_loc.formal_sol

lemma rel_loc.is_ample.is_short_at (hR : is_ample R) (𝓕 : formal_sol R) (p : dual_pair E)
  (x : E) : 𝓕.is_short_at p x :=
hR.mem_hull (𝓕.is_sol x) _ p


/-
Copyright (c) 2018 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import order.conditionally_complete_lattice.basic
import algebra.order.group.type_tags

/-!
# Conditionally complete lattices and groups.

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

-/

section group

variables {α : Type*} {ι : Sort*} {ι' : Sort*}
  [nonempty ι] [nonempty ι'] [conditionally_complete_lattice α] [group α]

@[to_additive]
lemma le_mul_cinfi [covariant_class α α (*) (≤)] {a : α} {g : α} {h : ι → α}
  (H : ∀ j, a ≤ g * h j) : a ≤ g * infi h :=
inv_mul_le_iff_le_mul.mp $ le_cinfi $ λ hi, inv_mul_le_iff_le_mul.mpr $ H _

@[to_additive]
lemma mul_csupr_le [covariant_class α α (*) (≤)] {a : α} {g : α} {h : ι → α}
  (H : ∀ j, g * h j ≤ a) : g * supr h ≤ a :=
@le_mul_cinfi αᵒᵈ _ _ _ _ _ _ _ _ H

@[to_additive]
lemma le_cinfi_mul [covariant_class α α (function.swap (*)) (≤)] {a : α} {g : ι → α} {h : α}
  (H : ∀ i, a ≤ g i * h) : a ≤ infi g * h :=
mul_inv_le_iff_le_mul.mp $ le_cinfi $ λ gi, mul_inv_le_iff_le_mul.mpr $ H _

@[to_additive]
lemma csupr_mul_le [covariant_class α α (function.swap (*)) (≤)] {a : α} {g : ι → α} {h : α}
  (H : ∀ i, g i * h ≤ a) : supr g * h ≤ a :=
@le_cinfi_mul αᵒᵈ _ _ _ _ _ _ _ _ H

@[to_additive]
lemma le_cinfi_mul_cinfi [covariant_class α α (*) (≤)] [covariant_class α α (function.swap (*)) (≤)]
  {a : α} {g : ι → α} {h : ι' → α} (H : ∀ i j, a ≤ g i * h j) : a ≤ infi g * infi h :=
le_cinfi_mul $ λ i, le_mul_cinfi $ H _

@[to_additive]
lemma csupr_mul_csupr_le [covariant_class α α (*) (≤)] [covariant_class α α (function.swap (*)) (≤)]
  {a : α} {g : ι → α} {h : ι' → α} (H : ∀ i j, g i * h j ≤ a) : supr g * supr h ≤ a :=
csupr_mul_le $ λ i, mul_csupr_le $ H _

end group


import tactic --hide

-- Level name : Associative laws pt 1

/-
This level proves that `∧` is *associative*.
-/

/-Lemma
If $P,Q,R$ are logical statements, then $P ∧ (Q ∧ R)$ is true iff $(P ∧ Q) ∧ R$ is true.
-/
lemma associativity_one (P Q R : Prop) : P ∧ (Q ∧ R) ↔ (P ∧ Q) ∧ R :=
begin
  split,
  intro h,
  split,
  cases h with hl hr,
  split,
  exact hl,
  cases hr,
  exact hr_left,
  cases h with h1 h2,
  cases h2 with h2 h3,
  exact h3,
  intro h,
  split,
  cases h,
  exact h_left.1,
  split,
  exact h.1.2,
  exact h.2,
end


import mynat.definition -- Imports the natural numbers.
import mynat.add -- imports addition.
import world02.level01 -- hide
import world02.level03 -- hide

namespace mynat -- hide

theorem succ_eq_add_one (n : mynat) : succ n = n + 1 :=
begin [nat_num_game]
  induction n with d hd,
  rw one_eq_succ_zero,
  rw add_succ,
  rw add_zero,
  refl,
  rw one_eq_succ_zero,
  rw add_succ,
  rw hd,
  rw one_eq_succ_zero,
  rw add_zero,
  refl,
end

end mynat -- hide


import .reverse

set_option trace.simplify.rewrite true

#print reverse_right

open list(nil)

-- axiom append.base (x : α) : append nil x = [x]
-- axiom append.step (x y : α) (xs : list α) :
--   append (x :: xs) y = x :: append xs y

-- axiom reverse.base : reverse nil = nil
-- axiom reverse.step (x : α) (xs : list α) :
--   reverse (x :: xs) = append (reverse xs) x

axiom reverse2.base : reverse2 nil = nil -- nil ~ []
axiom reverse2.step (x y : α) (xs : list α) :
  reverse2 (append (x :: xs) y) = append (y :: reverse2 xs) x

attribute [simp] reverse2.base reverse2.step

-- how to prove that reverse2.single is not provable if we have only two axioms:
-- reverse2.base, reverse.step + append axioms
@[simp]
lemma reverse2.single (x : α) : reverse2 [x] = [x] :=
begin
  type_check append.base x,
  type_check append.step x x [],
  conv {
    to_lhs,
    rw ←append.base,
  },
  sorry,
end

lemma reverse2_right (x : α) (xs : list α) :
  reverse2 (append xs x) = x :: reverse2 xs :=
begin
  induction xs with y ys ih,
  { simp },
  -- rw append.step,
  rw reverse2.step,
  rw ←ih,
  sorry,
end

theorem reverse_and_reverse2_are_equivalent (xs : list α) :
  reverse xs = reverse2 xs :=
begin
  induction xs with y ys ih,
  {
    simp,
  },
  {
    simp [ih],
    induction ys with z zs ih2,
    { simp },
    sorry,
  },
end


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon
-/

import data.pfunctor.multivariate.basic
import data.qpf.multivariate.basic

/-!
# The composition of QPFs is itself a QPF

We define composition between one `n`-ary functor and `n` `m`-ary functors
and show that it preserves the QPF structure
-/

universes u

namespace mvqpf
open_locale mvfunctor

variables {n m : ℕ}
  (F : typevec.{u} n → Type*) [fF : mvfunctor F] [q : mvqpf F]
  (G : fin2 n → typevec.{u} m → Type u) [fG : ∀ i, mvfunctor $ G i] [q' : ∀ i, mvqpf $ G i]

/-- Composition of an `n`-ary functor with `n` `m`-ary
functors gives us one `m`-ary functor -/
def comp (v : typevec.{u} m) : Type* :=
F $ λ i : fin2 n, G i v

namespace comp
open mvfunctor mvpfunctor
variables {F G} {α β : typevec.{u} m} (f : α ⟹ β)

instance [I : inhabited (F $ λ i : fin2 n, G i α)] : inhabited (comp F G α) := I

/-- Constructor for functor composition -/
protected def mk (x : F $ λ i, G i α) : (comp F G) α := x

/-- Destructor for functor composition -/
protected def get (x : (comp F G) α) : F $ λ i, G i α := x

@[simp] protected lemma mk_get (x : (comp F G) α) : comp.mk (comp.get x) = x := rfl

@[simp] protected lemma get_mk (x : F $ λ i, G i α) : comp.get (comp.mk x) = x := rfl

include fG

/-- map operation defined on a vector of functors -/
protected def map' : (λ (i : fin2 n), G i α) ⟹ λ (i : fin2 n), G i β :=
λ i, map f

include fF

/-- The composition of functors is itself functorial -/
protected def map : (comp F G) α → (comp F G) β :=
(map (λ i, map f) : F (λ i, G i α) → F (λ i, G i β))

instance : mvfunctor (comp F G) :=
{ map := λ α β, comp.map }

lemma map_mk (x : F $ λ i, G i α) :
  f <$$> comp.mk x = comp.mk ((λ i (x : G i α), f <$$> x) <$$> x) := rfl

lemma get_map (x : comp F G α) :
  comp.get (f <$$> x) = (λ i (x : G i α), f <$$> x) <$$> comp.get x := rfl

include q q'

instance : mvqpf (comp F G) :=
{ P         := mvpfunctor.comp (P F) (λ i, P $ G i),
  abs       := λ α, comp.mk ∘ map (λ i, abs) ∘ abs ∘ mvpfunctor.comp.get,
  repr      := λ α,  mvpfunctor.comp.mk ∘ repr ∘
                 map (λ i, (repr : G i α → (λ (i : fin2 n), obj (P (G i)) α) i)) ∘ comp.get,
  abs_repr  := by { intros, simp [(∘), mvfunctor.map_map, (⊚), abs_repr] },
  abs_map   := by { intros, simp [(∘)], rw [← abs_map],
                    simp [mvfunctor.id_map, (⊚), map_mk, mvpfunctor.comp.get_map, abs_map,
                      mvfunctor.map_map, abs_repr] } }

end comp

end mvqpf


/-
Copyright (c) 2020 Ashvni Narayanan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors : Ashvni Narayanan
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.deprecated.subring
import Mathlib.group_theory.subgroup
import Mathlib.ring_theory.subsemiring
import Mathlib.PostPort

universes u l u_1 u_2 v w

namespace Mathlib

/-!
# Subrings

Let `R` be a ring. This file defines the "bundled" subring type `subring R`, a type
whose terms correspond to subrings of `R`. This is the preferred way to talk
about subrings in mathlib. Unbundled subrings (`s : set R` and `is_subring s`)
are not in this file, and they will ultimately be deprecated.

We prove that subrings are a complete lattice, and that you can `map` (pushforward) and
`comap` (pull back) them along ring homomorphisms.

We define the `closure` construction from `set R` to `subring R`, sending a subset of `R`
to the subring it generates, and prove that it is a Galois insertion.

## Main definitions

Notation used here:

`(R : Type u) [ring R] (S : Type u) [ring S] (f g : R →+* S)`
`(A : subring R) (B : subring S) (s : set R)`

* `subring R` : the type of subrings of a ring `R`.

* `instance : complete_lattice (subring R)` : the complete lattice structure on the subrings.

* `subring.closure` : subring closure of a set, i.e., the smallest subring that includes the set.

* `subring.gi` : `closure : set M → subring M` and coercion `coe : subring M → set M`
  form a `galois_insertion`.

* `comap f B : subring A` : the preimage of a subring `B` along the ring homomorphism `f`

* `map f A : subring B` : the image of a subring `A` along the ring homomorphism `f`.

* `prod A B : subring (R × S)` : the product of subrings

* `f.range : subring B` : the range of the ring homomorphism `f`.

* `eq_locus f g : subring R` : given ring homomorphisms `f g : R →+* S`,
     the subring of `R` where `f x = g x`

## Implementation notes

A subring is implemented as a subsemiring which is also an additive subgroup.
The initial PR was as a submonoid which is also an additive subgroup.

Lattice inclusion (e.g. `≤` and `⊓`) is used rather than set notation (`⊆` and `∩`), although
`∈` is defined as membership of a subring's underlying set.

## Tags
subring, subrings
-/

/-- `subring R` is the type of subrings of `R`. A subring of `R` is a subset `s` that is a
  multiplicative submonoid and an additive subgroup. Note in particular that it shares the
  same 0 and 1 as R. -/
structure subring (R : Type u) [ring R] extends subsemiring R, add_subgroup R where

/-- Reinterpret a `subring` as a `subsemiring`. -/
/-- Reinterpret a `subring` as an `add_subgroup`. -/
namespace subring

/-- The underlying submonoid of a subring. -/
def to_submonoid {R : Type u} [ring R] (s : subring R) : submonoid R :=
  submonoid.mk (carrier s) sorry sorry

protected instance set.has_coe {R : Type u} [ring R] : has_coe (subring R) (set R) :=
  has_coe.mk carrier

protected instance has_mem {R : Type u} [ring R] : has_mem R (subring R) :=
  has_mem.mk fun (m : R) (S : subring R) => m ∈ ↑S

protected instance has_coe_to_sort {R : Type u} [ring R] : has_coe_to_sort (subring R) :=
  has_coe_to_sort.mk (Type u) fun (S : subring R) => Subtype fun (x : R) => x ∈ S

/-- Construct a `subring R` from a set `s`, a submonoid `sm`, and an additive
subgroup `sa` such that `x ∈ s ↔ x ∈ sm ↔ x ∈ sa`. -/
protected def mk' {R : Type u} [ring R] (s : set R) (sm : submonoid R) (sa : add_subgroup R)
    (hm : ↑sm = s) (ha : ↑sa = s) : subring R :=
  mk s sorry sorry sorry sorry sorry

@[simp] theorem coe_mk' {R : Type u} [ring R] {s : set R} {sm : submonoid R} (hm : ↑sm = s)
    {sa : add_subgroup R} (ha : ↑sa = s) : ↑(subring.mk' s sm sa hm ha) = s :=
  rfl

@[simp] theorem mem_mk' {R : Type u} [ring R] {s : set R} {sm : submonoid R} (hm : ↑sm = s)
    {sa : add_subgroup R} (ha : ↑sa = s) {x : R} : x ∈ subring.mk' s sm sa hm ha ↔ x ∈ s :=
  iff.rfl

@[simp] theorem mk'_to_submonoid {R : Type u} [ring R] {s : set R} {sm : submonoid R} (hm : ↑sm = s)
    {sa : add_subgroup R} (ha : ↑sa = s) : to_submonoid (subring.mk' s sm sa hm ha) = sm :=
  submonoid.ext' (Eq.symm hm)

@[simp] theorem mk'_to_add_subgroup {R : Type u} [ring R] {s : set R} {sm : submonoid R}
    (hm : ↑sm = s) {sa : add_subgroup R} (ha : ↑sa = s) :
    to_add_subgroup (subring.mk' s sm sa hm ha) = sa :=
  add_subgroup.ext' (Eq.symm ha)

end subring

/-- Construct a `subring` from a set satisfying `is_subring`. -/
def set.to_subring {R : Type u} [ring R] (S : set R) [is_subring S] : subring R :=
  subring.mk S sorry sorry sorry sorry sorry

protected theorem subring.exists {R : Type u} [ring R] {s : subring R} {p : ↥s → Prop} :
    (∃ (x : ↥s), p x) ↔ ∃ (x : R), ∃ (H : x ∈ s), p { val := x, property := H } :=
  set_coe.exists

protected theorem subring.forall {R : Type u} [ring R] {s : subring R} {p : ↥s → Prop} :
    (∀ (x : ↥s), p x) ↔ ∀ (x : R) (H : x ∈ s), p { val := x, property := H } :=
  set_coe.forall

/-- A `subsemiring` containing -1 is a `subring`. -/
def subsemiring.to_subring {R : Type u} [ring R] (s : subsemiring R) (hneg : -1 ∈ s) : subring R :=
  subring.mk (submonoid.carrier (subsemiring.to_submonoid s)) sorry sorry sorry sorry sorry

namespace subring

/-- Two subrings are equal if the underlying subsets are equal. -/
theorem ext' {R : Type u} [ring R] {s : subring R} {t : subring R} (h : ↑s = ↑t) : s = t := sorry

/-- Two subrings are equal if and only if the underlying subsets are equal. -/
protected theorem ext'_iff {R : Type u} [ring R] {s : subring R} {t : subring R} :
    s = t ↔ ↑s = ↑t :=
  { mp := fun (h : s = t) => h ▸ rfl, mpr := fun (h : ↑s = ↑t) => ext' h }

/-- Two subrings are equal if they have the same elements. -/
theorem ext {R : Type u} [ring R] {S : subring R} {T : subring R} (h : ∀ (x : R), x ∈ S ↔ x ∈ T) :
    S = T :=
  ext' (set.ext h)

/-- A subring contains the ring's 1. -/
theorem one_mem {R : Type u} [ring R] (s : subring R) : 1 ∈ s := one_mem' s

/-- A subring contains the ring's 0. -/
theorem zero_mem {R : Type u} [ring R] (s : subring R) : 0 ∈ s := zero_mem' s

/-- A subring is closed under multiplication. -/
theorem mul_mem {R : Type u} [ring R] (s : subring R) {x : R} {y : R} : x ∈ s → y ∈ s → x * y ∈ s :=
  mul_mem' s

/-- A subring is closed under addition. -/
theorem add_mem {R : Type u} [ring R] (s : subring R) {x : R} {y : R} : x ∈ s → y ∈ s → x + y ∈ s :=
  add_mem' s

/-- A subring is closed under negation. -/
theorem neg_mem {R : Type u} [ring R] (s : subring R) {x : R} : x ∈ s → -x ∈ s := neg_mem' s

/-- A subring is closed under subtraction -/
theorem sub_mem {R : Type u} [ring R] (s : subring R) {x : R} {y : R} (hx : x ∈ s) (hy : y ∈ s) :
    x - y ∈ s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (x - y ∈ s)) (sub_eq_add_neg x y))) (add_mem s hx (neg_mem s hy))

/-- Product of a list of elements in a subring is in the subring. -/
theorem list_prod_mem {R : Type u} [ring R] (s : subring R) {l : List R} :
    (∀ (x : R), x ∈ l → x ∈ s) → list.prod l ∈ s :=
  submonoid.list_prod_mem (to_submonoid s)

/-- Sum of a list of elements in a subring is in the subring. -/
theorem list_sum_mem {R : Type u} [ring R] (s : subring R) {l : List R} :
    (∀ (x : R), x ∈ l → x ∈ s) → list.sum l ∈ s :=
  add_subgroup.list_sum_mem (to_add_subgroup s)

/-- Product of a multiset of elements in a subring of a `comm_ring` is in the subring. -/
theorem multiset_prod_mem {R : Type u_1} [comm_ring R] (s : subring R) (m : multiset R) :
    (∀ (a : R), a ∈ m → a ∈ s) → multiset.prod m ∈ s :=
  submonoid.multiset_prod_mem (to_submonoid s) m

/-- Sum of a multiset of elements in an `subring` of a `ring` is
in the `subring`. -/
theorem multiset_sum_mem {R : Type u_1} [ring R] (s : subring R) (m : multiset R) :
    (∀ (a : R), a ∈ m → a ∈ s) → multiset.sum m ∈ s :=
  add_subgroup.multiset_sum_mem (to_add_subgroup s) m

/-- Product of elements of a subring of a `comm_ring` indexed by a `finset` is in the
    subring. -/
theorem prod_mem {R : Type u_1} [comm_ring R] (s : subring R) {ι : Type u_2} {t : finset ι}
    {f : ι → R} (h : ∀ (c : ι), c ∈ t → f c ∈ s) : (finset.prod t fun (i : ι) => f i) ∈ s :=
  submonoid.prod_mem (to_submonoid s) h

/-- Sum of elements in a `subring` of a `ring` indexed by a `finset`
is in the `subring`. -/
theorem sum_mem {R : Type u_1} [ring R] (s : subring R) {ι : Type u_2} {t : finset ι} {f : ι → R}
    (h : ∀ (c : ι), c ∈ t → f c ∈ s) : (finset.sum t fun (i : ι) => f i) ∈ s :=
  add_subgroup.sum_mem (to_add_subgroup s) h

theorem pow_mem {R : Type u} [ring R] (s : subring R) {x : R} (hx : x ∈ s) (n : ℕ) : x ^ n ∈ s :=
  submonoid.pow_mem (to_submonoid s) hx n

theorem gsmul_mem {R : Type u} [ring R] (s : subring R) {x : R} (hx : x ∈ s) (n : ℤ) : n •ℤ x ∈ s :=
  add_subgroup.gsmul_mem (to_add_subgroup s) hx n

theorem coe_int_mem {R : Type u} [ring R] (s : subring R) (n : ℤ) : ↑n ∈ s := sorry

/-- A subring of a ring inherits a ring structure -/
protected instance to_ring {R : Type u} [ring R] (s : subring R) : ring ↥s :=
  ring.mk add_comm_group.add sorry add_comm_group.zero sorry sorry add_comm_group.neg
    add_comm_group.sub sorry sorry monoid.mul sorry monoid.one sorry sorry sorry sorry

@[simp] theorem coe_add {R : Type u} [ring R] (s : subring R) (x : ↥s) (y : ↥s) :
    ↑(x + y) = ↑x + ↑y :=
  rfl

@[simp] theorem coe_neg {R : Type u} [ring R] (s : subring R) (x : ↥s) : ↑(-x) = -↑x := rfl

@[simp] theorem coe_mul {R : Type u} [ring R] (s : subring R) (x : ↥s) (y : ↥s) :
    ↑(x * y) = ↑x * ↑y :=
  rfl

@[simp] theorem coe_zero {R : Type u} [ring R] (s : subring R) : ↑0 = 0 := rfl

@[simp] theorem coe_one {R : Type u} [ring R] (s : subring R) : ↑1 = 1 := rfl

@[simp] theorem coe_eq_zero_iff {R : Type u} [ring R] (s : subring R) {x : ↥s} : ↑x = 0 ↔ x = 0 :=
  { mp := fun (h : ↑x = 0) => subtype.ext (trans h (Eq.symm (coe_zero s))),
    mpr := fun (h : x = 0) => Eq.symm h ▸ coe_zero s }

/-- A subring of a `comm_ring` is a `comm_ring`. -/
protected instance to_comm_ring {R : Type u_1} [comm_ring R] (s : subring R) : comm_ring ↥s :=
  comm_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry
    ring.one sorry sorry sorry sorry sorry

/-- The natural ring hom from a subring of ring `R` to `R`. -/
def subtype {R : Type u} [ring R] (s : subring R) : ↥s →+* R :=
  ring_hom.mk coe sorry sorry sorry sorry

@[simp] theorem coe_subtype {R : Type u} [ring R] (s : subring R) : ⇑(subtype s) = coe := rfl

/-! # Partial order -/

protected instance partial_order {R : Type u} [ring R] : partial_order (subring R) :=
  partial_order.mk (fun (s t : subring R) => ∀ {x : R}, x ∈ s → x ∈ t) partial_order.lt sorry sorry
    sorry

theorem le_def {R : Type u} [ring R] {s : subring R} {t : subring R} :
    s ≤ t ↔ ∀ {x : R}, x ∈ s → x ∈ t :=
  iff.rfl

@[simp] theorem coe_subset_coe {R : Type u} [ring R] {s : subring R} {t : subring R} :
    ↑s ⊆ ↑t ↔ s ≤ t :=
  iff.rfl

@[simp] theorem coe_ssubset_coe {R : Type u} [ring R] {s : subring R} {t : subring R} :
    ↑s ⊂ ↑t ↔ s < t :=
  iff.rfl

@[simp] theorem mem_coe {R : Type u} [ring R] {S : subring R} {m : R} : m ∈ ↑S ↔ m ∈ S := iff.rfl

@[simp] theorem coe_coe {R : Type u} [ring R] (s : subring R) : ↥↑s = ↥s := rfl

@[simp] theorem mem_to_submonoid {R : Type u} [ring R] {s : subring R} {x : R} :
    x ∈ to_submonoid s ↔ x ∈ s :=
  iff.rfl

@[simp] theorem coe_to_submonoid {R : Type u} [ring R] (s : subring R) : ↑(to_submonoid s) = ↑s :=
  rfl

@[simp] theorem mem_to_add_subgroup {R : Type u} [ring R] {s : subring R} {x : R} :
    x ∈ to_add_subgroup s ↔ x ∈ s :=
  iff.rfl

@[simp] theorem coe_to_add_subgroup {R : Type u} [ring R] (s : subring R) :
    ↑(to_add_subgroup s) = ↑s :=
  rfl

/-! # top -/

/-- The subring `R` of the ring `R`. -/
protected instance has_top {R : Type u} [ring R] : has_top (subring R) :=
  has_top.mk (mk (submonoid.carrier ⊤) sorry sorry sorry sorry sorry)

@[simp] theorem mem_top {R : Type u} [ring R] (x : R) : x ∈ ⊤ := set.mem_univ x

@[simp] theorem coe_top {R : Type u} [ring R] : ↑⊤ = set.univ := rfl

/-! # comap -/

/-- The preimage of a subring along a ring homomorphism is a subring. -/
def comap {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) (s : subring S) : subring R :=
  mk (⇑f ⁻¹' carrier s) sorry sorry sorry sorry sorry

@[simp] theorem coe_comap {R : Type u} {S : Type v} [ring R] [ring S] (s : subring S)
    (f : R →+* S) : ↑(comap f s) = ⇑f ⁻¹' ↑s :=
  rfl

@[simp] theorem mem_comap {R : Type u} {S : Type v} [ring R] [ring S] {s : subring S} {f : R →+* S}
    {x : R} : x ∈ comap f s ↔ coe_fn f x ∈ s :=
  iff.rfl

theorem comap_comap {R : Type u} {S : Type v} {T : Type w} [ring R] [ring S] [ring T]
    (s : subring T) (g : S →+* T) (f : R →+* S) :
    comap f (comap g s) = comap (ring_hom.comp g f) s :=
  rfl

/-! # map -/

/-- The image of a subring along a ring homomorphism is a subring. -/
def map {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) (s : subring R) : subring S :=
  mk (⇑f '' carrier s) sorry sorry sorry sorry sorry

@[simp] theorem coe_map {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) (s : subring R) :
    ↑(map f s) = ⇑f '' ↑s :=
  rfl

@[simp] theorem mem_map {R : Type u} {S : Type v} [ring R] [ring S] {f : R →+* S} {s : subring R}
    {y : S} : y ∈ map f s ↔ ∃ (x : R), ∃ (H : x ∈ s), coe_fn f x = y :=
  set.mem_image_iff_bex

theorem map_map {R : Type u} {S : Type v} {T : Type w} [ring R] [ring S] [ring T] (s : subring R)
    (g : S →+* T) (f : R →+* S) : map g (map f s) = map (ring_hom.comp g f) s :=
  ext' (set.image_image (fun (a : S) => coe_fn g a) (fun (a : R) => coe_fn f a) (carrier s))

theorem map_le_iff_le_comap {R : Type u} {S : Type v} [ring R] [ring S] {f : R →+* S}
    {s : subring R} {t : subring S} : map f s ≤ t ↔ s ≤ comap f t :=
  set.image_subset_iff

theorem gc_map_comap {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) :
    galois_connection (map f) (comap f) :=
  fun (S_1 : subring R) (T : subring S) => map_le_iff_le_comap

end subring

namespace ring_hom

/-! # range -/

/-- The range of a ring homomorphism, as a subring of the target. -/
def range {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) : subring S := subring.map f ⊤

@[simp] theorem coe_range {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) :
    ↑(range f) = set.range ⇑f :=
  set.image_univ

@[simp] theorem mem_range {R : Type u} {S : Type v} [ring R] [ring S] {f : R →+* S} {y : S} :
    y ∈ range f ↔ ∃ (x : R), coe_fn f x = y :=
  sorry

theorem mem_range_self {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) (x : R) :
    coe_fn f x ∈ range f :=
  iff.mpr mem_range (Exists.intro x rfl)

theorem map_range {R : Type u} {S : Type v} {T : Type w} [ring R] [ring S] [ring T] (g : S →+* T)
    (f : R →+* S) : subring.map g (range f) = range (comp g f) :=
  subring.map_map ⊤ g f

-- TODO -- rename to `cod_restrict` when is_ring_hom is deprecated

/-- Restrict the codomain of a ring homomorphism to a subring that includes the range. -/
def cod_restrict' {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) (s : subring S)
    (h : ∀ (x : R), coe_fn f x ∈ s) : R →+* ↥s :=
  mk (fun (x : R) => { val := coe_fn f x, property := h x }) sorry sorry sorry sorry

theorem surjective_onto_range {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) :
    function.surjective ⇑(cod_restrict' f (range f) (mem_range_self f)) :=
  sorry

end ring_hom

namespace subring

/-- A subring of a commutative ring is a commutative ring. -/
def subset_comm_ring {cR : Type u} [comm_ring cR] (S : subring cR) : comm_ring ↥S :=
  comm_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry
    ring.one sorry sorry sorry sorry sorry

/-- A subring of a non-trivial ring is non-trivial. -/
protected instance nontrivial {D : Type u_1} [ring D] [nontrivial D] (S : subring D) :
    nontrivial ↥S :=
  subsemiring.nontrivial (to_subsemiring S)

/-- A subring of a ring with no zero divisors has no zero divisors. -/
protected instance no_zero_divisors {D : Type u_1} [ring D] [no_zero_divisors D] (S : subring D) :
    no_zero_divisors ↥S :=
  subsemiring.no_zero_divisors (to_subsemiring S)

/-- A subring of an integral domain is an integral domain. -/
protected instance subring.domain {D : Type u_1} [integral_domain D] (S : subring D) :
    integral_domain ↥S :=
  integral_domain.mk comm_ring.add sorry comm_ring.zero sorry sorry comm_ring.neg comm_ring.sub
    sorry sorry comm_ring.mul sorry comm_ring.one sorry sorry sorry sorry sorry sorry sorry

/-! # bot -/

protected instance has_bot {R : Type u} [ring R] : has_bot (subring R) :=
  has_bot.mk (ring_hom.range (int.cast_ring_hom R))

protected instance inhabited {R : Type u} [ring R] : Inhabited (subring R) := { default := ⊥ }

theorem coe_bot {R : Type u} [ring R] : ↑⊥ = set.range coe :=
  ring_hom.coe_range (int.cast_ring_hom R)

theorem mem_bot {R : Type u} [ring R] {x : R} : x ∈ ⊥ ↔ ∃ (n : ℤ), ↑n = x := ring_hom.mem_range

/-! # inf -/

/-- The inf of two subrings is their intersection. -/
protected instance has_inf {R : Type u} [ring R] : has_inf (subring R) :=
  has_inf.mk fun (s t : subring R) => mk (↑s ∩ ↑t) sorry sorry sorry sorry sorry

@[simp] theorem coe_inf {R : Type u} [ring R] (p : subring R) (p' : subring R) :
    ↑(p ⊓ p') = ↑p ∩ ↑p' :=
  rfl

@[simp] theorem mem_inf {R : Type u} [ring R] {p : subring R} {p' : subring R} {x : R} :
    x ∈ p ⊓ p' ↔ x ∈ p ∧ x ∈ p' :=
  iff.rfl

protected instance has_Inf {R : Type u} [ring R] : has_Inf (subring R) :=
  has_Inf.mk
    fun (s : set (subring R)) =>
      subring.mk' (set.Inter fun (t : subring R) => set.Inter fun (H : t ∈ s) => ↑t)
        (infi fun (t : subring R) => infi fun (H : t ∈ s) => to_submonoid t)
        (infi fun (t : subring R) => infi fun (H : t ∈ s) => to_add_subgroup t) sorry sorry

@[simp] theorem coe_Inf {R : Type u} [ring R] (S : set (subring R)) :
    ↑(Inf S) = set.Inter fun (s : subring R) => set.Inter fun (H : s ∈ S) => ↑s :=
  rfl

theorem mem_Inf {R : Type u} [ring R] {S : set (subring R)} {x : R} :
    x ∈ Inf S ↔ ∀ (p : subring R), p ∈ S → x ∈ p :=
  set.mem_bInter_iff

@[simp] theorem Inf_to_submonoid {R : Type u} [ring R] (s : set (subring R)) :
    to_submonoid (Inf s) = infi fun (t : subring R) => infi fun (H : t ∈ s) => to_submonoid t :=
  mk'_to_submonoid (has_Inf._proof_1 s) (has_Inf._proof_2 s)

@[simp] theorem Inf_to_add_subgroup {R : Type u} [ring R] (s : set (subring R)) :
    to_add_subgroup (Inf s) =
        infi fun (t : subring R) => infi fun (H : t ∈ s) => to_add_subgroup t :=
  mk'_to_add_subgroup (has_Inf._proof_1 s) (has_Inf._proof_2 s)

/-- Subrings of a ring form a complete lattice. -/
protected instance complete_lattice {R : Type u} [ring R] : complete_lattice (subring R) :=
  complete_lattice.mk complete_lattice.sup complete_lattice.le complete_lattice.lt sorry sorry sorry
    sorry sorry sorry has_inf.inf sorry sorry sorry ⊤ sorry ⊥ sorry complete_lattice.Sup
    complete_lattice.Inf sorry sorry sorry sorry

/-! # subring closure of a subset -/

/-- The `subring` generated by a set. -/
def closure {R : Type u} [ring R] (s : set R) : subring R :=
  Inf (set_of fun (S : subring R) => s ⊆ ↑S)

theorem mem_closure {R : Type u} [ring R] {x : R} {s : set R} :
    x ∈ closure s ↔ ∀ (S : subring R), s ⊆ ↑S → x ∈ S :=
  mem_Inf

/-- The subring generated by a set includes the set. -/
@[simp] theorem subset_closure {R : Type u} [ring R] {s : set R} : s ⊆ ↑(closure s) :=
  fun (x : R) (hx : x ∈ s) => iff.mpr mem_closure fun (S : subring R) (hS : s ⊆ ↑S) => hS hx

/-- A subring `t` includes `closure s` if and only if it includes `s`. -/
@[simp] theorem closure_le {R : Type u} [ring R] {s : set R} {t : subring R} :
    closure s ≤ t ↔ s ⊆ ↑t :=
  { mp := set.subset.trans subset_closure, mpr := fun (h : s ⊆ ↑t) => Inf_le h }

/-- Subring closure of a set is monotone in its argument: if `s ⊆ t`,
then `closure s ≤ closure t`. -/
theorem closure_mono {R : Type u} [ring R] {s : set R} {t : set R} (h : s ⊆ t) :
    closure s ≤ closure t :=
  iff.mpr closure_le (set.subset.trans h subset_closure)

theorem closure_eq_of_le {R : Type u} [ring R] {s : set R} {t : subring R} (h₁ : s ⊆ ↑t)
    (h₂ : t ≤ closure s) : closure s = t :=
  le_antisymm (iff.mpr closure_le h₁) h₂

/-- An induction principle for closure membership. If `p` holds for `0`, `1`, and all elements
of `s`, and is preserved under addition, negation, and multiplication, then `p` holds for all elements
of the closure of `s`. -/
theorem closure_induction {R : Type u} [ring R] {s : set R} {p : R → Prop} {x : R}
    (h : x ∈ closure s) (Hs : ∀ (x : R), x ∈ s → p x) (H0 : p 0) (H1 : p 1)
    (Hadd : ∀ (x y : R), p x → p y → p (x + y)) (Hneg : ∀ (x : R), p x → p (-x))
    (Hmul : ∀ (x y : R), p x → p y → p (x * y)) : p x :=
  iff.mpr closure_le Hs x h

theorem mem_closure_iff {R : Type u} [ring R] {s : set R} {x : R} :
    x ∈ closure s ↔ x ∈ add_subgroup.closure ↑(submonoid.closure s) :=
  sorry

theorem exists_list_of_mem_closure {R : Type u} [ring R] {s : set R} {x : R} (h : x ∈ closure s) :
    ∃ (L : List (List R)),
        (∀ (t : List R), t ∈ L → ∀ (y : R), y ∈ t → y ∈ s ∨ y = -1) ∧
          list.sum (list.map list.prod L) = x :=
  sorry

/-- `closure` forms a Galois insertion with the coercion to set. -/
protected def gi (R : Type u) [ring R] : galois_insertion closure coe :=
  galois_insertion.mk (fun (s : set R) (_x : ↑(closure s) ≤ s) => closure s) sorry sorry sorry

/-- Closure of a subring `S` equals `S`. -/
theorem closure_eq {R : Type u} [ring R] (s : subring R) : closure ↑s = s :=
  galois_insertion.l_u_eq (subring.gi R) s

@[simp] theorem closure_empty {R : Type u} [ring R] : closure ∅ = ⊥ :=
  galois_connection.l_bot (galois_insertion.gc (subring.gi R))

@[simp] theorem closure_univ {R : Type u} [ring R] : closure set.univ = ⊤ := coe_top ▸ closure_eq ⊤

theorem closure_union {R : Type u} [ring R] (s : set R) (t : set R) :
    closure (s ∪ t) = closure s ⊔ closure t :=
  galois_connection.l_sup (galois_insertion.gc (subring.gi R))

theorem closure_Union {R : Type u} [ring R] {ι : Sort u_1} (s : ι → set R) :
    closure (set.Union fun (i : ι) => s i) = supr fun (i : ι) => closure (s i) :=
  galois_connection.l_supr (galois_insertion.gc (subring.gi R))

theorem closure_sUnion {R : Type u} [ring R] (s : set (set R)) :
    closure (⋃₀s) = supr fun (t : set R) => supr fun (H : t ∈ s) => closure t :=
  galois_connection.l_Sup (galois_insertion.gc (subring.gi R))

theorem map_sup {R : Type u} {S : Type v} [ring R] [ring S] (s : subring R) (t : subring R)
    (f : R →+* S) : map f (s ⊔ t) = map f s ⊔ map f t :=
  galois_connection.l_sup (gc_map_comap f)

theorem map_supr {R : Type u} {S : Type v} [ring R] [ring S] {ι : Sort u_1} (f : R →+* S)
    (s : ι → subring R) : map f (supr s) = supr fun (i : ι) => map f (s i) :=
  galois_connection.l_supr (gc_map_comap f)

theorem comap_inf {R : Type u} {S : Type v} [ring R] [ring S] (s : subring S) (t : subring S)
    (f : R →+* S) : comap f (s ⊓ t) = comap f s ⊓ comap f t :=
  galois_connection.u_inf (gc_map_comap f)

theorem comap_infi {R : Type u} {S : Type v} [ring R] [ring S] {ι : Sort u_1} (f : R →+* S)
    (s : ι → subring S) : comap f (infi s) = infi fun (i : ι) => comap f (s i) :=
  galois_connection.u_infi (gc_map_comap f)

@[simp] theorem map_bot {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) : map f ⊥ = ⊥ :=
  galois_connection.l_bot (gc_map_comap f)

@[simp] theorem comap_top {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) :
    comap f ⊤ = ⊤ :=
  galois_connection.u_top (gc_map_comap f)

/-- Given `subring`s `s`, `t` of rings `R`, `S` respectively, `s.prod t` is `s × t`
as a subring of `R × S`. -/
def prod {R : Type u} {S : Type v} [ring R] [ring S] (s : subring R) (t : subring S) :
    subring (R × S) :=
  mk (set.prod ↑s ↑t) sorry sorry sorry sorry sorry

theorem coe_prod {R : Type u} {S : Type v} [ring R] [ring S] (s : subring R) (t : subring S) :
    ↑(prod s t) = set.prod ↑s ↑t :=
  rfl

theorem mem_prod {R : Type u} {S : Type v} [ring R] [ring S] {s : subring R} {t : subring S}
    {p : R × S} : p ∈ prod s t ↔ prod.fst p ∈ s ∧ prod.snd p ∈ t :=
  iff.rfl

theorem prod_mono {R : Type u} {S : Type v} [ring R] [ring S] {s₁ : subring R} {s₂ : subring R}
    (hs : s₁ ≤ s₂) {t₁ : subring S} {t₂ : subring S} (ht : t₁ ≤ t₂) : prod s₁ t₁ ≤ prod s₂ t₂ :=
  set.prod_mono hs ht

theorem prod_mono_right {R : Type u} {S : Type v} [ring R] [ring S] (s : subring R) :
    monotone fun (t : subring S) => prod s t :=
  prod_mono (le_refl s)

theorem prod_mono_left {R : Type u} {S : Type v} [ring R] [ring S] (t : subring S) :
    monotone fun (s : subring R) => prod s t :=
  fun (s₁ s₂ : subring R) (hs : s₁ ≤ s₂) => prod_mono hs (le_refl t)

theorem prod_top {R : Type u} {S : Type v} [ring R] [ring S] (s : subring R) :
    prod s ⊤ = comap (ring_hom.fst R S) s :=
  sorry

theorem top_prod {R : Type u} {S : Type v} [ring R] [ring S] (s : subring S) :
    prod ⊤ s = comap (ring_hom.snd R S) s :=
  sorry

@[simp] theorem top_prod_top {R : Type u} {S : Type v} [ring R] [ring S] : prod ⊤ ⊤ = ⊤ :=
  Eq.trans (top_prod ⊤) (comap_top (ring_hom.snd R S))

/-- Product of subrings is isomorphic to their product as rings. -/
def prod_equiv {R : Type u} {S : Type v} [ring R] [ring S] (s : subring R) (t : subring S) :
    ↥(prod s t) ≃+* ↥s × ↥t :=
  ring_equiv.mk (equiv.to_fun (equiv.set.prod ↑s ↑t)) (equiv.inv_fun (equiv.set.prod ↑s ↑t)) sorry
    sorry sorry sorry

/-- The underlying set of a non-empty directed Sup of subrings is just a union of the subrings.
  Note that this fails without the directedness assumption (the union of two subrings is
  typically not a subring) -/
theorem mem_supr_of_directed {R : Type u} [ring R] {ι : Sort u_1} [hι : Nonempty ι]
    {S : ι → subring R} (hS : directed LessEq S) {x : R} :
    (x ∈ supr fun (i : ι) => S i) ↔ ∃ (i : ι), x ∈ S i :=
  sorry

theorem coe_supr_of_directed {R : Type u} [ring R] {ι : Sort u_1} [hι : Nonempty ι]
    {S : ι → subring R} (hS : directed LessEq S) :
    ↑(supr fun (i : ι) => S i) = set.Union fun (i : ι) => ↑(S i) :=
  sorry

theorem mem_Sup_of_directed_on {R : Type u} [ring R] {S : set (subring R)} (Sne : set.nonempty S)
    (hS : directed_on LessEq S) {x : R} : x ∈ Sup S ↔ ∃ (s : subring R), ∃ (H : s ∈ S), x ∈ s :=
  sorry

theorem coe_Sup_of_directed_on {R : Type u} [ring R] {S : set (subring R)} (Sne : set.nonempty S)
    (hS : directed_on LessEq S) :
    ↑(Sup S) = set.Union fun (s : subring R) => set.Union fun (H : s ∈ S) => ↑s :=
  sorry

end subring

namespace ring_hom

/-- Restriction of a ring homomorphism to a subring of the domain. -/
def restrict {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) (s : subring R) : ↥s →+* S :=
  comp f (subring.subtype s)

@[simp] theorem restrict_apply {R : Type u} {S : Type v} [ring R] [ring S] {s : subring R}
    (f : R →+* S) (x : ↥s) : coe_fn (restrict f s) x = coe_fn f ↑x :=
  rfl

/-- Restriction of a ring homomorphism to its range interpreted as a subsemiring. -/
def range_restrict {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) : R →+* ↥(range f) :=
  cod_restrict' f (range f) sorry

@[simp] theorem coe_range_restrict {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S)
    (x : R) : ↑(coe_fn (range_restrict f) x) = coe_fn f x :=
  rfl

theorem range_top_iff_surjective {R : Type u} {S : Type v} [ring R] [ring S] {f : R →+* S} :
    range f = ⊤ ↔ function.surjective ⇑f :=
  sorry

/-- The range of a surjective ring homomorphism is the whole of the codomain. -/
theorem range_top_of_surjective {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S)
    (hf : function.surjective ⇑f) : range f = ⊤ :=
  iff.mpr range_top_iff_surjective hf

/-- The subring of elements `x : R` such that `f x = g x`, i.e.,
  the equalizer of f and g as a subring of R -/
def eq_locus {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) (g : R →+* S) : subring R :=
  subring.mk (set_of fun (x : R) => coe_fn f x = coe_fn g x) sorry sorry sorry sorry sorry

/-- If two ring homomorphisms are equal on a set, then they are equal on its subring closure. -/
theorem eq_on_set_closure {R : Type u} {S : Type v} [ring R] [ring S] {f : R →+* S} {g : R →+* S}
    {s : set R} (h : set.eq_on (⇑f) (⇑g) s) : set.eq_on ⇑f ⇑g ↑(subring.closure s) :=
  (fun (this : subring.closure s ≤ eq_locus f g) => this) (iff.mpr subring.closure_le h)

theorem eq_of_eq_on_set_top {R : Type u} {S : Type v} [ring R] [ring S] {f : R →+* S} {g : R →+* S}
    (h : set.eq_on ⇑f ⇑g ↑⊤) : f = g :=
  ext fun (x : R) => h trivial

theorem eq_of_eq_on_set_dense {R : Type u} {S : Type v} [ring R] [ring S] {s : set R}
    (hs : subring.closure s = ⊤) {f : R →+* S} {g : R →+* S} (h : set.eq_on (⇑f) (⇑g) s) : f = g :=
  eq_of_eq_on_set_top (hs ▸ eq_on_set_closure h)

theorem closure_preimage_le {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) (s : set S) :
    subring.closure (⇑f ⁻¹' s) ≤ subring.comap f (subring.closure s) :=
  iff.mpr subring.closure_le
    fun (x : R) (hx : x ∈ ⇑f ⁻¹' s) =>
      iff.mpr subring.mem_coe (iff.mpr subring.mem_comap (subring.subset_closure hx))

/-- The image under a ring homomorphism of the subring generated by a set equals
the subring generated by the image of the set. -/
theorem map_closure {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) (s : set R) :
    subring.map f (subring.closure s) = subring.closure (⇑f '' s) :=
  sorry

end ring_hom

namespace subring

/-- The ring homomorphism associated to an inclusion of subrings. -/
def inclusion {R : Type u} [ring R] {S : subring R} {T : subring R} (h : S ≤ T) : ↥S →* ↥T :=
  ↑(ring_hom.cod_restrict' (subtype S) T sorry)

@[simp] theorem range_subtype {R : Type u} [ring R] (s : subring R) :
    ring_hom.range (subtype s) = s :=
  ext' (Eq.trans (ring_hom.coe_srange (subtype s)) subtype.range_coe)

@[simp] theorem range_fst {R : Type u} {S : Type v} [ring R] [ring S] :
    ring_hom.srange (ring_hom.fst R S) = ⊤ :=
  ring_hom.srange_top_of_surjective (ring_hom.fst R S) prod.fst_surjective

@[simp] theorem range_snd {R : Type u} {S : Type v} [ring R] [ring S] :
    ring_hom.srange (ring_hom.snd R S) = ⊤ :=
  ring_hom.srange_top_of_surjective (ring_hom.snd R S) prod.snd_surjective

@[simp] theorem prod_bot_sup_bot_prod {R : Type u} {S : Type v} [ring R] [ring S] (s : subring R)
    (t : subring S) : prod s ⊥ ⊔ prod ⊥ t = prod s t :=
  sorry

end subring

namespace ring_equiv

/-- Makes the identity isomorphism from a proof two subrings of a multiplicative
    monoid are equal. -/
def subring_congr {R : Type u} [ring R] {s : subring R} {t : subring R} (h : s = t) : ↥s ≃+* ↥t :=
  mk (equiv.to_fun (equiv.set_congr sorry)) (equiv.inv_fun (equiv.set_congr sorry)) sorry sorry
    sorry sorry

end ring_equiv

namespace subring

protected theorem in_closure.rec_on {R : Type u} [ring R] {s : set R} {C : R → Prop} {x : R}
    (hx : x ∈ closure s) (h1 : C 1) (hneg1 : C (-1))
    (hs : ∀ (z : R), z ∈ s → ∀ (n : R), C n → C (z * n)) (ha : ∀ {x y : R}, C x → C y → C (x + y)) :
    C x :=
  sorry

theorem closure_preimage_le {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S) (s : set S) :
    closure (⇑f ⁻¹' s) ≤ comap f (closure s) :=
  iff.mpr closure_le
    fun (x : R) (hx : x ∈ ⇑f ⁻¹' s) => iff.mpr mem_coe (iff.mpr mem_comap (subset_closure hx))

end subring

theorem add_subgroup.int_mul_mem {R : Type u} [ring R] {G : add_subgroup R} (k : ℤ) {g : R}
    (h : g ∈ G) : ↑k * g ∈ G :=
  sorry

end Mathlib


/-
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.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.discrete_category
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# The empty category

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

namespace category_theory

namespace functor

/-- The canonical functor out of the empty category. -/
def empty (C : Type u) [category C] : discrete pempty ⥤ C := discrete.functor pempty.elim

/-- Any two functors out of the empty category are isomorphic. -/
def empty_ext {C : Type u} [category C] (F : discrete pempty ⥤ C) (G : discrete pempty ⥤ C) :
    F ≅ G :=
  discrete.nat_iso fun (x : discrete pempty) => pempty.elim x

/--
Any functor out of the empty category is isomorphic to the canonical functor from the empty
category.
-/
def unique_from_empty {C : Type u} [category C] (F : discrete pempty ⥤ C) : F ≅ empty C :=
  empty_ext F (empty C)

/--
Any two functors out of the empty category are *equal*. You probably want to use
`empty_ext` instead of this.
-/
theorem empty_ext' {C : Type u} [category C] (F : discrete pempty ⥤ C) (G : discrete pempty ⥤ C) :
    F = G :=
  ext (fun (x : discrete pempty) => pempty.elim x)
    fun (x _x : discrete pempty) (_x_1 : x ⟶ _x) => pempty.elim x

end Mathlib


/-
  Basic definitions and lemmas about opens.

  TODO : Not use opens as sets when possible.

  Author: Ramon Fernandez Mir
-/

import topology.basic
import topology.opens

universes u v

open topological_space lattice lattice.lattice

section opens

variables {α : Type u} [topological_space α]

-- A couple of useful tricks to work avoid using the lattice jargon when
-- dealing with opens.

@[simp] lemma opens.inter (U V : opens α) :
U ∩ V = ⟨U.1 ∩ V.1, is_open_inter U.2 V.2⟩ := rfl

lemma opens.inter_comm (U V : opens α) :
U ∩ V = V ∩ U := subtype.ext.2 $ set.inter_comm U.1 V.1

prefix `⋃` := supr

-- Opens constants.

def opens.univ : opens α := ⟨set.univ, is_open_univ⟩

def opens.empty : opens α := ⟨∅, is_open_empty⟩

-- Some useful lemmas. Maybe versions of them are already somewhere.

lemma opens_supr_mem {γ : Type*} (X : γ → opens α)
: ∀ i x, x ∈ (X i).val → x ∈ (⋃ X).val :=
λ i x Hx, let Xi := X i in
begin
    unfold supr; simp,
    exact ⟨Xi.1, ⟨⟨Xi.2, i, by simp⟩, Hx⟩⟩,
end

lemma opens_supr_subset {γ : Type*} (X : γ → opens α)
: ∀ i, X i ⊆ ⋃ X :=
λ i x, opens_supr_mem X i x

-- Opens comap.

section opens_comap

variables {β : Type v} [topological_space β]
variables {f : α → β} (Hf : continuous f)

@[reducible] def opens.comap : opens β → opens α :=
λ U, ⟨f ⁻¹' U.1, Hf U.1 U.2⟩

def opens.comap_mono (U V : opens β) (HUV : U ≤ V) : opens.comap Hf U ≤ opens.comap Hf V :=
set.preimage_mono HUV

end opens_comap

-- Opens map (assuming that f is an open immersion).

section opens_map

variables {β : Type v} [topological_space β]
variables {f : α → β} (Hf : ∀ (U : opens α), is_open (f '' U))

def opens.map : opens α → opens β :=
λ U, ⟨f '' U, Hf U⟩

lemma opens.map_mono (U V : opens α) (HUV : U ≤ V) : opens.map Hf U ≤ opens.map Hf V :=
set.image_subset f HUV

end opens_map

end opens