/-
Copyright (c) 2022 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Kevin Buzzard
-/

import tactic -- imports all the Lean tactics
import data.real.basic -- imports the real numbers
import solutions.section02reals.sheet5 -- import a bunch of previous stuff

/-

# Harder questions

Here are some harder questions. Don't feel like you have
to do them. We've seen enough techniques to be able to do
all of these, but the truth is that we've seen a ton of stuff
in this course already, so probably you're not on top of all of
it yet, and furthermore we have not seen
some techniques which will enable you to cut corners. If you
want to become a real Lean expert then see how many of these
you can do. I will go through them all in a solutions video,
so if you like you can try some of them and then watch me
solving them.

Good luck!
-/

/-- If `a(n)` tends to `t` then `37 * a(n)` tends to `37 * t`-/
theorem tendsto_thirtyseven_mul (a : ℕ → ℝ) (t : ℝ) (h : tendsto a t) :
  tendsto (λ n, 37 * a n) (37 * t) :=
begin
  rw tendsto at *,intros,specialize h (ε/37) (by linarith),cases h with B h,use B,intros n α,specialize h n α,
  rw <-mul_sub,rw abs_mul,rw abs_of_nonneg,
  {linarith,},linarith,
end

/-- If `a(n)` tends to `t` and `c` is a positive constant then
`c * a(n)` tends to `c * t`. -/
theorem tendsto_pos_const_mul {a : ℕ → ℝ} {t : ℝ} (h : tendsto a t)
  {c : ℝ} (hc : 0 < c) : tendsto (λ n, c * a n) (c * t) :=
begin
  rw tendsto at *, intros,obtain ⟨B,x⟩ := h (ε/c)(div_pos H hc),use B,intros n α,
  specialize x n α,rw [<-mul_sub, abs_mul, abs_of_nonneg],exact (lt_div_iff' hc).mp x,linarith,
end

/-- If `a(n)` tends to `t` and `c` is a negative constant then
`c * a(n)` tends to `c * t`. -/
theorem tendsto_neg_const_mul {a : ℕ → ℝ} {t : ℝ} (h : tendsto a t)
  {c : ℝ} (hc : c < 0) : tendsto (λ n, c * a n) (c * t) :=
begin
  have q: 0< -c,simp,exact hc,
  intros ε e,obtain ⟨B,x⟩ := h (ε/ -c)(div_pos e q),use B,intros n ineq, simp,
  rw [<- mul_sub, abs_mul,abs_of_neg],specialize x n ineq,exact (lt_div_iff' q).mp x,assumption,
end

/-- If `a(n)` tends to `t` and `c` is a constant then `c * a(n)` tends
to `c * t`. -/
theorem tendsto_const_mul {a : ℕ → ℝ} {t : ℝ} (c : ℝ) (h : tendsto a t) :
  tendsto (λ n, c * a n) (c * t) :=
begin
  obtain (q|rfl|q) := lt_trichotomy 0 c,
  {exact tendsto_pos_const_mul h q},
  {simpa using tendsto_const 0},
  {exact tendsto_neg_const_mul h q},
end

/-- If `a(n)` tends to `t` and `c` is a constant then `a(n) * c` tends
to `t * c`. -/
theorem tendsto_mul_const {a : ℕ → ℝ} {t : ℝ} (c : ℝ) (h : tendsto a t) :
  tendsto (λ n, a n * c) (t * c) :=
begin
  simpa [mul_comm] using tendsto_const_mul c h,
end

-- another proof of this result, showcasing some tactics
-- which I've not covered yet.
theorem tendsto_neg' {a : ℕ → ℝ} {t : ℝ} (ha : tendsto a t) :
  tendsto (λ n, - a n) (-t) :=
begin
  convert tendsto_const_mul (-1) ha, -- read about `convert` on the community web pages
  { ext, simp }, -- ext is a generic extensionality tactic. Here it's being
                 -- used to deduce that two functions are the same if they take
                 -- the same values everywhere
  { simp },
end

/-- If `a(n)-b(n)` tends to `t` and `b(n)` tends to `u` then
`a(n)` tends to `t + u`. -/
theorem tendsto_of_tendsto_sub {a b : ℕ → ℝ} {t u : ℝ}
  (h1 : tendsto (λ n, a n - b n) t) (h2 : tendsto b u) :
  tendsto a (t+u) :=
begin
  simpa using tendsto_add h1 h2,
end

/-- If `a(n)` tends to `t` then `a(n)-t` tends to `0`. -/
theorem tendsto_sub_lim {a : ℕ → ℝ} {t : ℝ}
  (h : tendsto a t) : tendsto (λ n, a n - t) 0 :=
begin
  simpa using tendsto_sub h (tendsto_const t),
end

/-- If `a(n)` and `b(n)` both tend to zero, then their product tends
to zero. -/
theorem tendsto_zero_mul_tendsto_zero
  {a b : ℕ → ℝ} (ha : tendsto a 0) (hb : tendsto b 0) :
  tendsto (λ n, a n * b n) 0 :=
begin
  intros ε hε,
  obtain ⟨X, hX⟩ := ha ε hε,
  obtain ⟨Y, hY⟩ := hb 1 zero_lt_one,
  use max X Y,
  intros n hn,
  specialize hX n (le_of_max_le_left hn),
  specialize hY n (le_of_max_le_right hn),
  simpa [abs_mul] using mul_lt_mul'' hX hY _ _;
  exact abs_nonneg _,
end

/-- If `a(n)` tends to `t` and `b(n)` tends to `u` then
`a(n)*b(n)` tends to `t*u`. -/
theorem tendsto_mul (a b : ℕ → ℝ) (t u : ℝ) (ha : tendsto a t)
  (hb : tendsto b u) : tendsto (λ n, a n * b n) (t * u) :=
begin

end

-- something we never used!
/-- A sequence has at most one limit. -/
theorem tendsto_unique (a : ℕ → ℝ) (s t : ℝ)
  (hs : tendsto a s) (ht : tendsto a t) : s = t :=
begin
  sorry,
end


import order.filter.basic

/-

# tendsto

If `X` and `Y` are types, `φ : X → Y` is a function,
and `F : filter X` and `G : filter Y` are filters, then

`filter.tendsto φ F G`

is a true-false statement, which is pronounced something like
"`F` tends to `G` along `φ`". Of course we will `open filter`
in this file, so you can just write `tendsto φ F G`, or if
you like the dot notation you can even write `F.tendsto φ G`.

## Geometric meaning of `tendsto`.

Let's start by thinking about the easy case where `F` and `G`
are actually subsets of `X` and `Y` (that is, principal filters,
associated to sets which we will also call `F` and `G`). In this case,
`tendsto φ F G` simply means "`φ` restricts to a function
from `F` to `G`", or in other words `∀ x ∈ F, φ(x) ∈ G`.

There are two other ways of writing this predicate. The first
involves pushing a set forward along a map. If `F` is a subset of `X`
then let `φ(F)` denote the image of `F` under `φ`, that
is, the subset `{y : Y | ∃ x : X, φ x = y}` of `Y`.
Then `tendsto φ F G` simply means `φ(F) ⊆ G`.

The second involves pulling a set back along a map. If `G` is a subset
of `Y` then let `φ⁻¹(G)` denote the preimage of `G` under `φ`,
that is, the subset `{x : X | φ x ∈ G}` of `Y`. Then `tendsto φ F G`
simply means `F ⊆ φ⁻¹(G)`.

This is how it all works in the case of sets. What we need to
do today is to figure out how to push forward and pull back
filters along a map `φ`. Once we have done this, then we can
prove `φ(F) ≤ G ↔ F ≤ φ⁻¹(G)` and use either one of these
as our definition of `tendsto φ F G` -- it doesn't matter which.

## Digression : adjoint functors.

The discussion below is not needed to be able to do this week's
problems, but it might provide some helpful background for some.
Also note that anyone who still doens't like the word "type" can
literally just change it for the word "set" (and change "term of
type" to "element of set"), which is how arguments
of the below kind would appear in the traditional mathematical
literature.

Partially ordered types, such as the type of subsets of a fixed
type `X` or the type of filters on `X`, are actually very simple
examples of categories. In general if `P` is a partially ordered type
and `x,y` are terms of type `P` then the idea is that we can
define `Hom(x,y)` to have exactly one element if `x ≤ y` is true,
and no elements at all if `x ≤ y` is false. The structure/axioms for
a category are that `Hom(x,x)` is supposed to have an identity
element, which follows from reflexivity of `≤`, and that one can
compose morphisms, which follows from transitivity of `≤`.
Antisymmetry states that if two objects are isomorphic (i.e.,
in this case, if `Hom(x,y)` and `Hom(y,x)` are both nonempty),
then they are equal. If `φ : X → Y` is a map of types, then
pushing forward subsets and pulling back subsets are both
functors from `set X` to `set Y`, because `S ⊆ T → φ(S) ⊆ φ(T)`
and `U ⊆ V → φ⁻¹(U) ⊆ φ⁻¹(V)`. The statement that
`φ(S) ≤ U ↔ S ≤ φ⁻¹(U)` is simply the statement that these functors
are adjoint to each other. Today we will define pushforward and
pullback of filters, and show that they are also a pair of
adjoint functors, but we will not use this language. In fact there
is a special language for adjoint functors in this simple situation:
we will say that pushforward and pullback form a Galois connection.

-/

/-

## Warm-up: pushing forward and pulling back subsets.

Say `X` and `Y` are types, and `f : X → Y`.

-/

variables (X Y : Type) (f : X → Y)

/-

### images

In Lean, the image `f(S)` of a subset `S : set X` cannot
be denoted `f S`, because `f` expects an _element_ of `X` as
an input, not a subset of `X`, so we need new notation.

Notation : `f '' S` is the image of `S` under `f`. Let's
check this.

-/

example (S : set X) : f '' S = {y : Y | ∃ x : X, x ∈ S ∧ f x = y} :=
begin
  -- true by definition
  refl
end

/-

### preimages

In Lean, the preimage `f⁻¹(T)` of a subset `T : set Y` cannot
be denoted `f⁻¹ T` because `⁻¹` is the inverse notation in group
theory, so if anything would be a function from `Y` to `X`,
not a function on subsets of `Y`.

Notation : `f ⁻¹' T` is the preimage of `T` under `f`. Let's
check this.

Pro shortcut: `\-'` for `⁻¹'`

-/

example (T : set Y) : f ⁻¹' T = {x : X | f x ∈ T} :=
begin
  -- true by definition
  refl
end

/-

I claim that the following conditions on `S : set X` and `T : set Y`
are equivalent:

1) `f '' S ⊆ T`
2) `S ⊆ f⁻¹' T`

Indeed, they both say that `f` restricts to a function from `S` to `T`.
Let's check this. You might find

`mem_preimage : a ∈ f ⁻¹' s ↔ f a ∈ s`

and

-/

open set

example (S : set X) (T : set Y) : f '' S ⊆ T ↔ S ⊆ f⁻¹' T :=
begin
  split,
  { intros h x hxS,
    -- rw subset_def at h,
    -- rw mem_preimage,
    apply h,
    use [x, hxS, rfl] },
  { rintros h - ⟨x, hxS, rfl⟩,
    exact h hxS }
end

/-

## Pushing forward filters.

Pushing forward is easy, so let's do that first.
It's called `filter.map` in Lean.

We define the pushforward filter `map f F` on `Y` to be the
obvious thing: a subset of `Y` is in the filter iff `f⁻¹(Y)`
is in `F`. Let's check this is a filter.

Reminder of some helpful lemmas:

In `set`:
`mem_set_of_eq : a ∈ {x : α | p x} = p a` -- definitional

In `filter`:
`univ_mem_sets : univ ∈ F`
`mem_sets_of_superset : S ∈ F → S ⊆ T → T ∈ F`
`inter_mem_sets : S ∈ F → T ∈ F → S ∩ T ∈ F`

-/

open filter

-- this is called `F.map f` or `filter.map f F`
-- or just `map f F` if `filter` is open.
example (F : filter X) : filter Y :=
{ sets := {T : set Y | f ⁻¹' T ∈ F },
  univ_sets := begin
--    rw mem_set_of_eq,
    exact univ_mem_sets,
  end,
  sets_of_superset := begin
    intros S T hS hST,
    --rw mem_set_of_eq at *,
    refine mem_sets_of_superset hS _,
    intros x hx,
    exact hST hx,
  end,
  inter_sets := begin
    intros S T,
    -- I am abusing definitional equality
    exact inter_mem_sets,
  end, }

-- this is `filter.mem_map` and it's true by definition.
example (F : filter X) (T : set Y) : T ∈ F.map f ↔ f ⁻¹' T ∈ F :=
begin
  -- true by definition
  refl
end

-- Let's check that map satisfies some basic functorialities.
-- Recall that if your goal is to check two filters are
-- equal then you can use the `ext` tactic.

-- pushing along the identity map id : X → X doesn't change the filter.
-- this is `filter.map_id` but see if you can prove it yourself.
example (F : filter X) : F.map id = F :=
begin
  ext S,
  refl,
end

-- pushing along g ∘ f is the same as pushing along f and then g
-- for some reason this isn't in mathlib, instead they have `map_map` which
-- has the equality the other way.
variables (Z : Type) (g : Y → Z)

-- this isn't in mathlib, but `filter.map_map` is the equality the other
-- way around. See if you can prove it yourself.
example (F : filter X) : F.map (g ∘ f) = (F.map f).map g :=
begin
  ext S,
  refl,
end

open_locale filter -- for 𝓟 notation

-- pushing the principal filter `𝓟 S` along `f` gives `𝓟 (f '' S)`
-- this is `filter.map_principal` but see if you can prove it yourself.
example (S : set X) : (𝓟 S).map f = 𝓟 (f '' S) :=
begin
  ext T,
--  rw mem_map,
--  rw mem_principal_sets,
--  rw mem_principal_sets,
  split,
  { rintro h y ⟨x, hx, rfl⟩,
    exact h hx },
  { rintro h x hx,
    apply h,
    exact ⟨x, hx, rfl⟩ }
end

/-

## tendsto

The definition: if `f : X → Y` and `F : filter X` and `G : filter Y`
then `tendsto f F G : Prop := map f F ≤ G`. This is a definition (it
has type `Prop`), not the proof of a theorem. It is a true-false statement
attached to `f`, `F` and `G`, it's a bit like saying "f is continuous at x"
or something like that, it might be true and it might be false.

The mental model you might want to have of the definition is that
`tendsto f F G` means that the function `f` restricts to a function
from the generalized set `F` to the generalized set `G`.

-/

-- this is `filter.tendsto_def`
example (F : filter X) (G : filter Y) :
  tendsto f F G ↔ ∀ T : set Y, T ∈ G → f ⁻¹' T ∈ F :=
begin
  -- true by definition
  refl
end

-- Let's make a basic API for `tendsto`

-- this is `tendsto_id` but see if you can prove it yourself.
example (F : filter X) : tendsto id F F :=
begin
  intro S,
  exact id,
end

-- this is `tendsto.comp` but see if you can prove it yourself
example (F : filter X) (G : filter Y) (H : filter Z)
  (f : X → Y) (g : Y → Z)
  (hf : tendsto f F G) (hg : tendsto g G H) : tendsto (g ∘ f) F H :=
begin
  rintro S hS,
  specialize hg hS,
  specialize hf hg,
  exact hf,
end

-- I would recommend looking at the model answer to this one if
-- you get stuck.
lemma tendsto_comp_map (g : Y → Z) (F : filter X) (G : filter Z) :
  tendsto (g ∘ f) F G ↔ tendsto g (F.map f) G :=
begin
  refl, -- Both sides are the same, by definition. Think about it on paper!
end

/-

## Appendix : Pulling back filters

We don't use this in the next part.

Say `f : X → Y` and `G : filter Y`, and we want a filter on `X`. Let's make a
naive definition. We want a collection of subsets of `X` corresponding to the
filter obtained by pulling back `G` along `f`. When should `S : set X` be
in this filter? Perhaps it is when `f '' S ∈ G`. However, there is no reason
that the collection of `S` satisfying this property should be a filter
on `X`. For example, there is no reason to espect that `f '' univ ∈ G`
if `f` is not surjective.

Here's a way of fixing this. Remember that our model of a filter `G` is some
kind of generalised notion of a set. If `T : set Y` then `T ∈ G` is supposed to
mean that the "set" `G` is a subset of `T`. So this should imply
that `f⁻¹(G) ⊆ f⁻¹(T)`. In particular, if `T ∈ G` and `f⁻¹(T) ⊆ S` then this
should mean `f⁻¹(G) ⊆ S` and hence `S ∈ f⁻¹(G)`. Let's try this and see if
it works.

Random useful lemmas (you might be getting to the point where you can
guess the names of the lemmas):

`subset_univ S : S ⊆ univ`
`subset.trans : A ⊆ B → B ⊆ C → A ⊆ C`
-/

-- this is called filter.comap
example (G : filter Y) : filter X :=
{ sets := {S : set X | ∃ T ∈ G, f ⁻¹' T ⊆ S},
  univ_sets := begin
    use univ,
    split,
    { exact univ_mem_sets },
    { exact subset_univ _ }
  end,
  sets_of_superset := begin
    rintros S T ⟨U, hUG, hUS⟩ hST,
    use [U, hUG],
    exact subset.trans hUS hST
  end,
  inter_sets := begin
    rintro S T ⟨U, hUG, hUS⟩ ⟨V, hVG, hVT⟩,
    use [U ∩ V, inter_mem_sets hUG hVG],
    rintro x ⟨hxU, hxV⟩,
    exact ⟨hUS hxU, hVT hxV⟩,
  end }

-- Let's call this mem_comap
lemma mem_comap (f : X → Y) (G : filter Y) (S : set X) :
  S ∈ comap f G ↔ ∃ T ∈ G, f ⁻¹' T ⊆ S :=
begin
  -- true by definition
  refl
end

-- If you want to, you can check some preliminary properties of `comap`.

-- this is comap_id
example (G : filter Y) : comap id G = G :=
begin
  ext S,
  rw mem_comap,
  split,
  { rintro ⟨T, hT, h⟩,
    exact mem_sets_of_superset hT h,
  },
  { intro hS,
    use [S, hS],
    refl }
end

-- this is comap_comap but the other way around
lemma comap_comp (H : filter Z) : comap (g ∘ f) H = comap f (comap g H) :=
begin
  ext S,
  simp only [mem_comap],
  split,
  { rintro ⟨U, hU, h⟩,
    use g ⁻¹' U,
    refine ⟨_, h⟩,
    rw mem_comap,
    use [U, hU] },
  { rintro ⟨T, ⟨U, hU, h2⟩, h⟩,
    use [U, hU],
    refine subset.trans _ h,
    intros x hx,
    exact h2 hx }
end

-- this is comap_principal. Remember `mem_principal_sets`!
example (T : set Y) : comap f (𝓟 T) = 𝓟 (f ⁻¹' T) :=
begin
  ext S,
--  rw mem_comap,
--  rw mem_principal_sets,
  split,
  { rintro ⟨U, hU, h⟩,
    refine subset.trans (λ x, _) h,
    apply hU },
  { intro h,
    exact ⟨T, mem_principal_self T, h⟩ }
end

-- This is the proof that `map f` and `comap f` are adjoint functors,
-- or in other words form a Galois connection. It is the "generalised set"
-- analogue of the assertion that if S is a subset of X and T is a subset of Y
-- then f(S) ⊆ T ↔ S ⊆ f⁻¹(T), these both being ways to say that `f` restricts
-- to a function from `S` to `T`.
lemma filter.galois_connection (F : filter X) (G : filter Y) :
  map f F ≤ G ↔ F ≤ comap f G :=
begin
  split,
  { rintro h S ⟨T, hT, hTS⟩,
    rw le_def at h,
    exact mem_sets_of_superset (h T hT) hTS },
  { rintro h T hT,
    rw le_def at h,
    exact h (f ⁻¹' T) ⟨T, hT, subset.refl _⟩ },
end

-- indeed, `map f` and `comap f` form a Galois connection.
example : galois_connection (map f) (comap f) :=
filter.galois_connection X Y f


/-
Copyright (c) 2023 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Jujian Zhang
-/

import topology.bases               -- definition of topological bases
import topology.metric_space.basic  -- facts about intervals in ℝ
import topology.algebra.order.floor -- facts about floor function, fractional part function etc

noncomputable theory

/-!

# Topological Spaces in Lean

For any `X : Type`, a topology on `X` is defined as:
```
@[protect_proj] structure topological_space (α : Type u) :=
(is_open        : set α → Prop)
(is_open_univ   : is_open univ)
(is_open_inter  : ∀s t, is_open s → is_open t → is_open (s ∩ t))
(is_open_sUnion : ∀s, (∀t∈s, is_open t) → is_open (⋃₀ s))
```

In this sheet, the following can be found:
- defining several topological spaces;
- proof or disproof of some functions being continuous;
- denseness, compactness;
- homeomorphism
-/

universe u

namespace topological_space

variables (X : Type u)

/--
The discrete topology is the one the most open sets.
-/
def discrete : topological_space X :=
sorry

/--
The indiscrete topology is the one with the least open sets.
-/
def indiscrete : topological_space X :=
sorry

/--
                `1`
`(X, discrete) ----->  (X, indiscrete)` is continuous
-/
example : @@continuous (discrete X) (indiscrete X) id :=
sorry
/--
But is
                   `1`
`(X, indiscrete) ------> (X, discrete)` continuous?
-/
example (x y : X) (h : x ≠ y) : ¬ @@continuous (indiscrete X) (discrete X) id :=
sorry

/--
Finite sets only have finitely many possible topology on them.
-/
instance finitely_many_topologies [fintype X] : fintype (topological_space X) :=
sorry
/--
The upper bound is 2^2^|X|
-/
lemma card_topology_le [fintype X] :
  fintype.card (topological_space X) ≤ 2 ^ (2 ^ fintype.card X):=
sorry

/--
`ℝ` has a basis consisted of all open intervals
-/
example : is_topological_basis { I | ∃ (a b : ℝ), I = set.Ioo a b } :=
sorry

/--
`ℚ ⊆ ℝ` is dense
-/
lemma dense_ℚ : dense (algebra_map ℚ ℝ '' set.univ) :=
sorry

/--
Hence functions `ℝ → ℝ` is uniquely determined on `ℚ`.
-/
example (f g : ℝ → ℝ) (hf : continuous f) (hg : continuous g)
  (heq : ∀ (x : ℚ), f x = g x) : f = g :=
sorry

/--
An algebraic interpretation of unit circle `S¹` defined as `ℝ ⧸ ℤ` with the quotient topology,
i.e. `V ⊆ S¹` is open iff `π ⁻¹ V` is open in `ℝ` where `π : ℝ → ℝ ⧸ ℤ`.
-/
@[derive [topological_space, add_comm_group, inhabited]]
def circle := ℝ ⧸ (algebra_map ℤ ℝ).to_add_monoid_hom.range

namespace circle

/-- π -/
def from_real : ℝ → circle := sorry

/-- `[0, 1) → ℝ → S¹` -/
def from_Ico : set.Ico (0 : ℝ) 1 → circle := sorry

@[continuity]
lemma continuous_from_real : continuous from_real := sorry

@[continuity]
lemma continuous_on_from_real : continuous_on from_real (set.Ico 0 1) := sorry

@[continuity]
lemma continuous_from_Ico : continuous from_Ico :=
sorry

lemma from_Ico_inj : function.injective from_Ico :=
sorry

lemma from_Ico_surj : function.surjective from_Ico :=
sorry

/--
`S¹` is compact.
-/
instance is_compact : compact_space circle :=
sorry

/--
The half open interval `[0, 1)` continuously bijects to `S¹`.
-/
def equiv_Ico : set.Ico (0 : ℝ) 1 ≃ circle :=
sorry
/--
However, its inverse is not continuous.
-/
lemma not_cont_inv : ¬ continuous equiv_Ico.symm :=
sorry

end circle

end topological_space


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_numbertheory_458
  (n : ℕ)
  (h₀ : n % 8 = 7) :
  n % 4 = 3 :=
begin
  conv_lhs { rw ← nat.mod_add_div n 8 },
  norm_num [nat.mul_mod, h₀, nat.add_mod],
end


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Yury Kudryashov
-/
import order.bounds.basic
import algebra.order.group.defs

/-!
# Least upper bound and the greatest lower bound in linear ordered additive commutative groups

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

variables {α : Type*}

section linear_ordered_add_comm_group

variables [linear_ordered_add_comm_group α] {s : set α} {a ε : α}

lemma is_glb.exists_between_self_add (h : is_glb s a) (hε : 0 < ε) :
  ∃ b ∈ s, a ≤ b ∧ b < a + ε :=
h.exists_between $ lt_add_of_pos_right _ hε

lemma is_glb.exists_between_self_add' (h : is_glb s a) (h₂ : a ∉ s) (hε : 0 < ε) :
  ∃ b ∈ s, a < b ∧ b < a + ε :=
h.exists_between' h₂ $ lt_add_of_pos_right _ hε

lemma is_lub.exists_between_sub_self  (h : is_lub s a) (hε : 0 < ε) : ∃ b ∈ s, a - ε < b ∧ b ≤ a :=
h.exists_between $ sub_lt_self _ hε

lemma is_lub.exists_between_sub_self' (h : is_lub s a) (h₂ : a ∉ s) (hε : 0 < ε) :
  ∃ b ∈ s, a - ε < b ∧ b < a :=
h.exists_between' h₂ $ sub_lt_self _ hε

end linear_ordered_add_comm_group


/-
Copyright (c) 2022 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Kevin Buzzard
-/

import tactic -- imports all the Lean tactics

/-

Note that `X ≃ Y` is not an equivalence relation, for the stupid
reason that it's not even a true-false statement! It doesn't
say "there exists a bijection from X to Y" (which would be an
equivalence relation), it is the *type* of bijections between
`X` and `Y`, and in particular it can have more than one term
(indeed we just saw two distinct terms of type `ℚ ≃ ℚ` on the
previous sheet). However we can make some equivalence-relation-y
type constructions with `≃`. Here are definitions (not theorems!)
called `equiv.refl`, `equiv.symm` and `equiv.trans`.

-/

-- this is called `equiv.refl` in `mathlib`
example (X : Type) : X ≃ X :=
{ to_fun := λ x, x, -- x ↦ x
  inv_fun := λ y, y,-- y ↦ y
  left_inv := begin
    -- got to check that `∀ x, inv_fun (to_fun x) = x`
    intro x,
    dsimp, -- if you want to check the goal is definitionally `x = x`
    refl,
  end,
  right_inv := begin
    -- goal is definitionally `∀ y, to_fun (inv_fun y) = y`.
    intro y,
    refl,
  end }

-- now let's see you define `equiv.symm` and `equiv.trans`.
-- Let's start with `equiv.symm`.
-- Note that if `e : X ≃ Y` then `e.to_fun : X → Y`
-- and `e.left_inv` is a proof of `∀ x : X, e.inv_fun (e.to_fun x) = x` etc

-- This is `equiv.symm`. Can you fill in the proofs?
example (X Y : Type) (e : X ≃ Y) : Y ≃ X :=
{ to_fun := e.inv_fun, -- you could write `λ x, e.inv_fun x` instead
  inv_fun := e.to_fun, -- this is data -- don't use tactic mode
  left_inv := begin
    exact e.right_inv,
  end,
  right_inv := begin
    exact e.left_inv,
  end }

-- Actually, you're not supposed to write `e.to_fun` and `e.inv_fun`
-- directly, because `X ≃ Y` has got a coercion to `X → Y`,
-- so you can (and should) do it like this:

-- `equiv.symm` again
example (X Y : Type) (e : X ≃ Y) : Y ≃ X :=
{ to_fun := e.symm, -- using `equiv.symm` and dot notation
  inv_fun := e, -- using the coercion to function
  left_inv := e.right_inv,
  right_inv := e.left_inv, }

-- `equiv.trans`
example (X Y Z : Type) (eXY : X ≃ Y) (eYZ : Y ≃ Z) : X ≃ Z :=
{ to_fun := λ x, eYZ (eXY x),
  inv_fun := λ z, eXY.symm (eYZ.symm z),
  left_inv := begin
    intro x,
    simp,
  end,
  right_inv := begin
    intro z,
    simp,
  end }

-- Because `equiv.trans` is already there, we can just use it
-- directly:
example (X Y Z : Type) (eXY : X ≃ Y) (eYZ : Y ≃ Z) : X ≃ Z :=
equiv.trans eXY eYZ

-- here it is again using dot notation
example (X Y Z : Type) (eXY : X ≃ Y) (eYZ : Y ≃ Z) : X ≃ Z :=
eXY.trans eYZ

-- See if you can make the following bijection using dot notation
example (A B C X : Type) (eAX : A ≃ X) (eBX : B ≃ X) : A ≃ B :=
eAX.trans eBX.symm

/-

Note that `equiv` is *data* -- `X ≃ Y` doesn't say "`X` bijects with `Y`";
that statement is a true-false statement. A term of type `X ≃ Y`
is *explicit functions* `X → Y` and `Y → X`, together with proofs
that they're inverse bijections.

Clearly there's an equivalence relation going on *somewhere* though:
here it is.

If `X : Type` then `∃ x : X, true` is just the statement that `X`
is nonempty. It's a proposition. So this works:

-/

-- Two types `X` and `Y` satisfy `R X Y` iff there *exists*
-- a bijection `X ≃ Y`.
def R (X Y : Type) : Prop := ∃ e : X ≃ Y, true

example : equivalence R :=
begin
  refine ⟨_, _, _⟩,
  { intro X,
    exact ⟨equiv.refl X, trivial⟩, },
  { rintro X Y ⟨eXY, _⟩,
    exact ⟨eXY.symm, trivial⟩ },
  { rintro X Y Z ⟨eXY, _⟩ ⟨eYZ, _⟩,
    exact ⟨eXY.trans eYZ, trivial⟩ },
end

-- Remark: the equivalence classes of `R` are called *cardinals*.


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import data.nat.prime
import dynamics.fixed_points.basic
import data.pnat.basic
import data.set.lattice

/-!
# Periodic points

A point `x : α` is a periodic point of `f : α → α` of period `n` if `f^[n] x = x`.

## Main definitions

* `is_periodic_pt f n x` : `x` is a periodic point of `f` of period `n`, i.e. `f^[n] x = x`.
  We do not require `n > 0` in the definition.
* `pts_of_period f n` : the set `{x | is_periodic_pt f n x}`. Note that `n` is not required to
  be the minimal period of `x`.
* `periodic_pts f` : the set of all periodic points of `f`.
* `minimal_period f x` : the minimal period of a point `x` under an endomorphism `f` or zero
  if `x` is not a periodic point of `f`.

## Main statements

We provide “dot syntax”-style operations on terms of the form `h : is_periodic_pt f n x` including
arithmetic operations on `n` and `h.map (hg : semiconj_by g f f')`. We also prove that `f`
is bijective on each set `pts_of_period f n` and on `periodic_pts f`. Finally, we prove that `x`
is a periodic point of `f` of period `n` if and only if `minimal_period f x | n`.

## References

* https://en.wikipedia.org/wiki/Periodic_point

-/

open set

namespace function

variables {α : Type*} {β : Type*} {f fa : α → α} {fb : β → β} {x y : α} {m n : ℕ}

/-- A point `x` is a periodic point of `f : α → α` of period `n` if `f^[n] x = x`.
Note that we do not require `0 < n` in this definition. Many theorems about periodic points
need this assumption. -/
def is_periodic_pt (f : α → α) (n : ℕ) (x : α) := is_fixed_pt (f^[n]) x

/-- A fixed point of `f` is a periodic point of `f` of any prescribed period. -/
lemma is_fixed_pt.is_periodic_pt (hf : is_fixed_pt f x) (n : ℕ) : is_periodic_pt f n x :=
hf.iterate n

/-- For the identity map, all points are periodic. -/
lemma is_periodic_id (n : ℕ) (x : α) : is_periodic_pt id n x := (is_fixed_pt_id x).is_periodic_pt n

/-- Any point is a periodic point of period `0`. -/
lemma is_periodic_pt_zero (f : α → α) (x : α) : is_periodic_pt f 0 x := is_fixed_pt_id x

namespace is_periodic_pt

instance [decidable_eq α] {f : α → α} {n : ℕ} {x : α} : decidable (is_periodic_pt f n x) :=
is_fixed_pt.decidable

protected lemma is_fixed_pt (hf : is_periodic_pt f n x) : is_fixed_pt (f^[n]) x := hf

protected lemma map (hx : is_periodic_pt fa n x) {g : α → β} (hg : semiconj g fa fb) :
  is_periodic_pt fb n (g x) :=
hx.map (hg.iterate_right n)

lemma apply_iterate (hx : is_periodic_pt f n x) (m : ℕ) : is_periodic_pt f n (f^[m] x) :=
hx.map $ commute.iterate_self f m

protected lemma apply (hx : is_periodic_pt f n x) : is_periodic_pt f n (f x) :=
hx.apply_iterate 1

protected lemma add (hn : is_periodic_pt f n x) (hm : is_periodic_pt f m x) :
  is_periodic_pt f (n + m) x :=
by { rw [is_periodic_pt, iterate_add], exact hn.comp hm }

lemma left_of_add (hn : is_periodic_pt f (n + m) x) (hm : is_periodic_pt f m x) :
  is_periodic_pt f n x :=
by { rw [is_periodic_pt, iterate_add] at hn, exact hn.left_of_comp hm }

lemma right_of_add (hn : is_periodic_pt f (n + m) x) (hm : is_periodic_pt f n x) :
  is_periodic_pt f m x :=
by { rw add_comm at hn, exact hn.left_of_add hm }

protected lemma sub (hm : is_periodic_pt f m x) (hn : is_periodic_pt f n x) :
  is_periodic_pt f (m - n) x :=
begin
  cases le_total n m with h h,
  { refine left_of_add _ hn,
    rwa [tsub_add_cancel_of_le h] },
  { rw [tsub_eq_zero_iff_le.mpr h],
    apply is_periodic_pt_zero }
end

protected lemma mul_const (hm : is_periodic_pt f m x) (n : ℕ) : is_periodic_pt f (m * n) x :=
by simp only [is_periodic_pt, iterate_mul, hm.is_fixed_pt.iterate n]

protected lemma const_mul (hm : is_periodic_pt f m x) (n : ℕ) : is_periodic_pt f (n * m) x :=
by simp only [mul_comm n, hm.mul_const n]

lemma trans_dvd (hm : is_periodic_pt f m x) {n : ℕ} (hn : m ∣ n) : is_periodic_pt f n x :=
let ⟨k, hk⟩ := hn in hk.symm ▸ hm.mul_const k

protected lemma iterate (hf : is_periodic_pt f n x) (m : ℕ) : is_periodic_pt (f^[m]) n x :=
begin
  rw [is_periodic_pt, ← iterate_mul, mul_comm, iterate_mul],
  exact hf.is_fixed_pt.iterate m
end

lemma comp {g : α → α} (hco : commute f g) (hf : is_periodic_pt f n x) (hg : is_periodic_pt g n x) :
  is_periodic_pt (f ∘ g) n x :=
by { rw [is_periodic_pt, hco.comp_iterate], exact hf.comp hg }

lemma comp_lcm {g : α → α} (hco : commute f g) (hf : is_periodic_pt f m x)
  (hg : is_periodic_pt g n x) :
  is_periodic_pt (f ∘ g) (nat.lcm m n) x :=
(hf.trans_dvd $ nat.dvd_lcm_left _ _).comp hco (hg.trans_dvd $ nat.dvd_lcm_right _ _)

lemma left_of_comp {g : α → α} (hco : commute f g) (hfg : is_periodic_pt (f ∘ g) n x)
  (hg : is_periodic_pt g n x) : is_periodic_pt f n x :=
begin
  rw [is_periodic_pt, hco.comp_iterate] at hfg,
  exact hfg.left_of_comp hg
end

lemma iterate_mod_apply (h : is_periodic_pt f n x) (m : ℕ) :
  f^[m % n] x = (f^[m] x) :=
by conv_rhs { rw [← nat.mod_add_div m n, iterate_add_apply, (h.mul_const _).eq] }

protected lemma mod (hm : is_periodic_pt f m x) (hn : is_periodic_pt f n x) :
  is_periodic_pt f (m % n) x :=
(hn.iterate_mod_apply m).trans hm

protected lemma gcd (hm : is_periodic_pt f m x) (hn : is_periodic_pt f n x) :
  is_periodic_pt f (m.gcd n) x :=
begin
  revert hm hn,
  refine nat.gcd.induction m n (λ n h0 hn, _) (λ m n hm ih hm hn, _),
  { rwa [nat.gcd_zero_left], },
  { rw [nat.gcd_rec],
    exact ih (hn.mod hm) hm }
end

/-- If `f` sends two periodic points `x` and `y` of the same positive period to the same point,
then `x = y`. For a similar statement about points of different periods see `eq_of_apply_eq`. -/
lemma eq_of_apply_eq_same (hx : is_periodic_pt f n x) (hy : is_periodic_pt f n y) (hn : 0 < n)
  (h : f x = f y) :
  x = y :=
by rw [← hx.eq, ← hy.eq, ← iterate_pred_comp_of_pos f hn, comp_app, h]

/-- If `f` sends two periodic points `x` and `y` of positive periods to the same point,
then `x = y`. -/
lemma eq_of_apply_eq (hx : is_periodic_pt f m x) (hy : is_periodic_pt f n y) (hm : 0 < m)
  (hn : 0 < n) (h : f x = f y) :
  x = y :=
(hx.mul_const n).eq_of_apply_eq_same (hy.const_mul m) (mul_pos hm hn) h

end is_periodic_pt

/-- The set of periodic points of a given (possibly non-minimal) period. -/
def pts_of_period (f : α → α) (n : ℕ) : set α := {x : α | is_periodic_pt f n x}

@[simp] lemma mem_pts_of_period : x ∈ pts_of_period f n ↔ is_periodic_pt f n x :=
iff.rfl

lemma semiconj.maps_to_pts_of_period {g : α → β} (h : semiconj g fa fb) (n : ℕ) :
  maps_to g (pts_of_period fa n) (pts_of_period fb n) :=
(h.iterate_right n).maps_to_fixed_pts

lemma bij_on_pts_of_period (f : α → α) {n : ℕ} (hn : 0 < n) :
  bij_on f (pts_of_period f n) (pts_of_period f n) :=
⟨(commute.refl f).maps_to_pts_of_period n,
  λ x hx y hy hxy, hx.eq_of_apply_eq_same hy hn hxy,
  λ x hx, ⟨f^[n.pred] x, hx.apply_iterate _,
    by rw [← comp_app f, comp_iterate_pred_of_pos f hn, hx.eq]⟩⟩

lemma directed_pts_of_period_pnat (f : α → α) : directed (⊆) (λ n : ℕ+, pts_of_period f n) :=
λ m n, ⟨m * n, λ x hx, hx.mul_const n, λ x hx, hx.const_mul m⟩

/-- The set of periodic points of a map `f : α → α`. -/
def periodic_pts (f : α → α) : set α := {x : α | ∃ n > 0, is_periodic_pt f n x}

lemma mk_mem_periodic_pts (hn : 0 < n) (hx : is_periodic_pt f n x) :
  x ∈ periodic_pts f :=
⟨n, hn, hx⟩

lemma mem_periodic_pts : x ∈ periodic_pts f ↔ ∃ n > 0, is_periodic_pt f n x := iff.rfl

variable (f)

lemma bUnion_pts_of_period : (⋃ n > 0, pts_of_period f n) = periodic_pts f :=
set.ext $ λ x, by simp [mem_periodic_pts]

lemma Union_pnat_pts_of_period : (⋃ n : ℕ+, pts_of_period f n) = periodic_pts f :=
supr_subtype.trans $ bUnion_pts_of_period f

lemma bij_on_periodic_pts : bij_on f (periodic_pts f) (periodic_pts f) :=
Union_pnat_pts_of_period f ▸
  bij_on_Union_of_directed (directed_pts_of_period_pnat f) (λ i, bij_on_pts_of_period f i.pos)

variable {f}

lemma semiconj.maps_to_periodic_pts {g : α → β} (h : semiconj g fa fb) :
  maps_to g (periodic_pts fa) (periodic_pts fb) :=
λ x ⟨n, hn, hx⟩, ⟨n, hn, hx.map h⟩

open_locale classical

noncomputable theory

/-- Minimal period of a point `x` under an endomorphism `f`. If `x` is not a periodic point of `f`,
then `minimal_period f x = 0`. -/
def minimal_period (f : α → α) (x : α) :=
if h : x ∈ periodic_pts f then nat.find h else 0

lemma is_periodic_pt_minimal_period (f : α → α) (x : α) :
  is_periodic_pt f (minimal_period f x) x :=
begin
  delta minimal_period,
  split_ifs with hx,
  { exact (nat.find_spec hx).snd },
  { exact is_periodic_pt_zero f x }
end

lemma iterate_eq_mod_minimal_period : f^[n] x = (f^[n % minimal_period f x] x) :=
((is_periodic_pt_minimal_period f x).iterate_mod_apply n).symm

lemma minimal_period_pos_of_mem_periodic_pts (hx : x ∈ periodic_pts f) :
  0 < minimal_period f x :=
by simp only [minimal_period, dif_pos hx, (nat.find_spec hx).fst.lt]

lemma is_periodic_pt.minimal_period_pos (hn : 0 < n) (hx : is_periodic_pt f n x) :
  0 < minimal_period f x :=
minimal_period_pos_of_mem_periodic_pts $ mk_mem_periodic_pts hn hx

lemma minimal_period_pos_iff_mem_periodic_pts :
  0 < minimal_period f x ↔ x ∈ periodic_pts f :=
⟨not_imp_not.1 $ λ h,
  by simp only [minimal_period, dif_neg h, lt_irrefl 0, not_false_iff],
  minimal_period_pos_of_mem_periodic_pts⟩

lemma is_periodic_pt.minimal_period_le (hn : 0 < n) (hx : is_periodic_pt f n x) :
  minimal_period f x ≤ n :=
begin
  rw [minimal_period, dif_pos (mk_mem_periodic_pts hn hx)],
  exact nat.find_min' (mk_mem_periodic_pts hn hx) ⟨hn, hx⟩
end

lemma minimal_period_id : minimal_period id x = 1 :=
((is_periodic_id _ _ ).minimal_period_le nat.one_pos).antisymm
  (nat.succ_le_of_lt ((is_periodic_id _ _ ).minimal_period_pos nat.one_pos))

lemma is_fixed_point_iff_minimal_period_eq_one : minimal_period f x = 1 ↔ is_fixed_pt f x :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { rw ← iterate_one f,
    refine function.is_periodic_pt.is_fixed_pt _,
    rw ← h,
    exact is_periodic_pt_minimal_period f x },
  { exact ((h.is_periodic_pt 1).minimal_period_le nat.one_pos).antisymm
      (nat.succ_le_of_lt ((h.is_periodic_pt 1).minimal_period_pos nat.one_pos)) }
end

lemma is_periodic_pt.eq_zero_of_lt_minimal_period (hx : is_periodic_pt f n x)
  (hn : n < minimal_period f x) :
  n = 0 :=
eq.symm $ (eq_or_lt_of_le $ n.zero_le).resolve_right $ λ hn0,
not_lt.2 (hx.minimal_period_le hn0) hn

lemma not_is_periodic_pt_of_pos_of_lt_minimal_period :
  ∀ {n: ℕ} (n0 : n ≠ 0) (hn : n < minimal_period f x), ¬ is_periodic_pt f n x
| 0 n0 _ := (n0 rfl).elim
| (n + 1) _ hn := λ hp, nat.succ_ne_zero _ (hp.eq_zero_of_lt_minimal_period hn)

lemma is_periodic_pt.minimal_period_dvd (hx : is_periodic_pt f n x) :
  minimal_period f x ∣ n :=
(eq_or_lt_of_le $ n.zero_le).elim (λ hn0, hn0 ▸ dvd_zero _) $ λ hn0,
(nat.dvd_iff_mod_eq_zero _ _).2 $
(hx.mod $ is_periodic_pt_minimal_period f x).eq_zero_of_lt_minimal_period $
nat.mod_lt _ $ hx.minimal_period_pos hn0

lemma is_periodic_pt_iff_minimal_period_dvd :
  is_periodic_pt f n x ↔ minimal_period f x ∣ n :=
⟨is_periodic_pt.minimal_period_dvd, λ h, (is_periodic_pt_minimal_period f x).trans_dvd h⟩

open nat

lemma minimal_period_eq_minimal_period_iff {g : β → β} {y : β} :
  minimal_period f x = minimal_period g y ↔ ∀ n, is_periodic_pt f n x ↔ is_periodic_pt g n y :=
by simp_rw [is_periodic_pt_iff_minimal_period_dvd, dvd_right_iff_eq]

lemma minimal_period_eq_prime {p : ℕ} [hp : fact p.prime] (hper : is_periodic_pt f p x)
  (hfix : ¬ is_fixed_pt f x) : minimal_period f x = p :=
(hp.out.2 _ (hper.minimal_period_dvd)).resolve_left
  (mt is_fixed_point_iff_minimal_period_eq_one.1 hfix)

lemma minimal_period_eq_prime_pow {p k : ℕ} [hp : fact p.prime] (hk : ¬ is_periodic_pt f (p ^ k) x)
(hk1 : is_periodic_pt f (p ^ (k + 1)) x) : minimal_period f x = p ^ (k + 1) :=
begin
  apply nat.eq_prime_pow_of_dvd_least_prime_pow hp.out;
  rwa ← is_periodic_pt_iff_minimal_period_dvd
end

lemma commute.minimal_period_of_comp_dvd_lcm {g : α → α} (h : function.commute f g) :
  minimal_period (f ∘ g) x ∣ nat.lcm (minimal_period f x) (minimal_period g x) :=
begin
  rw [← is_periodic_pt_iff_minimal_period_dvd],
  exact (is_periodic_pt_minimal_period f x).comp_lcm h (is_periodic_pt_minimal_period g x)
end

lemma commute.minimal_period_of_comp_dvd_mul {g : α → α} (h : function.commute f g) :
  minimal_period (f ∘ g) x ∣ (minimal_period f x) * (minimal_period g x) :=
dvd_trans h.minimal_period_of_comp_dvd_lcm (lcm_dvd_mul _ _)

lemma commute.minimal_period_of_comp_eq_mul_of_coprime {g : α → α} (h : function.commute f g)
  (hco : coprime (minimal_period f x) (minimal_period g x)) :
  minimal_period (f ∘ g) x = (minimal_period f x) * (minimal_period g x) :=
begin
  apply dvd_antisymm (h.minimal_period_of_comp_dvd_mul),
  suffices : ∀ {f g : α → α}, commute f g → coprime (minimal_period f x) (minimal_period g x) →
    minimal_period f x ∣ minimal_period (f ∘ g) x,
    from hco.mul_dvd_of_dvd_of_dvd (this h hco) (h.comp_eq.symm ▸ this h.symm hco.symm),
  clear hco h f g,
  intros f g h hco,
  refine hco.dvd_of_dvd_mul_left (is_periodic_pt.left_of_comp h _ _).minimal_period_dvd,
  { exact (is_periodic_pt_minimal_period _ _).const_mul _ },
  { exact (is_periodic_pt_minimal_period _ _).mul_const _ }
end

private lemma minimal_period_iterate_eq_div_gcd_aux (h : 0 < gcd (minimal_period f x) n) :
  minimal_period (f ^[n]) x = minimal_period f x / nat.gcd (minimal_period f x) n :=
begin
  apply nat.dvd_antisymm,
  { apply is_periodic_pt.minimal_period_dvd,
    rw [is_periodic_pt, is_fixed_pt, ← iterate_mul, ← nat.mul_div_assoc _ (gcd_dvd_left _ _),
        mul_comm, nat.mul_div_assoc _ (gcd_dvd_right _ _), mul_comm, iterate_mul],
    exact (is_periodic_pt_minimal_period f x).iterate _ },
  { apply coprime.dvd_of_dvd_mul_right (coprime_div_gcd_div_gcd h),
    apply dvd_of_mul_dvd_mul_right h,
    rw [nat.div_mul_cancel (gcd_dvd_left _ _), mul_assoc, nat.div_mul_cancel (gcd_dvd_right _ _),
        mul_comm],
    apply is_periodic_pt.minimal_period_dvd,
    rw [is_periodic_pt, is_fixed_pt, iterate_mul],
    exact is_periodic_pt_minimal_period _ _ }
end

lemma minimal_period_iterate_eq_div_gcd (h : n ≠ 0) :
  minimal_period (f ^[n]) x = minimal_period f x / nat.gcd (minimal_period f x) n :=
minimal_period_iterate_eq_div_gcd_aux $ gcd_pos_of_pos_right _ (nat.pos_of_ne_zero h)

lemma minimal_period_iterate_eq_div_gcd' (h : x ∈ periodic_pts f) :
  minimal_period (f ^[n]) x = minimal_period f x / nat.gcd (minimal_period f x) n :=
minimal_period_iterate_eq_div_gcd_aux $
  gcd_pos_of_pos_left n (minimal_period_pos_iff_mem_periodic_pts.mpr h)

end function


--

def fib : Nat → Nat
| 0 | 1 => 1
| n+2 => fib n + fib (n+1)

example : fib 0 = 1 := rfl
example : fib 1 = 1 := rfl
example (n : Nat) : fib (n+2) = fib n + fib (n+1) := rfl


import data.real.basic

variables a b c : ℝ

#check mul_comm c
#check mul_assoc c b a

-- BEGIN
example (a b c : ℝ) : a * (b * c) = b * (c * a) :=
begin
  rw mul_comm a,
  sorry,
end

example (a b c : ℝ) : a * (b * c) = b * (a * c) :=
begin
  rw mul_comm,
  sorry,
end
-- END


/-
Copyright (c) 2020 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.calculus.local_extr
import Mathlib.topology.algebra.affine
import Mathlib.PostPort

universes u_2 u_1

namespace Mathlib

/-!
# Minima and maxima of convex functions

We show that if a function `f : E → β` is convex, then a local minimum is also
a global minimum, and likewise for concave functions.
-/

/--
Helper lemma for the more general case: `is_min_on.of_is_local_min_on_of_convex_on`.
-/
theorem is_min_on.of_is_local_min_on_of_convex_on_Icc {β : Type u_2}
    [linear_ordered_add_comm_group β] [semimodule ℝ β] [ordered_semimodule ℝ β] {f : ℝ → β} {a : ℝ}
    {b : ℝ} (a_lt_b : a < b) (h_local_min : is_local_min_on f (set.Icc a b) a)
    (h_conv : convex_on (set.Icc a b) f) (x : ℝ) (H : x ∈ set.Icc a b) : f a ≤ f x :=
  sorry

/--
A local minimum of a convex function is a global minimum, restricted to a set `s`.
-/
theorem is_min_on.of_is_local_min_on_of_convex_on {E : Type u_1} {β : Type u_2} [add_comm_group E]
    [topological_space E] [module ℝ E] [topological_add_group E] [topological_vector_space ℝ E]
    [linear_ordered_add_comm_group β] [semimodule ℝ β] [ordered_semimodule ℝ β] {s : set E}
    {f : E → β} {a : E} (a_in_s : a ∈ s) (h_localmin : is_local_min_on f s a)
    (h_conv : convex_on s f) (x : E) (H : x ∈ s) : f a ≤ f x :=
  sorry

/-- A local maximum of a concave function is a global maximum, restricted to a set `s`. -/
theorem is_max_on.of_is_local_max_on_of_concave_on {E : Type u_1} {β : Type u_2} [add_comm_group E]
    [topological_space E] [module ℝ E] [topological_add_group E] [topological_vector_space ℝ E]
    [linear_ordered_add_comm_group β] [semimodule ℝ β] [ordered_semimodule ℝ β] {s : set E}
    {f : E → β} {a : E} (a_in_s : a ∈ s) (h_localmax : is_local_max_on f s a)
    (h_conc : concave_on s f) (x : E) (H : x ∈ s) : f x ≤ f a :=
  is_min_on.of_is_local_min_on_of_convex_on a_in_s h_localmax h_conc

/-- A local minimum of a convex function is a global minimum. -/
theorem is_min_on.of_is_local_min_of_convex_univ {E : Type u_1} {β : Type u_2} [add_comm_group E]
    [topological_space E] [module ℝ E] [topological_add_group E] [topological_vector_space ℝ E]
    [linear_ordered_add_comm_group β] [semimodule ℝ β] [ordered_semimodule ℝ β] {f : E → β} {a : E}
    (h_local_min : is_local_min f a) (h_conv : convex_on set.univ f) (x : E) : f a ≤ f x :=
  is_min_on.of_is_local_min_on_of_convex_on (set.mem_univ a) (is_local_min.on h_local_min set.univ)
    h_conv x (set.mem_univ x)

/-- A local maximum of a concave function is a global maximum. -/
theorem is_max_on.of_is_local_max_of_convex_univ {E : Type u_1} {β : Type u_2} [add_comm_group E]
    [topological_space E] [module ℝ E] [topological_add_group E] [topological_vector_space ℝ E]
    [linear_ordered_add_comm_group β] [semimodule ℝ β] [ordered_semimodule ℝ β] {f : E → β} {a : E}
    (h_local_max : is_local_max f a) (h_conc : concave_on set.univ f) (x : E) : f x ≤ f a :=
  is_min_on.of_is_local_min_of_convex_univ h_local_max h_conc

end Mathlib


import analysis.normed.group.hom_completion

/-!

# A controlled exactness lemma for seminormed groups

This file contains a proof of Proposition 8.17 of `analytic.pdf`,
a technical lemma which controls, in some cases, the norm of the map
induced on completions by a normed group hom.

-/
noncomputable theory

open filter set function normed_group uniform_space normed_group_hom finset
open_locale topological_space big_operators

lemma controlled_exactness {M M₁ M₂ : Type*} [semi_normed_group M] [semi_normed_group M₁]
  [semi_normed_group M₂]
  {f : normed_group_hom M₁ M} {C : ℝ} (hC : 0 < C) {D : ℝ}
  {g : normed_group_hom M M₂}
  (h : f.surjective_on_with g.ker C)
  (h' : g.surjective_on_with g.range D) :
  ∀ ε > 0, f.completion.surjective_on_with g.completion.ker (C + ε) :=
begin
  intros ε ε_pos hatm hatm_in,
  by_cases H : hatm = 0,
  { use 0,
    simp only [H, le_refl, norm_zero, eq_self_iff_true, and_self, mul_zero,
      normed_group_hom.map_zero], },
  set hatf := f.completion,
  set i := incl g.ker,

  have norm_j_comp_i : ∀ x, ∥to_compl.comp i x∥ = ∥x∥,
  { intro x,
    erw [norm_to_compl, norm_incl] },

  have hatm_in : hatm ∈ closure ((to_compl.comp i).range : set $ completion M),
    by rwa ← normed_group_hom.ker_completion h',

  have : ∀ k : g.ker, ∃ m' : completion M₁, hatf m' = (to_compl.comp i) k ∧ ∥m'∥ ≤ C * ∥k∥,
  { rintros ⟨k, k_in⟩,
    rcases h k k_in with ⟨m₁, hm₁, hm₁'⟩,
    use m₁,
    erw [f.completion_coe, hm₁, norm_to_compl],
    exact ⟨rfl, hm₁'⟩ },
  exact controlled_closure_range_of_complete norm_j_comp_i hC ε_pos this _ hatm_in
end


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

! This file was ported from Lean 3 source module topology.sheaves.sheaf_condition.opens_le_cover
! leanprover-community/mathlib commit 85d6221d32c37e68f05b2e42cde6cee658dae5e9
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Sheaves.SheafCondition.Sites

/-!
# Another version of the sheaf condition.

Given a family of open sets `U : ι → opens X` we can form the subcategory
`{ V : opens X // ∃ i, V ≤ U i }`, which has `supr U` as a cocone.

The sheaf condition on a presheaf `F` is equivalent to
`F` sending the opposite of this cocone to a limit cone in `C`, for every `U`.

This condition is particularly nice when checking the sheaf condition
because we don't need to do any case bashing
(depending on whether we're looking at single or double intersections,
or equivalently whether we're looking at the first or second object in an equalizer diagram).

## Main statement

`Top.presheaf.is_sheaf_iff_is_sheaf_opens_le_cover`: for a presheaf on a topological space,
the sheaf condition in terms of Grothendieck topology is equivalent to the `opens_le_cover`
sheaf condition. This result will be used to further connect to other sheaf conditions on spaces,
like `pairwise_intersections` and `equalizer_products`.

## References
* This is the definition Lurie uses in [Spectral Algebraic Geometry][LurieSAG].
-/

universe w v u

noncomputable section

open CategoryTheory CategoryTheory.Limits TopologicalSpace TopologicalSpace.Opens Opposite

namespace TopCat

variable {C : Type u} [Category.{v} C]

variable {X : TopCat.{w}} (F : Presheaf C X) {ι : Type w} (U : ι → Opens X)

namespace Presheaf

namespace SheafCondition

/-- The category of open sets contained in some element of the cover.
-/
def OpensLeCover : Type w :=
  FullSubcategory fun V : Opens X => ∃ i, V ≤ U i deriving Category
#align Top.presheaf.sheaf_condition.opens_le_cover TopCat.Presheaf.SheafCondition.OpensLeCover

instance [Inhabited ι] : Inhabited (OpensLeCover U) :=
  ⟨⟨⊥, default, bot_le⟩⟩

namespace OpensLeCover

variable {U}

/-- An arbitrarily chosen index such that `V ≤ U i`.
-/
def index (V : OpensLeCover U) : ι :=
  V.property.some
#align Top.presheaf.sheaf_condition.opens_le_cover.index TopCat.Presheaf.SheafCondition.OpensLeCover.index

/-- The morphism from `V` to `U i` for some `i`.
-/
def homToIndex (V : OpensLeCover U) : V.obj ⟶ U (index V) :=
  V.property.choose_spec.Hom
#align Top.presheaf.sheaf_condition.opens_le_cover.hom_to_index TopCat.Presheaf.SheafCondition.OpensLeCover.homToIndex

end OpensLeCover

/-- `supr U` as a cocone over the opens sets contained in some element of the cover.

(In fact this is a colimit cocone.)
-/
def opensLeCoverCocone : Cocone (fullSubcategoryInclusion _ : OpensLeCover U ⥤ Opens X)
    where
  pt := supᵢ U
  ι := { app := fun V : OpensLeCover U => V.homToIndex ≫ Opens.leSupr U _ }
#align Top.presheaf.sheaf_condition.opens_le_cover_cocone TopCat.Presheaf.SheafCondition.opensLeCoverCocone

end SheafCondition

open SheafCondition

/-- An equivalent formulation of the sheaf condition
(which we prove equivalent to the usual one below as
`is_sheaf_iff_is_sheaf_opens_le_cover`).

A presheaf is a sheaf if `F` sends the cone `(opens_le_cover_cocone U).op` to a limit cone.
(Recall `opens_le_cover_cocone U`, has cone point `supr U`,
mapping down to any `V` which is contained in some `U i`.)
-/
def IsSheafOpensLeCover : Prop :=
  ∀ ⦃ι : Type w⦄ (U : ι → Opens X), Nonempty (IsLimit (F.mapCone (opensLeCoverCocone U).op))
#align Top.presheaf.is_sheaf_opens_le_cover TopCat.Presheaf.IsSheafOpensLeCover

section

variable {Y : Opens X} (hY : Y = supᵢ U)

/-- Given a family of opens `U` and an open `Y` equal to the union of opens in `U`, we may
    take the presieve on `Y` associated to `U` and the sieve generated by it, and form the
    full subcategory (subposet) of opens contained in `Y` (`over Y`) consisting of arrows
    in the sieve. This full subcategory is equivalent to `opens_le_cover U`, the (poset)
    category of opens contained in some `U i`. -/
@[simps]
def generateEquivalenceOpensLe :
    (FullSubcategory fun f : Over Y => (Sieve.generate (presieveOfCoveringAux U Y)).arrows f.Hom) ≌
      OpensLeCover U
    where
  Functor :=
    { obj := fun f =>
        ⟨f.1.left,
          let ⟨_, h, _, ⟨i, hY⟩, _⟩ := f.2
          ⟨i, hY ▸ h.le⟩⟩
      map := fun _ _ g => g.left }
  inverse :=
    { obj := fun V =>
        ⟨Over.mk
            (hY.substr
                (let ⟨i, h⟩ := V.2
                h.trans (le_supᵢ U i))).Hom,
          let ⟨i, h⟩ := V.2
          ⟨U i, h.Hom, (hY.substr (le_supᵢ U i)).Hom, ⟨i, rfl⟩, rfl⟩⟩
      map := fun _ _ g => Over.homMk g }
  unitIso :=
    eqToIso <|
      CategoryTheory.Functor.ext
        (by
          rintro ⟨⟨_, _⟩, _⟩
          dsimp
          congr <;> ext)
        (by
          intros
          ext)
  counitIso :=
    eqToIso <|
      CategoryTheory.Functor.hext
        (by
          intro
          ext
          rfl)
        (by
          intros
          rfl)
#align Top.presheaf.generate_equivalence_opens_le TopCat.Presheaf.generateEquivalenceOpensLe

/-- Given a family of opens `opens_le_cover_cocone U` is essentially the natural cocone
    associated to the sieve generated by the presieve associated to `U` with indexing
    category changed using the above equivalence. -/
@[simps]
def whiskerIsoMapGenerateCocone :
    (F.mapCone (opensLeCoverCocone U).op).whisker (generateEquivalenceOpensLe U hY).op.Functor ≅
      F.mapCone (Sieve.generate (presieveOfCoveringAux U Y)).arrows.Cocone.op
    where
  Hom :=
    { Hom := F.map (eqToHom (congr_arg op hY.symm))
      w' := fun j => by
        erw [← F.map_comp]
        congr }
  inv :=
    { Hom := F.map (eqToHom (congr_arg op hY))
      w' := fun j => by
        erw [← F.map_comp]
        congr }
  hom_inv_id' := by
    ext
    simp [eq_to_hom_map]
  inv_hom_id' := by
    ext
    simp [eq_to_hom_map]
#align Top.presheaf.whisker_iso_map_generate_cocone TopCat.Presheaf.whiskerIsoMapGenerateCocone

/-- Given a presheaf `F` on the topological space `X` and a family of opens `U` of `X`,
    the natural cone associated to `F` and `U` used in the definition of
    `F.is_sheaf_opens_le_cover` is a limit cone iff the natural cone associated to `F`
    and the sieve generated by the presieve associated to `U` is a limit cone. -/
def isLimitOpensLeEquivGenerate₁ :
    IsLimit (F.mapCone (opensLeCoverCocone U).op) ≃
      IsLimit (F.mapCone (Sieve.generate (presieveOfCoveringAux U Y)).arrows.Cocone.op) :=
  (IsLimit.whiskerEquivalenceEquiv (generateEquivalenceOpensLe U hY).op).trans
    (IsLimit.equivIsoLimit (whiskerIsoMapGenerateCocone F U hY))
#align Top.presheaf.is_limit_opens_le_equiv_generate₁ TopCat.Presheaf.isLimitOpensLeEquivGenerate₁

/-- Given a presheaf `F` on the topological space `X` and a presieve `R` whose generated sieve
    is covering for the associated Grothendieck topology (equivalently, the presieve is covering
    for the associated pretopology), the natural cone associated to `F` and the family of opens
    associated to `R` is a limit cone iff the natural cone associated to `F` and the generated
    sieve is a limit cone.
    Since only the existence of a 1-1 correspondence will be used, the exact definition does
    not matter, so tactics are used liberally. -/
def isLimitOpensLeEquivGenerate₂ (R : Presieve Y)
    (hR : Sieve.generate R ∈ Opens.grothendieckTopology X Y) :
    IsLimit (F.mapCone (opensLeCoverCocone (coveringOfPresieve Y R)).op) ≃
      IsLimit (F.mapCone (Sieve.generate R).arrows.Cocone.op) :=
  by
  convert is_limit_opens_le_equiv_generate₁ F (covering_of_presieve Y R)
        (covering_of_presieve.supr_eq_of_mem_grothendieck Y R hR).symm using
      2 <;>
    rw [covering_presieve_eq_self R]
#align Top.presheaf.is_limit_opens_le_equiv_generate₂ TopCat.Presheaf.isLimitOpensLeEquivGenerate₂

/-- A presheaf `(opens X)ᵒᵖ ⥤ C` on a topological space `X` is a sheaf on the site `opens X` iff
    it satisfies the `is_sheaf_opens_le_cover` sheaf condition. The latter is not the
    official definition of sheaves on spaces, but has the advantage that it does not
    require `has_products C`. -/
theorem isSheaf_iff_isSheafOpensLeCover : F.IsSheaf ↔ F.IsSheafOpensLeCover :=
  by
  refine' (presheaf.is_sheaf_iff_is_limit _ _).trans _
  constructor
  · intro h ι U
    rw [(is_limit_opens_le_equiv_generate₁ F U rfl).nonempty_congr]
    apply h
    apply presieve_of_covering.mem_grothendieck_topology
  · intro h Y S
    rw [← sieve.generate_sieve S]
    intro hS
    rw [← (is_limit_opens_le_equiv_generate₂ F S hS).nonempty_congr]
    apply h
#align Top.presheaf.is_sheaf_iff_is_sheaf_opens_le_cover TopCat.Presheaf.isSheaf_iff_isSheafOpensLeCover

end

end Presheaf

end TopCat


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner

! This file was ported from Lean 3 source module init.data.array.slice
! leanprover-community/mathlib commit 194cc8e2416b5969cfdab4006bb9e20cb75e5adc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Data.Nat.Default
import Leanbin.Init.Data.Array.Basic
import Leanbin.Init.Data.Nat.Lemmas

universe u

variable {α : Type u} {n : Nat}

namespace Array'

def slice (a : Array' n α) (k l : Nat) (h₁ : k ≤ l) (h₂ : l ≤ n) : Array' (l - k) α :=
  ⟨fun ⟨i, hi⟩ =>
    a.read
      ⟨i + k,
        calc
          i + k < l - k + k := Nat.add_lt_add_right hi _
          _ = l := (Nat.sub_add_cancel h₁)
          _ ≤ n := h₂
          ⟩⟩
#align array.slice Array'.slice

def take (a : Array' n α) (m : Nat) (h : m ≤ n) : Array' m α :=
  cast (by simp) <| a.slice 0 m (Nat.zero_le _) h
#align array.take Array'.take

def drop (a : Array' n α) (m : Nat) (h : m ≤ n) : Array' (n - m) α :=
  a.slice m n h (le_refl _)
#align array.drop Array'.drop

private theorem sub_sub_cancel (m n : ℕ) (h : m ≤ n) : n - (n - m) = m :=
  calc
    n - (n - m) = n - m + m - (n - m) := by rw [Nat.sub_add_cancel] <;> assumption
    _ = m := Nat.add_sub_cancel_left _ _

#align array.sub_sub_cancel array.sub_sub_cancel

def takeRight (a : Array' n α) (m : Nat) (h : m ≤ n) : Array' m α :=
  cast (by simp [*, sub_sub_cancel]) <| a.drop (n - m) (Nat.sub_le _ _)
#align array.take_right Array'.takeRight

def reverse (a : Array' n α) : Array' n α :=
  ⟨fun ⟨i, hi⟩ =>
    a.read ⟨n - (i + 1), by apply Nat.sub_lt_of_pos_le; apply Nat.zero_lt_succ; assumption⟩⟩
#align array.reverse Array'.reverse

end Array'


import definitions forall_keys tactic.linarith tactic.omega
set_option pp.generalized_field_notation false

universe u

namespace rotation_lemmas
open btree forall_keys_lemmas

variables {α : Type u}

/- # Auxiliary lemmas # -/
/-
  These auxiliary lemmas for rotations are used to show that the key relation of x to a tree doesn't change
  after a rotation if it previously exists.
  The auxiliary lemmas are done for both the simple and compound rotations.
-/

lemma forall_simple_left (x k : nat) (l r : btree α) (a : α) (p : nat → nat → Prop) :
  forall_keys p x (node l k a r) →
    forall_keys p x (simple_left (node l k a r)) :=
begin
  intro h₁,
  cases r,
  case empty {
    simp [simple_left],
    assumption,
  },
  case node : rl rk ra rr {
    simp [simple_left],
    rw forall_keys at *,
    intros k' h₂,
    simp [bound] at h₂,
    cases_matching* (_ ∨ _),
    repeat {
      apply h₁,
      simp [bound],
      tauto,
    },
  },
end

lemma forall_simple_right (x k : nat) (l r : btree α) (a : α) (p : nat → nat → Prop) :
  forall_keys p x (btree.node l k a r) →
    forall_keys p x (simple_right (node l k a r)) :=
begin
  intro h₁,
  cases l,
  case empty {
    simp [simple_right],
    assumption,
  },
  case node : ll lk la lr {
    simp [simple_right],
    rw forall_keys at *,
    intros k' h₂,
    simp [bound] at h₂,
    cases_matching* (_ ∨ _),
    repeat {
      apply h₁,
      simp [bound],
      tauto,
    },
  },
end

lemma forall_rotate_left (x k : nat) (l r : btree α) (a : α) (p : nat → nat → Prop) :
  forall_keys p x (node l k a r) →
    forall_keys p x (rotate_left (node l k a r)) :=
begin
  intro h₁,
  cases r,
  case empty {
    simp [rotate_left],
    exact h₁,
  },
  case node : rl rk ra rr {
    simp [rotate_left],
    by_cases c₁ : (height rr < height rl),
    { simp only [if_pos c₁],
      apply forall_simple_left,
      rw ← forall_keys_char,
      repeat { split },
      { unfold forall_keys at h₁ ⊢,
        intros k' h₂,
        apply h₁,
        simp [bound],
        apply or.inr (or.inl h₂),
      },
      { unfold forall_keys at h₁,
        apply h₁,
        simp [bound],
      },
      { apply forall_simple_right,
        unfold forall_keys at h₁ ⊢,
        intros k' h₂,
        apply h₁,
        simp [bound] at h₂ ⊢,
        tauto,
      },
    },
    { simp only [if_neg c₁],
      apply forall_simple_left,
      exact h₁,
    },
  },
end

lemma forall_rotate_right (x k : nat) (l r : btree α) (a : α) (p : nat → nat → Prop) :
  forall_keys p x (node l k a r) →
    forall_keys p x (rotate_right (node l k a r)) :=
begin
  intro h₁,
  cases l,
  case empty {
    simp [rotate_right],
    exact h₁,
  },
  case node : ll lk la lr {
    simp [rotate_right],
    by_cases c₁ : (height ll < height lr),
    { simp only [if_pos c₁],
      apply forall_simple_right,
      rw ← forall_keys_char,
      repeat { split },
      { apply forall_simple_left,
        unfold forall_keys at h₁ ⊢,
        intros k' h₂,
        apply h₁,
        simp [bound] at h₂ ⊢,
        tauto,
      },
      { unfold forall_keys at h₁,
        apply h₁,
        simp [bound],
      },
      { unfold forall_keys at h₁ ⊢,
        intros k' h₂,
        apply h₁,
        simp [bound],
        apply or.inr (or.inr h₂),
      },
    },
    { simp only [if_neg c₁],
      apply forall_simple_right,
      exact h₁,
    },
  },
end

/- # Rotations preserve order # -/

/- Simple left rotations preserve order -/
lemma simple_left_ordered (t : btree α) :
  ordered t → ordered (simple_left t) :=
begin
  intro h₁,
  cases t,
  case empty { simp [simple_left, ordered], },
  case node : tl tk ta tr {
    cases tr,
    case empty {
      simp [simple_left],
      exact h₁,
    },
    case node : trl trk tra trr {
      simp [simple_left],
      simp [ordered] at h₁ ⊢,
      cases_matching* (_ ∧ _),
      repeat { split }; try { assumption },
      { unfold forall_keys at h₁_right_right_right ⊢,
        intros k' h₂,
        apply h₁_right_right_right,
        simp [bound],
        apply or.inr (or.inl h₂),
      },
      { rw ← forall_keys_char,
        repeat { split },
        { apply forall_keys_trans _ (>) tk,
          { unfold forall_keys at h₁_right_right_right,
            apply h₁_right_right_right,
            simp [bound],
          },
          { apply trans, },
          { assumption, },
        },
        { unfold forall_keys at h₁_right_right_right,
          apply h₁_right_right_right,
          simp [bound],
        },
        { assumption, },
      },
    },
  },
end

/- Simple right rotations preserve order -/
lemma simple_right_ordered (t : btree α) :
  ordered t → ordered (simple_right t) :=
begin
  intro h₁,
  cases t,
  case empty {
    simp [simple_right, ordered],
  },
  case node : tl tk ta tr {
    cases tl,
    case empty {
      simp [simple_right],
      exact h₁,
    },
    case node : tll tlk tla tlr {
      simp [simple_right],
      simp [ordered] at h₁ ⊢,
      cases_matching* (_ ∧ _),
      repeat { split }; try { assumption },
      { unfold forall_keys at h₁_right_right_left ⊢,
        intros k' h₂,
        apply h₁_right_right_left,
        simp [bound],
        apply or.inr (or.inr h₂),
      },
      { rw ← forall_keys_char,
        repeat { split },
        { assumption, },
        { unfold forall_keys at h₁_right_right_left,
          apply h₁_right_right_left,
          simp [bound],
        },
        { apply forall_keys_trans _ (<) tk,
          { unfold forall_keys at h₁_right_right_left,
            apply h₁_right_right_left,
            simp [bound],
          },
          { apply trans, },
          { assumption, },
        },
      },
    },
  },
end

/- Left rotations preserve order -/
lemma rotate_left_ordered (t : btree α) :
  ordered t → ordered (rotate_left t) :=
begin
  intro h₁,
  cases t,
  case empty {
    simp [rotate_left, ordered],
  },
  case node : l k a r {
    cases r,
    case empty {
      simp [rotate_left],
      exact h₁,
    },
    case node : rl rk ra rr {
      simp only [rotate_left],
      by_cases c₁ : (height rr < height rl),
      { simp only [if_pos c₁],
        apply simple_left_ordered,
        cases rl,
        case empty {
          simp [simple_right],
          exact h₁,
        },
        case node : rll rlk rla rlr {
          simp only [simple_right],
          simp only [ordered] at h₁ ⊢,
          cases_matching* (_ ∧ _),
          repeat { split }; try { assumption },
          { unfold forall_keys at h₁_right_left_right_right_left ⊢,
            intros k' h₂,
            apply h₁_right_left_right_right_left,
            simp [bound],
            apply or.inr (or.inr h₂),
          },
          { rw ← forall_keys_char,
            repeat { split },
            { assumption, },
            { unfold forall_keys at h₁_right_left_right_right_left,
              apply h₁_right_left_right_right_left,
              simp [bound],
            },
            { apply forall_keys_trans _ (<) rk,
              { unfold forall_keys at h₁_right_left_right_right_left,
                apply h₁_right_left_right_right_left,
                simp [bound],
              },
              { apply trans, },
              { assumption, },
            },
          },
          { unfold forall_keys at h₁_right_right_right ⊢,
            intros k' h₂,
            apply h₁_right_right_right,
            simp [bound] at h₂ ⊢,
            tauto,
          },
        }
      },
      { simp only [if_neg c₁],
        apply simple_left_ordered,
        exact h₁,
      },
    },
  },
end

/- Right rotations preserve order -/
lemma rotate_right_ordered (t : btree α) :
  ordered t → ordered (rotate_right t) :=
begin
  intro h₁,
  cases t,
  case empty {
    simp [rotate_right, ordered],
  },
  case node : l k a r {
    cases l,
    case empty {
      simp [rotate_right],
      exact h₁,
    },
    case node : ll lk la lr {
      simp [rotate_right],
      by_cases c₁ : (height ll < height lr),
      { simp only [if_pos c₁],
        apply simple_right_ordered,
        cases lr,
        case empty {
          simp only [simple_left],
          exact h₁,
        },
        case node : lrl lrk lra lrr {
          simp only [simple_left],
          simp only [ordered] at h₁ ⊢,
          cases_matching* (_ ∧ _),
          repeat { split }; try { assumption },
          { unfold forall_keys at h₁_left_right_right_right ⊢,
            intros k' h₂,
            apply h₁_left_right_right_right,
            simp [bound],
            apply or.inr (or.inl h₂),
          },
          { rw ← forall_keys_char,
            repeat { split },
            { apply forall_keys_trans _ (>) lk,
              { unfold forall_keys at h₁_left_right_right_right,
                apply h₁_left_right_right_right,
                simp [bound],
              },
              { apply trans, },
              { assumption, },
            },
            { unfold forall_keys at h₁_left_right_right_right,
              apply h₁_left_right_right_right,
              simp [bound],
            },
            { assumption, },
          },
          { unfold forall_keys at h₁_right_right_left ⊢,
            intros k' h₂,
            apply h₁_right_right_left,
            simp [bound] at h₂ ⊢,
            tauto,
          },
        },
      },
      { simp only [if_neg c₁],
        apply simple_right_ordered,
        exact h₁,
      },
    },
  },
end

/- # Key Preservation # -/

/- Simple left rotations preserve pre-existing keys -/
lemma simple_left_keys (t : btree α) (k : nat) (x : bool) :
  bound k t = x ↔ bound k (simple_left t) = x :=
begin
  cases t,
  case empty {
    split; simp [simple_left],
  },
  case node : tl tk ta tr {
    cases tr,
    case empty {
      split; simp [simple_left],
    },
    case node : trl trk tra trr {
      simp [simple_left, bound],
      split; { intro h₁, finish, },
    },
  },
end

-- /- Simple right rotations preserve pre-existing keys -/
lemma simple_right_keys (t : btree α) (k : nat) (x : bool) :
  bound k t = x ↔ bound k (simple_right t) = x :=
begin
  cases t,
  case empty {
    split; simp [simple_right],
  },
  case node : tl tk ta tr {
    cases tl,
    case empty {
      split; simp [simple_right],
    },
    case node : tll tlk tla tlr {
      simp [simple_right, bound],
      split; { intro h₁, finish, },
    },
  },
end

/- Right rotations preserve pre-existing keys -/
lemma rotate_right_keys (t : btree α) (k : nat) (x : bool) :
  bound k t = x ↔ bound k (rotate_right t) = x :=
begin
  cases t,
  case empty {
    split; simp [rotate_right],
  },
  case node : tl tk ta tr {
    cases tl,
    case empty {
      split; simp [rotate_right],
    },
    case node : tll tlk tla tlr {
      simp [rotate_right],
      by_cases c₁ : (height tll < height tlr),
      { simp only [if_pos c₁],
        split,
        { intro h₁,
          rw ← simple_right_keys,
          cases tlr,
          case empty { simp [simple_left], assumption, },
          case node : tlrl tlrk tlra tlrr {
            simp [simple_left],
            simp [bound] at h₁ ⊢,
            finish,
          },
        },
        { intro h₁,
          rw ← simple_right_keys at h₁,
          cases tlr,
          case empty { simp [simple_left] at h₁, assumption, },
          case node : tlrl tlrk tlra tlrr {
            simp [simple_left] at h₁,
            simp [bound] at h₁ ⊢,
            finish,
          },
        },
      },
      { simp only [if_neg c₁],
        split,
        { intro h₁,
          rw ← simple_right_keys,
          exact h₁,
        },
        { intro h₁,
          rw ← simple_right_keys at h₁,
          exact h₁,
        },
      },
    },
  },
end

/- Left rotations preserve pre-existing keys -/
lemma rotate_left_keys (t : btree α) (k : nat) (x : bool) :
  bound k t = x ↔ bound k (rotate_left t) = x :=
begin
  cases t,
  case empty {
    split; simp [rotate_left],
  },
  case node : tl tk ta tr {
    cases tr,
    case empty {
      split; simp [rotate_left],
    },
    case node : trl trk tra trr {
      simp [rotate_left],
      by_cases c₁ : (height trr < height trl),
      { simp only [if_pos c₁],
        split,
        { intro h₁,
          rw ← simple_left_keys,
          cases trl,
          case empty { simp [simple_right], exact h₁, },
          case node : trll trlk trla trlr {
            simp [simple_right],
            simp [bound] at h₁ ⊢,
            finish,
          },
        },
        { intro h₁,
          rw ← simple_left_keys at h₁,
          cases trl,
          case empty { simp [simple_right] at h₁, exact h₁, },
          case node : trll trlk trla trlr {
            simp [simple_right, bound] at h₁,
            simp [bound],
            finish,
          }
        },
      },
      { simp only [if_neg c₁],
        split,
        { intro h₁,
          rw ← simple_left_keys,
          exact h₁,
        },
        { intro h₁,
          rw ← simple_left_keys at h₁,
          exact h₁,
        },
      },
    },
  },
end

/- # Balance restoration # -/

/- If a tree is right-heavy, a simple left rotations restores balance -/
lemma simple_left_balanced (t : btree α) :
  right_heavy t → balanced (simple_left t) :=
begin
  intro h₁,
  cases t,
  case empty {
    simp [simple_left, balanced],
  },
  case node : tl tk ta tr {
    cases tr,
    case empty {
      simp [simple_left, balanced],
      simp [right_heavy] at h₁,
      contradiction,
    },
    case node : trl trk tra trr {
      simp [simple_left, balanced, height],
      simp [right_heavy] at h₁,
      cases_matching* (_ ∧ _),
      by_cases c₁ : (height trr ≤ 1 + max (height tl) (height trl)),
      { simp [if_pos c₁],
        rw ← h₁_right_right_right at *,
        suffices h : 1 + max (height tl) (height trl) ≤ 1 + (height tl + 1),
        { omega, },
        apply (add_le_add_iff_left 1).mpr,
        apply max_le,
        { simp, },
        { assumption, },
      },
      { simp [if_neg c₁],
        rw ← h₁_right_right_right at *,
        rw max_eq_left h₁_right_right_left,
        linarith,
      },
    },
  },
end

/-  If a tree is left-heavy, a simple right rotation preserves balance -/
lemma simple_right_balanced (t : btree α) :
  left_heavy t →
    balanced (simple_right t) :=
begin
  intro h₁,
  cases t,
  case empty {
    simp [simple_right, balanced],
  },
  case node : tl tk ta tr {
    cases tl,
    case empty {
      simp [simple_right, balanced],
      simp [left_heavy] at h₁,
      contradiction,
    },
    case node : tll tlk tla tlr {
      simp [simple_right, balanced, height],
      simp [left_heavy] at h₁,
      cases_matching* (_ ∧ _),
      by_cases c₁ : (1 + max (height tlr) (height tr) ≤ height tll),
      { simp [if_pos c₁],
        rw max_eq_left h₁_right_right_left,
        linarith,
      },
      { simp [if_neg c₁],
        rw ← h₁_right_right_right at *,
        suffices h : 1 + max (height tlr) (height tr) ≤ 1 + (height tr + 1),
        { omega, },
        apply (add_le_add_iff_left 1).mpr,
        apply max_le,
        { assumption, },
        { simp, },
      },
    },
  },
end

/- If a tree is left-heavy, a right rotation restores balance -/
lemma rotate_right_balanced (t : btree α) :
  left_heavy t → balanced (rotate_right t) :=
begin
  intro h₁,
  cases t,
  case empty {
    simp [rotate_right, balanced],
  },
  case node : l k a r {
    cases l,
    case empty {
      simp [rotate_right, balanced],
      simp [left_heavy] at h₁,
      contradiction,
    },
    case node : tl tk ta tr {
      simp [rotate_right],
      by_cases c₁ : (height tl < height tr),
      { simp [if_pos c₁],
        apply simple_right_balanced,
        simp [left_heavy] at h₁,
        cases tr,
        case empty {
          simp [simple_left, left_heavy],
          assumption,
        },
        case node : trl trk tra trr {
          simp [simple_left, left_heavy],
          cases_matching* (_ ∧ _),
          linarith,
        }
      },
      { simp [if_neg c₁],
        apply simple_right_balanced,
        assumption,
      },
    },
  },
end

/- If a tree is right-heavy, a left rotation restores balance -/
lemma rotate_left_balanced (t : btree α) :
  right_heavy t → balanced (rotate_left t) :=
begin
  intro h₁,
  cases t,
  case empty {
    simp [rotate_left, balanced],
  },
  case node : l k a r {
    cases r,
    case empty {
      simp [rotate_left, balanced],
      simp [right_heavy] at h₁,
      contradiction,
    },
    case node : tl tk ta tr {
      simp [rotate_left],
      by_cases c₁ : (height tr < height tl),
      { simp [if_pos c₁],
        apply simple_left_balanced,
        simp [right_heavy] at h₁,
        cases tl,
        case empty {
          simp [simple_right, right_heavy],
          assumption,
        },
        case node : tll tlk tla tlr {
          simp [simple_right, right_heavy],
          cases_matching* (_ ∧ _),
          linarith,
        }
      },
      { simp [if_neg c₁],
        apply simple_left_balanced,
        exact h₁,
      },
    },
  },
end

end rotation_lemmas


/-
Copyright (c) 2020 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Riccardo Brasca
-/
import data.polynomial.algebra_map
import data.polynomial.monic

/-!
# Polynomials that lift

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

Given semirings `R` and `S` with a morphism `f : R →+* S`, we define a subsemiring `lifts` of
`S[X]` by the image of `ring_hom.of (map f)`.
Then, we prove that a polynomial that lifts can always be lifted to a polynomial of the same degree
and that a monic polynomial that lifts can be lifted to a monic polynomial (of the same degree).

## Main definition

* `lifts (f : R →+* S)` : the subsemiring of polynomials that lift.

## Main results

* `lifts_and_degree_eq` : A polynomial lifts if and only if it can be lifted to a polynomial
of the same degree.
* `lifts_and_degree_eq_and_monic` : A monic polynomial lifts if and only if it can be lifted to a
monic polynomial of the same degree.
* `lifts_iff_alg` : if `R` is commutative, a polynomial lifts if and only if it is in the image of
`map_alg`, where `map_alg : R[X] →ₐ[R] S[X]` is the only `R`-algebra map
that sends `X` to `X`.

## Implementation details

In general `R` and `S` are semiring, so `lifts` is a semiring. In the case of rings, see
`lifts_iff_lifts_ring`.

Since we do not assume `R` to be commutative, we cannot say in general that the set of polynomials
that lift is a subalgebra. (By `lift_iff` this is true if `R` is commutative.)

-/

open_locale classical big_operators polynomial
noncomputable theory

namespace polynomial
universes u v w

section semiring

variables {R : Type u} [semiring R] {S : Type v} [semiring S] {f : R →+* S}

/-- We define the subsemiring of polynomials that lifts as the image of `ring_hom.of (map f)`. -/
def lifts (f : R →+* S) : subsemiring S[X] := ring_hom.srange (map_ring_hom f)

lemma mem_lifts (p : S[X]) : p ∈ lifts f ↔ ∃ (q : R[X]), map f q = p :=
by simp only [coe_map_ring_hom, lifts, ring_hom.mem_srange]

lemma lifts_iff_ring_hom_srange (p : S[X]) : p ∈ lifts f ↔ p ∈ (map_ring_hom f).srange :=
by simp only [coe_map_ring_hom, lifts, set.mem_range, ring_hom.mem_srange]

lemma lifts_iff_coeff_lifts (p : S[X]) : p ∈ lifts f ↔ ∀ (n : ℕ), p.coeff n ∈ set.range f :=
by { rw [lifts_iff_ring_hom_srange, mem_map_srange f], refl }

/--If `(r : R)`, then `C (f r)` lifts. -/
lemma C_mem_lifts (f : R →+* S) (r : R) : (C (f r)) ∈ lifts f :=
⟨C r, by simp only [coe_map_ring_hom, map_C, set.mem_univ, subsemiring.coe_top, eq_self_iff_true,
  and_self]⟩

/-- If `(s : S)` is in the image of `f`, then `C s` lifts. -/
lemma C'_mem_lifts {f : R →+* S} {s : S} (h : s ∈ set.range f) : (C s) ∈ lifts f :=
begin
  obtain ⟨r, rfl⟩ := set.mem_range.1 h,
  use C r,
  simp only [coe_map_ring_hom, map_C, set.mem_univ, subsemiring.coe_top, eq_self_iff_true,
    and_self]
end

/-- The polynomial `X` lifts. -/
lemma X_mem_lifts (f : R →+* S) : (X : S[X]) ∈ lifts f :=
⟨X, by simp only [coe_map_ring_hom, set.mem_univ, subsemiring.coe_top, eq_self_iff_true, map_X,
  and_self]⟩

/-- The polynomial `X ^ n` lifts. -/
lemma X_pow_mem_lifts (f : R →+* S) (n : ℕ) : (X ^ n : S[X]) ∈ lifts f :=
⟨X ^ n, by simp only [coe_map_ring_hom, map_pow, set.mem_univ, subsemiring.coe_top,
  eq_self_iff_true, map_X, and_self]⟩

/-- If `p` lifts and `(r : R)` then `r * p` lifts. -/
lemma base_mul_mem_lifts {p : S[X]} (r : R) (hp : p ∈ lifts f) : C (f r) * p ∈ lifts f :=
begin
  simp only [lifts, ring_hom.mem_srange] at hp ⊢,
  obtain ⟨p₁, rfl⟩ := hp,
  use C r * p₁,
  simp only [coe_map_ring_hom, map_C, map_mul]
end

/-- If `(s : S)` is in the image of `f`, then `monomial n s` lifts. -/
lemma monomial_mem_lifts {s : S} (n : ℕ) (h : s ∈ set.range f) : (monomial n s) ∈ lifts f :=
begin
  obtain ⟨r, rfl⟩ := set.mem_range.1 h,
  use monomial n r,
  simp only [coe_map_ring_hom, set.mem_univ, map_monomial, subsemiring.coe_top, eq_self_iff_true,
    and_self],
end

/-- If `p` lifts then `p.erase n` lifts. -/
lemma erase_mem_lifts {p : S[X]} (n : ℕ) (h : p ∈ lifts f) : p.erase n ∈ lifts f :=
begin
  rw [lifts_iff_ring_hom_srange, mem_map_srange] at h ⊢,
  intros k,
  by_cases hk : k = n,
  { use 0,
    simp only [hk, ring_hom.map_zero, erase_same] },
  obtain ⟨i, hi⟩ := h k,
  use i,
  simp only [hi, hk, erase_ne, ne.def, not_false_iff],
end

section lift_deg

lemma monomial_mem_lifts_and_degree_eq {s : S} {n : ℕ} (hl : monomial n s ∈ lifts f) :
  ∃ (q : R[X]), map f q = (monomial n s) ∧ q.degree = (monomial n s).degree :=
begin
  by_cases hzero : s = 0,
  { use 0,
    simp only [hzero, degree_zero, eq_self_iff_true, and_self, monomial_zero_right,
               polynomial.map_zero] },
  rw lifts_iff_set_range at hl,
  obtain ⟨q, hq⟩ := hl,
  replace hq := (ext_iff.1 hq) n,
  have hcoeff : f (q.coeff n) = s,
  { simp [coeff_monomial] at hq,
    exact hq },
  use (monomial n (q.coeff n)),
  split,
  { simp only [hcoeff, map_monomial] },
  have hqzero : q.coeff n ≠ 0,
  { intro habs,
    simp only [habs, ring_hom.map_zero] at hcoeff,
    exact hzero hcoeff.symm },
  repeat {rw ← C_mul_X_pow_eq_monomial},
  simp only [hzero, hqzero, ne.def, not_false_iff, degree_C_mul_X_pow],
end

/-- A polynomial lifts if and only if it can be lifted to a polynomial of the same degree. -/
lemma mem_lifts_and_degree_eq {p : S[X]} (hlifts : p ∈ lifts f) :
  ∃ (q : R[X]), map f q = p ∧ q.degree = p.degree :=
begin
  generalize' hd : p.nat_degree = d,
  revert hd p,
  apply nat.strong_induction_on d,
  intros n hn p hlifts hdeg,
  by_cases erase_zero : p.erase_lead = 0,
  { rw [← erase_lead_add_monomial_nat_degree_leading_coeff p, erase_zero, zero_add, leading_coeff],
    exact monomial_mem_lifts_and_degree_eq (monomial_mem_lifts p.nat_degree
    ((lifts_iff_coeff_lifts p).1 hlifts p.nat_degree)) },
  have deg_erase := or.resolve_right (erase_lead_nat_degree_lt_or_erase_lead_eq_zero p) erase_zero,
  have pzero : p ≠ 0,
  { intro habs,
    exfalso,
    rw [habs, erase_lead_zero, eq_self_iff_true, not_true] at erase_zero,
    exact erase_zero },
  have lead_zero : p.coeff p.nat_degree ≠ 0,
  { rw [← leading_coeff, ne.def, leading_coeff_eq_zero]; exact pzero },
  obtain ⟨lead, hlead⟩ := monomial_mem_lifts_and_degree_eq (monomial_mem_lifts p.nat_degree
    ((lifts_iff_coeff_lifts p).1 hlifts p.nat_degree)),
  have deg_lead : lead.degree = p.nat_degree,
  { rw [hlead.2, ← C_mul_X_pow_eq_monomial, degree_C_mul_X_pow p.nat_degree lead_zero] },
  rw hdeg at deg_erase,
  obtain ⟨erase, herase⟩ := hn p.erase_lead.nat_degree deg_erase
    (erase_mem_lifts p.nat_degree hlifts) (refl p.erase_lead.nat_degree),
  use erase + lead,
  split,
  { simp only [hlead, herase, polynomial.map_add],
    nth_rewrite 0 erase_lead_add_monomial_nat_degree_leading_coeff p },
  rw [←hdeg, erase_lead] at deg_erase,
  replace deg_erase := lt_of_le_of_lt degree_le_nat_degree (with_bot.coe_lt_coe.2 deg_erase),
  rw [← deg_lead, ← herase.2] at deg_erase,
  rw [degree_add_eq_right_of_degree_lt deg_erase, deg_lead, degree_eq_nat_degree pzero]
end

end lift_deg

section monic

/-- A monic polynomial lifts if and only if it can be lifted to a monic polynomial
of the same degree. -/
lemma lifts_and_degree_eq_and_monic [nontrivial S] {p : S[X]} (hlifts : p ∈ lifts f)
  (hp : p.monic) : ∃ (q : R[X]), map f q = p ∧ q.degree = p.degree ∧ q.monic :=
begin
  casesI subsingleton_or_nontrivial R with hR hR,
  { obtain ⟨q, hq⟩ := mem_lifts_and_degree_eq hlifts,
    exact ⟨q, hq.1, hq.2, monic_of_subsingleton _⟩ },
  have H : erase p.nat_degree p + X ^ p.nat_degree = p,
  { simpa only [hp.leading_coeff, C_1, one_mul, erase_lead] using erase_lead_add_C_mul_X_pow p },
  by_cases h0 : erase p.nat_degree p = 0,
  { rw [← H, h0, zero_add],
    refine ⟨X ^ p.nat_degree, _, _, monic_X_pow p.nat_degree⟩,
    { rw [polynomial.map_pow, map_X] },
    { rw [degree_X_pow, degree_X_pow] } },
  obtain ⟨q, hq⟩ := mem_lifts_and_degree_eq (erase_mem_lifts p.nat_degree hlifts),
  have hdeg : q.degree < (X ^ p.nat_degree).degree,
  { rw [@degree_X_pow R, hq.2, degree_eq_nat_degree h0, with_bot.coe_lt_coe],
    exact or.resolve_right (erase_lead_nat_degree_lt_or_erase_lead_eq_zero p) h0, },
  refine ⟨q + X ^ p.nat_degree, _, _, (monic_X_pow _).add_of_right hdeg⟩,
  { rw [polynomial.map_add, hq.1, polynomial.map_pow, map_X, H], },
  { rw [degree_add_eq_right_of_degree_lt hdeg, degree_X_pow, degree_eq_nat_degree hp.ne_zero] }
end

lemma lifts_and_nat_degree_eq_and_monic {p : S[X]} (hlifts : p ∈ lifts f)
  (hp : p.monic) : ∃ (q : R[X]), map f q = p ∧ q.nat_degree = p.nat_degree ∧ q.monic :=
begin
  casesI subsingleton_or_nontrivial S with hR hR,
  { obtain (rfl : p = 1) := subsingleton.elim _ _,
    refine ⟨1, subsingleton.elim _ _, by simp, by simp⟩ },
  obtain ⟨p', h₁, h₂, h₃⟩ := lifts_and_degree_eq_and_monic hlifts hp,
  exact ⟨p', h₁, nat_degree_eq_of_degree_eq h₂, h₃⟩
end

end monic

end semiring

section ring

variables {R : Type u} [ring R] {S : Type v} [ring S] (f : R →+* S)

/-- The subring of polynomials that lift. -/
def lifts_ring (f : R →+* S) : subring S[X] := ring_hom.range (map_ring_hom f)

/-- If `R` and `S` are rings, `p` is in the subring of polynomials that lift if and only if it is in
the subsemiring of polynomials that lift. -/
lemma lifts_iff_lifts_ring (p : S[X]) : p ∈ lifts f ↔ p ∈ lifts_ring f :=
by simp only [lifts, lifts_ring, ring_hom.mem_range, ring_hom.mem_srange]

end ring

section algebra

variables {R : Type u} [comm_semiring R] {S : Type v} [semiring S] [algebra R S]

/-- The map `R[X] → S[X]` as an algebra homomorphism. -/
def map_alg (R : Type u) [comm_semiring R] (S : Type v) [semiring S] [algebra R S] :
  R[X] →ₐ[R] S[X] := @aeval _ S[X] _ _ _ (X : S[X])

/-- `map_alg` is the morphism induced by `R → S`. -/
lemma map_alg_eq_map (p : R[X]) : map_alg R S p = map (algebra_map R S) p :=
by simp only [map_alg, aeval_def, eval₂, map, algebra_map_apply, ring_hom.coe_comp]

/-- A polynomial `p` lifts if and only if it is in the image of `map_alg`. -/
lemma mem_lifts_iff_mem_alg (R : Type u) [comm_semiring R] {S : Type v} [semiring S] [algebra R S]
  (p : S[X]) :p ∈ lifts (algebra_map R S) ↔ p ∈ (alg_hom.range (@map_alg R _ S _ _)) :=
by simp only [coe_map_ring_hom, lifts, map_alg_eq_map, alg_hom.mem_range,
  ring_hom.mem_srange]

/-- If `p` lifts and `(r : R)` then `r • p` lifts. -/
lemma smul_mem_lifts {p : S[X]} (r : R) (hp : p ∈ lifts (algebra_map R S)) :
  r • p ∈ lifts (algebra_map R S) :=
by { rw mem_lifts_iff_mem_alg at hp ⊢, exact subalgebra.smul_mem (map_alg R S).range hp r }

end algebra

end polynomial


import Qpf
open MvQPF

/-!
  Let us start with a simple example of an inductive type: lists
  ```lean4
  inductive QpfList (α : Type u)
   | nil : QpfList α
   | cons : α →  QpfList α → QpfList α
  ```

  Since each argument to each constructor is purely a variable, or purely the resulting type `QpfList α`,
  we can translate this type to a fixpoint of some polynomial functor, which we'll call `QpfList.Shape`.

  Since we'll be taking a fixpoint, `QpfList.Shape` is indeed a binary functor, where the first argument
  will be passed on as `α`, and the second argument will be representing `QpfList α`.
  We can think of it like the following (non-recursive!) inductive type
  ```lean4
  inductive QpfList.Shape' (α β : Type u)
    | nil  : Shape' α β
    | cons : α → β → Shape' α β
  ```

  Of course, we won't actually define the type as such, instead, recall that polynomial functors are
  encoded by a "head" type, which may not depend on `α`, and a "child" type, that does depend on `α`.

-/
namespace QpfList
  /-
    The aforementioned "head" type is a simple enumeration of all constructors
  -/
  inductive HeadT
    | nil
    | cons

  /-
    The "child" type tells us for each constructor (i.e., element of `HeadT`) and each type argument,
    how many instances of that type we need, through the cardinality of `ChildT a i`.

    In this case, the `nil` constructor takes no argument, while `cons` takes one instance of both
    arguments, hence we use the empty and unit types, respectively.
  -/
  abbrev ChildT : HeadT → TypeVec 2
    | HeadT.nil , _ => Empty
    | HeadT.cons, _ => Unit

  /-
    We define the polynomial functor
  -/
  abbrev P := MvPFunctor.mk HeadT ChildT

  /- The `MvFunctor` instance is defined on `P` action on objects-/
  abbrev F := P.Obj

  /-
    Of course, each polynomial functor is a (multivariate) quotient of a polynomial functor, and
    this is automatically inferred
  -/
  example : MvQPF F :=
    by infer_instance

  /-
    We define `QpfList'` as the fixpoint of `P` in the last argument
  -/
  abbrev QpfList' : TypeFun 1
    := Fix QpfList.F

  /-
    And define a curried version for final use
  -/
  abbrev QpfList
    := QpfList'.curried

  example : MvQPF QpfList' :=
    by infer_instance

/-
  # Constructors
  We manually define the constructors in terms of `Fix.mk`
-/

  def nil {α : Type} : QpfList α :=
    Fix.mk ⟨HeadT.nil, fun _ emp => by contradiction⟩

  def cons {α} (hd : α) (tl : QpfList α) : QpfList α :=
    Fix.mk ⟨HeadT.cons, fun i _ => match i with
                          | 0 => tl
                          | 1 => hd
    ⟩

  -- The list `[1, 2, 3]`
  example : QpfList Nat :=
    cons 1 $ cons 2 $ cons 3 $ nil

  /-
    Pattern matching does not work like one would expect, but we'll ignore it for now

  def mul2 : QpfList Nat → QpfList Nat
    | nil        => nil
    | cons hd tl => cons (2*hd) (mul2 tl)
  -/

  -- def rec {α}
  --         {motive : QpfList α → Sort _}
  --         : (motive nil)
  --         → ((hd : α) → (tl : QpfList α) → motive (cons hd tl))
  --         → (t : QpfList α)
  --         → motive t :=
  -- fun base_case rec_case t => by
  --   let t' := Fix.dest t;
  --   simp [MvPFunctor.Obj] at t'
  --   rcases t' with ⟨a, f⟩
  --   cases a <;> simp [MvPFunctor.B] at f

    -- let g := fun ⟨a, f⟩ => match a with
    --   | HeadT.nil  => cast (
    --                     by  delta nil;
    --                         apply congrArg; apply congrArg;
    --                         simp [MvFunctor.map];
    --                         conv in (fun x emp => _) => {
    --                           tactic => funext x y; contradiction;
    --                         }
    --                   ) base_case
    --   | HeadT.cons => by simp [MvPFunctor.B, HeadT, ChildT] at f
    --                      skip
    --                      sorry
                      -- cast (
                      --   _
                      -- ) (rec_case (f (Fin2.fz) (by simp [P.B])) _)
    -- Fix.drec (β := motive) g t

end QpfList

export QpfList (QpfList QpfList')