/-
Copyright (c) 2018 Rohan Mitta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rohan Mitta, Kevin Buzzard, Alistair Tucker, Johannes Hölzl, Yury Kudryashov
-/
import logic.function.iterate
import data.set.intervals.proj_Icc
import topology.metric_space.basic
import category_theory.endomorphism
import category_theory.types

/-!
# Lipschitz continuous functions

A map `f : α → β` between two (extended) metric spaces is called *Lipschitz continuous*
with constant `K ≥ 0` if for all `x, y` we have `edist (f x) (f y) ≤ K * edist x y`.
For a metric space, the latter inequality is equivalent to `dist (f x) (f y) ≤ K * dist x y`.
There is also a version asserting this inequality only for `x` and `y` in some set `s`.

In this file we provide various ways to prove that various combinations of Lipschitz continuous
functions are Lipschitz continuous. We also prove that Lipschitz continuous functions are
uniformly continuous.

## Main definitions and lemmas

* `lipschitz_with K f`: states that `f` is Lipschitz with constant `K : ℝ≥0`
* `lipschitz_on_with K f`: states that `f` is Lipschitz with constant `K : ℝ≥0` on a set `s`
* `lipschitz_with.uniform_continuous`: a Lipschitz function is uniformly continuous
* `lipschitz_on_with.uniform_continuous_on`: a function which is Lipschitz on a set is uniformly
  continuous on that set.

## Implementation notes

The parameter `K` has type `ℝ≥0`. This way we avoid conjuction in the definition and have
coercions both to `ℝ` and `ℝ≥0∞`. Constructors whose names end with `'` take `K : ℝ` as an
argument, and return `lipschitz_with (real.to_nnreal K) f`.
-/

universes u v w x

open filter function set
open_locale topological_space nnreal ennreal

variables {α : Type u} {β : Type v} {γ : Type w} {ι : Type x}

/-- A function `f` is Lipschitz continuous with constant `K ≥ 0` if for all `x, y`
we have `dist (f x) (f y) ≤ K * dist x y` -/
def lipschitz_with [pseudo_emetric_space α] [pseudo_emetric_space β] (K : ℝ≥0) (f : α → β) :=
∀x y, edist (f x) (f y) ≤ K * edist x y

lemma lipschitz_with_iff_dist_le_mul [pseudo_metric_space α] [pseudo_metric_space β] {K : ℝ≥0}
  {f : α → β} : lipschitz_with K f ↔ ∀ x y, dist (f x) (f y) ≤ K * dist x y :=
by { simp only [lipschitz_with, edist_nndist, dist_nndist], norm_cast }

alias lipschitz_with_iff_dist_le_mul ↔ lipschitz_with.dist_le_mul lipschitz_with.of_dist_le_mul

/-- A function `f` is Lipschitz continuous with constant `K ≥ 0` on `s` if for all `x, y` in `s`
we have `dist (f x) (f y) ≤ K * dist x y` -/
def lipschitz_on_with [pseudo_emetric_space α] [pseudo_emetric_space β] (K : ℝ≥0) (f : α → β)
  (s : set α) :=
∀ ⦃x⦄ (hx : x ∈ s) ⦃y⦄ (hy : y ∈ s), edist (f x) (f y) ≤ K * edist x y

@[simp] lemma lipschitz_on_with_empty [pseudo_emetric_space α] [pseudo_emetric_space β] (K : ℝ≥0)
  (f : α → β) : lipschitz_on_with K f ∅ :=
λ x x_in y y_in, false.elim x_in

lemma lipschitz_on_with.mono [pseudo_emetric_space α] [pseudo_emetric_space β] {K : ℝ≥0}
  {s t : set α} {f : α → β} (hf : lipschitz_on_with K f t) (h : s ⊆ t) : lipschitz_on_with K f s :=
λ x x_in y y_in, hf (h x_in) (h y_in)

lemma lipschitz_on_with_iff_dist_le_mul [pseudo_metric_space α] [pseudo_metric_space β] {K : ℝ≥0}
  {s : set α} {f : α → β} :
  lipschitz_on_with K f s ↔ ∀ (x ∈ s) (y ∈ s), dist (f x) (f y) ≤ K * dist x y :=
by { simp only [lipschitz_on_with, edist_nndist, dist_nndist], norm_cast }

alias lipschitz_on_with_iff_dist_le_mul ↔
  lipschitz_on_with.dist_le_mul lipschitz_on_with.of_dist_le_mul

@[simp] lemma lipschitz_on_univ [pseudo_emetric_space α] [pseudo_emetric_space β] {K : ℝ≥0}
  {f : α → β} : lipschitz_on_with K f univ ↔ lipschitz_with K f :=
by simp [lipschitz_on_with, lipschitz_with]

lemma lipschitz_on_with_iff_restrict [pseudo_emetric_space α] [pseudo_emetric_space β] {K : ℝ≥0}
  {f : α → β} {s : set α} : lipschitz_on_with K f s ↔ lipschitz_with K (s.restrict f) :=
by simp only [lipschitz_on_with, lipschitz_with, set_coe.forall', restrict, subtype.edist_eq]

namespace lipschitz_with

section emetric

variables [pseudo_emetric_space α] [pseudo_emetric_space β] [pseudo_emetric_space γ]
variables {K : ℝ≥0} {f : α → β}

protected lemma lipschitz_on_with (h : lipschitz_with K f) (s : set α) : lipschitz_on_with K f s :=
λ x _ y _, h x y

lemma edist_le_mul (h : lipschitz_with K f) (x y : α) : edist (f x) (f y) ≤ K * edist x y := h x y

lemma edist_lt_top (hf : lipschitz_with K f) {x y : α} (h : edist x y ≠ ⊤) :
  edist (f x) (f y) < ⊤ :=
lt_of_le_of_lt (hf x y) $ ennreal.mul_lt_top ennreal.coe_ne_top h

lemma mul_edist_le (h : lipschitz_with K f) (x y : α) :
  (K⁻¹ : ℝ≥0∞) * edist (f x) (f y) ≤ edist x y :=
begin
  rw [mul_comm, ← div_eq_mul_inv],
  exact ennreal.div_le_of_le_mul' (h x y)
end

protected lemma of_edist_le (h : ∀ x y, edist (f x) (f y) ≤ edist x y) :
  lipschitz_with 1 f :=
λ x y, by simp only [ennreal.coe_one, one_mul, h]

protected lemma weaken (hf : lipschitz_with K f) {K' : ℝ≥0} (h : K ≤ K') :
  lipschitz_with K' f :=
assume x y, le_trans (hf x y) $ ennreal.mul_right_mono (ennreal.coe_le_coe.2 h)

lemma ediam_image_le (hf : lipschitz_with K f) (s : set α) :
  emetric.diam (f '' s) ≤ K * emetric.diam s :=
begin
  apply emetric.diam_le,
  rintros _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩,
  calc edist (f x) (f y) ≤ ↑K * edist x y : hf.edist_le_mul x y
                     ... ≤ ↑K * emetric.diam s :
    ennreal.mul_left_mono (emetric.edist_le_diam_of_mem hx hy)
end

lemma edist_lt_of_edist_lt_div (hf : lipschitz_with K f) {x y : α} {d : ℝ≥0∞}
  (h : edist x y < d / K) : edist (f x) (f y) < d :=
calc edist (f x) (f y) ≤ K * edist x y : hf x y
... < d : ennreal.mul_lt_of_lt_div' h

/-- A Lipschitz function is uniformly continuous -/
protected lemma uniform_continuous (hf : lipschitz_with K f) :
  uniform_continuous f :=
begin
  refine emetric.uniform_continuous_iff.2 (λε εpos, _),
  use [ε / K, ennreal.div_pos_iff.2 ⟨ne_of_gt εpos, ennreal.coe_ne_top⟩],
  exact λ x y, hf.edist_lt_of_edist_lt_div
end

/-- A Lipschitz function is continuous -/
protected lemma continuous (hf : lipschitz_with K f) :
  continuous f :=
hf.uniform_continuous.continuous

protected lemma const (b : β) : lipschitz_with 0 (λa:α, b) :=
assume x y, by simp only [edist_self, zero_le]

protected lemma id : lipschitz_with 1 (@id α) :=
lipschitz_with.of_edist_le $ assume x y, le_refl _

protected lemma subtype_val (s : set α) : lipschitz_with 1 (subtype.val : s → α) :=
lipschitz_with.of_edist_le $ assume x y, le_refl _

protected lemma subtype_coe (s : set α) : lipschitz_with 1 (coe : s → α) :=
lipschitz_with.subtype_val s

lemma subtype_mk (hf : lipschitz_with K f) {p : β → Prop} (hp : ∀ x, p (f x)) :
  lipschitz_with K (λ x, ⟨f x, hp x⟩ : α → {y // p y}) :=
hf

protected lemma eval {α : ι → Type u} [Π i, pseudo_emetric_space (α i)] [fintype ι] (i : ι) :
  lipschitz_with 1 (function.eval i : (Π i, α i) → α i) :=
lipschitz_with.of_edist_le $ λ f g, by convert edist_le_pi_edist f g i

protected lemma restrict (hf : lipschitz_with K f) (s : set α) :
  lipschitz_with K (s.restrict f) :=
λ x y, hf x y

protected lemma comp {Kf Kg : ℝ≥0} {f : β → γ} {g : α → β}
  (hf : lipschitz_with Kf f) (hg : lipschitz_with Kg g) : lipschitz_with (Kf * Kg) (f ∘ g) :=
assume x y,
calc edist (f (g x)) (f (g y)) ≤ Kf * edist (g x) (g y) : hf _ _
... ≤ Kf * (Kg * edist x y) : ennreal.mul_left_mono (hg _ _)
... = (Kf * Kg : ℝ≥0) * edist x y : by rw [← mul_assoc, ennreal.coe_mul]

protected lemma prod_fst : lipschitz_with 1 (@prod.fst α β) :=
lipschitz_with.of_edist_le $ assume x y, le_max_left _ _

protected lemma prod_snd : lipschitz_with 1 (@prod.snd α β) :=
lipschitz_with.of_edist_le $ assume x y, le_max_right _ _

protected lemma prod {f : α → β} {Kf : ℝ≥0} (hf : lipschitz_with Kf f)
  {g : α → γ} {Kg : ℝ≥0} (hg : lipschitz_with Kg g) :
  lipschitz_with (max Kf Kg) (λ x, (f x, g x)) :=
begin
  assume x y,
  rw [ennreal.coe_mono.map_max, prod.edist_eq, ennreal.max_mul],
  exact max_le_max (hf x y) (hg x y)
end

protected lemma uncurry {f : α → β → γ} {Kα Kβ : ℝ≥0} (hα : ∀ b, lipschitz_with Kα (λ a, f a b))
  (hβ : ∀ a, lipschitz_with Kβ (f a)) :
  lipschitz_with (Kα + Kβ) (function.uncurry f) :=
begin
  rintros ⟨a₁, b₁⟩ ⟨a₂, b₂⟩,
  simp only [function.uncurry, ennreal.coe_add, add_mul],
  apply le_trans (edist_triangle _ (f a₂ b₁) _),
  exact add_le_add (le_trans (hα _ _ _) $ ennreal.mul_left_mono $ le_max_left _ _)
    (le_trans (hβ _ _ _) $ ennreal.mul_left_mono $ le_max_right _ _)
end

protected lemma iterate {f : α → α} (hf : lipschitz_with K f) :
  ∀n, lipschitz_with (K ^ n) (f^[n])
| 0       := lipschitz_with.id
| (n + 1) := by rw [pow_succ']; exact (iterate n).comp hf

lemma edist_iterate_succ_le_geometric {f : α → α} (hf : lipschitz_with K f) (x n) :
  edist (f^[n] x) (f^[n + 1] x) ≤ edist x (f x) * K ^ n :=
begin
  rw [iterate_succ, mul_comm],
  simpa only [ennreal.coe_pow] using (hf.iterate n) x (f x)
end

open category_theory

protected lemma mul {f g : End α} {Kf Kg} (hf : lipschitz_with Kf f) (hg : lipschitz_with Kg g) :
  lipschitz_with (Kf * Kg) (f * g : End α) :=
hf.comp hg

/-- The product of a list of Lipschitz continuous endomorphisms is a Lipschitz continuous
endomorphism. -/
protected lemma list_prod (f : ι → End α) (K : ι → ℝ≥0) (h : ∀ i, lipschitz_with (K i) (f i)) :
  ∀ l : list ι, lipschitz_with (l.map K).prod (l.map f).prod
| [] := by simp [types_id, lipschitz_with.id]
| (i :: l) := by { simp only [list.map_cons, list.prod_cons], exact (h i).mul (list_prod l) }

protected lemma pow {f : End α} {K} (h : lipschitz_with K f) :
  ∀ n : ℕ, lipschitz_with (K^n) (f^n : End α)
| 0       := lipschitz_with.id
| (n + 1) := by { rw [pow_succ, pow_succ], exact h.mul (pow n) }

end emetric

section metric

variables [pseudo_metric_space α] [pseudo_metric_space β] [pseudo_metric_space γ] {K : ℝ≥0}

protected lemma of_dist_le' {f : α → β} {K : ℝ} (h : ∀ x y, dist (f x) (f y) ≤ K * dist x y) :
  lipschitz_with (real.to_nnreal K) f :=
of_dist_le_mul $ λ x y, le_trans (h x y) $
  mul_le_mul_of_nonneg_right (real.le_coe_to_nnreal K) dist_nonneg

protected lemma mk_one {f : α → β} (h : ∀ x y, dist (f x) (f y) ≤ dist x y) :
  lipschitz_with 1 f :=
of_dist_le_mul $ by simpa only [nnreal.coe_one, one_mul] using h

/-- For functions to `ℝ`, it suffices to prove `f x ≤ f y + K * dist x y`; this version
doesn't assume `0≤K`. -/
protected lemma of_le_add_mul' {f : α → ℝ} (K : ℝ) (h : ∀x y, f x ≤ f y + K * dist x y) :
  lipschitz_with (real.to_nnreal K) f :=
have I : ∀ x y, f x - f y ≤ K * dist x y,
  from assume x y, sub_le_iff_le_add'.2 (h x y),
lipschitz_with.of_dist_le' $
assume x y,
abs_sub_le_iff.2 ⟨I x y, dist_comm y x ▸ I y x⟩

/-- For functions to `ℝ`, it suffices to prove `f x ≤ f y + K * dist x y`; this version
assumes `0≤K`. -/
protected lemma of_le_add_mul {f : α → ℝ} (K : ℝ≥0) (h : ∀x y, f x ≤ f y + K * dist x y) :
  lipschitz_with K f :=
by simpa only [real.to_nnreal_coe] using lipschitz_with.of_le_add_mul' K h

protected lemma of_le_add {f : α → ℝ} (h : ∀ x y, f x ≤ f y + dist x y) :
  lipschitz_with 1 f :=
lipschitz_with.of_le_add_mul 1 $ by simpa only [nnreal.coe_one, one_mul]

protected lemma le_add_mul {f : α → ℝ} {K : ℝ≥0} (h : lipschitz_with K f) (x y) :
  f x ≤ f y + K * dist x y :=
sub_le_iff_le_add'.1 $ le_trans (le_abs_self _) $ h.dist_le_mul x y

protected lemma iff_le_add_mul {f : α → ℝ} {K : ℝ≥0} :
  lipschitz_with K f ↔ ∀ x y, f x ≤ f y + K * dist x y :=
⟨lipschitz_with.le_add_mul, lipschitz_with.of_le_add_mul K⟩

lemma nndist_le {f : α → β} (hf : lipschitz_with K f) (x y : α) :
  nndist (f x) (f y) ≤ K * nndist x y :=
hf.dist_le_mul x y

lemma diam_image_le {f : α → β} (hf : lipschitz_with K f) (s : set α) (hs : metric.bounded s) :
  metric.diam (f '' s) ≤ K * metric.diam s :=
begin
  apply metric.diam_le_of_forall_dist_le (mul_nonneg K.coe_nonneg metric.diam_nonneg),
  rintros _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩,
  calc dist (f x) (f y) ≤ ↑K * dist x y      : hf.dist_le_mul x y
                    ... ≤ ↑K * metric.diam s :
    mul_le_mul_of_nonneg_left (metric.dist_le_diam_of_mem hs hx hy) K.2
end

protected lemma dist_left (y : α) : lipschitz_with 1 (λ x, dist x y) :=
lipschitz_with.of_le_add $ assume x z, by { rw [add_comm], apply dist_triangle }

protected lemma dist_right (x : α) : lipschitz_with 1 (dist x) :=
lipschitz_with.of_le_add $ assume y z, dist_triangle_right _ _ _

protected lemma dist : lipschitz_with 2 (function.uncurry $ @dist α _) :=
lipschitz_with.uncurry lipschitz_with.dist_left lipschitz_with.dist_right

lemma dist_iterate_succ_le_geometric {f : α → α} (hf : lipschitz_with K f) (x n) :
  dist (f^[n] x) (f^[n + 1] x) ≤ dist x (f x) * K ^ n :=
begin
  rw [iterate_succ, mul_comm],
  simpa only [nnreal.coe_pow] using (hf.iterate n).dist_le_mul x (f x)
end

lemma _root_.lipschitz_with_max : lipschitz_with 1 (λ p : ℝ × ℝ, max p.1 p.2) :=
lipschitz_with.of_le_add $ λ p₁ p₂, sub_le_iff_le_add'.1 $
  (le_abs_self _).trans (abs_max_sub_max_le_max _ _ _ _)

lemma _root_.lipschitz_with_min : lipschitz_with 1 (λ p : ℝ × ℝ, min p.1 p.2) :=
lipschitz_with.of_le_add $ λ p₁ p₂, sub_le_iff_le_add'.1 $
  (le_abs_self _).trans (abs_min_sub_min_le_max _ _ _ _)

end metric

section emetric

variables {α} [pseudo_emetric_space α] {f g : α → ℝ} {Kf Kg : ℝ≥0}

protected lemma max (hf : lipschitz_with Kf f) (hg : lipschitz_with Kg g) :
  lipschitz_with (max Kf Kg) (λ x, max (f x) (g x)) :=
by simpa only [(∘), one_mul] using lipschitz_with_max.comp (hf.prod hg)

protected lemma min (hf : lipschitz_with Kf f) (hg : lipschitz_with Kg g) :
  lipschitz_with (max Kf Kg) (λ x, min (f x) (g x)) :=
by simpa only [(∘), one_mul] using lipschitz_with_min.comp (hf.prod hg)

lemma max_const (hf : lipschitz_with Kf f) (a : ℝ) : lipschitz_with Kf (λ x, max (f x) a) :=
by simpa only [max_eq_left (zero_le Kf)] using hf.max (lipschitz_with.const a)

lemma const_max (hf : lipschitz_with Kf f) (a : ℝ) : lipschitz_with Kf (λ x, max a (f x)) :=
by simpa only [max_comm] using hf.max_const a

lemma min_const (hf : lipschitz_with Kf f) (a : ℝ) : lipschitz_with Kf (λ x, min (f x) a) :=
by simpa only [max_eq_left (zero_le Kf)] using hf.min (lipschitz_with.const a)

lemma const_min (hf : lipschitz_with Kf f) (a : ℝ) : lipschitz_with Kf (λ x, min a (f x)) :=
by simpa only [min_comm] using hf.min_const a

end emetric

protected lemma proj_Icc {a b : ℝ} (h : a ≤ b) :
  lipschitz_with 1 (proj_Icc a b h) :=
((lipschitz_with.id.const_min _).const_max _).subtype_mk _

end lipschitz_with

namespace lipschitz_on_with

variables [pseudo_emetric_space α] [pseudo_emetric_space β] [pseudo_emetric_space γ]
variables {K : ℝ≥0} {s : set α} {f : α → β}

protected lemma uniform_continuous_on (hf : lipschitz_on_with K f s) : uniform_continuous_on f s :=
uniform_continuous_on_iff_restrict.mpr (lipschitz_on_with_iff_restrict.mp hf).uniform_continuous

protected lemma continuous_on (hf : lipschitz_on_with K f s) : continuous_on f s :=
hf.uniform_continuous_on.continuous_on

lemma edist_lt_of_edist_lt_div (hf : lipschitz_on_with K f s) {x y : α} (hx : x ∈ s) (hy : y ∈ s)
  {d : ℝ≥0∞} (hd : edist x y < d / K) : edist (f x) (f y) < d :=
(lipschitz_on_with_iff_restrict.mp hf).edist_lt_of_edist_lt_div $
  show edist (⟨x, hx⟩ : s) ⟨y, hy⟩ < d / K, from hd

end lipschitz_on_with

/-- Consider a function `f : α × β → γ`. Suppose that it is continuous on each “vertical fiber”
`{a} × t`, `a ∈ s`, and is Lipschitz continuous on each “horizontal fiber” `s × {b}`, `b ∈ t`
with the same Lipschitz constant `K`. Then it is continuous on `s × t`.

The actual statement uses (Lipschitz) continuity of `λ y, f (a, y)` and `λ x, f (x, b)` instead
of continuity of `f` on subsets of the product space. -/
lemma continuous_on_prod_of_continuous_on_lipschitz_on [pseudo_emetric_space α]
  [topological_space β] [pseudo_emetric_space γ] (f : α × β → γ) {s : set α} {t : set β}
  (K : ℝ≥0) (ha : ∀ a ∈ s, continuous_on (λ y, f (a, y)) t)
  (hb : ∀ b ∈ t, lipschitz_on_with K (λ x, f (x, b)) s) :
  continuous_on f (s.prod t) :=
begin
  rintro ⟨x, y⟩ ⟨hx : x ∈ s, hy : y ∈ t⟩,
  refine emetric.tendsto_nhds.2 (λ ε (ε0 : 0 < ε), _),
  replace ε0 : 0 < ε / 2 := ennreal.half_pos (ne_of_gt ε0),
  have εK : 0 < ε / 2 / K := ennreal.div_pos_iff.2 ⟨ε0.ne', ennreal.coe_ne_top⟩,
  have A : s ∩ emetric.ball x (ε / 2 / K) ∈ 𝓝[s] x :=
    inter_mem_nhds_within _ (emetric.ball_mem_nhds _ εK),
  have B : {b : β | b ∈ t ∧ edist (f (x, b)) (f (x, y)) < ε / 2} ∈ 𝓝[t] y :=
    inter_mem self_mem_nhds_within (ha x hx y hy (emetric.ball_mem_nhds _ ε0)),
  filter_upwards [nhds_within_prod A B],
  rintro ⟨a, b⟩ ⟨⟨has : a ∈ s, hax : edist a x < ε / 2 / K⟩,
    hbt : b ∈ t, hby : edist (f (x, b)) (f (x, y)) < ε / 2⟩,
  calc edist (f (a, b)) (f (x, y)) ≤ edist (f (a, b)) (f (x, b)) + edist (f (x, b)) (f (x, y)) :
    edist_triangle _ _ _
  ... < ε / 2 + ε / 2 : ennreal.add_lt_add ((hb _ hbt).edist_lt_of_edist_lt_div has hx hax) hby
  ... = ε : ennreal.add_halves ε
end

/-- Consider a function `f : α × β → γ`. Suppose that it is continuous on each “vertical section”
`{a} × univ`, `a : α`, and is Lipschitz continuous on each “horizontal section”
`univ × {b}`, `b : β` with the same Lipschitz constant `K`. Then it is continuous.

The actual statement uses (Lipschitz) continuity of `λ y, f (a, y)` and `λ x, f (x, b)` instead
of continuity of `f` on subsets of the product space. -/
lemma continuous_prod_of_continuous_lipschitz [pseudo_emetric_space α]
  [topological_space β] [pseudo_emetric_space γ] (f : α × β → γ) (K : ℝ≥0)
  (ha : ∀ a, continuous (λ y, f (a, y))) (hb : ∀ b, lipschitz_with K (λ x, f (x, b))) :
  continuous f :=
begin
  simp only [continuous_iff_continuous_on_univ, ← univ_prod_univ, ← lipschitz_on_univ] at *,
  exact continuous_on_prod_of_continuous_on_lipschitz_on f K (λ a _, ha a) (λ b _, hb b)
end

open metric

/-- If a function is locally Lipschitz around a point, then it is continuous at this point. -/
lemma continuous_at_of_locally_lipschitz [metric_space α] [metric_space β] {f : α → β} {x : α}
  {r : ℝ} (hr : 0 < r) (K : ℝ) (h : ∀y, dist y x < r → dist (f y) (f x) ≤ K * dist y x) :
  continuous_at f x :=
begin
  -- We use `h` to squeeze `dist (f y) (f x)` between `0` and `K * dist y x`
  refine tendsto_iff_dist_tendsto_zero.2
    (squeeze_zero' (eventually_of_forall $ λ _, dist_nonneg)
    (mem_of_superset (ball_mem_nhds _ hr) h) _),
  -- Then show that `K * dist y x` tends to zero as `y → x`
  refine (continuous_const.mul (continuous_id.dist continuous_const)).tendsto' _ _ _,
  simp
end


/-
Copyright (c) 2020 Kevin Kappelmann. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Kappelmann
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.continued_fractions.translations
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Stabilisation of gcf Computations Under Termination

## Summary

We show that the continuants and convergents of a gcf stabilise once the gcf terminates.
-/

namespace generalized_continued_fraction

/-- If a gcf terminated at position `n`, it also terminated at `m ≥ n`.-/
theorem terminated_stable {K : Type u_1} {g : generalized_continued_fraction K} {n : ℕ} {m : ℕ}
    (n_le_m : n ≤ m) (terminated_at_n : terminated_at g n) : terminated_at g m :=
  seq.terminated_stable (s g) n_le_m terminated_at_n

theorem continuants_aux_stable_step_of_terminated {K : Type u_1}
    {g : generalized_continued_fraction K} {n : ℕ} [division_ring K]
    (terminated_at_n : terminated_at g n) :
    continuants_aux g (n + bit0 1) = continuants_aux g (n + 1) :=
  sorry

theorem continuants_aux_stable_of_terminated {K : Type u_1} {g : generalized_continued_fraction K}
    {n : ℕ} {m : ℕ} [division_ring K] (succ_n_le_m : n + 1 ≤ m)
    (terminated_at_n : terminated_at g n) : continuants_aux g m = continuants_aux g (n + 1) :=
  sorry

theorem convergents'_aux_stable_step_of_terminated {K : Type u_1} {n : ℕ} [division_ring K]
    {s : seq (pair K)} (terminated_at_n : seq.terminated_at s n) :
    convergents'_aux s (n + 1) = convergents'_aux s n :=
  sorry

theorem convergents'_aux_stable_of_terminated {K : Type u_1} {n : ℕ} {m : ℕ} [division_ring K]
    {s : seq (pair K)} (n_le_m : n ≤ m) (terminated_at_n : seq.terminated_at s n) :
    convergents'_aux s m = convergents'_aux s n :=
  sorry

theorem continuants_stable_of_terminated {K : Type u_1} {g : generalized_continued_fraction K}
    {n : ℕ} {m : ℕ} [division_ring K] (n_le_m : n ≤ m) (terminated_at_n : terminated_at g n) :
    continuants g m = continuants g n :=
  sorry

theorem numerators_stable_of_terminated {K : Type u_1} {g : generalized_continued_fraction K}
    {n : ℕ} {m : ℕ} [division_ring K] (n_le_m : n ≤ m) (terminated_at_n : terminated_at g n) :
    numerators g m = numerators g n :=
  sorry

theorem denominators_stable_of_terminated {K : Type u_1} {g : generalized_continued_fraction K}
    {n : ℕ} {m : ℕ} [division_ring K] (n_le_m : n ≤ m) (terminated_at_n : terminated_at g n) :
    denominators g m = denominators g n :=
  sorry

theorem convergents_stable_of_terminated {K : Type u_1} {g : generalized_continued_fraction K}
    {n : ℕ} {m : ℕ} [division_ring K] (n_le_m : n ≤ m) (terminated_at_n : terminated_at g n) :
    convergents g m = convergents g n :=
  sorry

theorem convergents'_stable_of_terminated {K : Type u_1} {g : generalized_continued_fraction K}
    {n : ℕ} {m : ℕ} [division_ring K] (n_le_m : n ≤ m) (terminated_at_n : terminated_at g n) :
    convergents' g m = convergents' g n :=
  sorry

end Mathlib


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import group_theory.group_action.defs

/-! # Group actions on and by `Mˣ`

This file provides the action of a unit on a type `α`, `has_scalar Mˣ α`, in the presence of
`has_scalar M α`, with the obvious definition stated in `units.smul_def`. This definition preserves
`mul_action` and `distrib_mul_action` structures too.

Additionally, a `mul_action G M` for some group `G` satisfying some additional properties admits a
`mul_action G Mˣ` structure, again with the obvious definition stated in `units.coe_smul`.
These instances use a primed name.

The results are repeated for `add_units` and `has_vadd` where relevant.
-/

variables {G H M N : Type*} {α : Type*}

namespace units

/-! ### Action of the units of `M` on a type `α` -/

@[to_additive]
instance [monoid M] [has_scalar M α] : has_scalar Mˣ α :=
{ smul := λ m a, (m : M) • a }

@[to_additive]
lemma smul_def [monoid M] [has_scalar M α] (m : Mˣ) (a : α) :
  m • a = (m : M) • a := rfl

@[simp] lemma smul_is_unit [monoid M] [has_scalar M α] {m : M} (hm : is_unit m) (a : α) :
  hm.unit • a = m • a :=
rfl

lemma _root_.is_unit.inv_smul [monoid α] {a : α} (h : is_unit a) :
  (h.unit)⁻¹ • a = 1 :=
h.coe_inv_mul

@[to_additive]
instance [monoid M] [has_scalar M α] [has_faithful_smul M α] : has_faithful_smul Mˣ α :=
{ eq_of_smul_eq_smul := λ u₁ u₂ h, units.ext $ eq_of_smul_eq_smul h, }

@[to_additive]
instance [monoid M] [mul_action M α] : mul_action Mˣ α :=
{ one_smul := (one_smul M : _),
  mul_smul := λ m n, mul_smul (m : M) n, }

instance [monoid M] [add_monoid α] [distrib_mul_action M α] : distrib_mul_action Mˣ α :=
{ smul_add := λ m, smul_add (m : M),
  smul_zero := λ m, smul_zero m, }

instance [monoid M] [monoid α] [mul_distrib_mul_action M α] : mul_distrib_mul_action Mˣ α :=
{ smul_mul := λ m, smul_mul' (m : M),
  smul_one := λ m, smul_one m, }

instance smul_comm_class_left [monoid M] [has_scalar M α] [has_scalar N α]
  [smul_comm_class M N α] : smul_comm_class Mˣ N α :=
{ smul_comm := λ m n, (smul_comm (m : M) n : _)}

instance smul_comm_class_right [monoid N] [has_scalar M α] [has_scalar N α]
  [smul_comm_class M N α] : smul_comm_class M Nˣ α :=
{ smul_comm := λ m n, (smul_comm m (n : N) : _)}

instance [monoid M] [has_scalar M N] [has_scalar M α] [has_scalar N α] [is_scalar_tower M N α] :
  is_scalar_tower Mˣ N α :=
{ smul_assoc := λ m n, (smul_assoc (m : M) n : _)}

/-! ### Action of a group `G` on units of `M` -/

/-- If an action `G` associates and commutes with multiplication on `M`, then it lifts to an
action on `Mˣ`. Notably, this provides `mul_action Mˣ Nˣ` under suitable
conditions.
-/
instance mul_action' [group G] [monoid M] [mul_action G M] [smul_comm_class G M M]
  [is_scalar_tower G M M] : mul_action G Mˣ :=
{ smul := λ g m, ⟨g • (m : M), g⁻¹ • ↑(m⁻¹),
    by rw [smul_mul_smul, units.mul_inv, mul_right_inv, one_smul],
    by rw [smul_mul_smul, units.inv_mul, mul_left_inv, one_smul]⟩,
  one_smul := λ m, units.ext $ one_smul _ _,
  mul_smul := λ g₁ g₂ m, units.ext $ mul_smul _ _ _ }

@[simp] lemma coe_smul [group G] [monoid M] [mul_action G M] [smul_comm_class G M M]
  [is_scalar_tower G M M] (g : G) (m : Mˣ) : ↑(g • m) = g • (m : M) := rfl

/-- Note that this lemma exists more generally as the global `smul_inv` -/
@[simp] lemma smul_inv [group G] [monoid M] [mul_action G M] [smul_comm_class G M M]
  [is_scalar_tower G M M] (g : G) (m : Mˣ) : (g • m)⁻¹ = g⁻¹ • m⁻¹ := ext rfl

/-- Transfer `smul_comm_class G H M` to `smul_comm_class G H Mˣ` -/
instance smul_comm_class' [group G] [group H] [monoid M]
  [mul_action G M] [smul_comm_class G M M]
  [mul_action H M] [smul_comm_class H M M]
  [is_scalar_tower G M M] [is_scalar_tower H M M]
  [smul_comm_class G H M] : smul_comm_class G H Mˣ :=
{ smul_comm := λ g h m, units.ext $ smul_comm g h (m : M) }

/-- Transfer `is_scalar_tower G H M` to `is_scalar_tower G H Mˣ` -/
instance is_scalar_tower' [has_scalar G H] [group G] [group H] [monoid M]
  [mul_action G M] [smul_comm_class G M M]
  [mul_action H M] [smul_comm_class H M M]
  [is_scalar_tower G M M] [is_scalar_tower H M M]
  [is_scalar_tower G H M] : is_scalar_tower G H Mˣ :=
{ smul_assoc := λ g h m, units.ext $ smul_assoc g h (m : M) }

/-- Transfer `is_scalar_tower G M α` to `is_scalar_tower G Mˣ α` -/
instance is_scalar_tower'_left [group G] [monoid M] [mul_action G M] [has_scalar M α]
  [has_scalar G α] [smul_comm_class G M M] [is_scalar_tower G M M]
  [is_scalar_tower G M α] :
  is_scalar_tower G Mˣ α :=
{ smul_assoc := λ g m, (smul_assoc g (m : M) : _)}

-- Just to prove this transfers a particularly useful instance.
example [monoid M] [monoid N] [mul_action M N] [smul_comm_class M N N]
  [is_scalar_tower M N N] : mul_action Mˣ Nˣ := units.mul_action'

/-- A stronger form of `units.mul_action'`. -/
instance mul_distrib_mul_action' [group G] [monoid M] [mul_distrib_mul_action G M]
  [smul_comm_class G M M] [is_scalar_tower G M M] : mul_distrib_mul_action G Mˣ :=
{ smul := (•),
  smul_one := λ m, units.ext $ smul_one _,
  smul_mul := λ g m₁ m₂, units.ext $ smul_mul' _ _ _,
  .. units.mul_action' }

end units

lemma is_unit.smul [group G] [monoid M] [mul_action G M]
  [smul_comm_class G M M] [is_scalar_tower G M M] {m : M} (g : G) (h : is_unit m) :
  is_unit (g • m) :=
let ⟨u, hu⟩ := h in hu ▸ ⟨g • u, units.coe_smul _ _⟩


import analysis.topology.topological_space
import data.set
import data.fin
import tactic.find
import tactic.ring
import algebra.group

import homeos
import invariant_norms
import bigop

noncomputable theory
local attribute [instance] classical.prop_decidable

set_option pp.coercions false

open set function equiv list

def fix {X} (f : X → X) := { x : X | f x = x }

lemma fix_stable {X} (f : X → X) : f '' fix f = fix f :=
begin
  apply subset.antisymm,
  { intros x H,
    rcases H with ⟨y, y_in_fix, f_y_x⟩,
    simp [fix] at y_in_fix,
    rw y_in_fix at f_y_x,
    finish },
  { intros x H,
    existsi x,
    finish }
end

variables {X : Type} [topological_space X] (f : X → X)

def supp := closure (-fix f)

lemma compl_supp_eq_interior_fix : -supp f = interior (fix f) :=
calc -supp f = -closure (-fix f) : rfl
         ... = -(-interior (fix f)) : by rw closure_compl
         ... =  interior (fix f) : by rw compl_compl

lemma compl_supp_subset_fix : -supp f ⊆ fix f :=
calc -supp f = interior (fix f) : by rw compl_supp_eq_interior_fix
         ... ⊆ fix f : interior_subset

lemma fix_of_not_in_supp {x : X} {f : homeo X X} (h : x ∉ supp f) : f x = x :=
compl_supp_subset_fix f h

lemma mem_supp_or_fix (x) : x ∈ supp f ∨ f x = x :=
or_iff_not_imp_left.2 (λ h, compl_supp_subset_fix _ h)
-- Recall: or_iff_not_imp_left : a ∨ b ↔ (¬ a → b)

lemma stable_support (f : homeo X X) : f '' supp f = supp f :=
calc
  f '' supp f = f '' (closure (-fix f)) : rfl
          ... =  closure (f '' (-fix f)) : by rw f.image_closure
          ... =  closure (-(f '' (fix f))) : by rw f.image_compl
          ... =  closure (-(fix f)) : by rw fix_stable

lemma fundamental {f g : homeo X X} (H : supp f ∩ supp g = ∅) : f * g = g * f :=
begin
  ext x,
  by_cases H' : x ∈ supp f ∨ x ∈ supp g,
  { -- Here we assume H' : x ∈ supp f ∨ x ∈ supp g
    wlog h : x ∈ supp f using f g,
    have x_not_supp_g : x ∉ supp g := (subset_compl_iff_disjoint.2 H) h,
    have f_x_supp_f : f x ∈ supp f,
    { have : f x ∈ f '' supp f := mem_image_of_mem f h,
      finish [stable_support f] },
    have : f x ∉ supp g := (subset_compl_iff_disjoint.2 H) f_x_supp_f,
    finish [fix_of_not_in_supp] },
  { -- Now we assume H' : ¬(x ∈ supp f ∨ x ∈ supp g)
    rw not_or_distrib at H',
    finish [fix_of_not_in_supp] }
end
/- Calc version of above proof
lemma fundamental'' {f g : homeo X X} (H : supp f ∩ supp g = ∅) : f * g = g * f :=
begin
  ext x,
  by_cases H' : x ∈ supp f ∨ x ∈ supp g,
  { -- Here we assume H' : x ∈ supp f ∨ x ∈ supp g
    wlog h : x ∈ supp f using f g,
    exact calc
    (f * g) x = f (g x) : by simp
          ... = f x     : by { have x_not_supp_g : x ∉ supp g := (subset_compl_iff_disjoint.2 H) h,
                               finish [fix_of_not_in_supp] }
          ... = g (f x) : by { have f_x_supp_f : f x ∈ supp f,
                               { have : f x ∈ f '' supp f := mem_image_of_mem f h,
                                 finish [stable_support f] },
                               have : f x ∉ supp g := (subset_compl_iff_disjoint.2 H) f_x_supp_f,
                               finish [fix_of_not_in_supp] }
          ... = (g * f) x : by simp },
  { -- Now we assume H' : ¬(x ∈ supp f ∨ x ∈ supp g)
    rw not_or_distrib at H',
    finish [fix_of_not_in_supp] }
end
-/
lemma supp_conj (f g : homeo X X) : supp (conj g f : homeo X X) = g '' supp f :=
begin
  unfold supp,
  rw homeo.image_closure,
  congr_n 1,
  apply set.ext,
  intro x,
  rw mem_image_iff_of_inverse g.left_inverse g.right_inverse,
  apply not_congr,
  dsimp [conj],
  exact calc
     (g * f * g⁻¹) x = x
        ↔ g⁻¹ (g (f (g⁻¹ x))) = g⁻¹ x : by simp [(g⁻¹).bijective.1.eq_iff]
    ... ↔ (f (g⁻¹ x)) = g⁻¹ x : by rw [← aut_mul_val, mul_left_inv]; simp
end

local notation `〚`a, b`〛` := comm a b  -- type with \llb / \rrb

lemma numbers' {N} (H : N > 0) : ∀ i, i ∈ range' 0 (N - 1 + 1 - 0) → N - (N - 1 - i) = i + 1 :=
begin
  intros i hyp,
  simp [nat.add_sub_cancel' H] at hyp,
  rw [nat.sub_sub, add_comm, nat.sub_sub_self hyp.2]
end

/- replace hyp := hyp.right,
  have := nat.succ_le_of_lt  hyp,

  rw [← int.coe_nat_inj', int.coe_nat_sub, int.coe_nat_sub, int.coe_nat_sub],
  { ring },
  { assumption },
  { sorry },
  { sorry }-/

lemma trading_of_displaced (g a b : homeo X X)
  (supp_hyp : supp a ∩ g '' supp b = ∅) :
  ∃ c d e f : homeo X X, 〚a, b〛 = (conj c g⁻¹)*(conj d g)*(conj e g⁻¹)*(conj f g) :=
begin
  apply commutator_trading,
  rw ←supp_conj at supp_hyp,
  rw [commuting, fundamental supp_hyp]
end

--set_option trace.class_instances true
--set_option pp.all true

lemma commutators_crunching (U : set X) (φ f : homeo X X)
(wandering_hyp : ∀ i j : ℕ, i ≠ j → ⇑(φ^i) '' U ∩ ⇑(φ^j) '' U = ∅)
(N : ℕ) (aa : ℕ → homeo X X) (b : ℕ → homeo X X)
(supp_hyp : ∀ k : ℕ, supp (aa k) ⊆ U ∧ supp (b k) ⊆ U)
(comm_hyp : f = Π_(i = 1..N) 〚aa i, b i〛) :
∃ A B C D : homeo X X, f = 〚A, B〛 * 〚C, D〛 :=
begin
  by_cases H : N = 0,
  { rw big.empty_range at comm_hyp,
    repeat { existsi (1 : homeo X X) },
    simp [comm_hyp, comm],
    simp [H, zero_lt_one] },
  { replace H : N ≥ 1 := nat.succ_le_of_lt (nat.pos_of_ne_zero H),
    let G := homeo X X,
    let g := λ i, (Π_(j=1..i) 〚aa i, b i〛: G),
    let F := (Π_(i=0..(N-1)) conj (φ^i) $ g (N-i) : G),

    have commute : ∀ (i j k l : ℕ), i ≠ j →
      (conj (φ^i) (aa k))*(conj (φ^j) (b l)) = (conj (φ^j) (b l))*(conj (φ^i) (aa k)),
    begin
      intros i j k l i_neq_j,
      apply fundamental,
      repeat { rw supp_conj },
      specialize wandering_hyp i j i_neq_j,
      have supp_a := set.image_subset (φ^i : G) (supp_hyp k).left,
      have supp_b := set.image_subset (φ^j : G)  (supp_hyp l).right,

      have := set.inter_subset_inter supp_a supp_b,
      rw wandering_hyp at this,
      exact set.eq_empty_of_subset_empty this
    end,

    have numbers :=
    calc 1 + (1 + (N - 1)) - 1 =  (1 + (N-1)) + 1 - 1 : by simp
    ... = 1 + (N-1) : by rw nat.add_sub_cancel
    ... = N : by rw nat.add_sub_cancel' H,

    have cφf:= calc
    conj φ F = conj φ (Π_(i=0..(N-1)) conj (φ^i) $ g (N-i)) : rfl
    ... = Π_(i=0..(N-1)) conj φ (conj (φ^i) $ g (N-i)) : by rw (big.mph _ _ _ _ _ (is_group_hom.mul (conj φ)) (is_group_hom.one _))
    ... = Π_(i=0..(N-1)) conj (φ^(i+1)) $ g (N-i) : by simp[pow_succ]
    ... = Π_(i=1..N) conj (φ^i) $ g (N-(i-1)) : by { rw big.shift _ _ _ _ 0 (N-1) 1, simp, rw numbers, apply big.ext, simp, intros i hyp, rw nat.add_sub_cancel' (mem_range'.1 hyp).left},

    have := (@inv_is_group_anti_hom G _ _).mul,
    let gg := λ i, (conj (φ^i) $ (g (N-i))⁻¹ : G),
    have Finv := calc
    F⁻¹ = (Π_(i=0..(N-1)) conj (φ^i) $ g (N-i) : G)⁻¹ : rfl
    ... = (λ (g : G), g⁻¹) (Π_(i=0..(N-1)) conj (φ^i) $ g (N-i) : G) : rfl
    ... = (Π_(i=0..(N-1)) (conj (φ^(N-1-i)) $ g (N - (N - 1 - i)))⁻¹ : G) : by { rw big.range_anti_mph _ (1:G) _ _ _ _ this ; simp }
    ... = (Π_(i=0..(N-1)) (conj (φ^(N-1-i)) $ g (i+1))⁻¹ : G) : by { apply big.ext, { simp }, intros i hyp, rw numbers' H i hyp }
    ... = (Π_(i=0..(N-1)) conj (φ^(N-1-i)) $ (g (i+1))⁻¹ : G) : by { apply big.ext, simp, intros, rw ←is_group_hom.inv (conj _), apply_instance }
    ... = (Π_(i=0..(N-1)) conj (φ^i) $ (g (N-i))⁻¹ : G) : by { rw big.reverse_range_of_commute, apply big.ext, simp, simp, sorry, sorry }
    ... = (Π_(i=0..(N-1)) gg i)*(gg N)  : by { dsimp [g], simp[big.nil], sorry }
    ... = (Π_(i=0..N) gg i) : by{  have := (big.concat_true (*) (1:G) (range' 0 (N - 1 + 1 - 0)) gg N), cc, },

    have : conj (φ^N) (g 0)⁻¹ = 1,
    by { dsimp [g], simp[big.nil] } ,

    sorry }
end

#check big.concat_true
#check int.cast_inj


import data.nat.digits tactic algebra.big_operators
import data.zmod.basic number_theory.quadratic_reciprocity

open_locale big_operators

def yeet (b n m : ℕ) : Prop :=
n ^ m = nat.of_digits b (nat.digits b n ++ nat.digits b m)

namespace yeet

instance (b n m : ℕ) : decidable (yeet b n m) :=
by apply nat.decidable_eq

end yeet

theorem yeet_25_base_10 : yeet 10 5 2 :=
by unfold yeet nat.digits nat.digits_aux; refl

theorem yeet_1p0_any_base : ∀ b, yeet (b + 1) 1 0
| 0       := by change _ = _; refl
| (n + 1) := by unfold yeet nat.digits nat.digits_aux; refl

theorem yeet_np1_0_base (n : ℕ) : yeet 0 n.succ 1 :=
begin
  unfold yeet nat.digits nat.digits_aux_0,
  rw [pow_one, nat.of_digits_append],
  simp
end

lemma ex_pred_of_s : ∀ n > 0, ∃ m : ℕ, m.succ = n
| 0       h := absurd h dec_trivial
| (n + 1) _ := ⟨n, rfl⟩

lemma self_dvd_poly : ∀ n : ℕ, n.prime → n ∣ (3 ^ n - 3)
| 0       _  := dec_trivial
| 1       _  := dec_trivial
| 2       _  := dec_trivial
| 3       _  := dec_trivial
| (n + 4) hp :=
  begin
    have h := @zmod.pow_card_sub_one_eq_one (n + 4) hp 3 dec_trivial,
    norm_num at h,
    apply_fun λ x, (x - 1) * 3 at h,
    norm_num [sub_self, sub_mul] at h,
    conv_lhs at h { congr, congr, skip, rw ←@pow_one (zmod (n + 4)) _ 3 },
    rw [←pow_add, add_assoc] at h,
    norm_num at h,
    suffices hzm : (3 : zmod (n + 4)) ^ (n + 4) - 3 = ((3 ^ (n + 4) - 3 : ℕ) : zmod (n + 4)),
    rwa [←zmod.nat_coe_zmod_eq_zero_iff_dvd, ←hzm],
    suffices hle : 3 ≤ 3 ^ (n + 4), { rw nat.cast_sub hle, norm_num },
    change 3 ^ 1 ≤ _,
    rw nat.pow_le_iff_le_right (dec_trivial : 2 ≤ 3),
    linarith
  end

-- proof by Shing Tak Lam
theorem p3_lt_poly (n : ℕ) : (n + 3)^2 < 3^(n + 3) - 3 :=
begin
  suffices : (n+3)^2 + 3 < 3^(n+3), -- much nicer
  { have : 3^0 < 3^(n+3) := nat.pow_lt_pow_of_lt_right dec_trivial dec_trivial,
    omega },
  induction n with k IH,
  { norm_num },
  rw [nat.succ_eq_add_one, add_right_comm],
  rw show (k+3+1)^2 = (k+3)^2 + 2*(k+3) + 1, by ring,
  rw pow_succ 3,
  suffices : (k+3) + 1 < (k+3)^2,
  { linarith },
  rw pow_two,
  show k + 3 + 1 < (k + 3) * (k + 3), by nlinarith
end

lemma ex_pred_of_ss : ∀ n > 1, ∃ m : ℕ, m.succ.succ = n
| 0       h := absurd h dec_trivial
| 1       h := absurd h dec_trivial
| (n + 2) _ := ⟨n, rfl⟩

theorem yeet_3p_odd_prime : ∀ n > 2, nat.prime n → yeet ((3 ^ n - 3) / n) 3 n
| 0       h  _  := absurd h dec_trivial
| 1       h  _  := absurd h dec_trivial
| 2       h  _  := absurd h dec_trivial
| (n + 3) hl hp :=
  begin
    set m := n + 3 with hm,
    unfold yeet,
    suffices hpoly : m < ((3 ^ m - 3) / m),
    have hpolypos : 1 < ((3 ^ m - 3) / m) := by linarith,
    cases ex_pred_of_ss _ hpolypos with w hw,
    change (3 ^ m - 3) with (3 ^ m - 3) at hpoly ⊢,
    rw ←hw at hpoly ⊢,
    have h3ltpoly : 3 < w.succ.succ := by linarith,
    rw nat.digits_of_lt _ _ dec_trivial h3ltpoly,
    rw nat.digits_of_lt _ _ dec_trivial hpoly,
    norm_num [nat.of_digits],
    cases n, { norm_num [m, hw] },
    have : m ∣ 3 ^ m - 3 := self_dvd_poly _ hp,
    rw [hw, nat.div_mul_cancel this, add_comm],
    have h3le3pm : 3 ≤ 3 ^ m,
      { change 3 ^ 1 ≤ _,
        apply nat.pow_le_pow_of_le_right,
        exact dec_trivial,
        exact le_of_lt (lt_trans dec_trivial hl) },
    change _ = 3 ^ m - _ + _,
    rw nat.sub_add_cancel h3le3pm,
    change m < (3 ^ m - 3) / m,
    apply lt_of_mul_lt_mul_right _ (nat.zero_le m),
    rw [nat.div_mul_cancel (self_dvd_poly m hp), ←pow_two, hm],
    exact p3_lt_poly n
  end

def ceil_log (b n : ℕ) : ℕ :=
list.length $ nat.digits b n

@[simp]
theorem ceil_log_zero : ∀ b, ceil_log b 0 = 0
| 0     := rfl
| 1     := rfl
| (n+2) := rfl

@[simp]
theorem ceil_log_pos : ∀ b (n > 0), 0 < ceil_log b n
| _     0     h := absurd h dec_trivial
| 0     (n+1) _ := by norm_num [ceil_log, nat.digits, nat.digits_aux_0]
| 1     (n+1) _ := by norm_num [ceil_log, nat.digits, nat.digits_aux_1]
| (b+2) (n+1) _ := by norm_num [ceil_log, nat.digits, nat.digits_aux]

lemma mod_eq_c_iff_multiple_plus_c (n m l : ℕ) (hm : 0 < m) :
  n % m = l ↔ l < m ∧ ∃ p, n = p * m + l :=
begin
  split,
    { intro h,
      induction h,
      apply and.intro (nat.mod_lt _ hm),
      use n / m,
      rw [mul_comm, add_comm],
      exact eq.symm (nat.mod_add_div n m) },
    { rintro ⟨hl, w, h⟩,
      norm_num [h, nat.add_mod],
      exact nat.mod_eq_of_lt hl }
end

@[simp]
lemma nat.digits_of_base : ∀ b > 1, nat.digits b b = [0, 1]
| 0     h := absurd h dec_trivial
| 1     h := absurd h dec_trivial
| (b+2) h := by norm_num [nat.digits, nat.digits_aux]; split

-- proof by Shing Tak Lam
lemma of_digits_append (b : ℕ) (l1 l2 : list ℕ) :
  nat.of_digits b (l1 ++ l2) = nat.of_digits b l1 + b ^ (l1.length) * nat.of_digits b l2 :=
begin
  induction l1 with hd tl IH,
  { simp [nat.of_digits] },
  { rw [nat.of_digits, list.cons_append, nat.of_digits, IH, list.length_cons, pow_succ],
    ring }
end

-- proof by Shing Tak Lam
theorem nat.digits_split : ∀ b n m,
  nat.of_digits b (nat.digits b n ++ nat.digits b m) = n + m * (b ^ ceil_log b n) :=
begin
  intros b n m,
  rw [of_digits_append b (nat.digits b n) (nat.digits b m),
      nat.of_digits_digits, nat.of_digits_digits, ceil_log, mul_comm],
end

lemma kendfrey_2_dvd_poly {n : ℕ} (h : 0 < n) : 2 ∣ n * (n - 1) :=
begin
  cases ex_pred_of_s _ h with w hw,
  rw ←hw,
  change _ ∣ w.succ * w,
  cases nat.mod_two_eq_zero_or_one w with h h,
    { exact dvd_mul_of_dvd_right (nat.dvd_of_mod_eq_zero h) _ },
    { apply dvd_mul_of_dvd_left,
      rcases (mod_eq_c_iff_multiple_plus_c _ 2 _ dec_trivial).mp h with ⟨_, v, hv⟩,
      rw hv,
      change 2 ∣ _ * _ + 2,
      conv_rhs { congr, skip, rw [←one_mul 2] },
      rw [←add_mul, mul_comm],
      exact nat.dvd_mul_right _ _ }
end

lemma self_lt_kendfrey_poly (n : ℕ) : n + 5 < ((n + 5) * (n + 4)) / 2 :=
begin
  have hpoly := (@kendfrey_2_dvd_poly (n + 5) dec_trivial),
  have := nat.mod_eq_zero_of_dvd hpoly,
  rcases (mod_eq_c_iff_multiple_plus_c _ 2 _ dec_trivial).mp this with ⟨_, w, hw⟩,
  apply lt_of_mul_lt_mul_right _ (nat.zero_le 2),
  norm_num at hpoly,
  rw nat.div_mul_cancel hpoly,
  exact nat.mul_lt_mul_of_pos_left (dec_trivial : 2 < n + 4) (dec_trivial : 0 < n + 5)
end

theorem kendfrey_conjecture : ∀ n > 0, n ≠ 3 → yeet (n * (n - 1) / 2) n 2
| 0 h _ := absurd h (dec_trivial)
| 1 _ _ := dec_trivial
| 2 _ _ := dec_trivial
| 3 _ h := absurd h (dec_trivial)
| 4 _ _ := by norm_num [yeet, nat.of_digits]
| (n+5) h _ :=
  begin
    norm_num [yeet, nat.digits_split],
    have := nat.mod_eq_zero_of_dvd (kendfrey_2_dvd_poly h),
    rcases (mod_eq_c_iff_multiple_plus_c _ 2 _ dec_trivial).mp this with ⟨_, w, hw⟩,
    norm_num at hw,
    norm_num [hw, add_mul_self_eq, ceil_log],
    have hw2 : (n + 5) * (n + 4) / 2 = w,
      { apply_fun λ x, x / 2 at hw, simp at hw, exact hw },
    norm_num [←hw2, nat.digits_of_lt _ _ h (self_lt_kendfrey_poly _), ←hw],
    linarith
  end

lemma mod_3_eq_0_1_or_2 (n : ℕ) : n % 3 = 0 ∨ n % 3 = 1 ∨ n % 3 = 2 :=
match n % 3, @nat.mod_lt n 3 dec_trivial with
| 0,     _ := or.inl rfl
| 1,     _ := or.inr $ or.inl rfl
| 2,     _ := or.inr $ or.inr rfl
| k + 3, h := absurd h dec_trivial
end

lemma nyefari_3_dvd_poly {n : ℕ} (h : 0 < n) : 3 ∣ n * (n + 1) * (n - 1) :=
begin
  cases ex_pred_of_s _ h with w hw,
  rw ←hw,
  change _ ∣ (w + 1) * (w + 2) * w,
  rcases mod_3_eq_0_1_or_2 w with h | h | h,
    { exact dvd_mul_of_dvd_right (nat.dvd_of_mod_eq_zero h) _ },
  all_goals
    { apply dvd_mul_of_dvd_left,
      rcases (mod_eq_c_iff_multiple_plus_c _ 3 _ dec_trivial).mp h with ⟨_, v, hv⟩,
      rw [hv, add_assoc], },
    { apply dvd_mul_of_dvd_right,
      exact @nat.dvd_add 3 _ 3 (dvd_mul_left _ _) dec_trivial },
    { apply dvd_mul_of_dvd_left,
      exact @nat.dvd_add 3 _ 3 (dvd_mul_left _ _) dec_trivial }
end

theorem self_lt_nyefari_poly (n : ℕ) : n + 3 < ((n + 3) * (n + 4) * (n + 2) / 3) :=
begin
  have hpoly := (@nyefari_3_dvd_poly (n + 3) dec_trivial),
  have := nat.mod_eq_zero_of_dvd hpoly,
  rcases (mod_eq_c_iff_multiple_plus_c _ 3 _ dec_trivial).mp this with ⟨_, w, hw⟩,
  apply lt_of_mul_lt_mul_right _ (nat.zero_le 3),
  norm_num at hpoly,
  rw [nat.div_mul_cancel hpoly, mul_assoc],
  apply nat.mul_lt_mul_of_pos_left _ (dec_trivial : 0 < n + 3),
  norm_num [mul_add, add_mul],
  rw [add_assoc, add_comm _ (n + 2), ←add_assoc, ←add_assoc],
  exact dec_trivial
end

theorem nyefari_conjecture : ∀ n > 0, n ≠ 2 → yeet (n * (n + 1) * (n - 1) / 3) n 3
| 0 h _ := absurd h (dec_trivial)
| 1 _ _ := dec_trivial
| 2 _ h := absurd h (dec_trivial)
| (n+3) h _ :=
  begin
    norm_num [yeet, nat.digits_split],
    have := nat.mod_eq_zero_of_dvd (nyefari_3_dvd_poly h),
    rcases (mod_eq_c_iff_multiple_plus_c _ 3 _ dec_trivial).mp this with ⟨_, w, hw⟩,
    norm_num at hw,
    change (n + 3) ^ 3 with (n + 3) ^ (2 + 1),
    rw [pow_add, pow_one, pow_two],
    have hw2 : (n + 3) * (n + 4) * (n + 2) / 3 = w,
      { apply_fun λ x, x / 3 at hw, simp at hw, exact hw },
    unfold ceil_log,
    rw [
      nat.digits_of_lt _ _ h (self_lt_nyefari_poly _), list.length, list.length, hw,
      nat.mul_div_cancel _ (dec_trivial : 3 > 0), pow_one, mul_comm 3 w, ←hw
    ],
    ring,
  end

lemma n_le_n_p (p n > 0) : n ≤ n ^ p :=
by conv_lhs {rw ←pow_one n}; exact nat.pow_le_pow_of_le_right ‹_› ‹_›

theorem ultra_p_dvd_poly : ∀ p n : ℕ, p.prime → p ∣ (n ^ p - n) :=
begin
  intros p n hp,
  have hppos : 0 < p := nat.prime.pos hp,
  cases n, { rw zero_pow hppos, exact dvd_zero p },
  have h := @zmod.pow_card p hp n.succ,
  rw ←nat.modeq.modeq_iff_dvd' (n_le_n_p _ _ hppos (dec_trivial : n.succ > 0)),
  norm_cast at h,
  rwa [zmod.eq_iff_modeq_nat, nat.modeq.comm] at h
end

theorem ultra_conjecture (p n : ℕ) (hn₀ : 0 < n) (hn₁ : n < (n ^ p - n) / p) (hp : p.prime) :
  yeet ((n ^ p - n) / p) n p :=
begin
  norm_num [yeet, nat.digits_split],
  have := nat.mod_eq_zero_of_dvd (ultra_p_dvd_poly _ n hp),
  have hppos : 0 < p := nat.prime.pos hp,
  rcases (mod_eq_c_iff_multiple_plus_c _ _ _ hppos).mp this with ⟨_, w, hw⟩,
  norm_num at hw,
  rw [ceil_log, nat.digits_of_lt _ _ hn₀ hn₁, hw, nat.mul_div_cancel _ hppos],
  norm_num,
  rwa [nat.sub_eq_iff_eq_add, add_comm, mul_comm] at hw,
  exact n_le_n_p _ _ hppos hn₀
end


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau
-/
import data.list.lattice
import data.list.pairwise
import data.list.forall2

/-!
# Lists with no duplicates

`list.nodup` is defined in `data/list/defs`. In this file we prove various properties of this
predicate.
-/

universes u v

open nat function

variables {α : Type u} {β : Type v} {l l₁ l₂ : list α} {a b : α}

namespace list

@[simp] theorem forall_mem_ne {a : α} {l : list α} : (∀ (a' : α), a' ∈ l → ¬a = a') ↔ a ∉ l :=
⟨λ h m, h _ m rfl, λ h a' m e, h (e.symm ▸ m)⟩

@[simp] theorem nodup_nil : @nodup α [] := pairwise.nil

@[simp] theorem nodup_cons {a : α} {l : list α} : nodup (a::l) ↔ a ∉ l ∧ nodup l :=
by simp only [nodup, pairwise_cons, forall_mem_ne]

protected lemma pairwise.nodup {l : list α} {r : α → α → Prop} [is_irrefl α r] (h : pairwise r l) :
  nodup l :=
h.imp $ λ a b, ne_of_irrefl

lemma rel_nodup {r : α → β → Prop} (hr : relator.bi_unique r) : (forall₂ r ⇒ (↔)) nodup nodup
| _ _ forall₂.nil      := by simp only [nodup_nil]
| _ _ (forall₂.cons hab h) :=
  by simpa only [nodup_cons] using relator.rel_and (relator.rel_not (rel_mem hr hab h))
    (rel_nodup h)

protected lemma nodup.cons (ha : a ∉ l) (hl : nodup l) : nodup (a :: l) := nodup_cons.2 ⟨ha, hl⟩

lemma nodup_singleton (a : α) : nodup [a] := pairwise_singleton _ _

lemma nodup.of_cons (h : nodup (a :: l)) : nodup l := (nodup_cons.1 h).2
lemma nodup.not_mem (h : (a :: l).nodup) : a ∉ l := (nodup_cons.1 h).1

lemma not_nodup_cons_of_mem : a ∈ l → ¬ nodup (a :: l) := imp_not_comm.1 nodup.not_mem

protected lemma nodup.sublist : l₁ <+ l₂ → nodup l₂ → nodup l₁ := pairwise.sublist

theorem not_nodup_pair (a : α) : ¬ nodup [a, a] :=
not_nodup_cons_of_mem $ mem_singleton_self _

theorem nodup_iff_sublist {l : list α} : nodup l ↔ ∀ a, ¬ [a, a] <+ l :=
⟨λ d a h, not_nodup_pair a (d.sublist h), begin
  induction l with a l IH; intro h, {exact nodup_nil},
  exact (IH $ λ a s, h a $ sublist_cons_of_sublist _ s).cons
    (λ al, h a $ (singleton_sublist.2 al).cons_cons _)
end⟩

theorem nodup_iff_nth_le_inj {l : list α} :
  nodup l ↔ ∀ i j h₁ h₂, nth_le l i h₁ = nth_le l j h₂ → i = j :=
pairwise_iff_nth_le.trans
⟨λ H i j h₁ h₂ h, ((lt_trichotomy _ _)
  .resolve_left (λ h', H _ _ h₂ h' h))
  .resolve_right (λ h', H _ _ h₁ h' h.symm),
 λ H i j h₁ h₂ h, ne_of_lt h₂ (H _ _ _ _ h)⟩

theorem nodup.nth_le_inj_iff {α : Type*} {l : list α} (h : nodup l)
  {i j : ℕ} (hi : i < l.length) (hj : j < l.length) :
  l.nth_le i hi = l.nth_le j hj ↔ i = j :=
⟨nodup_iff_nth_le_inj.mp h _ _ _ _, by simp {contextual := tt}⟩

lemma nodup.ne_singleton_iff {l : list α} (h : nodup l) (x : α) :
  l ≠ [x] ↔ l = [] ∨ ∃ y ∈ l, y ≠ x :=
begin
  induction l with hd tl hl,
  { simp },
  { specialize hl h.of_cons,
    by_cases hx : tl = [x],
    { simpa [hx, and.comm, and_or_distrib_left] using h },
    { rw [←ne.def, hl] at hx,
      rcases hx with rfl | ⟨y, hy, hx⟩,
      { simp },
      { have : tl ≠ [] := ne_nil_of_mem hy,
        suffices : ∃ (y : α) (H : y ∈ hd :: tl), y ≠ x,
        { simpa [ne_nil_of_mem hy] },
        exact ⟨y, mem_cons_of_mem _ hy, hx⟩ } } }
end

lemma nth_le_eq_of_ne_imp_not_nodup (xs : list α) (n m : ℕ) (hn : n < xs.length)
  (hm : m < xs.length) (h : xs.nth_le n hn = xs.nth_le m hm) (hne : n ≠ m) :
  ¬ nodup xs :=
begin
  rw nodup_iff_nth_le_inj,
  simp only [exists_prop, exists_and_distrib_right, not_forall],
  exact ⟨n, m, ⟨hn, hm, h⟩, hne⟩
end

@[simp] theorem nth_le_index_of [decidable_eq α] {l : list α} (H : nodup l) (n h) :
  index_of (nth_le l n h) l = n :=
nodup_iff_nth_le_inj.1 H _ _ _ h $
index_of_nth_le $ index_of_lt_length.2 $ nth_le_mem _ _ _

theorem nodup_iff_count_le_one [decidable_eq α] {l : list α} : nodup l ↔ ∀ a, count a l ≤ 1 :=
nodup_iff_sublist.trans $ forall_congr $ λ a,
have [a, a] <+ l ↔ 1 < count a l, from (@le_count_iff_repeat_sublist _ _ a l 2).symm,
(not_congr this).trans not_lt

theorem nodup_repeat (a : α) : ∀ {n : ℕ}, nodup (repeat a n) ↔ n ≤ 1
| 0 := by simp [nat.zero_le]
| 1 := by simp
| (n+2) := iff_of_false
  (λ H, nodup_iff_sublist.1 H a ((repeat_sublist_repeat _).2 (nat.le_add_left 2 n)))
  (not_le_of_lt $ nat.le_add_left 2 n)

@[simp] theorem count_eq_one_of_mem [decidable_eq α] {a : α} {l : list α}
  (d : nodup l) (h : a ∈ l) : count a l = 1 :=
le_antisymm (nodup_iff_count_le_one.1 d a) (count_pos.2 h)

lemma nodup.of_append_left : nodup (l₁ ++ l₂) → nodup l₁ :=
nodup.sublist (sublist_append_left l₁ l₂)

lemma nodup.of_append_right : nodup (l₁ ++ l₂) → nodup l₂ :=
nodup.sublist (sublist_append_right l₁ l₂)

theorem nodup_append {l₁ l₂ : list α} : nodup (l₁++l₂) ↔ nodup l₁ ∧ nodup l₂ ∧ disjoint l₁ l₂ :=
by simp only [nodup, pairwise_append, disjoint_iff_ne]

theorem disjoint_of_nodup_append {l₁ l₂ : list α} (d : nodup (l₁++l₂)) : disjoint l₁ l₂ :=
(nodup_append.1 d).2.2

lemma nodup.append (d₁ : nodup l₁) (d₂ : nodup l₂) (dj : disjoint l₁ l₂) : nodup (l₁ ++ l₂) :=
nodup_append.2 ⟨d₁, d₂, dj⟩

theorem nodup_append_comm {l₁ l₂ : list α} : nodup (l₁++l₂) ↔ nodup (l₂++l₁) :=
by simp only [nodup_append, and.left_comm, disjoint_comm]

theorem nodup_middle {a : α} {l₁ l₂ : list α} : nodup (l₁ ++ a::l₂) ↔ nodup (a::(l₁++l₂)) :=
by simp only [nodup_append, not_or_distrib, and.left_comm, and_assoc, nodup_cons, mem_append,
  disjoint_cons_right]

lemma nodup.of_map (f : α → β) {l : list α} : nodup (map f l) → nodup l :=
pairwise.of_map f $ λ a b, mt $ congr_arg f

lemma nodup.map_on {f : α → β} (H : ∀ x ∈ l, ∀ y ∈ l, f x = f y → x = y) (d : nodup l) :
  (map f l).nodup :=
pairwise.map _ (by exact λ a b ⟨ma, mb, n⟩ e, n (H a ma b mb e)) (pairwise.and_mem.1 d)

theorem nodup_map_iff_inj_on {f : α → β} {l : list α} (d : nodup l) :
  nodup (map f l) ↔ (∀ (x ∈ l) (y ∈ l), f x = f y → x = y) :=
⟨inj_on_of_nodup_map, λ h, d.map_on h⟩

protected lemma nodup.map {f : α → β} (hf : injective f) : nodup l → nodup (map f l) :=
nodup.map_on (assume x _ y _ h, hf h)

theorem nodup_map_iff {f : α → β} {l : list α} (hf : injective f) : nodup (map f l) ↔ nodup l :=
⟨nodup.of_map _, nodup.map hf⟩

@[simp] theorem nodup_attach {l : list α} : nodup (attach l) ↔ nodup l :=
⟨λ h, attach_map_val l ▸ h.map (λ a b, subtype.eq),
  λ h, nodup.of_map subtype.val ((attach_map_val l).symm ▸ h)⟩

alias nodup_attach ↔ list.nodup.of_attach list.nodup.attach

attribute [protected] nodup.attach

lemma nodup.pmap {p : α → Prop} {f : Π a, p a → β} {l : list α} {H}
  (hf : ∀ a ha b hb, f a ha = f b hb → a = b) (h : nodup l) : nodup (pmap f l H) :=
by rw [pmap_eq_map_attach]; exact h.attach.map
  (λ ⟨a, ha⟩ ⟨b, hb⟩ h, by congr; exact hf a (H _ ha) b (H _ hb) h)

lemma nodup.filter (p : α → Prop) [decidable_pred p] {l} : nodup l → nodup (filter p l) :=
pairwise.filter p

@[simp] theorem nodup_reverse {l : list α} : nodup (reverse l) ↔ nodup l :=
pairwise_reverse.trans $ by simp only [nodup, ne.def, eq_comm]

lemma nodup.erase_eq_filter [decidable_eq α] {l} (d : nodup l) (a : α) :
  l.erase a = filter (≠ a) l :=
begin
  induction d with b l m d IH, {refl},
  by_cases b = a,
  { subst h, rw [erase_cons_head, filter_cons_of_neg],
    symmetry, rw filter_eq_self, simpa only [ne.def, eq_comm] using m, exact not_not_intro rfl },
  { rw [erase_cons_tail _ h, filter_cons_of_pos, IH], exact h }
end

lemma nodup.erase [decidable_eq α] (a : α) : nodup l → nodup (l.erase a) :=
nodup.sublist $ erase_sublist _ _

lemma nodup.diff [decidable_eq α] : l₁.nodup → (l₁.diff l₂).nodup :=
nodup.sublist $ diff_sublist _ _

lemma nodup.mem_erase_iff [decidable_eq α] (d : nodup l) : a ∈ l.erase b ↔ a ≠ b ∧ a ∈ l :=
by rw [d.erase_eq_filter, mem_filter, and_comm]

lemma nodup.not_mem_erase [decidable_eq α] (h : nodup l) : a ∉ l.erase a :=
λ H, (h.mem_erase_iff.1 H).1 rfl

theorem nodup_join {L : list (list α)} :
  nodup (join L) ↔ (∀ l ∈ L, nodup l) ∧ pairwise disjoint L :=
by simp only [nodup, pairwise_join, disjoint_left.symm, forall_mem_ne]

theorem nodup_bind {l₁ : list α} {f : α → list β} : nodup (l₁.bind f) ↔
  (∀ x ∈ l₁, nodup (f x)) ∧ pairwise (λ (a b : α), disjoint (f a) (f b)) l₁ :=
by simp only [list.bind, nodup_join, pairwise_map, and_comm, and.left_comm, mem_map,
  exists_imp_distrib, and_imp];
   rw [show (∀ (l : list β) (x : α), f x = l → x ∈ l₁ → nodup l) ↔
            (∀ (x : α), x ∈ l₁ → nodup (f x)),
       from forall_swap.trans $ forall_congr $ λ_, forall_eq']

protected lemma nodup.product {l₂ : list β} (d₁ : l₁.nodup) (d₂ : l₂.nodup) :
  (l₁.product l₂).nodup :=
nodup_bind.2
  ⟨λ a ma, d₂.map $ left_inverse.injective $ λ b, (rfl : (a,b).2 = b),
  d₁.imp $ λ a₁ a₂ n x h₁ h₂, begin
    rcases mem_map.1 h₁ with ⟨b₁, mb₁, rfl⟩,
    rcases mem_map.1 h₂ with ⟨b₂, mb₂, ⟨⟩⟩,
    exact n rfl
  end⟩

lemma nodup.sigma {σ : α → Type*} {l₂ : Π a, list (σ a)} (d₁ : nodup l₁) (d₂ : ∀ a, nodup (l₂ a)) :
  (l₁.sigma l₂).nodup :=
nodup_bind.2
  ⟨λ a ma, (d₂ a).map (λ b b' h, by injection h with _ h; exact eq_of_heq h),
  d₁.imp $ λ a₁ a₂ n x h₁ h₂, begin
    rcases mem_map.1 h₁ with ⟨b₁, mb₁, rfl⟩,
    rcases mem_map.1 h₂ with ⟨b₂, mb₂, ⟨⟩⟩,
    exact n rfl
  end⟩

protected lemma nodup.filter_map {f : α → option β} (h : ∀ a a' b, b ∈ f a → b ∈ f a' → a = a') :
  nodup l → nodup (filter_map f l) :=
pairwise.filter_map f $ λ a a' n b bm b' bm' e, n $ h a a' b' (e ▸ bm) bm'

protected lemma nodup.concat (h : a ∉ l) (h' : l.nodup) : (l.concat a).nodup :=
by rw concat_eq_append; exact h'.append (nodup_singleton _) (disjoint_singleton.2 h)

lemma nodup.insert [decidable_eq α] (h : l.nodup) : (insert a l).nodup :=
if h' : a ∈ l then by rw [insert_of_mem h']; exact h
else by rw [insert_of_not_mem h', nodup_cons]; split; assumption

lemma nodup.union [decidable_eq α] (l₁ : list α) (h : nodup l₂) : (l₁ ∪ l₂).nodup  :=
begin
  induction l₁ with a l₁ ih generalizing l₂,
  { exact h },
  { exact (ih h).insert }
end

lemma nodup.inter [decidable_eq α] (l₂ : list α) : nodup l₁ → nodup (l₁ ∩ l₂) := nodup.filter _

@[simp] theorem nodup_sublists {l : list α} : nodup (sublists l) ↔ nodup l :=
⟨λ h, (h.sublist (map_ret_sublist_sublists _)).of_map _,
 λ h, (pairwise_sublists h).imp (λ _ _ h, mt reverse_inj.2 h.to_ne)⟩

@[simp] theorem nodup_sublists' {l : list α} : nodup (sublists' l) ↔ nodup l :=
by rw [sublists'_eq_sublists, nodup_map_iff reverse_injective,
       nodup_sublists, nodup_reverse]

alias nodup_sublists ↔ list.nodup.of_sublists list.nodup.sublists
alias nodup_sublists' ↔ list.nodup.of_sublists' list.nodup.sublists'

attribute [protected] nodup.sublists nodup.sublists'

lemma nodup_sublists_len (n : ℕ) (h : nodup l) : (sublists_len n l).nodup :=
h.sublists'.sublist $ sublists_len_sublist_sublists' _ _

lemma nodup.diff_eq_filter [decidable_eq α] :
  ∀ {l₁ l₂ : list α} (hl₁ : l₁.nodup), l₁.diff l₂ = l₁.filter (∉ l₂)
| l₁ []      hl₁ := by simp
| l₁ (a::l₂) hl₁ :=
begin
  rw [diff_cons, (hl₁.erase _).diff_eq_filter, hl₁.erase_eq_filter, filter_filter],
  simp only [mem_cons_iff, not_or_distrib, and.comm]
end

lemma nodup.mem_diff_iff [decidable_eq α] (hl₁ : l₁.nodup) : a ∈ l₁.diff l₂ ↔ a ∈ l₁ ∧ a ∉ l₂ :=
by rw [hl₁.diff_eq_filter, mem_filter]

protected lemma nodup.update_nth : ∀ {l : list α} {n : ℕ} {a : α} (hl : l.nodup) (ha : a ∉ l),
  (l.update_nth n a).nodup
| []     n     a hl ha := nodup_nil
| (b::l) 0     a hl ha := nodup_cons.2 ⟨mt (mem_cons_of_mem _) ha, (nodup_cons.1 hl).2⟩
| (b::l) (n+1) a hl ha := nodup_cons.2
  ⟨λ h, (mem_or_eq_of_mem_update_nth h).elim
      (nodup_cons.1 hl).1
      (λ hba, ha (hba ▸ mem_cons_self _ _)), hl.of_cons.update_nth (mt (mem_cons_of_mem _) ha)⟩

lemma nodup.map_update [decidable_eq α] {l : list α} (hl : l.nodup) (f : α → β) (x : α) (y : β) :
  l.map (function.update f x y) =
    if x ∈ l then (l.map f).update_nth (l.index_of x) y else l.map f :=
begin
  induction l with hd tl ihl, { simp },
  rw [nodup_cons] at hl,
  simp only [mem_cons_iff, map, ihl hl.2],
  by_cases H : hd = x,
  { subst hd,
    simp [update_nth, hl.1] },
  { simp [ne.symm H, H, update_nth, ← apply_ite (cons (f hd))] }
end

lemma nodup.pairwise_of_forall_ne {l : list α} {r : α → α → Prop}
  (hl : l.nodup) (h : ∀ (a ∈ l) (b ∈ l), a ≠ b → r a b) : l.pairwise r :=
begin
  classical,
  refine pairwise_of_reflexive_on_dupl_of_forall_ne _ h,
  intros x hx,
  rw nodup_iff_count_le_one at hl,
  exact absurd (hl x) hx.not_le
end

lemma nodup.pairwise_of_set_pairwise {l : list α} {r : α → α → Prop}
  (hl : l.nodup) (h : {x | x ∈ l}.pairwise r) : l.pairwise r :=
hl.pairwise_of_forall_ne h

end list

theorem option.to_list_nodup {α} : ∀ o : option α, o.to_list.nodup
| none     := list.nodup_nil
| (some x) := list.nodup_singleton x


import ring_theory.principal_ideal_domain ring_theory.ideal.basic
import order.zorn data.real.basic

variables {V M : Type*} [integral_domain V] [is_principal_ideal_ring V]
   [add_comm_group M] -- I added field here, it *may* break things
   [module V M]

open module
open ideal zorn

lemma zero_in (I : set(ideal V)) (hI : I.nonempty)
  : (0 : V) ∈ (⋃ i ∈ I, (i : set V)) :=
begin
  rw set.mem_bUnion_iff,
  cases hI with a ha,
  use a,
  exact ⟨ ha, a.zero_mem ⟩,
end

lemma add_mem'
  {I : set (ideal V)}
  (hchain : chain (≤) I) :
  ∀ {a b : V},
    (a ∈ (⋃ i ∈ I, (i : set V))) →
    (b ∈ (⋃ i ∈ I, (i : set V))) →
    (a + b ∈ (⋃ i ∈ I, (i : set V))) :=
begin
  intros a b ha hb,
  rw set.mem_bUnion_iff at ha hb ⊢,
  rcases ha with ⟨J₁, hJ₁, gJ₁⟩,
  rcases hb with ⟨J₂, hJ₂, gJ₂⟩,
  rw chain at hchain,
  specialize hchain J₁ hJ₁ J₂ hJ₂,
  by_cases HJ₁J₂ : J₁ = J₂,
  {exact ⟨ J₂, hJ₂, J₂.add_mem (HJ₁J₂ ▸ gJ₁) gJ₂ ⟩,},
  { specialize hchain HJ₁J₂,
    cases hchain with HJ₁J₂ HJ₂J₁,
    { exact ⟨ J₂, hJ₂, J₂.add_mem (HJ₁J₂ gJ₁) (gJ₂) ⟩,},
    { exact ⟨ J₁, hJ₁, J₁.add_mem (gJ₁) (HJ₂J₁ gJ₂) ⟩,},
  }
end

lemma smul_mem'
  {I : set (ideal V)} :
  ∀ (c : V) {x : V},
    (x ∈ (⋃ i ∈ I, (i : set V))) →
    (c • x ∈ (⋃ i ∈ I, (i : set V))) :=
begin
  intros a b hb,
  rw set.mem_bUnion_iff at hb ⊢,
  rcases hb with ⟨X, hXI, hbX⟩,
  exact ⟨X, hXI, X.smul_mem a hbX⟩,
end

def Union_ideal {I : set(ideal V)} (hI : I.nonempty) (hchain : chain (≤) I) : ideal V := {
  carrier := (⋃ i ∈ I, (i : set V)),
  zero_mem' := zero_in _ hI,
  add_mem' := λ a b, add_mem' hchain,
  smul_mem' := smul_mem' }

lemma Union_in_Ideal {I : set(ideal V)} (hI : I.nonempty) (hchain : chain (≤) I) :
  Union_ideal hI hchain ∈ I :=
begin

  sorry
end

variables (I : set(ideal V)) (hI : I.nonempty)
#check set_has_maximal_iff_noetherian

lemma exists_maximal_in_set (I : set (ideal V)) (H : zorn.chain (≤) I) (hI : I.nonempty)
  : ∃ s ∈ I, ∀ t ∈ I, s ≤ t → t = s:=
begin
  -- apply principal_ideal_ring.is_noetherian_ring,
  have H := set_has_maximal_iff_noetherian,
  apply zorn.zorn_partial_order₀,
  intros X hXI XChain,
  -- use
  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

! This file was ported from Lean 3 source module data.qpf.multivariate.constructions.cofix
! leanprover-community/mathlib commit f694c7dead66f5d4c80f446c796a5aad14707f0e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Control.Functor.Multivariate
import Mathlib.Data.PFunctor.Multivariate.Basic
import Mathlib.Data.PFunctor.Multivariate.M
import Mathlib.Data.QPF.Multivariate.Basic

import Qpf.Util

/-!
# The final co-algebra of a multivariate qpf is again a qpf.

For a `(n+1)`-ary QPF `F (α₀,..,αₙ)`, we take the least fixed point of `F` with
regards to its last argument `αₙ`. The result is a `n`-ary functor: `fix F (α₀,..,αₙ₋₁)`.
Making `fix F` into a functor allows us to take the fixed point, compose with other functors
and take a fixed point again.

## Main definitions

 * `cofix.mk`     - constructor
 * `cofix.dest`   - destructor
 * `cofix.corec`  - corecursor: useful for formulating infinite, productive computations
 * `cofix.bisim`  - bisimulation: proof technique to show the equality of possibly infinite values
                    of `cofix F α`

## Implementation notes

For `F` a QPF, we define `cofix F α` in terms of the M-type of the polynomial functor `P` of `F`.
We define the relation `Mcongr` and take its quotient as the definition of `cofix F α`.

`Mcongr` is taken as the weakest bisimulation on M-type. See
[avigad-carneiro-hudon2019] for more details.

## Reference

 * Jeremy Avigad, Mario M. Carneiro and Simon Hudon.
   [*Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universe u

open MvFunctor

namespace MvQPF

open TypeVec MvPFunctor

open MvFunctor (LiftP LiftR)

variable {n : ℕ} {F : TypeVec.{u} (n + 1) → Type u} [q : MvQPF F]

/-- `corecF` is used as a basis for defining the corecursor of `cofix F α`. `corecF`
uses corecursion to construct the M-type generated by `q.P` and uses function on `F`
as a corecursive step -/
def corecF {α : TypeVec n} {β : Type _} (g : β → F (α.append1 β)) : β → q.P.M α :=
  M.corec _ fun x => repr (g x)
set_option linter.uppercaseLean3 false in
#align mvqpf.corecF MvQPF.corecF

theorem corecF_eq {α : TypeVec n} {β : Type _} (g : β → F (α.append1 β)) (x : β) :
    M.dest q.P (corecF g x) = appendFun id (corecF g) <$$> repr (g x) := by
  rw [corecF, M.dest_corec]
set_option linter.uppercaseLean3 false in
#align mvqpf.corecF_eq MvQPF.corecF_eq

/-- Characterization of desirable equivalence relations on M-types -/
def IsPrecongr {α : TypeVec n} (r : q.P.M α → q.P.M α → Prop) : Prop :=
  ∀ ⦃x y⦄,
    r x y →
      abs (appendFun id (Quot.mk r) <$$> M.dest q.P x) =
        abs (appendFun id (Quot.mk r) <$$> M.dest q.P y)
#align mvqpf.is_precongr MvQPF.IsPrecongr

/-- Equivalence relation on M-types representing a value of type `cofix F` -/
def Mcongr {α : TypeVec n} (x y : q.P.M α) : Prop :=
  ∃ r, IsPrecongr r ∧ r x y
set_option linter.uppercaseLean3 false in
#align mvqpf.Mcongr MvQPF.Mcongr

/-- Greatest fixed point of functor F. The result is a functor with one fewer parameters
than the input. For `F a b c` a ternary functor, fix F is a binary functor such that

```lean
cofix F a b = F a b (cofix F a b)
```
-/
def Cofix (F : TypeVec (n + 1) → Type u) [q : MvQPF F] (α : TypeVec n) :=
  Quot (@Mcongr _ F q α)
#align mvqpf.cofix MvQPF.Cofix

instance {α : TypeVec n} [Inhabited q.P.A] [∀ i : Fin2 n, Inhabited (α i)] :
    Inhabited (Cofix F α) :=
  ⟨Quot.mk _ default⟩

/-- maps every element of the W type to a canonical representative -/
def mRepr {α : TypeVec n} : q.P.M α → q.P.M α :=
  corecF (abs ∘ M.dest q.P)
set_option linter.uppercaseLean3 false in
#align mvqpf.Mrepr MvQPF.mRepr

/-- the map function for the functor `cofix F` -/
def Cofix.map {α β : TypeVec n} (g : α ⟹ β) : Cofix F α → Cofix F β :=
  Quot.lift (fun x : q.P.M α => Quot.mk Mcongr (g <$$> x))
    (by
      rintro aa₁ aa₂ ⟨r, pr, ra₁a₂⟩; apply Quot.sound
      let r' b₁ b₂ := ∃ a₁ a₂ : q.P.M α, r a₁ a₂ ∧ b₁ = g <$$> a₁ ∧ b₂ = g <$$> a₂
      use r'; constructor
      · show IsPrecongr r'
        rintro b₁ b₂ ⟨a₁, a₂, ra₁a₂, b₁eq, b₂eq⟩
        let u : Quot r → Quot r' :=
          Quot.lift (fun x : q.P.M α => Quot.mk r' (g <$$> x))
            (by
              intro a₁ a₂ ra₁a₂
              apply Quot.sound
              exact ⟨a₁, a₂, ra₁a₂, rfl, rfl⟩)
        have hu : (Quot.mk r' ∘ fun x : q.P.M α => g <$$> x) = u ∘ Quot.mk r :=
          by
          ext x
          rfl
        rw [b₁eq, b₂eq, M.dest_map, M.dest_map, ← q.P.comp_map, ← q.P.comp_map]
        rw [← appendFun_comp, id_comp, hu, ← comp_id g, appendFun_comp]
        rw [q.P.comp_map, q.P.comp_map, abs_map, pr ra₁a₂, ← abs_map]
      show r' (g <$$> aa₁) (g <$$> aa₂); exact ⟨aa₁, aa₂, ra₁a₂, rfl, rfl⟩)
#align mvqpf.cofix.map MvQPF.Cofix.map

instance Cofix.mvfunctor : MvFunctor (Cofix F) where map := @Cofix.map _ _ _
#align mvqpf.cofix.mvfunctor MvQPF.Cofix.mvfunctor

/-- Corecursor for `cofix F` -/
def Cofix.corec {α : TypeVec n} {β : Type u} (g : β → F (α.append1 β)) : β → Cofix F α := fun x =>
  Quot.mk _ (corecF g x)
#align mvqpf.cofix.corec MvQPF.Cofix.corec

/-- Destructor for `cofix F` -/
def Cofix.dest {α : TypeVec n} : Cofix F α → F (α.append1 (Cofix F α)) :=
  Quot.lift (fun x => appendFun id (Quot.mk Mcongr) <$$> abs (M.dest q.P x))
    (by
      rintro x y ⟨r, pr, rxy⟩
      dsimp
      have : ∀ x y, r x y → Mcongr x y := by
        intro x y h
        exact ⟨r, pr, h⟩
      rw [← Quot.factor_mk_eq _ _ this]
      dsimp
      conv =>
        lhs
        rw [appendFun_comp_id, comp_map, ← abs_map, pr rxy, abs_map, ← comp_map, ←
          appendFun_comp_id])
#align mvqpf.cofix.dest MvQPF.Cofix.dest

/-- Abstraction function for `cofix F α` -/
def Cofix.abs {α} : q.P.M α → Cofix F α :=
  Quot.mk _
#align mvqpf.cofix.abs MvQPF.Cofix.abs

/-- Representation function for `cofix F α` -/
def Cofix.repr {α} : Cofix F α → q.P.M α :=
  M.corec _ <| q.repr ∘ Cofix.dest
#align mvqpf.cofix.repr MvQPF.Cofix.repr

/-- Corecursor for `cofix F` -/
def Cofix.corec'₁ {α : TypeVec n} {β : Type u} (g : ∀ {X}, (β → X) → F (α.append1 X)) (x : β) :
    Cofix F α :=
  Cofix.corec (fun _ => g id) x
#align mvqpf.cofix.corec'₁ MvQPF.Cofix.corec'₁

/-- More flexible corecursor for `cofix F`. Allows the return of a fully formed
value instead of making a recursive call -/
def Cofix.corec' {α : TypeVec n} {β : Type u} (g : β → F (α.append1 (Sum (Cofix F α) β))) (x : β) :
    Cofix F α :=
  let f : (α ::: Cofix F α) ⟹ (α ::: Sum (Cofix F α) β) := id ::: Sum.inl
  Cofix.corec (Sum.elim (MvFunctor.map f ∘ Cofix.dest) g) (Sum.inr x : Sum (Cofix F α) β)
#align mvqpf.cofix.corec' MvQPF.Cofix.corec'

/-- Corecursor for `cofix F`. The shape allows recursive calls to
look like recursive calls. -/
def Cofix.corec₁ {α : TypeVec n} {β : Type u}
    (g : ∀ {X}, (Cofix F α → X) → (β → X) → β → F (α ::: X)) (x : β) : Cofix F α :=
  Cofix.corec' (fun x => g Sum.inl Sum.inr x) x
#align mvqpf.cofix.corec₁ MvQPF.Cofix.corec₁

theorem Cofix.dest_corec {α : TypeVec n} {β : Type u} (g : β → F (α.append1 β)) (x : β) :
    Cofix.dest (Cofix.corec g x) = appendFun id (Cofix.corec g) <$$> g x := by
  conv =>
    lhs
    rw [Cofix.dest, Cofix.corec];
  dsimp
  rw [corecF_eq, abs_map, abs_repr, ← comp_map, ← appendFun_comp]; rfl
#align mvqpf.cofix.dest_corec MvQPF.Cofix.dest_corec

/-- constructor for `cofix F` -/
def Cofix.mk {α : TypeVec n} : F (α.append1 <| Cofix F α) → Cofix F α :=
  Cofix.corec fun x => (appendFun id fun i : Cofix F α => Cofix.dest.{u} i) <$$> x
#align mvqpf.cofix.mk MvQPF.Cofix.mk

/-!
## Bisimulation principles for `cofix F`

The following theorems are bisimulation principles. The general idea
is to use a bisimulation relation to prove the equality between
specific values of type `cofix F α`.

A bisimulation relation `R` for values `x y : cofix F α`:

 * holds for `x y`: `R x y`
 * for any values `x y` that satisfy `R`, their root has the same shape
   and their children can be paired in such a way that they satisfy `R`.

-/

private theorem Cofix.bisim_aux {α : TypeVec n} (r : Cofix F α → Cofix F α → Prop) (h' : ∀ x, r x x)
    (h :
      ∀ x y,
        r x y →
          appendFun id (Quot.mk r) <$$> Cofix.dest x = appendFun id (Quot.mk r) <$$> Cofix.dest y) :
    ∀ x y, r x y → x = y := by
  intro x
  rcases x; clear x; rename M (P F) α => x;
  intro y
  rcases y; clear y; rename M (P F) α => y;
  intro rxy
  apply Quot.sound
  let r' := fun x y => r (Quot.mk _ x) (Quot.mk _ y)
  have hr' : r' = fun x y => r (Quot.mk _ x) (Quot.mk _ y) := by rfl;

  have : IsPrecongr r' := by
    intro a b r'ab
    have h₀ :
      appendFun id (Quot.mk r ∘ Quot.mk Mcongr) <$$> MvQPF.abs (M.dest q.P a) =
        appendFun id (Quot.mk r ∘ Quot.mk Mcongr) <$$> MvQPF.abs (M.dest q.P b) :=
      by rw [appendFun_comp_id, comp_map, comp_map]; exact h _ _ r'ab
    have h₁ : ∀ u v : q.P.M α, Mcongr u v → Quot.mk r' u = Quot.mk r' v :=
      by
      intro u v cuv
      apply Quot.sound
      dsimp [hr']
      rw [Quot.sound cuv]
      apply h'
    let f : Quot r → Quot r' :=
      Quot.lift (Quot.lift (Quot.mk r') h₁)
        (by
          intro c;
          apply Quot.inductionOn
                  (motive := fun c => ∀b, r c b → Quot.lift (Quot.mk r') h₁ c = Quot.lift (Quot.mk r') h₁ b)
                  c;
          clear c
          intro c d
          apply Quot.inductionOn
                  (motive := fun d => r (Quot.mk Mcongr c) d → Quot.lift (Quot.mk r') h₁ (Quot.mk Mcongr c) = Quot.lift (Quot.mk r') h₁ d)
                  d
          clear d
          intro d rcd; apply Quot.sound; apply rcd)
    have : f ∘ Quot.mk r ∘ Quot.mk Mcongr = Quot.mk r' := rfl
    rw [← this, appendFun_comp_id, q.P.comp_map, q.P.comp_map, abs_map, abs_map, abs_map, abs_map,
      h₀]
  refine' ⟨r', this, rxy⟩

/-- Bisimulation principle using `map` and `Quot.mk` to match and relate children of two trees. -/
theorem Cofix.bisim_rel {α : TypeVec n} (r : Cofix F α → Cofix F α → Prop)
    (h :
      ∀ x y,
        r x y →
          appendFun id (Quot.mk r) <$$> Cofix.dest x = appendFun id (Quot.mk r) <$$> Cofix.dest y) :
    ∀ x y, r x y → x = y := by
  let r' (x y) := x = y ∨ r x y
  intro x y rxy
  apply Cofix.bisim_aux r'
  · intro x
    left
    rfl
  · intro x y r'xy
    cases r'xy
    case inl h =>
      rw [h]
    case inr r'xy =>
      have : ∀ x y, r x y → r' x y := fun x y h => Or.inr h
      rw [← Quot.factor_mk_eq _ _ this]
      dsimp
      rw [appendFun_comp_id]
      rw [@comp_map _ _ q _ _ _ (appendFun id (Quot.mk r)),
        @comp_map _ _ q _ _ _ (appendFun id (Quot.mk r))]
      rw [h _ _ r'xy]
  right; exact rxy
#align mvqpf.cofix.bisim_rel MvQPF.Cofix.bisim_rel

/-- Bisimulation principle using `liftr` to match and relate children of two trees. -/
theorem Cofix.bisim {α : TypeVec n} (r : Cofix F α → Cofix F α → Prop)
    (h : ∀ x y, r x y → LiftR (RelLast α r (i:=_)) (Cofix.dest x) (Cofix.dest y)) : ∀ x y, r x y → x = y :=
  by
  apply Cofix.bisim_rel
  intro x y rxy
  rcases (liftR_iff (fun a b => RelLast α r a b) (dest x) (dest y)).mp (h x y rxy)
    with ⟨a, f₀, f₁, dxeq, dyeq, h'⟩
  rw [dxeq, dyeq, ← abs_map, ← abs_map, MvPFunctor.map_eq, MvPFunctor.map_eq]
  rw [← split_dropFun_lastFun f₀, ← split_dropFun_lastFun f₁]
  rw [appendFun_comp_splitFun, appendFun_comp_splitFun]
  rw [id_comp, id_comp]
  congr 2 with (i j); cases' i with _ i <;> dsimp
  · apply Quot.sound
    apply h' _ j
  · change f₀ _ j = f₁ _ j
    apply h' _ j
#align mvqpf.cofix.bisim MvQPF.Cofix.bisim

open MvFunctor

/-- Bisimulation principle using `liftr'` to match and relate children of two trees. -/
theorem Cofix.bisim₂ {α : TypeVec n} (r : Cofix F α → Cofix F α → Prop)
    (h : ∀ x y, r x y → LiftR' (RelLast' α r) (Cofix.dest x) (Cofix.dest y)) :
    ∀ x y, r x y → x = y :=
  Cofix.bisim r <| by intros; rw [← LiftR_RelLast_iff]; apply h; assumption
#align mvqpf.cofix.bisim₂ MvQPF.Cofix.bisim₂

/-- Bisimulation principle the values `⟨a,f⟩` of the polynomial functor representing
`cofix F α` as well as an invariant `Q : β → Prop` and a state `β` generating the
left-hand side and right-hand side of the equality through functions `u v : β → cofix F α` -/
theorem Cofix.bisim' {α : TypeVec n} {β : Type _} (Q : β → Prop) (u v : β → Cofix F α)
    (h :
      ∀ x,
        Q x →
          ∃ a f' f₀ f₁,
            Cofix.dest (u x) = q.abs ⟨a, q.P.appendContents f' f₀⟩ ∧
              Cofix.dest (v x) = q.abs ⟨a, q.P.appendContents f' f₁⟩ ∧
                ∀ i, ∃ x', Q x' ∧ f₀ i = u x' ∧ f₁ i = v x') :
    ∀ x, Q x → u x = v x := fun x Qx =>
  let R := fun w z : Cofix F α => ∃ x', Q x' ∧ w = u x' ∧ z = v x'
  Cofix.bisim R
    (fun x y ⟨x', Qx', xeq, yeq⟩ =>
      by
      rcases h x' Qx' with ⟨a, f', f₀, f₁, ux'eq, vx'eq, h'⟩
      rw [liftR_iff]
      refine'
        ⟨a, q.P.appendContents f' f₀, q.P.appendContents f' f₁, xeq.symm ▸ ux'eq,
          yeq.symm ▸ vx'eq, _⟩
      intro i; cases i
      · apply h'
      · intro j
        apply Eq.refl)
    _ _ ⟨x, Qx, rfl, rfl⟩
#align mvqpf.cofix.bisim' MvQPF.Cofix.bisim'

theorem Cofix.mk_dest {α : TypeVec n} (x : Cofix F α) : Cofix.mk (Cofix.dest x) = x := by
  apply Cofix.bisim_rel (fun x y : Cofix F α => x = Cofix.mk (Cofix.dest y)) _ _ _ rfl;
  dsimp
  intro x y h
  rw [h]
  conv =>
    lhs
    congr
    rfl
    rw [Cofix.mk]
    rw [Cofix.dest_corec]
  rw [← comp_map, ← appendFun_comp, id_comp]
  rw [← comp_map, ← appendFun_comp, id_comp, ← Cofix.mk]
  congr
  apply congrArg
  funext x
  apply Quot.sound;
  rfl
#align mvqpf.cofix.mk_dest MvQPF.Cofix.mk_dest

theorem Cofix.dest_mk {α : TypeVec n} (x : F (α.append1 <| Cofix F α)) :
    Cofix.dest (Cofix.mk x) = x := by
  have : Cofix.mk ∘ Cofix.dest = @_root_.id (Cofix F α) := funext Cofix.mk_dest
  rw [Cofix.mk, Cofix.dest_corec, ← comp_map, ← Cofix.mk, ← appendFun_comp, this, id_comp,
    appendFun_id_id, MvFunctor.id_map]
#align mvqpf.cofix.dest_mk MvQPF.Cofix.dest_mk

theorem Cofix.ext {α : TypeVec n} (x y : Cofix F α) (h : x.dest = y.dest) : x = y := by
  rw [← Cofix.mk_dest x, h, Cofix.mk_dest]
#align mvqpf.cofix.ext MvQPF.Cofix.ext

theorem Cofix.ext_mk {α : TypeVec n} (x y : F (α ::: Cofix F α)) (h : Cofix.mk x = Cofix.mk y) :
    x = y := by rw [← Cofix.dest_mk x, h, Cofix.dest_mk]
#align mvqpf.cofix.ext_mk MvQPF.Cofix.ext_mk

/-!
`liftr_map`, `liftr_map_last` and `liftr_map_last'` are useful for reasoning about
the induction step in bisimulation proofs.
-/

section LiftRMap

theorem liftR_map {α β : TypeVec n} {F' : TypeVec n → Type u} [MvFunctor F'] [LawfulMvFunctor F']
    (R : β ⊗ β ⟹ «repeat» n Prop) (x : F' α) (f g : α ⟹ β) (h : α ⟹ Subtype_ R)
    (hh : subtypeVal _ ⊚ h = (f ⊗' g) ⊚ prod.diag) : LiftR' R (f <$$> x) (g <$$> x) := by
  rw [LiftR_def]
  exists h <$$> x
  rw [MvFunctor.map_map, comp_assoc, hh, ← comp_assoc, fst_prod_mk, comp_assoc, fst_diag]
  rw [MvFunctor.map_map, comp_assoc, hh, ← comp_assoc, snd_prod_mk, comp_assoc, snd_diag]
  dsimp [LiftR']; constructor <;> rfl
#align mvqpf.liftr_map MvQPF.liftR_map

open Function

theorem liftR_map_last [lawful: @LawfulMvFunctor _ F q.toMvFunctor]
    {α : TypeVec n} {ι ι'} (R : ι' → ι' → Prop)
    (x : F (α ::: ι)) (f g : ι → ι') (hh : ∀ x : ι, R (f x) (g x)) :
    LiftR' (RelLast' _ R) ((id ::: f) <$$> x) ((id ::: g) <$$> x) :=
by
  stop
  let h : ι → { x : ι' × ι' // uncurry R x } := fun x => ⟨(f x, g x), hh x⟩
  have h' : h = fun x => ⟨(f x, g x), hh x⟩ := rfl
  let b : (α ::: ι) ⟹ _ := @diagSub n α ::: h
  have b' : b = (@diagSub n α ::: h) := rfl
  let c :
    (Subtype_ α.repeatEq ::: { x // uncurry R x }) ⟹
      ((fun i : Fin2 n => { x // ofRepeat (α.RelLast' R i.fs x) }) ::: Subtype (uncurry R)) :=
    ofSubtype _ ::: id
  have c' : c = (ofSubtype _ ::: _root_.id) := rfl;
  have hh :
    subtypeVal _ ⊚ toSubtype _ ⊚ fromAppend1DropLast ⊚ c ⊚ b =
      ((id ::: f) ⊗' (id ::: g)) ⊚ prod.diag :=
    by
    dsimp [c', b']
    apply eq_of_drop_last_eq
    · dsimp
      simp only [prod_map_id, dropFun_prod, dropFun_appendFun, dropFun_diag, id_comp,
        dropFun_toSubtype]
      erw [toSubtype_of_subtype_assoc, id_comp]
      clear liftR_map_last q mvf lawful F x R f g hh h h' b b' c c';
      ext (i x) : 2
      induction i with
      | fz => rfl
      | fs _ ih =>
        apply ih
    simp only [h', lastFun_from_append1_drop_last, lastFun_toSubtype, lastFun_appendFun,
      lastFun_subtypeVal, comp.left_id, lastFun_comp, lastFun_prod]
    dsimp
    ext1
    rfl
  -- liftR_map _ _ _ _ (toSubtype _ ⊚ fromAppend1DropLast ⊚ c ⊚ b) hh
#align mvqpf.liftr_map_last MvQPF.liftR_map_last

theorem liftR_map_last' [LawfulMvFunctor F] {α : TypeVec n} {ι} (R : ι → ι → Prop) (x : F (α ::: ι))
    (f : ι → ι) (hh : ∀ x : ι, R (f x) x) : LiftR' (RelLast' _ R) ((id ::: f) <$$> x) x := by
  have := liftR_map_last R x f id hh
  rwa [appendFun_id_id, MvFunctor.id_map] at this
#align mvqpf.liftr_map_last' MvQPF.liftR_map_last'

end LiftRMap

-- variable {F: TypeVec (n + 1) → Type u} [q : MvQPF F]

theorem Cofix.abs_repr {α} (x : Cofix F α) : Quot.mk Mcongr (Cofix.repr x) = x := by
  let R := fun x y : Cofix F α => abs (repr y) = x
  refine' Cofix.bisim₂ R _ _ _ rfl
  clear x;
  rintro x y h;
  subst h
  dsimp [Cofix.dest, Cofix.abs]

  induction y using Quot.ind
  simp only [Cofix.repr, M.dest_corec, abs_map, MvQPF.abs_repr, Function.comp]

  conv =>
    congr
    rfl
    rw [Cofix.dest]

  rw [MvFunctor.map_map, MvFunctor.map_map, ←appendFun_comp_id, ←appendFun_comp_id]

  apply liftR_map_last
  intros
  rfl
#align mvqpf.cofix.abs_repr MvQPF.Cofix.abs_repr

instance mvqpfCofix : MvQPF (Cofix F) where
  P         := q.P.mp
  abs       := Quot.mk Mcongr
  repr      := Cofix.repr
  abs_repr  := Cofix.abs_repr
  abs_map   := by intros; rfl
#align mvqpf.mvqpf_cofix MvQPF.mvqpfCofix

end MvQPF

-- namespace MvQPF
--   variable (F: TypeFun <| n + 1) [p: IsPolynomial F]

--   instance isPolynomialCofix : IsPolynomial (Cofix F) where
--     repr_abs :=
--     by
--       intro α x
--       simp

-- end MvQPF


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Mathlib.CategoryTheory.Category.Basic
import Mathlib.CategoryTheory.Functor.Basic
import Mathlib.CategoryTheory.Functor.Category
import Mathlib.CategoryTheory.NatTrans

import Moncalc.Data.DVect2.Basic
import Moncalc.CategoryTheory.List.Basic

/-!
# The 2-functor structure on `List`

As constructed in `CategoryTheory.List.Basic`, `List α` is a `Category` provided so is `α`.
Furthermore, it is actually a 2-functor; i.e. there are the following data:

  - A functor `mapF : Functor α β ⥤ Functor (List α) (List β)`, which is defined in [here](CategoryTheory/List/Basic.lean);
  - A natural isomorphism `mapF.unitor : 𝟭 (List α) ≅ mapF.obj (𝟭 α)`;
  - A natural isomorphism `mapF.compositor : mapF.obj F ⋙ mapF.obj ≅ mapF.obj (F ⋙ G)`.

These are supposed to satisfy the following conditions:

  - `mapF.naturality₂ : ∀ {F₁ F₂ : α → β} {G₁ G₂ : β → γ} (φ : F₁ ⟶ F₂) (ψ : G₁ → G₂), (mapF.map φ ◫ mapF.map ψ) ≫ mapF.compositor F₂ G₂ = mapF.compositor F₁ G₁ ≫ mapF.map (φ ◫ ψ)` as natural transformations `mapF.obj F₁ ⋙ mapF.obj G₁ ⟶ mapF.obj (F₂ ⋙ G₂)`.
  - the coherences for `mapF.unitor` and `mapF.compositor`.
-/

namespace CategoryTheory.List

universe u v w

namespace mapF

/-!
## Unitor

A natural isomorphism `mapF.obj (𝟭 α) ≅ 𝟭 (List α)` that realizes the equality `mapF.obj_id`.
-/
section unitor

variable {α : Type u} [Category α]

--- The body of the unitor in the "lax" functor direction
protected
def unitorLax : (as : List α) → Hom as ((mapF.obj (𝟭 α)).obj as)
| [] => DVect2.nil
| (a::as) => DVect2.cons (𝟙 a) (mapF.unitorLax as)

--- The body of the unitor in the "oplax" functor direction
protected
def unitorOplax : (as : List α) → Hom ((mapF.obj (𝟭 α)).obj as) as
| [] => DVect2.nil
| (a::as) => DVect2.cons (𝟙 a) (mapF.unitorOplax as)

--- The lax unitor is a right inverse to the oplax unitor.
@[simp]
protected
theorem unitor_lax_oplax (as : List α) : mapF.unitorLax as ≫ mapF.unitorOplax as = 𝟙 as := by
  induction as
  case nil => rfl
  case cons a as h_ind =>
    dsimp [mapF.unitorLax, mapF.unitorOplax, List.id, DVect2.fromList]
    rw [h_ind, Category.id_comp]

--- The lax unitor is a left inverse to the oplax unitor.
@[simp]
protected
theorem unitor_oplax_lax (as : List α) : mapF.unitorOplax as ≫ mapF.unitorLax as = 𝟙 ((mapF.obj (𝟭 α)).obj as) := by
  induction as
  case nil => rfl
  case cons a as h_ind =>
    dsimp [mapF.unitorLax, mapF.unitorOplax, List.id, DVect2.fromList]
    rw [h_ind, Category.id_comp]

--- The unitor of the 2-functor `(List, List.mapF)`.
protected
def unitor : 𝟭 (List α) ≅ mapF.obj (𝟭 α) where
  hom := {
    app := mapF.unitorLax
    naturality := by
      intro as bs fs
      induction fs
      case nil => rfl
      case cons f fs h_ind =>
        dsimp [mapF, mapF.unitorLax, DVect2.map] at *
        rw [h_ind, Category.id_comp, Category.comp_id]
  }
  inv := {
    app := mapF.unitorOplax
    naturality := by
      intro as bs fs
      induction fs
      case nil => rfl
      case cons f fs h_ind =>
        dsimp [mapF, mapF.unitorOplax, DVect2.map] at *
        rw [h_ind, Category.id_comp, Category.comp_id]
  }
  hom_inv_id := by ext; intros; simp
  inv_hom_id := by ext; intros; simp

end unitor

/-!
## Compositor

A natural isomorphism `mapF.obj F ⋙ mapF.obj G ≅ mapF.obj (F ⋙ G)` that realizes the equality `mapF.obj_comp`.
-/

section compositor

variable {α : Type u} [Category α] {β : Type v} [Category β] {γ : Type w} [Category γ] (F : Functor α β) (G : Functor β γ)

protected
def compositorLax : (as : List α) → Hom ((mapF.obj F ⋙ mapF.obj G).obj as) ((mapF.obj (F ⋙ G)).obj as)
| [] => DVect2.nil
| (_::as) => DVect2.cons (𝟙 _) (mapF.compositorLax as)

protected
def compositorOplax : (as : List α) → Hom ((mapF.obj (F ⋙ G)).obj as) ((mapF.obj F ⋙ mapF.obj G).obj as)
| [] => DVect2.nil
| (_::as) => DVect2.cons (𝟙 _) (mapF.compositorOplax as)

@[simp]
protected
theorem compositor_lax_oplax (as : List α) : mapF.compositorLax F G as ≫ mapF.compositorOplax F G as = 𝟙 ((mapF.obj F ⋙ mapF.obj G).obj as) := by
  induction as
  case nil => rfl
  case cons a as h_ind =>
    dsimp [mapF.compositorLax, mapF.compositorOplax]
    rw [h_ind, Category.id_comp]
    rfl

@[simp]
protected
theorem compositor_oplax_lax (as : List α) : mapF.compositorOplax F G as ≫ mapF.compositorLax F G as = 𝟙 ((mapF.obj (F ⋙ G)).obj as) := by
  induction as
  case nil => rfl
  case cons a as h_ind =>
  dsimp [mapF.compositorLax, mapF.compositorOplax]
  rw [h_ind, Category.id_comp]

protected
def compositor : mapF.obj F ⋙ mapF.obj G ≅ mapF.obj (F ⋙ G) where
  hom := {
    app := mapF.compositorLax F G
    naturality := by
      intro as bs fs
      induction fs
      case nil => rfl
      case cons f fs h_ind =>
        dsimp [mapF.compositorLax] at *
        rw [h_ind, Category.id_comp, Category.comp_id]
  }
  inv := {
    app := mapF.compositorOplax F G
    naturality := by
      intro as bs fs
      induction fs
      case nil => rfl
      case cons f fs h_ind =>
        dsimp [mapF.compositorOplax]
        rw [h_ind, Category.id_comp, Category.comp_id]
        rfl
  }
  hom_inv_id := by ext; intros; simp
  inv_hom_id := by ext; intros; simp

end compositor

/-!
## Coherences
-/

--- Compatibility of `mapF.compositor` with the horizontal composition `hcomp`.
protected
theorem naturality₂ {α : Type u} [Category α] {β : Type v} [Category β] {γ :Type w} [Category γ] {F₁ F₂ : Functor α β} {G₁ G₂ : Functor β γ} (φ : F₁ ⟶ F₂) (ψ : G₁ ⟶ G₂) : (mapF.map φ ◫ mapF.map ψ) ≫ (mapF.compositor F₂ G₂).hom = (mapF.compositor F₁ G₁).hom ≫ mapF.map (φ ◫ ψ) := by
  ext as
  induction as
  case nil => rfl
  case cons a as h_ind =>
    dsimp [mapF.compositor, mapF.compositorLax] at *
    rw [h_ind, Category.id_comp, Category.comp_id]

--! TO DO: more coherences

end mapF

end CategoryTheory.List


/-
Copyright (c) 2020 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import algebra.hom.aut
import logic.function.basic
import group_theory.subgroup.basic

/-!
# Semidirect product

This file defines semidirect products of groups, and the canonical maps in and out of the
semidirect product. The semidirect product of `N` and `G` given a hom `φ` from
`G` to the automorphism group of `N` is the product of sets with the group
`⟨n₁, g₁⟩ * ⟨n₂, g₂⟩ = ⟨n₁ * φ g₁ n₂, g₁ * g₂⟩`

## Key definitions

There are two homs into the semidirect product `inl : N →* N ⋊[φ] G` and
`inr : G →* N ⋊[φ] G`, and `lift` can be used to define maps `N ⋊[φ] G →* H`
out of the semidirect product given maps `f₁ : N →* H` and `f₂ : G →* H` that satisfy the
condition `∀ n g, f₁ (φ g n) = f₂ g * f₁ n * f₂ g⁻¹`

## Notation

This file introduces the global notation `N ⋊[φ] G` for `semidirect_product N G φ`

## Tags
group, semidirect product
-/
variables (N : Type*) (G : Type*) {H : Type*} [group N] [group G] [group H]

/-- The semidirect product of groups `N` and `G`, given a map `φ` from `G` to the automorphism
  group of `N`. It the product of sets with the group operation
  `⟨n₁, g₁⟩ * ⟨n₂, g₂⟩ = ⟨n₁ * φ g₁ n₂, g₁ * g₂⟩` -/
@[ext, derive decidable_eq]
structure semidirect_product (φ : G →* mul_aut N) :=
(left : N) (right : G)

attribute [pp_using_anonymous_constructor] semidirect_product

notation N` ⋊[`:35 φ:35`] `:0 G :35 := semidirect_product N G φ

namespace semidirect_product

variables {N G} {φ : G →* mul_aut N}

private def one_aux : N ⋊[φ] G := ⟨1, 1⟩
private def mul_aux (a b : N ⋊[φ] G) : N ⋊[φ] G := ⟨a.1 * φ a.2 b.1, a.right * b.right⟩
private def inv_aux (a : N ⋊[φ] G) : N ⋊[φ] G := let i := a.2⁻¹ in ⟨φ i a.1⁻¹, i⟩
private lemma mul_assoc_aux (a b c : N ⋊[φ] G) :
  mul_aux (mul_aux a b) c = mul_aux a (mul_aux b c) :=
by simp [mul_aux, mul_assoc, mul_equiv.map_mul]
private lemma mul_one_aux (a : N ⋊[φ] G) : mul_aux a one_aux = a :=
by cases a; simp [mul_aux, one_aux]
private lemma one_mul_aux (a : N ⋊[φ] G) : mul_aux one_aux a = a :=
by cases a; simp [mul_aux, one_aux]
private lemma mul_left_inv_aux (a : N ⋊[φ] G) : mul_aux (inv_aux a) a = one_aux :=
by simp only [mul_aux, inv_aux, one_aux, ← mul_equiv.map_mul, mul_left_inv]; simp

instance : group (N ⋊[φ] G) :=
{ one := one_aux,
  inv := inv_aux,
  mul := mul_aux,
  mul_assoc := mul_assoc_aux,
  one_mul := one_mul_aux,
  mul_one := mul_one_aux,
  mul_left_inv := mul_left_inv_aux }

instance : inhabited (N ⋊[φ] G) := ⟨1⟩

@[simp] lemma one_left : (1 : N ⋊[φ] G).left = 1 := rfl
@[simp] lemma one_right : (1 : N ⋊[φ] G).right = 1 := rfl
@[simp] lemma inv_left (a : N ⋊[φ] G) : (a⁻¹).left = φ a.right⁻¹ a.left⁻¹ := rfl
@[simp] lemma inv_right (a : N ⋊[φ] G) : (a⁻¹).right = a.right⁻¹ := rfl
@[simp] lemma mul_left (a b : N ⋊[φ] G) : (a * b).left = a.left * φ a.right b.left := rfl
@[simp] lemma mul_right (a b : N ⋊[φ] G) : (a * b).right = a.right * b.right := rfl

/-- The canonical map `N →* N ⋊[φ] G` sending `n` to `⟨n, 1⟩` -/
def inl : N →* N ⋊[φ] G :=
{ to_fun := λ n, ⟨n, 1⟩,
  map_one' := rfl,
  map_mul' := by intros; ext; simp }

@[simp] lemma left_inl (n : N) : (inl n : N ⋊[φ] G).left = n := rfl
@[simp] lemma right_inl (n : N) : (inl n : N ⋊[φ] G).right = 1 := rfl

lemma inl_injective : function.injective (inl : N → N ⋊[φ] G) :=
function.injective_iff_has_left_inverse.2 ⟨left, left_inl⟩

@[simp] lemma inl_inj {n₁ n₂ : N} : (inl n₁ : N ⋊[φ] G) = inl n₂ ↔ n₁ = n₂ :=
inl_injective.eq_iff

/-- The canonical map `G →* N ⋊[φ] G` sending `g` to `⟨1, g⟩` -/
def inr : G →* N ⋊[φ] G :=
{ to_fun := λ g, ⟨1, g⟩,
  map_one' := rfl,
  map_mul' := by intros; ext; simp }

@[simp] lemma left_inr (g : G) : (inr g : N ⋊[φ] G).left = 1 := rfl
@[simp] lemma right_inr (g : G) : (inr g : N ⋊[φ] G).right = g := rfl

lemma inr_injective : function.injective (inr : G → N ⋊[φ] G) :=
function.injective_iff_has_left_inverse.2 ⟨right, right_inr⟩

@[simp] lemma inr_inj {g₁ g₂ : G} : (inr g₁ : N ⋊[φ] G) = inr g₂ ↔ g₁ = g₂ :=
inr_injective.eq_iff

lemma inl_aut (g : G) (n : N) : (inl (φ g n) : N ⋊[φ] G) = inr g * inl n * inr g⁻¹ :=
by ext; simp

lemma inl_aut_inv (g : G) (n : N) : (inl ((φ g)⁻¹ n) : N ⋊[φ] G) = inr g⁻¹ * inl n * inr g :=
by rw [← monoid_hom.map_inv, inl_aut, inv_inv]

@[simp]

@[simp] lemma inl_left_mul_inr_right (x : N ⋊[φ] G) : inl x.left * inr x.right = x :=

by ext; simp

/-- The canonical projection map `N ⋊[φ] G →* G`, as a group hom. -/
def right_hom : N ⋊[φ] G →* G :=
{ to_fun := semidirect_product.right,
  map_one' := rfl,
  map_mul' := λ _ _, rfl }

@[simp] lemma right_hom_eq_right : (right_hom :  N ⋊[φ] G → G) = right := rfl

@[simp] lemma right_hom_comp_inl : (right_hom : N ⋊[φ] G →* G).comp inl = 1 :=
by ext; simp [right_hom]

@[simp] lemma right_hom_comp_inr : (right_hom : N ⋊[φ] G →* G).comp inr = monoid_hom.id _ :=
by ext; simp [right_hom]

@[simp] lemma right_hom_inl (n : N) : right_hom (inl n : N ⋊[φ] G) = 1 :=
by simp [right_hom]

@[simp] lemma right_hom_inr (g : G) : right_hom (inr g : N ⋊[φ] G) = g :=
by simp [right_hom]

lemma right_hom_surjective : function.surjective (right_hom : N ⋊[φ] G → G) :=
function.surjective_iff_has_right_inverse.2 ⟨inr, right_hom_inr⟩

lemma range_inl_eq_ker_right_hom : (inl : N →* N ⋊[φ] G).range = right_hom.ker :=
le_antisymm
  (λ _, by simp [monoid_hom.mem_ker, eq_comm] {contextual := tt})
  (λ x hx, ⟨x.left, by ext; simp [*, monoid_hom.mem_ker] at *⟩)

section lift
variables (f₁ : N →* H) (f₂ : G →* H)
  (h : ∀ g, f₁.comp (φ g).to_monoid_hom = (mul_aut.conj (f₂ g)).to_monoid_hom.comp f₁)

/-- Define a group hom `N ⋊[φ] G →* H`, by defining maps `N →* H` and `G →* H`  -/
def lift (f₁ : N →* H) (f₂ : G →* H)
  (h : ∀ g, f₁.comp (φ g).to_monoid_hom = (mul_aut.conj (f₂ g)).to_monoid_hom.comp f₁) :
  N ⋊[φ] G →* H :=
{ to_fun := λ a, f₁ a.1 * f₂ a.2,
  map_one' := by simp,
  map_mul' := λ a b, begin
    have := λ n g, monoid_hom.ext_iff.1 (h n) g,
    simp only [mul_aut.conj_apply, monoid_hom.comp_apply, mul_equiv.coe_to_monoid_hom] at this,
    simp [this, mul_assoc]
  end }

@[simp] lemma lift_inl (n : N) : lift f₁ f₂ h (inl n) = f₁ n := by simp [lift]
@[simp] lemma lift_comp_inl : (lift f₁ f₂ h).comp inl = f₁ := by ext; simp

@[simp] lemma lift_inr (g : G) : lift f₁ f₂ h (inr g) = f₂ g := by simp [lift]
@[simp] lemma lift_comp_inr : (lift f₁ f₂ h).comp inr = f₂ := by ext; simp

lemma lift_unique (F : N ⋊[φ] G →* H) :
  F = lift (F.comp inl) (F.comp inr) (λ _, by ext; simp [inl_aut]) :=
begin
  ext,
  simp only [lift, monoid_hom.comp_apply, monoid_hom.coe_mk],
  rw [← F.map_mul, inl_left_mul_inr_right],
end

/-- Two maps out of the semidirect product are equal if they're equal after composition
  with both `inl` and `inr` -/
lemma hom_ext {f g : (N ⋊[φ] G) →* H} (hl : f.comp inl = g.comp inl)
  (hr : f.comp inr = g.comp inr) : f = g :=
by { rw [lift_unique f, lift_unique g], simp only * }

end lift

section map

variables {N₁ : Type*} {G₁ : Type*} [group N₁] [group G₁] {φ₁ : G₁ →* mul_aut N₁}

/-- Define a map from `N ⋊[φ] G` to `N₁ ⋊[φ₁] G₁` given maps `N →* N₁` and `G →* G₁` that
  satisfy a commutativity condition `∀ n g, f₁ (φ g n) = φ₁ (f₂ g) (f₁ n)`.  -/
def map (f₁ : N →* N₁) (f₂ : G →* G₁)
  (h : ∀ g : G, f₁.comp (φ g).to_monoid_hom = (φ₁ (f₂ g)).to_monoid_hom.comp f₁) :
  N ⋊[φ] G →* N₁ ⋊[φ₁] G₁ :=
{ to_fun := λ x, ⟨f₁ x.1, f₂ x.2⟩,
  map_one' := by simp,
  map_mul' := λ x y, begin
    replace h := monoid_hom.ext_iff.1 (h x.right) y.left,
    ext; simp * at *,
  end }

variables (f₁ : N →* N₁) (f₂ : G →* G₁)
  (h : ∀ g : G, f₁.comp (φ g).to_monoid_hom = (φ₁ (f₂ g)).to_monoid_hom.comp f₁)

@[simp] lemma map_left (g : N ⋊[φ] G) : (map f₁ f₂ h g).left = f₁ g.left := rfl

@[simp] lemma map_right (g : N ⋊[φ] G) : (map f₁ f₂ h g).right = f₂ g.right := rfl

@[simp] lemma right_hom_comp_map : right_hom.comp (map f₁ f₂ h) = f₂.comp right_hom := rfl

@[simp] lemma map_inl (n : N) : map f₁ f₂ h (inl n) = inl (f₁ n) :=
by simp [map]

@[simp] lemma map_comp_inl : (map f₁ f₂ h).comp inl = inl.comp f₁ :=
by ext; simp

@[simp] lemma map_inr (g : G) : map f₁ f₂ h (inr g) = inr (f₂ g) :=
by simp [map]

@[simp] lemma map_comp_inr : (map f₁ f₂ h).comp inr = inr.comp f₂ :=
by ext; simp [map]

end map

end semidirect_product