import S5.semantics.basic

open Classical

-- General facts about non-modal logical constants
theorem neg_tt_iff_ff { M : model } { w : world } { p : form } : (M, w ⊩ (¬p)) = True ↔ ¬(M, w ⊩ p) := sorry
theorem neg_ff_iff_tt { M : model } { w : world } { p : form } : (M, w ⊩ p) = True ↔ ¬(M, w ⊩ (¬p)) := sorry

theorem impl_iff_implies { M : model } { w : world } {p q : form } :
  (M, w ⊩ (p → q)) = True ↔ ((M, w ⊩ p) → (M, w ⊩ q)) := sorry

theorem impl_tt_iff_ff_or_tt { M : model } { w : world } { p q : form } :
  (M, w ⊩ (p → q)) = true ↔ (¬(M, w ⊩ p)) ∨ (M, w ⊩ q) = True := sorry

theorem ff_or_tt_and_tt_implies_tt_right { M : model } { w : world } { p q : form } :
  ((¬(M, w ⊩ p)) ∨ (M, w ⊩ q) = True) → ((M, w ⊩ p) = True) → ((M, w ⊩ q) = True) := sorry

theorem bot_is_insatisf { w : world } : ¬∃ (M : model), (M, w ⊩ ⊥) = True := sorry

--  Modal logical constants (=>)
theorem forall_wrld_tt_nec_tt { M : model } { w : world } { p : form } :
  (∀ v, (v ∈ M.worlds) → (w ∈ M.worlds) → (M.access w v) → ((M, v ⊩ p) = True) → ((M, w ⊩ (□p)) = True)) := sorry

theorem exists_wlrd_tt_pos_tt { M : model } { w : world } { p : form } :
  (∃ v, (v ∈ M.worlds) → (w ∈ M.worlds) → (M.access w v = True) → ((M, v ⊩ p) = True)) → ((M, w ⊩ ⋄p) = True) := sorry

-- Modal logical constants (<=)
theorem nec_tt_forall_wrld_tt { M : model } { w : world } { p : form } :
  ((M, w ⊩ (□p)) = True) → (∀ v, (v ∈ M.worlds) → (w ∈ M.worlds) → (M.access w v) → ((M, v ⊩ p) = True)) := sorry

theorem pos_tt_exists_wlrd_tt { M : model } { w : world } { p : form } :
  ((M, w ⊩ (□p)) = True) → (∃ v, (v ∈ M.worlds) → (w ∈ M.worlds) → (M.access w v) → ((M, v ⊩ p) = True)) := sorry

theorem pos_ff_forall_wrld_ff { M : model } { w : world } { p : form } :
  ((M, w ⊩ (⋄p)) = False) →(∀ v, (v ∈ M.worlds) → (w ∈ M.worlds) → (M.access w v) → ((M, v ⊩ p) = False)) := sorry

-- Some facts about PL
theorem is_true_pl1 { M : model } { w : world } { p q : form } : (M, w ⊩ p → (q → p)) = True := sorry
theorem is_true_pl2 { M : model } { w : world } { p q r : form } : (M, w ⊩ (p → (q → r)) → ((p → q) → (p → r))) := sorry
theorem is_true_pl3 { M : model } { w : world } { p q : form } : (M, w ⊩ (((¬p) → (¬q)) → (((¬p) → q) → p))) := sorry

-- Some facts about K
theorem nec_impl_to_nec_to_nec { M : model } { w : world } { p q : form } :
  ((M, w ⊩ □(p → q)) = True) → ((M, w ⊩ □p) = True) → ((M, w ⊩ □q) = True) := sorry

theorem nec_nec_to_nec_impl { M : model } { w : world } { p q : form } :
  ((M, w ⊩ □p) = True) → ((M, w ⊩ □q) = True) → ((M, w ⊩ □(p → q)) = True) := sorry

theorem nec_impl_to_nec_impl_nec { M : model } { w : world } { p q : form } :
  ((M, w ⊩ □(p → q)) = True) → (((M, w ⊩ □p) = False) ∨ ((M, w ⊩ □q) = True)) := sorry

theorem is_true_k { M : model } { w : world } { p q : form } :
  (M, w ⊩ (□(p → q)) → ((□p) → □q)) = True := sorry
--impl_iff_implies.2 (λ h => impl_tt_iff_ff_or_tt.2 (nec_impl_to_nec_impl_nec h))

-- Some facts about T
theorem nec_to_tt { M : model } { w : world } { wm : w ∈ M.worlds } { p : form } :
  (M, w ⊩ □p) = True → (M, w ⊩ p) = True := sorry

theorem is_true_t { M : model } { w : world } { wm : w ∈ M.worlds } { p : form } :
  (M, w ⊩ (□p) → p) = True := by
  apply impl_iff_implies.2
  apply nec_to_tt
  repeat assumption

-- Some facts about S4
theorem nec_to_nec_of_nec { M : model } { w : world } { p : form } :
  (M, w ⊩ □p) = True → (M, w ⊩ □□p) = True := sorry

theorem is_true_s4 { M : model } { w : world } { p : form } : (M, w ⊩ (□p) → □□p) = True := by
  apply impl_iff_implies.2
  apply nec_to_nec_of_nec

-- General facts about contexts
theorem ctx_tt_iff_mem_tt { Γ : ctx } { M : model } { w : world } :
  (M, w ⊩ Γ) = True ↔ (∀ p, (p ∈ Γ) → (M, w ⊩ p) = True) := sorry

theorem mem_tt_to_ctx_tt (Γ : ctx) { M : model } { w : world } :
  (∀ (p : form), (h : p ∈ Γ) → (M, w ⊩ p) = True) → (M, w ⊩ Γ) = True :=
  ctx_tt_iff_mem_tt.2

theorem ctx_tt_to_mem_tt { Γ : ctx } { M : model } { w : world } { p : form } :
  (M, w ⊩ Γ) = True → (p ∈ Γ) → (M, w ⊩ p) = True := by
  intro
  apply ctx_tt_iff_mem_tt.1
  assumption

-- The empty context
theorem empty_ctx_tt { M : model } { w : world } : (M, w ⊩ []) = True := by
  apply ctx_tt_iff_mem_tt.2
  intro
  sorry
  --apply False.elim
  --assumption


/-
Copyright (c) 2021 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.monoidal.functor
import category_theory.groupoid

/-!
# The free monoidal category over a type

Given a type `C`, the free monoidal category over `C` has as objects formal expressions built from
(formal) tensor products of terms of `C` and a formal unit. Its morphisms are compositions and
tensor products of identities, unitors and associators.

In this file, we construct the free monoidal category and prove that it is a monoidal category. If
`D` is a monoidal category, we construct the functor `free_monoidal_category C ⥤ D` associated to
a function `C → D`.

The free monoidal category has two important properties: it is a groupoid and it is thin. The former
is obvious from the construction, and the latter is what is commonly known as the monoidal coherence
theorem. Both of these properties are proved in the file `coherence.lean`.

-/

universes v' u u'

namespace category_theory
open monoidal_category

variables {C : Type u}

section
variables (C)

/--
Given a type `C`, the free monoidal category over `C` has as objects formal expressions built from
(formal) tensor products of terms of `C` and a formal unit. Its morphisms are compositions and
tensor products of identities, unitors and associators.
-/
@[derive inhabited]
inductive free_monoidal_category : Type u
| of : C → free_monoidal_category
| unit : free_monoidal_category
| tensor : free_monoidal_category → free_monoidal_category → free_monoidal_category

end

local notation `F` := free_monoidal_category

namespace free_monoidal_category

/-- Formal compositions and tensor products of identities, unitors and associators. The morphisms
    of the free monoidal category are obtained as a quotient of these formal morphisms by the
    relations defining a monoidal category. -/
@[nolint has_inhabited_instance]
inductive hom : F C → F C → Type u
| id (X) : hom X X
| α_hom (X Y Z : F C) : hom ((X.tensor Y).tensor Z) (X.tensor (Y.tensor Z))
| α_inv (X Y Z : F C) : hom (X.tensor (Y.tensor Z)) ((X.tensor Y).tensor Z)
| l_hom (X) : hom (unit.tensor X) X
| l_inv (X) : hom X (unit.tensor X)
| ρ_hom (X : F C) : hom (X.tensor unit) X
| ρ_inv (X : F C) : hom X (X.tensor unit)
| comp {X Y Z} (f : hom X Y) (g : hom Y Z) : hom X Z
| tensor {W X Y Z} (f : hom W Y) (g : hom X Z) : hom (W.tensor X) (Y.tensor Z)

local infixr ` ⟶ᵐ `:10 := hom

/-- The morphisms of the free monoidal category satisfy 21 relations ensuring that the resulting
    category is in fact a category and that it is monoidal. -/
inductive hom_equiv : Π {X Y : F C}, (X ⟶ᵐ Y) → (X ⟶ᵐ Y) → Prop
| refl {X Y} (f : X ⟶ᵐ Y) : hom_equiv f f
| symm {X Y} (f g : X ⟶ᵐ Y) : hom_equiv f g → hom_equiv g f
| trans {X Y} {f g h : X ⟶ᵐ Y} : hom_equiv f g → hom_equiv g h → hom_equiv f h
| comp {X Y Z} {f f' : X ⟶ᵐ Y} {g g' : Y ⟶ᵐ Z} :
    hom_equiv f f' → hom_equiv g g' → hom_equiv (f.comp g) (f'.comp g')
| tensor {W X Y Z} {f f' : W ⟶ᵐ X} {g g' : Y ⟶ᵐ Z} :
    hom_equiv f f' → hom_equiv g g' → hom_equiv (f.tensor g) (f'.tensor g')
| comp_id {X Y} (f : X ⟶ᵐ Y) : hom_equiv (f.comp (hom.id _)) f
| id_comp {X Y} (f : X ⟶ᵐ Y) : hom_equiv ((hom.id _).comp f) f
| assoc {X Y U V : F C} (f : X ⟶ᵐ U) (g : U ⟶ᵐ V) (h : V ⟶ᵐ Y) :
    hom_equiv ((f.comp g).comp h) (f.comp (g.comp h))
| tensor_id {X Y} : hom_equiv ((hom.id X).tensor (hom.id Y)) (hom.id _)
| tensor_comp {X₁ Y₁ Z₁ X₂ Y₂ Z₂ : F C}
    (f₁ : X₁ ⟶ᵐ Y₁) (f₂ : X₂ ⟶ᵐ Y₂) (g₁ : Y₁ ⟶ᵐ Z₁) (g₂ : Y₂ ⟶ᵐ Z₂) :
    hom_equiv ((f₁.comp g₁).tensor (f₂.comp g₂)) ((f₁.tensor f₂).comp (g₁.tensor g₂))
| α_hom_inv {X Y Z} : hom_equiv ((hom.α_hom X Y Z).comp (hom.α_inv X Y Z)) (hom.id _)
| α_inv_hom {X Y Z} : hom_equiv ((hom.α_inv X Y Z).comp (hom.α_hom X Y Z)) (hom.id _)
| associator_naturality {X₁ X₂ X₃ Y₁ Y₂ Y₃} (f₁ : X₁ ⟶ᵐ Y₁) (f₂ : X₂ ⟶ᵐ Y₂) (f₃ : X₃ ⟶ᵐ Y₃) :
    hom_equiv (((f₁.tensor f₂).tensor f₃).comp (hom.α_hom Y₁ Y₂ Y₃))
      ((hom.α_hom X₁ X₂ X₃).comp (f₁.tensor (f₂.tensor f₃)))
| ρ_hom_inv {X} : hom_equiv ((hom.ρ_hom X).comp (hom.ρ_inv X)) (hom.id _)
| ρ_inv_hom {X} : hom_equiv ((hom.ρ_inv X).comp (hom.ρ_hom X)) (hom.id _)
| ρ_naturality {X Y} (f : X ⟶ᵐ Y) : hom_equiv
    ((f.tensor (hom.id unit)).comp (hom.ρ_hom Y)) ((hom.ρ_hom X).comp f)
| l_hom_inv {X} : hom_equiv ((hom.l_hom X).comp (hom.l_inv X)) (hom.id _)
| l_inv_hom {X} : hom_equiv ((hom.l_inv X).comp (hom.l_hom X)) (hom.id _)
| l_naturality {X Y} (f : X ⟶ᵐ Y) : hom_equiv
    (((hom.id unit).tensor f).comp (hom.l_hom Y)) ((hom.l_hom X).comp f)
| pentagon {W X Y Z} : hom_equiv
  (((hom.α_hom W X Y).tensor (hom.id Z)).comp
    ((hom.α_hom W (X.tensor Y) Z).comp ((hom.id W).tensor (hom.α_hom X Y Z))))
  ((hom.α_hom (W.tensor X) Y Z).comp (hom.α_hom W X (Y.tensor Z)))
| triangle {X Y} : hom_equiv ((hom.α_hom X unit Y).comp ((hom.id X).tensor (hom.l_hom Y)))
  ((hom.ρ_hom X).tensor (hom.id Y))

/-- We say that two formal morphisms in the free monoidal category are equivalent if they become
    equal if we apply the relations that are true in a monoidal category. Note that we will prove
    that there is only one equivalence class -- this is the monoidal coherence theorem. -/
def setoid_hom (X Y : F C) : setoid (X ⟶ᵐ Y) :=
⟨hom_equiv,
  ⟨λ f, hom_equiv.refl f, λ f g, hom_equiv.symm f g, λ f g h hfg hgh, hom_equiv.trans hfg hgh⟩⟩

attribute [instance] setoid_hom

section
open free_monoidal_category.hom_equiv

instance category_free_monoidal_category : category.{u} (F C) :=
{ hom := λ X Y, quotient (free_monoidal_category.setoid_hom X Y),
  id := λ X, ⟦free_monoidal_category.hom.id _⟧,
  comp := λ X Y Z f g, quotient.map₂ hom.comp (by { intros f f' hf g g' hg, exact comp hf hg }) f g,
  id_comp' := by { rintro X Y ⟨f⟩, exact quotient.sound (id_comp f) },
  comp_id' := by { rintro X Y ⟨f⟩, exact quotient.sound (comp_id f) },
  assoc' := by { rintro W X Y Z ⟨f⟩ ⟨g⟩ ⟨h⟩, exact quotient.sound (assoc f g h) } }

instance : monoidal_category (F C) :=
{ tensor_obj := λ X Y, free_monoidal_category.tensor X Y,
  tensor_hom := λ X₁ Y₁ X₂ Y₂, quotient.map₂ hom.tensor $
    by { intros _ _ h _ _ h', exact hom_equiv.tensor h h'},
  tensor_id' := λ X Y, quotient.sound tensor_id,
  tensor_comp' := λ X₁ Y₁ Z₁ X₂ Y₂ Z₂,
    by { rintros ⟨f₁⟩ ⟨f₂⟩ ⟨g₁⟩ ⟨g₂⟩, exact quotient.sound (tensor_comp _ _ _ _) },
  tensor_unit := free_monoidal_category.unit,
  associator := λ X Y Z,
    ⟨⟦hom.α_hom X Y Z⟧, ⟦hom.α_inv X Y Z⟧, quotient.sound α_hom_inv, quotient.sound α_inv_hom⟩,
  associator_naturality' := λ X₁ X₂ X₃ Y₁ Y₂ Y₃,
    by { rintros ⟨f₁⟩ ⟨f₂⟩ ⟨f₃⟩, exact quotient.sound (associator_naturality _ _ _) },
  left_unitor := λ X,
   ⟨⟦hom.l_hom X⟧, ⟦hom.l_inv X⟧, quotient.sound l_hom_inv, quotient.sound l_inv_hom⟩,
  left_unitor_naturality' := λ X Y, by { rintro ⟨f⟩, exact quotient.sound (l_naturality _) },
  right_unitor := λ X,
   ⟨⟦hom.ρ_hom X⟧, ⟦hom.ρ_inv X⟧, quotient.sound ρ_hom_inv, quotient.sound ρ_inv_hom⟩,
  right_unitor_naturality' := λ X Y, by { rintro ⟨f⟩, exact quotient.sound (ρ_naturality _) },
  pentagon' := λ W X Y Z, quotient.sound pentagon,
  triangle' := λ X Y, quotient.sound triangle }

@[simp] lemma mk_comp {X Y Z : F C} (f : X ⟶ᵐ Y) (g : Y ⟶ᵐ Z) :
  ⟦f.comp g⟧ = @category_struct.comp (F C) _ _ _ _ ⟦f⟧ ⟦g⟧ :=
rfl

@[simp] lemma mk_tensor {X₁ Y₁ X₂ Y₂ : F C} (f : X₁ ⟶ᵐ Y₁) (g : X₂ ⟶ᵐ Y₂) :
  ⟦f.tensor g⟧ = @monoidal_category.tensor_hom (F C) _ _ _ _ _ _ ⟦f⟧ ⟦g⟧ :=
rfl

@[simp] lemma mk_id {X : F C} : ⟦hom.id X⟧ = 𝟙 X := rfl
@[simp] lemma mk_α_hom {X Y Z : F C} : ⟦hom.α_hom X Y Z⟧ = (α_ X Y Z).hom := rfl
@[simp] lemma mk_α_inv {X Y Z : F C} : ⟦hom.α_inv X Y Z⟧ = (α_ X Y Z).inv := rfl
@[simp] lemma mk_ρ_hom {X : F C} : ⟦hom.ρ_hom X⟧ = (ρ_ X).hom := rfl
@[simp] lemma mk_ρ_inv {X : F C} : ⟦hom.ρ_inv X⟧ = (ρ_ X).inv := rfl
@[simp] lemma mk_l_hom {X : F C} : ⟦hom.l_hom X⟧ = (λ_ X).hom := rfl
@[simp] lemma mk_l_inv {X : F C} : ⟦hom.l_inv X⟧ = (λ_ X).inv := rfl
@[simp] lemma tensor_eq_tensor {X Y : F C} : X.tensor Y = X ⊗ Y := rfl
@[simp] lemma unit_eq_unit : free_monoidal_category.unit = 𝟙_ (F C) := rfl

section functor
variables {D : Type u'} [category.{v'} D] [monoidal_category D] (f : C → D)

/-- Auxiliary definition for `free_monoidal_category.project`. -/
def project_obj : F C → D
| (free_monoidal_category.of X) := f X
| free_monoidal_category.unit := 𝟙_ D
| (free_monoidal_category.tensor X Y) := project_obj X ⊗ project_obj Y

section
open hom

/-- Auxiliary definition for `free_monoidal_category.project`. -/
@[simp] def project_map_aux : Π {X Y : F C}, (X ⟶ᵐ Y) → (project_obj f X ⟶ project_obj f Y)
| _ _ (id _) := 𝟙 _
| _ _ (α_hom _ _ _) := (α_ _ _ _).hom
| _ _ (α_inv _ _ _) := (α_ _ _ _).inv
| _ _ (l_hom _) := (λ_ _).hom
| _ _ (l_inv _) := (λ_ _).inv
| _ _ (ρ_hom _) := (ρ_ _).hom
| _ _ (ρ_inv _) := (ρ_ _).inv
| _ _ (comp f g) := project_map_aux f ≫ project_map_aux g
| _ _ (hom.tensor f g) := project_map_aux f ⊗ project_map_aux g

/-- Auxiliary definition for `free_monoidal_category.project`. -/
def project_map (X Y : F C) : (X ⟶ Y) → (project_obj f X ⟶ project_obj f Y) :=
quotient.lift (project_map_aux f)
begin
  intros f g h,
  induction h with X Y f X Y f g hfg hfg' X Y f g h _ _ hfg hgh X Y Z f f' g g' _ _ hf hg
    W X Y Z f g f' g' _ _ hfg hfg',
  { refl },
  { exact hfg'.symm },
  { exact hfg.trans hgh },
  { simp only [project_map_aux, hf, hg] },
  { simp only [project_map_aux, hfg, hfg'] },
  { simp only [project_map_aux, category.comp_id] },
  { simp only [project_map_aux, category.id_comp] },
  { simp only [project_map_aux, category.assoc ] },
  { simp only [project_map_aux, monoidal_category.tensor_id], refl },
  { simp only [project_map_aux, monoidal_category.tensor_comp] },
  { simp only [project_map_aux, iso.hom_inv_id] },
  { simp only [project_map_aux, iso.inv_hom_id] },
  { simp only [project_map_aux, monoidal_category.associator_naturality] },
  { simp only [project_map_aux, iso.hom_inv_id] },
  { simp only [project_map_aux, iso.inv_hom_id] },
  { simp only [project_map_aux], dsimp [project_obj],
    exact monoidal_category.right_unitor_naturality _ },
  { simp only [project_map_aux, iso.hom_inv_id] },
  { simp only [project_map_aux, iso.inv_hom_id] },
  { simp only [project_map_aux], dsimp [project_obj],
    exact monoidal_category.left_unitor_naturality _ },
  { simp only [project_map_aux], exact monoidal_category.pentagon _ _ _ _ },
  { simp only [project_map_aux], exact monoidal_category.triangle _ _ }
end

end

/-- If `D` is a monoidal category and we have a function `C → D`, then we have a functor from the
    free monoidal category over `C` to the category `D`. -/
def project : monoidal_functor (F C) D :=
{ obj := project_obj f,
  map := project_map f,
  ε := 𝟙 _,
  μ := λ X Y, 𝟙 _ }

end functor

end

end free_monoidal_category

end category_theory


import Hw7
import Lean.Elab.Print
import Lean.Elab.Command

theorem desiredType : ∀ (α : Type) (A B C : α → Prop),
  (∀ (x : α), A x ∨ B x) → (∀ (x : α), A x → C x) → (∀ (x : α), B x → C x) → ∀ (x : α), C x:= sorry

open Lean
open Lean.Meta
open Lean.Elab.Command

def collectAxiomsOf (constName : Name) : MetaM (List String) := do
  let env ← getEnv
  let (_, s) := ((CollectAxioms.collect constName).run env).run {}
  let a := s.axioms.toList.map toString
  return a

#eval isDefEq (Expr.const ``desiredType []) (Expr.const ``problem4 [])
#eval collectAxiomsOf ``problem4


import Init.Data.Format

def hello := "world"

inductive Lambda : Nat → Type u where
  | Var : Fin n → Lambda n
  | App : Lambda n → Lambda n → Lambda n
  | Abs : Lambda (n+1) → Lambda n

open Lambda

infix:70 "ᵛ" => λ n v => (Var v : Lambda n)

instance {n} : CoeFun (Lambda n) (λ _ => Lambda n → Lambda n) where
  coe := App

def ID : Lambda n → Lambda n := λ r => App (Abs $ Var ⟨n, Nat.lt_of_succ_le (Nat.le_refl _) ⟩) r

theorem Eq.comm : a = b ↔ b = a :=
  ⟨Eq.symm, Eq.symm⟩

def push_arg {n depth : Nat} : Lambda (n + depth) → Lambda (n + (depth + 1))
  | Var v => Var $
    if v < n then
      ⟨v.val, by
        apply Nat.lt_trans v.isLt
        rw [← Nat.add_assoc, Nat.add_one]
        apply Nat.lt_of_succ_le
        apply Nat.le_of_eq
        rfl
      ⟩
    else
      ⟨v.val + 1, by
        simp [← Nat.add_assoc, Nat.add_one]
        apply Nat.succ_lt_succ
        exact v.isLt
      ⟩
  | Abs body => Abs (push_arg body)
  | App l r => App (push_arg l) (push_arg r)

def beta_aux (arg : Lambda (n + depth)) (body : Lambda (n + depth + 1)) : Lambda (n + depth) :=
  match body with
  | Var v =>
    if v_lt : v.val < n
      then by
        apply Var ∘ Fin.mk v.val
        apply Nat.lt_of_lt_of_le v_lt
        apply Nat.le_add_right
    else if v_eq : v = n
      then arg
      else
        have n_lt_v : n < v.val := by
          have ⟨v', vh⟩ := v
          clear body arg
          simp at *
          clear depth vh v
          apply Nat.lt_of_le_of_ne
          apply Nat.ge_of_not_lt
          exact v_lt
          rw [Eq.comm]
          exact v_eq
        have h : v.val - 1 < n + depth := by
          suffices v.val - 1 + 1 < n + depth + 1 by
            apply Nat.lt_of_succ_lt_succ
            apply this
          rw [Nat.sub_add_cancel]
          exact v.isLt
          apply Nat.succ_le_of_lt
          apply Nat.lt_of_le_of_lt _ n_lt_v
          apply Nat.zero_le
        Var ⟨v.val - 1, h⟩
  | App l r => App (beta_aux arg l) (beta_aux arg r)
  | Abs newBody =>
    have newArg : Lambda (n + (depth + 1)) := push_arg arg
    Abs (beta_aux newArg newBody)

def beta_aux2 : Lambda n → Lambda (n + 1) → Lambda n := by
  rw [← Nat.add_zero n]
  apply @beta_aux n 0

inductive beta : Lambda n → Lambda n → Prop
  | here (body arg result) : result = beta_aux2 arg body → beta (App (Abs body) arg) result
  | left (xs : beta x y) : beta (App x z) (App y z)
  | right (xs : beta x y) : beta (App z x) (App z y)
  | abs (xs : beta x y) : beta (Abs x) (Abs y)

inductive RTC (R : α → α → Prop) : α → α → Prop where
  | refl : RTC R a a
  | step : R a b → RTC R b c → RTC R a c

theorem RTC.trans : RTC R a b → RTC R b c → RTC R a c := by
  intros ab bc
  induction ab
  case refl =>
    exact bc
  case step a' b' c' x _ xs_ih =>
    apply RTC.step x (xs_ih bc)

infix:50 "~>" => RTC beta

example : ∀ r : Lambda n, ID r ~> r := by
  intros r
  apply RTC.step _ RTC.refl
  apply beta.here
  rw [beta_aux2]
  simp [beta_aux, Eq.mpr]

def Lambda.reprPrec' : Lambda n → Nat → Std.Format
  | Var v, prec => reprPrec n prec ++ "ᵛ" ++  reprPrec v prec
  | App l r, prec => Std.Format.paren (reprPrec' l prec ++ " " ++ reprPrec' r prec)
  | Abs body, prec => Std.Format.paren $ "λ." ++ Repr.addAppParen (body.reprPrec' (prec + 1)) prec

instance : Repr (Lambda n) where
  reprPrec l n := Lambda.reprPrec' l n


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

import analysis.special_functions.pow
import linear_algebra.free_module.pid
import linear_algebra.matrix.absolute_value
import number_theory.class_number.admissible_absolute_value
import ring_theory.class_group
import ring_theory.dedekind_domain.integral_closure
import ring_theory.norm

/-!
# Class numbers of global fields
In this file, we use the notion of "admissible absolute value" to prove
finiteness of the class group for number fields and function fields,
and define `class_number` as the order of this group.
## Main definitions
 - `class_group.fintype_of_admissible`: if `R` has an admissible absolute value,
   its integral closure has a finite class group
-/

open_locale big_operators
open_locale non_zero_divisors

namespace class_group

open ring

open_locale big_operators

section euclidean_domain

variables (R S K L : Type*) [euclidean_domain R] [comm_ring S] [is_domain S]
variables [field K] [field L]
variables [algebra R K] [is_fraction_ring R K]
variables [algebra K L] [finite_dimensional K L] [is_separable K L]
variables [algRL : algebra R L] [is_scalar_tower R K L]
variables [algebra R S] [algebra S L]
variables [ist : is_scalar_tower R S L] [iic : is_integral_closure S R L]

variables {R S} (abv : absolute_value R ℤ)
variables {ι : Type*} [decidable_eq ι] [fintype ι] (bS : basis ι R S)

/-- If `b` is an `R`-basis of `S` of cardinality `n`, then `norm_bound abv b` is an integer
such that for every `R`-integral element `a : S` with coordinates `≤ y`,
we have algebra.norm a ≤ norm_bound abv b * y ^ n`. (See also `norm_le` and `norm_lt`). -/
noncomputable def norm_bound : ℤ :=
let n := fintype.card ι,
    i : ι := nonempty.some bS.index_nonempty,
    m : ℤ := finset.max' (finset.univ.image (λ (ijk : ι × ι × ι),
        abv (algebra.left_mul_matrix bS (bS ijk.1) ijk.2.1 ijk.2.2)))
        ⟨_, finset.mem_image.mpr ⟨⟨i, i, i⟩, finset.mem_univ _, rfl⟩⟩
in nat.factorial n • (n • m) ^ n

lemma norm_bound_pos : 0 < norm_bound abv bS :=
begin
  obtain ⟨i, j, k, hijk⟩ : ∃ i j k,
    algebra.left_mul_matrix bS (bS i) j k ≠ 0,
  { by_contra' h,
    obtain ⟨i⟩ := bS.index_nonempty,
    apply bS.ne_zero i,
    apply (injective_iff_map_eq_zero (algebra.left_mul_matrix bS)).mp
      (algebra.left_mul_matrix_injective bS),
    ext j k,
    simp [h, dmatrix.zero_apply] },
  simp only [norm_bound, algebra.smul_def, eq_nat_cast],
  refine mul_pos (int.coe_nat_pos.mpr (nat.factorial_pos _)) _,
  refine pow_pos (mul_pos (int.coe_nat_pos.mpr (fintype.card_pos_iff.mpr ⟨i⟩)) _) _,
  refine lt_of_lt_of_le (abv.pos hijk) (finset.le_max' _ _ _),
  exact finset.mem_image.mpr ⟨⟨i, j, k⟩, finset.mem_univ _, rfl⟩
end

/-- If the `R`-integral element `a : S` has coordinates `≤ y` with respect to some basis `b`,
its norm is less than `norm_bound abv b * y ^ dim S`. -/
lemma norm_le (a : S) {y : ℤ} (hy : ∀ k, abv (bS.repr a k) ≤ y) :
  abv (algebra.norm R a) ≤ norm_bound abv bS * y ^ fintype.card ι :=
begin
  conv_lhs { rw ← bS.sum_repr a },
  rw [algebra.norm_apply, ← linear_map.det_to_matrix bS],
  simp only [algebra.norm_apply, alg_hom.map_sum, alg_hom.map_smul, linear_equiv.map_sum,
      linear_equiv.map_smul, algebra.to_matrix_lmul_eq, norm_bound, smul_mul_assoc, ← mul_pow],
  convert matrix.det_sum_smul_le finset.univ _ hy using 3,
  { rw [finset.card_univ, smul_mul_assoc, mul_comm] },
  { intros i j k,
    apply finset.le_max',
    exact finset.mem_image.mpr ⟨⟨i, j, k⟩, finset.mem_univ _, rfl⟩ },
end

/-- If the `R`-integral element `a : S` has coordinates `< y` with respect to some basis `b`,
its norm is strictly less than `norm_bound abv b * y ^ dim S`. -/
lemma norm_lt {T : Type*} [linear_ordered_ring T]
  (a : S) {y : T} (hy : ∀ k, (abv (bS.repr a k) : T) < y) :
  (abv (algebra.norm R a) : T) < norm_bound abv bS * y ^ fintype.card ι :=
begin
  obtain ⟨i⟩ := bS.index_nonempty,
  have him : (finset.univ.image (λ k, abv (bS.repr a k))).nonempty :=
    ⟨_, finset.mem_image.mpr ⟨i, finset.mem_univ _, rfl⟩⟩,
  set y' : ℤ := finset.max' _ him with y'_def,
  have hy' : ∀ k, abv (bS.repr a k) ≤ y',
  { intro k,
    exact finset.le_max' _ _ (finset.mem_image.mpr ⟨k, finset.mem_univ _, rfl⟩) },
  have : (y' : T) < y,
  { rw [y'_def, ← finset.max'_image (show monotone (coe : ℤ → T), from λ x y h, int.cast_le.mpr h)],
    apply (finset.max'_lt_iff _ (him.image _)).mpr,
    simp only [finset.mem_image, exists_prop],
    rintros _ ⟨x, ⟨k, -, rfl⟩, rfl⟩,
    exact hy k },
  have y'_nonneg : 0 ≤ y' := le_trans (abv.nonneg _) (hy' i),
  apply (int.cast_le.mpr (norm_le abv bS a hy')).trans_lt,
  simp only [int.cast_mul, int.cast_pow],
  apply mul_lt_mul' le_rfl,
  { exact pow_lt_pow_of_lt_left this
      (int.cast_nonneg.mpr y'_nonneg)
      (fintype.card_pos_iff.mpr ⟨i⟩) },
  { exact pow_nonneg (int.cast_nonneg.mpr y'_nonneg) _ },
  { exact int.cast_pos.mpr (norm_bound_pos abv bS) },
  { apply_instance }
end

/-- A nonzero ideal has an element of minimal norm. -/
lemma exists_min (I : (ideal S)⁰) :
  ∃ b ∈ (I : ideal S), b ≠ 0 ∧
  ∀ c ∈ (I : ideal S), abv (algebra.norm R c) < abv (algebra.norm R b) → c = (0 : S) :=
begin
  obtain ⟨_, ⟨b, b_mem, b_ne_zero, rfl⟩, min⟩ := @int.exists_least_of_bdd
    (λ a, ∃ b ∈ (I : ideal S), b ≠ (0 : S) ∧ abv (algebra.norm R b) = a) _ _,
  { refine ⟨b, b_mem, b_ne_zero, _⟩,
    intros c hc lt,
    contrapose! lt with c_ne_zero,
    exact min _ ⟨c, hc, c_ne_zero, rfl⟩ },
  { use 0,
    rintros _ ⟨b, b_mem, b_ne_zero, rfl⟩,
    apply abv.nonneg },
  { obtain ⟨b, b_mem, b_ne_zero⟩ := (I : ideal S).ne_bot_iff.mp (non_zero_divisors.coe_ne_zero I),
    exact ⟨_, ⟨b, b_mem, b_ne_zero, rfl⟩⟩ }
end

section is_admissible

variables (L) {abv} (adm : abv.is_admissible)

include adm

/-- If we have a large enough set of elements in `R^ι`, then there will be a pair
whose remainders are close together. We'll show that all sets of cardinality
at least `cardM bS adm` elements satisfy this condition.

The value of `cardM` is not at all optimal: for specific choices of `R`,
the minimum cardinality can be exponentially smaller.
-/
noncomputable def cardM : ℕ :=
adm.card (norm_bound abv bS ^ (-1 / (fintype.card ι) : ℝ)) ^ fintype.card ι

variables [infinite R]

/-- In the following results, we need a large set of distinct elements of `R`. -/
noncomputable def distinct_elems : fin (cardM bS adm).succ ↪ R :=
fin.coe_embedding.trans (infinite.nat_embedding R)

variables [decidable_eq R]

/-- `finset_approx` is a finite set such that each fractional ideal in the integral closure
contains an element close to `finset_approx`. -/
noncomputable def finset_approx : finset R :=
(finset.univ.image $ λ xy : _ × _, distinct_elems bS adm xy.1 - distinct_elems bS adm xy.2).erase 0

lemma finset_approx.zero_not_mem : (0 : R) ∉ finset_approx bS adm :=
finset.not_mem_erase _ _

@[simp] lemma mem_finset_approx {x : R} :
  x ∈ finset_approx bS adm ↔
  ∃ i j, i ≠ j ∧ distinct_elems bS adm i - distinct_elems bS adm j = x :=
begin
  simp only [finset_approx, finset.mem_erase, finset.mem_image],
  split,
  { rintros ⟨hx, ⟨i, j⟩, _, rfl⟩,
    refine ⟨i, j, _, rfl⟩,
    rintro rfl,
    simpa using hx },
  { rintros ⟨i, j, hij, rfl⟩,
    refine ⟨_, ⟨i, j⟩, finset.mem_univ _, rfl⟩,
    rw [ne.def, sub_eq_zero],
    exact λ h, hij ((distinct_elems bS adm).injective h) }
end

section real

open real

local attribute [-instance] real.decidable_eq

/-- We can approximate `a / b : L` with `q / r`, where `r` has finitely many options for `L`. -/
theorem exists_mem_finset_approx (a : S) {b} (hb : b ≠ (0 : R)) :
  ∃ (q : S) (r ∈ finset_approx bS adm),
    abv (algebra.norm R (r • a - b • q)) < abv (algebra.norm R (algebra_map R S b)) :=
begin
  have dim_pos := fintype.card_pos_iff.mpr bS.index_nonempty,
  set ε : ℝ := norm_bound abv bS ^ (-1 / (fintype.card ι) : ℝ) with ε_eq,
  have hε : 0 < ε := real.rpow_pos_of_pos (int.cast_pos.mpr (norm_bound_pos abv bS)) _,
  have ε_le : (norm_bound abv bS : ℝ) * (abv b • ε) ^ fintype.card ι ≤
                (abv b ^ fintype.card ι),
  { have := norm_bound_pos abv bS,
    have := abv.nonneg b,
    rw [ε_eq, algebra.smul_def, eq_int_cast, ← rpow_nat_cast, mul_rpow, ← rpow_mul,
        div_mul_cancel, rpow_neg_one, mul_left_comm, mul_inv_cancel, mul_one, rpow_nat_cast];
      try { norm_cast, linarith },
    { apply rpow_nonneg_of_nonneg,
      norm_cast,
      linarith } },
  let μ : fin (cardM bS adm).succ ↪ R := distinct_elems bS adm,
  set s := bS.repr a,
  have s_eq : ∀ i, s i = bS.repr a i := λ i, rfl,
  set qs := λ j i, (μ j * s i) / b,
  have q_eq : ∀ j i, qs j i = (μ j * s i) / b := λ i j, rfl,
  set rs := λ j i, (μ j * s i) % b with r_eq,
  have r_eq : ∀ j i, rs j i = (μ j * s i) % b := λ i j, rfl,
  have μ_eq : ∀ i j, μ j * s i = b * qs j i + rs j i,
  { intros i j,
    rw [q_eq, r_eq, euclidean_domain.div_add_mod], },
  have μ_mul_a_eq : ∀ j, μ j • a = b • ∑ i, qs j i • bS i + ∑ i, rs j i • bS i,
  { intro j,
    rw ← bS.sum_repr a,
    simp only [finset.smul_sum, ← finset.sum_add_distrib],
    refine finset.sum_congr rfl (λ i _, _),
    rw [← s_eq, ← mul_smul, μ_eq, add_smul, mul_smul] },

  obtain ⟨j, k, j_ne_k, hjk⟩ := adm.exists_approx hε hb (λ j i, μ j * s i),
  have hjk' : ∀ i, (abv (rs k i - rs j i) : ℝ) < abv b • ε,
  { simpa only [r_eq] using hjk },
  set q := ∑ i, (qs k i - qs j i) • bS i with q_eq,
  set r := μ k - μ j with r_eq,
  refine ⟨q, r, (mem_finset_approx bS adm).mpr _, _⟩,
  { exact ⟨k, j, j_ne_k.symm, rfl⟩ },
  have : r • a - b • q = (∑ (x : ι), (rs k x • bS x - rs j x • bS x)),
  { simp only [r_eq, sub_smul, μ_mul_a_eq, q_eq, finset.smul_sum, ← finset.sum_add_distrib,
               ← finset.sum_sub_distrib, smul_sub],
    refine finset.sum_congr rfl (λ x _, _),
    ring },
  rw [this, algebra.norm_algebra_map_of_basis bS, abv.map_pow],

  refine int.cast_lt.mp ((norm_lt abv bS _ (λ i, lt_of_le_of_lt _ (hjk' i))).trans_le _),
  { apply le_of_eq,
    congr,
    simp_rw [linear_equiv.map_sum, linear_equiv.map_sub, linear_equiv.map_smul,
             finset.sum_apply', finsupp.sub_apply, finsupp.smul_apply,
             finset.sum_sub_distrib, basis.repr_self_apply, smul_eq_mul, mul_boole,
             finset.sum_ite_eq', finset.mem_univ, if_true] },
  { exact_mod_cast ε_le },
end

include ist iic

/-- We can approximate `a / b : L` with `q / r`, where `r` has finitely many options for `L`. -/
theorem exists_mem_finset_approx' (h : algebra.is_algebraic R L) (a : S) {b : S} (hb : b ≠ 0) :
  ∃ (q : S) (r ∈ finset_approx bS adm),
  abv (algebra.norm R (r • a - q * b)) < abv (algebra.norm R b) :=
begin
  have inj : function.injective (algebra_map R L),
  { rw is_scalar_tower.algebra_map_eq R S L,
    exact (is_integral_closure.algebra_map_injective S R L).comp bS.algebra_map_injective },
  obtain ⟨a', b', hb', h⟩ := is_integral_closure.exists_smul_eq_mul h inj a hb,
  obtain ⟨q, r, hr, hqr⟩ := exists_mem_finset_approx bS adm a' hb',
  refine ⟨q, r, hr, _⟩,
  refine lt_of_mul_lt_mul_left _
    (show 0 ≤ abv (algebra.norm R (algebra_map R S b')), from abv.nonneg _),
  refine lt_of_le_of_lt (le_of_eq _) (mul_lt_mul hqr le_rfl
    (abv.pos ((algebra.norm_ne_zero_iff_of_basis bS).mpr hb)) (abv.nonneg _)),
  rw [← abv.map_mul, ← monoid_hom.map_mul, ← abv.map_mul, ← monoid_hom.map_mul, ← algebra.smul_def,
      smul_sub b', sub_mul, smul_comm, h, mul_comm b a', algebra.smul_mul_assoc r a' b,
      algebra.smul_mul_assoc b' q b]
end

end real

lemma prod_finset_approx_ne_zero : algebra_map R S (∏ m in finset_approx bS adm, m) ≠ 0 :=
begin
  refine mt ((injective_iff_map_eq_zero _).mp bS.algebra_map_injective _) _,
  simp only [finset.prod_eq_zero_iff, not_exists],
  rintros x hx rfl,
  exact finset_approx.zero_not_mem bS adm hx
end

lemma ne_bot_of_prod_finset_approx_mem
  (J : ideal S) (h : algebra_map _ _ (∏ m in finset_approx bS adm, m) ∈ J) :
  J ≠ ⊥ :=
(submodule.ne_bot_iff _).mpr ⟨_, h, prod_finset_approx_ne_zero _ _⟩

include ist iic

/-- Each class in the class group contains an ideal `J`
such that `M := Π m ∈ finset_approx` is in `J`. -/
theorem exists_mk0_eq_mk0 [is_dedekind_domain S] (h : algebra.is_algebraic R L) (I : (ideal S)⁰) :
  ∃ (J : (ideal S)⁰), class_group.mk0 I = class_group.mk0 J ∧
    algebra_map _ _ (∏ m in finset_approx bS adm, m) ∈ (J : ideal S) :=
begin
  set M := ∏ m in finset_approx bS adm, m with M_eq,
  have hM : algebra_map R S M ≠ 0 := prod_finset_approx_ne_zero bS adm,
  obtain ⟨b, b_mem, b_ne_zero, b_min⟩ := exists_min abv I,
  suffices : ideal.span {b} ∣ ideal.span {algebra_map _ _ M} * I.1,
  { obtain ⟨J, hJ⟩ := this,
    refine ⟨⟨J, _⟩, _, _⟩,
    { rw mem_non_zero_divisors_iff_ne_zero,
      rintro rfl,
      rw [ideal.zero_eq_bot, ideal.mul_bot] at hJ,
      exact hM (ideal.span_singleton_eq_bot.mp (I.2 _ hJ)) },
    { rw class_group.mk0_eq_mk0_iff,
      exact ⟨algebra_map _ _ M, b, hM, b_ne_zero, hJ⟩ },
    rw [← set_like.mem_coe, ← set.singleton_subset_iff, ← ideal.span_le, ← ideal.dvd_iff_le],
    refine (mul_dvd_mul_iff_left _).mp _,
    swap, { exact mt ideal.span_singleton_eq_bot.mp b_ne_zero },
    rw [subtype.coe_mk, ideal.dvd_iff_le, ← hJ, mul_comm],
    apply ideal.mul_mono le_rfl,
    rw [ideal.span_le, set.singleton_subset_iff],
    exact b_mem },
  rw [ideal.dvd_iff_le, ideal.mul_le],
  intros r' hr' a ha,
  rw ideal.mem_span_singleton at ⊢ hr',
  obtain ⟨q, r, r_mem, lt⟩ := exists_mem_finset_approx' L bS adm h a b_ne_zero,
  apply @dvd_of_mul_left_dvd _ _ q,
  simp only [algebra.smul_def] at lt,
  rw ← sub_eq_zero.mp (b_min _ (I.1.sub_mem (I.1.mul_mem_left _ ha) (I.1.mul_mem_left _ b_mem)) lt),
  refine mul_dvd_mul_right (dvd_trans (ring_hom.map_dvd _ _) hr') _,
  exact multiset.dvd_prod (multiset.mem_map.mpr ⟨_, r_mem, rfl⟩)
end

omit iic ist

/-- `class_group.mk_M_mem` is a specialization of `class_group.mk0` to (the finite set of)
ideals that contain `M := ∏ m in finset_approx L f abs, m`.
By showing this function is surjective, we prove that the class group is finite. -/
noncomputable def mk_M_mem [is_dedekind_domain S]
  (J : {J : ideal S // algebra_map _ _ (∏ m in finset_approx bS adm, m) ∈ J}) :
  class_group S :=
class_group.mk0 ⟨J.1, mem_non_zero_divisors_iff_ne_zero.mpr
  (ne_bot_of_prod_finset_approx_mem bS adm J.1 J.2)⟩

include iic ist

lemma mk_M_mem_surjective [is_dedekind_domain S] (h : algebra.is_algebraic R L) :
  function.surjective (class_group.mk_M_mem bS adm) :=
begin
  intro I',
  obtain ⟨⟨I, hI⟩, rfl⟩ := class_group.mk0_surjective I',
  obtain ⟨J, mk0_eq_mk0, J_dvd⟩ := exists_mk0_eq_mk0 L bS adm h ⟨I, hI⟩,
  exact ⟨⟨J, J_dvd⟩, mk0_eq_mk0.symm⟩
end

open_locale classical

/-- The main theorem: the class group of an integral closure `S` of `R` in an
algebraic extension `L` is finite if there is an admissible absolute value.

See also `class_group.fintype_of_admissible_of_finite` where `L` is a finite
extension of `K = Frac(R)`, supplying most of the required assumptions automatically.
-/
noncomputable def fintype_of_admissible_of_algebraic [is_dedekind_domain S]
  (h : algebra.is_algebraic R L) : fintype (class_group S) :=
@fintype.of_surjective _ _ _
  (@fintype.of_equiv _
    {J // J ∣ ideal.span ({algebra_map R S (∏ (m : R) in finset_approx bS adm, m)} : set S)}
    (unique_factorization_monoid.fintype_subtype_dvd _
      (by { rw [ne.def, ideal.zero_eq_bot, ideal.span_singleton_eq_bot],
            exact prod_finset_approx_ne_zero bS adm }))
    ((equiv.refl _).subtype_equiv (λ I, ideal.dvd_iff_le.trans
      (by rw [equiv.refl_apply, ideal.span_le, set.singleton_subset_iff]))))
  (class_group.mk_M_mem bS adm)
  (class_group.mk_M_mem_surjective L bS adm h)

include K

/-- The main theorem: the class group of an integral closure `S` of `R` in a
finite extension `L` of `K = Frac(R)` is finite if there is an admissible
absolute value.

See also `class_group.fintype_of_admissible_of_algebraic` where `L` is an
algebraic extension of `R`, that includes some extra assumptions.
-/
noncomputable def fintype_of_admissible_of_finite [is_dedekind_domain R] :
  fintype (class_group S) :=
begin
  letI := classical.dec_eq L,
  letI := is_integral_closure.is_fraction_ring_of_finite_extension R K L S,
  letI := is_integral_closure.is_dedekind_domain R K L S,
  choose s b hb_int using finite_dimensional.exists_is_basis_integral R K L,
  obtain ⟨n, b⟩ := submodule.basis_of_pid_of_le_span _
    (is_integral_closure.range_le_span_dual_basis S b hb_int),
  let bS := b.map ((linear_map.quot_ker_equiv_range _).symm ≪≫ₗ _),
  refine fintype_of_admissible_of_algebraic L bS adm
    (λ x, (is_fraction_ring.is_algebraic_iff R K L).mpr (algebra.is_algebraic_of_finite _ _ x)),
  { rw linear_map.ker_eq_bot.mpr,
    { exact submodule.quot_equiv_of_eq_bot _ rfl },
    { exact is_integral_closure.algebra_map_injective _ R _ } },
  { refine (basis.linear_independent _).restrict_scalars _,
    simp only [algebra.smul_def, mul_one],
    apply is_fraction_ring.injective }
end

end is_admissible

end euclidean_domain

end class_group


import to_mathlib.analysis.inner_product_space.tensor_product
import to_mathlib.linear_algebra.tensor_power

noncomputable theory

open set function tensor_power
open_locale tensor_product big_operators real_inner_product_space

namespace inner_product_space

namespace tensor_power

variables (E : Type*) [inner_product_space ℝ E]

def linear_equiv.map_eq_zero {R M N : Type*} [add_comm_group M] [add_comm_group N]
  [comm_ring R] [module R M] [module R N] (l : M ≃ₗ[R] N) (x : M) :
  l x = 0 ↔ x = 0 :=
(show l x = 0 ↔ x ∈ linear_map.ker l, by rw linear_map.mem_ker).trans begin
  suffices : linear_map.ker l = ⊥,
  { rw this, refl },
  exact (linear_map.ker_eq_bot.mpr l.injective : linear_map.ker l.to_linear_map = ⊥),
end

def lift_equiv_left {M N N' R : Type*} [add_comm_monoid M] [add_comm_monoid N] [add_comm_monoid N']
  [comm_semiring R] [module R M] [module R N] [module R N'] (l : N ≃ₗ[R] N') :
  M ⊗[R] N ≃ₗ[R] M ⊗[R] N' :=
{ to_fun := tensor_product.hom_tensor_hom_map R M N M N' (linear_map.id ⊗ₜ[R] l),
  map_add' := map_add _,
  map_smul' := map_smul _,
  inv_fun := tensor_product.hom_tensor_hom_map R M N' M N (linear_map.id ⊗ₜ[R] l.symm),
  left_inv := λ r, begin
    induction r using tensor_product.induction_on with x y x y ihx ihy,
    { simp only [map_zero] },
    { rw [tensor_product.hom_tensor_hom_map_apply, tensor_product.hom_tensor_hom_map_apply],
      simp only [tensor_product.map_tmul, linear_map.id_coe, id.def, linear_equiv.coe_coe,
        linear_equiv.symm_apply_apply], },
    { simp only [map_add, ihx, ihy] },
  end,
  right_inv := λ x, begin
    induction x using tensor_product.induction_on with x y x y ihx ihy,
    { simp only [map_zero] },
    { rw [tensor_product.hom_tensor_hom_map_apply, tensor_product.hom_tensor_hom_map_apply],
      simp only [tensor_product.map_tmul, linear_map.id_coe, id.def, linear_equiv.coe_coe,
        linear_equiv.apply_symm_apply], },
    { simp only [map_add, ihx, ihy] },
  end }

lemma lift_equiv_left_tmul {M N N' R : Type*} [add_comm_monoid M] [add_comm_monoid N] [add_comm_monoid N']
  [comm_semiring R] [module R M] [module R N] [module R N'] (l : N ≃ₗ[R] N')
  (m : M) (n : N) : lift_equiv_left l (m ⊗ₜ n) = m ⊗ₜ (l n) := rfl

def core_zero_power : inner_product_space.core ℝ (⨂[ℝ]^0 E) :=
{ inner := λ x y, (pi_tensor_product.is_empty_equiv (fin 0) x) *
    (pi_tensor_product.is_empty_equiv (fin 0) y),
  conj_sym := λ x y, by rw [is_R_or_C.conj_to_real, mul_comm],
  nonneg_re := λ x, by simpa only [is_R_or_C.re_to_real] using mul_self_nonneg _,
  definite := λ x hx, by rwa [mul_self_eq_zero, linear_equiv.map_eq_zero] at hx,
  add_left := λ x y z, by simp only [map_add, add_mul],
  smul_left := λ x y r, by simp only [map_smul, smul_eq_mul, is_R_or_C.conj_to_real, mul_assoc] }

lemma core_zero_power_inner_apply (e₁ e₂ : fin 0 → E) :
  (core_zero_power E).inner (tpow ℝ e₁) (tpow ℝ e₂) =
  ∏ i : fin 0, ⟪e₁ i, e₂ i⟫ :=
begin
  rw [fin.prod_univ_zero],
  dunfold core_zero_power, dsimp only,
  erw [pi_tensor_product.is_empty_equiv_apply_tprod, mul_one],
end

def core_succ_power {k : ℕ} (ic : inner_product_space.core ℝ (⨂[ℝ]^k E)) :
  inner_product_space.core ℝ (⨂[ℝ]^k.succ E) :=
let l : ⨂[ℝ]^k.succ E ≃ₗ[ℝ] ⨂[ℝ]^k E ⊗[ℝ] E :=
  (@tensor_power.mul_equiv ℝ E _ _ _ k 1).symm.trans
  (lift_equiv_left (pi_tensor_product.subsingleton_equiv 0) : ⨂[ℝ]^k E ⊗ ⨂[ℝ]^1 E ≃ₗ[ℝ] ⨂[ℝ]^k E ⊗[ℝ] E),
  inner_product_space' : inner_product_space ℝ (⨂[ℝ]^k E ⊗[ℝ] E) :=
    @inner_product_space.tensor_product' (⨂[ℝ]^k E) E (inner_product_space.of_core ic) _,
  i : (⨂[ℝ]^k E ⊗[ℝ] E) → (⨂[ℝ]^k E ⊗[ℝ] E) → ℝ := inner_product_space'.inner in
{ inner := λ x y, i (l x) (l y),
  conj_sym := λ x y, begin
    convert inner_conj_sym (l x) (l y),
  end,
  nonneg_re := λ x, begin
    convert inner_product_space.core.nonneg_re _ (l x),
  end,
  definite := λ x hx, begin
    have := inner_product_space.core.definite _ (l x) hx,
    rwa linear_equiv.map_eq_zero l x at this,
  end,
  add_left := λ x y z, begin
    convert inner_product_space.core.add_left _ (l x) (l y) (l z),
    rw map_add,
  end,
  smul_left := λ x y r, begin
    convert inner_product_space.core.smul_left _ (l x) (l y) r,
    rw map_smul,
  end }

lemma core_succ_power_inner_apply_aux {k : ℕ} (e₁ e₂ : fin k.succ → E)
  (ic : inner_product_space.core ℝ (⨂[ℝ]^k E)) :
  (core_succ_power E ic).inner (tpow ℝ e₁) (tpow ℝ e₂) =
  (@inner_product_space.tensor_product' (⨂[ℝ]^k E) E
    (inner_product_space.of_core ic) _).inner
      ((@tensor_power.mul_equiv ℝ E _ _ _ k 1).symm.trans
  (lift_equiv_left (pi_tensor_product.subsingleton_equiv 0) : ⨂[ℝ]^k E ⊗ ⨂[ℝ]^1 E ≃ₗ[ℝ] ⨂[ℝ]^k E ⊗[ℝ] E) (tpow ℝ e₁))
  ((@tensor_power.mul_equiv ℝ E _ _ _ k 1).symm.trans
  (lift_equiv_left (pi_tensor_product.subsingleton_equiv 0) : ⨂[ℝ]^k E ⊗ ⨂[ℝ]^1 E ≃ₗ[ℝ] ⨂[ℝ]^k E ⊗[ℝ] E) (tpow ℝ e₂)) :=
rfl

def core (k : ℕ) : inner_product_space.core ℝ (⨂[ℝ]^k E) :=
nat.rec (core_zero_power E) (λ n hn, core_succ_power E hn) k

lemma core_succ_power_inner_apply_tpow {k : ℕ} (e₁ e₂ : fin k.succ → E) :
  (core_succ_power E (core E k)).inner (tpow ℝ e₁) (tpow ℝ e₂) =
  (core E k).inner
    (tpow ℝ (λ (i : fin k), e₁ (@fin_sum_fin_equiv k 1 (sum.inl i))))
    (tpow ℝ (λ (i : fin k), e₂ (@fin_sum_fin_equiv k 1 (sum.inl i)))) *
  ⟪e₁ ⟨k, lt_add_one _⟩, e₂ ⟨k, lt_add_one _⟩⟫ :=
begin
  simp only [core_succ_power_inner_apply_aux],
  dunfold tpow tensor_power.mul_equiv,
  simp only [linear_equiv.trans_symm, pi_tensor_product.reindex_symm, linear_equiv.trans_apply,
    pi_tensor_product.reindex_tprod, pi_tensor_product.tmul_equiv_symm_apply,
    lift_equiv_left_tmul, pi_tensor_product.subsingleton_equiv_apply_tprod],
  simp_rw [equiv.symm_symm],
  erw inner_product_space.inner_tprod,
  rw [fin_sum_fin_equiv_apply_right], congr,
end

lemma core_inner_tpow {k : ℕ} (e₁ e₂ : fin k → E) :
  (core E k).inner (tpow ℝ e₁) (tpow ℝ e₂) =
  ∏ i, ⟪e₁ i, e₂ i⟫ :=
begin
  induction k with k ih,
  { apply core_zero_power_inner_apply, },
  { erw [core_succ_power_inner_apply_tpow E e₁ e₂, ih, fin.prod_univ_succ_above, mul_comm],
    congr' 1,
    apply finset.prod_congr rfl,
    rintros ⟨x, hx⟩ -,
    congr' 2;
    { simp only [fin_sum_fin_equiv_apply_left, fin.cast_add_mk],
      ext, simp only [fin.coe_mk],
      rw fin.succ_above_below, refl, assumption, },
     }
end

instance (k : ℕ) : inner_product_space ℝ (⨂[ℝ]^k E) :=
inner_product_space.of_core (core E k)

@[simp] lemma inner_tpow {k : ℕ} (e₁ e₂ : fin k → E) :
  ⟪tensor_power.tpow ℝ e₁, tensor_power.tpow ℝ e₂⟫ = ∏ i, ⟪e₁ i, e₂ i⟫ :=
core_inner_tpow E e₁ e₂

end tensor_power

end inner_product_space


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

/-!
# 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) int
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_zpow (x : ℝ) (n : ℤ) :
  (translate (multiplicative.of_add x))^n = translate (multiplicative.of_add $ ↑n * x) :=
by simp only [← zsmul_eq_mul, of_add_zsmul, monoid_hom.map_zpow]

@[simp] lemma translate_pow (x : ℝ) (n : ℕ) :
  (translate (multiplicative.of_add x))^n = translate (multiplicative.of_add $ ↑n * x) :=
translate_zpow 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 rw [int.fract, f.map_sub_int, sub_sub_sub_cancel_right]

/-!
### 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_comm
    (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_zpow (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 is_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 is_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 (zpowers_hom _ f₁) n) =
    τ ((units.coe_hom _).comp (zpowers_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


import .lang

namespace ualg

variables {L : lang} (A : ralg L) (R : rules L)

namespace addr
def rel : A → A → Prop := λ x y, ∀ (B : ualg L R) (f : A →% B), f x = f y
def setoid : setoid A := ⟨rel A R,
begin
  refine ⟨_,_,_⟩,
  { intros x B g, refl },
  { intros x y h B g, symmetry, apply h },
  { intros x y z h1 h2 B g, rw [h1,h2] }
end⟩

def pre : ralg L :=
{ carrier := quotient (addr.setoid A R),
  appo := λ n t, @vector.quotient_lift _ (quotient (addr.setoid A R)) (addr.setoid A R) _
  (λ as, quotient.mk' $ applyo t as)
  begin
    intros as bs h,
    dsimp only [],
    apply quotient.sound',
    intros B g,
    simp_rw ←ralg.applyo_map,
    apply congr_arg,
    rw vector.eq_iff_to_fn_eq_to_fn,
    ext,
    simp_rw vector.map_to_fn,
    apply h,
  end }

def rquot : A →% (pre A R) :=
{ to_fn := quotient.mk',
  applyo_map := λ n t as,
  begin
    change vector.quotient_lift _ _ (vector.map quotient.mk _) = _,
    rw vector.quotient_lift_eq,
  end }

end addr

def addr : ualg L R :=
{ cond_eq :=
  begin
    intros m n t1 t2 as h,
    rcases vector.exists_rep (@quotient.mk' _ (addr.setoid A R)) as (quot.exists_rep) with ⟨bs,rfl⟩,
    change applyt t1 (vector.map (addr.rquot A R) _) = _,
    change _ = applyt t2 (vector.map (addr.rquot A R) _),
    simp_rw [ralg.applyt_map,vector.eq_iff_to_fn_eq_to_fn,vector.map_to_fn],
    ext,
    change quotient.mk' ((applyt t1 bs) x) = quotient.mk' ((applyt t2 bs) x),
    apply quotient.sound',
    intros B g,
    suffices : (applyt t1 bs).map g = (applyt t2 bs).map g,
    { rw vector.eq_iff_to_fn_eq_to_fn at this,
      simp_rw vector.map_to_fn at this,
      change (g ∘ (applyt t1 bs)) x = _, -- should also have a lemma to avoid this suffices
      rw this },
    simp_rw ←ralg.applyt_map,
    exact B.cond_eq h, -- the B.cond_eq should be made a lemma in lang.lean file
  end,
  ..addr.pre A R
  }

namespace addr
def univ : A →% (addr A R) := addr.rquot A R
variable {A}
def lift {B : ualg L R} (f : A →% B) : addr A R →% B :=
{ to_fn := @quotient.lift _ _ (addr.setoid A R) f (λ a b h, by {apply h}),
  applyo_map := λ n t as,
  begin
    rcases vector.exists_rep (@quotient.mk' _ (addr.setoid A R)) as (quot.exists_rep) with ⟨bs,rfl⟩,
    have : @quotient.mk' _ (addr.setoid A R) = rquot A R, by refl,
    erw [this,ralg.applyo_map,quotient.lift_beta,vector.map_map],
    conv_rhs {rw ←ralg.applyo_map},
    apply congr_arg,
    rw vector.eq_iff_to_fn_eq_to_fn,
    ext,
    simp only [vector.map_to_fn,function.comp_apply],
    erw quotient.lift_beta,
  end }

theorem univ_comp_lift {B : ualg L R} (f : A →% B) :
  (univ A R).comp (lift R f) = f :=
begin
  ext,
  unfold ralgHom.comp,
  unfold_coes,
  dsimp only [],
  simp only [ralgHom.comp, function.comp_apply, function.comp_apply],
  erw quotient.lift_beta,
end

theorem lift_unique {B : ualg L R} (f : A →% B) (g : addr A R →% B) :
  (univ A R).comp g = f → g = lift R f := λ hyp,
begin
  ext,
  replace hyp := congr_arg ralgHom.to_fn hyp,
  unfold ralgHom.comp at hyp,
  dsimp only [] at hyp,
  unfold univ at hyp,
  rcases quot.exists_rep x with ⟨x,rfl⟩,
  change (g ∘ (rquot A R)) _ = _,
  rw hyp,
  refl,
end

end addr

end ualg


import Mathlib.ring_theory.jacobson
import Mathlib.field_theory.algebraic_closure
import Mathlib.field_theory.mv_polynomial
import Mathlib.algebraic_geometry.prime_spectrum

set_option synthInstance.maxHeartbeats 50000

namespace Mathlib

syntax "{ " ident (" : " term)? " | " term " }" : term

macro_rules
  | `({ $x : $type | $p }) => `(Mathlib.set_of fun ($x:ident : $type) => $p)
  | `({ $x | $p })         => `(Mathlib.set_of fun ($x:ident : _) => $p)

universes u v w

open ideal

namespace mv_polynomial

variable {k : Type u} [field k]
variable {σ : Type v}

noncomputable def zero_locus (I : ideal (mv_polynomial σ k)) : set (σ → k) :=
  { x : σ → k | ∀ (p : mv_polynomial σ k), p ∈ I →
     coe_fn (_inst_1 := ring_hom.has_coe_to_fun) (eval x) p = 0 }

#exit
theorem mv_polynomial.mem_zero_locus_iff {I : ideal (mv_polynomial σ k)} {x : σ → k} :
    x ∈ zero_locus I ↔ (p : mv_polynomial σ k) → p ∈ I → coe_fn (_inst_1 := Mathlib.ring_hom.has_coe_to_fun) (eval x) p = has_zero.zero :=
  sorry

theorem zero_locus_anti_mono {I J : ideal (mv_polynomial σ k)} (h : I ≤ J) : zero_locus J ≤ zero_locus I :=
  sorry

theorem zero_locus_bot : zero_locus (⊥ : ideal (mv_polynomial σ k)) = ⊤ :=
  sorry

theorem zero_locus_top : zero_locus (⊤ : ideal (mv_polynomial σ k)) = ⊥ :=
  sorry

end mv_polynomial
end Mathlib


import tactic
import tactic.induction
import data.nat.lattice

noncomputable theory
open_locale classical

@[simp] def L (a b : ℕ) : ℕ :=
if a ≤ b then 1 else 0

@[simp] def M (f : ℕ → ℕ) : ℕ :=
Inf {n | f n ≠ 0}

---

@[simp] lemma M_const {a : ℕ} : M (λ (b : ℕ), a) = 0 :=
begin
  dsimp, by_cases h : a = 0,
  { simp [h] },
  { rw [eq_true_intro h, nat.Inf_def ⟨0, _⟩], swap, { trivial },
    generalize_proofs h₁, have h₂ : nat.find h₁ ≤ 0 := nat.find_le trivial,
    rw le_zero_iff at h₂, convert h₂ },
end

@[simp] lemma M_id : M (λ (a : ℕ), a) = 1 :=
by { dsimp, rw [nat.Inf_def ⟨1, _⟩]; simp [nat.find_eq_iff] }

@[simp] lemma Inf_ge {a : ℕ} : Inf {b | a ≤ b} = a :=
by { rw nat.Inf_def ⟨a, _⟩; simp [nat.find_eq_iff, le_refl a] }

-- #exit

---

def zero' : ℕ := M (λ (a : ℕ), L a a)

def one' : ℕ := M (λ (a : ℕ), a)

def not' (a : ℕ) : ℕ :=
M (λ (b : ℕ), L (L a zero') b)

def imp' (a b : ℕ) : ℕ :=
M (λ (c : ℕ), L (L a b) c)

def or' (a b : ℕ) : ℕ :=
M (λ (c : ℕ), L (imp' (not' a) b) c)

-- #exit

---

@[simp] lemma zero'_def : zero' = 0 :=
by simp [zero']

@[simp] lemma one'_def : one' = 1 :=
by simp [one']

@[simp] lemma not'_def {a : ℕ} : not' a = if a = 0 then 1 else 0 :=
by simp [not']

@[simp] lemma zero'_imp' {a : ℕ} : imp' zero' a = 1 :=
by simp [imp']

@[simp] lemma imp'_zero' {a : ℕ} : imp' a zero' = not' a :=
by simp [imp']

@[simp] lemma one_imp' {a : ℕ} : imp' 1 a = if a = 0 then 0 else 1 :=
begin
  simp only [imp', M, L, ne.def, ite_eq_right_iff, nat.one_ne_zero,
  not_forall, not_false_iff, exists_prop, and_true, Inf_ge], rw ←ite_not, simp,
end

@[simp] lemma zero'_or' {a : ℕ} : or' zero' a = if a = 0 then 0 else 1 :=
by simp [or']

-- #exit

---

@[simp] def f₁ : ℕ → ℕ :=
λ (a : ℕ), L (L 0 0) (L (M (λ (b : ℕ), 0)) 0)

example {n : ℕ} : f₁ n = 1 :=
by simp

@[simp] def f₂ : ℕ → ℕ :=
λ (a : ℕ), a

example {n : ℕ} : f₂ n = n :=
by simp

@[simp] def f₃ : ℕ → ℕ :=
λ (a : ℕ), (λ (b : ℕ), L 0 ((λ (c : ℕ → ℕ), 0) (λ (c : ℕ), 0)))
  ((λ (b : ℕ → ℕ), 0) (λ (b : ℕ), b))

example {n : ℕ} : f₃ n = 1 :=
by simp

@[simp] def f₄ : ℕ → ℕ :=
λ (a : ℕ), M (λ (b : ℕ), (λ (c : ℕ → ℕ), c ((λ (d : ℕ), L 0 (M (λ (e : ℕ), 0))) a))
  (λ (c : ℕ), L (M (λ (d : ℕ), 0)) 0))

example {n : ℕ} : f₄ n = 0 :=
by simp

@[simp] def f₅ : ℕ → ℕ :=
λ (a : ℕ), L a (L (M (λ (b : ℕ), a)) a)

example {n : ℕ} : f₅ n = if n ≤ 1 then 1 else 0 :=
by simp

@[simp] def f₆ : ℕ → ℕ :=
λ (a : ℕ), L ((λ (b : ℕ), L (M (λ (c : ℕ), b)) a) (M (λ (b : ℕ), b))) a

example {n : ℕ} : f₆ n = if n = 0 then 0 else 1 :=
by { simp only [f₆, L, M_const, zero_le, if_true], rw ←ite_not, simp }


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl
-/

section subtype
variables {α : Sort*} {β : α → Prop}

protected lemma subtype.eq' : ∀ {a1 a2 : {x // β x}}, a1.val = a2.val → a1 = a2
| ⟨x, h1⟩ ⟨.(x), h2⟩ rfl := rfl

lemma subtype.ext {a1 a2 : {x // β x}} : a1 = a2 ↔ a1.val = a2.val :=
⟨congr_arg _, subtype.eq'⟩

lemma subtype.coe_ext {a1 a2 : {x // β x}} : a1 = a2 ↔ (a1 : α) = a2 :=
subtype.ext

theorem subtype.val_injective : function.injective (@subtype.val _ β) :=
λ a b, subtype.eq'

@[simp] theorem subtype.coe_eta {α : Type*} {β : α → Prop}
 (a : {a // β a}) (h : β a) : subtype.mk ↑a h = a := subtype.eta _ _

@[simp] theorem subtype.coe_mk {α : Type*} {β : α → Prop}
 (a h) : (@subtype.mk α β a h : α) = a := rfl

@[simp] theorem subtype.mk_eq_mk {α : Type*} {β : α → Prop}
 {a h a' h'} : @subtype.mk α β a h = @subtype.mk α β a' h' ↔ a = a' :=
⟨λ H, by injection H, λ H, by congr; assumption⟩

@[simp] theorem subtype.forall {p : {a // β a} → Prop} :
  (∀ x, p x) ↔ (∀ a b, p ⟨a, b⟩) :=
⟨assume h a b, h ⟨a, b⟩, assume h ⟨a, b⟩, h a b⟩

@[simp] theorem subtype.exists {p : {a // β a} → Prop} :
  (∃ x, p x) ↔ (∃ a b, p ⟨a, b⟩) :=
⟨assume ⟨⟨a, b⟩, h⟩, ⟨a, b, h⟩, assume ⟨a, b, h⟩, ⟨⟨a, b⟩, h⟩⟩

end subtype

namespace subtype
variables {α : Sort*} {β : Sort*} {γ : Sort*}

/-- Restriction of a function to a function on subtypes. -/
def map {p : α → Prop} {q : β → Prop} (f : α → β) (h : ∀a, p a → q (f a)) :
  subtype p → subtype q
| ⟨v, hv⟩ := ⟨f v, h v hv⟩

theorem map_comp {p : α → Prop} {q : β → Prop} {r : γ → Prop} {x : subtype p}
  (f : α → β) (h : ∀a, p a → q (f a)) (g : β → γ) (l : ∀a, q a → r (g a)) :
  map g l (map f h x) = map (g ∘ f) (assume a ha, l (f a) $ h a ha) x :=
by cases x with v h; refl

theorem map_id {p : α → Prop} {h : ∀a, p a → p (id a)} : map (@id α) h = id :=
funext $ assume ⟨v, h⟩, rfl

end subtype

namespace subtype
variables {α : Sort*}

instance [has_equiv α] (p : α → Prop) : has_equiv (subtype p) :=
⟨λ s t, s.val ≈ t.val⟩

theorem equiv_iff [has_equiv α] {p : α → Prop} {s t : subtype p} :
  s ≈ t ↔ s.val ≈ t.val :=
iff.rfl

variables [setoid α] {p : α → Prop}

protected theorem refl (s : subtype p) : s ≈ s :=
setoid.refl s.val

protected theorem symm {s t : subtype p} (h : s ≈ t) : t ≈ s :=
setoid.symm h

protected theorem trans {s t u : subtype p} (h₁ : s ≈ t) (h₂ : t ≈ u) : s ≈ u :=
setoid.trans h₁ h₂

theorem equivalence (p : α → Prop) : equivalence (@has_equiv.equiv (subtype p) _) :=
mk_equivalence _ subtype.refl (@subtype.symm _ _ p) (@subtype.trans _ _ p)

instance (p : α → Prop) : setoid (subtype p) :=
setoid.mk (≈) (equivalence p)

end subtype


open tactic interactive interactive.types lean.parser expr

private meta def set_cases_tags (in_tag : tag) (rs : list name) : tactic unit := do
  te ← tags_enabled,
  gs ← get_goals,
  match gs with
  | [g] := when te (set_tag g in_tag) -- if only one goal was produced, we should not make the tag longer
  | _   := do
    let tgs : list (name × expr) := rs.map₂ (λ n g, (n, g)) gs,
    if te
    then tgs.mmap' (λ ⟨n, g⟩, set_tag g (n::in_tag))
        /- If `induction/cases` is not in a `with_cases` block, we still set tags using `_case_simple` to make
            sure we can use the `case` notation.
            ```
            induction h,
            case c { ... }
            ```
        -/
    else tgs.mmap' (λ ⟨n, g⟩, with_enable_tags
      (set_tag g (name.mk_numeral (unsigned.of_nat 0) `_case::n::[])))
  end

meta def known_induction (ty : parse ident) (gen : parse texpr) : tactic unit := do
  in_tag ← get_main_tag,
  focus1 $ do {
    gen <- i_to_expr gen,

    env ← tactic_state.env <$> read,
    ty ← resolve_constant ty
          <|> fail ("'" ++ to_string ty ++ "' cannot be found"),
    let ctors := environment.constructors_of env ty,

    rw ← apply gen,
    set_cases_tags in_tag ctors
  }

run_cmd add_interactive [`known_induction]

example : ∀ (n : ℕ), 0 < (nat.succ n) := λ n, begin
  known_induction nat (@nat.rec_on (λ n, 0 < (nat.succ n)) n),
  case nat.zero { from nat.zero_lt_succ _ },
  case nat.succ : n ih { from nat.zero_lt_succ _ },
end