import topology.algebra.ring
import ring_theory.algebra
import ring_theory.ideal_operations

import tactic.abel tactic.chain

import for_mathlib.submodule
import for_mathlib.open_embeddings
import for_mathlib.rings
import topology.algebra.open_subgroup

local attribute [instance] set.pointwise_mul_semiring
local attribute [instance] set.smul_set_action

/--A topological group is non-archimedean if every neighborhood of 1 contains an open subgroup.-/
definition topological_group.nonarchimedean (G : Type*)
  [group G] [topological_space G] [topological_group G] : Prop :=
∀ U ∈ nhds (1 : G), ∃ V : open_subgroup G, (V : set G) ⊆ U

/--A topological additive group is non-archimedean if every neighborhood of 0 contains an
   open subgroup.-/
definition topological_add_group.nonarchimedean (G : Type*)
  [add_group G] [topological_space G] [topological_add_group G] : Prop :=
∀ U ∈ nhds (0 : G), ∃ V : open_add_subgroup G, (V : set G) ⊆ U

attribute [to_additive topological_add_group.nonarchimedean] topological_group.nonarchimedean

namespace topological_group
open function (hiding embedding) set
variables {G₀ : Type*} [group G₀] [topological_space G₀] [topological_group G₀]
variables {G : Type*} [group G] [topological_space G] [topological_group G]
variables (f : G₀ → G) [is_group_hom f]

@[to_additive topological_add_group.nonarchimedean_of_nonarchimedean_open_embedding]
lemma nonarchimedean_of_nonarchimedean_open_embedding
  (emb : open_embedding f) (h : nonarchimedean G₀) :
  nonarchimedean G :=
begin
  intros U hU,
  cases h (f ⁻¹' U) _ with V hV,
  { refine ⟨⟨f '' V, _, _⟩, _⟩,
    { exact emb.is_open_map _ V.is_open },
    { apply_instance },
    { rwa ← set.image_subset_iff at hV } },
  { apply emb.continuous.tendsto,
    rwa is_group_hom.map_one f }
end

end topological_group

namespace topological_add_group
namespace nonarchimedean
open topological_ring
variables {R : Type*} [ring R] [topological_space R] [topological_ring R]
variables {S : Type*} [ring S] [topological_space S] [topological_ring S]

lemma left_mul_subset (h : nonarchimedean R) (U : open_add_subgroup R) (r : R) :
  ∃ V : open_add_subgroup R, r • (V : set R) ⊆ U :=
begin
  let V : open_add_subgroup R := ⟨_, _, _⟩,
  { use V,
    intros x hx,
    rw set.mem_smul_set at hx,
    rcases hx with ⟨y, hy, rfl⟩,
    exact hy },
  { exact continuous_const.mul continuous_id U.val U.is_open },
  { refine {..}; intros,
    { show r * 0 ∈ U, simpa using U.zero_mem },
    { show r * (_ + _) ∈ U, rw left_distrib, apply U.add_mem, assumption' },
    { show r * _ ∈ U, rw mul_neg_eq_neg_mul_symm, apply U.neg_mem, assumption } },
end

lemma prod_subset (hR : nonarchimedean R) (hS : nonarchimedean S) :
  ∀ U ∈ nhds (0 : R × S), ∃ (V : open_add_subgroup R) (W : open_add_subgroup S),
    (V : set R).prod (W : set S) ⊆ U :=
begin
  intros U hU,
  erw [nhds_prod_eq, filter.mem_prod_iff] at hU,
  rcases hU with ⟨U₁, hU₁, U₂, hU₂, h⟩,
  cases hR _ hU₁ with V hV,
  cases hS _ hU₂ with W hW,
  use [V, W, set.subset.trans (set.prod_mono hV hW) h]
end

lemma prod_self_subset (hR : nonarchimedean R) :
  ∀ U ∈ nhds (0 : R × R), ∃ (V : open_add_subgroup R), (V : set R).prod (V : set R) ⊆ U :=
begin
  intros U hU,
  rcases prod_subset hR hR U hU with ⟨V, W, h⟩,
  use V ⊓ W,
  refine set.subset.trans (set.prod_mono _ _) ‹_›; simp
end

lemma prod (hR : nonarchimedean R) (hS : nonarchimedean S) :
  nonarchimedean (R × S) :=
begin
  intros U hU,
  rcases prod_subset hR hS U hU with ⟨V, W, h⟩,
  refine ⟨V.sum W, ‹_›⟩
end

lemma mul_subset (h : nonarchimedean R) (U : open_add_subgroup R) :
  ∃ V : open_add_subgroup R, (V : set R) * V ⊆ U :=
begin
  rcases prod_self_subset h _ _ with ⟨V, H⟩,
  use V,
  work_on_goal 0 {
    rwa [set.pointwise_mul_eq_image, set.image_subset_iff] },
  apply mem_nhds_sets (continuous_mul _ U.is_open),
  simpa only [prod.fst_zero, prod.snd_zero, set.mem_preimage, mul_zero] using U.zero_mem
end

end nonarchimedean
end topological_add_group


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri
-/

import geometry.manifold.algebra.smooth_functions
import ring_theory.derivation

/-!

# Derivation bundle

In this file we define the derivations at a point of a manifold on the algebra of smooth fuctions.
Moreover, we define the differential of a function in terms of derivations.

The content of this file is not meant to be regarded as an alternative definition to the current
tangent bundle but rather as a purely algebraic theory that provides a purely algebraic definition
of the Lie algebra for a Lie group.

-/

variables (𝕜 : Type*) [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
(M : Type*) [topological_space M] [charted_space H M] (n : with_top ℕ)

open_locale manifold

-- the following two instances prevent poorly understood type class inference timeout problems
instance smooth_functions_algebra : algebra 𝕜 C^∞⟮I, M; 𝕜⟯ := by apply_instance
instance smooth_functions_tower : is_scalar_tower 𝕜 C^∞⟮I, M; 𝕜⟯ C^∞⟮I, M; 𝕜⟯ := by apply_instance

/-- Type synonym, introduced to put a different `has_scalar` action on `C^n⟮I, M; 𝕜⟯`
which is defined as `f • r = f(x) * r`. -/
@[nolint unused_arguments] def pointed_smooth_map (x : M) := C^n⟮I, M; 𝕜⟯

localized "notation `C^` n `⟮` I `,` M `;` 𝕜 `⟯⟨` x `⟩` :=
  pointed_smooth_map 𝕜 I M n x" in derivation

variables {𝕜 M}

namespace pointed_smooth_map

instance {x : M} : has_coe_to_fun C^∞⟮I, M; 𝕜⟯⟨x⟩ (λ _, M → 𝕜) :=
times_cont_mdiff_map.has_coe_to_fun
instance {x : M} : comm_ring C^∞⟮I, M; 𝕜⟯⟨x⟩ := smooth_map.comm_ring
instance {x : M} : algebra 𝕜 C^∞⟮I, M; 𝕜⟯⟨x⟩ := smooth_map.algebra
instance {x : M} : inhabited C^∞⟮I, M; 𝕜⟯⟨x⟩ := ⟨0⟩
instance {x : M} : algebra C^∞⟮I, M; 𝕜⟯⟨x⟩ C^∞⟮I, M; 𝕜⟯ := algebra.id C^∞⟮I, M; 𝕜⟯
instance {x : M} : is_scalar_tower 𝕜 C^∞⟮I, M; 𝕜⟯⟨x⟩ C^∞⟮I, M; 𝕜⟯ := is_scalar_tower.right

variable {I}

/-- `smooth_map.eval_ring_hom` gives rise to an algebra structure of `C^∞⟮I, M; 𝕜⟯` on `𝕜`. -/
instance eval_algebra {x : M} : algebra C^∞⟮I, M; 𝕜⟯⟨x⟩ 𝕜 :=
(smooth_map.eval_ring_hom x : C^∞⟮I, M; 𝕜⟯⟨x⟩ →+* 𝕜).to_algebra

/-- With the `eval_algebra` algebra structure evaluation is actually an algebra morphism. -/
def eval (x : M) : C^∞⟮I, M; 𝕜⟯ →ₐ[C^∞⟮I, M; 𝕜⟯⟨x⟩] 𝕜 :=
algebra.of_id C^∞⟮I, M; 𝕜⟯⟨x⟩ 𝕜

lemma smul_def (x : M) (f : C^∞⟮I, M; 𝕜⟯⟨x⟩) (k : 𝕜) : f • k = f x * k := rfl

instance (x : M) : is_scalar_tower 𝕜 C^∞⟮I, M; 𝕜⟯⟨x⟩ 𝕜 :=
{ smul_assoc := λ k f h, by { simp only [smul_def, algebra.id.smul_eq_mul, smooth_map.coe_smul,
  pi.smul_apply, mul_assoc]} }

end pointed_smooth_map

open_locale derivation

/-- The derivations at a point of a manifold. Some regard this as a possible definition of the
tangent space -/
@[reducible] def point_derivation (x : M) := derivation 𝕜 (C^∞⟮I, M; 𝕜⟯⟨x⟩) 𝕜

section

variables (I) {M} (X Y : derivation 𝕜 C^∞⟮I, M; 𝕜⟯ C^∞⟮I, M; 𝕜⟯) (f g : C^∞⟮I, M; 𝕜⟯) (r : 𝕜)

/-- Evaluation at a point gives rise to a `C^∞⟮I, M; 𝕜⟯`-linear map between `C^∞⟮I, M; 𝕜⟯` and `𝕜`.
 -/
def smooth_function.eval_at (x : M) : C^∞⟮I, M; 𝕜⟯ →ₗ[C^∞⟮I, M; 𝕜⟯⟨x⟩] 𝕜 :=
(pointed_smooth_map.eval x).to_linear_map

namespace derivation

variable {I}

/-- The evaluation at a point as a linear map. -/
def eval_at (x : M) : (derivation 𝕜 C^∞⟮I, M; 𝕜⟯ C^∞⟮I, M; 𝕜⟯) →ₗ[𝕜] point_derivation I x :=
(smooth_function.eval_at I x).comp_der

lemma eval_at_apply (x : M) : eval_at x X f = (X f) x := rfl

end derivation

variables {I} {E' : Type*} [normed_group E'] [normed_space 𝕜 E']
{H' : Type*} [topological_space H'] {I' : model_with_corners 𝕜 E' H'}
{M' : Type*} [topological_space M'] [charted_space H' M']

/-- The heterogeneous differential as a linear map. Instead of taking a function as an argument this
differential takes `h : f x = y`. It is particularly handy to deal with situations where the points
on where it has to be evaluated are equal but not definitionally equal. -/
def hfdifferential {f : C^∞⟮I, M; I', M'⟯} {x : M} {y : M'} (h : f x = y) :
  point_derivation I x →ₗ[𝕜] point_derivation I' y :=
{ to_fun := λ v, { to_linear_map :=
    { to_fun := λ g, v (g.comp f),
      map_add' := λ g g', by rw [smooth_map.add_comp, derivation.map_add],
      map_smul' := λ k g,
        by simp only [smooth_map.smul_comp, derivation.map_smul, ring_hom.id_apply], },
    leibniz' := λ g g', by simp only [derivation.leibniz, smooth_map.mul_comp,
      pointed_smooth_map.smul_def, times_cont_mdiff_map.comp_apply, h] },
  map_smul' := λ k v, rfl,
  map_add' := λ v w, rfl }

/-- The homogeneous differential as a linear map. -/
def fdifferential (f : C^∞⟮I, M; I', M'⟯) (x : M) :
  point_derivation I x →ₗ[𝕜] point_derivation I' (f x) :=
hfdifferential (rfl : f x = f x)

/- Standard notation for the differential. The abbreviation is `MId`. -/
localized "notation `𝒅` := fdifferential" in manifold

/- Standard notation for the differential. The abbreviation is `MId`. -/
localized "notation `𝒅ₕ` := hfdifferential" in manifold

@[simp] lemma apply_fdifferential (f : C^∞⟮I, M; I', M'⟯) {x : M} (v : point_derivation I x)
  (g : C^∞⟮I', M'; 𝕜⟯) : 𝒅f x v g = v (g.comp f) := rfl

@[simp] lemma apply_hfdifferential {f : C^∞⟮I, M; I', M'⟯} {x : M} {y : M'} (h : f x = y)
  (v : point_derivation I x) (g : C^∞⟮I', M'; 𝕜⟯) : 𝒅ₕh v g = 𝒅f x v g := rfl

variables {E'' : Type*} [normed_group E''] [normed_space 𝕜 E'']
{H'' : Type*} [topological_space H''] {I'' : model_with_corners 𝕜 E'' H''}
{M'' : Type*} [topological_space M''] [charted_space H'' M'']

@[simp] lemma fdifferential_comp (g : C^∞⟮I', M'; I'', M''⟯) (f : C^∞⟮I, M; I', M'⟯) (x : M) :
  𝒅(g.comp f) x = (𝒅g (f x)).comp (𝒅f x) := rfl

end


import tactic
import algebra.group.defs
import data.vector
import data.nat.basic
import data.nat.nth

noncomputable theory

def starStar  (u q j a : ℕ) (b₁ b₂ : fin u.succ) (b₀ : fin b₁.1): Prop :=
-- property the b's should have
    u = b₀.1 + b₁.1 * ((j+1) + a*q + b₂.1 * q*q)
    ∧
    (∃ c: fin b₁.1.succ, b₁.1 = c.1*c.1)
    ∧
    ∀ d: fin b₁.1, d.1 ≠ 1 → d.1 ∣ (b₁.1) →  q ∣ d.1

def βexist (u q j a : ℕ) : Prop := a < q ∧ ∃ b₁ b₂ : fin u.succ, ∃ b₀ : fin b₁.1, starStar u q j a b₁ b₂ b₀

def φβ (u q j a : ℕ) : Prop :=
  (βexist u q j a ∧ ∀ aa: fin a, ¬ βexist u q j aa.1) ∨
  ((∀ aa:fin q, ¬ βexist u q j aa.1) ∧ a = 0)

def stage₁ (s p t z y₀ : ℕ) : Prop :=
φβ t p (2*s) z ∧ φβ t p (2*s+1) y₀

 /-
Example program:
    0 R₀ = R₀ + ∣,
    1 HALT
    t p encodes the sequence 0,0,1,0 (line number 0, R₀=0, line number 1, R₀=0)
 -/
def inc_R0_once (u:fin 1) (u':fin 2) (u₀ u₀' : ℕ) : Prop :=
  -- in general it should depend on u but here u must be 0
  u'.1 = u.1 + 1 ∧ u₀' = u₀ + 1

-- Example program 0 R₀ += ∣, 1 R₀ -= ∣, 2 HALT
def inc_dec_R0 (u:fin 2) (u':fin 3) (u₀ u₀' : ℕ) : Prop :=
  (u.1=0 → u'.1 = u.1 + 1 ∧ u₀' = u₀ + 1)
  ∧
  (u.1=1 → u'.1 = u.1 + 1 ∧ u₀' = u₀ - 1) -- monus

 -- Homework program: 0 R₀ += ∣, 1 PRINT, 2 HALT
def inc_R0_print (u:fin 2) (u':fin 3) (u₀ u₀' : ℕ) : Prop :=
  (u.1=0 → u'.1 = u.1 + 1 ∧ u₀' = u₀ + 1)
  ∧
  (u.1=1 → u'.1 = u.1 + 1 ∧ u₀' = u₀)

def χ_steps (k:ℕ)(program:(fin k)→(fin k.succ)→ℕ→ ℕ→Prop) (t p i:ℕ) : Prop :=
  ∀ u:fin k, ∀ u₀:ℕ, ∀ u':fin k.succ, ∀ u₀' : ℕ,
  stage₁ i p t u u₀ → stage₁ (i+1) p t u' u₀' →
  program u u' u₀ u₀'

 def χ₁ (k:ℕ) (program:(fin k)→(fin k.succ)→ℕ→ℕ→Prop) (x₀ z y₀ : ℕ) : Prop := ∃ s p t : ℕ,
  stage₁ 0 p t 0 x₀ ∧
  stage₁ s p t z y₀ ∧
  ∀ i:fin s,  χ_steps k program t p i.1

def b_0 (i p:ℕ) (a_ : vector (fin p) i) : ℕ :=
  (list.of_fn (λ j:fin i, j.1.succ * (p ^ (2*j.1)))).sum
    +
  (list.of_fn (λ j:fin i, (a_.nth j).1 * p ^ (2*j.1+1))).sum

def t {r:ℕ} (p:ℕ) (a_ : vector (fin p) r.succ) : ℕ :=
b_0 r.succ p a_

def b_1 (i p:ℕ) : ℕ := p^(2*i)

theorem easy {j i r : ℕ} (h: j < r.succ - (i+1)): i+1+j<r.succ:= lt_tsub_iff_left.mp h

def b_2  (i p :ℕ){r:ℕ} (a_ : vector (fin p) (r.succ)) : ℕ :=
  (list.of_fn (λ j:fin (r.succ-(i+1)), (a_.nth (⟨i+1+j.1,easy j.2⟩)).1 * p ^ (2*j.1+1))).sum
  +
  (list.of_fn (λ j:fin (r-i), (i+2+j.1) * p ^ (2*j.1))).sum

def vector_take {n:ℕ} {α:Type}
   (x : vector α n) (i:ℕ) (h: i≤ n) : vector α i :=
  ⟨(x.take i).1, eq.trans ((x.take i).2) (min_eq_left h)⟩

#eval (nat.prime 11 : bool)

example : nat.prime 11 := sorry -- to avoid having to prove this, we state "decode" and "encode" in a simplified way:

theorem decode {p r:ℕ}   (a_ : vector (fin p) r.succ)(i:fin r.succ): -- (hprime: nat.prime p):
φβ (t p a_) p i (a_.nth i)
:= sorry

theorem encode {p:ℕ}  ( r i:ℕ)(h:i<r.succ)
(a_ : vector (fin p) r.succ) (a:ℕ):
φβ (t p a_) p i a → a = (a_.nth i)
:= λ hφβ, sorry

theorem le_succ_succ {i j:ℕ}: i < j.succ.succ → i ≤ j ∨ i=j.succ :=
λ h, nat.of_le_succ (nat.lt_succ_iff.mp h)

theorem lt_one {i:ℕ} : i < 1 → i=0 := nat.lt_one_iff.mp

theorem lt_two {i:ℕ} : i < 2 → i=0∨ i=1
  :=
  λ h2,
    have i ≤ 0 ∨ i = 1, from le_succ_succ h2,
    this.elim
      (λ h, or.inl (nat.le_zero_iff.mp h))
      (λ h1, or.inr ( h1))

theorem lt_three {i:ℕ} : i < 3 → i=0∨ i=1∨ i=2
  :=
  λ h3,
  have i ≤ 2, from nat.lt_succ_iff.mp h3,
  (em (i=2)).elim (
    λ h2, or.inr (or.inr h2)
  ) (
    λ hn2,
    have i<2,           from ne.lt_of_le hn2 this,
    have i ≤ 0 ∨ i = 1, from le_succ_succ this,

    this.elim
      (λ h, or.inl (nat.le_zero_iff.mp h))
      (λ h1, or.inr (or.inl h1))
  )

theorem true_of_eq {P:ℕ → Prop} {i j :ℕ} (he: i=j) (hP: P j): P i := cast (congr_arg P he).symm hP

theorem of_lt_3 {P:ℕ → Prop}: P 0 → P 1 → P 2 → ∀ i:fin 3, P i.1 :=
λ h0 h1 h2 i, (lt_three i.2).elim (
     λ h, true_of_eq h h0
  ) (
    λ h12, h12.elim
    (λ h, true_of_eq h h1)
    (λ h, true_of_eq h h2)
  )

theorem of_lt_2 {P:ℕ → Prop}: P 0 → P 1 → ∀ i:fin 2, P i.1 :=
λ h0 h1 i, (lt_two i.2).elim (
     λ h, true_of_eq h h0
  ) (
    λ h, true_of_eq h h1
  )

theorem of_lt_1 {P:ℕ → Prop}: P 0 → ∀ i:fin 1, P i.1 :=
  λ h0 i, true_of_eq (lt_one i.2) h0

theorem does_halt_longer: χ₁ 2 inc_dec_R0 0 2 0 :=
  let p := 11 in
  let a_ := (⟨[0,0,1,1,2,0],rfl⟩: vector (fin p) 6) in
  let r := 5 in
  exists.intro 2 ( -- number of steps s=2
    exists.intro p (
      exists.intro (t p a_) (
        and.intro (
          and.intro (decode a_ 0) (decode a_ 1)
        ) (
          and.intro (
            and.intro (decode a_ 4) (decode a_ 5)
          ) (
            of_lt_2 (
              λ u u₀ u' u₀' h0 h1,
              let t:= t p a_, hu := h0.1, hu₀ := h0.2, hu' := h1.1, hu₀' := h1.2 in
              and.intro (
                λ hu0,
                and.intro (
                  calc u'.1 = 1: encode r 2 dec_trivial a_ u'.1 hu'
                        ... = 0+1: by ring
                        ... = u.1+1: by rw hu0
                ) (
                    have Hu₀: u₀ = (vector.nth a_ 1).1, from encode r 1 dec_trivial a_ u₀ hu₀,
                    show  u₀' = u₀ + 1, from calc
                            _ = (vector.nth a_ 3).1: encode r 3 dec_trivial a_ u₀' hu₀'
                          ... = 0+1: by ring
                          ... = (vector.nth a_ 1).1 + 1: rfl
                          ... = u₀+1: by rw Hu₀
                )
              ) (
                λ hu1, -- show line number 1 at stage 0 doesn't, and can't, happen
                false.elim (
                  have u.1 = 0, from encode r 0 dec_trivial a_ u hu,
                  zero_ne_one (eq.trans this.symm hu1)
                )
              )
            ) (
            let t:= t p a_ in
            show   ∀ u:fin 2, ∀ u₀:ℕ, ∀ u':fin 3, ∀ u₀' : ℕ,
            stage₁ 1 p t u u₀ → stage₁ (1+1) p t u' u₀' →
            inc_dec_R0 u u' u₀ u₀', from
            λ u u₀ u' u₀' h0 h1,
            let hu := h0.1, hu₀ := h0.2, hu' := h1.1, hu₀' := h1.2 in
            show   (u.1=0 → u'.1 = u.1 + 1 ∧ u₀' = u₀ + 1)
                  ∧
                  (u.1=1 → u'.1 = u.1 + 1 ∧ u₀' = u₀ - 1) -- monus
                , from
            and.intro (
              λ hu0,-- can't happen
              false.elim (
                have u.1 = 1, from encode r 2 dec_trivial a_ u hu,
                zero_ne_one (eq.trans hu0.symm this)
              )
            ) (
              λ hu1,
              and.intro (
                calc u'.1 = 2: encode r 4 dec_trivial a_ u'.1 hu'
                      ... = 1+1: by ring
                      ... = u.1+1: by rw hu1
              ) (
                  have Hu₀: u₀ = (vector.nth a_ 3).1, from encode r 3 dec_trivial a_ u₀ hu₀,
                  show  u₀' = u₀ - 1, from calc
                          _ = (vector.nth a_ 5).1: encode r 5 dec_trivial a_ u₀' hu₀'
                        ... = 1-1: by ring
                        ... = (vector.nth a_ 3).1 - 1: rfl
                        ... = u₀-1: by rw Hu₀
                )
              )
            )
          )
        )
      )
    )
  )

 theorem does_halt: χ₁ 1 inc_R0_once 0 1 1 :=
  let p := 5 in
  let a_ := (⟨[0,0,1,1],rfl⟩: vector (fin p) 4) in
  let r := 3 in -- r is length a_ minus one
  exists.intro 1 (
    exists.intro p
    (
      exists.intro (t p a_)
      (
        and.intro (
          and.intro (decode a_ 0) (decode a_ 1)
        ) (
          and.intro (
            and.intro (decode a_ 2) (decode a_ 3)
          ) (
            of_lt_1 (
              λ u u₀ u' u₀',
              λ hfst hsnd,
              let hu := hfst.1, hu₀ := hfst.2, hu' := hsnd.1, hu₀' := hsnd.2 in
              and.intro (
              calc u'.1 = 1: encode r 2 dec_trivial a_ u'.1 hu'
                  ... = 0+1: by ring
                  ... = u.1+1: by rw (lt_one u.2)
              ) (
              have Hu₀: u₀ = (vector.nth a_ 1).1, from encode r 1 dec_trivial a_ u₀ hu₀,
              show  u₀' = u₀ + 1, from calc
                      _ = (vector.nth a_ r).1: encode r r dec_trivial a_ u₀' hu₀'
                    ... = 0+1: by ring
                    ... = (vector.nth a_ 1).1 + 1: rfl
                    ... = u₀+1: by rw Hu₀
              )
            )
          )
        )
      )
    )
  )

theorem homework: χ₁ 2 inc_R0_print 0 2 1 := -- starting at config (0,0), we get to config (2,1)
-- HOMEWORK
sorry


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import for_mathlib.algebraic_topology.homotopical_algebra.homotopies
import for_mathlib.algebraic_topology.homotopical_algebra.fibrant
import category_theory.full_subcategory
import for_mathlib.category_theory.quotient_misc
import for_mathlib.category_theory.localization.predicate

noncomputable theory

open algebraic_topology
open category_theory
open category_theory.limits
open category_theory.category

namespace algebraic_topology

namespace model_category

variables (C : Type*) [category C] [model_category C]

@[nolint has_nonempty_instance]
structure cofibrant_object :=
(obj : C)
[cof : is_cofibrant obj]

namespace cofibrant_object

instance (X : cofibrant_object C) : is_cofibrant X.obj := X.cof

instance : category (cofibrant_object C) := induced_category.category (λ X, X.obj)

@[simps, derive full, derive faithful]
def forget : cofibrant_object C ⥤ C := induced_functor _

variable {C}

@[simp]
def weq : morphism_property (cofibrant_object C) := λ X Y f, model_category.weq ((forget C).map f)

def right_homotopy : hom_rel (cofibrant_object C) := λ A X f₁ f₂,
∃ (P : path_object X.obj), nonempty (right_homotopy P.pre f₁ f₂)

namespace right_homotopy

lemma mk {A X : cofibrant_object C} {f₁ f₂ : A ⟶ X} (P : path_object X.obj)
  (H : model_category.right_homotopy P.pre f₁ f₂) : right_homotopy f₁ f₂ :=
⟨P, nonempty.intro H⟩

lemma symm {A X : cofibrant_object C} {f₁ f₂ : A ⟶ X} (H : right_homotopy f₁ f₂) :
  right_homotopy f₂ f₁ :=
right_homotopy.mk H.some.symm H.some_spec.some.symm

lemma comp_left {A B X : cofibrant_object C} {g₁ g₂ : B ⟶ X} (H : right_homotopy g₁ g₂)
  (f : A ⟶ B) : right_homotopy (f ≫ g₁) (f ≫ g₂) :=
right_homotopy.mk H.some (H.some_spec.some.comp_left f)

lemma comp_right {A X Y : cofibrant_object C} {f₁ f₂ : A ⟶ X} (H : right_homotopy f₁ f₂)
  (g : X ⟶ Y) : right_homotopy (f₁ ≫ g) (f₂ ≫ g) :=
begin
  cases H with P hP,
  rcases hP.some.with_cof_σ_of_right_homotopy with ⟨P', H', hP'⟩,
  haveI : cofibration P'.σ := hP',
  let Q := path_object.some Y.1,
  suffices H'' : model_category.right_homotopy Q.pre (P'.d₀ ≫ g) (P'.d₁ ≫ g),
  { exact mk Q { h := H'.h ≫ H''.h, }, },
  apply right_homotopy.extension P'.σ,
  simp only [pre_path_object.d₀σ_assoc, pre_path_object.d₁σ_assoc],
  apply right_homotopy.refl,
end

inductive trans_closure ⦃A X : cofibrant_object C⦄ : (A ⟶ X) → (A ⟶ X) → Prop
| mk {f₁ f₂ : A ⟶ X} (H : right_homotopy f₁ f₂) : trans_closure f₁ f₂
| trans {f₁ f₂ f₃ : A ⟶ X} (H₁₂ : trans_closure f₁ f₂) (H₂₃ : trans_closure f₂ f₃) :
  trans_closure f₁ f₃

namespace trans_closure

lemma is_equiv (A X : cofibrant_object C) :
  is_equiv (A ⟶ X) (λ f₁ f₂, trans_closure f₁ f₂) :=
{ refl := λ f, trans_closure.mk (right_homotopy.mk
    (path_object.some X.1) (right_homotopy.refl _ f)),
  trans := λ f₁ f₂ f₃ H₁₂ H₂₃, trans_closure.trans H₁₂ H₂₃,
  symm := λ f₁ f₂ H, begin
    induction H with f₁ f₂ H₁₂ f₁ f₂ f₃ H₁₂ H₂₃ H₂₁ H₃₂,
    { exact trans_closure.mk H₁₂.symm, },
    { exact trans_closure.trans H₃₂ H₂₁, },
  end, }

lemma comp_left {A B X : cofibrant_object C} {g₁ g₂ : B ⟶ X} (H : trans_closure g₁ g₂)
  (f : A ⟶ B) : trans_closure (f ≫ g₁) (f ≫ g₂) :=
begin
  induction H with f₁ f₂ H₁₂ f₁ f₂ f₃ H₁₂ H₂₃ H₁₂' H₂₃',
  { exact mk (H₁₂.comp_left f), },
  { exact trans H₁₂' H₂₃', }
end

lemma comp_right {A X Y : cofibrant_object C} {f₁ f₂ : A ⟶ X} (H : trans_closure f₁ f₂)
  (g : X ⟶ Y) : trans_closure (f₁ ≫ g) (f₂ ≫ g) :=
begin
  induction H with f₁ f₂ H₁₂ f₁ f₂ f₃ H₁₂ H₂₃ H₁₂' H₂₃',
  { exact mk (H₁₂.comp_right g), },
  { exact trans H₁₂' H₂₃', },
end

end trans_closure

end right_homotopy

variable (C)

@[simp]
def homotopy_relation : hom_rel (cofibrant_object C) := right_homotopy.trans_closure

instance : congruence (homotopy_relation C) :=
{ is_equiv := right_homotopy.trans_closure.is_equiv,
  comp_left := λ A B X f g₁ g₂ H, H.comp_left f,
  comp_right := λ A X Y f₁ f₂ g H, H.comp_right g, }

@[nolint has_nonempty_instance]
def homotopy_category := quotient (right_homotopy.trans_closure : hom_rel (cofibrant_object C))

instance : congruence (right_homotopy.trans_closure : hom_rel (cofibrant_object C)) :=
{ is_equiv := right_homotopy.trans_closure.is_equiv,
  comp_left := λ A B X f g₁ g₂ H, H.comp_left f,
  comp_right := λ A X Y f₁ f₂ g H, H.comp_right g, }

instance : category (homotopy_category C) := quotient.category _

variable {C}

def homotopy_category.Q : cofibrant_object C ⥤ homotopy_category C := quotient.functor _

namespace homotopy_category

@[simp]
lemma Q_map {X Y : cofibrant_object C} (f : X ⟶ Y) :
  Q.map f = (quotient.functor _).map f := rfl

lemma Q_map_surjective (X Y : cofibrant_object C) :
  function.surjective (@category_theory.functor.map _ _ _ _ Q X Y) :=
by apply quotient.functor_map_surjective

lemma Q_map_eq_iff {X Y : cofibrant_object C} [hY : is_fibrant Y.obj]
  (Cyl : cylinder X.obj) (f₁ f₂ : X ⟶ Y) :
  (Q.map f₁ = Q.map f₂) ↔ nonempty (left_homotopy Cyl.pre f₁ f₂) :=
begin
  split,
  { intro h,
    simp only [Q_map, quotient.functor_map_eq_iff] at h,
    induction h with f₁ f₂ H f₁ f₂ f₃ H₁₂ H₂₃ H H',
    { exact nonempty.intro (H.some_spec.some.to_left_homotopy Cyl), },
    { exact nonempty.intro ((H.some.trans H'.some).change_cylinder Cyl), }, },
  { intro h,
    apply category_theory.quotient.sound,
    refine right_homotopy.trans_closure.mk
      (right_homotopy.mk (path_object.some Y.obj) (h.some.to_right_homotopy _)), },
end

lemma Q_map_eq_iff' {X Y : cofibrant_object C} [is_fibrant Y.obj]
  (P : path_object Y.obj) (f₁ f₂ : X ⟶ Y) :
  (Q.map f₁ = Q.map f₂) ↔ nonempty (model_category.right_homotopy P.pre f₁ f₂) :=
begin
  rw Q_map_eq_iff (cylinder.some X.obj) f₁ f₂,
  split,
  { exact λ h, nonempty.intro (h.some.to_right_homotopy _), },
  { exact λ h, nonempty.intro (h.some.to_left_homotopy _), },
end

def weq : morphism_property (cofibrant_object.homotopy_category C) :=
λ X Y f, ∃ (g : X.as.obj ⟶ Y.as.obj) (hg : model_category.weq g), f = Q.map g

lemma weq_Q_map_iff {X Y : cofibrant_object C} (f : X ⟶ Y) :
  weq (Q.map f) ↔ cofibrant_object.weq f :=
begin
  refine ⟨λ hf, _, λ hf, ⟨f, hf, rfl⟩⟩,
  rcases hf with ⟨g : X ⟶ Y, hg, H⟩,
  dsimp only [Q] at H,
  rw quotient.functor_map_eq_iff at H,
  induction H with f₁ f₂ H f₁ f₂ f₃ H₁₂ H₂₃ h₁ h₂,
  { rcases H with ⟨P, H⟩,
    let f'₁ : X.obj ⟶ Y.obj := f₁,
    let f'₂ : X.obj ⟶ Y.obj := f₂,
    change model_category.weq f'₁,
    change model_category.weq f'₂ at hg,
    let h : model_category.right_homotopy P.pre f'₁ f'₂ := H.some,
    rw ← h.h₀,
    rw ← h.h₁ at hg,
    exact CM2.of_comp _ _ (CM2.of_comp_right _ _ weak_eq.property hg) weak_eq.property, },
  { exact h₁ (h₂ hg), },
end

end homotopy_category

end cofibrant_object

variable (C)

@[derive category]
def Hocof' := (cofibrant_object.weq : morphism_property (cofibrant_object C)).localization

variable {C}

def Lcof' : cofibrant_object C ⥤ Hocof' C :=
(cofibrant_object.weq : morphism_property (cofibrant_object C)).Q

instance Lcof'_is_localization :
(Lcof' : cofibrant_object C ⥤ Hocof' C).is_localization cofibrant_object.weq :=
by { dsimp [Lcof'], apply_instance, }

end model_category

end algebraic_topology


/-
Copyright (c) 2021 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import data.fintype.basic
import algebra.big_operators.basic

/-!
# The Hales-Jewett theorem

We prove the Hales-Jewett theorem and deduce Van der Waerden's theorem as a corollary.

The Hales-Jewett theorem is a result in Ramsey theory dealing with *combinatorial lines*. Given
an 'alphabet' `α : Type*` and `a b : α`, an example of a combinatorial line in `α^5` is
`{ (a, x, x, b, x) | x : α }`. See `combinatorics.line` for a precise general definition. The
Hales-Jewett theorem states that for any fixed finite types `α` and `κ`, there exists a (potentially
huge) finite type `ι` such that whenever `ι → α` is `κ`-colored (i.e. for any coloring
`C : (ι → α) → κ`), there exists a monochromatic line. We prove the Hales-Jewett theorem using
the idea of *color focusing* and a *product argument*. See the proof of
`combinatorics.line.exists_mono_in_high_dimension'` for details.

The version of Van der Waerden's theorem in this file states that whenever a commutative monoid `M`
is finitely colored and `S` is a finite subset, there exists a monochromatic homothetic copy of `S`.
This follows from the Hales-Jewett theorem by considering the map `(ι → S) → M` sending `v`
to `∑ i : ι, v i`, which sends a combinatorial line to a homothetic copy of `S`.

## Main results

- `combinatorics.line.exists_mono_in_high_dimension`: the Hales-Jewett theorem.
- `combinatorics.exists_mono_homothetic_copy`: a generalization of Van der Waerden's theorem.

## Implementation details

For convenience, we work directly with finite types instead of natural numbers. That is, we write
`α, ι, κ` for (finite) types where one might traditionally use natural numbers `n, H, c`. This
allows us to work directly with `α`, `option α`, `(ι → α) → κ`, and `ι ⊕ ι'` instead of `fin n`,
`fin (n+1)`, `fin (c^(n^H))`, and `fin (H + H')`.

## Todo

- Prove a finitary version of Van der Waerden's theorem (either by compactness or by modifying the
current proof).

- One could reformulate the proof of Hales-Jewett to give explicit upper bounds on the number of
coordinates needed.

## Tags

combinatorial line, Ramsey theory, arithmetic progession

### References

* https://en.wikipedia.org/wiki/Hales%E2%80%93Jewett_theorem

-/

open_locale classical
open_locale big_operators

universes u v

namespace combinatorics

/-- The type of combinatorial lines. A line `l : line α ι` in the hypercube `ι → α` defines a
function `α → ι → α` from `α` to the hypercube, such that for each coordinate `i : ι`, the function
`λ x, l x i` is either `id` or constant. We require lines to be nontrivial in the sense that
`λ x, l x i` is `id` for at least one `i`.

Formally, a line is represented by the function `l.idx_fun : ι → option α` which says whether
`λ x, l x i` is `id` (corresponding to `l.idx_fun i = none`) or constantly `y` (corresponding to
`l.idx_fun i = some y`).

When `α` has size `1` there can be many elements of `line α ι` defining the same function. -/
structure line (α ι : Type*) :=
(idx_fun : ι → option α)
(proper : ∃ i, idx_fun i = none)

namespace line

/- This lets us treat a line `l : line α ι` as a function `α → ι → α`. -/
instance (α ι) : has_coe_to_fun (line α ι) (λ _, α → ι → α) :=
⟨λ l x i, (l.idx_fun i).get_or_else x⟩

/-- A line is monochromatic if all its points are the same color. -/
def is_mono {α ι κ} (C : (ι → α) → κ) (l : line α ι) : Prop :=
∃ c, ∀ x, C (l x) = c

/-- The diagonal line. It is the identity at every coordinate. -/
def diagonal (α ι) [nonempty ι] : line α ι :=
{ idx_fun := λ _, none,
  proper  := ⟨classical.arbitrary ι, rfl⟩ }

instance (α ι) [nonempty ι] : inhabited (line α ι) := ⟨diagonal α ι⟩

/-- The type of lines that are only one color except possibly at their endpoints. -/
structure almost_mono {α ι κ : Type*} (C : (ι → option α) → κ) :=
(line : line (option α) ι)
(color : κ)
(has_color : ∀ x : α, C (line (some x)) = color)

instance {α ι κ : Type*} [nonempty ι] [inhabited κ] :
  inhabited (almost_mono (λ v : ι → option α, default κ)) :=
⟨{ line      := default _,
   color     := default κ,
   has_color := λ _, rfl }⟩

/-- The type of collections of lines such that
- each line is only one color except possibly at its endpoint
- the lines all have the same endpoint
- the colors of the lines are distinct.
Used in the proof `exists_mono_in_high_dimension`. -/
structure color_focused {α ι κ : Type*} (C : (ι → option α) → κ) :=
(lines : multiset (almost_mono C))
(focus : ι → option α)
(is_focused : ∀ p ∈ lines, almost_mono.line p none = focus)
(distinct_colors : (lines.map almost_mono.color).nodup)

instance {α ι κ} (C : (ι → option α) → κ) : inhabited (color_focused C) :=
⟨⟨0, λ _, none, λ _, false.elim, multiset.nodup_zero⟩⟩

/-- A function `f : α → α'` determines a function `line α ι → line α' ι`. For a coordinate `i`,
`l.map f` is the identity at `i` if `l` is, and constantly `f y` if `l` is constantly `y` at `i`. -/
def map {α α' ι} (f : α → α') (l : line α ι) : line α' ι :=
{ idx_fun := λ i, (l.idx_fun i).map f,
  proper  := ⟨l.proper.some, by rw [l.proper.some_spec, option.map_none'] ⟩ }

/-- A point in `ι → α` and a line in `ι' → α` determine a line in `ι ⊕ ι' → α`. -/
def vertical {α ι ι'} (v : ι → α) (l : line α ι') : line α (ι ⊕ ι') :=
{ idx_fun := sum.elim (some ∘ v) l.idx_fun,
  proper  := ⟨sum.inr l.proper.some, l.proper.some_spec⟩ }

/-- A line in `ι → α` and a point in `ι' → α` determine a line in `ι ⊕ ι' → α`. -/
def horizontal {α ι ι'} (l : line α ι) (v : ι' → α) : line α (ι ⊕ ι') :=
{ idx_fun := sum.elim l.idx_fun (some ∘ v),
  proper  := ⟨sum.inl l.proper.some, l.proper.some_spec⟩ }

/-- One line in `ι → α` and one in `ι' → α` together determine a line in `ι ⊕ ι' → α`. -/
def prod {α ι ι'} (l : line α ι) (l' : line α ι') : line α (ι ⊕ ι') :=
{ idx_fun := sum.elim l.idx_fun l'.idx_fun,
  proper  := ⟨sum.inl l.proper.some, l.proper.some_spec⟩ }

lemma apply {α ι} (l : line α ι) (x : α) : l x = λ i, (l.idx_fun i).get_or_else x := rfl

lemma apply_none {α ι} (l : line α ι) (x : α) (i : ι) (h : l.idx_fun i = none) : l x i = x :=
by simp only [option.get_or_else_none, h, l.apply]

lemma apply_of_ne_none {α ι} (l : line α ι) (x : α) (i : ι) (h : l.idx_fun i ≠ none) :
  some (l x i) = l.idx_fun i :=
by rw [l.apply, option.get_or_else_of_ne_none h]

@[simp] lemma map_apply {α α' ι} (f : α → α') (l : line α ι) (x : α) :
  l.map f (f x) = f ∘ l x :=
by simp only [line.apply, line.map, option.get_or_else_map]

@[simp] lemma vertical_apply {α ι ι'} (v : ι → α) (l : line α ι') (x : α) :
  l.vertical v x = sum.elim v (l x) :=
by { funext i, cases i; refl }

@[simp] lemma horizontal_apply {α ι ι'} (l : line α ι) (v : ι' → α) (x : α) :
  l.horizontal v x = sum.elim (l x) v :=
by { funext i, cases i; refl }

@[simp]

@[simp] lemma diagonal_apply {α ι} [nonempty ι] (x : α) :
  line.diagonal α ι x = λ i, x :=
by simp_rw [line.apply, line.diagonal, option.get_or_else_none]

/-- The Hales-Jewett theorem. This version has a restriction on universe levels which is necessary
for the proof. See `exists_mono_in_high_dimension` for a fully universe-polymorphic version. -/
private theorem exists_mono_in_high_dimension' :
  ∀ (α : Type u) [fintype α] (κ : Type (max v u)) [fintype κ],
  ∃ (ι : Type) (_ : fintype ι), ∀ C : (ι → α) → κ, ∃ l : line α ι, l.is_mono C :=
-- The proof proceeds by induction on `α`.
fintype.induction_empty_option
-- We have to show that the theorem is invariant under `α ≃ α'` for the induction to work.
(λ α α' e, forall_imp $ λ κ, forall_imp $ λ _, Exists.imp $ λ ι, Exists.imp $ λ _ h C,
  let ⟨l, c, lc⟩ := h (λ v, C (e ∘ v)) in
  ⟨l.map e, c, e.forall_congr_left.mp $ λ x, by rw [←lc x, line.map_apply]⟩)
begin -- This deals with the degenerate case where `α` is empty.
  introsI κ _,
  by_cases h : nonempty κ,
  { resetI, exact ⟨unit, infer_instance, λ C, ⟨default _, classical.arbitrary _, pempty.rec _⟩⟩, },
  { exact ⟨empty, infer_instance, λ C, (h ⟨C (empty.rec _)⟩).elim⟩, }
end
begin -- Now we have to show that the theorem holds for `option α` if it holds for `α`.
  introsI α _ ihα κ _,
-- Later we'll need `α` to be nonempty. So we first deal with the trivial case where `α` is empty.
-- Then `option α` has only one element, so any line is monochromatic.
  by_cases h : nonempty α,
  work_on_goal 1 { refine ⟨unit, infer_instance, λ C, ⟨diagonal _ _, C (λ _, none), _⟩⟩,
    rintros (_ | ⟨a⟩), refl, exact (h ⟨a⟩).elim, },
-- The key idea is to show that for every `r`, in high dimension we can either find
-- `r` color focused lines or a monochromatic line.
  suffices key : ∀ r : ℕ, ∃ (ι : Type) (_ : fintype ι), ∀ C : (ι → (option α)) → κ,
    (∃ s : color_focused C, s.lines.card = r) ∨ (∃ l, is_mono C l),
-- Given the key claim, we simply take `r = |κ| + 1`. We cannot have this many distinct colors so
-- we must be in the second case, where there is a monochromatic line.
  { obtain ⟨ι, _inst, hι⟩ := key (fintype.card κ + 1),
    refine ⟨ι, _inst, λ C, (hι C).resolve_left _⟩,
    rintro ⟨s, sr⟩,
    apply nat.not_succ_le_self (fintype.card κ),
    rw [←nat.add_one, ←sr, ←multiset.card_map, ←finset.card_mk],
    exact finset.card_le_univ ⟨_, s.distinct_colors⟩ },
-- We now prove the key claim, by induction on `r`.
  intro r,
  induction r with r ihr,
-- The base case `r = 0` is trivial as the empty collection is color-focused.
  { exact ⟨empty, infer_instance, λ C, or.inl ⟨default _, multiset.card_zero⟩⟩, },
-- Supposing the key claim holds for `r`, we need to show it for `r+1`. First pick a high enough
-- dimension `ι` for `r`.
  obtain ⟨ι, _inst, hι⟩ := ihr,
  resetI,
-- Then since the theorem holds for `α` with any number of colors, pick a dimension `ι'` such that
-- `ι' → α` always has a monochromatic line whenever it is `(ι → option α) → κ`-colored.
  specialize ihα ((ι → option α) → κ),
  obtain ⟨ι', _inst, hι'⟩ := ihα,
  resetI,
-- We claim that `ι ⊕ ι'` works for `option α` and `κ`-coloring.
  refine ⟨ι ⊕ ι', infer_instance, _⟩,
  intro C,
-- A `κ`-coloring of `ι ⊕ ι' → option α` induces an `(ι → option α) → κ`-coloring of `ι' → α`.
  specialize hι' (λ v' v, C (sum.elim v (some ∘ v'))),
-- By choice of `ι'` this coloring has a monochromatic line `l'` with color class `C'`, where
-- `C'` is a `κ`-coloring of `ι → α`.
  obtain ⟨l', C', hl'⟩ := hι',
-- If `C'` has a monochromatic line, then so does `C`. We use this in two places below.
  have mono_of_mono : (∃ l, is_mono C' l) → (∃ l, is_mono C l),
  { rintro ⟨l, c, hl⟩,
    refine ⟨l.horizontal (some ∘ l' (classical.arbitrary α)), c, λ x, _⟩,
    rw [line.horizontal_apply, ←hl, ←hl'], },
-- By choice of `ι`, `C'` either has `r` color-focused lines or a monochromatic line.
  specialize hι C',
  rcases hι with ⟨s, sr⟩ | _,
-- By above, we are done if `C'` has a monochromatic line.
  work_on_goal 1 { exact or.inr (mono_of_mono hι) },
-- Here we assume `C'` has `r` color focused lines. We split into cases depending on whether one of
-- these `r` lines has the same color as the focus point.
  by_cases h : ∃ p ∈ s.lines, (p : almost_mono _).color = C' s.focus,
-- If so then this is a `C'`-monochromatic line and we are done.
  { obtain ⟨p, p_mem, hp⟩ := h,
    refine or.inr (mono_of_mono ⟨p.line, p.color, _⟩),
    rintro (_ | _), rw [hp, s.is_focused p p_mem], apply p.has_color, },
-- If not, we get `r+1` color focused lines by taking the product of the `r` lines with `l'` and
-- adding to this the vertical line obtained by the focus point and `l`.
  refine or.inl ⟨⟨(s.lines.map _).cons ⟨(l'.map some).vertical s.focus, C' s.focus, λ x, _⟩,
    sum.elim s.focus (l'.map some none), _, _⟩, _⟩,
-- The vertical line is almost monochromatic.
  { rw [vertical_apply, ←congr_fun (hl' x), line.map_apply], },
  { refine λ p, ⟨p.line.prod (l'.map some), p.color, λ x, _⟩,
-- The product lines are almost monochromatic.
    rw [line.prod_apply, line.map_apply, ←p.has_color, ←congr_fun (hl' x)], },
-- Our `r+1` lines have the same endpoint.
  { simp_rw [multiset.mem_cons, multiset.mem_map],
    rintros _ (rfl | ⟨q, hq, rfl⟩),
    { rw line.vertical_apply, },
    { rw [line.prod_apply, s.is_focused q hq], }, },
-- Our `r+1` lines have distinct colors (this is why we needed to split into cases above).
  { rw [multiset.map_cons, multiset.map_map, multiset.nodup_cons, multiset.mem_map],
    exact ⟨λ ⟨q, hq, he⟩, h ⟨q, hq, he⟩, s.distinct_colors⟩, },
-- Finally, we really do have `r+1` lines!
  { rw [multiset.card_cons, multiset.card_map, sr], },
end

/-- The Hales-Jewett theorem: for any finite types `α` and `κ`, there exists a finite type `ι` such
that whenever the hypercube `ι → α` is `κ`-colored, there is a monochromatic combinatorial line. -/
theorem exists_mono_in_high_dimension (α : Type u) [fintype α] (κ : Type v) [fintype κ] :
  ∃ (ι : Type) [fintype ι], ∀ C : (ι → α) → κ, ∃ l : line α ι, l.is_mono C :=
let ⟨ι, ιfin, hι⟩ := exists_mono_in_high_dimension' α (ulift κ)
in ⟨ι, ιfin, λ C, let ⟨l, c, hc⟩ := hι (ulift.up ∘ C) in ⟨l, c.down, λ x, by rw ←hc⟩ ⟩

end line

/-- A generalization of Van der Waerden's theorem: if `M` is a finitely colored commutative
monoid, and `S` is a finite subset, then there exists a monochromatic homothetic copy of `S`. -/
theorem exists_mono_homothetic_copy
  {M κ} [add_comm_monoid M] (S : finset M) [fintype κ] (C : M → κ) :
  ∃ (a > 0) (b : M) (c : κ), ∀ s ∈ S, C (a • s + b) = c :=
begin
  obtain ⟨ι, _inst, hι⟩ := line.exists_mono_in_high_dimension S κ,
  resetI,
  specialize hι (λ v, C $ ∑ i, v i),
  obtain ⟨l, c, hl⟩ := hι,
  set s : finset ι := { i ∈ finset.univ | l.idx_fun i = none } with hs,
  refine ⟨s.card, finset.card_pos.mpr ⟨l.proper.some, _⟩,
    ∑ i in sᶜ, ((l.idx_fun i).map coe).get_or_else 0, c, _⟩,
  { rw [hs, finset.sep_def, finset.mem_filter], exact ⟨finset.mem_univ _, l.proper.some_spec⟩, },
  intros x xs,
  rw ←hl ⟨x, xs⟩,
  clear hl, congr,
  rw ←finset.sum_add_sum_compl s,
  congr' 1,
  { rw ←finset.sum_const,
    apply finset.sum_congr rfl,
    intros i hi,
    rw [hs, finset.sep_def, finset.mem_filter] at hi,
    rw [l.apply_none _ _ hi.right, subtype.coe_mk], },
  { apply finset.sum_congr rfl,
    intros i hi,
    rw [hs, finset.sep_def, finset.compl_filter, finset.mem_filter] at hi,
    obtain ⟨y, hy⟩ := option.ne_none_iff_exists.mp hi.right,
    simp_rw [line.apply, ←hy, option.map_some', option.get_or_else_some], },
end

end combinatorics


import analysis.special_functions.exp
import analysis.special_functions.log.base

open set real

#check exp_log

-- BEGIN

example : inj_on log { x | x > 0 } :=
begin
  intros x xpos y ypos,
  intro e,   -- log x = log y
  calc
    x   = exp (log x) : by rw exp_log xpos
    ... = exp (log y) : by rw e
    ... = y           : by rw exp_log ypos
end

-- END


import M4R.Algebra.Ring.Defs

namespace M4R
  open NCSemiring Semiring

  namespace SubSemiring

    def Self (α : Type _) [NCSemiring α] : SubSemiring α where
      toSubMonoid := SubMonoid.Self α
      has_one := trivial
      mul_closed := by intros; trivial

    protected theorem ext [NCSemiring α] (s₁ s₂ : SubSemiring α) : s₁.subset = s₂.subset ↔ s₁ = s₂ :=
      ⟨match s₁, s₂ with | ⟨_, _, _⟩, ⟨_, _, _⟩ => by rw [SubSemiring.mk.injEq]; exact (SubMonoid.ext _ _).mp,
      fun h => by rw [h]⟩

    protected instance toNCSemiring [NCSemiring α] (s : SubSemiring α) : NCSemiring ↑s.subset where
      one := ⟨1, s.has_one⟩
      mul := fun ⟨x, hx⟩ ⟨y, hy⟩ => ⟨x * y, s.mul_closed x hx y hy⟩
      mul_one := fun ⟨a, _⟩ => Set.elementExt (mul_one a)
      one_mul := fun ⟨a, _⟩ => Set.elementExt (one_mul a)
      mul_assoc := fun ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩ => Set.elementExt (mul_assoc a b c)
      mul_distrib_left := fun ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩ => Set.elementExt (mul_distrib_left a b c)
      mul_distrib_right := fun ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩ => Set.elementExt (mul_distrib_right a b c)
      mul_zero := fun ⟨a, _⟩ => Set.elementExt (mul_zero a)
      zero_mul := fun ⟨a, _⟩ => Set.elementExt (zero_mul a)

    protected instance toSemiring [Semiring α] (s : SubSemiring α) : Semiring ↑s.subset where
      toNCSemiring := s.toNCSemiring
      mul_comm := fun ⟨a, _⟩ ⟨b, _⟩ => Set.elementExt (mul_comm a b)

  end SubSemiring

  namespace SubRing

    def Self (α : Type _) [NCRing α] : SubRing α where
      toSubSemiring := SubSemiring.Self α
      neg_closed := (SubGroup.Self α).neg_closed

    protected theorem ext [NCRing α] (s₁ s₂ : SubRing α) : s₁.subset = s₂.subset ↔ s₁ = s₂ :=
      ⟨match s₁, s₂ with | ⟨a, b⟩, ⟨c, d⟩ => by rw [SubRing.mk.injEq]; exact (SubSemiring.ext _ _).mp, by intro h; rw [h]⟩

    protected instance toNCRing [NCRing α] (s : SubRing α) : NCRing ↑s.subset where
      toNeg := s.toSubGroup.toGroup.toNeg
      add_neg := s.toSubGroup.toGroup.add_neg

    protected instance toRing [Ring α] (s : SubRing α) : Ring ↑(s.subset) where
      mul_comm := s.toSemiring.mul_comm

  end SubRing
end M4R


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

! This file was ported from Lean 3 source module linear_algebra.matrix.basis
! leanprover-community/mathlib commit 2f4cdce0c2f2f3b8cd58f05d556d03b468e1eb2e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.Matrix.NonsingularInverse
import Mathbin.LinearAlgebra.Matrix.Reindex
import Mathbin.LinearAlgebra.Matrix.ToLin

/-!
# Bases and matrices

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

## Main definitions

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

## Main results

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

## Tags

matrix, basis
-/

noncomputable section

open LinearMap Matrix Set Submodule

open BigOperators

open Matrix

section BasisToMatrix

variable {ι ι' κ κ' : Type _}

variable {R M : Type _} [CommSemiring R] [AddCommMonoid M] [Module R M]

variable {R₂ M₂ : Type _} [CommRing R₂] [AddCommGroup M₂] [Module R₂ M₂]

open Function Matrix

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

variable (e : Basis ι R M) (v : ι' → M) (i : ι) (j : ι')

namespace Basis

theorem toMatrix_apply : e.toMatrix v i j = e.repr (v j) i :=
  rfl
#align basis.to_matrix_apply Basis.toMatrix_apply

theorem toMatrix_transpose_apply : (e.toMatrix v)ᵀ j = e.repr (v j) :=
  funext fun _ => rfl
#align basis.to_matrix_transpose_apply Basis.toMatrix_transpose_apply

theorem toMatrix_eq_toMatrix_constr [Fintype ι] [DecidableEq ι] (v : ι → M) :
    e.toMatrix v = LinearMap.toMatrix e e (e.constr ℕ v) :=
  by
  ext
  rw [Basis.toMatrix_apply, LinearMap.toMatrix_apply, Basis.constr_basis]
#align basis.to_matrix_eq_to_matrix_constr Basis.toMatrix_eq_toMatrix_constr

-- TODO (maybe) Adjust the definition of `basis.to_matrix` to eliminate the transpose.
theorem CoePiBasisFun.toMatrix_eq_transpose [Fintype ι] :
    ((Pi.basisFun R ι).toMatrix : Matrix ι ι R → Matrix ι ι R) = Matrix.transpose :=
  by
  ext (M i j)
  rfl
#align basis.coe_pi_basis_fun.to_matrix_eq_transpose Basis.CoePiBasisFun.toMatrix_eq_transpose

@[simp]
theorem toMatrix_self [DecidableEq ι] : e.toMatrix e = 1 :=
  by
  rw [Basis.toMatrix]
  ext (i j)
  simp [Basis.equivFun, Matrix.one_apply, Finsupp.single_apply, eq_comm]
#align basis.to_matrix_self Basis.toMatrix_self

theorem toMatrix_update [DecidableEq ι'] (x : M) :
    e.toMatrix (Function.update v j x) = Matrix.updateColumn (e.toMatrix v) j (e.repr x) :=
  by
  ext (i' k)
  rw [Basis.toMatrix, Matrix.updateColumn_apply, e.to_matrix_apply]
  split_ifs
  · rw [h, update_same j x v]
  · rw [update_noteq h]
#align basis.to_matrix_update Basis.toMatrix_update

/-- The basis constructed by `units_smul` has vectors given by a diagonal matrix. -/
@[simp]
theorem toMatrix_unitsSmul [DecidableEq ι] (e : Basis ι R₂ M₂) (w : ι → R₂ˣ) :
    e.toMatrix (e.units_smul w) = diagonal (coe ∘ w) :=
  by
  ext (i j)
  by_cases h : i = j
  · simp [h, to_matrix_apply, units_smul_apply, Units.smul_def]
  · simp [h, to_matrix_apply, units_smul_apply, Units.smul_def, Ne.symm h]
#align basis.to_matrix_units_smul Basis.toMatrix_unitsSmul

/-- The basis constructed by `is_unit_smul` has vectors given by a diagonal matrix. -/
@[simp]
theorem toMatrix_isUnitSmul [DecidableEq ι] (e : Basis ι R₂ M₂) {w : ι → R₂}
    (hw : ∀ i, IsUnit (w i)) : e.toMatrix (e.isUnitSmul hw) = diagonal w :=
  e.toMatrix_unitsSmul _
#align basis.to_matrix_is_unit_smul Basis.toMatrix_isUnitSmul

@[simp]
theorem sum_toMatrix_smul_self [Fintype ι] : (∑ i : ι, e.toMatrix v i j • e i) = v j := by
  simp_rw [e.to_matrix_apply, e.sum_repr]
#align basis.sum_to_matrix_smul_self Basis.sum_toMatrix_smul_self

theorem toMatrix_map_vecMul {S : Type _} [Ring S] [Algebra R S] [Fintype ι] (b : Basis ι R S)
    (v : ι' → S) : ((b.toMatrix v).map <| algebraMap R S).vecMul b = v :=
  by
  ext i
  simp_rw [vec_mul, dot_product, Matrix.map_apply, ← Algebra.commutes, ← Algebra.smul_def,
    sum_to_matrix_smul_self]
#align basis.to_matrix_map_vec_mul Basis.toMatrix_map_vecMul

@[simp]
theorem toLin_toMatrix [Fintype ι] [Fintype ι'] [DecidableEq ι'] (v : Basis ι' R M) :
    Matrix.toLin v e (e.toMatrix v) = id :=
  v.ext fun i => by rw [to_lin_self, id_apply, e.sum_to_matrix_smul_self]
#align basis.to_lin_to_matrix Basis.toLin_toMatrix

/-- From a basis `e : ι → M`, build a linear equivalence between families of vectors `v : ι → M`,
and matrices, making the matrix whose columns are the vectors `v i` written in the basis `e`. -/
def toMatrixEquiv [Fintype ι] (e : Basis ι R M) : (ι → M) ≃ₗ[R] Matrix ι ι R
    where
  toFun := e.toMatrix
  map_add' v w := by
    ext (i j)
    change _ = _ + _
    rw [e.to_matrix_apply, Pi.add_apply, LinearEquiv.map_add]
    rfl
  map_smul' := by
    intro c v
    ext (i j)
    rw [e.to_matrix_apply, Pi.smul_apply, LinearEquiv.map_smul]
    rfl
  invFun m j := ∑ i, m i j • e i
  left_inv := by
    intro v
    ext j
    exact e.sum_to_matrix_smul_self v j
  right_inv := by
    intro m
    ext (k l)
    simp only [e.to_matrix_apply, ← e.equiv_fun_apply, ← e.equiv_fun_symm_apply,
      LinearEquiv.apply_symm_apply]
#align basis.to_matrix_equiv Basis.toMatrixEquiv

end Basis

section MulLinearMapToMatrix

variable {N : Type _} [AddCommMonoid N] [Module R N]

variable (b : Basis ι R M) (b' : Basis ι' R M) (c : Basis κ R N) (c' : Basis κ' R N)

variable (f : M →ₗ[R] N)

open LinearMap

section Fintype

variable [Fintype ι'] [Fintype κ] [Fintype κ']

@[simp]
theorem basis_toMatrix_mul_linearMap_toMatrix [DecidableEq ι'] :
    c.toMatrix c' ⬝ LinearMap.toMatrix b' c' f = LinearMap.toMatrix b' c f :=
  (Matrix.toLin b' c).Injective
    (by
      haveI := Classical.decEq κ' <;>
        rw [to_lin_to_matrix, to_lin_mul b' c' c, to_lin_to_matrix, c.to_lin_to_matrix, id_comp])
#align basis_to_matrix_mul_linear_map_to_matrix basis_toMatrix_mul_linearMap_toMatrix

variable [Fintype ι]

@[simp]
theorem linearMap_toMatrix_mul_basis_toMatrix [DecidableEq ι] [DecidableEq ι'] :
    LinearMap.toMatrix b' c' f ⬝ b'.toMatrix b = LinearMap.toMatrix b c' f :=
  (Matrix.toLin b c').Injective
    (by rw [to_lin_to_matrix, to_lin_mul b b' c', to_lin_to_matrix, b'.to_lin_to_matrix, comp_id])
#align linear_map_to_matrix_mul_basis_to_matrix linearMap_toMatrix_mul_basis_toMatrix

theorem basis_toMatrix_mul_linearMap_toMatrix_mul_basis_toMatrix [DecidableEq ι] [DecidableEq ι'] :
    c.toMatrix c' ⬝ LinearMap.toMatrix b' c' f ⬝ b'.toMatrix b = LinearMap.toMatrix b c f := by
  rw [basis_toMatrix_mul_linearMap_toMatrix, linearMap_toMatrix_mul_basis_toMatrix]
#align basis_to_matrix_mul_linear_map_to_matrix_mul_basis_to_matrix basis_toMatrix_mul_linearMap_toMatrix_mul_basis_toMatrix

theorem basis_toMatrix_mul [DecidableEq κ] (b₁ : Basis ι R M) (b₂ : Basis ι' R M) (b₃ : Basis κ R N)
    (A : Matrix ι' κ R) : b₁.toMatrix b₂ ⬝ A = LinearMap.toMatrix b₃ b₁ (toLin b₃ b₂ A) :=
  by
  have := basis_toMatrix_mul_linearMap_toMatrix b₃ b₁ b₂ (Matrix.toLin b₃ b₂ A)
  rwa [LinearMap.toMatrix_toLin] at this
#align basis_to_matrix_mul basis_toMatrix_mul

theorem mul_basis_toMatrix [DecidableEq ι] [DecidableEq ι'] (b₁ : Basis ι R M) (b₂ : Basis ι' R M)
    (b₃ : Basis κ R N) (A : Matrix κ ι R) :
    A ⬝ b₁.toMatrix b₂ = LinearMap.toMatrix b₂ b₃ (toLin b₁ b₃ A) :=
  by
  have := linearMap_toMatrix_mul_basis_toMatrix b₂ b₁ b₃ (Matrix.toLin b₁ b₃ A)
  rwa [LinearMap.toMatrix_toLin] at this
#align mul_basis_to_matrix mul_basis_toMatrix

theorem basis_toMatrix_basisFun_mul (b : Basis ι R (ι → R)) (A : Matrix ι ι R) :
    b.toMatrix (Pi.basisFun R ι) ⬝ A = of fun i j => b.repr (Aᵀ j) i := by
  classical
    simp only [basis_toMatrix_mul _ _ (Pi.basisFun R ι), Matrix.toLin_eq_toLin']
    ext (i j)
    rw [LinearMap.toMatrix_apply, Matrix.toLin'_apply, Pi.basisFun_apply,
      Matrix.mulVec_stdBasis_apply, Matrix.of_apply]
#align basis_to_matrix_basis_fun_mul basis_toMatrix_basisFun_mul

/-- A generalization of `linear_map.to_matrix_id`. -/
@[simp]
theorem LinearMap.toMatrix_id_eq_basis_toMatrix [DecidableEq ι] :
    LinearMap.toMatrix b b' id = b'.toMatrix b :=
  by
  haveI := Classical.decEq ι'
  rw [← @basis_toMatrix_mul_linearMap_toMatrix _ _ ι, to_matrix_id, Matrix.mul_one]
#align linear_map.to_matrix_id_eq_basis_to_matrix LinearMap.toMatrix_id_eq_basis_toMatrix

/-- See also `basis.to_matrix_reindex` which gives the `simp` normal form of this result. -/
theorem Basis.toMatrix_reindex' [DecidableEq ι] [DecidableEq ι'] (b : Basis ι R M) (v : ι' → M)
    (e : ι ≃ ι') : (b.reindex e).toMatrix v = Matrix.reindexAlgEquiv _ e (b.toMatrix (v ∘ e)) :=
  by
  ext
  simp only [Basis.toMatrix_apply, Basis.repr_reindex, Matrix.reindexAlgEquiv_apply,
    Matrix.reindex_apply, Matrix.submatrix_apply, Function.comp_apply, e.apply_symm_apply,
    Finsupp.mapDomain_equiv_apply]
#align basis.to_matrix_reindex' Basis.toMatrix_reindex'

end Fintype

/-- A generalization of `basis.to_matrix_self`, in the opposite direction. -/
@[simp]
theorem Basis.toMatrix_mul_toMatrix {ι'' : Type _} [Fintype ι'] (b'' : ι'' → M) :
    b.toMatrix b' ⬝ b'.toMatrix b'' = b.toMatrix b'' :=
  by
  have := Classical.decEq ι
  have := Classical.decEq ι'
  haveI := Classical.decEq ι''
  ext (i j)
  simp only [Matrix.mul_apply, Basis.toMatrix_apply, Basis.sum_repr_mul_repr]
#align basis.to_matrix_mul_to_matrix Basis.toMatrix_mul_toMatrix

/-- `b.to_matrix b'` and `b'.to_matrix b` are inverses. -/
theorem Basis.toMatrix_mul_toMatrix_flip [DecidableEq ι] [Fintype ι'] :
    b.toMatrix b' ⬝ b'.toMatrix b = 1 := by rw [Basis.toMatrix_mul_toMatrix, Basis.toMatrix_self]
#align basis.to_matrix_mul_to_matrix_flip Basis.toMatrix_mul_toMatrix_flip

/-- A matrix whose columns form a basis `b'`, expressed w.r.t. a basis `b`, is invertible. -/
def Basis.invertibleToMatrix [DecidableEq ι] [Fintype ι] (b b' : Basis ι R₂ M₂) :
    Invertible (b.toMatrix b') :=
  Matrix.invertibleOfLeftInverse _ _ (Basis.toMatrix_mul_toMatrix_flip _ _)
#align basis.invertible_to_matrix Basis.invertibleToMatrix

@[simp]
theorem Basis.toMatrix_reindex (b : Basis ι R M) (v : ι' → M) (e : ι ≃ ι') :
    (b.reindex e).toMatrix v = (b.toMatrix v).submatrix e.symm id :=
  by
  ext
  simp only [Basis.toMatrix_apply, Basis.repr_reindex, Matrix.submatrix_apply, id.def,
    Finsupp.mapDomain_equiv_apply]
#align basis.to_matrix_reindex Basis.toMatrix_reindex

@[simp]
theorem Basis.toMatrix_map (b : Basis ι R M) (f : M ≃ₗ[R] N) (v : ι → N) :
    (b.map f).toMatrix v = b.toMatrix (f.symm ∘ v) :=
  by
  ext
  simp only [Basis.toMatrix_apply, Basis.map, LinearEquiv.trans_apply]
#align basis.to_matrix_map Basis.toMatrix_map

end MulLinearMapToMatrix

end BasisToMatrix


import xenalib.M1Fstuff algebra.group_power xenalib.square_root xenalib.complex
local infix ` ^ ` := monoid.pow

-- Need to start off with some fake reals to do Q1,2

constant fake_reals : Type

@[instance] constant fake_reals_comm_ring : comm_ring fake_reals
@[instance] constant fake_reals_have_lt : has_lt fake_reals
-- we define a<=b to mean a<b or a=b. Axiom 3 says that at most one occurs.
@[instance] noncomputable definition fake_reals_have_le : has_le fake_reals := ⟨λ a b, (a<b) ∨ (a=b)⟩
axiom A1 {a b t : fake_reals} : a < b → a+t < b+t
axiom A2 {a b c : fake_reals} : a < b → b < c → a < c
axiom A3 {a b : fake_reals} : (a < b ∨ a = b ∨ b < a)
                                   ∧ (a < b → ¬ (a = b))
                                   ∧ (a < b → ¬ (b < a))
                                   ∧ (a = b → ¬ (b < a))
axiom A4 {a b : fake_reals} : a > 0 → b > 0  → (a*b) > 0

axiom A0 : (0 : fake_reals) ≠ (1 : fake_reals)

theorem one_pos : (1:fake_reals) > 0 :=
begin
cases (@A3 0 1).left with H1pos H1nonpos,
  assumption,
cases H1nonpos with H1zero H1neg,
  exfalso,
  exact A0 H1zero,
have H : (1:fake_reals) + (-1) < 0 + (-1),
  exact A1 H1neg,
  rw [add_neg_self,zero_add] at H,
have H2 : (-1:fake_reals) * (-1) > 0,
  exact A4 H H,
rw [←neg_eq_neg_one_mul] at H2,
-- exact H2, -- oops
rw [neg_neg] at H2,
exact H2,
end

section M1F_Sheet03

-- set_option pp.all true

theorem Q1 : ∀ x y : fake_reals, 0<x ∧ 0<y → 0<(x+y) :=
begin
intros x y Hxy,
have H : y < x+y := calc
y = 0 + y : by simp [zero_add]
... < x+y : A1 Hxy.left,
exact A2 Hxy.right H,
end

theorem n_pos : ∀ n : ℕ, n ≠ 0 → (n : fake_reals) > 0 :=
begin
intro n,
cases n with m,
  by norm_num,
induction m with p Hp,
  intro,rw [nat.cast_one],
  exact one_pos,
have H0 : nat.succ p ≠ 0,
  intro H,
  exact nat.no_confusion H,
have H1 : ↑(nat.succ p) > (0:fake_reals),
  exact Hp H0,
intro H,clear Hp H0 H,
  rw [nat.succ_eq_add_one,nat.cast_add,nat.cast_one],
  exact Q1 (nat.succ p) 1 ⟨H1,one_pos⟩,
end
-- a) We proved in lectures that if x > y and c > 0 then cx > cy. Deduce from this that the
-- product of a positive number and a negative number is negative.

-- #check @lt_of_sub_pos

theorem mul_pos_lt_of_lt {x y c : fake_reals} : (y < x) → (0 < c) → c*y < c*x :=
begin
intros Hx_gt_y Hc_gt_zero,
have Hsub_gt_zero : 0 < (x-y),
  rw [sub_eq_add_neg,←(add_neg_self y)],
  exact A1 Hx_gt_y, -- is apply OK to finish a goal?
have H2 : c*(x-y) > 0 := A4 Hc_gt_zero Hsub_gt_zero,
rw [mul_sub,sub_eq_add_neg] at H2,
have H3 : c*x + -(c*y)+c*y>0+c*y := A1 H2,
rwa [zero_add,add_assoc,neg_add_self,add_zero] at H3,
end

theorem Q2a {x y : fake_reals} : (x > 0) → (y < 0) → x * y < 0 :=
begin
intros Hx_gt_0 Hy_lt_0,
have H : x*0 > x*y := mul_pos_lt_of_lt Hy_lt_0 Hx_gt_0,
rwa [mul_zero] at H,
end

theorem neg_pos_of_neg' {x : fake_reals} : x < 0 → -x > 0 :=
begin
intro Hx_neg,
  have H : x + (-x) < 0 + (-x) := A1 Hx_neg,
  rwa [add_neg_self,zero_add] at H,
end

theorem neg_eq_neg_one_mul' {x : fake_reals} : -x = (-1)*x :=
neg_eq_neg_one_mul x

theorem neg_one_squared : (-1:fake_reals)*(-1)=1 :=
calc (-1:fake_reals)*(-1)=-(-1) : eq.symm (@neg_eq_neg_one_mul' (-1))
... = 1 : neg_neg 1

theorem pos_eq_neg_mul_neg {x y : fake_reals} : x < 0 → y < 0 → x * y > 0 :=
begin
intros Hxneg Hyneg,
have Hneg_x_pos : -x > 0 := neg_pos_of_neg' Hxneg,
have Hneg_y_pos : -y > 0 := neg_pos_of_neg' Hyneg,
exact calc x * y = -x * -y : by rw [neg_eq_neg_one_mul',@neg_eq_neg_one_mul' y,←mul_one (x * y),←neg_one_squared];simp
... > 0 : A4 Hneg_x_pos Hneg_y_pos,
end

theorem Q2b {x y : fake_reals} : x < 0 → y < 0 → x * y > 0 := pos_eq_neg_mul_neg

theorem zero_not_pos : ¬ ((0:fake_reals) < 0) := (@A3 0 0).right.right.right (rfl)

theorem fake_reals_integral_domain {x y : fake_reals} : x * y = 0 → x = 0 ∨ y = 0 :=
begin
intro Hxy_zero,
cases (@A3 0 x).left with Hx_pos Hx_nonpos,
  cases (@A3 0 y).left with Hy_pos Hy_nonpos,
    exfalso,
    exact zero_not_pos (calc 0 < x * y : A4 Hx_pos Hy_pos ... = 0 : Hxy_zero),
  cases Hy_nonpos with Hy_0 Hy_neg,
    right,exact eq.symm Hy_0,
  exfalso,
  apply zero_not_pos,
  exact calc 0 = x*y : eq.symm Hxy_zero ... <0 : Q2a Hx_pos Hy_neg,
cases Hx_nonpos with Hx_0 Hx_neg,
  left,exact eq.symm Hx_0,
cases (@A3 0 y).left with Hy_pos Hy_nonpos,
  exfalso,
  apply zero_not_pos,
  exact calc 0=x*y : eq.symm Hxy_zero ... = y*x : by rw[mul_comm] ... <0 : Q2a Hy_pos Hx_neg,
cases Hy_nonpos with Hy_0 Hy_neg,
  right,exact eq.symm Hy_0,
exfalso, apply zero_not_pos,
exact calc 0 < x * y : Q2b Hx_neg Hy_neg ... = 0 : Hxy_zero,
end

theorem Q2c : ∀ x y : fake_reals, x * y = 0 → x = 0 ∨ y = 0 :=
@fake_reals_integral_domain

end M1F_Sheet03

axiom A5 : ∀ x : fake_reals, x > 0 → ∃ y : fake_reals,
                 y > 0 ∧ y*y=x ∧ ∀ z : fake_reals, z > 0 ∧ z*z=x → z=y

section M1F_Sheet03

theorem Q2d : ∀ x : fake_reals, x > 0 → ∃ z1 z2 : fake_reals, z1*z1=x ∧ z2*z2=x ∧ ∀ z : fake_reals, z*z=x → z=z1 ∨ z=z2 :=
begin
intros x Hx_pos,
have H : ∃ (y : fake_reals), y > 0 ∧ y * y = x ∧ ∀ (z : fake_reals), z > 0 ∧ z * z = x → z = y,
  exact A5 x Hx_pos,
cases H with y Hy,
existsi y,
existsi -y,
split,
  exact Hy.right.left,
split,
  rw [neg_mul_neg],
  exact Hy.right.left,
intro z,
intro Hz2,
have Hz2_eq_y2 : z*z = y*y := eq.symm Hy.right.left ▸ Hz2,
have Hcases : (0 < z ∨ 0 = z ∨ z < 0) := (@A3 0 z).left,
cases Hcases with Hz_neg Hz_nonneg,
  left,
  exact Hy.right.right z ⟨Hz_neg,Hz2⟩,
cases Hz_nonneg with Hz_0 Hz_pos,
  exfalso,
  rw [←Hz_0,mul_zero] at Hz2,
  rw [←Hz2] at Hx_pos,
  revert Hx_pos,
  exact zero_not_pos,
right,
apply eq.symm,
apply neg_eq_iff_neg_eq.1,
apply Hy.right.right,
split,
  have H : z + (-z) < 0 + (-z) := A1 Hz_pos,
  rwa [add_neg_self,zero_add] at H,
simp [Hz2],
end

end M1F_Sheet03

axiom A6 : ∀ n : ℕ, n > 0 →
             ∀ x : fake_reals, x > 0 →
               ∃ y : fake_reals,
                 y > 0
                ∧ y ^ n = x
                ∧ ∀ z : fake_reals, z > 0 ∧ z ^ n = x → z = y

section M1F_Sheet03

-- some definitions before Q3a

theorem three_not_zero : (3:ℕ) ≠ 0 := by norm_num
theorem two_not_zero : (2:ℕ) ≠ 0 := by norm_num

-- set_option pp.notation false

theorem pow_pos_of_pos (x : fake_reals) (n : ℕ) : (0 < x) → (0 < n) → 0 < x^n :=
begin
intros Hx_pos Hn_pos,
cases n with m,
  revert Hn_pos,norm_num,
clear Hn_pos,
induction m with p Hp,
  simp [Hx_pos,monoid.pow],
exact A4 Hx_pos Hp,
end

theorem pow_lt_of_lt (x y : fake_reals) (n : ℕ) : (0 < x) → (x < y) → (0 < n) → x ^ n < y^n :=
begin
intros Hx_pos Hx_lt_y Hn_pos,
cases n with m,
  exfalso, revert Hn_pos,norm_num,
induction m with p Hp,
  simp [Hx_lt_y,monoid.pow],
have H : x^ nat.succ p < y^nat.succ p := Hp (nat.zero_lt_succ p),
clear Hp Hn_pos,
change x ^ nat.succ (nat.succ p) with x * (x^nat.succ p),
change y ^ nat.succ (nat.succ p) with y * (y^nat.succ p),

have H1: x * (x ^ nat.succ p) < y * (x ^ nat.succ p) := calc
x * (x ^ nat.succ p) = (x ^ nat.succ p) * x : by rw [mul_comm]
... < (x ^ nat.succ p) * y : mul_pos_lt_of_lt Hx_lt_y (pow_pos_of_pos x (nat.succ p) Hx_pos (nat.zero_lt_succ p))
... = y * (x ^ nat.succ p) : by rw [mul_comm],

have H2 : y * (x ^ nat.succ p) < y * (y ^ nat.succ p) := mul_pos_lt_of_lt H (A2 Hx_pos Hx_lt_y),

exact A2 H1 H2
end

def n:ℕ := 1000000000000

def t3_stuff := A6 3000000000000 (by norm_num) ↑3 (n_pos 3 (three_not_zero))
def t2_stuff := A6 2000000000000 (by norm_num) ↑2 (n_pos 2 (two_not_zero))
noncomputable def t2 := classical.some t2_stuff
noncomputable def t3 := classical.some t3_stuff
def t2_facts := classical.some_spec t2_stuff
def t3_facts := classical.some_spec t3_stuff

theorem Q3a : t3 > t2 := -- these are both fake reals.
begin
have H3 : t3 ^ (6*n) = ↑9,
  change 6 with 2*3,
  rw [mul_assoc,mul_comm,pow_mul],
  have H3trill : 3*n=3000000000000 := by change n with 1000000000000;norm_num,
  have Htemp : t3 ^ (3*n) = ↑3,
    rw [H3trill],
    exact t3_facts.right.left,
  rw [Htemp],
  norm_num,
have H2 : t2 ^ (6*n) = ↑8,
  change 6 with 3*2,
  rw [mul_assoc,mul_comm,pow_mul],
  have H2trill : 2*n=2000000000000 := by change n with 1000000000000;norm_num,
  have Htemp : t2 ^ (2*n) = ↑2,
    rw [H2trill],
    exact t2_facts.right.left,
  rw [Htemp],
  norm_num,
have Hlt : t2 ^ (6*n) < t3 ^ (6*n),
  rw [H2,H3],
  change 8 with 0+8,
  change 9 with 1+8,
  rw [nat.cast_add,nat.cast_add,nat.cast_zero,nat.cast_one],
  exact A1 one_pos,
clear H2 H3,
have Hneq : ¬ (t2^(6*n) = t3^(6*n)),
  exact A3.right.left Hlt,
have Hngt : ¬ (t2^(6*n) > t3^(6*n)),
  exact A3.right.right.left Hlt,
cases (@A3 t2 t3).left with Hlt Hge,
  exact Hlt,
exfalso,
cases Hge with Heq Hgt,
  rw Heq at Hneq,
  apply Hneq,
  trivial,
apply Hngt,
apply pow_lt_of_lt,
    exact t3_facts.left,
  exact Hgt,
apply mul_pos,
  norm_num,
change n with 1000000000000,
norm_num,
end

-- I've done the next two parts with integers, on the basis that
-- inequality on the reals extends inequality on the integers.

-- ambiguous overload for power ^ symbol :-(
-- Could mean nat.pow or pow_nat.

-- Here's something that's in core lean for nat.pow
-- and we need for pow_nat.

--#print nat.pow_eq_pow

--#print nat.pow_eq_pow_nat

theorem pow_lt_pow_of_lt {x i j : ℕ} : x > 1 → i < j → x^i < x^j :=
begin
rw [←nat.pow_eq_pow,←nat.pow_eq_pow],
intro H,
exact nat.pow_lt_pow_of_lt_right H,
end

theorem Q3b : 10000^100 < 100^10000 :=
begin
have H : 10000 = 100^2,
  { norm_num },
have H2 : 10000^100=(100^2)^100,
  rw [H],
rw [H2,←pow_mul],
have H3 : 2*100 = 200,
  { norm_num},
rw [H3],
apply pow_lt_pow_of_lt,
  { norm_num },
norm_num,
end

theorem Q3ci : (2^11)^2 = 2^22 :=
begin
rw [←pow_mul],
change 11*2 with 22,
trivial,
end

theorem Q3cii : (2^(2^21))^2 = 2^(2^22) :=
begin
rw [←pow_mul],
suffices H : 2^22 = (2^21) * 2,
  rw [H],
change 22 with 21+1,
rw [pow_add],
change 2^1 with 2,
trivial,
end

-- set_option pp.notation false

universe u

theorem lt_iff_sub_neg {α : Type} [ordered_comm_group α] {a b : α} :
   a - b < 0 ↔  a < b := ⟨lt_of_sub_neg,sub_neg_of_lt⟩

theorem Q4 : { x : ℝ | x ≠ 0 ∧ 3*x + 1/x < 4 } = {x : ℝ | x<0 ∨ ( ((1:ℝ)/3)<x ∧ x<1) } :=
begin
apply funext,
intro x,
apply propext,
-- unfolded goal is x ≠ 0 ∧ 3 * x + 1 / x < 4 ↔ x < 0 ∨ 1 / 3 < x ∧ x < 1
-- I should now prove 3x+1/x-4 = (3x^2-1-4x)/x=(3x-1)(x-1)/x
have Hkey : x ≠ 0 → 3*x+1/x-4 = (3*x-1)*(x-1)/x,
  have Htemp : (4:ℝ)=(3:ℝ)+(1:ℝ) := by norm_num,
  rw [Htemp],
  intro Hx_ne_0,
  apply eq_div_of_mul_eq _ _ Hx_ne_0,
  simp [Hx_ne_0,mul_add,add_mul],
/- is this useful?
have Hx_squared_pos : 0 < x*x,
    cases lt_or_gt_of_ne H.left with Hx_lt_0 Hx_gt_0,
      exact mul_pos_of_neg_of_neg Hx_lt_0 Hx_lt_0,
    exact mul_pos Hx_gt_0 Hx_gt_0,
-/
have H : 3*x+1/x-4<0 ↔ 3*x+1/x<4,
  exact lt_iff_sub_neg,
unfold set_of,
rw [←H],
split,
  intro Hleft,
  have Hx_ne_0 := Hleft.left,
  have Hx_eq := Hleft.right,
  clear Hleft,
  rw [Hkey Hx_ne_0] at Hx_eq,
  cases lt_or_ge x 0 with Hx_lt_0 Hx_ge_0,
    left,assumption,
  right,
  have Hx_gt_0 := lt_of_le_of_ne Hx_ge_0 (ne.symm Hx_ne_0),
  clear Hx_ge_0,
  cases lt_or_ge ((1:ℝ)/3) x with H1 H2,
    split,exact H1,
    have H2 := mul_neg_of_neg_of_pos Hx_eq Hx_gt_0,
    rw [div_eq_mul_inv,mul_assoc,(inv_mul_cancel Hx_ne_0),mul_one] at H2,
    have H3 : 3*x>1 :=
      calc 3*x>3*(1/3) : mul_lt_mul_of_pos_left H1 (by norm_num)
      ...          =1 : by norm_num,
    have H4 : 3*x-1>0 :=
      calc 3*x-1 > 1-1 : (sub_lt_sub_iff_right _).2 _
           ... =0 : by simp,
    have H5 : x-1<0 := neg_of_mul_neg_left H2 (le_of_lt H4),
    rwa [lt_iff_sub_neg] at H5,
    exact H3,
  exfalso,
  have H3 : 3*x ≤ 3*(1/3) := (mul_le_mul_left (by norm_num)).2 H2,
  rw [one_div_eq_inv,@mul_inv_cancel ℝ _ 3 (by norm_num)] at H3,
  have H4 : 3*x-1 ≤ 0 := sub_nonpos_of_le H3,
  have H5 : x-1 < 0 := calc x-1 ≤ (1/3)-1 : (sub_le_sub_iff_right 1).2 H2
    ... < 0 : by norm_num,
  have H6: (3*x-1)*(x-1) ≥ 0 := mul_nonneg_of_nonpos_of_nonpos H4 (le_of_lt H5),
  exact not_le_of_gt Hx_eq (div_nonneg_of_nonneg_of_pos H6 Hx_gt_0),
intro H2,
cases H2 with H3 H3,
  have Hx_ne_0 := ne_of_lt H3,
  split,
    assumption,
  rw [Hkey Hx_ne_0],
  apply div_neg_of_pos_of_neg _ H3,
  apply mul_pos_of_neg_of_neg,
    apply sub_neg_of_lt,
    exact calc 3*x<0 : mul_neg_of_pos_of_neg (by norm_num) H3
    ... < 1 : zero_lt_one,
  apply sub_neg_of_lt,
  exact calc x<0 : H3
    ... < 1 : zero_lt_one,
have Hx_gt_0 : 0 < x := calc (0:ℝ) < 1/3 : by norm_num ... < x: H3.left,
split, exact ne_of_gt Hx_gt_0,
rw [Hkey (ne_of_gt Hx_gt_0)],
apply div_neg_of_neg_of_pos _ Hx_gt_0,
have H4 := H3.left,
rw [one_div_eq_inv] at H4,
have H4 := mul_lt_mul_of_pos_right H4 _,
  rw [inv_mul_cancel] at H4,
    apply mul_neg_of_pos_of_neg,
      rw [mul_comm] at H4,
      exact sub_pos_of_lt H4,
    exact sub_neg_of_lt H3.right,
  repeat {norm_num},
end

theorem Q5a (t x:ℝ) (H:t>0) : abs x < t ↔ -t < x ∧ x < t :=
begin
exact abs_lt,
end

theorem Q5b (x:ℝ) : abs(x+1)<3 ↔ -4<x ∧ x<2 :=
begin
rw [abs_lt],
split;intro H;split,
  have H2 :-(4:ℝ) = -3 - 1 := by norm_num,
  rw H2,
  simp [H.left],

  have H2 : (2:ℝ) = 3 - 1 := by norm_num,
  rw H2,
  simp [H.right],

  have H2 : -(3:ℝ) = -4 + 1 := by norm_num,
  rw H2,
  exact (add_lt_add_iff_right 1).2 H.left,

  have H2 : (3:ℝ) = 2 + 1 := by norm_num,
  rw H2,
  exact (add_lt_add_iff_right 1).2 H.right,
end

theorem Q5c (x:ℝ) : abs (x-2) < abs (x-4) ↔ x < 3 :=
begin
split,
  intro H,
  cases lt_or_ge x 4 with H2 H2,
    rw [abs_of_neg (sub_neg_of_lt H2)] at H,
    have H3 : x-2 < -(x-4) := calc x-2 ≤ abs (x-2) : le_abs_self (x-2) ... < -(x-4) : H,
    rw [neg_sub] at H3,
    have H4 := sub_neg_of_lt H3,
    rw [sub_sub,add_sub] at H4,
    have H5 : (2:ℝ)+4=6 := by norm_num,
    rw [H5,←sub_add,sub_add_eq_add_sub,←two_mul,lt_iff_sub_neg] at H4,
    have H6 : 2⁻¹ * (2*x) < 2⁻¹ * 6 := mul_lt_mul_of_pos_left H4 (by norm_num),
    norm_num at H6,
    exact H6,
  exfalso,
  have H3 : x-2 < x-2 := calc
  x-2 ≤ abs(x-2) : le_abs_self (x-2)
  ... < abs(x-4) : H
  ... = x-4 : abs_of_nonneg (_)
  ... < x-2 : (sub_lt_sub_iff_left x).2 _,
      exact lt_irrefl (x-2) H3,
    exact sub_nonneg_of_le H2,
  { norm_num },
intro Hx_lt_3,
suffices : abs (x-2) < 4-x,
  apply lt_of_lt_of_le this,
  rw [←neg_sub x 4],
  exact neg_le_abs_self (x-4),
apply (abs_lt).2,
split,
  rw [neg_sub],
  exact (sub_lt_sub_iff_left x).2 (by norm_num),
  apply @lt_trans _ _ (x-2) 1 (4-x),
  exact calc _ < 3-2 : (sub_lt_sub_iff_right (2:ℝ)).2 Hx_lt_3
  ... =1 : by norm_num,
apply lt_of_sub_pos,
have := sub_pos_of_lt Hx_lt_3,
have H : (4:ℝ)=3+1 := by norm_num,
rw [H],
suffices H2 : 3+1-x-1 = 3-x,
  rw [H2],
  assumption,
simp,
end

-- probably these should be done with "fake complexes", defined
-- using addition and multiplication on R^2. But given that I
-- just actually wrote a proper implementation of the complexes
-- in Lean, I am just going to use them, but still give the
-- proofs which I was looking for rather than just noting that
-- Lean knows complexes are associative etc.

theorem Q6a : ∀ p q r : complex, (p+q)+r=p+(q+r) :=
begin
intros,
apply complex.eq_of_re_eq_and_im_eq,
split,
  repeat {rw [complex.proj_add_re]},
  exact @add_assoc ℝ _ _ _ _,
repeat {rw [complex.proj_add_im]},
exact @add_assoc ℝ _ _ _ _,
end

theorem Q6b : ∀ p q : complex, p*q=q*p :=
begin
intros,
apply complex.eq_of_re_eq_and_im_eq,
repeat {rw [complex.proj_mul_re,complex.proj_mul_im]},
split;simp,
end

theorem Q6c : ∀ p q : complex, complex.conjugate p * complex.conjugate q = complex.conjugate (p*q) :=
begin
intros,
unfold complex.conjugate,
apply complex.eq_of_re_eq_and_im_eq,
repeat {rw [complex.proj_mul_re,complex.proj_mul_im]},
simp,
end

theorem Q7 (z : complex) (H : z^2=-1) : z=complex.I ∨ z = -complex.I :=
begin
rw [pow_two_eq_mul_self] at H,
have Him : (z*z).im = 0,
  rw [H],
  rw [complex.proj_neg_im,complex.proj_one_im,neg_zero],
have Hre : (z*z).re = -1,
  rw [H],
  rw [complex.proj_neg_re,complex.proj_one_re],
rw [complex.proj_mul_im,mul_comm,←two_mul,mul_eq_zero] at Him,
cases Him with Hfalse Him,
  revert Hfalse,norm_num,
rw [mul_eq_zero] at Him,
rw [complex.proj_mul_re] at Hre,
cases Him with Hfalse Htrue,
  rw [Hfalse,mul_zero,sub_zero] at Hre,
  have : -(1:ℝ)≥0 := calc -1 = z.re*z.re : eq.symm Hre ... ≥ 0 : mul_self_nonneg _,
  norm_num at this,
rw [Htrue] at Hre,
have H1 : z.im*z.im=1, simpa using Hre,
have H2 : z.im = 1 ∨ z.im = -1 := (mul_self_eq_one_iff z.im).1 H1,
cases H2 with Hi Hmi,
  left,rw [complex.eq_iff_re_eq_and_im_eq,Htrue,Hi],split;refl,
  right,rw [complex.eq_iff_re_eq_and_im_eq,Htrue,Hmi],split;
    simp [complex.proj_neg_re,complex.proj_neg_im,complex.proj_I_re,complex.proj_I_im],
end

end M1F_Sheet03


import algebra.module.localized_module

section algebra

lemma is_localized_module.mk_of_algebra {R S S' : Type*} [comm_ring R] [comm_ring S] [comm_ring S']
  [algebra R S] [algebra R S'] (M : submonoid R) (f : S →ₐ[R] S')
  (h₁ : ∀ x ∈ M, is_unit (algebra_map R S' x))
  (h₂ : ∀ y, ∃ (x : S × M), x.2 • y = f x.1)
  (h₃ : ∀ x, f x = 0 → ∃ m : M, m • x = 0) :
  is_localized_module M f.to_linear_map :=
begin
  replace h₃ := λ x, iff.intro (h₃ x) (λ ⟨⟨m, hm⟩, e⟩, (h₁ m hm).mul_left_cancel $
    by { rw ← algebra.smul_def, simpa [submonoid.smul_def] using f.congr_arg e }),
  constructor,
  { intro x,
    rw module.End_is_unit_iff,
    split,
    { rintros a b (e : x • a = x • b), simp_rw [submonoid.smul_def, algebra.smul_def] at e,
      exact (h₁ x x.2).mul_left_cancel e },
    { intro a, refine ⟨((h₁ x x.2).unit⁻¹ : _) * a, _⟩, change (x : R) • (_ * a) = _,
      rw [algebra.smul_def, ← mul_assoc, is_unit.mul_coe_inv, one_mul] } },
  { exact h₂ },
  { intros, dsimp, rw [eq_comm, ← sub_eq_zero, ← map_sub, h₃], simp_rw [smul_sub, sub_eq_zero] },
end

end algebra

namespace is_localized_module

universes u v
variables {R : Type*} [comm_ring R] (S : submonoid R)
variables {M M' M'' : Type*} [add_comm_monoid M] [add_comm_monoid M'] [add_comm_monoid M'']
variables [module R M] [module R M'] [module R M''] (f : M →ₗ[R] M') (g : M →ₗ[R] M'')

variable [is_localized_module S f]

@[simp]
lemma iso_mk (m : M) (s : S) :
  is_localized_module.iso S f (localized_module.mk m s) = is_localized_module.mk' f m s :=
rfl

@[simp]
lemma iso_symm_mk' (m : M) (s : S) :
  (is_localized_module.iso S f).symm (is_localized_module.mk' f m s) = localized_module.mk m s :=
(is_localized_module.iso S f).symm_apply_apply (localized_module.mk m s)

@[simp]
lemma iso_mk' (m : M) (s : S) :
  is_localized_module.iso S f (is_localized_module.mk' (localized_module.mk_linear_map S M) m s) =
    is_localized_module.mk' f m s :=
by rw [← is_localized_module.mk_eq_mk', iso_mk]

local attribute [-simp] iso_symm_apply

@[simp]
lemma lift_mk' (g : M →ₗ[R] M'')
  (h : ∀ (x : S), is_unit ((algebra_map R (module.End R M'')) x)) (m : M) (s : S) :
  (is_localized_module.lift S f g h) (is_localized_module.mk' f m s) = (h s).unit⁻¹ (g m) :=
by { delta is_localized_module.lift, dsimp,
  rw [is_localized_module.iso_symm_mk', localized_module.lift_mk], refl }

end is_localized_module

section submodule

universes u v
variables {R : Type*} [comm_ring R] (S : submonoid R)
variables {M M' M'' : Type*} [add_comm_monoid M] [add_comm_monoid M'] [add_comm_monoid M'']
variables [module R M] [module R M'] [module R M''] (f : M →ₗ[R] M') (g : M →ₗ[R] M'')

variable [is_localized_module S f]

variable (N : submodule R M)

/-- The localization of a submodule of `M` in `localized_module S M`. -/
def submodule.localize : submodule (localization S) (localized_module S M) :=
{ carrier := { x | ∃ (y ∈ N) s, localized_module.mk y s = x },
  add_mem' := begin
    rintros _ _ ⟨x, hx, s, rfl⟩ ⟨x', hx', s', rfl⟩,
    refine ⟨_, _, _, localized_module.mk_add_mk⟩,
    apply add_mem; apply submodule.smul_mem; assumption
  end,
  zero_mem' := ⟨_, zero_mem _, _, rfl⟩,
  smul_mem' := begin
    rintros r _ ⟨x, hx, s, rfl⟩,
    induction r using localization.induction_on,
    exact ⟨_, N.smul_mem _ hx, _, rfl⟩,
  end }

variables {S N}

lemma submodule.mem_localize_of_mem {x : M} (hx : x ∈ N) (s : S) :
  localized_module.mk x s ∈ N.localize S :=
⟨_, hx, _, rfl⟩

variables (S N)

lemma submodule.localize_eq_span :
  N.localize S = submodule.span (localization S) (N.map $ localized_module.mk_linear_map S M) :=
begin
  apply le_antisymm,
  { rintro _ ⟨x, hx, s, rfl⟩,
    rw [← mul_one s, ← one_smul R x, ← localized_module.mk_smul_mk],
    exact submodule.smul_mem _ (localization.mk (1 : R) s)
      (submodule.subset_span $ submodule.mem_map_of_mem hx) },
  { rw submodule.span_le,
    rintros _ ⟨x, hx, rfl⟩,
    exact submodule.mem_localize_of_mem hx _ }
end

lemma submodule.localize_span (s : set M) :
  (submodule.span R s).localize S =
    submodule.span (localization S) (localized_module.mk_linear_map S M '' s) :=
by rw [submodule.localize_eq_span, submodule.map_span, submodule.span_span_of_tower]

@[simp]
lemma submodule.localize_bot : (⊥ : submodule R M).localize S = ⊥ :=
by rw [← submodule.span_empty, submodule.localize_span, set.image_empty, submodule.span_empty]

@[simp]
lemma submodule.localize_top : (⊤ : submodule R M).localize S = ⊤ :=
begin
  rw eq_top_iff,
  rintros x -,
  induction x using localized_module.induction_on,
  exact submodule.mem_localize_of_mem trivial _
end

end submodule

section base_change

variables {R : Type*} [comm_ring R] (S : submonoid R)
variables {M M' M'' : Type*} [add_comm_monoid M] [add_comm_monoid M'] [add_comm_monoid M'']
variables [module R M] [module R M'] [module R M''] (f : M →ₗ[R] M') (g : M →ₗ[R] M'')
variables (R' : Type*) [comm_ring R'] [algebra R R'] [is_localization S R']
variables [module R' M'] [is_scalar_tower R R' M'] [module R' M''] [is_scalar_tower R R' M'']

/-- If `M''` is an `S⁻¹R` module, then any `M →ₗ[R] M''` can be lifted to `S⁻¹M →ₗ[S⁻¹R] M''`. -/
noncomputable
def is_localized_module.base_change [is_localized_module S f] (g : M →ₗ[R] M'') : M' →ₗ[R'] M'' :=
begin
  have : ∀ (x : S), is_unit (algebra_map R (module.End R M'') ↑x),
  { intro x,
    have := (is_localization.map_units R' x).map (algebra_map R' (module.End R' M'')),
    rw module.End_is_unit_iff at this ⊢,
    convert this using 1,
    ext n,
    exact (algebra_map_smul _ _ _).symm },
  refine { map_smul' := _, ..is_localized_module.lift S f g this },
  { intros r x,
    obtain ⟨⟨r', s⟩, e⟩ := is_localization.surj S r,
    obtain ⟨⟨x, t⟩, rfl⟩ := is_localized_module.mk'_surjective S f x,
    simp_rw module.End_is_unit_iff at this,
    apply (this s).injective,
    dsimp at e ⊢,
    rw [mul_comm, ← algebra.smul_def] at e,
    rw [← smul_assoc, e, algebra_map_smul, ← linear_map.map_smul, ← linear_map.map_smul,
      ← smul_assoc, e, algebra_map_smul] }
end

lemma _root_.is_localization.smul_mk' (r s : R) (m : S) :
  r • is_localization.mk' R' s m = is_localization.mk' R' (r * s) m :=
by rw [algebra.smul_def, is_localization.mul_mk'_eq_mk'_of_mul]

@[simp]
lemma is_localized_module.base_change_mk' [is_localized_module S f] (g : M →ₗ[R] M'') (m) (s : S) :
    is_localized_module.base_change S f R' g (is_localized_module.mk' f m s) =
      (is_localization.mk' R' 1 s) • (g m) :=
begin
  dsimp [is_localized_module.base_change],
  rw [is_localized_module.lift_mk', module.End_algebra_map_is_unit_inv_apply_eq_iff,
    ← smul_assoc, is_localization.smul_mk', is_localization.mk'_mul_cancel_left, map_one, one_smul],
end

variable (M'')

/-- `is_localized_module.base_change` as an `R`-linear map. -/
@[simps]
noncomputable
def is_localized_module.base_change_linear_map [is_localized_module S f] :
  (M →ₗ[R] M'') →ₗ[R] M' →ₗ[R'] M'' :=
{ to_fun := is_localized_module.base_change S f R',
  map_add' := begin
    intros g₁ g₂,
    ext x,
    obtain ⟨⟨x, t⟩, rfl⟩ := is_localized_module.mk'_surjective S f x,
    dsimp,
    simp only [is_localized_module.base_change_mk', linear_map.add_apply, smul_add],
  end,
  map_smul' := begin
    intros r g,
    ext x,
    obtain ⟨⟨x, t⟩, rfl⟩ := is_localized_module.mk'_surjective S f x,
    dsimp,
    simp only [is_localized_module.base_change_mk', linear_map.smul_apply],
    rw smul_comm,
  end }
.

local notation `S⁻¹R` := localization S
local notation `S⁻¹` := localized_module S

/-- `S⁻¹M →ₗ[S⁻¹R] S⁻¹M'`, the localization of a linear_map `M →ₗ[R] M'`. -/
noncomputable
def localized_module.map :
  (M →ₗ[R] M') →ₗ[R] S⁻¹ M →ₗ[S⁻¹R] S⁻¹ M' :=
  ((is_localized_module.base_change_linear_map S (S⁻¹ M')
    (localized_module.mk_linear_map S M) S⁻¹R).comp (linear_map.comp_right $
      localized_module.mk_linear_map S M'))

alias is_localized_module.mk_eq_mk' ← localized_module.mk_eq_mk'

@[simp]
lemma localized_module.map_mk (x : M) (m : S) :
  localized_module.map S f (localized_module.mk x m) =
    localized_module.mk (f x) m :=
begin
  dsimp [localized_module.map],
  rw [localized_module.mk_eq_mk', is_localized_module.base_change_mk'],
  dsimp,
  rw [ ← localization.mk_eq_mk', localized_module.mk_smul_mk, one_smul, mul_one],
end

@[simp]
lemma localized_module.map_id :
  localized_module.map S (linear_map.id : M →ₗ[R] M) = linear_map.id :=
begin
  apply linear_map.ext,
  intro x,
  induction x using localized_module.induction_on,
  exact localized_module.map_mk _ _ _ _
end

@[simp]
lemma localized_module.map_comp (g : M' →ₗ[R] M'') :
  localized_module.map S (g.comp f) =
    (localized_module.map S g).comp (localized_module.map S f) :=
begin
  apply linear_map.ext,
  intro x,
  induction x using localized_module.induction_on,
  simp,
end

lemma submodule.localize_comap_map {N' : submodule R M'} :
  (N'.localize S).comap (localized_module.map S f) = (N'.comap f).localize S :=
begin
  apply le_antisymm,
  { rintros x ⟨x', hx, r, e⟩,
    induction x using localized_module.induction_on with x s,
    simp_rw [localized_module.map_mk, localized_module.mk_eq, submonoid.smul_def, ← f.map_smul,
      smul_smul] at e,
    obtain ⟨u, e⟩ := e,
    refine ⟨(u * r : R) • x, _, u * r * s, _⟩,
    { dsimp, rw e, exact N'.smul_mem _ hx },
    { rw [← submonoid.coe_mul, ← submonoid.smul_def],
      exact localized_module.mk_cancel_common_left _ _ _ } },
  { rintros _ ⟨x, hx, s, rfl⟩, dsimp, rw localized_module.map_mk,
    exact submodule.mem_localize_of_mem hx _ }
end

lemma submodule.localize_map_map {N : submodule R M} :
  (N.localize S).map (localized_module.map S f) = (N.map f).localize S :=
begin
  apply le_antisymm,
  { rintros _ ⟨_, ⟨x, hx, s, rfl⟩, rfl⟩,
    rw [localized_module.map_mk],
    exact submodule.mem_localize_of_mem (submodule.mem_map_of_mem hx) _ },
  { rintros _ ⟨_, ⟨x, hx, rfl⟩, s, rfl⟩, rw ← localized_module.map_mk,
    exact submodule.mem_map_of_mem (submodule.mem_localize_of_mem hx _) }
end

end base_change


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.fin_category
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.wide_pullbacks
import category_theory.limits.shapes.pullbacks
import data.fintype.option

/-!
# Categories with finite limits.

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

A typeclass for categories with all finite (co)limits.
-/

universes w' w v' u' v u

noncomputable theory

open category_theory

namespace category_theory.limits

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

/--
A category has all finite limits if every functor `J ⥤ C` with a `fin_category J`
instance and `J : Type` has a limit.

This is often called 'finitely complete'.
-/
-- We can't just made this an `abbreviation`
-- because of https://github.com/leanprover-community/lean/issues/429
class has_finite_limits : Prop :=
(out (J : Type) [𝒥 : small_category J] [@fin_category J 𝒥] : @has_limits_of_shape J 𝒥 C _)

@[priority 100]
instance has_limits_of_shape_of_has_finite_limits
  (J : Type w) [small_category J] [fin_category J] [has_finite_limits C] :
  has_limits_of_shape J C :=
begin
  apply has_limits_of_shape_of_equivalence (fin_category.equiv_as_type J),
  apply has_finite_limits.out
end

@[priority 100]
instance has_finite_limits_of_has_limits_of_size [has_limits_of_size.{v' u'} C] :
  has_finite_limits C :=
⟨λ J hJ hJ', by { haveI := has_limits_of_size_shrink.{0 0} C,
  exact has_limits_of_shape_of_equivalence (fin_category.equiv_as_type J) }⟩

/-- If `C` has all limits, it has finite limits. -/
@[priority 100]
instance has_finite_limits_of_has_limits [has_limits C] : has_finite_limits C :=
infer_instance

/-- We can always derive `has_finite_limits C` by providing limits at an
arbitrary universe. -/
lemma has_finite_limits_of_has_finite_limits_of_size
  (h : ∀ (J : Type w) {𝒥 : small_category J} (hJ : @fin_category J 𝒥),
    by { resetI, exact has_limits_of_shape J C }) :
  has_finite_limits C :=
⟨λ J hJ hhJ,
  begin
    resetI,
    letI : category.{w w} (ulift_hom.{w} (ulift.{w 0} J)),
    { apply ulift_hom.category.{0}, exact category_theory.ulift_category J },
    haveI := h (ulift_hom.{w} (ulift.{w} J)) category_theory.fin_category_ulift,
    exact has_limits_of_shape_of_equivalence (ulift_hom_ulift_category.equiv.{w w} J).symm
  end ⟩

/--
A category has all finite colimits if every functor `J ⥤ C` with a `fin_category J`
instance and `J : Type` has a colimit.

This is often called 'finitely cocomplete'.
-/
class has_finite_colimits : Prop :=
(out (J : Type) [𝒥 : small_category J] [@fin_category J 𝒥] : @has_colimits_of_shape J 𝒥 C _)

@[priority 100]
instance has_colimits_of_shape_of_has_finite_colimits
  (J : Type w) [small_category J] [fin_category J] [has_finite_colimits C] :
  has_colimits_of_shape J C :=
begin
  apply has_colimits_of_shape_of_equivalence (fin_category.equiv_as_type J),
  apply has_finite_colimits.out
end

@[priority 100]
instance has_finite_colimits_of_has_colimits_of_size [has_colimits_of_size.{v' u'} C] :
  has_finite_colimits C :=
⟨λ J hJ hJ', by { haveI := has_colimits_of_size_shrink.{0 0} C,
  exact has_colimits_of_shape_of_equivalence (fin_category.equiv_as_type J) }⟩

/-- We can always derive `has_finite_colimits C` by providing colimits at an
arbitrary universe. -/
lemma has_finite_colimits_of_has_finite_colimits_of_size
  (h : ∀ (J : Type w) {𝒥 : small_category J} (hJ : @fin_category J 𝒥),
    by { resetI, exact has_colimits_of_shape J C }) :
  has_finite_colimits C :=
⟨λ J hJ hhJ,
  begin
    resetI,
    letI : category.{w w} (ulift_hom.{w} (ulift.{w 0} J)),
    { apply ulift_hom.category.{0}, exact category_theory.ulift_category J },
    haveI := h (ulift_hom.{w} (ulift.{w} J)) category_theory.fin_category_ulift,
    exact has_colimits_of_shape_of_equivalence (ulift_hom_ulift_category.equiv.{w w} J).symm
  end ⟩
section

open walking_parallel_pair walking_parallel_pair_hom

instance fintype_walking_parallel_pair : fintype walking_parallel_pair :=
{ elems := [walking_parallel_pair.zero, walking_parallel_pair.one].to_finset,
  complete := λ x, by { cases x; simp } }

local attribute [tidy] tactic.case_bash

instance (j j' : walking_parallel_pair) : fintype (walking_parallel_pair_hom j j') :=
{ elems := walking_parallel_pair.rec_on j
    (walking_parallel_pair.rec_on j' [walking_parallel_pair_hom.id zero].to_finset
      [left, right].to_finset)
    (walking_parallel_pair.rec_on j' ∅ [walking_parallel_pair_hom.id one].to_finset),
  complete := by tidy }

end

instance : fin_category walking_parallel_pair := { }

/-- Equalizers are finite limits, so if `C` has all finite limits, it also has all equalizers -/
example [has_finite_limits C] : has_equalizers C := by apply_instance

/-- Coequalizers are finite colimits, of if `C` has all finite colimits, it also has all
    coequalizers -/
example [has_finite_colimits C] : has_coequalizers C := by apply_instance

variables {J : Type v}

local attribute [tidy] tactic.case_bash

namespace wide_pullback_shape

instance fintype_obj [fintype J] : fintype (wide_pullback_shape J) :=
by { rw wide_pullback_shape, apply_instance }

instance fintype_hom (j j' : wide_pullback_shape J) : fintype (j ⟶ j') :=
{ elems :=
  begin
    cases j',
    { cases j,
      { exact {hom.id none} },
      { exact {hom.term j} } },
    { by_cases some j' = j,
      { rw h,
        exact {hom.id j} },
      { exact ∅ } }
  end,
  complete := by tidy }

end wide_pullback_shape

namespace wide_pushout_shape

instance fintype_obj [fintype J] : fintype (wide_pushout_shape J) :=
by { rw wide_pushout_shape, apply_instance }

instance fintype_hom (j j' : wide_pushout_shape J) : fintype (j ⟶ j') :=
{ elems :=
  begin
    cases j,
    { cases j',
      { exact {hom.id none} },
      { exact {hom.init j'} } },
    { by_cases some j = j',
      { rw h,
        exact {hom.id j'} },
      { exact ∅ } }
  end,
  complete := by tidy }

end wide_pushout_shape

instance fin_category_wide_pullback [fintype J] : fin_category (wide_pullback_shape J) :=
{ fintype_hom := wide_pullback_shape.fintype_hom }

instance fin_category_wide_pushout [fintype J] :
  fin_category (wide_pushout_shape J) :=
{ fintype_hom := wide_pushout_shape.fintype_hom }

/--
`has_finite_wide_pullbacks` represents a choice of wide pullback
for every finite collection of morphisms
-/
-- We can't just made this an `abbreviation`
-- because of https://github.com/leanprover-community/lean/issues/429
class has_finite_wide_pullbacks : Prop :=
(out (J : Type) [fintype J] : has_limits_of_shape (wide_pullback_shape J) C)

instance has_limits_of_shape_wide_pullback_shape
  (J : Type) [finite J] [has_finite_wide_pullbacks C] :
  has_limits_of_shape (wide_pullback_shape J) C :=
by { casesI nonempty_fintype J, haveI := @has_finite_wide_pullbacks.out C _ _ J, apply_instance }

/--
`has_finite_wide_pushouts` represents a choice of wide pushout
for every finite collection of morphisms
-/
class has_finite_wide_pushouts : Prop :=
(out (J : Type) [fintype J] : has_colimits_of_shape (wide_pushout_shape J) C)

instance has_colimits_of_shape_wide_pushout_shape
  (J : Type) [finite J] [has_finite_wide_pushouts C] :
  has_colimits_of_shape (wide_pushout_shape J) C :=
by { casesI nonempty_fintype J, haveI := @has_finite_wide_pushouts.out C _ _ J, apply_instance }

/--
Finite wide pullbacks are finite limits, so if `C` has all finite limits,
it also has finite wide pullbacks
-/

/--
Finite wide pushouts are finite colimits, so if `C` has all finite colimits,
it also has finite wide pushouts
-/
lemma has_finite_wide_pushouts_of_has_finite_limits [has_finite_colimits C] :
  has_finite_wide_pushouts C :=
⟨λ J _, by exactI has_finite_colimits.out _⟩

instance fintype_walking_pair : fintype walking_pair :=
{ elems := {walking_pair.left, walking_pair.right},
  complete := λ x, by { cases x; simp } }

/-- Pullbacks are finite limits, so if `C` has all finite limits, it also has all pullbacks -/
example [has_finite_wide_pullbacks C] : has_pullbacks C := by apply_instance

/-- Pushouts are finite colimits, so if `C` has all finite colimits, it also has all pushouts -/
example [has_finite_wide_pushouts C] : has_pushouts C := by apply_instance

end category_theory.limits