/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker, Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.basic
import Mathlib.data.polynomial.div
import Mathlib.data.polynomial.algebra_map
import Mathlib.data.set.finite
import Mathlib.PostPort

universes u v u_1

namespace Mathlib

/-!
# Theory of univariate polynomials

This file starts looking like the ring theory of $ R[X] $

-/

namespace polynomial

theorem nat_degree_pos_of_aeval_root {R : Type u} {S : Type v} [comm_ring R] [comm_ring S] [algebra R S] {p : polynomial R} (hp : p ≠ 0) {z : S} (hz : coe_fn (aeval z) p = 0) (inj : ∀ (x : R), coe_fn (algebra_map R S) x = 0 → x = 0) : 0 < nat_degree p :=
  nat_degree_pos_of_eval₂_root hp (algebra_map R S) hz inj

theorem degree_pos_of_aeval_root {R : Type u} {S : Type v} [comm_ring R] [comm_ring S] [algebra R S] {p : polynomial R} (hp : p ≠ 0) {z : S} (hz : coe_fn (aeval z) p = 0) (inj : ∀ (x : R), coe_fn (algebra_map R S) x = 0 → x = 0) : 0 < degree p :=
  iff.mp nat_degree_pos_iff_degree_pos (nat_degree_pos_of_aeval_root hp hz inj)

theorem aeval_mod_by_monic_eq_self_of_root {R : Type u} {S : Type v} [comm_ring R] [comm_ring S] [algebra R S] {p : polynomial R} {q : polynomial R} (hq : monic q) {x : S} (hx : coe_fn (aeval x) q = 0) : coe_fn (aeval x) (p %ₘ q) = coe_fn (aeval x) p :=
  eval₂_mod_by_monic_eq_self_of_root hq hx

protected instance integral_domain {R : Type u} [integral_domain R] : integral_domain (polynomial R) :=
  integral_domain.mk comm_ring.add sorry comm_ring.zero sorry sorry comm_ring.neg comm_ring.sub sorry sorry comm_ring.mul
    sorry comm_ring.one sorry sorry sorry sorry sorry sorry sorry

theorem nat_degree_mul {R : Type u} [integral_domain R] {p : polynomial R} {q : polynomial R} (hp : p ≠ 0) (hq : q ≠ 0) : nat_degree (p * q) = nat_degree p + nat_degree q := sorry

@[simp] theorem nat_degree_pow {R : Type u} [integral_domain R] (p : polynomial R) (n : ℕ) : nat_degree (p ^ n) = n * nat_degree p := sorry

theorem root_mul {R : Type u} {a : R} [integral_domain R] {p : polynomial R} {q : polynomial R} : is_root (p * q) a ↔ is_root p a ∨ is_root q a := sorry

theorem root_or_root_of_root_mul {R : Type u} {a : R} [integral_domain R] {p : polynomial R} {q : polynomial R} (h : is_root (p * q) a) : is_root p a ∨ is_root q a :=
  iff.mp root_mul h

theorem degree_le_mul_left {R : Type u} [integral_domain R] {q : polynomial R} (p : polynomial R) (hq : q ≠ 0) : degree p ≤ degree (p * q) := sorry

theorem nat_degree_le_of_dvd {R : Type u} [integral_domain R] {p : polynomial R} {q : polynomial R} (h1 : p ∣ q) (h2 : q ≠ 0) : nat_degree p ≤ nat_degree q := sorry

theorem degree_eq_zero_of_is_unit {R : Type u} [integral_domain R] {p : polynomial R} (h : is_unit p) : degree p = 0 := sorry

@[simp] theorem degree_coe_units {R : Type u} [integral_domain R] (u : units (polynomial R)) : degree ↑u = 0 :=
  degree_eq_zero_of_is_unit (Exists.intro u rfl)

theorem prime_X_sub_C {R : Type u} [integral_domain R] {r : R} : prime (X - coe_fn C r) := sorry

theorem prime_X {R : Type u} [integral_domain R] : prime X := sorry

theorem prime_of_degree_eq_one_of_monic {R : Type u} [integral_domain R] {p : polynomial R} (hp1 : degree p = 1) (hm : monic p) : prime p := sorry

theorem irreducible_X_sub_C {R : Type u} [integral_domain R] (r : R) : irreducible (X - coe_fn C r) :=
  irreducible_of_prime prime_X_sub_C

theorem irreducible_X {R : Type u} [integral_domain R] : irreducible X :=
  irreducible_of_prime prime_X

theorem irreducible_of_degree_eq_one_of_monic {R : Type u} [integral_domain R] {p : polynomial R} (hp1 : degree p = 1) (hm : monic p) : irreducible p :=
  irreducible_of_prime (prime_of_degree_eq_one_of_monic hp1 hm)

theorem eq_of_monic_of_associated {R : Type u} [integral_domain R] {p : polynomial R} {q : polynomial R} (hp : monic p) (hq : monic q) (hpq : associated p q) : p = q := sorry

@[simp] theorem root_multiplicity_zero {R : Type u} [integral_domain R] {x : R} : root_multiplicity x 0 = 0 :=
  dif_pos rfl

theorem root_multiplicity_eq_zero {R : Type u} [integral_domain R] {p : polynomial R} {x : R} (h : ¬is_root p x) : root_multiplicity x p = 0 := sorry

theorem root_multiplicity_pos {R : Type u} [integral_domain R] {p : polynomial R} (hp : p ≠ 0) {x : R} : 0 < root_multiplicity x p ↔ is_root p x := sorry

theorem root_multiplicity_mul {R : Type u} [integral_domain R] {p : polynomial R} {q : polynomial R} {x : R} (hpq : p * q ≠ 0) : root_multiplicity x (p * q) = root_multiplicity x p + root_multiplicity x q := sorry

theorem root_multiplicity_X_sub_C_self {R : Type u} [integral_domain R] {x : R} : root_multiplicity x (X - coe_fn C x) = 1 := sorry

theorem root_multiplicity_X_sub_C {R : Type u} [integral_domain R] {x : R} {y : R} : root_multiplicity x (X - coe_fn C y) = ite (x = y) 1 0 := sorry

/-- The multiplicity of `a` as root of `(X - a) ^ n` is `n`. -/
theorem root_multiplicity_X_sub_C_pow {R : Type u} [integral_domain R] (a : R) (n : ℕ) : root_multiplicity a ((X - coe_fn C a) ^ n) = n := sorry

/-- If `(X - a) ^ n` divides a polynomial `p` then the multiplicity of `a` as root of `p` is at
least `n`. -/
theorem root_multiplicity_of_dvd {R : Type u} [integral_domain R] {p : polynomial R} {a : R} {n : ℕ} (hzero : p ≠ 0) (h : (X - coe_fn C a) ^ n ∣ p) : n ≤ root_multiplicity a p := sorry

/-- The multiplicity of `p + q` is at least the minimum of the multiplicities. -/
theorem root_multiplicity_add {R : Type u} [integral_domain R] {p : polynomial R} {q : polynomial R} (a : R) (hzero : p + q ≠ 0) : min (root_multiplicity a p) (root_multiplicity a q) ≤ root_multiplicity a (p + q) :=
  root_multiplicity_of_dvd hzero (min_pow_dvd_add (pow_root_multiplicity_dvd p a) (pow_root_multiplicity_dvd q a))

theorem exists_multiset_roots {R : Type u} [integral_domain R] {p : polynomial R} (hp : p ≠ 0) : ∃ (s : multiset R), ↑(coe_fn multiset.card s) ≤ degree p ∧ ∀ (a : R), multiset.count a s = root_multiplicity a p := sorry

/-- `roots p` noncomputably gives a multiset containing all the roots of `p`,
including their multiplicities. -/
def roots {R : Type u} [integral_domain R] (p : polynomial R) : multiset R :=
  dite (p = 0) (fun (h : p = 0) => ∅) fun (h : ¬p = 0) => classical.some (exists_multiset_roots h)

@[simp] theorem roots_zero {R : Type u} [integral_domain R] : roots 0 = 0 :=
  dif_pos rfl

theorem card_roots {R : Type u} [integral_domain R] {p : polynomial R} (hp0 : p ≠ 0) : ↑(coe_fn multiset.card (roots p)) ≤ degree p := sorry

theorem card_roots' {R : Type u} [integral_domain R] {p : polynomial R} (hp0 : p ≠ 0) : coe_fn multiset.card (roots p) ≤ nat_degree p :=
  iff.mp with_bot.coe_le_coe (le_trans (card_roots hp0) (le_of_eq (degree_eq_nat_degree hp0)))

theorem card_roots_sub_C {R : Type u} [integral_domain R] {p : polynomial R} {a : R} (hp0 : 0 < degree p) : ↑(coe_fn multiset.card (roots (p - coe_fn C a))) ≤ degree p := sorry

theorem card_roots_sub_C' {R : Type u} [integral_domain R] {p : polynomial R} {a : R} (hp0 : 0 < degree p) : coe_fn multiset.card (roots (p - coe_fn C a)) ≤ nat_degree p := sorry

@[simp] theorem count_roots {R : Type u} {a : R} [integral_domain R] {p : polynomial R} (hp : p ≠ 0) : multiset.count a (roots p) = root_multiplicity a p := sorry

@[simp] theorem mem_roots {R : Type u} {a : R} [integral_domain R] {p : polynomial R} (hp : p ≠ 0) : a ∈ roots p ↔ is_root p a := sorry

theorem eq_zero_of_infinite_is_root {R : Type u} [integral_domain R] (p : polynomial R) (h : set.infinite (set_of fun (x : R) => is_root p x)) : p = 0 := sorry

theorem eq_of_infinite_eval_eq {R : Type u_1} [integral_domain R] (p : polynomial R) (q : polynomial R) (h : set.infinite (set_of fun (x : R) => eval x p = eval x q)) : p = q := sorry

theorem roots_mul {R : Type u} [integral_domain R] {p : polynomial R} {q : polynomial R} (hpq : p * q ≠ 0) : roots (p * q) = roots p + roots q := sorry

@[simp] theorem mem_roots_sub_C {R : Type u} [integral_domain R] {p : polynomial R} {a : R} {x : R} (hp0 : 0 < degree p) : x ∈ roots (p - coe_fn C a) ↔ eval x p = a := sorry

@[simp] theorem roots_X_sub_C {R : Type u} [integral_domain R] (r : R) : roots (X - coe_fn C r) = r ::ₘ 0 := sorry

@[simp] theorem roots_C {R : Type u} [integral_domain R] (x : R) : roots (coe_fn C x) = 0 := sorry

@[simp] theorem roots_one {R : Type u} [integral_domain R] : roots 1 = ∅ :=
  roots_C 1

theorem roots_list_prod {R : Type u} [integral_domain R] (L : List (polynomial R)) : (∀ (p : polynomial R), p ∈ L → p ≠ 0) → roots (list.prod L) = multiset.bind (↑L) roots := sorry

theorem roots_multiset_prod {R : Type u} [integral_domain R] (m : multiset (polynomial R)) : (∀ (p : polynomial R), p ∈ m → p ≠ 0) → roots (multiset.prod m) = multiset.bind m roots := sorry

theorem roots_prod {R : Type u} [integral_domain R] {ι : Type u_1} (f : ι → polynomial R) (s : finset ι) : finset.prod s f ≠ 0 → roots (finset.prod s f) = multiset.bind (finset.val s) fun (i : ι) => roots (f i) := sorry

theorem roots_prod_X_sub_C {R : Type u} [integral_domain R] (s : finset R) : roots (finset.prod s fun (a : R) => X - coe_fn C a) = finset.val s := sorry

theorem card_roots_X_pow_sub_C {R : Type u} [integral_domain R] {n : ℕ} (hn : 0 < n) (a : R) : coe_fn multiset.card (roots (X ^ n - coe_fn C a)) ≤ n :=
  iff.mp with_bot.coe_le_coe (trans_rel_left LessEq (card_roots (X_pow_sub_C_ne_zero hn a)) (degree_X_pow_sub_C hn a))

/-- `nth_roots n a` noncomputably returns the solutions to `x ^ n = a`-/
def nth_roots {R : Type u} [integral_domain R] (n : ℕ) (a : R) : multiset R :=
  roots (X ^ n - coe_fn C a)

@[simp] theorem mem_nth_roots {R : Type u} [integral_domain R] {n : ℕ} (hn : 0 < n) {a : R} {x : R} : x ∈ nth_roots n a ↔ x ^ n = a := sorry

@[simp] theorem nth_roots_zero {R : Type u} [integral_domain R] (r : R) : nth_roots 0 r = 0 := sorry

theorem card_nth_roots {R : Type u} [integral_domain R] (n : ℕ) (a : R) : coe_fn multiset.card (nth_roots n a) ≤ n := sorry

/-- The multiset `nth_roots ↑n (1 : R)` as a finset. -/
def nth_roots_finset (n : ℕ) (R : Type u_1) [integral_domain R] : finset R :=
  multiset.to_finset (nth_roots n 1)

@[simp] theorem mem_nth_roots_finset {R : Type u} [integral_domain R] {n : ℕ} (h : 0 < n) {x : R} : x ∈ nth_roots_finset n R ↔ x ^ n = 1 := sorry

theorem coeff_comp_degree_mul_degree {R : Type u} [integral_domain R] {p : polynomial R} {q : polynomial R} (hqd0 : nat_degree q ≠ 0) : coeff (comp p q) (nat_degree p * nat_degree q) = leading_coeff p * leading_coeff q ^ nat_degree p := sorry

theorem nat_degree_comp {R : Type u} [integral_domain R] {p : polynomial R} {q : polynomial R} : nat_degree (comp p q) = nat_degree p * nat_degree q := sorry

theorem leading_coeff_comp {R : Type u} [integral_domain R] {p : polynomial R} {q : polynomial R} (hq : nat_degree q ≠ 0) : leading_coeff (comp p q) = leading_coeff p * leading_coeff q ^ nat_degree p := sorry

theorem units_coeff_zero_smul {R : Type u} [integral_domain R] (c : units (polynomial R)) (p : polynomial R) : coeff (↑c) 0 • p = ↑c * p := sorry

@[simp] theorem nat_degree_coe_units {R : Type u} [integral_domain R] (u : units (polynomial R)) : nat_degree ↑u = 0 :=
  nat_degree_eq_of_degree_eq_some (degree_coe_units u)

theorem zero_of_eval_zero {R : Type u} [integral_domain R] [infinite R] (p : polynomial R) (h : ∀ (x : R), eval x p = 0) : p = 0 := sorry

theorem funext {R : Type u} [integral_domain R] [infinite R] {p : polynomial R} {q : polynomial R} (ext : ∀ (r : R), eval r p = eval r q) : p = q := sorry

theorem is_unit_iff {R : Type u} [integral_domain R] {f : polynomial R} : is_unit f ↔ ∃ (r : R), is_unit r ∧ coe_fn C r = f := sorry

theorem coeff_coe_units_zero_ne_zero {R : Type u} [integral_domain R] (u : units (polynomial R)) : coeff (↑u) 0 ≠ 0 := sorry

theorem degree_eq_degree_of_associated {R : Type u} [integral_domain R] {p : polynomial R} {q : polynomial R} (h : associated p q) : degree p = degree q := sorry

theorem degree_eq_one_of_irreducible_of_root {R : Type u} [integral_domain R] {p : polynomial R} (hi : irreducible p) {x : R} (hx : is_root p x) : degree p = 1 := sorry

/-- Division by a monic polynomial doesn't change the leading coefficient. -/
theorem leading_coeff_div_by_monic_of_monic {R : Type u} [integral_domain R] {p : polynomial R} {q : polynomial R} (hmonic : monic q) (hdegree : degree q ≤ degree p) : leading_coeff (p /ₘ q) = leading_coeff p := sorry

theorem eq_of_monic_of_dvd_of_nat_degree_le {R : Type u} [integral_domain R] {p : polynomial R} {q : polynomial R} (hp : monic p) (hq : monic q) (hdiv : p ∣ q) (hdeg : nat_degree q ≤ nat_degree p) : q = p := sorry

theorem is_unit_of_is_unit_leading_coeff_of_is_unit_map {R : Type u} {S : Type v} [semiring R] [integral_domain S] (φ : R →+* S) (f : polynomial R) (hf : is_unit (leading_coeff f)) (H : is_unit (map φ f)) : is_unit f := sorry

/--
A polynomial over an integral domain `R` is irreducible if it is monic and
  irreducible after mapping into an integral domain `S`.

A special case of this lemma is that a polynomial over `ℤ` is irreducible if
  it is monic and irreducible over `ℤ/pℤ` for some prime `p`.
-/
theorem monic.irreducible_of_irreducible_map {R : Type u} {S : Type v} [integral_domain R] [integral_domain S] (φ : R →+* S) (f : polynomial R) (h_mon : monic f) (h_irr : irreducible (map φ f)) : irreducible f := sorry

end polynomial

namespace is_integral_domain

/-- Lift evidence that `is_integral_domain R` to `is_integral_domain (polynomial R)`. -/
theorem polynomial {R : Type u_1} [comm_ring R] (h : is_integral_domain R) : is_integral_domain (polynomial R) :=
  integral_domain.to_is_integral_domain (polynomial R)


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Casper Putz, Anne Baanen
-/
import linear_algebra.matrix.nonsingular_inverse
import linear_algebra.matrix.reindex
import linear_algebra.matrix.to_lin

/-!
# Bases and matrices

This file defines the map `basis.to_matrix` that sends a family of vectors to
the matrix of their coordinates with respect to some basis.

## Main definitions

 * `basis.to_matrix e v` is the matrix whose `i, j`th entry is `e.repr (v j) i`
 * `basis.to_matrix_equiv` is `basis.to_matrix` bundled as a linear equiv

## Main results

 * `linear_map.to_matrix_id_eq_basis_to_matrix`: `linear_map.to_matrix b c id`
   is equal to `basis.to_matrix b c`
 * `basis.to_matrix_mul_to_matrix`: multiplying `basis.to_matrix` with another
   `basis.to_matrix` gives a `basis.to_matrix`

## Tags

matrix, basis
-/

noncomputable theory

open linear_map matrix set submodule
open_locale big_operators
open_locale matrix

section basis_to_matrix

variables {ι ι' κ κ' : Type*}
variables {R M : Type*} [comm_semiring R] [add_comm_monoid M] [module R M]
variables {R₂ M₂ : Type*} [comm_ring R₂] [add_comm_group M₂] [module R₂ M₂]

open function matrix

/-- From a basis `e : ι → M` and a family of vectors `v : ι' → M`, make the matrix whose columns
are the vectors `v i` written in the basis `e`. -/
def basis.to_matrix (e : basis ι R M) (v : ι' → M) : matrix ι ι' R :=
λ i j, e.repr (v j) i

variables (e : basis ι R M) (v : ι' → M) (i : ι) (j : ι')

namespace basis

lemma to_matrix_apply : e.to_matrix v i j = e.repr (v j) i :=
rfl

lemma to_matrix_transpose_apply : (e.to_matrix v)ᵀ j = e.repr (v j) :=
funext $ (λ _, rfl)

lemma to_matrix_eq_to_matrix_constr [fintype ι] [decidable_eq ι] (v : ι → M) :
  e.to_matrix v = linear_map.to_matrix e e (e.constr ℕ v) :=
by { ext, rw [basis.to_matrix_apply, linear_map.to_matrix_apply, basis.constr_basis] }

-- TODO (maybe) Adjust the definition of `basis.to_matrix` to eliminate the transpose.
lemma coe_pi_basis_fun.to_matrix_eq_transpose [fintype ι] :
  ((pi.basis_fun R ι).to_matrix : matrix ι ι R → matrix ι ι R) = matrix.transpose :=
by { ext M i j, refl, }

@[simp] lemma to_matrix_self [decidable_eq ι] : e.to_matrix e = 1 :=
begin
  rw basis.to_matrix,
  ext i j,
  simp [basis.equiv_fun, matrix.one_apply, finsupp.single_apply, eq_comm]
end

lemma to_matrix_update [decidable_eq ι'] (x : M) :
  e.to_matrix (function.update v j x) = matrix.update_column (e.to_matrix v) j (e.repr x) :=
begin
  ext i' k,
  rw [basis.to_matrix, matrix.update_column_apply, e.to_matrix_apply],
  split_ifs,
  { rw [h, update_same j x v] },
  { rw update_noteq h },
end

/-- The basis constructed by `units_smul` has vectors given by a diagonal matrix. -/
@[simp] lemma to_matrix_units_smul [decidable_eq ι] (e : basis ι R₂ M₂) (w : ι → R₂ˣ) :
  e.to_matrix (e.units_smul w) = diagonal (coe ∘ w) :=
begin
  ext i j,
  by_cases h : i = j,
  { simp [h, to_matrix_apply, units_smul_apply, units.smul_def] },
  { simp [h, to_matrix_apply, units_smul_apply, units.smul_def, ne.symm h] }
end

/-- The basis constructed by `is_unit_smul` has vectors given by a diagonal matrix. -/
@[simp] lemma to_matrix_is_unit_smul [decidable_eq ι] (e : basis ι R₂ M₂) {w : ι → R₂}
  (hw : ∀ i, is_unit (w i)) :
  e.to_matrix (e.is_unit_smul hw) = diagonal w :=
e.to_matrix_units_smul _

@[simp] lemma sum_to_matrix_smul_self [fintype ι] : ∑ (i : ι), e.to_matrix v i j • e i = v j :=
by simp_rw [e.to_matrix_apply, e.sum_repr]

lemma to_matrix_map_vec_mul {S : Type*} [ring S] [algebra R S] [fintype ι]
  (b : basis ι R S) (v : ι' → S) :
  ((b.to_matrix v).map $ algebra_map R S).vec_mul b = v :=
begin
  ext i,
  simp_rw [vec_mul, dot_product, matrix.map_apply, ← algebra.commutes, ← algebra.smul_def,
    sum_to_matrix_smul_self],
end

@[simp] lemma to_lin_to_matrix [fintype ι] [fintype ι'] [decidable_eq ι'] (v : basis ι' R M) :
  matrix.to_lin v e (e.to_matrix v) = id :=
v.ext (λ i, by rw [to_lin_self, id_apply, e.sum_to_matrix_smul_self])

/-- From a basis `e : ι → M`, build a linear equivalence between families of vectors `v : ι → M`,
and matrices, making the matrix whose columns are the vectors `v i` written in the basis `e`. -/
def to_matrix_equiv [fintype ι] (e : basis ι R M) : (ι → M) ≃ₗ[R] matrix ι ι R :=
{ to_fun := e.to_matrix,
  map_add' := λ v w, begin
    ext i j,
    change _ = _ + _,
    rw [e.to_matrix_apply, pi.add_apply, linear_equiv.map_add],
    refl
  end,
  map_smul' := begin
    intros c v,
    ext i j,
    rw [e.to_matrix_apply, pi.smul_apply, linear_equiv.map_smul],
    refl
  end,
  inv_fun := λ m j, ∑ i, (m i j) • e i,
  left_inv := begin
    intro v,
    ext j,
    exact e.sum_to_matrix_smul_self v j
  end,
  right_inv := begin
    intros m,
    ext k l,
    simp only [e.to_matrix_apply, ← e.equiv_fun_apply, ← e.equiv_fun_symm_apply,
               linear_equiv.apply_symm_apply],
  end }

end basis

section mul_linear_map_to_matrix

variables {N : Type*} [add_comm_monoid N] [module R N]
variables (b : basis ι R M) (b' : basis ι' R M) (c : basis κ R N) (c' : basis κ' R N)
variables (f : M →ₗ[R] N)

open linear_map

section fintype

variables [fintype ι'] [fintype κ] [fintype κ']

@[simp] lemma basis_to_matrix_mul_linear_map_to_matrix [decidable_eq ι'] :
  c.to_matrix c' ⬝ linear_map.to_matrix b' c' f = linear_map.to_matrix b' c f :=
(matrix.to_lin b' c).injective
  (by haveI := classical.dec_eq κ';
      rw [to_lin_to_matrix, to_lin_mul b' c' c, to_lin_to_matrix, c.to_lin_to_matrix, id_comp])

variable [fintype ι]

@[simp] lemma linear_map_to_matrix_mul_basis_to_matrix [decidable_eq ι] [decidable_eq ι'] :
  linear_map.to_matrix b' c' f ⬝ b'.to_matrix b = linear_map.to_matrix b c' f :=
(matrix.to_lin b c').injective
  (by rw [to_lin_to_matrix, to_lin_mul b b' c', to_lin_to_matrix, b'.to_lin_to_matrix, comp_id])

lemma basis_to_matrix_mul_linear_map_to_matrix_mul_basis_to_matrix
  [decidable_eq ι] [decidable_eq ι'] :
  c.to_matrix c' ⬝ linear_map.to_matrix b' c' f ⬝ b'.to_matrix b = linear_map.to_matrix b c f :=
by rw [basis_to_matrix_mul_linear_map_to_matrix, linear_map_to_matrix_mul_basis_to_matrix]

lemma basis_to_matrix_mul [decidable_eq κ]
    (b₁ : basis ι R M) (b₂ : basis ι' R M) (b₃ : basis κ R N) (A : matrix ι' κ R) :
  b₁.to_matrix b₂ ⬝ A = linear_map.to_matrix b₃ b₁ (to_lin b₃ b₂ A) :=
begin
  have := basis_to_matrix_mul_linear_map_to_matrix b₃ b₁ b₂ (matrix.to_lin b₃ b₂ A),
  rwa [linear_map.to_matrix_to_lin] at this
end

lemma mul_basis_to_matrix [decidable_eq ι] [decidable_eq ι']
    (b₁ : basis ι R M) (b₂ : basis ι' R M) (b₃ : basis κ R N) (A : matrix κ ι R) :
  A ⬝ b₁.to_matrix b₂ = linear_map.to_matrix b₂ b₃ (to_lin b₁ b₃ A) :=
begin
  have := linear_map_to_matrix_mul_basis_to_matrix b₂ b₁ b₃ (matrix.to_lin b₁ b₃ A),
  rwa [linear_map.to_matrix_to_lin] at this
end

lemma basis_to_matrix_basis_fun_mul (b : basis ι R (ι → R)) (A : matrix ι ι R) :
  b.to_matrix (pi.basis_fun R ι) ⬝ A = of (λ i j, b.repr (Aᵀ j) i) :=
begin
  classical,
  simp only [basis_to_matrix_mul _ _ (pi.basis_fun R ι), matrix.to_lin_eq_to_lin'],
  ext i j,
  rw [linear_map.to_matrix_apply, matrix.to_lin'_apply, pi.basis_fun_apply,
    matrix.mul_vec_std_basis_apply, matrix.of_apply]
end

/-- A generalization of `linear_map.to_matrix_id`. -/
@[simp] lemma linear_map.to_matrix_id_eq_basis_to_matrix [decidable_eq ι] :
  linear_map.to_matrix b b' id = b'.to_matrix b :=
by { haveI := classical.dec_eq ι',
      rw [←@basis_to_matrix_mul_linear_map_to_matrix _ _ ι, to_matrix_id, matrix.mul_one] }

/-- See also `basis.to_matrix_reindex` which gives the `simp` normal form of this result. -/
lemma basis.to_matrix_reindex' [decidable_eq ι] [decidable_eq ι']
  (b : basis ι R M) (v : ι' → M) (e : ι ≃ ι') :
  (b.reindex e).to_matrix v = matrix.reindex_alg_equiv _ e (b.to_matrix (v ∘ e)) :=
by { ext, simp only [basis.to_matrix_apply, basis.repr_reindex, matrix.reindex_alg_equiv_apply,
        matrix.reindex_apply, matrix.submatrix_apply, function.comp_app, e.apply_symm_apply,
        finsupp.map_domain_equiv_apply] }

end fintype

/-- A generalization of `basis.to_matrix_self`, in the opposite direction. -/
@[simp] lemma basis.to_matrix_mul_to_matrix {ι'' : Type*} [fintype ι'] (b'' : ι'' → M) :
  b.to_matrix b' ⬝ b'.to_matrix b'' = b.to_matrix b'' :=
begin
  have  := classical.dec_eq ι,
  have  := classical.dec_eq ι',
  haveI := classical.dec_eq ι'',
  ext i j,
  simp only [matrix.mul_apply, basis.to_matrix_apply, basis.sum_repr_mul_repr],
end

/-- `b.to_matrix b'` and `b'.to_matrix b` are inverses. -/
lemma basis.to_matrix_mul_to_matrix_flip [decidable_eq ι] [fintype ι'] :
  b.to_matrix b' ⬝ b'.to_matrix b = 1 :=
by rw [basis.to_matrix_mul_to_matrix, basis.to_matrix_self]

/-- A matrix whose columns form a basis `b'`, expressed w.r.t. a basis `b`, is invertible. -/
def basis.invertible_to_matrix [decidable_eq ι] [fintype ι] (b b' : basis ι R₂ M₂) :
  invertible (b.to_matrix b') :=
matrix.invertible_of_left_inverse _ _ (basis.to_matrix_mul_to_matrix_flip _ _)

@[simp]
lemma basis.to_matrix_reindex
  (b : basis ι R M) (v : ι' → M) (e : ι ≃ ι') :
  (b.reindex e).to_matrix v = (b.to_matrix v).submatrix e.symm id :=
by { ext, simp only [basis.to_matrix_apply, basis.repr_reindex, matrix.submatrix_apply, id.def,
  finsupp.map_domain_equiv_apply] }

@[simp]
lemma basis.to_matrix_map (b : basis ι R M) (f : M ≃ₗ[R] N) (v : ι → N) :
  (b.map f).to_matrix v = b.to_matrix (f.symm ∘ v) :=
by { ext, simp only [basis.to_matrix_apply, basis.map, linear_equiv.trans_apply] }

end mul_linear_map_to_matrix

end basis_to_matrix


/-
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 analysis.specific_limits
import order.iterate
import order.semiconj_Sup
import algebra.iterate_hom

/-!
# Translation number of a monotone real map that commutes with `x ↦ x + 1`

Let `f : ℝ → ℝ` be a monotone map such that `f (x + 1) = f x + 1` for all `x`. Then the limit
$$
  \tau(f)=\lim_{n\to\infty}{f^n(x)-x}{n}
$$
exists and does not depend on `x`. This number is called the *translation number* of `f`.
Different authors use different notation for this number: `τ`, `ρ`, `rot`, etc

In this file we define a structure `circle_deg1_lift` for bundled maps with these properties, define
translation number of `f : circle_deg1_lift`, prove some estimates relating `f^n(x)-x` to `τ(f)`. In
case of a continuous map `f` we also prove that `f` admits a point `x` such that `f^n(x)=x+m` if and
only if `τ(f)=m/n`.

Maps of this type naturally appear as lifts of orientation preserving circle homeomorphisms. More
precisely, let `f` be an orientation preserving homeomorphism of the circle $S^1=ℝ/ℤ$, and
consider a real number `a` such that
`⟦a⟧ = f 0`, where `⟦⟧` means the natural projection `ℝ → ℝ/ℤ`. Then there exists a unique
continuous function `F : ℝ → ℝ` such that `F 0 = a` and `⟦F x⟧ = f ⟦x⟧` for all `x` (this fact is
not formalized yet). This function is strictly monotone, continuous, and satisfies
`F (x + 1) = F x + 1`. The number `⟦τ F⟧ : ℝ / ℤ` is called the *rotation number* of `f`.
It does not depend on the choice of `a`.

## Main definitions

* `circle_deg1_lift`: a monotone map `f : ℝ → ℝ` such that `f (x + 1) = f x + 1` for all `x`;
  the type `circle_deg1_lift` is equipped with `lattice` and `monoid` structures; the
  multiplication is given by composition: `(f * g) x = f (g x)`.
* `circle_deg1_lift.translation_number`: translation number of `f : circle_deg1_lift`.

## Main statements

We prove the following properties of `circle_deg1_lift.translation_number`.

* `circle_deg1_lift.translation_number_eq_of_dist_bounded`: if the distance between `(f^n) 0`
  and `(g^n) 0` is bounded from above uniformly in `n : ℕ`, then `f` and `g` have equal
  translation numbers.

* `circle_deg1_lift.translation_number_eq_of_semiconj_by`: if two `circle_deg1_lift` maps `f`, `g`
  are semiconjugate by a `circle_deg1_lift` map, then `τ f = τ g`.

* `circle_deg1_lift.translation_number_units_inv`: if `f` is an invertible `circle_deg1_lift` map
  (equivalently, `f` is a lift of an orientation-preserving circle homeomorphism), then
  the translation number of `f⁻¹` is the negative of the translation number of `f`.

* `circle_deg1_lift.translation_number_mul_of_commute`: if `f` and `g` commute, then
  `τ (f * g) = τ f + τ g`.

* `circle_deg1_lift.translation_number_eq_rat_iff`: the translation number of `f` is equal to
  a rational number `m / n` if and only if `(f^n) x = x + m` for some `x`.

* `circle_deg1_lift.semiconj_of_bijective_of_translation_number_eq`: if `f` and `g` are two
  bijective `circle_deg1_lift` maps and their translation numbers are equal, then these
  maps are semiconjugate to each other.

* `circle_deg1_lift.semiconj_of_group_action_of_forall_translation_number_eq`: let `f₁` and `f₂` be
  two actions of a group `G` on the circle by degree 1 maps (formally, `f₁` and `f₂` are two
  homomorphisms from `G →* circle_deg1_lift`). If the translation numbers of `f₁ g` and `f₂ g` are
  equal to each other for all `g : G`, then these two actions are semiconjugate by some `F :
  circle_deg1_lift`. This is a version of Proposition 5.4 from [Étienne Ghys, Groupes
  d'homeomorphismes du cercle et cohomologie bornee][ghys87:groupes].

## Notation

We use a local notation `τ` for the translation number of `f : circle_deg1_lift`.

## Implementation notes

We define the translation number of `f : circle_deg1_lift` to be the limit of the sequence
`(f ^ (2 ^ n)) 0 / (2 ^ n)`, then prove that `((f ^ n) x - x) / n` tends to this number for any `x`.
This way it is much easier to prove that the limit exists and basic properties of the limit.

We define translation number for a wider class of maps `f : ℝ → ℝ` instead of lifts of orientation
preserving circle homeomorphisms for two reasons:

* non-strictly monotone circle self-maps with discontinuities naturally appear as Poincaré maps
  for some flows on the two-torus (e.g., one can take a constant flow and glue in a few Cherry
  cells);
* definition and some basic properties still work for this class.

## References

* [Étienne Ghys, Groupes d'homeomorphismes du cercle et cohomologie bornee][ghys87:groupes]

## TODO

Here are some short-term goals.

* Introduce a structure or a typeclass for lifts of circle homeomorphisms. We use `units
  circle_deg1_lift` for now, but it's better to have a dedicated type (or a typeclass?).

* Prove that the `semiconj_by` relation on circle homeomorphisms is an equivalence relation.

* Introduce `conditionally_complete_lattice` structure, use it in the proof of
  `circle_deg1_lift.semiconj_of_group_action_of_forall_translation_number_eq`.

* Prove that the orbits of the irrational rotation are dense in the circle. Deduce that a
  homeomorphism with an irrational rotation is semiconjugate to the corresponding irrational
  translation by a continuous `circle_deg1_lift`.

## Tags

circle homeomorphism, rotation number
-/

open filter set function (hiding commute)
open_locale topological_space classical

/-!
### Definition and monoid structure
-/

/-- A lift of a monotone degree one map `S¹ → S¹`. -/
structure circle_deg1_lift : Type :=
(to_fun : ℝ → ℝ)
(monotone' : monotone to_fun)
(map_add_one' : ∀ x, to_fun (x + 1) = to_fun x + 1)

namespace circle_deg1_lift

instance : has_coe_to_fun circle_deg1_lift := ⟨λ _, ℝ → ℝ, circle_deg1_lift.to_fun⟩

@[simp] lemma coe_mk (f h₁ h₂) : ⇑(mk f h₁ h₂) = f := rfl

variables (f g : circle_deg1_lift)

protected lemma monotone  : monotone f := f.monotone'

@[mono] lemma mono {x y} (h : x ≤ y) : f x ≤ f y := f.monotone h

lemma strict_mono_iff_injective : strict_mono f ↔ injective f :=
f.monotone.strict_mono_iff_injective

@[simp] lemma map_add_one : ∀ x, f (x + 1) = f x + 1 := f.map_add_one'

@[simp] lemma map_one_add (x : ℝ) : f (1 + x) = 1 + f x := by rw [add_comm, map_add_one, add_comm]

theorem coe_inj : ∀ ⦃f g : circle_deg1_lift ⦄, (f : ℝ → ℝ) = g → f = g :=
assume ⟨f, fm, fd⟩ ⟨g, gm, gd⟩ h, by congr; exact h

@[ext] theorem ext ⦃f g : circle_deg1_lift ⦄ (h : ∀ x, f x = g x) : f = g :=
coe_inj $ funext h

theorem ext_iff {f g : circle_deg1_lift} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

instance : monoid circle_deg1_lift :=
{ mul := λ f g,
  { to_fun := f ∘ g,
    monotone' := f.monotone.comp g.monotone,
    map_add_one' := λ x, by simp [map_add_one] },
  one := ⟨id, monotone_id, λ _, rfl⟩,
  mul_one := λ f, coe_inj $ function.comp.right_id f,
  one_mul := λ f, coe_inj $ function.comp.left_id f,
  mul_assoc := λ f₁ f₂ f₃, coe_inj rfl }

instance : inhabited circle_deg1_lift := ⟨1⟩

@[simp] lemma coe_mul : ⇑(f * g) = f ∘ g := rfl

lemma mul_apply (x) : (f * g) x = f (g x) := rfl

@[simp] lemma coe_one : ⇑(1 : circle_deg1_lift) = id := rfl

instance units_has_coe_to_fun : has_coe_to_fun (units circle_deg1_lift) :=
⟨λ _, ℝ → ℝ, λ f, ⇑(f : circle_deg1_lift)⟩

@[simp, norm_cast] lemma units_coe (f : units circle_deg1_lift) : ⇑(f : circle_deg1_lift) = f := rfl

@[simp] lemma units_inv_apply_apply (f : units circle_deg1_lift) (x : ℝ) :
  (f⁻¹ : units circle_deg1_lift) (f x) = x :=
by simp only [← units_coe, ← mul_apply, f.inv_mul, coe_one, id]

@[simp] lemma units_apply_inv_apply (f : units circle_deg1_lift) (x : ℝ) :
  f ((f⁻¹ : units circle_deg1_lift) x) = x :=
by simp only [← units_coe, ← mul_apply, f.mul_inv, coe_one, id]

/-- If a lift of a circle map is bijective, then it is an order automorphism of the line. -/
def to_order_iso : units circle_deg1_lift →* ℝ ≃o ℝ :=
{ to_fun := λ f,
    { to_fun := f,
      inv_fun := ⇑(f⁻¹),
      left_inv := units_inv_apply_apply f,
      right_inv := units_apply_inv_apply f,
      map_rel_iff' := λ x y, ⟨λ h, by simpa using mono ↑(f⁻¹) h, mono f⟩ },
  map_one' := rfl,
  map_mul' := λ f g, rfl }

@[simp] lemma coe_to_order_iso (f : units circle_deg1_lift) : ⇑(to_order_iso f) = f := rfl

@[simp] lemma coe_to_order_iso_symm (f : units circle_deg1_lift) :
  ⇑(to_order_iso f).symm = (f⁻¹ : units circle_deg1_lift) := rfl

@[simp] lemma coe_to_order_iso_inv (f : units circle_deg1_lift) :
  ⇑(to_order_iso f)⁻¹ = (f⁻¹ : units circle_deg1_lift) := rfl

lemma is_unit_iff_bijective {f : circle_deg1_lift} : is_unit f ↔ bijective f :=
⟨λ ⟨u, h⟩, h ▸ (to_order_iso u).bijective, λ h, units.is_unit
  { val := f,
    inv := { to_fun := (equiv.of_bijective f h).symm,
             monotone' := λ x y hxy, (f.strict_mono_iff_injective.2 h.1).le_iff_le.1
               (by simp only [equiv.of_bijective_apply_symm_apply f h, hxy]),
             map_add_one' := λ x, h.1 $
               by simp only [equiv.of_bijective_apply_symm_apply f, f.map_add_one] },
    val_inv := ext $ equiv.of_bijective_apply_symm_apply f h,
    inv_val := ext $ equiv.of_bijective_symm_apply_apply f h }⟩

lemma semiconj_by_iff_semiconj {f g₁ g₂ : circle_deg1_lift} :
  semiconj_by f g₁ g₂ ↔ semiconj f g₁ g₂ :=
ext_iff

lemma commute_iff_commute {f g : circle_deg1_lift} :
  commute f g ↔ function.commute f g :=
ext_iff

/-!
### Translate by a constant
-/

/-- The map `y ↦ x + y` as a `circle_deg1_lift`. More precisely, we define a homomorphism from
`multiplicative ℝ` to `units circle_deg1_lift`, so the translation by `x` is
`translation (multiplicative.of_add x)`. -/
def translate : multiplicative ℝ →* units circle_deg1_lift :=
by refine (units.map _).comp to_units.to_monoid_hom; exact
{ to_fun := λ x, ⟨λ y, x.to_add + y, λ y₁ y₂ h, add_le_add_left h _, λ y, (add_assoc _ _ _).symm⟩,
  map_one' := ext $ zero_add,
  map_mul' := λ x y, ext $ add_assoc _ _ }

@[simp] lemma translate_apply (x y : ℝ) : translate (multiplicative.of_add x) y = x + y := rfl

@[simp]
lemma translate_inv_apply (x y : ℝ) : (translate $ multiplicative.of_add x)⁻¹ y = -x + y := rfl

@[simp] lemma translate_gpow (x : ℝ) (n : ℤ) :
  (translate (multiplicative.of_add x))^n = translate (multiplicative.of_add $ ↑n * x) :=
by simp only [← gsmul_eq_mul, of_add_gsmul, monoid_hom.map_gpow]

@[simp] lemma translate_pow (x : ℝ) (n : ℕ) :
  (translate (multiplicative.of_add x))^n = translate (multiplicative.of_add $ ↑n * x) :=
translate_gpow x n

@[simp] lemma translate_iterate (x : ℝ) (n : ℕ) :
  (translate (multiplicative.of_add x))^[n] = translate (multiplicative.of_add $ ↑n * x) :=
by rw [← units_coe, ← coe_pow, ← units.coe_pow, translate_pow, units_coe]

/-!
### Commutativity with integer translations

In this section we prove that `f` commutes with translations by an integer number.
First we formulate these statements (for a natural or an integer number,
addition on the left or on the right, addition or subtraction) using `function.commute`,
then reformulate as `simp` lemmas `map_int_add` etc.
-/

lemma commute_nat_add (n : ℕ) : function.commute f ((+) n) :=
by simpa only [nsmul_one, add_left_iterate] using function.commute.iterate_right f.map_one_add n

lemma commute_add_nat (n : ℕ) : function.commute f (λ x, x + n) :=
by simp only [add_comm _ (n:ℝ), f.commute_nat_add n]

lemma commute_sub_nat (n : ℕ) : function.commute f (λ x, x - n) :=
by simpa only [sub_eq_add_neg] using
  (f.commute_add_nat n).inverses_right (equiv.add_right _).right_inv (equiv.add_right _).left_inv

lemma commute_add_int : ∀ n : ℤ, function.commute f (λ x, x + n)
| (n:ℕ) := f.commute_add_nat n
| -[1+n] := by simpa only [sub_eq_add_neg] using f.commute_sub_nat (n + 1)

lemma commute_int_add (n : ℤ) : function.commute f ((+) n) :=
by simpa only [add_comm _ (n:ℝ)] using f.commute_add_int n

lemma commute_sub_int (n : ℤ) : function.commute f (λ x, x - n) :=
by simpa only [sub_eq_add_neg] using
  (f.commute_add_int n).inverses_right (equiv.add_right _).right_inv (equiv.add_right _).left_inv

@[simp] lemma map_int_add (m : ℤ) (x : ℝ) : f (m + x) = m + f x :=
f.commute_int_add m x

@[simp] lemma map_add_int (x : ℝ) (m : ℤ) : f (x + m) = f x + m :=
f.commute_add_int m x

@[simp] lemma map_sub_int (x : ℝ) (n : ℤ) : f (x - n) = f x - n :=
f.commute_sub_int n x

@[simp] lemma map_add_nat (x : ℝ) (n : ℕ) : f (x + n) = f x + n :=
f.map_add_int x n

@[simp] lemma map_nat_add (n : ℕ) (x : ℝ) : f (n + x) = n + f x :=
f.map_int_add n x

@[simp] lemma map_sub_nat (x : ℝ) (n : ℕ) : f (x - n) = f x - n :=
f.map_sub_int x n

lemma map_int_of_map_zero (n : ℤ) : f n = f 0 + n :=
by rw [← f.map_add_int, zero_add]

@[simp] lemma map_fract_sub_fract_eq (x : ℝ) :
  f (fract x) - fract x = f x - x :=
by conv_rhs { rw [← fract_add_floor x, f.map_add_int, add_sub_comm, sub_self, add_zero] }

/-!
### Pointwise order on circle maps
-/

/-- Monotone circle maps form a lattice with respect to the pointwise order -/
noncomputable instance : lattice circle_deg1_lift :=
{ sup := λ f g,
  { to_fun := λ x, max (f x) (g x),
    monotone' := λ x y h, max_le_max (f.mono h) (g.mono h), -- TODO: generalize to `monotone.max`
    map_add_one' := λ x, by simp [max_add_add_right] },
  le := λ f g, ∀ x, f x ≤ g x,
  le_refl := λ f x, le_refl (f x),
  le_trans := λ f₁ f₂ f₃ h₁₂ h₂₃ x, le_trans (h₁₂ x) (h₂₃ x),
  le_antisymm := λ f₁ f₂ h₁₂ h₂₁, ext $ λ x, le_antisymm (h₁₂ x) (h₂₁ x),
  le_sup_left := λ f g x, le_max_left (f x) (g x),
  le_sup_right := λ f g x, le_max_right (f x) (g x),
  sup_le := λ f₁ f₂ f₃ h₁ h₂ x, max_le (h₁ x) (h₂ x),
  inf := λ f g,
  { to_fun := λ x, min (f x) (g x),
    monotone' := λ x y h, min_le_min (f.mono h) (g.mono h),
    map_add_one' := λ x, by simp [min_add_add_right] },
  inf_le_left := λ f g x, min_le_left (f x) (g x),
  inf_le_right := λ f g x, min_le_right (f x) (g x),
  le_inf := λ f₁ f₂ f₃ h₂ h₃ x, le_min (h₂ x) (h₃ x) }

@[simp] lemma sup_apply (x : ℝ) : (f ⊔ g) x = max (f x) (g x) := rfl

@[simp] lemma inf_apply (x : ℝ) : (f ⊓ g) x = min (f x) (g x) := rfl

lemma iterate_monotone (n : ℕ) : monotone (λ f : circle_deg1_lift, f^[n]) :=
λ f g h, f.monotone.iterate_le_of_le h _

lemma iterate_mono {f g : circle_deg1_lift} (h : f ≤ g) (n : ℕ) : f^[n] ≤ (g^[n]) :=
iterate_monotone n h

lemma pow_mono {f g : circle_deg1_lift} (h : f ≤ g) (n : ℕ) : f^n ≤ g^n :=
λ x, by simp only [coe_pow, iterate_mono h n x]

lemma pow_monotone (n : ℕ) : monotone (λ f : circle_deg1_lift, f^n) :=
λ f g h, pow_mono h n

/-!
### Estimates on `(f * g) 0`

We prove the estimates `f 0 + ⌊g 0⌋ ≤ f (g 0) ≤ f 0 + ⌈g 0⌉` and some corollaries with added/removed
floors and ceils.

We also prove that for two semiconjugate maps `g₁`, `g₂`, the distance between `g₁ 0` and `g₂ 0`
is less than two.
-/

lemma map_le_of_map_zero (x : ℝ) : f x ≤ f 0 + ⌈x⌉ :=
calc f x ≤ f ⌈x⌉     : f.monotone $ le_ceil _
     ... = f 0 + ⌈x⌉ : f.map_int_of_map_zero _

lemma map_map_zero_le : f (g 0) ≤ f 0 + ⌈g 0⌉ := f.map_le_of_map_zero (g 0)

lemma floor_map_map_zero_le : ⌊f (g 0)⌋ ≤ ⌊f 0⌋ + ⌈g 0⌉ :=
calc ⌊f (g 0)⌋ ≤ ⌊f 0 + ⌈g 0⌉⌋ : floor_mono $ f.map_map_zero_le g
           ... = ⌊f 0⌋ + ⌈g 0⌉ : floor_add_int _ _

lemma ceil_map_map_zero_le : ⌈f (g 0)⌉ ≤ ⌈f 0⌉ + ⌈g 0⌉ :=
calc ⌈f (g 0)⌉ ≤ ⌈f 0 + ⌈g 0⌉⌉ : ceil_mono $ f.map_map_zero_le g
           ... = ⌈f 0⌉ + ⌈g 0⌉ : ceil_add_int _ _

lemma map_map_zero_lt : f (g 0) < f 0 + g 0 + 1 :=
calc f (g 0) ≤ f 0 + ⌈g 0⌉     : f.map_map_zero_le g
         ... < f 0 + (g 0 + 1) : add_lt_add_left (ceil_lt_add_one _) _
         ... = f 0 + g 0 + 1   : (add_assoc _ _ _).symm

lemma le_map_of_map_zero (x : ℝ) : f 0 + ⌊x⌋ ≤ f x :=
calc f 0 + ⌊x⌋ = f ⌊x⌋ : (f.map_int_of_map_zero _).symm
           ... ≤ f x   : f.monotone $ floor_le _

lemma le_map_map_zero : f 0 + ⌊g 0⌋ ≤ f (g 0) := f.le_map_of_map_zero (g 0)

lemma le_floor_map_map_zero : ⌊f 0⌋ + ⌊g 0⌋ ≤ ⌊f (g 0)⌋ :=
calc ⌊f 0⌋ + ⌊g 0⌋ = ⌊f 0 + ⌊g 0⌋⌋ : (floor_add_int _ _).symm
               ... ≤ ⌊f (g 0)⌋     : floor_mono $ f.le_map_map_zero g

lemma le_ceil_map_map_zero : ⌈f 0⌉ + ⌊g 0⌋ ≤ ⌈(f * g) 0⌉ :=
calc ⌈f 0⌉ + ⌊g 0⌋ = ⌈f 0 + ⌊g 0⌋⌉ : (ceil_add_int _ _).symm
               ... ≤ ⌈f (g 0)⌉     : ceil_mono $ f.le_map_map_zero g

lemma lt_map_map_zero : f 0 + g 0 - 1 < f (g 0) :=
calc f 0 + g 0 - 1 = f 0 + (g 0 - 1) : add_sub_assoc _ _ _
               ... < f 0 + ⌊g 0⌋     : add_lt_add_left (sub_one_lt_floor _) _
               ... ≤ f (g 0)         : f.le_map_map_zero g

lemma dist_map_map_zero_lt : dist (f 0 + g 0) (f (g 0)) < 1 :=
begin
  rw [dist_comm, real.dist_eq, abs_lt, lt_sub_iff_add_lt', sub_lt_iff_lt_add', ← sub_eq_add_neg],
  exact ⟨f.lt_map_map_zero g, f.map_map_zero_lt g⟩
end

lemma dist_map_zero_lt_of_semiconj {f g₁ g₂ : circle_deg1_lift} (h : function.semiconj f g₁ g₂) :
  dist (g₁ 0) (g₂ 0) < 2 :=
calc dist (g₁ 0) (g₂ 0) ≤ dist (g₁ 0) (f (g₁ 0) - f 0) + dist _ (g₂ 0) : dist_triangle _ _ _
... = dist (f 0 + g₁ 0) (f (g₁ 0)) + dist (g₂ 0 + f 0) (g₂ (f 0)) :
  by simp only [h.eq, real.dist_eq, sub_sub, add_comm (f 0), sub_sub_assoc_swap, abs_sub (g₂ (f 0))]
... < 2 : add_lt_add (f.dist_map_map_zero_lt g₁) (g₂.dist_map_map_zero_lt f)

lemma dist_map_zero_lt_of_semiconj_by {f g₁ g₂ : circle_deg1_lift} (h : semiconj_by f g₁ g₂) :
  dist (g₁ 0) (g₂ 0) < 2 :=
dist_map_zero_lt_of_semiconj $ semiconj_by_iff_semiconj.1 h

/-!
### Limits at infinities and continuity
-/

protected lemma tendsto_at_bot : tendsto f at_bot at_bot :=
tendsto_at_bot_mono f.map_le_of_map_zero $ tendsto_at_bot_add_const_left _ _ $
  tendsto_at_bot_mono (λ x, (ceil_lt_add_one x).le) $ tendsto_at_bot_add_const_right _ _ tendsto_id

protected lemma tendsto_at_top : tendsto f at_top at_top :=
tendsto_at_top_mono f.le_map_of_map_zero $ tendsto_at_top_add_const_left _ _ $
  tendsto_at_top_mono (λ x, (sub_one_lt_floor x).le) $
    by simpa [sub_eq_add_neg] using tendsto_at_top_add_const_right _ _ tendsto_id

lemma continuous_iff_surjective : continuous f ↔ function.surjective f :=
⟨λ h, h.surjective f.tendsto_at_top f.tendsto_at_bot, f.monotone.continuous_of_surjective⟩

/-!
### Estimates on `(f^n) x`

If we know that `f x` is `≤`/`<`/`≥`/`>`/`=` to `x + m`, then we have a similar estimate on
`f^[n] x` and `x + n * m`.

For `≤`, `≥`, and `=` we formulate both `of` (implication) and `iff` versions because implications
work for `n = 0`. For `<` and `>` we formulate only `iff` versions.
-/

lemma iterate_le_of_map_le_add_int {x : ℝ} {m : ℤ} (h : f x ≤ x + m) (n : ℕ) :
  f^[n] x ≤ x + n * m :=
by simpa only [nsmul_eq_mul, add_right_iterate]
using (f.commute_add_int m).iterate_le_of_map_le f.monotone (monotone_id.add_const m) h n

lemma le_iterate_of_add_int_le_map {x : ℝ} {m : ℤ} (h : x + m ≤ f x) (n : ℕ) :
  x + n * m ≤ (f^[n]) x :=
by simpa only [nsmul_eq_mul, add_right_iterate]
using (f.commute_add_int m).symm.iterate_le_of_map_le (monotone_id.add_const m) f.monotone h n

lemma iterate_eq_of_map_eq_add_int {x : ℝ} {m : ℤ} (h : f x = x + m) (n : ℕ) :
  f^[n] x = x + n * m :=
by simpa only [nsmul_eq_mul, add_right_iterate]
using (f.commute_add_int m).iterate_eq_of_map_eq n h

lemma iterate_pos_le_iff {x : ℝ} {m : ℤ} {n : ℕ} (hn : 0 < n) :
  f^[n] x ≤ x + n * m ↔ f x ≤ x + m :=
by simpa only [nsmul_eq_mul, add_right_iterate]
using (f.commute_add_int m).iterate_pos_le_iff_map_le f.monotone (strict_mono_id.add_const m) hn

lemma iterate_pos_lt_iff {x : ℝ} {m : ℤ} {n : ℕ} (hn : 0 < n) :
  f^[n] x < x + n * m ↔ f x < x + m :=
by simpa only [nsmul_eq_mul, add_right_iterate]
using (f.commute_add_int m).iterate_pos_lt_iff_map_lt f.monotone (strict_mono_id.add_const m) hn

lemma iterate_pos_eq_iff {x : ℝ} {m : ℤ} {n : ℕ} (hn : 0 < n) :
  f^[n] x = x + n * m ↔ f x = x + m :=
by simpa only [nsmul_eq_mul, add_right_iterate]
using (f.commute_add_int m).iterate_pos_eq_iff_map_eq f.monotone (strict_mono_id.add_const m) hn

lemma le_iterate_pos_iff {x : ℝ} {m : ℤ} {n : ℕ} (hn : 0 < n) :
  x + n * m ≤ (f^[n]) x ↔ x + m ≤ f x :=
by simpa only [not_lt] using not_congr (f.iterate_pos_lt_iff hn)

lemma lt_iterate_pos_iff {x : ℝ} {m : ℤ} {n : ℕ} (hn : 0 < n) :
  x + n * m < (f^[n]) x ↔ x + m < f x :=
by simpa only [not_le] using not_congr (f.iterate_pos_le_iff hn)

lemma mul_floor_map_zero_le_floor_iterate_zero (n : ℕ) : ↑n * ⌊f 0⌋ ≤ ⌊(f^[n] 0)⌋ :=
begin
  rw [le_floor, int.cast_mul, int.cast_coe_nat, ← zero_add ((n : ℝ) * _)],
  apply le_iterate_of_add_int_le_map,
  simp [floor_le]
end

/-!
### Definition of translation number
-/
noncomputable theory

/-- An auxiliary sequence used to define the translation number. -/
def transnum_aux_seq (n : ℕ) : ℝ := (f^(2^n)) 0 / 2^n

/-- The translation number of a `circle_deg1_lift`, $τ(f)=\lim_{n→∞}\frac{f^n(x)-x}{n}$. We use
an auxiliary sequence `\frac{f^{2^n}(0)}{2^n}` to define `τ(f)` because some proofs are simpler
this way. -/
def translation_number : ℝ :=
lim at_top f.transnum_aux_seq

-- TODO: choose two different symbols for `circle_deg1_lift.translation_number` and the future
-- `circle_mono_homeo.rotation_number`, then make them `localized notation`s
local notation `τ` := translation_number

lemma transnum_aux_seq_def : f.transnum_aux_seq = λ n : ℕ, (f^(2^n)) 0 / 2^n := rfl

lemma translation_number_eq_of_tendsto_aux {τ' : ℝ}
  (h : tendsto f.transnum_aux_seq at_top (𝓝 τ')) :
  τ f = τ' :=
h.lim_eq

lemma translation_number_eq_of_tendsto₀ {τ' : ℝ}
  (h : tendsto (λ n:ℕ, f^[n] 0 / n) at_top (𝓝 τ')) :
  τ f = τ' :=
f.translation_number_eq_of_tendsto_aux $
by simpa [(∘), transnum_aux_seq_def, coe_pow]
using h.comp (nat.tendsto_pow_at_top_at_top_of_one_lt one_lt_two)

lemma translation_number_eq_of_tendsto₀' {τ' : ℝ}
  (h : tendsto (λ n:ℕ, f^[n + 1] 0 / (n + 1)) at_top (𝓝 τ')) :
  τ f = τ' :=
f.translation_number_eq_of_tendsto₀ $ (tendsto_add_at_top_iff_nat 1).1 h

lemma transnum_aux_seq_zero : f.transnum_aux_seq 0 = f 0 := by simp [transnum_aux_seq]

lemma transnum_aux_seq_dist_lt (n : ℕ) :
  dist (f.transnum_aux_seq n) (f.transnum_aux_seq (n+1)) < (1 / 2) / (2^n) :=
begin
  have : 0 < (2^(n+1):ℝ) := pow_pos zero_lt_two _,
  rw [div_div_eq_div_mul, ← pow_succ, ← abs_of_pos this],
  replace := abs_pos.2 (ne_of_gt this),
  convert (div_lt_div_right this).2 ((f^(2^n)).dist_map_map_zero_lt (f^(2^n))),
  simp_rw [transnum_aux_seq, real.dist_eq],
  rw [← abs_div, sub_div, pow_succ', pow_succ, ← two_mul,
    mul_div_mul_left _ _ (@two_ne_zero ℝ _ _),
    pow_mul, sq, mul_apply]
end

lemma tendsto_translation_number_aux : tendsto f.transnum_aux_seq at_top (𝓝 $ τ f) :=
(cauchy_seq_of_le_geometric_two 1 (λ n, le_of_lt $ f.transnum_aux_seq_dist_lt n)).tendsto_lim

lemma dist_map_zero_translation_number_le : dist (f 0) (τ f) ≤ 1 :=
f.transnum_aux_seq_zero ▸ dist_le_of_le_geometric_two_of_tendsto₀ 1
  (λ n, le_of_lt $ f.transnum_aux_seq_dist_lt n) f.tendsto_translation_number_aux

lemma tendsto_translation_number_of_dist_bounded_aux (x : ℕ → ℝ) (C : ℝ)
  (H : ∀ n : ℕ, dist ((f^n) 0) (x n) ≤ C) :
  tendsto (λ n : ℕ, x (2^n) / (2^n)) at_top (𝓝 $ τ f) :=
begin
  refine f.tendsto_translation_number_aux.congr_dist (squeeze_zero (λ _, dist_nonneg) _ _),
  { exact λ n, C / 2^n },
  { intro n,
    have : 0 < (2^n:ℝ) := pow_pos zero_lt_two _,
    convert (div_le_div_right this).2 (H (2^n)),
    rw [transnum_aux_seq, real.dist_eq, ← sub_div, abs_div, abs_of_pos this, real.dist_eq] },
  { exact mul_zero C ▸ tendsto_const_nhds.mul (tendsto_inv_at_top_zero.comp $
      tendsto_pow_at_top_at_top_of_one_lt one_lt_two) }
end

lemma translation_number_eq_of_dist_bounded {f g : circle_deg1_lift} (C : ℝ)
  (H : ∀ n : ℕ, dist ((f^n) 0) ((g^n) 0) ≤ C) :
  τ f = τ g :=
eq.symm $ g.translation_number_eq_of_tendsto_aux $
  f.tendsto_translation_number_of_dist_bounded_aux _ C H

@[simp] lemma translation_number_one : τ 1 = 0 :=
translation_number_eq_of_tendsto₀ _ $ by simp [tendsto_const_nhds]

lemma translation_number_eq_of_semiconj_by {f g₁ g₂ : circle_deg1_lift} (H : semiconj_by f g₁ g₂) :
  τ g₁ = τ g₂ :=
translation_number_eq_of_dist_bounded 2 $ λ n, le_of_lt $
  dist_map_zero_lt_of_semiconj_by $ H.pow_right n

lemma translation_number_eq_of_semiconj {f g₁ g₂ : circle_deg1_lift}
  (H : function.semiconj f g₁ g₂) :
  τ g₁ = τ g₂ :=
translation_number_eq_of_semiconj_by $ semiconj_by_iff_semiconj.2 H

lemma translation_number_mul_of_commute {f g : circle_deg1_lift} (h : commute f g) :
  τ (f * g) = τ f + τ g :=
begin
  have : tendsto (λ n : ℕ, ((λ k, (f^k) 0 + (g^k) 0) (2^n)) / (2^n)) at_top (𝓝 $ τ f + τ g) :=
    ((f.tendsto_translation_number_aux.add g.tendsto_translation_number_aux).congr $
      λ n, (add_div ((f^(2^n)) 0) ((g^(2^n)) 0) ((2:ℝ)^n)).symm),
  refine tendsto_nhds_unique
    ((f * g).tendsto_translation_number_of_dist_bounded_aux _ 1 (λ n, _))
    this,
  rw [h.mul_pow, dist_comm],
  exact le_of_lt ((f^n).dist_map_map_zero_lt (g^n))
end

@[simp] lemma translation_number_units_inv (f : units circle_deg1_lift) :
  τ ↑(f⁻¹) = -τ f :=
eq_neg_iff_add_eq_zero.2 $
  by simp [← translation_number_mul_of_commute (commute.refl _).units_inv_left]

@[simp] lemma translation_number_pow :
  ∀ n : ℕ, τ (f^n) = n * τ f
| 0 := by simp
| (n+1) := by rw [pow_succ', translation_number_mul_of_commute (commute.pow_self f n),
  translation_number_pow n, nat.cast_add_one, add_mul, one_mul]

@[simp] lemma translation_number_gpow (f : units circle_deg1_lift) :
  ∀ n : ℤ, τ (f ^ n : units _) = n * τ f
| (n : ℕ) := by simp [translation_number_pow f n]
| -[1+n] := by { simp,  ring }

@[simp] lemma translation_number_conj_eq (f : units circle_deg1_lift) (g : circle_deg1_lift) :
  τ (↑f * g * ↑(f⁻¹)) = τ g :=
(translation_number_eq_of_semiconj_by (f.mk_semiconj_by g)).symm

@[simp] lemma translation_number_conj_eq' (f : units circle_deg1_lift) (g : circle_deg1_lift) :
  τ (↑(f⁻¹) * g * f) = τ g :=
translation_number_conj_eq f⁻¹ g

lemma dist_pow_map_zero_mul_translation_number_le (n:ℕ) :
  dist ((f^n) 0) (n * f.translation_number) ≤ 1 :=
f.translation_number_pow n ▸ (f^n).dist_map_zero_translation_number_le

lemma tendsto_translation_number₀' :
  tendsto (λ n:ℕ, (f^(n+1)) 0 / (n+1)) at_top (𝓝 $ τ f) :=
begin
  refine (tendsto_iff_dist_tendsto_zero.2 $ squeeze_zero (λ _, dist_nonneg) (λ n, _)
    ((tendsto_const_div_at_top_nhds_0_nat 1).comp (tendsto_add_at_top_nat 1))),
  dsimp,
  have : (0:ℝ) < n + 1 := n.cast_add_one_pos,
  rw [real.dist_eq, div_sub' _ _ _ (ne_of_gt this), abs_div, ← real.dist_eq, abs_of_pos this,
    div_le_div_right this, ← nat.cast_add_one],
  apply dist_pow_map_zero_mul_translation_number_le
end

lemma tendsto_translation_number₀ :
  tendsto (λ n:ℕ, ((f^n) 0) / n) at_top (𝓝 $ τ f) :=
(tendsto_add_at_top_iff_nat 1).1 f.tendsto_translation_number₀'

/-- For any `x : ℝ` the sequence $\frac{f^n(x)-x}{n}$ tends to the translation number of `f`.
In particular, this limit does not depend on `x`. -/
lemma tendsto_translation_number (x : ℝ) :
  tendsto (λ n:ℕ, ((f^n) x - x) / n) at_top (𝓝 $ τ f) :=
begin
  rw [← translation_number_conj_eq' (translate $ multiplicative.of_add x)],
  convert tendsto_translation_number₀ _,
  ext n,
  simp [sub_eq_neg_add, units.conj_pow']
end

lemma tendsto_translation_number' (x : ℝ) :
  tendsto (λ n:ℕ, ((f^(n+1)) x - x) / (n+1)) at_top (𝓝 $ τ f) :=
(tendsto_add_at_top_iff_nat 1).2 (f.tendsto_translation_number x)

lemma translation_number_mono : monotone τ :=
λ f g h, le_of_tendsto_of_tendsto' f.tendsto_translation_number₀
  g.tendsto_translation_number₀ $ λ n, div_le_div_of_le_of_nonneg (pow_mono h n 0) n.cast_nonneg

lemma translation_number_translate (x : ℝ) :
  τ (translate $ multiplicative.of_add x) = x :=
translation_number_eq_of_tendsto₀' _ $
  by simp [nat.cast_add_one_ne_zero, mul_div_cancel_left, tendsto_const_nhds]

lemma translation_number_le_of_le_add {z : ℝ} (hz : ∀ x, f x ≤ x + z) : τ f ≤ z :=
translation_number_translate z ▸ translation_number_mono
  (λ x, trans_rel_left _ (hz x) (add_comm _ _))

lemma le_translation_number_of_add_le {z : ℝ} (hz : ∀ x, x + z ≤ f x) : z ≤ τ f :=
translation_number_translate z ▸ translation_number_mono
  (λ x, trans_rel_right _ (add_comm _ _) (hz x))

lemma translation_number_le_of_le_add_int {x : ℝ} {m : ℤ} (h : f x ≤ x + m) : τ f ≤ m :=
le_of_tendsto' (f.tendsto_translation_number' x) $ λ n,
(div_le_iff' (n.cast_add_one_pos : (0 : ℝ) < _)).mpr $ sub_le_iff_le_add'.2 $
(coe_pow f (n + 1)).symm ▸ f.iterate_le_of_map_le_add_int h (n + 1)

lemma translation_number_le_of_le_add_nat {x : ℝ} {m : ℕ} (h : f x ≤ x + m) : τ f ≤ m :=
@translation_number_le_of_le_add_int f x m h

lemma le_translation_number_of_add_int_le {x : ℝ} {m : ℤ} (h : x + m ≤ f x) : ↑m ≤ τ f :=
ge_of_tendsto' (f.tendsto_translation_number' x) $ λ n,
(le_div_iff (n.cast_add_one_pos : (0 : ℝ) < _)).mpr $ le_sub_iff_add_le'.2 $
by simp only [coe_pow, mul_comm (m:ℝ), ← nat.cast_add_one, f.le_iterate_of_add_int_le_map h]

lemma le_translation_number_of_add_nat_le {x : ℝ} {m : ℕ} (h : x + m ≤ f x) : ↑m ≤ τ f :=
@le_translation_number_of_add_int_le f x m h

/-- If `f x - x` is an integer number `m` for some point `x`, then `τ f = m`.
On the circle this means that a map with a fixed point has rotation number zero. -/
lemma translation_number_of_eq_add_int {x : ℝ} {m : ℤ} (h : f x = x + m) : τ f = m :=
le_antisymm (translation_number_le_of_le_add_int f $ le_of_eq h)
  (le_translation_number_of_add_int_le f $ le_of_eq h.symm)

lemma floor_sub_le_translation_number (x : ℝ) : ↑⌊f x - x⌋ ≤ τ f :=
le_translation_number_of_add_int_le f $ le_sub_iff_add_le'.1 (floor_le $ f x - x)

lemma translation_number_le_ceil_sub (x : ℝ) : τ f ≤ ⌈f x - x⌉ :=
translation_number_le_of_le_add_int f $ sub_le_iff_le_add'.1 (le_ceil $ f x - x)

lemma map_lt_of_translation_number_lt_int {n : ℤ} (h : τ f < n) (x : ℝ) : f x < x + n :=
not_le.1 $ mt f.le_translation_number_of_add_int_le $ not_le.2 h

lemma map_lt_of_translation_number_lt_nat {n : ℕ} (h : τ f < n) (x : ℝ) : f x < x + n :=
@map_lt_of_translation_number_lt_int f n h x

lemma map_lt_add_floor_translation_number_add_one (x : ℝ) : f x < x + ⌊τ f⌋ + 1 :=
begin
  rw [add_assoc],
  norm_cast,
  refine map_lt_of_translation_number_lt_int _ _ _,
  push_cast,
  exact lt_floor_add_one _
end

lemma map_lt_add_translation_number_add_one (x : ℝ) : f x < x + τ f + 1 :=
calc f x < x + ⌊τ f⌋ + 1 : f.map_lt_add_floor_translation_number_add_one x
... ≤ x + τ f + 1 : by { mono*, exact floor_le (τ f) }

lemma lt_map_of_int_lt_translation_number {n : ℤ} (h : ↑n < τ f) (x : ℝ) : x + n < f x :=
not_le.1 $ mt f.translation_number_le_of_le_add_int $ not_le.2 h

lemma lt_map_of_nat_lt_translation_number {n : ℕ} (h : ↑n < τ f) (x : ℝ) : x + n < f x :=
@lt_map_of_int_lt_translation_number f n h x

/-- If `f^n x - x`, `n > 0`, is an integer number `m` for some point `x`, then
`τ f = m / n`. On the circle this means that a map with a periodic orbit has
a rational rotation number. -/
lemma translation_number_of_map_pow_eq_add_int {x : ℝ} {n : ℕ} {m : ℤ}
  (h : (f^n) x = x + m) (hn : 0 < n) :
  τ f = m / n :=
begin
  have := (f^n).translation_number_of_eq_add_int h,
  rwa [translation_number_pow, mul_comm, ← eq_div_iff] at this,
  exact nat.cast_ne_zero.2 (ne_of_gt hn)
end

/-- If a predicate depends only on `f x - x` and holds for all `0 ≤ x ≤ 1`,
then it holds for all `x`. -/
lemma forall_map_sub_of_Icc (P : ℝ → Prop)
  (h : ∀ x ∈ Icc (0:ℝ) 1, P (f x - x)) (x : ℝ) : P (f x - x) :=
f.map_fract_sub_fract_eq x ▸ h _ ⟨fract_nonneg _, le_of_lt (fract_lt_one _)⟩

lemma translation_number_lt_of_forall_lt_add (hf : continuous f) {z : ℝ}
  (hz : ∀ x, f x < x + z) : τ f < z :=
begin
  obtain ⟨x, xmem, hx⟩ : ∃ x ∈ Icc (0:ℝ) 1, ∀ y ∈ Icc (0:ℝ) 1, f y - y ≤ f x - x,
    from compact_Icc.exists_forall_ge (nonempty_Icc.2 zero_le_one)
      (hf.sub continuous_id).continuous_on,
  refine lt_of_le_of_lt _ (sub_lt_iff_lt_add'.2 $ hz x),
  apply translation_number_le_of_le_add,
  simp only [← sub_le_iff_le_add'],
  exact f.forall_map_sub_of_Icc (λ a, a ≤ f x - x) hx
end

lemma lt_translation_number_of_forall_add_lt (hf : continuous f) {z : ℝ}
  (hz : ∀ x, x + z < f x) : z < τ f :=
begin
  obtain ⟨x, xmem, hx⟩ : ∃ x ∈ Icc (0:ℝ) 1, ∀ y ∈ Icc (0:ℝ) 1, f x - x ≤ f y - y,
    from compact_Icc.exists_forall_le (nonempty_Icc.2 zero_le_one)
      (hf.sub continuous_id).continuous_on,
  refine lt_of_lt_of_le (lt_sub_iff_add_lt'.2 $ hz x) _,
  apply le_translation_number_of_add_le,
  simp only [← le_sub_iff_add_le'],
  exact f.forall_map_sub_of_Icc _ hx
end

/-- If `f` is a continuous monotone map `ℝ → ℝ`, `f (x + 1) = f x + 1`, then there exists `x`
such that `f x = x + τ f`. -/
lemma exists_eq_add_translation_number (hf : continuous f) :
  ∃ x, f x = x + τ f :=
begin
  obtain ⟨a, ha⟩ : ∃ x, f x ≤ x + f.translation_number,
  { by_contradiction H,
    push_neg at H,
    exact lt_irrefl _ (f.lt_translation_number_of_forall_add_lt hf H) },
  obtain ⟨b, hb⟩ : ∃ x, x + τ f ≤ f x,
  { by_contradiction H,
    push_neg at H,
    exact lt_irrefl _ (f.translation_number_lt_of_forall_lt_add hf H) },
  exact intermediate_value_univ₂ hf (continuous_id.add continuous_const) ha hb
end

lemma translation_number_eq_int_iff (hf : continuous f) {m : ℤ} :
  τ f = m ↔ ∃ x, f x = x + m :=
begin
  refine ⟨λ h, h ▸ f.exists_eq_add_translation_number hf, _⟩,
  rintros ⟨x, hx⟩,
  exact f.translation_number_of_eq_add_int hx
end

lemma continuous_pow (hf : continuous f) (n : ℕ) :
  continuous ⇑(f^n : circle_deg1_lift) :=
by { rw coe_pow, exact hf.iterate n }

lemma translation_number_eq_rat_iff (hf : continuous f) {m : ℤ}
  {n : ℕ} (hn : 0 < n) :
  τ f = m / n ↔ ∃ x, (f^n) x = x + m :=
begin
  rw [eq_div_iff, mul_comm, ← translation_number_pow]; [skip, exact ne_of_gt (nat.cast_pos.2 hn)],
  exact (f^n).translation_number_eq_int_iff (f.continuous_pow hf n)
end

/-- Consider two actions `f₁ f₂ : G →* circle_deg1_lift` of a group on the real line by lifts of
orientation preserving circle homeomorphisms. Suppose that for each `g : G` the homeomorphisms
`f₁ g` and `f₂ g` have equal rotation numbers. Then there exists `F : circle_deg1_lift`  such that
`F * f₁ g = f₂ g * F` for all `g : G`.

This is a version of Proposition 5.4 from [Étienne Ghys, Groupes d'homeomorphismes du cercle et
cohomologie bornee][ghys87:groupes]. -/
lemma semiconj_of_group_action_of_forall_translation_number_eq
  {G : Type*} [group G] (f₁ f₂ : G →* circle_deg1_lift)
  (h : ∀ g, τ (f₁ g) = τ (f₂ g)) :
  ∃ F : circle_deg1_lift, ∀ g, semiconj F (f₁ g) (f₂ g) :=
begin
  -- Equality of translation number guarantees that for each `x`
  -- the set `{f₂ g⁻¹ (f₁ g x) | g : G}` is bounded above.
  have : ∀ x, bdd_above (range $ λ g, f₂ g⁻¹ (f₁ g x)),
  { refine λ x, ⟨x + 2, _⟩,
    rintro _ ⟨g, rfl⟩,
    have : τ (f₂ g⁻¹) = -τ (f₂ g),
      by rw [← monoid_hom.coe_to_hom_units, monoid_hom.map_inv,
        translation_number_units_inv, monoid_hom.coe_to_hom_units],
    calc f₂ g⁻¹ (f₁ g x) ≤ f₂ g⁻¹ (x + τ (f₁ g) + 1) :
      mono _ (map_lt_add_translation_number_add_one _ _).le
    ... = f₂ g⁻¹ (x + τ (f₂ g)) + 1 :
      by rw [h, map_add_one]
    ... ≤ x + τ (f₂ g) + τ (f₂ g⁻¹) + 1 + 1 :
      by { mono, exact (map_lt_add_translation_number_add_one _ _).le }
    ... = x + 2 : by simp [this, bit0, add_assoc] },
  -- We have a theorem about actions by `order_iso`, so we introduce auxiliary maps
  -- to `ℝ ≃o ℝ`.
  set F₁ := to_order_iso.comp f₁.to_hom_units,
  set F₂ := to_order_iso.comp f₂.to_hom_units,
  have hF₁ : ∀ g, ⇑(F₁ g) = f₁ g := λ _, rfl,
  have hF₂ : ∀ g, ⇑(F₂ g) = f₂ g := λ _, rfl,
  simp only [← hF₁, ← hF₂],
  -- Now we apply `cSup_div_semiconj` and go back to `f₁` and `f₂`.
  refine ⟨⟨_, λ x y hxy, _, λ x, _⟩, cSup_div_semiconj F₂ F₁ (λ x, _)⟩;
    simp only [hF₁, hF₂, ← monoid_hom.map_inv, coe_mk],
  { refine csupr_le_csupr (this y) (λ g, _),
    exact mono _ (mono _ hxy) },
  { simp only [map_add_one],
    exact (map_csupr_of_continuous_at_of_monotone (continuous_at_id.add continuous_at_const)
      (monotone_id.add_const (1 : ℝ)) (this x)).symm },
  { exact this x }
end

/-- If two lifts of circle homeomorphisms have the same translation number, then they are
semiconjugate by a `circle_deg1_lift`. This version uses arguments `f₁ f₂ : units circle_deg1_lift`
to assume that `f₁` and `f₂` are homeomorphisms. -/
lemma units_semiconj_of_translation_number_eq {f₁ f₂ : units circle_deg1_lift}
  (h : τ f₁ = τ f₂) :
  ∃ F : circle_deg1_lift, semiconj F f₁ f₂ :=
begin
  have : ∀ n : multiplicative ℤ, τ ((units.coe_hom _).comp (gpowers_hom _ f₁) n) =
    τ ((units.coe_hom _).comp (gpowers_hom _ f₂) n),
  { intro n, simp [h] },
  exact (semiconj_of_group_action_of_forall_translation_number_eq _ _ this).imp
    (λ F hF, hF (multiplicative.of_add 1))
end

/-- If two lifts of circle homeomorphisms have the same translation number, then they are
semiconjugate by a `circle_deg1_lift`. This version uses assumptions `is_unit f₁` and `is_unit f₂`
to assume that `f₁` and `f₂` are homeomorphisms. -/
lemma semiconj_of_is_unit_of_translation_number_eq {f₁ f₂ : circle_deg1_lift}
  (h₁ : is_unit f₁) (h₂ : is_unit f₂) (h : τ f₁ = τ f₂) :
  ∃ F : circle_deg1_lift, semiconj F f₁ f₂ :=
by { rcases ⟨h₁, h₂⟩ with ⟨⟨f₁, rfl⟩, ⟨f₂, rfl⟩⟩, exact units_semiconj_of_translation_number_eq h }

/-- If two lifts of circle homeomorphisms have the same translation number, then they are
semiconjugate by a `circle_deg1_lift`. This version uses assumptions `bijective f₁` and
`bijective f₂` to assume that `f₁` and `f₂` are homeomorphisms. -/
lemma semiconj_of_bijective_of_translation_number_eq {f₁ f₂ : circle_deg1_lift}
  (h₁ : bijective f₁) (h₂ : bijective f₂) (h : τ f₁ = τ f₂) :
  ∃ F : circle_deg1_lift, semiconj F f₁ f₂ :=
semiconj_of_is_unit_of_translation_number_eq
  (is_unit_iff_bijective.2 h₁) (is_unit_iff_bijective.2 h₂) h

end circle_deg1_lift


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

! This file was ported from Lean 3 source module algebra.module.submodule.bilinear
! leanprover-community/mathlib commit 6010cf523816335f7bae7f8584cb2edaace73940
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.LinearAlgebra.Span
import Mathlib.LinearAlgebra.BilinearMap

/-!
# Images of pairs of submodules under bilinear maps

This file provides `Submodule.map₂`, which is later used to implement `Submodule.mul`.

## Main results

* `Submodule.map₂_eq_span_image2`: the image of two submodules under a bilinear map is the span of
  their `Set.image2`.

## Notes

This file is quite similar to the n-ary section of `Data.Set.Basic` and to `Order.Filter.NAry`.
Please keep them in sync.
-/

universe uι u v

open Set

open BigOperators

open Pointwise

namespace Submodule

variable {ι : Sort uι} {R M N P : Type _}

variable [CommSemiring R] [AddCommMonoid M] [AddCommMonoid N] [AddCommMonoid P]

variable [Module R M] [Module R N] [Module R P]

/-- Map a pair of submodules under a bilinear map.

This is the submodule version of `Set.image2`.  -/
def map₂ (f : M →ₗ[R] N →ₗ[R] P) (p : Submodule R M) (q : Submodule R N) : Submodule R P :=
  ⨆ s : p, q.map <| f s
#align submodule.map₂ Submodule.map₂

theorem apply_mem_map₂ (f : M →ₗ[R] N →ₗ[R] P) {m : M} {n : N} {p : Submodule R M}
    {q : Submodule R N} (hm : m ∈ p) (hn : n ∈ q) : f m n ∈ map₂ f p q :=
  (le_supᵢ _ ⟨m, hm⟩ : _ ≤ map₂ f p q) ⟨n, hn, by rfl⟩
#align submodule.apply_mem_map₂ Submodule.apply_mem_map₂

theorem map₂_le {f : M →ₗ[R] N →ₗ[R] P} {p : Submodule R M} {q : Submodule R N}
    {r : Submodule R P} : map₂ f p q ≤ r ↔ ∀ m ∈ p, ∀ n ∈ q, f m n ∈ r :=
  ⟨fun H _m hm _n hn => H <| apply_mem_map₂ _ hm hn, fun H =>
    supᵢ_le fun ⟨m, hm⟩ => map_le_iff_le_comap.2 fun n hn => H m hm n hn⟩
#align submodule.map₂_le Submodule.map₂_le

variable (R)
theorem map₂_span_span (f : M →ₗ[R] N →ₗ[R] P) (s : Set M) (t : Set N) :
    map₂ f (span R s) (span R t) = span R (Set.image2 (fun m n => f m n) s t) := by
  apply le_antisymm
  · rw [map₂_le]
    apply @span_induction' R M _ _ _ s
    intro a ha
    apply @span_induction' R N _ _ _ t
    intro b hb
    exact subset_span ⟨_, _, ‹_›, ‹_›, rfl⟩
    all_goals intros; simp only [*, add_mem, smul_mem, zero_mem, _root_.map_zero, map_add,
                                 LinearMap.zero_apply, LinearMap.add_apply, LinearMap.smul_apply,
                                 SMulHomClass.map_smul]
  · rw [span_le]
    rintro _ ⟨a, b, ha, hb, rfl⟩
    exact apply_mem_map₂ _ (subset_span ha) (subset_span hb)
#align submodule.map₂_span_span Submodule.map₂_span_span
variable {R}

@[simp]
theorem map₂_bot_right (f : M →ₗ[R] N →ₗ[R] P) (p : Submodule R M) : map₂ f p ⊥ = ⊥ :=
  eq_bot_iff.2 <|
    map₂_le.2 fun m _hm n hn => by
      rw [Submodule.mem_bot] at hn
      rw [hn, LinearMap.map_zero]; simp only [mem_bot]
#align submodule.map₂_bot_right Submodule.map₂_bot_right

@[simp]
theorem map₂_bot_left (f : M →ₗ[R] N →ₗ[R] P) (q : Submodule R N) : map₂ f ⊥ q = ⊥ :=
  eq_bot_iff.2 <|
    map₂_le.2 fun m hm n hn => by
      rw [Submodule.mem_bot] at hm⊢
      rw [hm, LinearMap.map_zero₂]
#align submodule.map₂_bot_left Submodule.map₂_bot_left

@[mono]
theorem map₂_le_map₂ {f : M →ₗ[R] N →ₗ[R] P} {p₁ p₂ : Submodule R M} {q₁ q₂ : Submodule R N}
    (hp : p₁ ≤ p₂) (hq : q₁ ≤ q₂) : map₂ f p₁ q₁ ≤ map₂ f p₂ q₂ :=
  map₂_le.2 fun _m hm _n hn => apply_mem_map₂ _ (hp hm) (hq hn)
#align submodule.map₂_le_map₂ Submodule.map₂_le_map₂

theorem map₂_le_map₂_left {f : M →ₗ[R] N →ₗ[R] P} {p₁ p₂ : Submodule R M} {q : Submodule R N}
    (h : p₁ ≤ p₂) : map₂ f p₁ q ≤ map₂ f p₂ q :=
  map₂_le_map₂ h (le_refl q)
#align submodule.map₂_le_map₂_left Submodule.map₂_le_map₂_left

theorem map₂_le_map₂_right {f : M →ₗ[R] N →ₗ[R] P} {p : Submodule R M} {q₁ q₂ : Submodule R N}
    (h : q₁ ≤ q₂) : map₂ f p q₁ ≤ map₂ f p q₂ :=
  map₂_le_map₂ (le_refl p) h
#align submodule.map₂_le_map₂_right Submodule.map₂_le_map₂_right

theorem map₂_sup_right (f : M →ₗ[R] N →ₗ[R] P) (p : Submodule R M) (q₁ q₂ : Submodule R N) :
    map₂ f p (q₁ ⊔ q₂) = map₂ f p q₁ ⊔ map₂ f p q₂ :=
  le_antisymm
    (map₂_le.2 fun _m hm _np hnp =>
      let ⟨_n, hn, _p, hp, hnp⟩ := mem_sup.1 hnp
      mem_sup.2 ⟨_, apply_mem_map₂ _ hm hn, _, apply_mem_map₂ _ hm hp, hnp ▸ (map_add _ _ _).symm⟩)
    (sup_le (map₂_le_map₂_right le_sup_left) (map₂_le_map₂_right le_sup_right))
#align submodule.map₂_sup_right Submodule.map₂_sup_right

theorem map₂_sup_left (f : M →ₗ[R] N →ₗ[R] P) (p₁ p₂ : Submodule R M) (q : Submodule R N) :
    map₂ f (p₁ ⊔ p₂) q = map₂ f p₁ q ⊔ map₂ f p₂ q :=
  le_antisymm
    (map₂_le.2 fun _mn hmn _p hp =>
      let ⟨_m, hm, _n, hn, hmn⟩ := mem_sup.1 hmn
      mem_sup.2
        ⟨_, apply_mem_map₂ _ hm hp, _, apply_mem_map₂ _ hn hp,
          hmn ▸ (LinearMap.map_add₂ _ _ _ _).symm⟩)
    (sup_le (map₂_le_map₂_left le_sup_left) (map₂_le_map₂_left le_sup_right))
#align submodule.map₂_sup_left Submodule.map₂_sup_left

theorem image2_subset_map₂ (f : M →ₗ[R] N →ₗ[R] P) (p : Submodule R M) (q : Submodule R N) :
    Set.image2 (fun m n => f m n) (↑p : Set M) (↑q : Set N) ⊆ (↑(map₂ f p q) : Set P) := by
  rintro _ ⟨i, j, hi, hj, rfl⟩
  exact apply_mem_map₂ _ hi hj
#align submodule.image2_subset_map₂ Submodule.image2_subset_map₂

theorem map₂_eq_span_image2 (f : M →ₗ[R] N →ₗ[R] P) (p : Submodule R M) (q : Submodule R N) :
    map₂ f p q = span R (Set.image2 (fun m n => f m n) (p : Set M) (q : Set N)) := by
  rw [← map₂_span_span, span_eq, span_eq]
#align submodule.map₂_eq_span_image2 Submodule.map₂_eq_span_image2

theorem map₂_supᵢ_left (f : M →ₗ[R] N →ₗ[R] P) (s : ι → Submodule R M) (t : Submodule R N) :
    map₂ f (⨆ i, s i) t = ⨆ i, map₂ f (s i) t := by
  suffices map₂ f (⨆ i, span R (s i : Set M)) (span R t) = ⨆ i, map₂ f (span R (s i)) (span R t) by
    simpa only [span_eq] using this
  simp_rw [map₂_span_span, ← span_unionᵢ, map₂_span_span, Set.image2_unionᵢ_left]
#align submodule.map₂_supr_left Submodule.map₂_supᵢ_left

theorem map₂_supᵢ_right (f : M →ₗ[R] N →ₗ[R] P) (s : Submodule R M) (t : ι → Submodule R N) :
    map₂ f s (⨆ i, t i) = ⨆ i, map₂ f s (t i) := by
  suffices map₂ f (span R s) (⨆ i, span R (t i : Set N)) = ⨆ i, map₂ f (span R s) (span R (t i)) by
    simpa only [span_eq] using this
  simp_rw [map₂_span_span, ← span_unionᵢ, map₂_span_span, Set.image2_unionᵢ_right]
#align submodule.map₂_supr_right Submodule.map₂_supᵢ_right

theorem map₂_span_singleton_eq_map (f : M →ₗ[R] N →ₗ[R] P) (m : M) :
    map₂ f (span R {m}) = map (f m) := by
  funext; rw [map₂_eq_span_image2]; apply le_antisymm
  · rw [span_le, Set.image2_subset_iff]
    intro x hx y hy
    obtain ⟨a, rfl⟩ := mem_span_singleton.1 hx
    rw [f.map_smul]
    exact smul_mem _ a (mem_map_of_mem hy)
  · rintro _ ⟨n, hn, rfl⟩
    exact subset_span ⟨m, n, mem_span_singleton_self m, hn, rfl⟩
#align submodule.map₂_span_singleton_eq_map Submodule.map₂_span_singleton_eq_map

theorem map₂_span_singleton_eq_map_flip (f : M →ₗ[R] N →ₗ[R] P) (s : Submodule R M) (n : N) :
    map₂ f s (span R {n}) = map (f.flip n) s := by rw [← map₂_span_singleton_eq_map, map₂_flip]
#align submodule.map₂_span_singleton_eq_map_flip Submodule.map₂_span_singleton_eq_map_flip

end Submodule


import data.list.basic

universe u

theorem list.foldl_map' {α β: Type u} (g : α → β) (f : α → α → α) (f' : β → β → β)
  (a : α) (l : list α) (h : ∀ x y, g (f x y) = f' (g x) (g y)) :
  g (list.foldl f a l) = list.foldl f' (g a) (l.map g) :=
begin
  induction l generalizing a,
  { simp },
  { simp [list.foldl_cons, l_ih, h] }
end

lemma function.injective_foldl_comp {α : Type*} {l : list (α → α)} {f : α → α}
  (hl : ∀ f ∈ l, function.injective f) (hf : function.injective f):
  function.injective (@list.foldl (α → α) (α → α) function.comp f l) :=
begin
  induction l generalizing f,
  { exact hf },
  { apply l_ih (λ _ h, hl _ (list.mem_cons_of_mem _ h)),
    apply function.injective.comp hf,
    apply hl _ (list.mem_cons_self _ _) }
end


inductive Vec.{u} (α : Type u) : Nat → Type u
| nil  : Vec α 0
| cons : α → {n : Nat} → Vec α n → Vec α (n+1)

open Vec
universes u

variable {α : Type u}
variable (f : α → α → α)

def mapHead1 : {n : Nat} → Vec α n → Vec α n → Vec α n
| _, nil, nil => nil
| _, cons a va, cons b bv => cons (f a b) va

theorem ex1 : mapHead1 f nil nil = nil :=
rfl

theorem ex2 (a b : α) (n : Nat) (va vb : Vec α n) : mapHead1 f (cons a va) (cons b vb) = cons (f a b) va :=
rfl


import syntax
import tactic

import data.subtype
import tactic.induction

namespace typing_relation

open term type

variables {gnd con fv : Type} [fvar fv] [const con gnd]

-- Tried alist, it got messy
def env (gnd fv : Type) := list (Σ (_ : fv), type gnd)
instance : has_mem (Σ (_ : fv), type gnd) (env gnd fv) := list.has_mem

inductive ok : env gnd fv → Type
| Nil  : ok []
| Cons : ∀ {Γ x A}, ok Γ → x ∉ Γ.keys → ok (⟨x, A⟩ :: Γ)

theorem ok_unicity {Γ : env gnd fv} (h1 h2 : ok Γ) : h1 = h2 :=
begin
  with_cases { induction' Γ fixing *; cases h1; cases h2 },
  case list.nil
  { refl },
  case list.cons : Γ ih x A h1 hx1 h2 hx2
  { rw ih h1 h2 }
end

theorem nodupkeys_of_ok {Γ : env gnd fv} (hΓ : ok Γ) : Γ.nodupkeys :=
begin
  induction hΓ,
  case ok.Nil { exact list.nodupkeys_nil },
  case ok.Cons : Γ x A hΓ hx ih {
    simp only [list.nodupkeys_cons],
    exact ⟨hx, ih⟩
  }
end

-- This has to be a Type, since we interpret the structure of derivations
-- into morphisms in a category for the semantics. Making it Prop would make it
-- impossible to pattern match on the structure of the derivations, since proofs
-- are erased.
inductive has_type : env gnd fv → term gnd con fv → type gnd → Type

| Fvar  : ∀ {Γ : env gnd fv} {x : fv} {A : type gnd},
ok (⟨x, A⟩ :: Γ)
------------------------------
→ has_type (⟨x, A⟩ :: Γ) ⌊x⌋ A

| Fvar' : ∀ {Γ : env gnd fv} {x y : fv} {A A' : type gnd},
y ∉ Γ.keys → x ≠ y → has_type Γ ⌊x⌋ A
-------------------------------------
→ has_type (⟨y, A'⟩ :: Γ) ⌊x⌋ A

| Const : ∀ {Γ c},
ok Γ
-------------------------------
→ has_type Γ (|c|) (const.type_of c)

| Unit : ∀ {Γ},
ok Γ
--------------------
→ has_type Γ ⟪⟫ unit

| Pair : ∀ {Γ t t' A A'},
has_type Γ t A → has_type Γ t' A'
-------------------------------------
→ has_type Γ ⟪t, t'⟫ (A ∏ A')

| Fst : ∀ {Γ t A A'},
has_type Γ t (A ∏ A')
------------------------
→ has_type Γ (fst t) A

| Snd : ∀ {Γ t A A'},
has_type Γ t (A ∏ A')
-------------------------
→ has_type Γ (snd t) A'

-- Since has_type is a Type not Prop, this should really be Π not ∀, but it's
-- helpful to think of it as like a Prop with proof-relevance.
| Abs : ∀ {Γ : env gnd fv} {t A A'},
(∀ x ∉ free_vars t ∪ Γ.keys.to_finset, has_type (⟨x, A⟩ :: Γ) (open_var x 0 t) A')
--------------------------------------------------------------------------------
→ has_type Γ (Λ A. t) (A ⊃ A')

| App : ∀ {Γ t t' A A'},
has_type Γ t (A ⊃ A') → has_type Γ t' A
---------------------------------------------
→ has_type Γ (t ⬝ t') A'

notation Γ ` ⊩ ` t ` ∷ ` A := has_type Γ t A

variables {Γ : env gnd fv} {t t1 t2 : term gnd con fv} {A A1 A2 B C : type gnd}
          {x y : fv}

lemma mem_of_has_type_fv (h : Γ ⊩ (⌊x⌋ : term gnd con fv) ∷ A)
: sigma.mk x A ∈ Γ :=
begin
  induction' h,
  { simp },
  { simp only [list.mem_cons_iff, heq_iff_eq], right, exact ih }
end

lemma ok_of_has_type (h : Γ ⊩ t ∷ A) : ok Γ :=
begin
  induction' h,
  case typing_relation.has_type.Fvar
  { exact x_1 },
  case typing_relation.has_type.Fvar' : Γ x y A A' h h_1 h_2 ih
  { apply ok.Cons, exact ih, exact h },
  case typing_relation.has_type.Const : Γ c
  { exact x },
  case typing_relation.has_type.Unit
  { exact x },
  case typing_relation.has_type.Pair : Γ t1 t2 A1 A2 h1 h2 ih1 ih2
  { exact ih1 },
  case typing_relation.has_type.Fst : Γ t_1 A A' h ih
  { exact ih },
  case typing_relation.has_type.Snd : Γ t_1 A A' h ih
  { exact ih },
  case typing_relation.has_type.Abs : Γ t1 A B h ih
  { set x := fvar.fresh (free_vars t1 ∪ Γ.keys.to_finset),
    have hfresh := fvar.hfresh (free_vars t1 ∪ Γ.keys.to_finset),
    specialize @ih x hfresh,
    cases' ih,
    exact ih
  },
  case typing_relation.has_type.App : Γ t1 t2 A1 A2 h1 h2 ih1 ih2
  { exact ih1 }
end

lemma lc_of_has_type (h : Γ ⊩ t ∷ A) : locally_closed Γ.keys.to_finset t :=
begin
  induction' h,
  case typing_relation.has_type.Fvar : Γ x A h
  { apply locally_closed.Fvar,
    simp only [list.keys_cons, list.to_finset_cons, finset.mem_insert,
               eq_self_iff_true, true_or]
  },
  case typing_relation.has_type.Fvar' : Γ x y A A' h h_1 h_2 ih
  { apply locally_closed.Fvar,
    cases' ih,
    simp only [list.keys_cons, list.to_finset_cons, finset.mem_insert,
               list.mem_to_finset] at h_3 ⊢,
    right,
    exact h_3
  },
  case typing_relation.has_type.Const : Γ c h
  { exact locally_closed.Const },
  case typing_relation.has_type.Unit : Γ h
  { exact locally_closed.Unit },
  case typing_relation.has_type.Pair : Γ t1 t2 A1 A2 h1 h2 ih1 ih2
  { exact locally_closed.Pair ih1 ih2 },
  case typing_relation.has_type.Fst : Γ t A A' h ih
  { exact locally_closed.Fst ih },
  case typing_relation.has_type.Snd : Γ t A A_1 h ih
  { exact locally_closed.Snd ih },
  case typing_relation.has_type.Abs : Γ t A A_1 h ih
  { apply locally_closed.Abs,
    intros x hx,
    specialize h x hx,
    specialize ih x hx,
    simp at ih,
    exact ih
  },
  case typing_relation.has_type.App : Γ t1 t2 A1 A2 h1 h2 ih1 ih2
  { exact locally_closed.App ih1 ih2 },
end

theorem type_unicity (h1 : Γ ⊩ t ∷ A1) (h2 : Γ ⊩ t ∷ A2) : A1 = A2 :=
begin
  have ht := lc_of_has_type h1,
  with_cases {induction' ht generalizing Γ A1 A2 t; cases h1; cases h2},
  case locally_closed.Const { refl },
  case locally_closed.Unit { refl },
  case locally_closed.Pair
  : _ t1 t2 hlc1 hlc2 ih1 ih2 A1 A2 h1t1 h1t2 B1 B2 h2t1 h2t2 {
    simp only,
    split,
    exact ih1 h1t1 h2t1,
    exact ih2 h1t2 h2t2
  },
  case locally_closed.Fst : _ A1 A2 t hlc ih B1 h1 B2 h2 {
    specialize ih h1 h2,
    simp only at ih,
    exact ih.left
  },
  case locally_closed.Snd : _ A1 A2 t hlc ih B1 h1 B2 h2 {
    specialize ih h1 h2,
    simp only at ih,
    exact ih.right
  },
  case locally_closed.Abs : _ B t hlc ih A1 h1 A2 h2 {
    simp only [eq_self_iff_true, true_and],
    have hfresh := fvar.hfresh (free_vars t ∪ (list.keys Γ).to_finset),
    set x := fvar.fresh (free_vars t ∪ (list.keys Γ).to_finset),
    specialize h1 x hfresh,
    specialize h2 x hfresh,
    refine ih x hfresh _ h1 h2,
    simp,
  },
  case locally_closed.App
  : _  A1 A2 t1 t2 hlc1 hlc2 ih1 ih2 B1 h1t2 h1t1 B2 h2t2 h2t1 {
    specialize ih1 h1t1 h2t1,
    simp only at ih1,
    exact ih1.right,
  },
  case has_type.Fvar has_type.Fvar { refl },
  case has_type.Fvar has_type.Fvar' { contradiction },
  case has_type.Fvar' has_type.Fvar { contradiction },
  case has_type.Fvar' has_type.Fvar' : _ A1 A2 x hx y A' hy hneq h1 _ _ h2 {
    have hnodup := nodupkeys_of_ok (ok_of_has_type h1),
    exact hnodup.eq_of_mk_mem (mem_of_has_type_fv h1) (mem_of_has_type_fv h2)
  }
end

theorem deriv_unicity (h1 h2 : Γ ⊩ t ∷ A) : h1 = h2 :=
begin
  have ht := lc_of_has_type h1,
  --set FV := (list.keys Γ).to_finset,
  with_cases {induction' ht generalizing Γ A t; cases h1; cases h2},

  case locally_closed.Const : _ c h1 h2 { rw ok_unicity h1 h2 },
  case locally_closed.Unit : _ h1 h2 { rw ok_unicity h1 h2 },
  case locally_closed.Pair
  : _ t1 t2 hlc1 hlc2 ih1 ih2 A B h1t1 h1t2 h2t1 h2t2 {
    rw ih1 h1t1 h2t1,
    rw ih2 h1t2 h2t2
  },
  case locally_closed.Fst : _ A t hlc ih B1 h1 B2 h2 {
    have := type_unicity h1 h2,
    simp only [eq_self_iff_true, true_and] at this,
    subst this,
    rw ih h1 h2,
  },
  case locally_closed.Snd : _ A t hlc ih B1 h1 B2 h2 {
    have := type_unicity h1 h2,
    simp only [eq_self_iff_true, and_true] at this,
    subst this,
    rw ih h1 h2,
  },
  case locally_closed.Abs : _ A t hlc ih B h1 h2 {
    -- this looks easy now, but actually needed induction', otherwise the ih
    -- came in the wrong form and couldnt be used because it was not tracking enough
    -- info about the local closure hlc
    simp only,
    ext x hx,
    refine ih x hx _ (h1 x hx) (h2 x hx),
    simp,
  },
  case locally_closed.App
  : _ B t1 t2 hlc1 hlc2 ih1 ih2 A1 h1t2 h1t1 A2 h2t2 h2t1 {
    have := type_unicity h1t2 h2t2,
    subst this,
    rw ih1 h1t1 h2t1,
    rw ih2 h1t2 h2t2,
  },
  case has_type.Fvar has_type.Fvar : _ A x h1 hx h2 { rw ok_unicity h1 h2 },
  case has_type.Fvar has_type.Fvar' { contradiction },
  case has_type.Fvar' has_type.Fvar { contradiction },
  case has_type.Fvar' has_type.Fvar' : A1 x Γ y A2 hy hx hneq h1 hy' hneq' h2 {
    simp only,
    with_cases { induction' Γ fixing *; cases h1; cases h2 },
    case has_type.Fvar has_type.Fvar : _ _ _ _ _ h1 h2
    { rw ok_unicity h1 h2 },
    case has_type.Fvar has_type.Fvar'
    { contradiction },
    case has_type.Fvar' has_type.Fvar
    { contradiction },
    case has_type.Fvar' has_type.Fvar'
    : Γ ih x' A' hy _ hy' h1x' h1neqx' h1 h2x' h2neqx' h2
    { simp only,
      simp only [not_or_distrib, list.keys_cons, list.mem_cons_iff] at hy,
      refine ih hy.right _ h1 hy.right h2,
      simp only [list.keys_cons, list.to_finset_cons, finset.mem_insert,
                 list.mem_to_finset] at ⊢ hx,
      rcases hx with (hx | hx | hx),
      { left, exact hx }, { contradiction }, {right, exact hx}
    },
  }
end

lemma exchange (h : ⟨x, A⟩::⟨y, B⟩::Γ ⊩ t ∷ C) : ⟨y, B⟩::⟨x, A⟩::Γ ⊩ t ∷ C :=
begin
  sorry
  -- no time!
end

-- I realised (too late) I probably should've followed the
lemma weakening (hx : x ∉ free_vars t ∪ Γ.keys.to_finset)
(h : Γ ⊩ t ∷ A) : (⟨x, B⟩::Γ) ⊩ t ∷ A :=
begin
  induction' h generalizing Γ t A,
  case typing_relation.has_type.Fvar : Γ x_1 A h
  { simp only [not_or_distrib, list.keys_cons, list.to_finset_cons,
               finset.union_insert, finset.mem_insert, finset.mem_union,
               list.mem_to_finset] at hx,
    apply has_type.Fvar',
    { simp only [not_or_distrib, list.keys_cons, list.mem_cons_iff],
      exact ⟨hx.left, hx.right.right⟩ },
    { symmetry, exact hx.left },
    exact has_type.Fvar h
  },
  case typing_relation.has_type.Fvar' : Γ x_1 y A A' h h_1 h_2 ih
  { simp only [not_or_distrib, list.keys_cons, list.to_finset_cons,
               finset.union_insert, finset.mem_insert, finset.mem_union,
               list.mem_to_finset, free_vars, finset.not_mem_singleton] at hx,
    apply has_type.Fvar',
    { simp only [not_or_distrib, list.keys_cons, list.mem_cons_iff],
      exact ⟨hx.left, hx.right.right⟩ },
    { symmetry, exact hx.right.left },
    apply has_type.Fvar',
    { exact h }, { exact h_1 },
    exact h_2
  },
  case typing_relation.has_type.Const : Γ c h
  { apply has_type.Const,
    apply ok.Cons,
    exact h,
    simp only [not_or_distrib, list.keys_cons, list.to_finset_cons,
              finset.union_insert, finset.mem_insert, finset.mem_union,
              list.mem_to_finset] at hx,
    exact hx.right,
  },
  case typing_relation.has_type.Unit : Γ h
  { apply has_type.Unit,
    apply ok.Cons,
    exact h,
    simp only [not_or_distrib, list.keys_cons, list.to_finset_cons,
              finset.union_insert, finset.mem_insert, finset.mem_union,
              list.mem_to_finset] at hx,
    exact hx.right,
  },
  case typing_relation.has_type.Pair : Γ t1 t2 A1 A2 h1 h2 ih1 ih2
  { simp only [not_or_distrib, list.keys_cons, list.to_finset_cons,
               finset.union_insert, finset.mem_insert, finset.mem_union,
               list.mem_to_finset, free_vars, finset.not_mem_singleton] at hx,
    apply has_type.Pair,
    { apply ih1,
      simp only [not_or_distrib, finset.mem_union, list.mem_to_finset],
      exact ⟨hx.left.left, hx.right⟩
    },
    { apply ih2,
      simp only [not_or_distrib, finset.mem_union, list.mem_to_finset],
      exact ⟨hx.left.right, hx.right⟩
    }
  },
  case typing_relation.has_type.Fst : Γ t A A' h ih
  { apply has_type.Fst, exact ih hx },
  case typing_relation.has_type.Snd : Γ t A A_1 h ih
  { apply has_type.Snd, exact ih hx },
  case typing_relation.has_type.Abs : Γ t A A_1 h ih
  { apply has_type.Abs, intros x1 hx1,
    /- actually might need to strengthen the goal to
       (h : Δ ++ Γ ⊩ t ∷ A) : (Δ ++ ⟨x, B⟩::Γ) ⊩ t ∷ A,
       and maybe need exchange lemma? -/
    sorry
  },
  case typing_relation.has_type.App : Γ t1 t2 A B h1 h2 ih1 ih2
  { simp only [not_or_distrib, list.keys_cons, list.to_finset_cons,
               finset.union_insert, finset.mem_insert, finset.mem_union,
               list.mem_to_finset, free_vars, finset.not_mem_singleton] at hx,
    apply has_type.App,
    { apply ih1,
      simp only [not_or_distrib, finset.mem_union, list.mem_to_finset],
      exact ⟨hx.left.left, hx.right⟩
    },
    { apply ih2,
      simp only [not_or_distrib, finset.mem_union, list.mem_to_finset],
      exact ⟨hx.left.right, hx.right⟩
    }
  },
end

lemma subst_preserves_type
(h1 : (⟨x, A1⟩::Γ ⊩ t2 ∷ A2)) (h2 : (Γ ⊩ t1 ∷ A1))
: (Γ ⊩ (subst t1 x t2) ∷ A2) :=
begin
  have ht2 := lc_of_has_type h1,
  induction' ht2 generalizing Γ x t1 t2 A1 A2 h2,
  case term.locally_closed.Const : t2
  { simp only [subst],
    cases' h1,
    apply has_type.Const,
    cases' x_1,
    exact x_1
  },
  case term.locally_closed.Fvar : t
  { simp only [subst],
    split_ifs,
    { subst h_1, cases' h1, { exact h2 }, { contradiction } },
    { cases' h1, { contradiction }, { exact h1 } }
  },
  case term.locally_closed.Unit
  { simp only [subst],
    cases' h1,
    apply has_type.Unit,
    cases' x_1,
    exact x_1
  },
  case term.locally_closed.Pair : t2l t2r ht2l ht2r ihl ihr
  { simp only [subst],
    cases' h1,
    specialize ihl h2 h1,
    specialize ihr h2 h1_1,
    exact has_type.Pair ihl ihr
  },
  case term.locally_closed.Fst : t2 ht2 ih
  { simp only [subst],
    cases' h1,
    exact has_type.Fst (ih h2 h1)
  },
  case term.locally_closed.Snd : t2 ht2 ih
  { simp only [subst],
    cases' h1,
    exact has_type.Snd (ih h2 h1)
  },
  case term.locally_closed.Abs : A1 t2 ht2 ih
  { simp only [subst],
    cases' h1,
    apply has_type.Abs,
    intros x1 hx1,
    -- This should be doable in principle, need to show a similar lemma to
    -- free_vars_open_term but for free_vars_subst instead.
    -- also need to show commutativity between subst and open_var...
    sorry
  },
  case term.locally_closed.App : t2l t2r ht2l ht2r ihl ihr
  { simp only [subst],
    cases' h1,
    specialize ihl h2 h1,
    specialize ihr h2 h1_1,
    exact has_type.App ihl ihr
  }
end

lemma free_vars_subset_env (h : Γ ⊩ t ∷ A) : free_vars t ⊆ Γ.keys.to_finset :=
begin
  induction' h,
  case typing_relation.has_type.Fvar : Γ x A x_1
  { simp only [free_vars, list.keys_cons, list.to_finset_cons,
               finset.singleton_subset_iff, finset.mem_insert, eq_self_iff_true,
               true_or],
  },
  case typing_relation.has_type.Fvar' : Γ x y A A' h h_1 h_2 ih
  { simp only [free_vars, list.keys_cons, list.to_finset_cons,
               finset.singleton_subset_iff, finset.mem_insert, list.mem_to_finset]
               at ⊢ ih,
    right, exact ih
  },
  case typing_relation.has_type.Const : Γ c x
  { simp only [free_vars, finset.empty_subset] },
  case typing_relation.has_type.Unit : Γ x
  { simp only [free_vars, finset.empty_subset] },
  case typing_relation.has_type.Pair : Γ t1 t2 A1 A2 h1 h2 ih1 ih2
  { simp only [free_vars], exact finset.union_subset ih1 ih2 },
  case typing_relation.has_type.Fst : Γ t A A' h ih
  { simp only [free_vars], exact ih },
  case typing_relation.has_type.Snd : Γ t A A_1 h ih
  { simp only [free_vars], exact ih },
  case typing_relation.has_type.Abs : Γ t A A_1 h ih
  { have hfresh := fvar.hfresh (free_vars t ∪ (list.keys Γ).to_finset),
    set x := fvar.fresh (free_vars t ∪ (list.keys Γ).to_finset),
    specialize ih x hfresh,
    specialize h x hfresh,
    simp only [free_vars],
    have := free_vars_open_var t x 0,
    cases this,
    all_goals {
      simp only [this, finset.insert_eq, list.keys_cons, list.to_finset_cons] at ih,
      rw finset.subset_iff; intros x' hx',
    },
    -- do this for first goal
    any_goals {specialize ih (finset.subset_union_left _ _ hx')},
    -- do this for second goal
    any_goals {specialize ih hx'},
    -- and then same steps across both goals again
    all_goals {
      cases finset.mem_union.mp ih,
      { exfalso, rw finset.mem_singleton at h_1, rw h_1 at hx',
        rw finset.not_mem_union at hfresh, exact hfresh.left hx' },
      { exact h_1 },
    }
  },
  case typing_relation.has_type.App : Γ t1 t2 A1 A2 h1 h2 ih1 ih2
  { simp only [free_vars], exact finset.union_subset ih1 ih2 },
end

end typing_relation