import deduction.deduction order.bounded_order

namespace deduction_cart

open deduction_basic

/- Truth -/
class has_ltop (Form : Type) extends has_struct_derives Form :=
  (top : Form)
  (truth : ∀ {Φ : Hyp}, derives Φ top)

instance {Form : Type} [Der : has_ltop Form] : has_top Form := ⟨ Der.top ⟩

/- Logical And -/
class has_and (Form : Type) extends has_ltop Form :=
  (and : Form → Form → Form)
  (and_intro {Φ} {φ ψ : Form}
        : derives Φ φ → derives Φ ψ → derives Φ (and φ ψ))
  (and_eliml {Φ} {φ ψ : Form}
        : derives Φ (and φ ψ) → derives Φ φ)
  (and_elimr {Φ} {φ ψ : Form}
        : derives Φ (and φ ψ) → derives Φ ψ)

infix `&`:79      := has_and.and

/- Implication -/
class has_impl (Form : Type) extends has_and Form :=
  (impl : Form → Form → Form)
  (impl_intro {Φ} (φ) {ψ}
        : derives (insert φ Φ) ψ → derives Φ (impl φ ψ))
  (impl_elim {Φ} (φ) {ψ}
        : derives Φ (impl φ ψ) → derives Φ φ → derives Φ ψ)

notation (name:= has_impl.impl) φ ` ⊃ `:80 ψ := has_impl.impl φ ψ

/- All three -/
end deduction_cart

namespace cart_x
  open deduction_basic
  open deduction_cart

  lemma and_intro1 {Form : Type} [Der : has_and Form] {φ ψ : Form} :
    Der.derives (Der.insertHyp.insert ψ {φ}) (φ&ψ) :=
  begin
    apply Der.and_intro,
    apply Der.weak1,
    apply derive_refl,
    apply Der.hyp,
    apply Der.inInsert,
  end
  lemma and_internal {Form : Type} [Der : has_and Form] {φ ψ θ: Form} :
    (φ & ψ ⊢ θ) → Der.derives (Der.insertHyp.insert ψ {φ}) θ :=
  begin
    assume h,
    apply Der.derive_Trans (φ & ψ),
    exact and_intro1,
    exact h,
  end

  lemma and_eliml1 {Form : Type} [Der : has_and Form] {φ ψ : Form} :
    φ & ψ ⊢ φ :=
  begin
    apply Der.and_eliml,
    apply derive_refl,
  end
  lemma and_elimr1 {Form : Type} [Der : has_and Form] {φ ψ : Form} :
    φ & ψ ⊢ ψ :=
  begin
    apply Der.and_elimr,
    apply derive_refl,
  end

  lemma modus_ponens {Form : Type} [Der : has_impl Form] :
    ∀ {φ ψ : Form}, (φ ⊃ ψ) & φ ⊢ ψ :=
  begin
    assume φ ψ,
    apply Der.impl_elim φ,
    apply and_eliml1,
    apply and_elimr1,
  end

  lemma impl_ε {Form : Type} [Der : has_impl Form] :
    ∀ {φ ψ θ : Form}, φ & ψ ⊢ θ  →  φ ⊢ ψ ⊃ θ :=
  begin
    assume φ ψ θ h,
    apply Der.impl_intro,
    apply Der.derive_Trans,
    apply and_intro1,
    exact h,
  end

  lemma insert_trans {Form : Type} [Der : has_impl Form] {Φ} {φ ψ : Form} :
    (φ ⊢ ψ) → Der.derives (Der.insertHyp.insert φ Φ) ψ :=
  begin
    assume h,
    apply Der.derive_Trans φ,
    apply Der.hyp,
    apply Der.inInsert,
    exact h,
  end
end cart_x


/-
Copyright (c) 2021 Kevin Kappelmann. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Kappelmann
-/
import algebra.continued_fractions.computation.approximations
import algebra.continued_fractions.convergents_equiv
import topology.algebra.ordered
/-!
# Corollaries From Approximation Lemmas (`algebra.continued_fractions.computation.approximations`)

## Summary

We show that the generalized_continued_fraction given by `generalized_continued_fraction.of` in fact
is a (regular) continued fraction. Using the equivalence of the convergents computations
(`generalized_continued_fraction.convergents` and `generalized_continued_fraction.convergents'`) for
continued fractions (see `algebra.continued_fractions.convergents_equiv`), it follows that the
convergents computations for `generalized_continued_fraction.of` are equivalent.

Moreover, we show the convergence of the continued fractions computations, that is
`(generalized_continued_fraction.of v).convergents` indeed computes `v` in the limit.

## Main Definitions

- `continued_fraction.of` returns the (regular) continued fraction of a value.

## Main Theorems

- `generalized_continued_fraction.of_convergents_eq_convergents'` shows that the convergents
  computations for `generalized_continued_fraction.of` are equivalent.
- `generalized_continued_fraction.of_convergence` shows that
  `(generalized_continued_fraction.of v).convergents` converges to `v`.

## Tags

convergence, fractions
-/

variables {K : Type*} (v : K) [linear_ordered_field K] [floor_ring K]
open generalized_continued_fraction as gcf

lemma generalized_continued_fraction.of_is_simple_continued_fraction :
  (gcf.of v).is_simple_continued_fraction :=
(λ _ _ nth_part_num_eq, gcf.of_part_num_eq_one nth_part_num_eq)

/-- Creates the simple continued fraction of a value. -/
def simple_continued_fraction.of : simple_continued_fraction K :=
⟨gcf.of v, generalized_continued_fraction.of_is_simple_continued_fraction v⟩

lemma simple_continued_fraction.of_is_continued_fraction :
  (simple_continued_fraction.of v).is_continued_fraction :=
(λ _ denom nth_part_denom_eq,
  lt_of_lt_of_le zero_lt_one(gcf.of_one_le_nth_part_denom nth_part_denom_eq))

/-- Creates the continued fraction of a value. -/
def continued_fraction.of : continued_fraction K :=
⟨simple_continued_fraction.of v, simple_continued_fraction.of_is_continued_fraction v⟩

namespace generalized_continued_fraction

open continued_fraction as cf

lemma of_convergents_eq_convergents' : (gcf.of v).convergents = (gcf.of v).convergents' :=
@cf.convergents_eq_convergents'  _ _ (continued_fraction.of v)

section convergence
/-!
### Convergence

We next show that `(generalized_continued_fraction.of v).convergents v` converges to `v`.
-/

variable [archimedean K]
local notation `|` x `|` := abs x
open nat

theorem of_convergence_epsilon :
  ∀ (ε > (0 : K)), ∃ (N : ℕ), ∀ (n ≥ N), |v - (gcf.of v).convergents n| < ε :=
begin
  assume ε ε_pos,
  -- use the archemidean property to obtian a suitable N
  rcases (exists_nat_gt (1 / ε) : ∃ (N' : ℕ), 1 / ε < N') with ⟨N', one_div_ε_lt_N'⟩,
  let N := max N' 5, -- set minimum to 5 to have N ≤ fib N work
  existsi N,
  assume n n_ge_N,
  let g := gcf.of v,
  cases decidable.em (g.terminated_at n) with terminated_at_n not_terminated_at_n,
  { have : v = g.convergents n, from of_correctness_of_terminated_at terminated_at_n,
    have : v - g.convergents n = 0, from sub_eq_zero.elim_right this,
    rw [this],
    exact_mod_cast ε_pos },
  { let B := g.denominators n,
    let nB := g.denominators (n + 1),
    have abs_v_sub_conv_le : |v - g.convergents n| ≤ 1 / (B * nB), from
      abs_sub_convergents_le not_terminated_at_n,
    suffices : 1 / (B * nB) < ε, from lt_of_le_of_lt abs_v_sub_conv_le this,
    -- show that `0 < (B * nB)` and then multiply by `B * nB` to get rid of the division
    have nB_ineq : (fib (n + 2) : K) ≤ nB, by
    { have : ¬g.terminated_at (n + 1 - 1), from not_terminated_at_n,
      exact (succ_nth_fib_le_of_nth_denom (or.inr this)) },
    have B_ineq : (fib (n + 1) : K) ≤ B, by
    { have : ¬g.terminated_at (n - 1), from mt (terminated_stable n.pred_le) not_terminated_at_n,
      exact (succ_nth_fib_le_of_nth_denom (or.inr this)) },
    have zero_lt_B : 0 < B, by
    { have : (0 : K) < fib (n + 1), by exact_mod_cast fib_pos n.zero_lt_succ,
      exact (lt_of_lt_of_le this B_ineq) },
    have zero_lt_mul_conts : 0 < B * nB, by
    { have : 0 < nB, by
      { have : (0 : K) < fib (n + 2), by exact_mod_cast fib_pos (n + 1).zero_lt_succ,
        exact (lt_of_lt_of_le this nB_ineq) },
      solve_by_elim [mul_pos] },
    suffices : 1 < ε * (B * nB), from (div_lt_iff zero_lt_mul_conts).elim_right this,
    -- use that `N ≥ n` was obtained from the archimedian property to show the following
    have one_lt_ε_mul_N : 1 < ε * n, by
    { have one_lt_ε_mul_N' : 1 < ε * (N' : K), from (div_lt_iff' ε_pos).elim_left one_div_ε_lt_N',
      have : (N' : K) ≤ N, by exact_mod_cast (le_max_left  _ _),
      have : ε * N' ≤ ε * n, from
        (mul_le_mul_left ε_pos).elim_right (le_trans this (by exact_mod_cast n_ge_N)),
      exact (lt_of_lt_of_le one_lt_ε_mul_N' this) },
    suffices : ε * n ≤ ε * (B * nB), from lt_of_lt_of_le one_lt_ε_mul_N this,
    -- cancel `ε`
    suffices : (n : K) ≤ B * nB, from (mul_le_mul_left ε_pos).elim_right this,
    show (n : K) ≤ B * nB,
      calc (n : K)
          ≤ fib n                     : by exact_mod_cast (le_fib_self $ le_trans
                                           (le_max_right N' 5) n_ge_N)
      ... ≤ fib (n + 1)               : by exact_mod_cast fib_le_fib_succ
      ... ≤ fib (n + 1) * fib (n + 1) : by exact_mod_cast ((fib (n + 1)).le_mul_self)
      ... ≤ fib (n + 1) * fib (n + 2) : mul_le_mul_of_nonneg_left
                                          (by exact_mod_cast fib_le_fib_succ)
                                          (by exact_mod_cast (fib (n + 1)).zero_le)
      ... ≤ B * nB                    : mul_le_mul B_ineq nB_ineq
                                          (by exact_mod_cast (fib (n + 2)).zero_le)
                                          (le_of_lt zero_lt_B) }
end

local attribute [instance] preorder.topology

theorem of_convergence [order_topology K] :
  filter.tendsto ((gcf.of v).convergents) filter.at_top $ nhds v :=
by simpa [linear_ordered_add_comm_group.tendsto_nhds, abs_sub] using (of_convergence_epsilon v)

end convergence

end generalized_continued_fraction


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Reid Barton, Sean Leather, Yury Kudryashov

! This file was ported from Lean 3 source module category_theory.concrete_category.basic
! leanprover-community/mathlib commit 05b820ec79b3c98a7dbf1cb32e181584166da2ca
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Types
import Mathlib.CategoryTheory.Functor.EpiMono
import Mathlib.CategoryTheory.Limits.Constructions.EpiMono

/-!
# Concrete categories

A concrete category is a category `C` with a fixed faithful functor
`forget : C ⥤ Type*`.  We define concrete categories using `class
concrete_category`.  In particular, we impose no restrictions on the
carrier type `C`, so `Type` is a concrete category with the identity
forgetful functor.

Each concrete category `C` comes with a canonical faithful functor
`forget C : C ⥤ Type*`.  We say that a concrete category `C` admits a
*forgetful functor* to a concrete category `D`, if it has a functor
`forget₂ C D : C ⥤ D` such that `(forget₂ C D) ⋙ (forget D) = forget C`,
see `class has_forget₂`.  Due to `faithful.div_comp`, it suffices
to verify that `forget₂.obj` and `forget₂.map` agree with the equality
above; then `forget₂` will satisfy the functor laws automatically, see
`has_forget₂.mk'`.

Two classes helping construct concrete categories in the two most
common cases are provided in the files `bundled_hom` and
`unbundled_hom`, see their documentation for details.

## References

See [Ahrens and Lumsdaine, *Displayed Categories*][ahrens2017] for
related work.
-/

universe w v v' u

namespace CategoryTheory

open CategoryTheory.Limits

/-- A concrete category is a category `C` with a fixed faithful functor `Forget : C ⥤ Type`.

Note that `ConcreteCategory` potentially depends on three independent universe levels,
* the universe level `w` appearing in `Forget : C ⥤ Type w`
* the universe level `v` of the morphisms (i.e. we have a `Category.{v} C`)
* the universe level `u` of the objects (i.e `C : Type u`)
They are specified that order, to avoid unnecessary universe annotations.
-/
class ConcreteCategory (C : Type u) [Category.{v} C] where
  /-- We have a functor to Type -/
  Forget : C ⥤ Type w -- Porting note: it has Type in the signature...
  /-- That functor is faithful -/
  [forget_faithful : Faithful Forget]
#align category_theory.concrete_category CategoryTheory.ConcreteCategory
#align category_theory.concrete_category.forget CategoryTheory.ConcreteCategory.Forget

attribute [instance] ConcreteCategory.forget_faithful

/-- The forgetful functor from a concrete category to `Type u`. -/
@[reducible]
def forget (C : Type v) [Category C] [ConcreteCategory.{u} C] : C ⥤ Type u :=
  ConcreteCategory.Forget
#align category_theory.forget CategoryTheory.forget

instance ConcreteCategory.types : ConcreteCategory (Type u) where
  Forget := 𝟭 _
#align category_theory.concrete_category.types CategoryTheory.ConcreteCategory.types

/-- Provide a coercion to `Type u` for a concrete category. This is not marked as an instance
as it could potentially apply to every type, and so is too expensive in typeclass search.

You can use it on particular examples as:
```
instance : HasCoeToSort X := ConcreteCategory.hasCoeToSort X
```
-/
def ConcreteCategory.hasCoeToSort (C : Type v) [Category C] [ConcreteCategory C] :
    CoeSort C (Type u) where
  coe := fun X => ConcreteCategory.Forget.obj X
#align category_theory.concrete_category.has_coe_to_sort CategoryTheory.ConcreteCategory.hasCoeToSort

section

attribute [local instance] ConcreteCategory.hasCoeToSort

variable {C : Type v} [Category C] [ConcreteCategory.{w} C]

@[simp]
theorem forget_obj_eq_coe {X : C} : (forget C).obj X = X := rfl
#align category_theory.forget_obj_eq_coe CategoryTheory.forget_obj_eq_coe

/-- Usually a bundled hom structure already has a coercion to function
that works with different universes. So we don't use this as a global instance. -/
def ConcreteCategory.hasCoeToFun {X Y : C} : CoeFun (X ⟶ Y) fun _ => X → Y :=
  ⟨fun f => (forget _).map f⟩
#align category_theory.concrete_category.has_coe_to_fun CategoryTheory.ConcreteCategory.hasCoeToFun

attribute [local instance] ConcreteCategory.hasCoeToFun

/-- In any concrete category, we can test equality of morphisms by pointwise evaluations.-/
@[ext 900] -- Porting note: lowered priority
theorem ConcreteCategory.hom_ext {X Y : C} (f g : X ⟶ Y) (w : ∀ x : X, f x = g x) : f = g := by
  apply @Faithful.map_injective C _ (Type w) _ (forget C) _ X Y
  dsimp [forget]
  funext x
  exact w x
#align category_theory.concrete_category.hom_ext CategoryTheory.ConcreteCategory.hom_ext

@[simp, nolint synTaut] -- Porting note: synTaut is fine with CoeFun.coe explicitly on the RHS
theorem forget_map_eq_coe {X Y : C} (f : X ⟶ Y) : (forget C).map f = f := rfl
#align category_theory.forget_map_eq_coe CategoryTheory.forget_map_eq_coe

/-- Analogue of `congr_fun h x`,
when `h : f = g` is an equality between morphisms in a concrete category.
-/
theorem congr_hom {X Y : C} {f g : X ⟶ Y} (h : f = g) (x : X) : f x = g x :=
  congrFun (congrArg (fun k : X ⟶ Y => (k : X → Y)) h) x
#align category_theory.congr_hom CategoryTheory.congr_hom

theorem coe_id {X : C} : (𝟙 X : X → X) = id :=
  (forget _).map_id X
#align category_theory.coe_id CategoryTheory.coe_id

theorem coe_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) : (f ≫ g : X → Z) = g ∘ f :=
  (forget _).map_comp f g
#align category_theory.coe_comp CategoryTheory.coe_comp

-- Porting note: removed @[simp] since simp can prove this
theorem id_apply {X : C} (x : X) : (𝟙 X : X → X) x = x :=
  congr_fun ((forget _).map_id X) x
#align category_theory.id_apply CategoryTheory.id_apply

-- Porting note: removed @[simp] since simp can prove this
theorem comp_apply {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) : (f ≫ g) x = g (f x) :=
  congr_fun ((forget _).map_comp _ _) x
#align category_theory.comp_apply CategoryTheory.comp_apply

theorem ConcreteCategory.congr_hom {X Y : C} {f g : X ⟶ Y} (h : f = g) (x : X) : f x = g x :=
  congr_fun (congr_arg (fun f : X ⟶ Y => (f : X → Y)) h) x
#align category_theory.concrete_category.congr_hom CategoryTheory.ConcreteCategory.congr_hom

theorem ConcreteCategory.congr_arg {X Y : C} (f : X ⟶ Y) {x x' : X} (h : x = x') : f x = f x' :=
  congrArg (f : X → Y) h
#align category_theory.concrete_category.congr_arg CategoryTheory.ConcreteCategory.congr_arg

/-- In any concrete category, injective morphisms are monomorphisms. -/
theorem ConcreteCategory.mono_of_injective {X Y : C} (f : X ⟶ Y) (i : Function.Injective f) :
    Mono f :=
  (forget C).mono_of_mono_map ((mono_iff_injective f).2 i)
#align category_theory.concrete_category.mono_of_injective CategoryTheory.ConcreteCategory.mono_of_injective

theorem ConcreteCategory.injective_of_mono_of_preservesPullback {X Y : C} (f : X ⟶ Y) [Mono f]
    [PreservesLimitsOfShape WalkingCospan (forget C)] : Function.Injective f :=
  (mono_iff_injective ((forget C).map f)).mp inferInstance
#align category_theory.concrete_category.injective_of_mono_of_preserves_pullback CategoryTheory.ConcreteCategory.injective_of_mono_of_preservesPullback

theorem ConcreteCategory.mono_iff_injective_of_preservesPullback {X Y : C} (f : X ⟶ Y)
    [PreservesLimitsOfShape WalkingCospan (forget C)] : Mono f ↔ Function.Injective f :=
  ((forget C).mono_map_iff_mono _).symm.trans (mono_iff_injective _)
#align category_theory.concrete_category.mono_iff_injective_of_preserves_pullback CategoryTheory.ConcreteCategory.mono_iff_injective_of_preservesPullback

/-- In any concrete category, surjective morphisms are epimorphisms. -/
theorem ConcreteCategory.epi_of_surjective {X Y : C} (f : X ⟶ Y) (s : Function.Surjective f) :
    Epi f :=
  (forget C).epi_of_epi_map ((epi_iff_surjective f).2 s)
#align category_theory.concrete_category.epi_of_surjective CategoryTheory.ConcreteCategory.epi_of_surjective

theorem ConcreteCategory.surjective_of_epi_of_preservesPushout {X Y : C} (f : X ⟶ Y) [Epi f]
    [PreservesColimitsOfShape WalkingSpan (forget C)] : Function.Surjective f :=
  (epi_iff_surjective ((forget C).map f)).mp inferInstance
#align category_theory.concrete_category.surjective_of_epi_of_preserves_pushout CategoryTheory.ConcreteCategory.surjective_of_epi_of_preservesPushout

theorem ConcreteCategory.epi_iff_surjective_of_preservesPushout {X Y : C} (f : X ⟶ Y)
    [PreservesColimitsOfShape WalkingSpan (forget C)] : Epi f ↔ Function.Surjective f :=
  ((forget C).epi_map_iff_epi _).symm.trans (epi_iff_surjective _)
#align category_theory.concrete_category.epi_iff_surjective_of_preserves_pushout CategoryTheory.ConcreteCategory.epi_iff_surjective_of_preservesPushout

theorem ConcreteCategory.bijective_of_isIso {X Y : C} (f : X ⟶ Y) [IsIso f] :
    Function.Bijective ((forget C).map f) := by
  rw [← isIso_iff_bijective]
  infer_instance
#align category_theory.concrete_category.bijective_of_is_iso CategoryTheory.ConcreteCategory.bijective_of_isIso

@[simp]
theorem ConcreteCategory.hasCoeToFun_Type {X Y : Type u} (f : X ⟶  Y) : CoeFun.coe f = f := rfl
#align category_theory.concrete_category.has_coe_to_fun_Type CategoryTheory.ConcreteCategory.hasCoeToFun_Type

end

/-- `HasForget₂ C D`, where `C` and `D` are both concrete categories, provides a functor
`forget₂ C D : C ⥤ D` and a proof that `forget₂ ⋙ (forget D) = forget C`.
-/
class HasForget₂ (C : Type v) (D : Type v') [Category C] [ConcreteCategory.{u} C] [Category D]
  [ConcreteCategory.{u} D] where
  /-- A functor from `C` to `D` -/
  forget₂ : C ⥤ D
  /-- It covers the `ConcreteCategory.Forget` for `C` and `D` -/
  forget_comp : forget₂ ⋙ forget D = forget C := by aesop
#align category_theory.has_forget₂ CategoryTheory.HasForget₂

/-- The forgetful functor `C ⥤ D` between concrete categories for which we have an instance
`HasForget₂ C `. -/
@[reducible]
def forget₂ (C : Type v) (D : Type v') [Category C] [ConcreteCategory C] [Category D]
    [ConcreteCategory D] [HasForget₂ C D] : C ⥤ D :=
  HasForget₂.forget₂
#align category_theory.forget₂ CategoryTheory.forget₂

instance forget₂_faithful (C : Type v) (D : Type v') [Category C] [ConcreteCategory C] [Category D]
    [ConcreteCategory D] [HasForget₂ C D] : Faithful (forget₂ C D) :=
  HasForget₂.forget_comp.faithful_of_comp
#align category_theory.forget₂_faithful CategoryTheory.forget₂_faithful

instance forget₂_preservesMonomorphisms (C : Type v) (D : Type v') [Category C] [ConcreteCategory C]
    [Category D] [ConcreteCategory D] [HasForget₂ C D] [(forget C).PreservesMonomorphisms] :
    (forget₂ C D).PreservesMonomorphisms :=
  have : (forget₂ C D ⋙ forget D).PreservesMonomorphisms := by
    simp only [HasForget₂.forget_comp]
    infer_instance
  Functor.preservesMonomorphisms_of_preserves_of_reflects _ (forget D)
#align category_theory.forget₂_preserves_monomorphisms CategoryTheory.forget₂_preservesMonomorphisms

instance forget₂_preservesEpimorphisms (C : Type v) (D : Type v') [Category C] [ConcreteCategory C]
    [Category D] [ConcreteCategory D] [HasForget₂ C D] [(forget C).PreservesEpimorphisms] :
    (forget₂ C D).PreservesEpimorphisms :=
  have : (forget₂ C D ⋙ forget D).PreservesEpimorphisms := by
    simp only [HasForget₂.forget_comp]
    infer_instance
  Functor.preservesEpimorphisms_of_preserves_of_reflects _ (forget D)
#align category_theory.forget₂_preserves_epimorphisms CategoryTheory.forget₂_preservesEpimorphisms

instance InducedCategory.concreteCategory {C : Type v} {D : Type v'} [Category D]
    [ConcreteCategory D] (f : C → D) : ConcreteCategory (InducedCategory D f) where
  Forget := inducedFunctor f ⋙ forget D
#align category_theory.induced_category.concrete_category CategoryTheory.InducedCategory.concreteCategory

instance InducedCategory.hasForget₂ {C : Type v} {D : Type v'} [Category D] [ConcreteCategory D]
    (f : C → D) : HasForget₂ (InducedCategory D f) D where
  forget₂ := inducedFunctor f
  forget_comp := rfl
#align category_theory.induced_category.has_forget₂ CategoryTheory.InducedCategory.hasForget₂

instance FullSubcategory.concreteCategory {C : Type v} [Category C] [ConcreteCategory C]
    (Z : C → Prop) : ConcreteCategory (FullSubcategory Z) where
  Forget := fullSubcategoryInclusion Z ⋙ forget C
#align category_theory.full_subcategory.concrete_category CategoryTheory.FullSubcategoryₓ.concreteCategory

instance FullSubcategory.hasForget₂ {C : Type v} [Category C] [ConcreteCategory C] (Z : C → Prop) :
    HasForget₂ (FullSubcategory Z) C where
  forget₂ := fullSubcategoryInclusion Z
  forget_comp := rfl
#align category_theory.full_subcategory.has_forget₂ CategoryTheory.FullSubcategoryₓ.hasForget₂

/-- In order to construct a “partially forgetting” functor, we do not need to verify functor laws;
it suffices to ensure that compositions agree with `forget₂ C D ⋙ forget D = forget C`.
-/
def HasForget₂.mk' {C : Type v} {D : Type v'} [Category C] [ConcreteCategory C] [Category D]
    [ConcreteCategory D] (obj : C → D) (h_obj : ∀ X, (forget D).obj (obj X) = (forget C).obj X)
    (map : ∀ {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
    (h_map : ∀ {X Y} {f : X ⟶ Y}, HEq ((forget D).map (map f)) ((forget C).map f)) : HasForget₂ C D
    where
  forget₂ := Faithful.div _ _ _ @h_obj _ @h_map
  forget_comp := by apply Faithful.div_comp
#align category_theory.has_forget₂.mk' CategoryTheory.HasForget₂.mk'

/-- Every forgetful functor factors through the identity functor. This is not a global instance as
    it is prone to creating type class resolution loops. -/
def hasForgetToType (C : Type v) [Category C] [ConcreteCategory C] : HasForget₂ C (Type u) where
  forget₂ := forget C
  forget_comp := Functor.comp_id _
#align category_theory.has_forget_to_Type CategoryTheory.hasForgetToType

end CategoryTheory


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.functor.fully_faithful

/-!
# Functors which reflect isomorphisms

A functor `F` reflects isomorphisms if whenever `F.map f` is an isomorphism, `f` was too.

It is formalized as a `Prop` valued typeclass `reflects_isomorphisms F`.

Any fully faithful functor reflects isomorphisms.
-/

open category_theory

namespace category_theory

universes v₁ v₂ v₃ u₁ u₂ u₃

variables {C : Type u₁} [category.{v₁} C]

section reflects_iso
variables {D : Type u₂} [category.{v₂} D]
variables {E : Type u₃} [category.{v₃} E]

/--
Define what it means for a functor `F : C ⥤ D` to reflect isomorphisms: for any
morphism `f : A ⟶ B`, if `F.map f` is an isomorphism then `f` is as well.
Note that we do not assume or require that `F` is faithful.
-/
class reflects_isomorphisms (F : C ⥤ D) : Prop :=
(reflects : Π {A B : C} (f : A ⟶ B) [is_iso (F.map f)], is_iso f)

/-- If `F` reflects isos and `F.map f` is an iso, then `f` is an iso. -/
lemma is_iso_of_reflects_iso {A B : C} (f : A ⟶ B) (F : C ⥤ D)
  [is_iso (F.map f)] [reflects_isomorphisms F] :
  is_iso f :=
reflects_isomorphisms.reflects F f

@[priority 100]
instance of_full_and_faithful (F : C ⥤ D) [full F] [faithful F] : reflects_isomorphisms F :=
{ reflects := λ X Y f i, by exactI
  ⟨⟨F.preimage (inv (F.map f)), ⟨F.map_injective (by simp), F.map_injective (by simp)⟩⟩⟩ }

instance (F : C ⥤ D) (G : D ⥤ E) [reflects_isomorphisms F] [reflects_isomorphisms G] :
  reflects_isomorphisms (F ⋙ G) :=
⟨λ _ _ f (hf : is_iso (G.map _)),
  by { resetI, haveI := is_iso_of_reflects_iso (F.map f) G, exact is_iso_of_reflects_iso f F }⟩

end reflects_iso

end category_theory


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.natural_isomorphism
import Mathlib.category_theory.full_subcategory
import Mathlib.PostPort

universes v₁ v₂ u₁ u₂ l

namespace Mathlib

/-!
# Essential image of a functor

The essential image `ess_image` of a functor consists of the objects in the target category which
are isomorphic to an object in the image of the object function.
This, for instance, allows us to talk about objects belonging to a subcategory expressed as a
functor rather than a subtype, preserving the principle of equivalence. For example this lets us
define exponential ideals.

The essential image can also be seen as a subcategory of the target category, and witnesses that
a functor decomposes into a essentially surjective functor and a fully faithful functor.
(TODO: show that this decomposition forms an orthogonal factorisation system).
-/

namespace category_theory

namespace functor

/--
The essential image of a functor `F` consists of those objects in the target category which are
isomorphic to an object in the image of the function `F.obj`. In other words, this is the closure
under isomorphism of the function `F.obj`.
This is the "non-evil" way of describing the image of a functor.
-/
def ess_image {C : Type u₁} {D : Type u₂} [category C] [category D] (F : C ⥤ D) : set D :=
  fun (Y : D) => ∃ (X : C), Nonempty (obj F X ≅ Y)

/-- Get the witnessing object that `Y` is in the subcategory given by `F`. -/
def ess_image.witness {C : Type u₁} {D : Type u₂} [category C] [category D] {F : C ⥤ D} {Y : D}
    (h : Y ∈ ess_image F) : C :=
  Exists.some h

/-- Extract the isomorphism between `F.obj h.witness` and `Y` itself. -/
def ess_image.get_iso {C : Type u₁} {D : Type u₂} [category C] [category D] {F : C ⥤ D} {Y : D}
    (h : Y ∈ ess_image F) : obj F (ess_image.witness h) ≅ Y :=
  Classical.choice sorry

/-- Being in the essential image is a "hygenic" property: it is preserved under isomorphism. -/
theorem ess_image.of_iso {C : Type u₁} {D : Type u₂} [category C] [category D] {F : C ⥤ D} {Y : D}
    {Y' : D} (h : Y ≅ Y') (hY : Y ∈ ess_image F) : Y' ∈ ess_image F :=
  Exists.imp (fun (B : C) => nonempty.map fun (_x : obj F B ≅ Y) => _x ≪≫ h) hY

/--
If `Y` is in the essential image of `F` then it is in the essential image of `F'` as long as
`F ≅ F'`.
-/
theorem ess_image.of_nat_iso {C : Type u₁} {D : Type u₂} [category C] [category D] {F : C ⥤ D}
    {F' : C ⥤ D} (h : F ≅ F') {Y : D} (hY : Y ∈ ess_image F) : Y ∈ ess_image F' :=
  Exists.imp (fun (X : C) => nonempty.map fun (t : obj F X ≅ Y) => iso.app (iso.symm h) X ≪≫ t) hY

/-- Isomorphic functors have equal essential images. -/
theorem ess_image_eq_of_nat_iso {C : Type u₁} {D : Type u₂} [category C] [category D] {F : C ⥤ D}
    {F' : C ⥤ D} (h : F ≅ F') : ess_image F = ess_image F' :=
  set.ext fun (A : D) => { mp := ess_image.of_nat_iso h, mpr := ess_image.of_nat_iso (iso.symm h) }

/-- An object in the image is in the essential image. -/
theorem obj_mem_ess_image {C : Type u₁} {D : Type u₂} [category C] [category D] (F : D ⥤ C)
    (Y : D) : obj F Y ∈ ess_image F :=
  Exists.intro Y (Nonempty.intro (iso.refl (obj F Y)))

protected instance ess_image.category_theory.category {C : Type u₁} {D : Type u₂} [category C]
    [category D] {F : C ⥤ D} : category ↥(ess_image F) :=
  category_theory.full_subcategory fun (x : D) => x ∈ ess_image F

/-- The essential image as a subcategory has a fully faithful inclusion into the target category. -/
@[simp] theorem ess_image_inclusion_obj {C : Type u₁} {D : Type u₂} [category C] [category D]
    (F : C ⥤ D) (c : Subtype fun (X : D) => (fun (x : D) => x ∈ ess_image F) X) :
    obj (ess_image_inclusion F) c = ↑c :=
  Eq.refl ↑c

/--
Given a functor `F : C ⥤ D`, we have an (essentially surjective) functor from `C` to the essential
image of `F`.
-/
def to_ess_image {C : Type u₁} {D : Type u₂} [category C] [category D] (F : C ⥤ D) :
    C ⥤ ↥(ess_image F) :=
  mk (fun (X : C) => { val := obj F X, property := obj_mem_ess_image F X })
    fun (X Y : C) (f : X ⟶ Y) => preimage (ess_image_inclusion F) (map F f)

/--
The functor `F` factorises through its essential image, where the first functor is essentially
surjective and the second is fully faithful.
-/
@[simp] theorem to_ess_image_comp_essential_image_inclusion_hom_app {C : Type u₁} {D : Type u₂}
    [category C] [category D] {F : C ⥤ D} (X : C) :
    nat_trans.app (iso.hom to_ess_image_comp_essential_image_inclusion) X = 𝟙 :=
  Eq.refl 𝟙

end functor

/--
A functor `F : C ⥤ D` is essentially surjective if every object of `D` is in the essential image
of `F`. In other words, for every `Y : D`, there is some `X : C` with `F.obj X ≅ Y`.

See https://stacks.math.columbia.edu/tag/001C.
-/
class ess_surj {C : Type u₁} {D : Type u₂} [category C] [category D] (F : C ⥤ D) where
  mem_ess_image : ∀ (Y : D), Y ∈ functor.ess_image F

protected instance functor.to_ess_image.ess_surj {C : Type u₁} {D : Type u₂} [category C]
    [category D] {F : C ⥤ D} : ess_surj (functor.to_ess_image F) :=
  ess_surj.mk fun (_x : ↥(functor.ess_image F)) => sorry

/-- Given an essentially surjective functor, we can find a preimage for every object `Y` in the
    codomain. Applying the functor to this preimage will yield an object isomorphic to `Y`, see
    `obj_obj_preimage_iso`. -/
/-- Applying an essentially surjective functor to a preimage of `Y` yields an object that is
def functor.obj_preimage {C : Type u₁} {D : Type u₂} [category C] [category D] (F : C ⥤ D)
    [ess_surj F] (Y : D) : C :=
  functor.ess_image.witness (ess_surj.mem_ess_image F Y)

    isomorphic to `Y`. -/
def functor.obj_obj_preimage_iso {C : Type u₁} {D : Type u₂} [category C] [category D] (F : C ⥤ D)
    [ess_surj F] (Y : D) : functor.obj F (functor.obj_preimage F Y) ≅ Y :=
  functor.ess_image.get_iso (ess_surj.mem_ess_image F Y)

end Mathlib


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

import order.category.Lat

/-!
# Category of linear orders

This defines `LinOrd`, the category of linear orders with monotone maps.
-/

open category_theory

universe u

/-- The category of linear orders. -/
def LinOrd := bundled linear_order

namespace LinOrd

instance : bundled_hom.parent_projection @linear_order.to_partial_order := ⟨⟩

attribute [derive [large_category, concrete_category]] LinOrd

instance : has_coe_to_sort LinOrd Type* := bundled.has_coe_to_sort

/-- Construct a bundled `LinOrd` from the underlying type and typeclass. -/
def of (α : Type*) [linear_order α] : LinOrd := bundled.of α

@[simp] lemma coe_of (α : Type*) [linear_order α] : ↥(of α) = α := rfl

instance : inhabited LinOrd := ⟨of punit⟩

instance (α : LinOrd) : linear_order α := α.str

instance has_forget_to_Lat : has_forget₂ LinOrd Lat :=
{ forget₂ := { obj := λ X, Lat.of X,
               map := λ X Y f, (order_hom_class.to_lattice_hom X Y f : lattice_hom X Y) } }

/-- Constructs an equivalence between linear orders from an order isomorphism between them. -/
@[simps] def iso.mk {α β : LinOrd.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply x },
  inv_hom_id' := by { ext, exact e.apply_symm_apply x } }

/-- `order_dual` as a functor. -/
@[simps] def dual : LinOrd ⥤ LinOrd :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, order_hom.dual }

/-- The equivalence between `LinOrd` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : LinOrd ≌ LinOrd :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end LinOrd

lemma LinOrd_dual_comp_forget_to_Lat :
  LinOrd.dual ⋙ forget₂ LinOrd Lat = forget₂ LinOrd Lat ⋙ Lat.dual :=
rfl


import
  IMO2020.N4.N4_basic
  number_theory.legendre_symbol.quadratic_reciprocity
  extra.number_theory.dirichlet_thm_arithmetic_progression

/-! # IMO 2020 N4, Generalized Version (Part 2) -/

namespace IMOSL
namespace IMO2020N4

open function
open_locale classical

def balanced (p : ℕ) := ∀ a b : ℕ,
  a.coprime p → b.coprime p → a < b → ∃ i : ℕ, 0 < i ∧ (F p^[i]) a ≤ (F p^[i]) b

section general_results

variables {p : ℕ} (h : odd p)
include h

theorem balanced_iff_S0_coprime_eq_pairwise :
  balanced p ↔ ∀ x y : ℕ, x.coprime p → y.coprime p → S0 h x = S0 h y :=
begin
  ---- Right-to-left direction is easy
  symmetry; refine ⟨λ h1 a b ha hb h2, ⟨order_two_mod_p h, order_two_mod_p_pos h, _⟩, _⟩,
  rw [F_iterate_S, F_iterate_S, ← S0, ← S0, h1 a b ha hb, add_le_add_iff_right],
  exact le_of_lt h2,

  ---- Use contrapositive, and reduce to the case `S_p(x) < S_p(y)`
  suffices : (∃ x y : ℕ, x.coprime p ∧ y.coprime p ∧ S0 h x < S0 h y) → ¬balanced p,
  { intros h1; contrapose! h1,
    rcases h1 with ⟨x, y, h1, h2, h3⟩,
    rw [ne_iff_lt_or_gt, gt_iff_lt] at h3,
    cases h3 with h3 h3,
    exacts [this ⟨x, y, h1, h2, h3⟩, this ⟨y, x, h2, h1, h3⟩] },

  ---- There exists such `x` and `y` with an extra condition: `y < x`
  rintros ⟨u, y, h1, h2, h3⟩,
  simp only [balanced, not_forall, not_exists, not_and, not_le],
  replace h1 : ∃ x : ℕ, x.coprime p ∧ y < x ∧ S0 h x < S0 h y :=
  begin
    refine ⟨u + (y + 1) * p, _, _, _⟩,
    rwa nat.coprime_add_mul_right_left,
    rw ← nat.add_one_le_iff,
    exact le_trans (nat.le_mul_of_pos_right h.pos) le_add_self,
    rwa [S0_mod_p, nat.add_mul_mod_self_right, ← S0_mod_p]
  end,
  clear h3 u,
  rcases h1 with ⟨x, h1, h3⟩,

  ---- It suffices to find some `N ≥ 0` such that `F_p^N(x) > F_p^N(y)` but
  ----   `F_p^n(x) > F_p^n(y)` for all `n > N`
  suffices : ∃ N : ℕ, (∀ n : ℕ, N < n → (F p^[n]) x < (F p^[n]) y) ∧ (F p^[N]) y < (F p^[N]) x,
  { rcases this with ⟨N, h4, h5⟩,
    refine ⟨(F p^[N]) y, (F p^[N]) x, F_iterate_coprime h h2 _,
      F_iterate_coprime h h1 _, h5, λ k hk, _⟩,
    replace h4 := h4 (k + N) (lt_add_of_pos_left N hk),
    rwa [iterate_add, comp_app, comp_app] at h4 },

  ---- Finishing: find such `N`
  clear h1 h2; cases h3 with h1 h2,
  replace h2 := eventually_F_lt_of_S0_lt h h2,
  have h3 := nat.find_spec h2,
  refine ⟨(nat.find h2).pred, λ n X, h3 n (nat.le_of_pred_lt X), _⟩,
  generalize_hyp h4 : nat.find h2 = N at h3 ⊢,
  cases N with _ N,
  exact h1,
  refine lt_of_le_of_ne _ (λ X, ne_of_lt h1 (injective.iterate (F_injective h) _ X)),
  rw [nat.pred_succ, ← not_lt],
  replace h4 := nat.find_min h2 (by rw h4; exact N.lt_succ_self),
  clear h2,
  simp only [not_forall] at h4,
  rcases h4 with ⟨n, h2, h4⟩,
  rw [le_iff_eq_or_lt, ← nat.succ_le_iff] at h2,
  rcases h2 with rfl | h2,
  exact h4,
  exfalso; exact h4 (h3 n h2)
end

theorem balanced_iff_S0_coprime_eq_const (h0 : 1 < p) :
  balanced p ↔ ∀ x : ℕ, x.coprime p → 2 * S0 h x = order_two_mod_p h * p :=
begin
  ---- Right-to-left direction is again easy
  rw [balanced_iff_S0_coprime_eq_pairwise h, iff.comm],
  refine ⟨λ h1 x y h2 h3, _, λ h1 x h2, _⟩,
  replace h2 := h1 x h2,
  rw ← h1 y h3 at h2,
  exact nat.eq_of_mul_eq_mul_left two_pos h2,

  ---- Left-to-right direction is not too hard either
  suffices : ∃ y : ℕ, y.coprime p ∧ p ∣ x + y,
  { rcases this with ⟨y, h3, h4⟩,
    rw [← S0_p_dvd_add h (not_dvd_of_coprime (ne_of_gt h0) h2) h4, ← h1 x y h2 h3, ← two_mul] },
  clear h1 h0,
  refine ⟨x * (p - 1), h2.mul _, _⟩,
  cases p with _ p,
  exfalso; exact nat.lt_irrefl 0 h.pos,
  rw [nat.succ_eq_add_one, nat.add_sub_cancel, nat.coprime_self_add_right],
  exact nat.coprime_one_right p,
  rw [← mul_one_add, add_comm, nat.sub_add_cancel h.pos],
  exact ⟨x, mul_comm x p⟩
end

/-- Generally, if `-1` is a power of `2` mod `p`, then `p` is balanced -/
lemma balanced_of_neg_one_is_two_pow_mod_p (h0 : 1 < p) (h1 : ∃ c : ℕ, p ∣ 2 ^ c + 1) :
  balanced p :=
begin
  cases h1 with c h1,
  rw balanced_iff_S0_coprime_eq_const h h0; intros x h2,
  replace h1 : p ∣ x + 2 ^ c * x :=
    by rw [← one_add_mul, add_comm]; exact dvd_mul_of_dvd_left h1 x,
  rw [← S0_p_dvd_add h (not_dvd_of_coprime (ne_of_gt h0) h2) h1, S0_two_pow_mul h, ← two_mul]
end

/-- Generally, if `p` is balanced, then the order of `2` mod `p` is even -/
lemma even_order_two_mod_p_of_balanced (h0 : 1 < p) (h1 : balanced p) :
  even (order_two_mod_p h) :=
begin
  rw balanced_iff_S0_coprime_eq_const h h0 at h1,
  replace h1 : 2 ∣ order_two_mod_p h * p := ⟨S0 h 1, (h1 1 (nat.coprime_one_left p)).symm⟩,
  rwa [(two_coprime_p h).dvd_mul_right, ← even_iff_two_dvd] at h1
end

end general_results

section prime_results

/-- Final solution, part 2, prime power version -/
theorem final_solution_part2' {p : ℕ} (h : odd p) (h0 : is_prime_pow p) :
  balanced p ↔ even (order_two_mod_p h) :=
⟨even_order_two_mod_p_of_balanced h h0.one_lt,
  λ h1, balanced_of_neg_one_is_two_pow_mod_p h h0.one_lt
    ((order_two_even_iff_prime_pow h h0).mp h1)⟩

variables {p : ℕ} (hp : p.prime)
include hp

/-- Final solution, part 2 -/
theorem final_solution_part2 (h : odd p) :
  balanced p ↔ even (order_two_mod_p h) :=
  final_solution_part2' h hp.is_prime_pow

/-- If p is prime, p ≡ 3 or 5 (mod 8), then p is balanced -/
theorem balanced_3_or_5_mod_8 (h : p % 8 = 3 ∨ p % 8 = 5) : balanced p :=
begin
  have h0 : p ≠ 2 := by contrapose! h; subst h; split; norm_num,
  have h1 : odd p := (or_iff_right h0).mp hp.eq_two_or_odd',
  refine balanced_of_neg_one_is_two_pow_mod_p h1 hp.one_lt ⟨p / 2, _⟩,
  haveI : fact p.prime := ⟨hp⟩,
  have h2 := h0,
  rw [← nat.coprime_primes hp nat.prime_two, hp.coprime_iff_not_dvd,
      ← char_p.cast_eq_zero_iff (zmod p), nat.cast_two, ← int.cast_two] at h2,
  cases legendre_sym.eq_one_or_neg_one p h2 with h3 h3,
  rw [legendre_sym.eq_one_iff p h2, int.cast_two, zmod.exists_sq_eq_two_iff h0] at h3,
  exfalso; contrapose! h,
  cases h3 with h3 h3; rw h3; norm_num,
  rw [← char_p.cast_eq_zero_iff (zmod p), nat.cast_succ, add_eq_zero_iff_eq_neg,
      nat.cast_pow, nat.cast_two, ← int.cast_two, ← legendre_sym.eq_pow, h3,
      int.cast_neg, int.cast_one]
end

/-- If p is prime, p ≡ 7 (mod 8), then p is not balanced -/
theorem not_balanced_7_mod_8 (h : p % 8 = 7) : ¬balanced p :=
begin
  have h0 : p ≠ 2 := by contrapose! h; subst h; norm_num,
  have h1 : odd p := (or_iff_right h0).mp hp.eq_two_or_odd',
  rw [final_solution_part2 hp h1, ← nat.odd_iff_not_even],
  suffices : 2 ^ (p / 2) ≡ 1 [MOD p],
  { rw two_pow_mod_p_eq_one_iff h1 at this,
    cases this with c this,
    refine @nat.odd.of_mul_left _ c _,
    rw ← this; clear this c,
    rw [← nat.div_add_mod p 8, h, bit0, ← two_mul, mul_assoc, add_comm,
        nat.add_mul_div_left _ _ two_pos, nat.odd_add],
    norm_num },

  haveI : fact p.prime := ⟨hp⟩,
  rw [← zmod.eq_iff_modeq_nat, nat.cast_one, nat.cast_pow, nat.cast_two,
      ← zmod.euler_criterion, zmod.exists_sq_eq_two_iff h0],
  right; exact h,
  rwa [ne.def, ← nat.cast_two, char_p.cast_eq_zero_iff (zmod p) p,
       ← hp.coprime_iff_not_dvd, nat.coprime_primes hp nat.prime_two]
end

end prime_results

/-- There are infinitely many odd primes that are not balanced.
  This is the original version of Part 2. -/
theorem infinite_set_of_odd_primes_not_balanced :
  {p : ℕ | odd p ∧ p.prime ∧ ¬balanced p}.infinite :=
begin
  have h : 7 < 8 := by norm_num,
  have h0 : nat.coprime 7 8 := by norm_num,
  refine set.infinite.mono _ (extra.infinite_set_of_primes_mod_eq h h0),
  rintros p ⟨hp, h1⟩,
  refine ⟨_, hp, not_balanced_7_mod_8 hp h1⟩,
  refine (or_iff_right _).mp hp.eq_two_or_odd',
  contrapose! h1; subst h1; norm_num
end

/-- There are also infinitely many odd primes that are balanced. -/
theorem infinite_set_of_odd_primes_balanced :
  {p : ℕ | odd p ∧ p.prime ∧ balanced p}.infinite :=
begin
  have h : 5 < 8 := by norm_num,
  have h0 : nat.coprime 5 8 := by norm_num,
  refine set.infinite.mono _ (extra.infinite_set_of_primes_mod_eq h h0),
  rintros p ⟨hp, h1⟩,
  refine ⟨_, hp, balanced_3_or_5_mod_8 hp (or.inr h1)⟩,
  refine (or_iff_right _).mp hp.eq_two_or_odd',
  contrapose! h1; subst h1; norm_num
end

end IMO2020N4
end IMOSL


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

Introduces the rational numbers as discrete, linear ordered field.
-/

import
  data.nat.gcd data.pnat data.int.sqrt data.equiv.encodable order.basic
  algebra.ordered_field data.real.cau_seq

/- rational numbers -/

/-- `rat`, or `ℚ`, is the type of rational numbers. It is defined
  as the set of pairs ⟨n, d⟩ of integers such that `d` is positive and `n` and
  `d` are coprime. This representation is preferred to the quotient
  because without periodic reduction, the numerator and denominator can grow
  exponentially (for example, adding 1/2 to itself repeatedly). -/
structure rat := mk' ::
(num : ℤ)
(denom : ℕ)
(pos : denom > 0)
(cop : num.nat_abs.coprime denom)
notation `ℚ` := rat

namespace rat

protected def repr : ℚ → string
| ⟨n, d, _, _⟩ := if d = 1 then _root_.repr n else
  _root_.repr n ++ "/" ++ _root_.repr d

instance : has_repr ℚ := ⟨rat.repr⟩
instance : has_to_string ℚ := ⟨rat.repr⟩
meta instance : has_to_format ℚ := ⟨coe ∘ rat.repr⟩

instance : encodable ℚ := encodable.of_equiv (Σ n : ℤ, {d : ℕ // d > 0 ∧ n.nat_abs.coprime d})
  ⟨λ ⟨a, b, c, d⟩, ⟨a, b, c, d⟩, λ⟨a, b, c, d⟩, ⟨a, b, c, d⟩,
   λ ⟨a, b, c, d⟩, rfl, λ⟨a, b, c, d⟩, rfl⟩

/-- Embed an integer as a rational number -/
def of_int (n : ℤ) : ℚ :=
⟨n, 1, nat.one_pos, nat.coprime_one_right _⟩

instance : has_zero ℚ := ⟨of_int 0⟩
instance : has_one ℚ := ⟨of_int 1⟩
instance : inhabited ℚ := ⟨0⟩

/-- Form the quotient `n / d` where `n:ℤ` and `d:ℕ+` (not necessarily coprime) -/
def mk_pnat (n : ℤ) : ℕ+ → ℚ | ⟨d, dpos⟩ :=
let n' := n.nat_abs, g := n'.gcd d in
⟨n / g, d / g, begin
  apply (nat.le_div_iff_mul_le _ _ (nat.gcd_pos_of_pos_right _ dpos)).2,
  simp, exact nat.le_of_dvd dpos (nat.gcd_dvd_right _ _)
end, begin
  have : int.nat_abs (n / ↑g) = n' / g,
  { cases int.nat_abs_eq n with e e; rw e, { refl },
    rw [int.neg_div_of_dvd, int.nat_abs_neg], { refl },
    exact int.coe_nat_dvd.2 (nat.gcd_dvd_left _ _) },
  rw this,
  exact nat.coprime_div_gcd_div_gcd (nat.gcd_pos_of_pos_right _ dpos)
end⟩

/-- Form the quotient `n / d` where `n:ℤ` and `d:ℕ`. In the case `d = 0`, we
  define `n / 0 = 0` by convention. -/
def mk_nat (n : ℤ) (d : ℕ) : ℚ :=
if d0 : d = 0 then 0 else mk_pnat n ⟨d, nat.pos_of_ne_zero d0⟩

/-- Form the quotient `n / d` where `n d : ℤ`. -/
def mk : ℤ → ℤ → ℚ
| n (int.of_nat d) := mk_nat n d
| n -[1+ d]        := mk_pnat (-n) d.succ_pnat

local infix ` /. `:70 := mk

theorem mk_pnat_eq (n d h) : mk_pnat n ⟨d, h⟩ = n /. d :=
by change n /. d with dite _ _ _; simp [ne_of_gt h]

theorem mk_nat_eq (n d) : mk_nat n d = n /. d := rfl

@[simp] theorem mk_zero (n) : n /. 0 = 0 := rfl

@[simp] theorem zero_mk_pnat (n) : mk_pnat 0 n = 0 :=
by cases n; simp [mk_pnat]; change int.nat_abs 0 with 0; simp *; refl

@[simp] theorem zero_mk_nat (n) : mk_nat 0 n = 0 :=
by by_cases n = 0; simp [*, mk_nat]

@[simp] theorem zero_mk (n) : 0 /. n = 0 :=
by cases n; simp [mk]

private lemma gcd_abs_dvd_left {a b} : (nat.gcd (int.nat_abs a) b : ℤ) ∣ a :=
int.dvd_nat_abs.1 $ int.coe_nat_dvd.2 $ nat.gcd_dvd_left (int.nat_abs a) b

@[simp] theorem mk_eq_zero {a b : ℤ} (b0 : b ≠ 0) : a /. b = 0 ↔ a = 0 :=
begin
  constructor; intro h; [skip, {subst a, simp}],
  have : ∀ {a b}, mk_pnat a b = 0 → a = 0,
  { intros a b e, cases b with b h,
    injection e with e,
    apply int.eq_mul_of_div_eq_right gcd_abs_dvd_left e },
  cases b with b; simp [mk, mk_nat] at h,
  { simp [mt (congr_arg int.of_nat) b0] at h,
    exact this h },
  { apply neg_inj, simp [this h] }
end

theorem mk_eq : ∀ {a b c d : ℤ} (hb : b ≠ 0) (hd : d ≠ 0),
  a /. b = c /. d ↔ a * d = c * b :=
suffices ∀ a b c d hb hd, mk_pnat a ⟨b, hb⟩ = mk_pnat c ⟨d, hd⟩ ↔ a * d = c * b,
begin
  intros, cases b with b b; simp [mk, mk_nat, nat.succ_pnat],
  simp [mt (congr_arg int.of_nat) hb],
  all_goals {
    cases d with d d; simp [mk, mk_nat, nat.succ_pnat],
    simp [mt (congr_arg int.of_nat) hd],
    all_goals { rw this, try {refl} } },
  { change a * ↑(d.succ) = -c * ↑b ↔ a * -(d.succ) = c * b,
    constructor; intro h; apply neg_inj; simpa [left_distrib, neg_add_eq_iff_eq_add,
      eq_neg_iff_add_eq_zero, neg_eq_iff_add_eq_zero] using h },
  { change -a * ↑d = c * b.succ ↔ a * d = c * -b.succ,
    constructor; intro h; apply neg_inj; simpa [left_distrib, eq_comm] using h },
  { change -a * d.succ = -c * b.succ ↔ a * -d.succ = c * -b.succ,
    simp [left_distrib] }
end,
begin
  intros, simp [mk_pnat], constructor; intro h,
  { cases h with ha hb,
    have ha, {
      have dv := @gcd_abs_dvd_left,
      have := int.eq_mul_of_div_eq_right dv ha,
      rw ← int.mul_div_assoc _ dv at this,
      exact int.eq_mul_of_div_eq_left (dvd_mul_of_dvd_right dv _) this.symm },
    have hb, {
      have dv := λ {a b}, nat.gcd_dvd_right (int.nat_abs a) b,
      have := nat.eq_mul_of_div_eq_right dv hb,
      rw ← nat.mul_div_assoc _ dv at this,
      exact nat.eq_mul_of_div_eq_left (dvd_mul_of_dvd_right dv _) this.symm },
    have m0 : (a.nat_abs.gcd b * c.nat_abs.gcd d : ℤ) ≠ 0, {
      refine int.coe_nat_ne_zero.2 (ne_of_gt _),
      apply mul_pos; apply nat.gcd_pos_of_pos_right; assumption },
    apply eq_of_mul_eq_mul_right m0,
    simpa [mul_comm, mul_left_comm] using
      congr (congr_arg (*) ha.symm) (congr_arg coe hb) },
  { suffices : ∀ a c, a * d = c * b →
      a / a.gcd b = c / c.gcd d ∧ b / a.gcd b = d / c.gcd d,
    { cases this a.nat_abs c.nat_abs
        (by simpa [int.nat_abs_mul] using congr_arg int.nat_abs h) with h₁ h₂,
      have hs := congr_arg int.sign h,
      simp [int.sign_eq_one_of_pos (int.coe_nat_lt.2 hb),
            int.sign_eq_one_of_pos (int.coe_nat_lt.2 hd)] at hs,
      conv in a { rw ← int.sign_mul_nat_abs a },
      conv in c { rw ← int.sign_mul_nat_abs c },
      rw [int.mul_div_assoc, int.mul_div_assoc],
      exact ⟨congr (congr_arg (*) hs) (congr_arg coe h₁), h₂⟩,
      all_goals { exact int.coe_nat_dvd.2 (nat.gcd_dvd_left _ _) } },
    intros a c h,
    suffices bd : b / a.gcd b = d / c.gcd d,
    { refine ⟨_, bd⟩,
      apply nat.eq_of_mul_eq_mul_left hb,
      rw [← nat.mul_div_assoc _ (nat.gcd_dvd_left _ _), mul_comm,
          nat.mul_div_assoc _ (nat.gcd_dvd_right _ _), bd,
          ← nat.mul_div_assoc _ (nat.gcd_dvd_right _ _), h, mul_comm,
          nat.mul_div_assoc _ (nat.gcd_dvd_left _ _)] },
    suffices : ∀ {a c : ℕ} (b>0) (d>0),
      a * d = c * b → b / a.gcd b ≤ d / c.gcd d,
    { exact le_antisymm (this _ hb _ hd h) (this _ hd _ hb h.symm) },
    intros a c b hb d hd h,
    have gb0 := nat.gcd_pos_of_pos_right a hb,
    have gd0 := nat.gcd_pos_of_pos_right c hd,
    apply nat.le_of_dvd,
    apply (nat.le_div_iff_mul_le _ _ gd0).2,
    simp, apply nat.le_of_dvd hd (nat.gcd_dvd_right _ _),
    apply (nat.coprime_div_gcd_div_gcd gb0).symm.dvd_of_dvd_mul_left,
    refine ⟨c / c.gcd d, _⟩,
    rw [← nat.mul_div_assoc _ (nat.gcd_dvd_left _ _),
        ← nat.mul_div_assoc _ (nat.gcd_dvd_right _ _)],
    apply congr_arg (/ c.gcd d),
    rw [mul_comm, ← nat.mul_div_assoc _ (nat.gcd_dvd_left _ _),
        mul_comm, h, nat.mul_div_assoc _ (nat.gcd_dvd_right _ _), mul_comm] }
end

@[simp] theorem div_mk_div_cancel_left {a b c : ℤ} (c0 : c ≠ 0) :
  (a * c) /. (b * c) = a /. b :=
begin
  by_cases b0 : b = 0, { subst b0, simp },
  apply (mk_eq (mul_ne_zero b0 c0) b0).2, simp [mul_comm, mul_assoc]
end

theorem num_denom : ∀ a : ℚ, a = a.num /. a.denom
| ⟨n, d, h, (c:_=1)⟩ := show _ = mk_nat n d,
  by simp [mk_nat, ne_of_gt h, mk_pnat, c]

theorem num_denom' (n d h c) : (⟨n, d, h, c⟩ : ℚ) = n /. d := num_denom _

@[elab_as_eliminator] theorem {u} num_denom_cases_on {C : ℚ → Sort u}
   : ∀ (a : ℚ) (H : ∀ n d, d > 0 → (int.nat_abs n).coprime d → C (n /. d)), C a
| ⟨n, d, h, c⟩ H := by rw num_denom'; exact H n d h c

@[elab_as_eliminator] theorem {u} num_denom_cases_on' {C : ℚ → Sort u}
   (a : ℚ) (H : ∀ (n:ℤ) (d:ℕ), d ≠ 0 → C (n /. d)) : C a :=
num_denom_cases_on a $ λ n d h c,
H n d $ ne_of_gt h

theorem num_dvd (a) {b : ℤ} (b0 : b ≠ 0) : (a /. b).num ∣ a :=
begin
  cases e : a /. b with n d h c,
  rw [rat.num_denom', rat.mk_eq b0
    (ne_of_gt (int.coe_nat_pos.2 h))] at e,
  refine (int.nat_abs_dvd.1 $ int.dvd_nat_abs.1 $ int.coe_nat_dvd.2 $
    c.dvd_of_dvd_mul_right _),
  have := congr_arg int.nat_abs e,
  simp [int.nat_abs_mul, int.nat_abs_of_nat] at this, simp [this]
end

theorem denom_dvd (a b : ℤ) : ((a /. b).denom : ℤ) ∣ b :=
begin
  by_cases b0 : b = 0, {simp [b0]},
  cases e : a /. b with n d h c,
  rw [num_denom', mk_eq b0 (ne_of_gt (int.coe_nat_pos.2 h))] at e,
  refine (int.dvd_nat_abs.1 $ int.coe_nat_dvd.2 $ c.symm.dvd_of_dvd_mul_left _),
  rw [← int.nat_abs_mul, ← int.coe_nat_dvd, int.dvd_nat_abs, ← e], simp
end

protected def add : ℚ → ℚ → ℚ
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := mk_pnat (n₁ * d₂ + n₂ * d₁) ⟨d₁ * d₂, mul_pos h₁ h₂⟩

instance : has_add ℚ := ⟨rat.add⟩

theorem lift_binop_eq (f : ℚ → ℚ → ℚ) (f₁ : ℤ → ℤ → ℤ → ℤ → ℤ) (f₂ : ℤ → ℤ → ℤ → ℤ → ℤ)
  (fv : ∀ {n₁ d₁ h₁ c₁ n₂ d₂ h₂ c₂},
    f ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ = f₁ n₁ d₁ n₂ d₂ /. f₂ n₁ d₁ n₂ d₂)
  (f0 : ∀ {n₁ d₁ n₂ d₂} (d₁0 : d₁ ≠ 0) (d₂0 : d₂ ≠ 0), f₂ n₁ d₁ n₂ d₂ ≠ 0)
  (a b c d : ℤ) (b0 : b ≠ 0) (d0 : d ≠ 0)
  (H : ∀ {n₁ d₁ n₂ d₂} (h₁ : a * d₁ = n₁ * b) (h₂ : c * d₂ = n₂ * d),
       f₁ n₁ d₁ n₂ d₂ * f₂ a b c d = f₁ a b c d * f₂ n₁ d₁ n₂ d₂) :
  f (a /. b) (c /. d) = f₁ a b c d /. f₂ a b c d :=
begin
  generalize ha : a /. b = x, cases x with n₁ d₁ h₁ c₁, rw num_denom' at ha,
  generalize hc : c /. d = x, cases x with n₂ d₂ h₂ c₂, rw num_denom' at hc,
  rw fv,
  have d₁0 := ne_of_gt (int.coe_nat_lt.2 h₁),
  have d₂0 := ne_of_gt (int.coe_nat_lt.2 h₂),
  exact (mk_eq (f0 d₁0 d₂0) (f0 b0 d0)).2 (H ((mk_eq b0 d₁0).1 ha) ((mk_eq d0 d₂0).1 hc))
end

@[simp] theorem add_def {a b c d : ℤ} (b0 : b ≠ 0) (d0 : d ≠ 0) :
  a /. b + c /. d = (a * d + c * b) /. (b * d) :=
begin
  apply lift_binop_eq rat.add; intros; try {assumption},
  { apply mk_pnat_eq },
  { apply mul_ne_zero d₁0 d₂0 },
  calc (n₁ * d₂ + n₂ * d₁) * (b * d) =
          (n₁ * b) * d₂ * d + (n₂ * d) * (d₁ * b) : by simp [mul_add, mul_comm, mul_left_comm]
    ... = (a * d₁) * d₂ * d + (c * d₂) * (d₁ * b) : by rw [h₁, h₂]
    ... = (a * d + c * b) * (d₁ * d₂)             : by simp [mul_add, mul_comm, mul_left_comm]
end

protected def neg : ℚ → ℚ
| ⟨n, d, h, c⟩ := ⟨-n, d, h, by simp [c]⟩

instance : has_neg ℚ := ⟨rat.neg⟩

@[simp] theorem neg_def {a b : ℤ} : -(a /. b) = -a /. b :=
begin
  by_cases b0 :  b = 0, { subst b0, simp, refl },
  generalize ha : a /. b = x, cases x with n₁ d₁ h₁ c₁, rw num_denom' at ha,
  show rat.mk' _ _ _ _ = _, rw num_denom',
  have d0 := ne_of_gt (int.coe_nat_lt.2 h₁),
  apply (mk_eq d0 b0).2, have h₁ := (mk_eq b0 d0).1 ha,
  simp only [neg_mul_eq_neg_mul_symm, congr_arg has_neg.neg h₁]
end

protected def mul : ℚ → ℚ → ℚ
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := mk_pnat (n₁ * n₂) ⟨d₁ * d₂, mul_pos h₁ h₂⟩

instance : has_mul ℚ := ⟨rat.mul⟩

@[simp] theorem mul_def {a b c d : ℤ} (b0 : b ≠ 0) (d0 : d ≠ 0) :
  (a /. b) * (c /. d) = (a * c) /. (b * d) :=
begin
  apply lift_binop_eq rat.mul; intros; try {assumption},
  { apply mk_pnat_eq },
  { apply mul_ne_zero d₁0 d₂0 },
  cc
end

protected def inv : ℚ → ℚ
| ⟨(n+1:ℕ), d, h, c⟩ := ⟨d, n+1, n.succ_pos, c.symm⟩
| ⟨0, d, h, c⟩ := 0
| ⟨-[1+ n], d, h, c⟩ := ⟨-d, n+1, n.succ_pos, nat.coprime.symm $ by simp; exact c⟩

instance : has_inv ℚ := ⟨rat.inv⟩

@[simp] theorem inv_def {a b : ℤ} : (a /. b)⁻¹ = b /. a :=
begin
  by_cases a0 : a = 0, { subst a0, simp, refl },
  by_cases b0 : b = 0, { subst b0, simp, refl },
  generalize ha : a /. b = x, cases x with n d h c, rw num_denom' at ha,
  refine eq.trans (_ : rat.inv ⟨n, d, h, c⟩ = d /. n) _,
  { cases n with n; [cases n with n, skip],
    { refl },
    { change int.of_nat n.succ with (n+1:ℕ),
      unfold rat.inv, rw num_denom' },
    { unfold rat.inv, rw num_denom', refl } },
  have n0 : n ≠ 0,
  { refine mt (λ (n0 : n = 0), _) a0,
    subst n0, simp at ha,
    exact (mk_eq_zero b0).1 ha },
  have d0 := ne_of_gt (int.coe_nat_lt.2 h),
  have ha := (mk_eq b0 d0).1 ha,
  apply (mk_eq n0 a0).2,
  cc
end

variables (a b c : ℚ)

protected theorem add_zero : a + 0 = a :=
num_denom_cases_on' a $ λ n d h,
by rw [← zero_mk d]; simp [h, -zero_mk]

protected theorem zero_add : 0 + a = a :=
num_denom_cases_on' a $ λ n d h,
by rw [← zero_mk d]; simp [h, -zero_mk]

protected theorem add_comm : a + b = b + a :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
by simp [h₁, h₂, mul_comm]

protected theorem add_assoc : a + b + c = a + (b + c) :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
num_denom_cases_on' c $ λ n₃ d₃ h₃,
by simp [h₁, h₂, h₃, mul_ne_zero, mul_add, mul_comm, mul_left_comm, add_left_comm]

protected theorem add_left_neg : -a + a = 0 :=
num_denom_cases_on' a $ λ n d h,
by simp [h]

protected theorem mul_one : a * 1 = a :=
num_denom_cases_on' a $ λ n d h,
by change (1:ℚ) with 1 /. 1; simp [h]

protected theorem one_mul : 1 * a = a :=
num_denom_cases_on' a $ λ n d h,
by change (1:ℚ) with 1 /. 1; simp [h]

protected theorem mul_comm : a * b = b * a :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
by simp [h₁, h₂, mul_comm]

protected theorem mul_assoc : a * b * c = a * (b * c) :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
num_denom_cases_on' c $ λ n₃ d₃ h₃,
by simp [h₁, h₂, h₃, mul_ne_zero, mul_comm, mul_left_comm]

protected theorem add_mul : (a + b) * c = a * c + b * c :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
num_denom_cases_on' c $ λ n₃ d₃ h₃,
by simp [h₁, h₂, h₃, mul_ne_zero];
   refine (div_mk_div_cancel_left (int.coe_nat_ne_zero.2 h₃)).symm.trans _;
   simp [mul_add, mul_comm, mul_assoc, mul_left_comm]

protected theorem mul_add : a * (b + c) = a * b + a * c :=
by rw [rat.mul_comm, rat.add_mul, rat.mul_comm, rat.mul_comm c a]

protected theorem zero_ne_one : 0 ≠ (1:ℚ) :=
mt (λ (h : 0 = 1 /. 1), (mk_eq_zero one_ne_zero).1 h.symm) one_ne_zero

protected theorem mul_inv_cancel : a ≠ 0 → a * a⁻¹ = 1 :=
num_denom_cases_on' a $ λ n d h a0,
have n0 : n ≠ 0, from mt (by intro e; subst e; simp) a0,
by simp [h, n0, mul_comm]; exact
eq.trans (by simp) (@div_mk_div_cancel_left 1 1 _ n0)

protected theorem inv_mul_cancel (h : a ≠ 0) : a⁻¹ * a = 1 :=
eq.trans (rat.mul_comm _ _) (rat.mul_inv_cancel _ h)

instance : decidable_eq ℚ := by tactic.mk_dec_eq_instance

instance : discrete_field ℚ :=
{ zero             := 0,
  add              := rat.add,
  neg              := rat.neg,
  one              := 1,
  mul              := rat.mul,
  inv              := rat.inv,
  zero_add         := rat.zero_add,
  add_zero         := rat.add_zero,
  add_comm         := rat.add_comm,
  add_assoc        := rat.add_assoc,
  add_left_neg     := rat.add_left_neg,
  mul_one          := rat.mul_one,
  one_mul          := rat.one_mul,
  mul_comm         := rat.mul_comm,
  mul_assoc        := rat.mul_assoc,
  left_distrib     := rat.mul_add,
  right_distrib    := rat.add_mul,
  zero_ne_one      := rat.zero_ne_one,
  mul_inv_cancel   := rat.mul_inv_cancel,
  inv_mul_cancel   := rat.inv_mul_cancel,
  has_decidable_eq := rat.decidable_eq,
  inv_zero         := rfl }

/- Extra instances to short-circuit type class resolution -/
instance : field ℚ              := by apply_instance
instance : division_ring ℚ      := by apply_instance
instance : integral_domain ℚ    := by apply_instance
-- TODO(Mario): this instance slows down data.real.basic
--instance : domain ℚ           := by apply_instance
instance : nonzero_comm_ring ℚ  := by apply_instance
instance : comm_ring ℚ          := by apply_instance
--instance : ring ℚ             := by apply_instance
instance : comm_semiring ℚ      := by apply_instance
instance : semiring ℚ           := by apply_instance
instance : add_comm_group ℚ     := by apply_instance
instance : add_group ℚ          := by apply_instance
instance : add_comm_monoid ℚ    := by apply_instance
instance : add_monoid ℚ         := by apply_instance
instance : add_left_cancel_semigroup ℚ := by apply_instance
instance : add_right_cancel_semigroup ℚ := by apply_instance
instance : add_comm_semigroup ℚ := by apply_instance
instance : add_semigroup ℚ      := by apply_instance
instance : comm_monoid ℚ        := by apply_instance
instance : monoid ℚ             := by apply_instance
instance : comm_semigroup ℚ     := by apply_instance
instance : semigroup ℚ          := by apply_instance

theorem sub_def {a b c d : ℤ} (b0 : b ≠ 0) (d0 : d ≠ 0) :
  a /. b - c /. d = (a * d - c * b) /. (b * d) :=
by simp [b0, d0]

protected def nonneg : ℚ → Prop
| ⟨n, d, h, c⟩ := n ≥ 0

@[simp] theorem mk_nonneg (a : ℤ) {b : ℤ} (h : b > 0) : (a /. b).nonneg ↔ a ≥ 0 :=
begin
  generalize ha : a /. b = x, cases x with n₁ d₁ h₁ c₁, rw num_denom' at ha,
  simp [rat.nonneg],
  have d0 := int.coe_nat_lt.2 h₁,
  have := (mk_eq (ne_of_gt h) (ne_of_gt d0)).1 ha,
  constructor; intro h₂,
  { apply nonneg_of_mul_nonneg_right _ d0,
    rw this, exact mul_nonneg h₂ (le_of_lt h) },
  { apply nonneg_of_mul_nonneg_right _ h,
    rw ← this, exact mul_nonneg h₂ (int.coe_zero_le _) },
end

protected def nonneg_add {a b} : rat.nonneg a → rat.nonneg b → rat.nonneg (a + b) :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
begin
  have d₁0 : (d₁:ℤ) > 0 := int.coe_nat_pos.2 (nat.pos_of_ne_zero h₁),
  have d₂0 : (d₂:ℤ) > 0 := int.coe_nat_pos.2 (nat.pos_of_ne_zero h₂),
  simp [d₁0, d₂0, h₁, h₂, mul_pos d₁0 d₂0],
  intros n₁0 n₂0,
  apply add_nonneg; apply mul_nonneg; {assumption <|> apply int.coe_zero_le}
end

protected def nonneg_mul {a b} : rat.nonneg a → rat.nonneg b → rat.nonneg (a * b) :=
num_denom_cases_on' a $ λ n₁ d₁ h₁,
num_denom_cases_on' b $ λ n₂ d₂ h₂,
begin
  have d₁0 : (d₁:ℤ) > 0 := int.coe_nat_pos.2 (nat.pos_of_ne_zero h₁),
  have d₂0 : (d₂:ℤ) > 0 := int.coe_nat_pos.2 (nat.pos_of_ne_zero h₂),
  simp [d₁0, d₂0, h₁, h₂, mul_pos d₁0 d₂0],
  exact mul_nonneg
end

protected def nonneg_antisymm {a} : rat.nonneg a → rat.nonneg (-a) → a = 0 :=
num_denom_cases_on' a $ λ n d h,
begin
  have d0 : (d:ℤ) > 0 := int.coe_nat_pos.2 (nat.pos_of_ne_zero h),
  simp [d0, h],
  exact λ h₁ h₂, le_antisymm (nonpos_of_neg_nonneg h₂) h₁
end

protected def nonneg_total : rat.nonneg a ∨ rat.nonneg (-a) :=
by cases a with n; exact
or.imp_right neg_nonneg_of_nonpos (le_total 0 n)

instance decidable_nonneg : decidable (rat.nonneg a) :=
by cases a; unfold rat.nonneg; apply_instance

protected def le (a b : ℚ) := rat.nonneg (b - a)

instance : has_le ℚ := ⟨rat.le⟩

instance decidable_le : decidable_rel ((≤) : ℚ → ℚ → Prop)
| a b := show decidable (rat.nonneg (b - a)), by apply_instance

protected theorem le_def {a b c d : ℤ} (b0 : b > 0) (d0 : d > 0) :
  a /. b ≤ c /. d ↔ a * d ≤ c * b :=
show rat.nonneg _ ↔ _,
by simpa [ne_of_gt b0, ne_of_gt d0, mul_pos b0 d0, mul_comm]
   using @sub_nonneg _ _ (b * c) (a * d)

protected theorem le_refl : a ≤ a :=
show rat.nonneg (a - a), by rw sub_self; exact le_refl (0 : ℤ)

protected theorem le_total : a ≤ b ∨ b ≤ a :=
by have := rat.nonneg_total (b - a); rwa neg_sub at this

protected theorem le_antisymm {a b : ℚ} (hab : a ≤ b) (hba : b ≤ a) : a = b :=
by have := eq_neg_of_add_eq_zero (rat.nonneg_antisymm hba $ by simpa);
   rwa neg_neg at this

protected theorem le_trans {a b c : ℚ} (hab : a ≤ b) (hbc : b ≤ c) : a ≤ c :=
have rat.nonneg (b - a + (c - b)), from rat.nonneg_add hab hbc,
by simpa

instance : decidable_linear_order ℚ :=
{ le              := rat.le,
  le_refl         := rat.le_refl,
  le_trans        := @rat.le_trans,
  le_antisymm     := @rat.le_antisymm,
  le_total        := rat.le_total,
  decidable_eq    := by apply_instance,
  decidable_le    := assume a b, rat.decidable_nonneg (b - a) }

/- Extra instances to short-circuit type class resolution -/
instance : has_lt ℚ                  := by apply_instance
instance : lattice.distrib_lattice ℚ := by apply_instance
instance : lattice.lattice ℚ         := by apply_instance
instance : lattice.semilattice_inf ℚ := by apply_instance
instance : lattice.semilattice_sup ℚ := by apply_instance
instance : lattice.has_inf ℚ         := by apply_instance
instance : lattice.has_sup ℚ         := by apply_instance
instance : linear_order ℚ            := by apply_instance
instance : partial_order ℚ           := by apply_instance
instance : preorder ℚ                := by apply_instance

theorem nonneg_iff_zero_le {a} : rat.nonneg a ↔ 0 ≤ a :=
show rat.nonneg a ↔ rat.nonneg (a - 0), by simp

theorem num_nonneg_iff_zero_le : ∀ {a : ℚ}, 0 ≤ a.num ↔ 0 ≤ a
| ⟨n, d, h, c⟩ := @nonneg_iff_zero_le ⟨n, d, h, c⟩

theorem mk_le {a b c d : ℤ} (h₁ : b > 0) (h₂ : d > 0) :
  a /. b ≤ c /. d ↔ a * d ≤ c * b :=
by conv in (_ ≤ _) {
  simp only [(≤), rat.le],
  rw [sub_def (ne_of_gt h₂) (ne_of_gt h₁),
      mk_nonneg _ (mul_pos h₂ h₁), ge, sub_nonneg] }

protected theorem add_le_add_left {a b c : ℚ} : c + a ≤ c + b ↔ a ≤ b :=
by unfold has_le.le rat.le; rw add_sub_add_left_eq_sub

protected theorem mul_nonneg {a b : ℚ} (ha : 0 ≤ a) (hb : 0 ≤ b) : 0 ≤ a * b :=
by rw ← nonneg_iff_zero_le at ha hb ⊢; exact rat.nonneg_mul ha hb

instance : discrete_linear_ordered_field ℚ :=
{ zero_lt_one     := dec_trivial,
  add_le_add_left := assume a b ab c, rat.add_le_add_left.2 ab,
  add_lt_add_left := assume a b ab c, lt_of_not_ge $ λ ba,
    not_le_of_lt ab $ rat.add_le_add_left.1 ba,
  mul_nonneg      := @rat.mul_nonneg,
  mul_pos         := assume a b ha hb, lt_of_le_of_ne
    (rat.mul_nonneg (le_of_lt ha) (le_of_lt hb))
    (mul_ne_zero (ne_of_lt ha).symm (ne_of_lt hb).symm).symm,
  ..rat.discrete_field, ..rat.decidable_linear_order }

/- Extra instances to short-circuit type class resolution -/
instance : linear_ordered_field ℚ                := by apply_instance
instance : decidable_linear_ordered_comm_ring ℚ  := by apply_instance
instance : linear_ordered_comm_ring ℚ            := by apply_instance
instance : linear_ordered_ring ℚ                 := by apply_instance
instance : ordered_ring ℚ                        := by apply_instance
instance : decidable_linear_ordered_semiring ℚ   := by apply_instance
instance : linear_ordered_semiring ℚ             := by apply_instance
instance : ordered_semiring ℚ                    := by apply_instance
instance : decidable_linear_ordered_comm_group ℚ := by apply_instance
instance : ordered_comm_group ℚ                  := by apply_instance
instance : ordered_cancel_comm_monoid ℚ          := by apply_instance
instance : ordered_comm_monoid ℚ                 := by apply_instance

attribute [irreducible] rat.le

theorem num_pos_iff_pos {a : ℚ} : 0 < a.num ↔ 0 < a :=
lt_iff_lt_of_le_iff_le $
by simpa [(by cases a; refl : (-a).num = -a.num)]
   using @num_nonneg_iff_zero_le (-a)

theorem of_int_eq_mk (z : ℤ) : of_int z = z /. 1 := num_denom' _ _ _ _

theorem coe_int_eq_mk : ∀ z : ℤ, ↑z = z /. 1
| (n : ℕ) := show (n:ℚ) = n /. 1,
  by induction n with n IH n; simp [*, show (1:ℚ) = 1 /. 1, from rfl]
| -[1+ n] := show (-(n + 1) : ℚ) = -[1+ n] /. 1, begin
  induction n with n IH, {refl},
  show -(n + 1 + 1 : ℚ) = -[1+ n.succ] /. 1,
  rw [neg_add, IH],
  simpa [show -1 = (-1) /. 1, from rfl]
end

theorem coe_int_eq_of_int (z : ℤ) : ↑z = of_int z :=
(coe_int_eq_mk z).trans (of_int_eq_mk z).symm

theorem mk_eq_div (n d : ℤ) : n /. d = (n / d : ℚ) :=
begin
  by_cases d0 : d = 0, {simp [d0, div_zero]},
  rw [division_def, coe_int_eq_mk, coe_int_eq_mk, inv_def,
      mul_def one_ne_zero d0, one_mul, mul_one]
end

/-- `floor q` is the largest integer `z` such that `z ≤ q` -/
def floor : ℚ → ℤ
| ⟨n, d, h, c⟩ := n / d

theorem le_floor {z : ℤ} : ∀ {r : ℚ}, z ≤ floor r ↔ (z : ℚ) ≤ r
| ⟨n, d, h, c⟩ := begin
  simp [floor],
  rw [num_denom'],
  have h' := int.coe_nat_lt.2 h,
  conv { to_rhs,
    rw [coe_int_eq_mk, mk_le zero_lt_one h', mul_one] },
  exact int.le_div_iff_mul_le h'
end

theorem floor_lt {r : ℚ} {z : ℤ} : floor r < z ↔ r < z :=
lt_iff_lt_of_le_iff_le le_floor

theorem floor_le (r : ℚ) : (floor r : ℚ) ≤ r :=
le_floor.1 (le_refl _)

theorem lt_succ_floor (r : ℚ) : r < (floor r).succ :=
floor_lt.1 $ int.lt_succ_self _

@[simp] theorem floor_coe (z : ℤ) : floor z = z :=
eq_of_forall_le_iff $ λ a, by rw [le_floor, int.cast_le]

theorem floor_mono {a b : ℚ} (h : a ≤ b) : floor a ≤ floor b :=
le_floor.2 (le_trans (floor_le _) h)

@[simp] theorem floor_add_int (r : ℚ) (z : ℤ) : floor (r + z) = floor r + z :=
eq_of_forall_le_iff $ λ a, by rw [le_floor,
  ← sub_le_iff_le_add, ← sub_le_iff_le_add, le_floor, int.cast_sub]

theorem floor_sub_int (r : ℚ) (z : ℤ) : floor (r - z) = floor r - z :=
eq.trans (by rw [int.cast_neg]; refl) (floor_add_int _ _)

/-- `ceil q` is the smallest integer `z` such that `q ≤ z` -/
def ceil (r : ℚ) : ℤ :=
-(floor (-r))

theorem ceil_le {z : ℤ} {r : ℚ} : ceil r ≤ z ↔ r ≤ z :=
by rw [ceil, neg_le, le_floor, int.cast_neg, neg_le_neg_iff]

theorem le_ceil (r : ℚ) : r ≤ ceil r :=
ceil_le.1 (le_refl _)

@[simp] theorem ceil_coe (z : ℤ) : ceil z = z :=
by rw [ceil, ← int.cast_neg, floor_coe, neg_neg]

theorem ceil_mono {a b : ℚ} (h : a ≤ b) : ceil a ≤ ceil b :=
ceil_le.2 (le_trans h (le_ceil _))

@[simp] theorem ceil_add_int (r : ℚ) (z : ℤ) : ceil (r + z) = ceil r + z :=
by rw [ceil, neg_add', floor_sub_int, neg_sub, sub_eq_neg_add]; refl

theorem ceil_sub_int (r : ℚ) (z : ℤ) : ceil (r - z) = ceil r - z :=
eq.trans (by rw [int.cast_neg]; refl) (ceil_add_int _ _)

/- cast (injection into fields) -/

section cast
variables {α : Type*}

section
variables [division_ring α]

/-- Construct the canonical injection from `ℚ` into an arbitrary
  division ring. If the field has positive characteristic `p`,
  we define `1 / p = 1 / 0 = 0` for consistency with our
  division by zero convention. -/
protected def cast : ℚ → α
| ⟨n, d, h, c⟩ := n / d

@[priority 0] instance cast_coe : has_coe ℚ α := ⟨rat.cast⟩

@[simp] theorem cast_of_int (n : ℤ) : (of_int n : α) = n :=
show (n / (1:ℕ) : α) = n, by rw [nat.cast_one, div_one]

@[simp] theorem cast_coe_int (n : ℤ) : ((n : ℚ) : α) = n :=
by rw [coe_int_eq_of_int, cast_of_int]

@[simp] theorem coe_int_num (n : ℤ) : (n : ℚ).num = n :=
by rw coe_int_eq_of_int; refl

@[simp] theorem coe_int_denom (n : ℤ) : (n : ℚ).denom = 1 :=
by rw coe_int_eq_of_int; refl

@[simp] theorem coe_nat_num (n : ℕ) : (n : ℚ).num = n :=
by rw [← int.cast_coe_nat, coe_int_num]

@[simp] theorem coe_nat_denom (n : ℕ) : (n : ℚ).denom = 1 :=
by rw [← int.cast_coe_nat, coe_int_denom]

@[simp] theorem cast_coe_nat (n : ℕ) : ((n : ℚ) : α) = n := cast_coe_int n

@[simp] theorem cast_zero : ((0 : ℚ) : α) = 0 :=
(cast_of_int _).trans int.cast_zero

@[simp] theorem cast_one : ((1 : ℚ) : α) = 1 :=
(cast_of_int _).trans int.cast_one

theorem mul_cast_comm (a : α) :
  ∀ (n : ℚ), (n.denom : α) ≠ 0 → a * n = n * a
| ⟨n, d, h, c⟩ h₂ := show a * (n * d⁻¹) = n * d⁻¹ * a,
  by rw [← mul_assoc, int.mul_cast_comm, mul_assoc, mul_assoc,
         ← show (d:α)⁻¹ * a = a * d⁻¹, from
           division_ring.inv_comm_of_comm h₂ (int.mul_cast_comm a d).symm]

theorem cast_mk_of_ne_zero (a b : ℤ)
  (b0 : (b:α) ≠ 0) : (a /. b : α) = a / b :=
begin
  have b0' : b ≠ 0, { refine mt _ b0, simp {contextual := tt} },
  cases e : a /. b with n d h c,
  have d0 : (d:α) ≠ 0,
  { intro d0,
    have dd := denom_dvd a b,
    cases (show (d:ℤ) ∣ b, by rwa e at dd) with k ke,
    have : (b:α) = (d:α) * (k:α), {rw [ke, int.cast_mul], refl},
    rw [d0, zero_mul] at this, contradiction },
  rw [num_denom'] at e,
  have := congr_arg (coe : ℤ → α) ((mk_eq b0' $ ne_of_gt $ int.coe_nat_pos.2 h).1 e),
  rw [int.cast_mul, int.cast_mul, int.cast_coe_nat] at this,
  symmetry, change (a * b⁻¹ : α) = n / d,
  rw [eq_div_iff_mul_eq _ _ d0, mul_assoc, nat.mul_cast_comm,
      ← mul_assoc, this, mul_assoc, mul_inv_cancel b0, mul_one]
end

theorem cast_add_of_ne_zero : ∀ {m n : ℚ},
  (m.denom : α) ≠ 0 → (n.denom : α) ≠ 0 → ((m + n : ℚ) : α) = m + n
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := λ (d₁0 : (d₁:α) ≠ 0) (d₂0 : (d₂:α) ≠ 0), begin
  have d₁0' : (d₁:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₁0; exact d₁0 rfl),
  have d₂0' : (d₂:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₂0; exact d₂0 rfl),
  rw [num_denom', num_denom', add_def d₁0' d₂0'],
  suffices : (n₁ * (d₂ * (d₂⁻¹ * d₁⁻¹)) +
    n₂ * (d₁ * d₂⁻¹) * d₁⁻¹ : α) = n₁ * d₁⁻¹ + n₂ * d₂⁻¹,
  { rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, cast_mk_of_ne_zero],
    { simpa [division_def, left_distrib, right_distrib, mul_inv_eq,
             d₁0, d₂0, division_ring.mul_ne_zero d₁0 d₂0, mul_assoc] },
    all_goals {simp [d₁0, d₂0, division_ring.mul_ne_zero d₁0 d₂0]} },
  rw [← mul_assoc (d₂:α), mul_inv_cancel d₂0, one_mul,
      ← nat.mul_cast_comm], simp [d₁0, mul_assoc]
end

@[simp] theorem cast_neg : ∀ n, ((-n : ℚ) : α) = -n
| ⟨n, d, h, c⟩ := show (↑-n * d⁻¹ : α) = -(n * d⁻¹),
  by rw [int.cast_neg, neg_mul_eq_neg_mul]

theorem cast_sub_of_ne_zero {m n : ℚ}
  (m0 : (m.denom : α) ≠ 0) (n0 : (n.denom : α) ≠ 0) : ((m - n : ℚ) : α) = m - n :=
have ((-n).denom : α) ≠ 0, by cases n; exact n0,
by simp [m0, this, cast_add_of_ne_zero]

theorem cast_mul_of_ne_zero : ∀ {m n : ℚ},
  (m.denom : α) ≠ 0 → (n.denom : α) ≠ 0 → ((m * n : ℚ) : α) = m * n
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := λ (d₁0 : (d₁:α) ≠ 0) (d₂0 : (d₂:α) ≠ 0), begin
  have d₁0' : (d₁:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₁0; exact d₁0 rfl),
  have d₂0' : (d₂:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₂0; exact d₂0 rfl),
  rw [num_denom', num_denom', mul_def d₁0' d₂0'],
  suffices : (n₁ * ((n₂ * d₂⁻¹) * d₁⁻¹) : α) = n₁ * (d₁⁻¹ * (n₂ * d₂⁻¹)),
  { rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, cast_mk_of_ne_zero],
    { simpa [division_def, mul_inv_eq, d₁0, d₂0, division_ring.mul_ne_zero d₁0 d₂0, mul_assoc] },
    all_goals {simp [d₁0, d₂0, division_ring.mul_ne_zero d₁0 d₂0]} },
  rw [division_ring.inv_comm_of_comm d₁0 (nat.mul_cast_comm _ _).symm]
end

theorem cast_inv_of_ne_zero : ∀ {n : ℚ},
  (n.num : α) ≠ 0 → (n.denom : α) ≠ 0 → ((n⁻¹ : ℚ) : α) = n⁻¹
| ⟨n, d, h, c⟩ := λ (n0 : (n:α) ≠ 0) (d0 : (d:α) ≠ 0), begin
  have n0' : (n:ℤ) ≠ 0 := λ e, by rw e at n0; exact n0 rfl,
  have d0' : (d:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d0; exact d0 rfl),
  rw [num_denom', inv_def],
  rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, inv_div];
  simp [n0, d0]
end

theorem cast_div_of_ne_zero {m n : ℚ} (md : (m.denom : α) ≠ 0)
  (nn : (n.num : α) ≠ 0) (nd : (n.denom : α) ≠ 0) : ((m / n : ℚ) : α) = m / n :=
have (n⁻¹.denom : ℤ) ∣ n.num,
by conv in n⁻¹.denom { rw [num_denom n, inv_def] };
   apply denom_dvd,
have (n⁻¹.denom : α) = 0 → (n.num : α) = 0, from
λ h, let ⟨k, e⟩ := this in
  by have := congr_arg (coe : ℤ → α) e;
     rwa [int.cast_mul, int.cast_coe_nat, h, zero_mul] at this,
by rw [division_def, cast_mul_of_ne_zero md (mt this nn), cast_inv_of_ne_zero nn nd, division_def]

@[simp] theorem cast_inj [char_zero α] : ∀ {m n : ℚ}, (m : α) = n ↔ m = n
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := begin
  refine ⟨λ h, _, congr_arg _⟩,
  have d₁0 : d₁ ≠ 0 := ne_of_gt h₁,
  have d₂0 : d₂ ≠ 0 := ne_of_gt h₂,
  have d₁a : (d₁:α) ≠ 0 := nat.cast_ne_zero.2 d₁0,
  have d₂a : (d₂:α) ≠ 0 := nat.cast_ne_zero.2 d₂0,
  rw [num_denom', num_denom'] at h ⊢,
  rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero] at h; simp [d₁0, d₂0] at h ⊢,
  rwa [eq_div_iff_mul_eq _ _ d₂a, division_def, mul_assoc,
    division_ring.inv_comm_of_comm d₁a (nat.mul_cast_comm _ _),
    ← mul_assoc, ← division_def, eq_comm, eq_div_iff_mul_eq _ _ d₁a, eq_comm,
    ← int.cast_coe_nat, ← int.cast_mul, ← int.cast_coe_nat, ← int.cast_mul,
    int.cast_inj, ← mk_eq (int.coe_nat_ne_zero.2 d₁0) (int.coe_nat_ne_zero.2 d₂0)] at h
end

theorem cast_injective [char_zero α] : function.injective (coe : ℚ → α)
| m n := cast_inj.1

@[simp] theorem cast_eq_zero [char_zero α] {n : ℚ} : (n : α) = 0 ↔ n = 0 :=
by rw [← cast_zero, cast_inj]

@[simp] theorem cast_ne_zero [char_zero α] {n : ℚ} : (n : α) ≠ 0 ↔ n ≠ 0 :=
not_congr cast_eq_zero

theorem eq_cast_of_ne_zero (f : ℚ → α) (H1 : f 1 = 1)
  (Hadd : ∀ x y, f (x + y) = f x + f y)
  (Hmul : ∀ x y, f (x * y) = f x * f y) :
  ∀ n : ℚ, (n.denom : α) ≠ 0 → f n = n
| ⟨n, d, h, c⟩ := λ (h₂ : ((d:ℤ):α) ≠ 0), show _ = (n / (d:ℤ) : α), begin
  rw [num_denom', mk_eq_div, eq_div_iff_mul_eq _ _ h₂],
  have : ∀ n : ℤ, f n = n, { apply int.eq_cast; simp [H1, Hadd] },
  rw [← this, ← this, ← Hmul, div_mul_cancel],
  exact int.cast_ne_zero.2 (int.coe_nat_ne_zero.2 $ ne_of_gt h),
end

theorem eq_cast [char_zero α] (f : ℚ → α) (H1 : f 1 = 1)
  (Hadd : ∀ x y, f (x + y) = f x + f y)
  (Hmul : ∀ x y, f (x * y) = f x * f y) (n : ℚ) : f n = n :=
eq_cast_of_ne_zero _ H1 Hadd Hmul _ $
  nat.cast_ne_zero.2 $ ne_of_gt n.pos

end

theorem cast_mk [discrete_field α] [char_zero α] (a b : ℤ) : ((a /. b) : α) = a / b :=
if b0 : b = 0 then by simp [b0, div_zero]
else cast_mk_of_ne_zero a b (int.cast_ne_zero.2 b0)

@[simp] theorem cast_add [division_ring α] [char_zero α] (m n) : ((m + n : ℚ) : α) = m + n :=
cast_add_of_ne_zero (nat.cast_ne_zero.2 $ ne_of_gt m.pos) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp] theorem cast_sub [division_ring α] [char_zero α] (m n) : ((m - n : ℚ) : α) = m - n :=
cast_sub_of_ne_zero (nat.cast_ne_zero.2 $ ne_of_gt m.pos) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp] theorem cast_mul [division_ring α] [char_zero α] (m n) : ((m * n : ℚ) : α) = m * n :=
cast_mul_of_ne_zero (nat.cast_ne_zero.2 $ ne_of_gt m.pos) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp] theorem cast_inv [discrete_field α] [char_zero α] (n) : ((n⁻¹ : ℚ) : α) = n⁻¹ :=
if n0 : n.num = 0 then
  by simp [show n = 0, by rw [num_denom n, n0]; simp, inv_zero] else
cast_inv_of_ne_zero (int.cast_ne_zero.2 n0) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp] theorem cast_div [discrete_field α] [char_zero α] (m n) : ((m / n : ℚ) : α) = m / n :=
by rw [division_def, cast_mul, cast_inv, division_def]

@[simp] theorem cast_pow [discrete_field α] [char_zero α] (q) (k : ℕ) : ((q ^ k : ℚ) : α) = q ^ k :=
by induction k; simp only [*, cast_one, cast_mul, pow_zero, pow_succ]

@[simp] theorem cast_bit0 [division_ring α] [char_zero α] (n : ℚ) : ((bit0 n : ℚ) : α) = bit0 n := cast_add _ _

@[simp] theorem cast_bit1 [division_ring α] [char_zero α] (n : ℚ) : ((bit1 n : ℚ) : α) = bit1 n :=
by rw [bit1, cast_add, cast_one, cast_bit0]; refl

@[simp] theorem cast_nonneg [linear_ordered_field α] : ∀ {n : ℚ}, 0 ≤ (n : α) ↔ 0 ≤ n
| ⟨n, d, h, c⟩ := show 0 ≤ (n * d⁻¹ : α) ↔ 0 ≤ (⟨n, d, h, c⟩ : ℚ),
  by rw [num_denom', ← nonneg_iff_zero_le, mk_nonneg _ (int.coe_nat_pos.2 h),
    mul_nonneg_iff_right_nonneg_of_pos (@inv_pos α _ _ (nat.cast_pos.2 h)),
    int.cast_nonneg]

@[simp] theorem cast_le [linear_ordered_field α] {m n : ℚ} : (m : α) ≤ n ↔ m ≤ n :=
by rw [← sub_nonneg, ← cast_sub, cast_nonneg, sub_nonneg]

@[simp] theorem cast_lt [linear_ordered_field α] {m n : ℚ} : (m : α) < n ↔ m < n :=
by simpa [-cast_le] using not_congr (@cast_le α _ n m)

@[simp] theorem cast_nonpos [linear_ordered_field α] {n : ℚ} : (n : α) ≤ 0 ↔ n ≤ 0 :=
by rw [← cast_zero, cast_le]

@[simp] theorem cast_pos [linear_ordered_field α] {n : ℚ} : (0 : α) < n ↔ 0 < n :=
by rw [← cast_zero, cast_lt]

@[simp] theorem cast_lt_zero [linear_ordered_field α] {n : ℚ} : (n : α) < 0 ↔ n < 0 :=
by rw [← cast_zero, cast_lt]

@[simp] theorem cast_id : ∀ n : ℚ, ↑n = n
| ⟨n, d, h, c⟩ := show (n / (d : ℤ) : ℚ) = _, by rw [num_denom', mk_eq_div]

@[simp] theorem cast_min [discrete_linear_ordered_field α] {a b : ℚ} : (↑(min a b) : α) = min a b :=
by by_cases a ≤ b; simp [h, min]

@[simp] theorem cast_max [discrete_linear_ordered_field α] {a b : ℚ} : (↑(max a b) : α) = max a b :=
by by_cases a ≤ b; simp [h, max]

@[simp] theorem cast_abs [discrete_linear_ordered_field α] {q : ℚ} : ((abs q : ℚ) : α) = abs q :=
by simp [abs]

end cast

/- nat ceiling -/

/-- `nat_ceil q` is the smallest nonnegative integer `n` with `q ≤ n`.
  It is the same as `ceil q` when `q ≥ 0`, otherwise it is `0`. -/
def nat_ceil (q : ℚ) : ℕ := int.to_nat (ceil q)

theorem nat_ceil_le {q : ℚ} {n : ℕ} : nat_ceil q ≤ n ↔ q ≤ n :=
by rw [nat_ceil, int.to_nat_le, ceil_le]; refl

theorem lt_nat_ceil {q : ℚ} {n : ℕ} : n < nat_ceil q ↔ (n : ℚ) < q :=
not_iff_not.1 $ by rw [not_lt, not_lt, nat_ceil_le]

theorem le_nat_ceil (q : ℚ) : q ≤ nat_ceil q :=
nat_ceil_le.1 (le_refl _)

theorem nat_ceil_mono {q₁ q₂ : ℚ} (h : q₁ ≤ q₂) : nat_ceil q₁ ≤ nat_ceil q₂ :=
nat_ceil_le.2 (le_trans h (le_nat_ceil _))

@[simp] theorem nat_ceil_coe (n : ℕ) : nat_ceil n = n :=
show (ceil (n:ℤ)).to_nat = n, by rw [ceil_coe]; refl

@[simp] theorem nat_ceil_zero : nat_ceil 0 = 0 := nat_ceil_coe 0

theorem nat_ceil_add_nat {q : ℚ} (hq : 0 ≤ q) (n : ℕ) : nat_ceil (q + n) = nat_ceil q + n :=
show int.to_nat (ceil (q + (n:ℤ))) = int.to_nat (ceil q) + n,
by rw [ceil_add_int]; exact
match ceil q, int.eq_coe_of_zero_le (ceil_mono hq) with
| _, ⟨m, rfl⟩ := rfl
end

theorem nat_ceil_lt_add_one {q : ℚ} (hq : q ≥ 0) : ↑(nat_ceil q) < q + 1 :=
lt_nat_ceil.1 $ by rw [
  show nat_ceil (q+1) = nat_ceil q+1, from nat_ceil_add_nat hq 1]; apply nat.lt_succ_self

@[simp] lemma denom_neg_eq_denom : ∀ q : ℚ, (-q).denom = q.denom
| ⟨_, d, _, _⟩ := rfl

@[simp] lemma num_neg_eq_neg_num : ∀ q : ℚ, (-q).num = -(q.num)
| ⟨n, _, _, _⟩ := rfl

@[simp] lemma num_zero : rat.num 0 = 0 := rfl

lemma zero_of_num_zero {q : ℚ} (hq : q.num = 0) : q = 0 :=
have q = q.num /. q.denom, from num_denom _,
by simpa [hq]

lemma zero_iff_num_zero {q : ℚ} : q = 0 ↔ q.num = 0 :=
⟨λ _, by simp *, zero_of_num_zero⟩

lemma num_ne_zero_of_ne_zero {q : ℚ} (h : q ≠ 0) : q.num ≠ 0 :=
assume : q.num = 0,
h $ zero_of_num_zero this

@[simp] lemma num_one : (1 : ℚ).num = 1 := rfl

@[simp] lemma denom_one : (1 : ℚ).denom = 1 := rfl

lemma denom_ne_zero (q : ℚ) : q.denom ≠ 0 :=
ne_of_gt q.pos

lemma mk_num_ne_zero_of_ne_zero {q : ℚ} {n d : ℤ} (hq : q ≠ 0) (hqnd : q = n /. d) : n ≠ 0 :=
assume : n = 0,
hq $ by simpa [this] using hqnd

lemma mk_denom_ne_zero_of_ne_zero {q : ℚ} {n d : ℤ} (hq : q ≠ 0) (hqnd : q = n /. d) : d ≠ 0 :=
assume : d = 0,
hq $ by simpa [this] using hqnd

lemma mk_ne_zero_of_ne_zero {n d : ℤ} (h : n ≠ 0) (hd : d ≠ 0) : n /. d ≠ 0 :=
assume : n /. d = 0,
h $ (mk_eq_zero hd).1 this

lemma mul_num_denom (q r : ℚ) : q * r = (q.num * r.num) /. ↑(q.denom * r.denom) :=
have hq' : (↑q.denom : ℤ) ≠ 0, by have := denom_ne_zero q; simpa,
have hr' : (↑r.denom : ℤ) ≠ 0, by have := denom_ne_zero r; simpa,
suffices (q.num /. ↑q.denom) * (r.num /. ↑r.denom) = (q.num * r.num) /. ↑(q.denom * r.denom),
  by rwa [←num_denom q, ←num_denom r] at this,
by simp [mul_def hq' hr']

lemma div_num_denom (q r : ℚ) : q / r = (q.num * r.denom) /. (q.denom * r.num) :=
if hr : r.num = 0 then
  have hr' : r = 0, from zero_of_num_zero hr,
  by simp *
else calc q / r = q * r⁻¹ : div_eq_mul_inv
            ... = (q.num /. q.denom) * (r.num /. r.denom)⁻¹ : by rw [←num_denom q, ←num_denom r]
            ... = (q.num /. q.denom) * (r.denom /. r.num) : by rw inv_def
            ... = (q.num * r.denom) /. (q.denom * r.num) : mul_def (by simpa using denom_ne_zero q) hr

lemma num_denom_mk {q : ℚ} {n d : ℤ} (hn : n ≠ 0) (hd : d ≠ 0) (qdf : q = n /. d) :
      ∃ c : ℤ, n = c * q.num ∧ d = c * q.denom :=
have hq : q ≠ 0, from
  assume : q = 0,
  hn $ (rat.mk_eq_zero hd).1 (by cc),
have q.num /. q.denom = n /. d, by rwa [←rat.num_denom q],
have q.num * d = n * ↑(q.denom), from (rat.mk_eq (by simp [rat.denom_ne_zero]) hd).1 this,
begin
  existsi n / q.num,
  have hqdn : q.num ∣ n, begin rw qdf, apply rat.num_dvd, assumption end,
  split,
    { rw int.div_mul_cancel hqdn },
    { apply int.eq_mul_div_of_mul_eq_mul_of_dvd_left,
      {apply rat.num_ne_zero_of_ne_zero hq},
      {simp [rat.denom_ne_zero]},
      repeat {assumption} }
end

theorem mk_pnat_num (n : ℤ) (d : ℕ+) :
  (mk_pnat n d).num = n / nat.gcd n.nat_abs d :=
by cases d; refl

theorem mk_pnat_denom (n : ℤ) (d : ℕ+) :
  (mk_pnat n d).denom = d / nat.gcd n.nat_abs d :=
by cases d; refl

theorem mul_num (q₁ q₂ : ℚ) : (q₁ * q₂).num =
  (q₁.num * q₂.num) / nat.gcd (q₁.num * q₂.num).nat_abs (q₁.denom * q₂.denom) :=
by cases q₁; cases q₂; refl

theorem mul_denom (q₁ q₂ : ℚ) : (q₁ * q₂).denom =
  (q₁.denom * q₂.denom) / nat.gcd (q₁.num * q₂.num).nat_abs (q₁.denom * q₂.denom) :=
by cases q₁; cases q₂; refl

theorem mul_self_num (q : ℚ) : (q * q).num = q.num * q.num :=
by rw [mul_num, int.nat_abs_mul, nat.coprime.gcd_eq_one, int.coe_nat_one, int.div_one];
exact (q.cop.mul_right q.cop).mul (q.cop.mul_right q.cop)

theorem mul_self_denom (q : ℚ) : (q * q).denom = q.denom * q.denom :=
by rw [rat.mul_denom, int.nat_abs_mul, nat.coprime.gcd_eq_one, nat.div_one];
exact (q.cop.mul_right q.cop).mul (q.cop.mul_right q.cop)

theorem abs_def (q : ℚ) : abs q = q.num.nat_abs /. q.denom :=
begin
  have hz : (0:ℚ) = 0 /. 1 := rfl,
  cases le_total q 0 with hq hq,
  { rw [abs_of_nonpos hq],
    rw [num_denom q, hz, rat.le_def (int.coe_nat_pos.2 q.pos) zero_lt_one,
        mul_one, zero_mul] at hq,
    rw [int.of_nat_nat_abs_of_nonpos hq, ← neg_def, ← num_denom q] },
  { rw [abs_of_nonneg hq],
    rw [num_denom q, hz, rat.le_def zero_lt_one (int.coe_nat_pos.2 q.pos),
        mul_one, zero_mul] at hq,
    rw [int.nat_abs_of_nonneg hq, ← num_denom q] }
end

lemma add_num_denom (q r : ℚ) : q + r =
  ((q.num * r.denom + q.denom * r.num : ℤ)) /. (↑q.denom * ↑r.denom : ℤ) :=
have hqd : (q.denom : ℤ) ≠ 0, from int.coe_nat_ne_zero_iff_pos.2 q.3,
have hrd : (r.denom : ℤ) ≠ 0, from int.coe_nat_ne_zero_iff_pos.2 r.3,
by conv { to_lhs, rw [rat.num_denom q, rat.num_denom r, rat.add_def hqd hrd] };
  simp [mul_comm]

def sqrt (q : ℚ) : ℚ :=
rat.mk (int.sqrt q.num) (nat.sqrt q.denom)

theorem sqrt_eq (q : ℚ) : rat.sqrt (q*q) = abs q :=
by rw [sqrt, mul_self_num, mul_self_denom,
       int.sqrt_eq, nat.sqrt_eq, abs_def]

theorem exists_mul_self (x : ℚ) :
  (∃ q, q * q = x) ↔ rat.sqrt x * rat.sqrt x = x :=
⟨λ ⟨n, hn⟩, by rw [← hn, sqrt_eq, abs_mul_abs_self],
λ h, ⟨rat.sqrt x, h⟩⟩

theorem sqrt_nonneg (q : ℚ) : 0 ≤ rat.sqrt q :=
nonneg_iff_zero_le.1 $ (mk_nonneg _ $ int.coe_nat_pos.2 $
nat.pos_of_ne_zero $ λ H, nat.pos_iff_ne_zero.1 q.pos $ nat.sqrt_eq_zero.1 H).2 trivial

end rat


/- THE CUBE CATEGORY ON fiITE SETS -/
import .cubes .fi

open cmonad fi nat

universes u v

def cfi (n : ℕ) := cmonad (fi n)

/- Projecting at the i-th dimension -/
-- TODO generalize this to arbitrary elementary surjections?
def cproj (b : bool) : Π {m}, fi (m + 1) → cmor (fi (m + 1)) (fi m)
| m       fi.zero fi.zero := b
| (m + 1) fi.zero (suc j) := dim j
| (m + 1) (suc i) fi.zero := dim fi.zero
| (m + 1) (suc i) (suc j) := do x <- cproj i j,
                                dim $ suc x

--TODO simplify this
theorem cproj_self (b : bool) {m} (i : fi (m + 1)) : cproj b i i = b :=
begin
  cases i with n n i,
  { cases m, repeat {reflexivity} },
  { induction i with n n i ih_i, simp[cproj],
    { cases n, repeat {simp[cproj], rw cbind_bool} },
    { simp[cproj], rw [ih_i, cbind_bool] } }
end

def cdeg {m} (i : fi (m + 1)) : cmor (fi m) (fi (m + 1)) := dim ∘ deg i

theorem cproj_cdeg {m} {b : bool} (i : fi (m + 1)) : cproj b i ∘c cdeg i = dim :=
begin
  apply funext, intro j, change (_ ∘c dim) _ = _, rw cid_right,
  cases i with n n i,
  { induction j, reflexivity, reflexivity },
  { induction j with n n j ih_j, reflexivity,
    simp[deg, cproj], cases i,
    { cases j, reflexivity, reflexivity },
    { rw ih_j, reflexivity } }
end

/- Lift a cubical morphism by 1 -/
-- TODO generalize this
def clift {n k} (f : cmor (fi n) (fi k)) : cmor (fi (succ n)) (fi (succ k))
| fi.zero := dim fi.zero
| (suc i) := do x <- f i,
                dim $ suc x

theorem clift_suc {n k} (f : cmor (fi n) (fi k)) (i : fi n) :
    clift f (suc i) = (f i >>= (dim ∘ suc)) :=
by reflexivity

theorem clift_dim {n : ℕ} : clift (@dim (fi n)) = dim :=
begin
  apply funext, intro i, cases i, repeat {reflexivity},
end

theorem clift_ccomp {m n o : ℕ} (f : cmor (fi m) (fi n)) (g : cmor (fi n) (fi o)) :
  clift (g ∘c f) = (clift g) ∘c (clift f) :=
begin
  apply funext, intro i, cases i with n n i, reflexivity,
  simp[clift,ccomp], cases (f i) with j, reflexivity, reflexivity,
  change (g j >>= _) = clift _ _, rw clift_suc,
end

--TODO generalize to arbitrary projections
theorem cproj_clift {m n : ℕ} (f : cmor (fi m) (fi n)) (b : bool) :
  (cproj b fi.zero) ∘c (clift f) = f ∘c (cproj b fi.zero) :=
begin
  apply funext, intro i, cases i with n n i,
  simp[ccomp, clift], rw [cproj_self, cbind_bool, cbind_dim, cproj_self],
  { cases m, simp[ccomp], cases i,
    simp[ccomp, cproj, clift], rw [cbind_dim, cbind_assoc],
    cases f i with j, reflexivity, reflexivity, rw cbind_dim, rw cbind_dim,
    cases n, cases j, reflexivity }
end

def zero_deg {m : ℕ} : cmor (fi 0) (fi m) := λ i, match i with
                                                  end

theorem zero_deg_right {m n : ℕ} (f : cmor (fi m) (fi n)) :
  f ∘c zero_deg = zero_deg :=
begin
  apply funext, intro i, cases i
end