import tactic.rewrite_search

inductive slice
| pos : ℕ → slice
| neg : ℕ → slice
| cup : ℕ → slice
| cap : ℕ → slice

open slice

inductive diagram
| nil
| cons : slice → diagram → diagram

infixr ` ~~ `:80 := diagram.cons
notation `t[` l:(foldr `, ` (h t, diagram.cons h t) diagram.nil `]`) := l

namespace isotopy
variable (d : diagram)
axiom commute_pos_pos (n m) (h : n ≥ m + 2) : (pos n) ~~ (pos m) ~~ d = (pos m) ~~ (pos n) ~~ d
axiom commute_pos_neg (n m) (h : n ≥ m + 2) : (pos n) ~~ (neg m) ~~ d = (neg m) ~~ (pos n) ~~ d
axiom commute_neg_pos (n m) (h : n ≥ m + 2) : (neg n) ~~ (pos m) ~~ d = (pos m) ~~ (neg n) ~~ d
axiom commute_neg_neg (n m) (h : n ≥ m + 2) : (neg n) ~~ (neg m) ~~ d = (neg m) ~~ (neg n) ~~ d

axiom commute_cup_pos (n m) (h : n ≥ m + 2) : (cup n) ~~ (pos m) ~~ d = (pos m) ~~ (cup n) ~~ d
axiom commute_cup_neg (n m) (h : n ≥ m + 2) : (cup n) ~~ (neg m) ~~ d = (neg m) ~~ (cup n) ~~ d
axiom commute_cap_pos (n m) (h : n ≥ m + 2) : (cap n) ~~ (pos m) ~~ d = (pos m) ~~ (cap n) ~~ d
axiom commute_cap_neg (n m) (h : n ≥ m + 2) : (cap n) ~~ (neg m) ~~ d = (neg m) ~~ (cap n) ~~ d

axiom commute_pos_cup (n m) (h : n ≥ m)     : (pos n) ~~ (cup m) ~~ d = (cup m) ~~ (pos (n+2)) ~~ d
axiom commute_pos_cap (n m) (h : n ≥ m + 2) : (pos n) ~~ (cap m) ~~ d = (cap m) ~~ (pos (n-2)) ~~ d
axiom commute_neg_cup (n m) (h : n ≥ m)     : (neg n) ~~ (cup m) ~~ d = (cup m) ~~ (neg (n+2)) ~~ d
axiom commute_neg_cap (n m) (h : n ≥ m + 2) : (neg n) ~~ (cap m) ~~ d = (cap m) ~~ (neg (n-2)) ~~ d

axiom commute_cup_cup (n m) (h : n ≥ m)     : (cup n) ~~ (cup m) ~~ d = (cup m) ~~ (cup (n+2)) ~~ d
axiom commute_cup_cap (n m) (h : n ≥ m + 2) : (cup n) ~~ (cap m) ~~ d = (cap m) ~~ (cup (n-2)) ~~ d
axiom commute_cap_cup (n m) (h : n ≥ m)     : (cap n) ~~ (cup m) ~~ d = (cup m) ~~ (cap (n+2)) ~~ d
axiom commute_cap_cap (n m) (h : n ≥ m + 2) : (cap n) ~~ (cap m) ~~ d = (cap m) ~~ (cap (n-2)) ~~ d

axiom zigzag_left (n : ℕ) : (cup n) ~~ (cap (n+1)) ~~ d = d
axiom zigzag_right (n : ℕ) : (cup (n+1)) ~~ (cap n) ~~ d = d

axiom R2_east (n : ℕ) : (neg n) ~~ (pos n) ~~ d = d
axiom R2_west (n : ℕ) : (pos n) ~~ (neg n) ~~ d = d
axiom R2_north (n : ℕ) : (cup (n+1)) ~~ (pos n) ~~ (neg (n+2)) ~~ cap(n+1) ~~ d = (cap n) ~~ (cup n) ~~ d
axiom R2_south (n : ℕ) : (cup (n+1)) ~~ (neg n) ~~ (pos (n+2)) ~~ cap(n+1) ~~ d = (cap n) ~~ (cup n) ~~ d

axiom R1_pos_east (n : ℕ) : (cup (n+1)) ~~ (pos n) ~~ (cap (n+1)) ~~ d = d
axiom R1_neg_east (n : ℕ) : (cup (n+1)) ~~ (neg n) ~~ (cap (n+1)) ~~ d = d
axiom R1_pos_west (n : ℕ) : (cup n) ~~ (pos (n+1)) ~~ (cap n) ~~ d = d
axiom R1_neg_west (n : ℕ) : (cup n) ~~ (neg (n+1)) ~~ (cap n) ~~ d = d
axiom R1_pos_north (n : ℕ) : (pos n) ~~ (cap n) ~~ d = (cap n) ~~ d
axiom R1_neg_north (n : ℕ) : (neg n) ~~ (cap n) ~~ d = (cap n) ~~ d
axiom R1_pos_south (n : ℕ) : (cup n) ~~ (pos n) ~~ d = (cup n) ~~ d
axiom R1_neg_south (n : ℕ) : (cup n) ~~ (neg n) ~~ d = (cup n) ~~ d

axiom R3_pos_pos_pos (n : ℕ) : (pos n) ~~ (pos (n+1)) ~~ (pos n) ~~ d = (pos (n+1)) ~~ (pos n) ~~ (pos (n+1)) ~~ d
axiom R3_pos_pos_neg (n : ℕ) : (pos n) ~~ (pos (n+1)) ~~ (neg n) ~~ d = (neg (n+1)) ~~ (pos n) ~~ (pos (n+1)) ~~ d
axiom R3_pos_neg_neg (n : ℕ) : (pos n) ~~ (neg (n+1)) ~~ (neg n) ~~ d = (neg (n+1)) ~~ (neg n) ~~ (pos (n+1)) ~~ d
axiom R3_neg_pos_pos (n : ℕ) : (neg n) ~~ (pos (n+1)) ~~ (pos n) ~~ d = (pos (n+1)) ~~ (pos n) ~~ (neg (n+1)) ~~ d
axiom R3_neg_neg_pos (n : ℕ) : (neg n) ~~ (neg (n+1)) ~~ (pos n) ~~ d = (pos (n+1)) ~~ (neg n) ~~ (neg (n+1)) ~~ d
axiom R3_neg_neg_neg (n : ℕ) : (neg n) ~~ (neg (n+1)) ~~ (neg n) ~~ d = (neg (n+1)) ~~ (neg n) ~~ (neg (n+1)) ~~ d

axiom cap_over  (n : ℕ) : (pos n) ~~ (cap (n+1)) ~~ d = (neg (n+1)) ~~ (cap n) ~~ d
axiom cap_under (n : ℕ) : (neg n) ~~ (cap (n+1)) ~~ d = (pos (n+1)) ~~ (cap n) ~~ d
axiom cup_over  (n : ℕ) : (cup (n+1)) ~~ (neg n) ~~ d = (cup n) ~~ (pos (n+1)) ~~ d
axiom cup_under (n : ℕ) : (cup (n+1)) ~~ (pos n) ~~ d = (cup n) ~~ (neg (n+1)) ~~ d

-- axiom rotate_pos_clockwise   (n : ℕ) : (cup n) ~~ (pos (n+1)) ~~ (cap (n+2)) ~~ d = (neg n) ~~ d
-- axiom rotate_neg_clockwise   (n : ℕ) : (cup n) ~~ (neg (n+1)) ~~ (cap (n+2)) ~~ d = (pos n) ~~ d
-- axiom rotate_pos_widdershins (n : ℕ) : (cup (n+2)) ~~ (pos (n+1)) ~~ (cap n) ~~ d = (neg n) ~~ d
-- axiom rotate_neg_widdershins (n : ℕ) : (cup (n+2)) ~~ (neg (n+1)) ~~ (cap n) ~~ d = (pos n) ~~ d

attribute [search] commute_pos_pos commute_pos_neg commute_neg_pos commute_neg_neg
attribute [search] commute_cup_pos commute_cup_neg commute_cap_pos commute_cap_neg
attribute [search] commute_pos_cup commute_pos_cap commute_neg_cup commute_neg_cap
attribute [search] commute_cup_cup commute_cup_cap commute_cap_cup commute_cap_cap
attribute [search] zigzag_left zigzag_right
attribute [search] cap_over cap_under cup_over cup_under
attribute [search] R1_pos_east R1_neg_east R1_pos_west R1_neg_west R1_pos_north R1_neg_north R1_pos_south R1_neg_south
attribute [search] R2_east R2_west R2_north R2_south
attribute [search] R3_pos_pos_pos R3_pos_pos_neg R3_pos_neg_neg R3_neg_pos_pos R3_neg_neg_pos R3_neg_neg_neg
-- attribute [search] rotate_pos_clockwise rotate_neg_clockwise rotate_pos_widdershins rotate_neg_widdershins

end isotopy

open isotopy
open tactic

meta def isotopy := `[rewrite_search_using [`search] { discharger := `[norm_num], simplifier := norm_num.derive, explain := tt }]
meta def isotopy' := `[rewrite_search_using [`search] { discharger := `[norm_num], simplifier := norm_num.derive, trace := tt, no visualiser, explain := tt }]

lemma commute_1 : t[pos 0, neg 2, pos 4] = t[pos 4, neg 2, pos 0] := by isotopy
lemma commute_2 : t[cup 0, pos 2] = t[pos 0, cup 0] := by isotopy
lemma commute_3 : t[cup 2, cap 0] = t[cup 0, cap 2] := by isotopy

lemma bulge : t[cup 1, cap 0, cup 0, cap 1] = t[] := by isotopy

lemma R2_north : t[cup 1, pos 0, neg 2, cap 1] = t[cap 0, cup 0] := by isotopy

lemma twists : t[cup 0, cup 2, pos 0, pos 2, cap 1, cap 0] = t[cup 0, cap 0] := by isotopy
-- begin
-- rw commute_cup_pos,
-- rw R1_pos_south,
-- rw R1_pos_south,
-- rw zigzag_right,
-- norm_num
-- end

lemma rotate : t[cup 0, pos 1, cap 2] = t[neg 0] := by isotopy

-- lemma recognise_trefoil : t[cup 0, cup 1, pos 0, pos 0, pos 0, cap 1, cap 0] = t[cup 0, cup 2, neg 1, pos 0, pos 2, cap 1, cap 0] := by isotopy


lemma mul_left_comm (a b c : mynat) : a * (b * c) = b * (a * c) :=
begin
rw ← mul_assoc,
rw mul_comm a,
rw mul_assoc,
refl,
end


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.presheafed_space.gluing

/-!
# Gluing Schemes

Given a family of gluing data of schemes, we may glue them together.

## Main definitions

* `algebraic_geometry.Scheme.glue_data`: A structure containing the family of gluing data.
* `algebraic_geometry.Scheme.glue_data.glued`: The glued scheme.
    This is defined as the multicoequalizer of `∐ V i j ⇉ ∐ U i`, so that the general colimit API
    can be used.
* `algebraic_geometry.Scheme.glue_data.ι`: The immersion `ι i : U i ⟶ glued` for each `i : J`.
* `algebraic_geometry.Scheme.glue_data.iso_carrier`: The isomorphism between the underlying space
  of the glued scheme and the gluing of the underlying topological spaces.
* `algebraic_geometry.Scheme.open_cover.glue_data`: The glue data associated with an open cover.
* `algebraic_geometry.Scheme.open_cover.from_glue_data`: The canonical morphism
  `𝒰.glue_data.glued ⟶ X`. This has an `is_iso` instance.
* `algebraic_geometry.Scheme.open_cover.glue_morphisms`: We may glue a family of compatible
  morphisms defined on an open cover of a scheme.

## Main results

* `algebraic_geometry.Scheme.glue_data.ι_is_open_immersion`: The map `ι i : U i ⟶ glued`
  is an open immersion for each `i : J`.
* `algebraic_geometry.Scheme.glue_data.ι_jointly_surjective` : The underlying maps of
  `ι i : U i ⟶ glued` are jointly surjective.
* `algebraic_geometry.Scheme.glue_data.V_pullback_cone_is_limit` : `V i j` is the pullback
  (intersection) of `U i` and `U j` over the glued space.
* `algebraic_geometry.Scheme.glue_data.ι_eq_iff_rel` : `ι i x = ι j y` if and only if they coincide
  when restricted to `V i i`.
* `algebraic_geometry.Scheme.glue_data.is_open_iff` : An subset of the glued scheme is open iff
  all its preimages in `U i` are open.

## Implementation details

All the hard work is done in `algebraic_geometry/presheafed_space/gluing.lean` where we glue
presheafed spaces, sheafed spaces, and locally ringed spaces.

-/

noncomputable theory

universe u

open topological_space category_theory opposite
open category_theory.limits algebraic_geometry.PresheafedSpace
open category_theory.glue_data

namespace algebraic_geometry

namespace Scheme

/--
A family of gluing data consists of
1. An index type `J`
2. An scheme `U i` for each `i : J`.
3. An scheme `V i j` for each `i j : J`.
  (Note that this is `J × J → Scheme` rather than `J → J → Scheme` to connect to the
  limits library easier.)
4. An open immersion `f i j : V i j ⟶ U i` for each `i j : ι`.
5. A transition map `t i j : V i j ⟶ V j i` for each `i j : ι`.
such that
6. `f i i` is an isomorphism.
7. `t i i` is the identity.
8. `V i j ×[U i] V i k ⟶ V i j ⟶ V j i` factors through `V j k ×[U j] V j i ⟶ V j i` via some
    `t' : V i j ×[U i] V i k ⟶ V j k ×[U j] V j i`.
9. `t' i j k ≫ t' j k i ≫ t' k i j = 𝟙 _`.

We can then glue the schemes `U i` together by identifying `V i j` with `V j i`, such
that the `U i`'s are open subschemes of the glued space.
-/
@[nolint has_nonempty_instance]
structure glue_data extends category_theory.glue_data Scheme :=
(f_open : ∀ i j, is_open_immersion (f i j))

attribute [instance] glue_data.f_open

namespace glue_data

variables (D : glue_data)

include D

local notation `𝖣` := D.to_glue_data

/-- The glue data of locally ringed spaces spaces associated to a family of glue data of schemes. -/
abbreviation to_LocallyRingedSpace_glue_data : LocallyRingedSpace.glue_data :=
{ f_open := D.f_open,
  to_glue_data := 𝖣 .map_glue_data forget_to_LocallyRingedSpace }

/-- (Implementation). The glued scheme of a glue data.
This should not be used outside this file. Use `Scheme.glue_data.glued` instead. -/
def glued_Scheme : Scheme :=
begin
  apply LocallyRingedSpace.is_open_immersion.Scheme
    D.to_LocallyRingedSpace_glue_data.to_glue_data.glued,
  intro x,
  obtain ⟨i, y, rfl⟩ := D.to_LocallyRingedSpace_glue_data.ι_jointly_surjective x,
  refine ⟨_, _ ≫ D.to_LocallyRingedSpace_glue_data.to_glue_data.ι i, _⟩,
  swap, exact (D.U i).affine_cover.map y,
  split,
  { dsimp [-set.mem_range],
    rw [coe_comp, set.range_comp],
    refine set.mem_image_of_mem _ _,
    exact (D.U i).affine_cover.covers y },
  { apply_instance },
end

instance : creates_colimit 𝖣 .diagram.multispan forget_to_LocallyRingedSpace :=
creates_colimit_of_fully_faithful_of_iso D.glued_Scheme
  (has_colimit.iso_of_nat_iso (𝖣 .diagram_iso forget_to_LocallyRingedSpace).symm)

instance : preserves_colimit 𝖣 .diagram.multispan forget_to_Top :=
begin
  delta forget_to_Top LocallyRingedSpace.forget_to_Top,
  apply_instance,
end

instance : has_multicoequalizer 𝖣 .diagram :=
has_colimit_of_created _ forget_to_LocallyRingedSpace

/-- The glued scheme of a glued space. -/
abbreviation glued : Scheme := 𝖣 .glued

/-- The immersion from `D.U i` into the glued space. -/
abbreviation ι (i : D.J) : D.U i ⟶ D.glued := 𝖣 .ι i

/-- The gluing as sheafed spaces is isomorphic to the gluing as presheafed spaces. -/
abbreviation iso_LocallyRingedSpace :
  D.glued.to_LocallyRingedSpace ≅ D.to_LocallyRingedSpace_glue_data.to_glue_data.glued :=
𝖣 .glued_iso forget_to_LocallyRingedSpace

lemma ι_iso_LocallyRingedSpace_inv (i : D.J) :
  D.to_LocallyRingedSpace_glue_data.to_glue_data.ι i ≫ D.iso_LocallyRingedSpace.inv = 𝖣 .ι i :=
𝖣 .ι_glued_iso_inv forget_to_LocallyRingedSpace i

instance ι_is_open_immersion (i : D.J) :
  is_open_immersion (𝖣 .ι i) :=
by { rw ← D.ι_iso_LocallyRingedSpace_inv, apply_instance }

lemma ι_jointly_surjective (x : 𝖣 .glued.carrier) :
  ∃ (i : D.J) (y : (D.U i).carrier), (D.ι i).1.base y = x :=
𝖣 .ι_jointly_surjective (forget_to_Top ⋙ forget Top) x

@[simp, reassoc]
lemma glue_condition (i j : D.J) :
  D.t i j ≫ D.f j i ≫ D.ι j = D.f i j ≫ D.ι i :=
𝖣 .glue_condition i j

/-- The pullback cone spanned by `V i j ⟶ U i` and `V i j ⟶ U j`.
This is a pullback diagram (`V_pullback_cone_is_limit`). -/
def V_pullback_cone (i j : D.J) : pullback_cone (D.ι i) (D.ι j) :=
pullback_cone.mk (D.f i j) (D.t i j ≫ D.f j i) (by simp)

/-- The following diagram is a pullback, i.e. `Vᵢⱼ` is the intersection of `Uᵢ` and `Uⱼ` in `X`.

Vᵢⱼ ⟶ Uᵢ
 |      |
 ↓      ↓
 Uⱼ ⟶ X
-/
def V_pullback_cone_is_limit (i j : D.J) :
  is_limit (D.V_pullback_cone i j) :=
𝖣 .V_pullback_cone_is_limit_of_map forget_to_LocallyRingedSpace i j
  (D.to_LocallyRingedSpace_glue_data.V_pullback_cone_is_limit _ _)

/-- The underlying topological space of the glued scheme is isomorphic to the gluing of the
underlying spacess -/
def iso_carrier :
  D.glued.carrier ≅ D.to_LocallyRingedSpace_glue_data.to_SheafedSpace_glue_data
    .to_PresheafedSpace_glue_data.to_Top_glue_data.to_glue_data.glued :=
begin
  refine (PresheafedSpace.forget _).map_iso _ ≪≫
    glue_data.glued_iso _ (PresheafedSpace.forget _),
  refine SheafedSpace.forget_to_PresheafedSpace.map_iso _ ≪≫
    SheafedSpace.glue_data.iso_PresheafedSpace _,
  refine LocallyRingedSpace.forget_to_SheafedSpace.map_iso _ ≪≫
    LocallyRingedSpace.glue_data.iso_SheafedSpace _,
  exact Scheme.glue_data.iso_LocallyRingedSpace _
end

@[simp]
lemma ι_iso_carrier_inv (i : D.J) :
  D.to_LocallyRingedSpace_glue_data.to_SheafedSpace_glue_data
    .to_PresheafedSpace_glue_data.to_Top_glue_data.to_glue_data.ι i ≫ D.iso_carrier.inv =
    (D.ι i).1.base :=
begin
  delta iso_carrier,
  simp only [functor.map_iso_inv, iso.trans_inv, iso.trans_assoc,
    glue_data.ι_glued_iso_inv_assoc, functor.map_iso_trans, category.assoc],
  iterate 3 { erw ← comp_base },
  simp_rw ← category.assoc,
  rw D.to_LocallyRingedSpace_glue_data.to_SheafedSpace_glue_data.ι_iso_PresheafedSpace_inv i,
  erw D.to_LocallyRingedSpace_glue_data.ι_iso_SheafedSpace_inv i,
  change (_ ≫ D.iso_LocallyRingedSpace.inv).1.base = _,
  rw D.ι_iso_LocallyRingedSpace_inv i
end

/-- An equivalence relation on `Σ i, D.U i` that holds iff `𝖣 .ι i x = 𝖣 .ι j y`.
See `Scheme.gluing_data.ι_eq_iff`. -/
def rel (a b : Σ i, ((D.U i).carrier : Type*)) : Prop :=
  a = b ∨ ∃ (x : (D.V (a.1, b.1)).carrier),
    (D.f _ _).1.base x = a.2 ∧ (D.t _ _ ≫ D.f _ _).1.base x = b.2

lemma ι_eq_iff (i j : D.J) (x : (D.U i).carrier) (y : (D.U j).carrier) :
  (𝖣 .ι i).1.base x = (𝖣 .ι j).1.base y ↔ D.rel ⟨i, x⟩ ⟨j, y⟩ :=
begin
  refine iff.trans _ (D.to_LocallyRingedSpace_glue_data.to_SheafedSpace_glue_data
      .to_PresheafedSpace_glue_data.to_Top_glue_data.ι_eq_iff_rel i j x y),
  rw ← ((Top.mono_iff_injective D.iso_carrier.inv).mp infer_instance).eq_iff,
    simp_rw [← comp_apply, D.ι_iso_carrier_inv]
end

lemma is_open_iff (U : set D.glued.carrier) : is_open U ↔ ∀ i, is_open ((D.ι i).1.base ⁻¹' U) :=
begin
  rw ← (Top.homeo_of_iso D.iso_carrier.symm).is_open_preimage,
  rw Top.glue_data.is_open_iff,
  apply forall_congr,
  intro i,
  erw [← set.preimage_comp, ← coe_comp, ι_iso_carrier_inv]
end

/-- The open cover of the glued space given by the glue data. -/
def open_cover (D : Scheme.glue_data) : open_cover D.glued :=
{ J := D.J,
  obj := D.U,
  map := D.ι,
  f := λ x, (D.ι_jointly_surjective x).some,
  covers := λ x, ⟨_, (D.ι_jointly_surjective x).some_spec.some_spec⟩ }

end glue_data

namespace open_cover

variables {X : Scheme.{u}} (𝒰 : open_cover.{u} X)

/-- (Implementation) the transition maps in the glue data associated with an open cover. -/
def glued_cover_t' (x y z : 𝒰.J) :
  pullback (pullback.fst : pullback (𝒰.map x) (𝒰.map y) ⟶ _)
    (pullback.fst : pullback (𝒰.map x) (𝒰.map z) ⟶ _) ⟶
  pullback (pullback.fst : pullback (𝒰.map y) (𝒰.map z) ⟶ _)
    (pullback.fst : pullback (𝒰.map y) (𝒰.map x) ⟶ _) :=
begin
  refine (pullback_right_pullback_fst_iso _ _ _).hom ≫ _,
  refine _ ≫ (pullback_symmetry _ _).hom,
  refine _ ≫ (pullback_right_pullback_fst_iso _ _ _).inv,
  refine pullback.map _ _ _ _ (pullback_symmetry _ _).hom (𝟙 _) (𝟙 _) _ _,
  { simp [pullback.condition] },
  { simp }
end

@[simp, reassoc]
lemma glued_cover_t'_fst_fst (x y z : 𝒰.J) :
   𝒰.glued_cover_t' x y z ≫ pullback.fst ≫ pullback.fst = pullback.fst ≫ pullback.snd :=
by { delta glued_cover_t', simp }

@[simp, reassoc]
lemma glued_cover_t'_fst_snd (x y z : 𝒰.J) :
  glued_cover_t' 𝒰 x y z ≫ pullback.fst ≫ pullback.snd = pullback.snd ≫ pullback.snd :=
by { delta glued_cover_t', simp }

@[simp, reassoc]
lemma glued_cover_t'_snd_fst (x y z : 𝒰.J) :
  glued_cover_t' 𝒰 x y z ≫ pullback.snd ≫ pullback.fst = pullback.fst ≫ pullback.snd :=
by { delta glued_cover_t', simp }

@[simp, reassoc]
lemma glued_cover_t'_snd_snd (x y z : 𝒰.J) :
  glued_cover_t' 𝒰 x y z ≫ pullback.snd ≫ pullback.snd = pullback.fst ≫ pullback.fst :=
by { delta glued_cover_t', simp }

lemma glued_cover_cocycle_fst (x y z : 𝒰.J) :
  glued_cover_t' 𝒰 x y z ≫ glued_cover_t' 𝒰 y z x ≫ glued_cover_t' 𝒰 z x y ≫ pullback.fst =
    pullback.fst :=
by apply pullback.hom_ext; simp

lemma glued_cover_cocycle_snd (x y z : 𝒰.J) :
  glued_cover_t' 𝒰 x y z ≫ glued_cover_t' 𝒰 y z x ≫ glued_cover_t' 𝒰 z x y ≫ pullback.snd =
    pullback.snd :=
by apply pullback.hom_ext; simp [pullback.condition]

lemma glued_cover_cocycle (x y z : 𝒰.J) :
  glued_cover_t' 𝒰 x y z ≫ glued_cover_t' 𝒰 y z x ≫ glued_cover_t' 𝒰 z x y = 𝟙 _ :=
begin
  apply pullback.hom_ext; simp_rw [category.id_comp, category.assoc],
  apply glued_cover_cocycle_fst,
  apply glued_cover_cocycle_snd,
end

/-- The glue data associated with an open cover.
The canonical isomorphism `𝒰.glued_cover.glued ⟶ X` is provided by `𝒰.from_glued`. -/
@[simps]
def glued_cover : Scheme.glue_data.{u} :=
{ J := 𝒰.J,
  U := 𝒰.obj,
  V := λ ⟨x, y⟩, pullback (𝒰.map x) (𝒰.map y),
  f := λ x y, pullback.fst,
  f_id := λ x, infer_instance,
  t := λ x y, (pullback_symmetry _ _).hom,
  t_id := λ x, by simpa,
  t' := λ x y z, glued_cover_t' 𝒰 x y z,
  t_fac := λ x y z, by apply pullback.hom_ext; simp,
  -- The `cocycle` field could have been `by tidy` but lean timeouts.
  cocycle := λ x y z, glued_cover_cocycle 𝒰 x y z,
  f_open := λ x, infer_instance }

/-- The canonical morphism from the gluing of an open cover of `X` into `X`.
This is an isomorphism, as witnessed by an `is_iso` instance. -/
def from_glued : 𝒰.glued_cover.glued ⟶ X :=
begin
  fapply multicoequalizer.desc,
  exact λ x, (𝒰.map x),
  rintro ⟨x, y⟩,
  change pullback.fst ≫ _ = ((pullback_symmetry _ _).hom ≫ pullback.fst) ≫ _,
  simpa using pullback.condition
end

@[simp, reassoc]
lemma ι_from_glued (x : 𝒰.J) :
  𝒰.glued_cover.ι x ≫ 𝒰.from_glued = 𝒰.map x :=
multicoequalizer.π_desc _ _ _ _ _

lemma from_glued_injective : function.injective 𝒰.from_glued.1.base :=
begin
  intros x y h,
  obtain ⟨i, x, rfl⟩ := 𝒰.glued_cover.ι_jointly_surjective x,
  obtain ⟨j, y, rfl⟩ :=  𝒰.glued_cover.ι_jointly_surjective y,
  simp_rw [← comp_apply, ← SheafedSpace.comp_base, ← LocallyRingedSpace.comp_val] at h,
  erw [ι_from_glued, ι_from_glued] at h,
  let e := (Top.pullback_cone_is_limit _ _).cone_point_unique_up_to_iso
    (is_limit_of_has_pullback_of_preserves_limit Scheme.forget_to_Top
      (𝒰.map i) (𝒰.map j)),
  rw 𝒰.glued_cover.ι_eq_iff,
  right,
  use e.hom ⟨⟨x, y⟩, h⟩,
  simp_rw ← comp_apply,
  split,
  { erw is_limit.cone_point_unique_up_to_iso_hom_comp _ _ walking_cospan.left, refl },
  { erw [pullback_symmetry_hom_comp_fst,
      is_limit.cone_point_unique_up_to_iso_hom_comp _ _ walking_cospan.right], refl }
end

instance from_glued_stalk_iso (x : 𝒰.glued_cover.glued.carrier) :
  is_iso (PresheafedSpace.stalk_map 𝒰.from_glued.val x) :=
begin
  obtain ⟨i, x, rfl⟩ := 𝒰.glued_cover.ι_jointly_surjective x,
  have := PresheafedSpace.stalk_map.congr_hom _ _
    (congr_arg LocallyRingedSpace.hom.val $ 𝒰.ι_from_glued i) x,
  erw PresheafedSpace.stalk_map.comp at this,
  rw ← is_iso.eq_comp_inv at this,
  rw this,
  apply_instance,
end

lemma from_glued_open_map : is_open_map 𝒰.from_glued.1.base :=
begin
  intros U hU,
  rw is_open_iff_forall_mem_open,
  intros x hx,
  rw 𝒰.glued_cover.is_open_iff at hU,
  use 𝒰.from_glued.val.base '' U ∩ set.range (𝒰.map (𝒰.f x)).1.base,
  use set.inter_subset_left _ _,
  split,
  { rw ← set.image_preimage_eq_inter_range,
    apply (show is_open_immersion (𝒰.map (𝒰.f x)), by apply_instance).base_open.is_open_map,
    convert hU (𝒰.f x) using 1,
    rw ← ι_from_glued, erw coe_comp, rw set.preimage_comp,
    congr' 1,
    refine set.preimage_image_eq _ 𝒰.from_glued_injective },
  { exact ⟨hx, 𝒰.covers x⟩ }
end

lemma from_glued_open_embedding : open_embedding 𝒰.from_glued.1.base :=
open_embedding_of_continuous_injective_open (by continuity) 𝒰.from_glued_injective
  𝒰.from_glued_open_map

instance : epi 𝒰.from_glued.val.base :=
begin
  rw Top.epi_iff_surjective,
  intro x,
  obtain ⟨y, h⟩ := 𝒰.covers x,
  use (𝒰.glued_cover.ι (𝒰.f x)).1.base y,
  rw ← comp_apply,
  rw ← 𝒰.ι_from_glued (𝒰.f x) at h,
  exact h
end

instance from_glued_open_immersion : is_open_immersion 𝒰.from_glued :=
SheafedSpace.is_open_immersion.of_stalk_iso _ 𝒰.from_glued_open_embedding

instance : is_iso 𝒰.from_glued :=
begin
  apply is_iso_of_reflects_iso _ (Scheme.forget_to_LocallyRingedSpace ⋙
    LocallyRingedSpace.forget_to_SheafedSpace ⋙ SheafedSpace.forget_to_PresheafedSpace),
  change @is_iso (PresheafedSpace _) _ _ _ 𝒰.from_glued.val,
  apply PresheafedSpace.is_open_immersion.to_iso,
end

/-- Given an open cover of `X`, and a morphism `𝒰.obj x ⟶ Y` for each open subscheme in the cover,
such that these morphisms are compatible in the intersection (pullback), we may glue the morphisms
together into a morphism `X ⟶ Y`.

Note:
If `X` is exactly (defeq to) the gluing of `U i`, then using `multicoequalizer.desc` suffices.
-/
def glue_morphisms {Y : Scheme} (f : ∀ x, 𝒰.obj x ⟶ Y)
  (hf : ∀ x y, (pullback.fst : pullback (𝒰.map x) (𝒰.map y) ⟶ _) ≫ f x = pullback.snd ≫ f y) :
  X ⟶ Y :=
begin
  refine inv 𝒰.from_glued ≫ _,
  fapply multicoequalizer.desc,
  exact f,
  rintro ⟨i, j⟩,
  change pullback.fst ≫ f i = (_ ≫ _) ≫ f j,
  erw pullback_symmetry_hom_comp_fst,
  exact hf i j
end

@[simp, reassoc]
lemma ι_glue_morphisms {Y : Scheme} (f : ∀ x, 𝒰.obj x ⟶ Y)
  (hf : ∀ x y, (pullback.fst : pullback (𝒰.map x) (𝒰.map y) ⟶ _) ≫ f x = pullback.snd ≫ f y)
  (x : 𝒰.J) : (𝒰.map x) ≫ 𝒰.glue_morphisms f hf = f x :=
begin
  rw [← ι_from_glued, category.assoc],
  erw [is_iso.hom_inv_id_assoc, multicoequalizer.π_desc],
end

lemma hom_ext {Y : Scheme} (f₁ f₂ : X ⟶ Y) (h : ∀ x, 𝒰.map x ≫ f₁ = 𝒰.map x ≫ f₂) : f₁ = f₂ :=
begin
  rw ← cancel_epi 𝒰.from_glued,
  apply multicoequalizer.hom_ext,
  intro x,
  erw multicoequalizer.π_desc_assoc,
  erw multicoequalizer.π_desc_assoc,
  exact h x,
end

end open_cover

end Scheme

end algebraic_geometry


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Jakob von Raumer
-/
import data.list.chain
import category_theory.punit
import category_theory.groupoid
import category_theory.category.ulift

/-!
# Connected category

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

Define a connected category as a _nonempty_ category for which every functor
to a discrete category is isomorphic to the constant functor.

NB. Some authors include the empty category as connected, we do not.
We instead are interested in categories with exactly one 'connected
component'.

We give some equivalent definitions:
- A nonempty category for which every functor to a discrete category is
  constant on objects.
  See `any_functor_const_on_obj` and `connected.of_any_functor_const_on_obj`.
- A nonempty category for which every function `F` for which the presence of a
  morphism `f : j₁ ⟶ j₂` implies `F j₁ = F j₂` must be constant everywhere.
  See `constant_of_preserves_morphisms` and `connected.of_constant_of_preserves_morphisms`.
- A nonempty category for which any subset of its elements containing the
  default and closed under morphisms is everything.
  See `induct_on_objects` and `connected.of_induct`.
- A nonempty category for which every object is related under the reflexive
  transitive closure of the relation "there is a morphism in some direction
  from `j₁` to `j₂`".
  See `connected_zigzag` and `zigzag_connected`.
- A nonempty category for which for any two objects there is a sequence of
  morphisms (some reversed) from one to the other.
  See `exists_zigzag'` and `connected_of_zigzag`.

We also prove the result that the functor given by `(X × -)` preserves any
connected limit. That is, any limit of shape `J` where `J` is a connected
category is preserved by the functor `(X × -)`. This appears in `category_theory.limits.connected`.
-/

universes v₁ v₂ u₁ u₂

noncomputable theory

open category_theory.category
open opposite

namespace category_theory

/--
A possibly empty category for which every functor to a discrete category is constant.
-/
class is_preconnected (J : Type u₁) [category.{v₁} J] : Prop :=
(iso_constant : Π {α : Type u₁} (F : J ⥤ discrete α) (j : J),
  nonempty (F ≅ (functor.const J).obj (F.obj j)))

/--
We define a connected category as a _nonempty_ category for which every
functor to a discrete category is constant.

NB. Some authors include the empty category as connected, we do not.
We instead are interested in categories with exactly one 'connected
component'.

This allows us to show that the functor X ⨯ - preserves connected limits.

See <https://stacks.math.columbia.edu/tag/002S>
-/
class is_connected (J : Type u₁) [category.{v₁} J] extends is_preconnected J : Prop :=
[is_nonempty : nonempty J]

attribute [instance, priority 100] is_connected.is_nonempty

variables {J : Type u₁} [category.{v₁} J]
variables {K : Type u₂} [category.{v₂} K]

/--
If `J` is connected, any functor `F : J ⥤ discrete α` is isomorphic to
the constant functor with value `F.obj j` (for any choice of `j`).
-/
def iso_constant [is_preconnected J] {α : Type u₁} (F : J ⥤ discrete α) (j : J) :
  F ≅ (functor.const J).obj (F.obj j) :=
  (is_preconnected.iso_constant F j).some

/--
If J is connected, any functor to a discrete category is constant on objects.
The converse is given in `is_connected.of_any_functor_const_on_obj`.
-/
lemma any_functor_const_on_obj [is_preconnected J]
  {α : Type u₁} (F : J ⥤ discrete α) (j j' : J) :
  F.obj j = F.obj j' :=
by { ext, exact ((iso_constant F j').hom.app j).down.1 }

/--
If any functor to a discrete category is constant on objects, J is connected.
The converse of `any_functor_const_on_obj`.
-/
lemma is_connected.of_any_functor_const_on_obj [nonempty J]
  (h : ∀ {α : Type u₁} (F : J ⥤ discrete α), ∀ (j j' : J), F.obj j = F.obj j') :
  is_connected J :=
{ iso_constant := λ α F j',
  ⟨nat_iso.of_components (λ j, eq_to_iso (h F j j')) (λ _ _ _, subsingleton.elim _ _)⟩ }

/--
If `J` is connected, then given any function `F` such that the presence of a
morphism `j₁ ⟶ j₂` implies `F j₁ = F j₂`, we have that `F` is constant.
This can be thought of as a local-to-global property.

The converse is shown in `is_connected.of_constant_of_preserves_morphisms`
-/
lemma constant_of_preserves_morphisms [is_preconnected J] {α : Type u₁} (F : J → α)
  (h : ∀ (j₁ j₂ : J) (f : j₁ ⟶ j₂), F j₁ = F j₂) (j j' : J) :
  F j = F j' :=
by simpa using any_functor_const_on_obj
  { obj := discrete.mk ∘ F,
    map := λ _ _ f, eq_to_hom (by { ext, exact (h _ _ f), }) } j j'

/--
`J` is connected if: given any function `F : J → α` which is constant for any
`j₁, j₂` for which there is a morphism `j₁ ⟶ j₂`, then `F` is constant.
This can be thought of as a local-to-global property.

The converse of `constant_of_preserves_morphisms`.
-/
lemma is_connected.of_constant_of_preserves_morphisms [nonempty J]
  (h : ∀ {α : Type u₁} (F : J → α), (∀ {j₁ j₂ : J} (f : j₁ ⟶ j₂), F j₁ = F j₂) →
    (∀ j j' : J, F j = F j')) :
  is_connected J :=
is_connected.of_any_functor_const_on_obj
  (λ _ F, h F.obj (λ _ _ f, by { ext, exact discrete.eq_of_hom (F.map f) }))

/--
An inductive-like property for the objects of a connected category.
If the set `p` is nonempty, and `p` is closed under morphisms of `J`,
then `p` contains all of `J`.

The converse is given in `is_connected.of_induct`.
-/
lemma induct_on_objects [is_preconnected J] (p : set J) {j₀ : J} (h0 : j₀ ∈ p)
  (h1 : ∀ {j₁ j₂ : J} (f : j₁ ⟶ j₂), j₁ ∈ p ↔ j₂ ∈ p) (j : J) :
  j ∈ p :=
begin
  injection (constant_of_preserves_morphisms (λ k, ulift.up (k ∈ p)) (λ j₁ j₂ f, _) j j₀) with i,
  rwa i,
  dsimp,
  exact congr_arg ulift.up (propext (h1 f)),
end

/--
If any maximal connected component containing some element j₀ of J is all of J, then J is connected.

The converse of `induct_on_objects`.
-/
lemma is_connected.of_induct [nonempty J] {j₀ : J}
  (h : ∀ (p : set J), j₀ ∈ p → (∀ {j₁ j₂ : J} (f : j₁ ⟶ j₂), j₁ ∈ p ↔ j₂ ∈ p) → ∀ (j : J), j ∈ p) :
  is_connected J :=
is_connected.of_constant_of_preserves_morphisms (λ α F a,
begin
  have w := h {j | F j = F j₀} rfl (λ _ _ f, by simp [a f]),
  dsimp at w,
  intros j j',
  rw [w j, w j'],
end)

/-- Lifting the universe level of morphisms and objects preserves connectedness. -/
instance [hc : is_connected J] : is_connected (ulift_hom.{v₂} (ulift.{u₂} J)) :=
begin
  haveI : nonempty (ulift_hom.{v₂} (ulift.{u₂} J)), { simp [ulift_hom, hc.is_nonempty] },
  apply is_connected.of_induct,
  rintros p hj₀ h ⟨j⟩,
  let p' : set J := ((λ (j : J), p {down := j}) : set J),
  have hj₀' : (classical.choice hc.is_nonempty) ∈ p', { simp only [p'], exact hj₀ },
  apply induct_on_objects (λ (j : J), p {down := j}) hj₀'
    (λ _ _ f, h ((ulift_hom_ulift_category.equiv J).functor.map f))
end

/--
Another induction principle for `is_preconnected J`:
given a type family `Z : J → Sort*` and
a rule for transporting in *both* directions along a morphism in `J`,
we can transport an `x : Z j₀` to a point in `Z j` for any `j`.
-/
lemma is_preconnected_induction [is_preconnected J] (Z : J → Sort*)
  (h₁ : Π {j₁ j₂ : J} (f : j₁ ⟶ j₂), Z j₁ → Z j₂)
  (h₂ : Π {j₁ j₂ : J} (f : j₁ ⟶ j₂), Z j₂ → Z j₁)
  {j₀ : J} (x : Z j₀) (j : J) : nonempty (Z j) :=
(induct_on_objects {j | nonempty (Z j)} ⟨x⟩
  (λ j₁ j₂ f, ⟨by { rintro ⟨y⟩, exact ⟨h₁ f y⟩, }, by { rintro ⟨y⟩, exact ⟨h₂ f y⟩, }⟩) j : _)

/-- If `J` and `K` are equivalent, then if `J` is preconnected then `K` is as well. -/
lemma is_preconnected_of_equivalent {K : Type u₁} [category.{v₂} K] [is_preconnected J]
  (e : J ≌ K) :
  is_preconnected K :=
{ iso_constant := λ α F k, ⟨
  calc F ≅ e.inverse ⋙ e.functor ⋙ F : (e.inv_fun_id_assoc F).symm
     ... ≅ e.inverse ⋙ (functor.const J).obj ((e.functor ⋙ F).obj (e.inverse.obj k)) :
                       iso_whisker_left e.inverse (iso_constant (e.functor ⋙ F) (e.inverse.obj k))

     ... ≅ e.inverse ⋙ (functor.const J).obj (F.obj k) :
          iso_whisker_left _ ((F ⋙ functor.const J).map_iso (e.counit_iso.app k))
     ... ≅ (functor.const K).obj (F.obj k) : nat_iso.of_components (λ X, iso.refl _) (by simp),
  ⟩ }

/-- If `J` and `K` are equivalent, then if `J` is connected then `K` is as well. -/
lemma is_connected_of_equivalent {K : Type u₁} [category.{v₂} K]
  (e : J ≌ K) [is_connected J] :
  is_connected K :=
{ is_nonempty := nonempty.map e.functor.obj (by apply_instance),
  to_is_preconnected := is_preconnected_of_equivalent e }

/-- If `J` is preconnected, then `Jᵒᵖ` is preconnected as well. -/
instance is_preconnected_op [is_preconnected J] : is_preconnected Jᵒᵖ :=
{ iso_constant := λ α F X, ⟨nat_iso.of_components
      (λ Y, eq_to_iso (discrete.ext _ _ (discrete.eq_of_hom ((nonempty.some
        (is_preconnected.iso_constant (F.right_op ⋙ (discrete.opposite α).functor) (unop X))).app
          (unop Y)).hom)))
      (λ Y Z f, subsingleton.elim _ _)⟩ }

/-- If `J` is connected, then `Jᵒᵖ` is connected as well. -/
instance is_connected_op [is_connected J] : is_connected Jᵒᵖ :=
{ is_nonempty := nonempty.intro (op (classical.arbitrary J)) }

lemma is_preconnected_of_is_preconnected_op [is_preconnected Jᵒᵖ] : is_preconnected J :=
is_preconnected_of_equivalent (op_op_equivalence J)

lemma is_connected_of_is_connected_op [is_connected Jᵒᵖ] : is_connected J :=
is_connected_of_equivalent (op_op_equivalence J)

/-- j₁ and j₂ are related by `zag` if there is a morphism between them. -/
@[reducible]
def zag (j₁ j₂ : J) : Prop := nonempty (j₁ ⟶ j₂) ∨ nonempty (j₂ ⟶ j₁)

lemma zag_symmetric : symmetric (@zag J _) :=
λ j₂ j₁ h, h.swap

/--
`j₁` and `j₂` are related by `zigzag` if there is a chain of
morphisms from `j₁` to `j₂`, with backward morphisms allowed.
-/
@[reducible]
def zigzag : J → J → Prop := relation.refl_trans_gen zag

lemma zigzag_symmetric : symmetric (@zigzag J _) :=
relation.refl_trans_gen.symmetric zag_symmetric

lemma zigzag_equivalence : _root_.equivalence (@zigzag J _) :=
mk_equivalence _
    relation.reflexive_refl_trans_gen
    zigzag_symmetric
    relation.transitive_refl_trans_gen

/--
The setoid given by the equivalence relation `zigzag`. A quotient for this
setoid is a connected component of the category.
-/
def zigzag.setoid (J : Type u₂) [category.{v₁} J] : setoid J :=
{ r := zigzag,
  iseqv := zigzag_equivalence }

/--
If there is a zigzag from `j₁` to `j₂`, then there is a zigzag from `F j₁` to
`F j₂` as long as `F` is a functor.
-/
lemma zigzag_obj_of_zigzag (F : J ⥤ K) {j₁ j₂ : J} (h : zigzag j₁ j₂) :
  zigzag (F.obj j₁) (F.obj j₂) :=
h.lift _ $ λ j k, or.imp (nonempty.map (λ f, F.map f)) (nonempty.map (λ f, F.map f))

-- TODO: figure out the right way to generalise this to `zigzag`.
lemma zag_of_zag_obj (F : J ⥤ K) [full F] {j₁ j₂ : J} (h : zag (F.obj j₁) (F.obj j₂)) :
  zag j₁ j₂ :=
or.imp (nonempty.map F.preimage) (nonempty.map F.preimage) h

/-- Any equivalence relation containing (⟶) holds for all pairs of a connected category. -/
lemma equiv_relation [is_connected J] (r : J → J → Prop) (hr : _root_.equivalence r)
  (h : ∀ {j₁ j₂ : J} (f : j₁ ⟶ j₂), r j₁ j₂) :
  ∀ (j₁ j₂ : J), r j₁ j₂ :=
begin
  have z : ∀ (j : J), r (classical.arbitrary J) j :=
    induct_on_objects (λ k, r (classical.arbitrary J) k)
      (hr.1 (classical.arbitrary J)) (λ _ _ f, ⟨λ t, hr.2.2 t (h f), λ t, hr.2.2 t (hr.2.1 (h f))⟩),
  intros, apply hr.2.2 (hr.2.1 (z _)) (z _)
end

/-- In a connected category, any two objects are related by `zigzag`. -/
lemma is_connected_zigzag [is_connected J] (j₁ j₂ : J) : zigzag j₁ j₂ :=
equiv_relation _ zigzag_equivalence
  (λ _ _ f, relation.refl_trans_gen.single (or.inl (nonempty.intro f))) _ _

/--
If any two objects in an nonempty category are related by `zigzag`, the category is connected.
-/
lemma zigzag_is_connected [nonempty J] (h : ∀ (j₁ j₂ : J), zigzag j₁ j₂) : is_connected J :=
begin
  apply is_connected.of_induct,
  intros p hp hjp j,
  have: ∀ (j₁ j₂ : J), zigzag j₁ j₂ → (j₁ ∈ p ↔ j₂ ∈ p),
  { introv k,
    induction k with _ _ rt_zag zag,
    { refl },
    { rw k_ih,
      rcases zag with ⟨⟨_⟩⟩ | ⟨⟨_⟩⟩,
      apply hjp zag,
      apply (hjp zag).symm } },
  rwa this j (classical.arbitrary J) (h _ _)
end

lemma exists_zigzag' [is_connected J] (j₁ j₂ : J) :
  ∃ l, list.chain zag j₁ l ∧ list.last (j₁ :: l) (list.cons_ne_nil _ _) = j₂ :=
list.exists_chain_of_relation_refl_trans_gen (is_connected_zigzag _ _)

/--
If any two objects in an nonempty category are linked by a sequence of (potentially reversed)
morphisms, then J is connected.

The converse of `exists_zigzag'`.
-/
lemma is_connected_of_zigzag [nonempty J]
  (h : ∀ (j₁ j₂ : J), ∃ l, list.chain zag j₁ l ∧ list.last (j₁ :: l) (list.cons_ne_nil _ _) = j₂) :
  is_connected J :=
begin
  apply zigzag_is_connected,
  intros j₁ j₂,
  rcases h j₁ j₂ with ⟨l, hl₁, hl₂⟩,
  apply list.relation_refl_trans_gen_of_exists_chain l hl₁ hl₂,
end

/-- If `discrete α` is connected, then `α` is (type-)equivalent to `punit`. -/
def discrete_is_connected_equiv_punit {α : Type u₁} [is_connected (discrete α)] : α ≃ punit :=
discrete.equiv_of_equivalence.{u₁ u₁}
  { functor := functor.star (discrete α),
    inverse := discrete.functor (λ _, classical.arbitrary _),
    unit_iso := by { exact (iso_constant _ (classical.arbitrary _)), },
    counit_iso := functor.punit_ext _ _ }

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

/--
For objects `X Y : C`, any natural transformation `α : const X ⟶ const Y` from a connected
category must be constant.
This is the key property of connected categories which we use to establish properties about limits.
-/

instance [is_connected J] : full (functor.const J : C ⥤ J ⥤ C) :=
{ preimage := λ X Y f, f.app (classical.arbitrary J),
  witness' := λ X Y f,
  begin
    ext j,
    apply nat_trans_from_is_connected f (classical.arbitrary J) j,
  end }

instance nonempty_hom_of_connected_groupoid {G} [groupoid G] [is_connected G] :
  ∀ (x y : G), nonempty (x ⟶ y) :=
begin
  refine equiv_relation _ _ (λ j₁ j₂, nonempty.intro),
  exact ⟨λ j, ⟨𝟙 _⟩, λ j₁ j₂, nonempty.map (λ f, inv f), λ _ _ _, nonempty.map2 (≫)⟩,
end

end category_theory


-- Definición de matriz
-- ====================

import data.matrix.basic

universes u v
variables {n : Type u} [fintype n]
variables {R : Type v} [comm_ring R]

def my_matrix (n : ℕ) : matrix (fin n) (fin n) R
| ⟨0, hn⟩ j := 0
| i j       := 1

lemma my_matrix_def_not_the_first_row
  (n : ℕ)
  (i : fin n)
  (hn : 0 < n)
  (h0 : (⟨0, hn⟩ : fin n) ≠ i)
  (j : fin n)
  : (my_matrix n) i j = (1 : R) :=
begin
  cases n,
  { exact fin_zero_elim i },
  { rcases i with _|i,
    { simpa using h0 },
    { rw my_matrix } }
end


import
  algebra.ring.basic
  data.finset.pointwise
  data.int.parity
  data.int.interval
  data.int.modeq

/-! # IMO 2017 A2 -/

namespace IMOSL
namespace IMO2017A2

open finset
open_locale pointwise

def sq_add_diff_num {R : Type*} [ring R] (T : finset R) (x : R) :=
  ∃ a b c d : R, a ∈ T ∧ b ∈ T ∧ c ∈ T ∧ d ∈ T ∧ x = (a ^ 2 + b ^ 2) - (c ^ 2 + d ^ 2)

def good {R : Type*} [ring R] (q : R) (T : finset R) :=
  ∀ u v : R, u ∈ T → v ∈ T → sq_add_diff_num T (q * (u * v))

def excellent (k : ℕ) {R : Type*} [ring R] [decidable_eq R] (q : R) :=
  ∀ S : finset R, S.card = k → good q (S - S)

section extra_lemmas

private lemma special_identity {R : Type*} [comm_ring R] (w x y z : R) :
  2 * ((w - x) * (y - z)) = (w - z) ^ 2 + (x - y) ^ 2 - ((w - y) ^ 2 + (x - z) ^ 2) :=
  by ring

private lemma set_coe_image_sub {R : Type*} [ring R] [decidable_eq R] (S T : finset ℤ) :
  image (coe : ℤ → R) (S - T) = image coe S - image coe T :=
begin
  ext x; simp only [mem_image, mem_sub]; split,
  rintros ⟨a, ⟨x, y, h, h0, rfl⟩, rfl⟩;
    exact ⟨x, y, ⟨x, h, rfl⟩, ⟨y, h0, rfl⟩, by rw int.cast_sub⟩,
  rintros ⟨x, y, ⟨x, h, rfl⟩, ⟨y, h0, rfl⟩, rfl⟩;
    exact ⟨x - y, ⟨x, y, h, h0, rfl⟩, by rw int.cast_sub⟩
end

private lemma card_image_coe {R : Type*} [ring R] [decidable_eq R] [char_zero R] (T : finset ℤ) :
  (image (coe : ℤ → R) T).card = T.card :=
  card_image_of_injective T int.cast_injective

private lemma mem_diff_doubleton_mul {R : Type*} [ring R] [decidable_eq R]
  {x u v : R} (h : u ∈ ({0, x, -x} : finset R)) (h0 : v ∈ ({0, x, -x} : finset R)) :
  u * v ∈ ({0, x ^ 2, -x ^ 2} : finset R) :=
begin
  simp_rw [mem_insert, mem_singleton] at h h0 ⊢,
  rcases h with rfl | h,
  left; rw zero_mul,
  rcases h0 with rfl | h0,
  left; rw mul_zero,
  rcases h with rfl | rfl; rcases h0 with rfl | rfl,
  right; left; rw ← sq,
  right; right; rw [mul_neg, ← sq],
  right; right; rw [neg_mul, ← sq],
  right; left; rw [neg_mul_neg, ← sq]
end

variables {G : Type*} [add_group G] [decidable_eq G]

private lemma self_diff_singleton {T : finset G} (h : T.card = 1) : T - T = {0} :=
  by rw card_eq_one at h; rcases h with ⟨a, rfl⟩; rw [singleton_sub_singleton, sub_self]

private lemma self_diff_doubleton {T : finset G} (h : T.card = 2) :
  ∃ g : G, T - T = {0, g, -g} :=
begin
  rw card_eq_two at h,
  rcases h with ⟨a, b, -, rfl⟩; use a - b,
  simp_rw [neg_sub, insert_eq, union_sub, sub_union, singleton_sub_singleton, sub_self],
  rw [union_assoc, union_comm,← union_assoc, union_right_idem, union_comm]
end

end extra_lemmas

section sq_add_diff_num

variables {R : Type*} [ring R] {T : finset R} {x : R}

private lemma zero_is_sq_add_diff_num (h : T.nonempty) : sq_add_diff_num T 0 :=
  by cases h with x h; exact ⟨x, x, x, x, h, h, h, h, (sub_self (x ^ 2 + x ^ 2)).symm⟩

private lemma neg_is_sq_add_diff_num (h : sq_add_diff_num T x) :
  sq_add_diff_num T (-x) :=
  by rcases h with ⟨a, b, c, d, ha, hb, hc, hd, rfl⟩;
    exact ⟨c, d, a, b, hc, hd, ha, hb, neg_sub (a ^ 2 + b ^ 2) (c ^ 2 + d ^ 2)⟩

private lemma sq_is_sq_add_diff_num (h : x ∈ T) (h0 : (0 : R) ∈ T) :
  sq_add_diff_num T (x ^ 2) :=
  ⟨x, 0, 0, 0, h, h0, h0, h0, by rw [sq (0 : R), zero_mul, add_zero, add_zero, sub_zero]⟩

private lemma two_mul_sq_is_sq_add_diff_num (h : x ∈ T) (h0 : (0 : R) ∈ T) :
  sq_add_diff_num T (2 * x ^ 2) :=
  ⟨x, x, 0, 0, h, h, h0, h0, by rw [← two_mul, sq (0 : R), zero_mul, add_zero, sub_zero]⟩

private lemma is_sq_add_diff_num_imp_eq_int_cast [decidable_eq R]
  {T : finset ℤ} (h : sq_add_diff_num (image coe T) x) :
  ∃ n : ℤ, x = n :=
begin
  rcases h with ⟨a, b, c, d, ha, hb, hc, hd, rfl⟩,
  rw mem_image at ha hb hc hd,
  rcases ha with ⟨w, hw, rfl⟩,
  rcases hb with ⟨x, hx, rfl⟩,
  rcases hc with ⟨y, hy, rfl⟩,
  rcases hd with ⟨z, hz, rfl⟩,
  refine ⟨w ^ 2 + x ^ 2 - (y ^ 2 + z ^ 2), _⟩,
  simp_rw [int.cast_sub, int.cast_add, int.cast_pow]
end

private lemma cast_is_sq_add_diff_num_imp [decidable_eq R] [char_zero R]
  {T : finset ℤ} {n : ℤ} (h : sq_add_diff_num (image coe T) (n : R)) :
  sq_add_diff_num T n :=
begin
  rcases h with ⟨a, b, c, d, ha, hb, hc, hd, h⟩,
  rw mem_image at ha hb hc hd,
  rcases ha with ⟨w, hw, rfl⟩,
  rcases hb with ⟨x, hx, rfl⟩,
  rcases hc with ⟨y, hy, rfl⟩,
  rcases hd with ⟨z, hz, rfl⟩,
  simp_rw [← int.cast_pow, ← int.cast_add, ← int.cast_sub, int.cast_inj] at h,
  exact ⟨w, x, y, z, hw, hx, hy, hz, h⟩
end

end sq_add_diff_num

section good

variables {R : Type*} [ring R]

private lemma good_any_empty (q : R) : good q ∅ :=
  λ u v h _, by exfalso; exact h

private lemma good_any_singleton_zero (q : R) : good q {0} :=
  λ u v h _, by rw mem_singleton at h; rw [h, zero_mul, mul_zero];
    exact zero_is_sq_add_diff_num (singleton_nonempty 0)

private lemma good_neg_any {q : R} {T : finset R} (h : good q T) : good (-q) T :=
  λ u v h0 h1, by rw neg_mul; exact neg_is_sq_add_diff_num (h u v h0 h1)

private lemma good_zero_any (T : finset R) : good 0 T :=
  λ u _ h _, ⟨u, u, u, u, h, h, h, h, by rw [sub_self, zero_mul]⟩

private lemma good_one_self_diff_doubleton [decidable_eq R] (x : R) :
  good (1 : R) {0, x, -x} :=
begin
  intros u v h h0; rw one_mul,
  replace h := mem_diff_doubleton_mul h h0,
  generalize_hyp : u * v = y at h ⊢; clear h0 u v,
  have h0 : sq_add_diff_num ({0, x, -x} : finset R) (x ^ 2) :=
    sq_is_sq_add_diff_num (mem_insert_of_mem (mem_insert_self x _)) (mem_insert_self 0 _),
  simp_rw [mem_insert, mem_singleton] at h,
  rcases h with rfl | rfl | rfl,
  exacts [zero_is_sq_add_diff_num (insert_nonempty 0 {x, -x}), h0, neg_is_sq_add_diff_num h0]
end

private lemma good_two_self_diff_doubleton [decidable_eq R] (x : R) :
  good (2 : R) {0, x, -x} :=
begin
  intros u v h h0,
  replace h := mem_diff_doubleton_mul h h0,
  generalize_hyp : u * v = y at h ⊢; clear h0 u v,
  have h0 : sq_add_diff_num ({0, x, -x} : finset R) (2 * x ^ 2) :=
    two_mul_sq_is_sq_add_diff_num (mem_insert_of_mem (mem_insert_self x _)) (mem_insert_self 0 _),
  simp_rw [mem_insert, mem_singleton] at h,
  rcases h with rfl | rfl | rfl,
  rw mul_zero; exact zero_is_sq_add_diff_num (insert_nonempty 0 {x, -x}),
  exact h0,
  rw mul_neg; exact neg_is_sq_add_diff_num h0
end

private lemma good_two_self_diff {R : Type*} [comm_ring R] [decidable_eq R] (T : finset R) :
  good 2 (T - T) :=
begin
  intros u v h h0; unfold sq_add_diff_num,
  simp_rw mem_sub at h h0 ⊢,
  rcases h with ⟨w, x, hw, hx, rfl⟩,
  rcases h0 with ⟨y, z, hy, hz, rfl⟩,
  exact ⟨w - z, x - y, w - y, x - z, ⟨w, z, hw, hz, rfl⟩, ⟨x, y, hx, hy, rfl⟩,
    ⟨w, y, hw, hy, rfl⟩, ⟨x, z, hx, hz, rfl⟩, special_identity w x y z⟩
end

private lemma good_one_mem_imp_eq_int_cast [decidable_eq R]
  {q : R} {T : finset ℤ} (h : good q (image coe T)) (h0 : (1 : ℤ) ∈ T) :
  ∃ n : ℤ, q = n :=
begin
  replace h0 : (1 : R) ∈ image coe T :=
    by rw ← int.cast_one; exact mem_image_of_mem coe h0,
  replace h := h _ _ h0 h0,
  rw [mul_one, mul_one] at h; exact is_sq_add_diff_num_imp_eq_int_cast h
end

private lemma good_cast_cast_imp_good [decidable_eq R] [char_zero R]
  {n : ℤ} {T : finset ℤ} (h : good (n : R) (image coe T)) :
  good n T :=
begin
  intros u v h0 h1,
  replace h := h u v (mem_image_of_mem coe h0) (mem_image_of_mem coe h1),
  simp_rw ← int.cast_mul at h; exact cast_is_sq_add_diff_num_imp h
end

private lemma good_int_bound {n : ℤ} {T : finset ℤ} (h : good n T) (h0 : ∃ k : ℤ, k ≠ 0 ∧ k ∈ T) :
  n ∈ ({0, 1, -1, 2, -2} : finset ℤ) :=
begin
  ---- Get the integer with maximum square in `T`
  replace h0 : ∃ k : ℤ, k ≠ 0 ∧ k ∈ T ∧ ∀ m : ℤ, m ∈ T → m ^ 2 ≤ k ^ 2 :=
  begin
    rcases h0 with ⟨k, h0, h1⟩,
    let U := image (λ x, x ^ 2) T,
    replace h : U.nonempty := by rw nonempty.image_iff; exact ⟨k, h1⟩,
    obtain ⟨c, h2, h3⟩ : ∃ c : ℤ, c ∈ U ∧ ∀ d : ℤ, d ∈ U → d ≤ c :=
      ⟨U.max' h, max'_mem U h, le_max' U⟩,
    simp_rw mem_image at h3,
    replace h3 : ∀ m : ℤ, m ∈ T → m ^ 2 ≤ c := λ m h4, h3 (m ^ 2) ⟨m, h4, rfl⟩,
    rw mem_image at h2; rcases h2 with ⟨n, h2, rfl⟩,
    refine ⟨n, _, h2, h3⟩,
    rw ← sq_pos_iff at h0 ⊢; exact lt_of_lt_of_le h0 (h3 k h1)
  end,

  ---- Bound `a^2 + b^2` for `a, b ∈ T`
  rcases h0 with ⟨k, h0, h1, h2⟩,
  replace h2 : ∀ m n : ℤ, m ∈ T → n ∈ T → m ^ 2 + n ^ 2 ≤ 2 * k ^ 2 :=
    λ m n h3 h4, by rw two_mul; exact add_le_add (h2 m h3) (h2 n h4),
  have h3 : ∀ m n : ℤ, 0 ≤ m ^ 2 + n ^ 2 := λ m n, add_nonneg (sq_nonneg m) (sq_nonneg n),

  ---- Get the bound `|n| ≤ 2`
  replace h := h k k h1 h1,
  rcases h with ⟨a, b, c, d, ha, hb, hc, hd, h⟩; rw ← sq at h,
  replace h1 := le_trans (le_of_eq_of_le h (sub_le_self _ (h3 c d))) (h2 a b ha hb),
  rw [← neg_sub, eq_neg_iff_eq_neg, eq_comm] at h,
  replace h := le_trans (le_of_eq_of_le h (sub_le_self _ (h3 a b))) (h2 c d hc hd),
  rw [neg_le, ← neg_mul] at h,
  rw mul_le_mul_right ((sq_pos_iff k).mpr h0) at h1 h,
  replace h : |n| ≤ 2 := abs_le.mpr ⟨h, h1⟩,
  clear ha hb hc hd h0 h1 h2 h3 a b c d k T,

  ---- Finishing
  simp_rw [mem_insert, mem_singleton],
  rw [← abs_eq, ← or_assoc (n = 1), ← abs_eq, ← abs_nonpos_iff, ← int.lt_add_one_iff, zero_add,
      ← or_assoc, ← le_iff_lt_or_eq, ← int.lt_add_one_iff, ← bit0, ← le_iff_lt_or_eq],
  exacts [h, zero_le_one, zero_le_two]
end

private lemma not_good_one {T : finset ℤ}
  (h : (1 : ℤ) ∈ T) (h0 : (4 : ℤ) ∈ T) (h1 : ∀ x : ℤ, x ∈ T → odd x ∨ 4 ∣ x) :
  ¬good (1 : ℤ) T :=
begin
  ---- Some setup
  intros h2; replace h2 := h2 1 4 h h0; clear h h0,
  rw [one_mul, one_mul] at h2,
  replace h1 : ∀ x, x ∈ T → ∃ c : ℤ, (c = 0 ∨ c = 1) ∧ x ^ 2 ≡ c [ZMOD 8] :=
  begin
    change (8 : ℤ) with (2 : ℤ) ^ 2 * 2,
    intros x h; replace h1 := h1 x h,
    rcases h1 with ⟨y, rfl⟩ | ⟨y, rfl⟩,
    refine ⟨1, or.inr rfl, _⟩,
    replace h := int.even_mul_succ_self y; cases h with z h,
    rw [add_sq, one_pow, mul_one, ← mul_assoc, ← sq, mul_pow, ← mul_add, sq y, ← mul_add_one,
        h, ← two_mul, ← mul_assoc, int.modeq_iff_dvd, ← sub_sub, sub_sub_cancel_left, dvd_neg],
    exact ⟨z, rfl⟩,
    refine ⟨0, or.inl rfl, _⟩,
    rw [int.modeq_zero_iff_dvd, mul_pow],
    exact dvd_mul_of_dvd_left ⟨2, rfl⟩ (y ^ 2)
  end,

  ---- Reduce to modulo `8` equality
  rcases h2 with ⟨a, b, c, d, ha, hb, hc, hd, h2⟩,
  replace ha := h1 a ha; generalize_hyp : a ^ 2 = p at h2 ha,
  rcases ha with ⟨p0, hp, hp0⟩,
  replace hb := h1 b hb; generalize_hyp : b ^ 2 = q at h2 hb,
  rcases hb with ⟨q0, hq, hq0⟩,
  replace hc := h1 c hc; generalize_hyp : c ^ 2 = r at h2 hc,
  rcases hc with ⟨r0, hr, hr0⟩,
  replace hd := h1 d hd; generalize_hyp : d ^ 2 = s at h2 hd,
  rcases hd with ⟨s0, hs, hs0⟩,
  have h := (hp0.add hq0).sub (hr0.add hs0),
  rw [← h2, int.modeq_iff_dvd] at h,
  clear h1 h2 hp0 hq0 hr0 hs0 a b c d p q r s T,

  ---- `{0, 1} + {0, 1} ⊆ {0, 1, 2}`
  have h1 : ∀ a b : ℤ, (a = 0 ∨ a = 1) → (b = 0 ∨ b = 1) →
    a + b = 0 ∨ a + b = 1 ∨ a + b = 2 :=
  begin
    intros a b h h0,
    rcases h with rfl | rfl; rcases h0 with rfl | rfl,
    left; rw add_zero,
    right; left; rw zero_add,
    right; left; rw add_zero,
    right; right; rw ← bit0
  end,

  have h0 := h1 p0 q0 hp hq; generalize_hyp : p0 + q0 = u at h h0 ⊢,
  replace h1 := h1 r0 s0 hr hs; generalize_hyp : r0 + s0 = v at h h1 ⊢,
  clear hp hq hr hs p0 q0 r0 s0,

  ---- Finishing
  revert h; rw imp_false,
  rcases h0 with rfl | rfl | rfl; rcases h1 with rfl | rfl | rfl; norm_num
end

end good

section main_results

private lemma excellent_any_zero (R : Type*) [ring R] [decidable_eq R] (k : ℕ) :
  excellent k (0 : R) :=
  λ T _, good_zero_any (T - T)

private lemma excellent_any_two (R : Type*) [comm_ring R] [decidable_eq R] (k : ℕ) :
  excellent k (2 : R) :=
  λ T _, good_two_self_diff T

variables {R : Type*} [ring R] [decidable_eq R]

private lemma excellent_any_neg (k : ℕ) {q : R} (h : excellent k q) : excellent k (-q) :=
  λ T h0, good_neg_any (h T h0)

private lemma excellent_ge_two_imp [char_zero R]
  {k : ℕ} (h : 2 ≤ k) {q : R} (h0 : excellent k q) :
  q ∈ ({0, 1, -1, 2, -2} : finset R) :=
begin
  ---- First find some `T : finset ℤ` of size `k` such that `1 ∈ T - T`
  obtain ⟨T, rfl, h1⟩ : ∃ T : finset ℤ, T.card = k ∧ (1 : ℤ) ∈ T - T :=
  begin
    refine ⟨Ico (0 : ℤ) (k : ℤ), by rw [int.card_Ico, sub_zero, int.to_nat_coe_nat], _⟩,
    rw mem_sub; refine ⟨1, 0, _, _, sub_zero 1⟩,
    rw mem_Ico; exact ⟨int.one_nonneg, nat.one_lt_cast.mpr h⟩,
    rw mem_Ico; exact ⟨le_refl 0, nat.cast_pos.mpr (lt_of_lt_of_le two_pos h)⟩
  end,

  ---- Show that `q = ↑n` for some integer `n ∈ {0, 1, -1, 2, -2}`
  replace h0 := h0 (image coe T) (card_image_coe T),
  rw ← set_coe_image_sub at h0,
  obtain ⟨n, rfl⟩ := good_one_mem_imp_eq_int_cast h0 h1,
  replace h0 := good_int_bound (good_cast_cast_imp_good h0) ⟨1, one_ne_zero, h1⟩,

  ---- Finishing
  convert mem_image_of_mem (coe : ℤ → R) h0; clear h h0 h1 n T,
  simp_rw [image_insert, image_singleton, int.cast_neg],
  rw [int.cast_zero, int.cast_one, int.cast_two]
end

private lemma excellent_ge_three_imp [char_zero R] {k : ℕ} (h : 3 ≤ k) :
  ∀ {q : R}, excellent k q → q ∈ ({0, 2, -2} : finset R) :=
begin
  ---- Reduce to showing that `1 : R` is not `k`-excellent
  suffices h0 : ¬excellent k (1 : R),
  { intros q h1,
    replace h := excellent_ge_two_imp (le_trans (nat.le_succ 2) h) h1,
    simp_rw [mem_insert, mem_singleton] at h ⊢,
    rcases h with rfl | rfl | rfl | rfl | rfl,
    left; refl,
    exfalso; exact h0 h1,
    exfalso; rw ← neg_neg (1 : R) at h0,
    exact h0 (excellent_any_neg k h1),
    right; left; refl,
    right; right; refl },

  ---- Reduce to finding `T : finset ℤ` such that `1, 4 ∈ T - T` and
  ----   all elements of `T - T` are either odd or divisible by `4`
  rsuffices ⟨T, h0, ⟨h1, h2⟩, h3⟩ : ∃ T : finset ℤ,
    T.card = k ∧ ((1 : ℤ) ∈ T - T ∧ (4 : ℤ) ∈ T - T) ∧ ∀ x : ℤ, x ∈ T - T → odd x ∨ 4 ∣ x,
  { intros h4; replace h4 := h4 (image coe T) (by rw [card_image_coe, h0]),
    rw [← set_coe_image_sub, ← int.cast_one] at h4,
    exact not_good_one h1 h2 h3 (good_cast_cast_imp_good h4) },

  ---- Find the desired `T`
  obtain ⟨m, rfl⟩ := nat.exists_eq_succ_of_ne_zero (ne_of_gt (lt_trans two_pos h)),
  rw nat.succ_le_succ_iff at h; simp_rw mem_sub,
  let T := insert (1 : ℤ) (image (has_mul.mul (4 : ℤ)) (Ico 0 m)),
  refine ⟨T, _, _, _⟩,

  -- `|T| = m + 1`
  rw [card_insert_of_not_mem, card_image_of_injective, int.card_Ico, sub_zero, int.to_nat_coe_nat],
  exact mul_right_injective₀ four_ne_zero,
  intros h0; rw mem_image at h0,
  replace h0 : (4 : ℤ) ∣ 1 := by rcases h0 with ⟨a, -, h0⟩; exact ⟨a, h0.symm⟩,
  replace h0 := int.eq_one_of_dvd_one zero_le_four h0,
  revert h0; norm_num,

  -- `1, 4 ∈ T - T`
  rsuffices ⟨h0, h1, h2⟩ : (0 : ℤ) ∈ T ∧ (1 : ℤ) ∈ T ∧ (4 : ℤ) ∈ T,
    exact ⟨⟨1, 0, h1, h0, sub_zero 1⟩, ⟨4, 0, h2, h0, sub_zero 4⟩⟩,
  refine ⟨mem_insert_of_mem _, mem_insert_self 1 _, mem_insert_of_mem _⟩; rw mem_image,
  refine ⟨0, _, mul_zero 4⟩,
  rw [left_mem_Ico, int.coe_nat_pos]; exact lt_of_lt_of_le two_pos h,
  refine ⟨1, _, mul_one 4⟩,
  rw [mem_Ico, nat.one_lt_cast]; exact ⟨int.one_nonneg, lt_of_lt_of_le one_lt_two h⟩,

  -- `x ∈ T - T` implies `x` is odd or `4 ∣ x`
  replace h0 : ∀ c : ℤ, c ∈ T → c = 1 ∨ 4 ∣ c :=
  begin
    intros c h0; rw [mem_insert, mem_image] at h0,
    rcases h0 with rfl | ⟨a, -, rfl⟩,
    left; refl,
    right; use a
  end,

  rintros x ⟨a, b, h2, h3, rfl⟩,
  replace h2 := h0 a h2,
  replace h3 := h0 b h3,
  have h1 : ∀ c : ℤ, odd (4 * c - 1) :=
    λ c, by rw [int.odd_sub', iff_true_left odd_one, int.even_mul]; left; exact even_bit0 2,
  rcases h2 with rfl | ⟨u, rfl⟩; rcases h3 with rfl | ⟨v, rfl⟩,
  right; rw sub_self; exact dvd_zero 4,
  left; rw [← neg_sub, odd_neg]; exact h1 v,
  left; exact h1 u,
  right; rw ← mul_sub; exact ⟨u - v, rfl⟩
end

end main_results

/-- Final solution, `k = 0` -/
theorem final_solution_k_eq_0 {R : Type*} [ring R] [decidable_eq R] :
  ∀ q : R, excellent 0 q :=
  λ q T h, by rw [card_eq_zero.mp h, sub_empty]; exact good_any_empty q

/-- Final solution, `k = 1` -/
theorem final_solution_k_eq_1 {R : Type*} [ring R] [decidable_eq R] :
  ∀ q : R, excellent 1 q :=
  λ q T h, by rw self_diff_singleton h; exact good_any_singleton_zero q

/-- Final solution, `k = 2` -/
theorem final_solution_k_eq_2 {R : Type*} [ring R] [decidable_eq R] [char_zero R] :
  ∀ q : R, excellent 2 q ↔ q ∈ ({0, 1, -1, 2, -2} : finset R) :=
begin
  ---- Reduce to showing that `1, 2 : R` are `2`-excellent
  rsuffices ⟨h0, h1⟩ : excellent 2 (1 : R) ∧ excellent 2 (2 : R),
  { intros q; refine ⟨excellent_ge_two_imp (le_refl 2), λ h, _⟩,
    simp_rw [mem_insert, mem_singleton] at h,
    rcases h with rfl | rfl | rfl | rfl | rfl,
    exacts [excellent_any_zero R 2, h0, excellent_any_neg 2 h0, h1, excellent_any_neg 2 h1] },

  ---- Now show that both `1, 2 : R` are `2`-excellent
  refine ⟨λ T h, _, λ T h, _⟩;
    replace h := self_diff_doubleton h;
    cases h with x h; rw h,
  exacts [good_one_self_diff_doubleton x, good_two_self_diff_doubleton x]
end

/-- Final solution, `k ≥ 3` -/
theorem final_solution_k_ge_3 {k : ℕ} (h : 3 ≤ k)
  {R : Type*} [comm_ring R] [decidable_eq R] [char_zero R] :
  ∀ q : R, excellent k q ↔ q ∈ ({0, 2, -2} : finset R) :=
begin
  have h0 : excellent k (2 : R) := λ T _, good_two_self_diff T,
  refine λ q, ⟨excellent_ge_three_imp h, λ h1, _⟩,
  simp_rw [mem_insert, mem_singleton] at h1,
  rcases h1 with rfl | rfl | rfl,
  exacts [excellent_any_zero R k, h0, excellent_any_neg k h0]
end

end IMO2017A2
end IMOSL


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen, Devon Tuma
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.polynomial.basic
import Mathlib.ring_theory.non_zero_divisors
import Mathlib.PostPort

universes u_3 u_4 u_1 u_2

namespace Mathlib

/-- `scale_roots p s` is a polynomial with root `r * s` for each root `r` of `p`. -/
def scale_roots {R : Type u_3} [comm_ring R] (p : polynomial R) (s : R) : polynomial R :=
  finsupp.on_finset (finsupp.support p)
    (fun (i : ℕ) => polynomial.coeff p i * s ^ (polynomial.nat_degree p - i)) sorry

@[simp] theorem coeff_scale_roots {R : Type u_3} [comm_ring R] (p : polynomial R) (s : R) (i : ℕ) :
    polynomial.coeff (scale_roots p s) i =
        polynomial.coeff p i * s ^ (polynomial.nat_degree p - i) :=
  rfl

theorem coeff_scale_roots_nat_degree {R : Type u_3} [comm_ring R] (p : polynomial R) (s : R) :
    polynomial.coeff (scale_roots p s) (polynomial.nat_degree p) = polynomial.leading_coeff p :=
  sorry

@[simp] theorem zero_scale_roots {R : Type u_3} [comm_ring R] (s : R) : scale_roots 0 s = 0 := sorry

theorem scale_roots_ne_zero {R : Type u_3} [comm_ring R] {p : polynomial R} (hp : p ≠ 0) (s : R) :
    scale_roots p s ≠ 0 :=
  sorry

theorem support_scale_roots_le {R : Type u_3} [comm_ring R] (p : polynomial R) (s : R) :
    finsupp.support (scale_roots p s) ≤ finsupp.support p :=
  sorry

theorem support_scale_roots_eq {R : Type u_3} [comm_ring R] (p : polynomial R) {s : R}
    (hs : s ∈ non_zero_divisors R) : finsupp.support (scale_roots p s) = finsupp.support p :=
  sorry

@[simp] theorem degree_scale_roots {R : Type u_3} [comm_ring R] (p : polynomial R) {s : R} :
    polynomial.degree (scale_roots p s) = polynomial.degree p :=
  sorry

@[simp] theorem nat_degree_scale_roots {R : Type u_3} [comm_ring R] (p : polynomial R) (s : R) :
    polynomial.nat_degree (scale_roots p s) = polynomial.nat_degree p :=
  sorry

theorem monic_scale_roots_iff {R : Type u_3} [comm_ring R] {p : polynomial R} (s : R) :
    polynomial.monic (scale_roots p s) ↔ polynomial.monic p :=
  sorry

theorem scale_roots_eval₂_eq_zero {R : Type u_3} {S : Type u_4} [comm_ring R] [comm_ring S]
    {p : polynomial S} (f : S →+* R) {r : R} {s : S} (hr : polynomial.eval₂ f r p = 0) :
    polynomial.eval₂ f (coe_fn f s * r) (scale_roots p s) = 0 :=
  sorry

theorem scale_roots_aeval_eq_zero {R : Type u_3} {S : Type u_4} [comm_ring R] [comm_ring S]
    [algebra S R] {p : polynomial S} {r : R} {s : S} (hr : coe_fn (polynomial.aeval r) p = 0) :
    coe_fn (polynomial.aeval (coe_fn (algebra_map S R) s * r)) (scale_roots p s) = 0 :=
  scale_roots_eval₂_eq_zero (algebra_map S R) hr

theorem scale_roots_eval₂_eq_zero_of_eval₂_div_eq_zero {A : Type u_1} {K : Type u_2}
    [integral_domain A] [field K] {p : polynomial A} {f : A →+* K} (hf : function.injective ⇑f)
    {r : A} {s : A} (hr : polynomial.eval₂ f (coe_fn f r / coe_fn f s) p = 0)
    (hs : s ∈ non_zero_divisors A) : polynomial.eval₂ f (coe_fn f r) (scale_roots p s) = 0 :=
  sorry

theorem scale_roots_aeval_eq_zero_of_aeval_div_eq_zero {A : Type u_1} {K : Type u_2}
    [integral_domain A] [field K] [algebra A K] (inj : function.injective ⇑(algebra_map A K))
    {p : polynomial A} {r : A} {s : A}
    (hr : coe_fn (polynomial.aeval (coe_fn (algebra_map A K) r / coe_fn (algebra_map A K) s)) p = 0)
    (hs : s ∈ non_zero_divisors A) :
    coe_fn (polynomial.aeval (coe_fn (algebra_map A K) r)) (scale_roots p s) = 0 :=
  scale_roots_eval₂_eq_zero_of_eval₂_div_eq_zero inj hr hs

end Mathlib


-- import data.finset
import algebra.field
import field_theory.subfield
import field_theory.intermediate_field
-- import order.zorn
-- import Rings.ToMathlib
import Rings.Pregeometry

open classical
local attribute [instance] prop_decidable

universe u

namespace intermediate_field

  variables
    (K L : Type u) [field K] [field L] [algebra K L]

  @[simp] def closure : set L → subfield L :=
  λ S, subfield.closure (S ∪ set.range (algebra_map K L))

  @[simp] def closure' : set L → intermediate_field K L :=
  λ S, subfield.to_intermediate_field (closure K L S)
    (λ x, subfield.subset_closure (by simp))

  @[simp] def closure_fun : set L → set L :=
  λ S, closure K L S

  variables {K L}

  lemma closure_fun_closure {U : set L} : closure_fun K L U = closure K L U := rfl

  lemma closure'_closure {U : set L} : (closure' K L U : set L) = closure K L U := rfl

  lemma subset_closure (U : set L) : U ⊆ closure_fun K L U :=
  begin
    intros _ ha,
    simp only [closure, closure_fun],
    apply subfield.subset_closure,
    left,
    exact ha,
  end

  lemma closure_mono (U V : set L) (hUV : U ⊆ V) :
    closure_fun K L U ⊆ closure_fun K L V :=
  begin
    simp only [closure, closure_fun],
    intros _ ha,
    have hUVK : U ∪ set.range (algebra_map K L) ⊆ V ∪ set.range (algebra_map K L),
    {
      intros x hx,
      cases hx,
      {left, exact hUV hx},
      {right, exact hx}
    },
    apply subfield.closure_mono hUVK ha,
  end

  lemma closure_idem (U : set L) :
    closure_fun K L (closure_fun K L U)
      = closure_fun K L U :=
  begin
    rw closure_fun_closure,
    simp only [closure],
    have h : (closure_fun K L U) ∪ set.range (algebra_map K L) = closure_fun K L U,
    {
      rw set.union_eq_self_of_subset_right,
      intros x hx,
      simp only [closure, set_like.mem_coe, closure_fun],
      apply subfield.subset_closure,
      right,
      exact hx,
    },
    rw h,
    repeat {rw closure_fun_closure},
    simp only [set_like.coe_set_eq],
    apply subfield.closure_eq (closure K L U),
  end

end intermediate_field


import geometry.axioms data.set tactic.interactive
open classical
namespace Euclidean_plane
variables {point : Type} [Euclidean_plane point]

local attribute [instance, priority 0] prop_decidable

--Conclusions from the first 5 axioms
@[simp] theorem eqd.refl (a b : point) : eqd a b a b :=
eqd_trans (eqd_refl b a) (eqd_refl b a)

theorem eqd.symm {a b c d : point} : eqd a b c d → eqd c d a b :=
λ h, eqd_trans h (eqd.refl a b)

theorem eqd.trans {a b c d e f: point} : eqd a b c d → eqd c d e f → eqd a b e f :=
assume h h1,
eqd_trans h.symm h1

theorem two4 {a b c d : point} : eqd a b c d → eqd b a c d := eqd_trans (eqd_refl a b)

theorem two5 {a b c d : point} : eqd a b c d → eqd a b d c := assume h, eqd.trans h (eqd_refl c d)

theorem eqd.flip {a b c d : point} : eqd a b c d → eqd b a d c := assume h, two4 (two5 h)

theorem two7 {a b c d : point} : eqd a b c d → a ≠ b → c ≠ d :=
begin
intros h h1 h2,
subst d,
exact h1 (id_eqd h)
end

@[simp] theorem two8 (a b : point) : eqd a a b b :=
let ⟨x, h⟩ := seg_cons a b b b in
have a = x := id_eqd h.2,
by rw ←this at h; exact h.2

def afs (a b c d a' b' c' d' : point) : Prop := B a b c ∧ B a' b' c' ∧ eqd a b a' b'
∧ eqd b c b' c' ∧ eqd a d a' d' ∧ eqd b d b' d'

theorem afive_seg {a b c d a' b' c' d' : point} : afs a b c d a' b' c' d' →
a ≠ b → eqd c d c' d' :=
λ h h1, five_seg h1 h.1 h.2.1 h.2.2.1 h.2.2.2.1 h.2.2.2.2.1 h.2.2.2.2.2

theorem two11 {a b c a' b' c' : point} : B a b c → B a' b' c' → eqd a b a' b'
→ eqd b c b' c' → eqd a c a' c' :=
begin
intros h h1 h2 h3,
by_cases h_1 : a = b,
  subst b,
  rwa id_eqd h2.symm,
exact (five_seg h_1 h h1 h2 h3 (two8 a a') h2.flip).flip
end

theorem two12 {a q x y b c : point} (h : q ≠ a) : B q a x → eqd a x b c → B q a y → eqd a y b c → x = y :=
begin
intros h1 h2 h3 h4,
by_contradiction h_1,
suffices : eqd x x x y,
  exact h_1 (id_eqd this.symm),
apply five_seg h h1 h1 _ _ (two11 h1 h3 _ (h2.trans h4.symm)) (eqd.trans h2 h4.symm);
simp
end

-- Properties of B

@[simp] theorem three1 (a b : point) : B a b b :=
let ⟨x, h, h1⟩ := seg_cons b b b a in
by rwa (id_eqd h1).symm at h

theorem B.symm {a b c : point} : B a b c → B c b a :=
λ h, let ⟨x, h1, h2⟩ := pasch h (three1 b c) in
by rwa (bet_same h1).symm at h2

theorem three2 (a b c : point) : B a b c ↔ B c b a :=
⟨B.symm, B.symm⟩

@[simp] theorem three3 (a b : point) : B a a b :=
(three1 b a).symm

instance dec_eqp : decidable_eq point :=
begin
intros a b,
cases dec_B a b a,
  left,
  intro h_1,
  subst b,
  exact h (three1 a a),
right,
exact bet_same h
end

theorem three4 {a b c: point} : B a b c → B b a c → a = b :=
λ h h1, let ⟨x, hx⟩ := pasch h h1 in
(bet_same hx.2).trans (bet_same hx.1).symm

theorem three5a {a b c d : point} : B a b d → B b c d → B a b c :=
λ h h1, let ⟨x, h2, h3⟩ := pasch h h1 in
(bet_same h2).symm ▸ h3.symm

theorem three6a {a b c d : point} : B a b c → B a c d → B b c d :=
λ h h1, (three5a h1.symm h.symm).symm

theorem three7a {a b c d : point} : B a b c → B b c d → b ≠ c → B a c d :=
λ h h1 h2, let ⟨x, h3, h4⟩ := seg_cons c c d a in
(two12 h2 (three6a h h3) h4 h1 (eqd.refl c d)) ▸ h3

theorem three5b {a b c d : point} : B a b d → B b c d → B a c d :=
begin
intros h h1,
cases em (b = c),
  rwa h_1 at h,
exact three7a (three5a h h1) h1 h_1
end

theorem three6b {a b c d : point} : B a b c → B a c d → B a b d :=
λ h h1, (three5b h1.symm h.symm).symm

theorem three7b {a b c d : point} : B a b c → B b c d → b ≠ c → B a b d :=
λ h h1 h2, (three5b (three7a h h1 h2).symm h.symm).symm

theorem three13 : (P1 : point) ≠ P2 :=
begin
intro h,
apply (two_dim point).1,
rw h,
exact three3 P2 P3
end

def three14 (a b : point) : {c // B a b c ∧ b ≠ c} :=
begin
cases seg_cons b P1 P2 a with c h,
cases h with h1 h2,
refine ⟨c, h1, _⟩,
intro h_1,
subst c,
exact three13 (id_eqd h2.symm)
end

theorem three15 {a b c : point} : B a b c → eqd a b a c → b = c :=
begin
intros h h1,
by_cases h_1 : a = c,
  subst c,
  exact id_eqd h1.flip,
cases three14 c a with d hd,
exact two12 hd.2.symm (three5a hd.1.symm h) h1 hd.1.symm (eqd.refl a c)
end

theorem three17 {a b c a' b' p : point} : B a b c → B a' b' c
→ B a p a' → {q // B p q c ∧ B b q b'} :=
begin
intros h1 h2 h3,
cases pasch h3 h2.symm with x h4,
cases pasch h1.symm h4.2 with y h5,
exact ⟨y, three5b h4.1 h5.2, h5.1⟩
end

-- cong + col

def ifs (a b c d a' b' c' d' : point) : Prop := B a b c ∧ B a' b' c' ∧ eqd a c a' c'
∧ eqd b c b' c' ∧ eqd a d a' d' ∧ eqd c d c' d'

theorem four2 {a b c d a' b' c' d' : point} : ifs a b c d a' b' c' d' → eqd b d b' d' :=
begin
rintro ⟨h, h1, h2, h3, h4, h5⟩,
cases em (a = c),
  subst c,
  rw (bet_same h) at h3 h5,
  rwa (id_eqd h3.symm).symm at h5,
cases three14 a c with e he,
cases seg_cons c' c e a' with e' he',
have : afs a c e d a' c' e' d',
  repeat {split};
    try{assumption},
    exact he.1,
    exact he'.1,
  exact he'.2.symm,
have : eqd e d e' d',
  exact afive_seg this h_1,
exact five_seg he.2.symm (three6a h he.1).symm (three6a h1 he'.1).symm he'.2.symm.flip h3.flip this h5
end

theorem four3 {a b c a' b' c' : point} : B a b c → B a' b' c' → eqd a c a' c'
→ eqd b c b' c' → eqd a b a' b' :=
begin
intros h h1 h2 h3,
  have : ifs a b c a a' b' c' a',
  repeat {split};
    try{assumption},
    exact two8 a a',
  exact h2.flip,
exact (four2 this).flip
end

def cong (a b c a' b' c' : point) : Prop := eqd a b a' b' ∧ eqd b c b' c' ∧ eqd a c a' c'

@[simp] theorem cong.refl (a b c : point) : cong a b c a b c :=
begin
repeat {split};
exact eqd.refl _ _
end

theorem cong.symm {a b c a' b' c' : point} : cong a b c a' b' c' → cong a' b' c' a b c :=
begin
intro h,
split,
  exact h.1.symm,
split,
  exact h.2.1.symm,
exact h.2.2.symm
end

theorem cong.trans {a b c a' b' c' a'' b'' c'' : point} : cong a b c a' b' c' → cong a' b' c' a'' b'' c'' → cong a b c a'' b'' c'' :=
begin
intros h h1,
split,
  exact eqd.trans h.1 h1.1,
split,
  exact eqd.trans h.2.1 h1.2.1,
exact eqd.trans h.2.2 h1.2.2
end

lemma four4 {a b c a' b' c' : point} : cong a b c a' b' c' → cong a c b a' c' b' ∧ cong b a c b' a' c' ∧
cong b c a b' c' a' ∧ cong c a b c' a' b' ∧ cong c b a c' b' a' :=
λ h, ⟨⟨h.2.2, h.2.1.flip, h.1⟩, ⟨h.1.flip, h.2.2, h.2.1⟩, ⟨h.2.1, h.2.2.flip, h.1.flip⟩,
⟨h.2.2.flip, h.1, h.2.1.flip⟩, ⟨h.2.1.flip, h.1.flip, h.2.2.flip⟩⟩

def four5 {a b c a' c' : point} : B a b c → eqd a c a' c'
→ {b'// B a' b' c' ∧ cong a b c a' b' c'} :=
begin
intros h h1,
cases three14 c' a' with d' hd,
cases seg_cons a' a b d' with b' hb,
cases seg_cons b' b c d' with c'' hc,
have h2 : B a' b' c'' ∧ B d' a' c'',
  split,
    exact three6a hb.1 hc.1,
  exact three6b hb.1 hc.1,
have h3 : eqd a' c'' a c,
  exact two11 h2.1 h hb.2 hc.2,
have h4 : c' = c'',
  exact (two12 hd.2.symm) hd.1.symm h1.symm h2.2 h3,
rw ←h4 at *,
existsi b',
split,
  exact h2.1,
unfold cong,
split,
  apply four3 h h2.1,
    exact h3.symm,
  exact hc.2.symm,
split,
  exact hc.2.symm,
exact h3.symm
end

theorem four6 {a b c a' b' c' : point} : B a b c → cong a b c a' b' c' → B a' b' c' :=
begin
intros h h1,
cases h1 with h1 h2,
cases h2 with h2 h3,
cases four5 h h3 with b'' hb,
cases hb with hb hb1,
cases hb1 with hb1 hb2,
cases hb2 with hb2 hb3,
have : ifs a' b'' c' b'' a' b'' c' b',
  repeat {split};
    try {assumption},
    exact eqd.trans hb3.symm h3,
    exact eqd.refl _ _,
    exact eqd.trans hb1.symm h1,
    have : eqd b'' c' b' c',
      exact eqd.trans hb2.symm h2,
    exact this.flip,
have : b'' = b',
  have h4 : eqd b'' b'' b'' b',
    exact four2 this,
  exact id_eqd h4.symm,
rwa this at *
end

def col (a b c : point) : Prop := B a b c ∨ B b c a ∨ B c a b

instance dec_col : ∀ (a : point) b c, decidable (col a b c) :=
begin
intros,
cases dec_B a b c,
  cases dec_B b c a,
    cases dec_B c a b,
      left,
      unfold col,
      simp *,
    exact is_true (or.inr (or.inr h_2)),
  exact is_true (or.inr (or.inl h_1)),
exact is_true (or.inl h)
end

theorem four11 {a b c : point} : col a b c → col a c b ∧ col b a c ∧ col b c a ∧ col c a b ∧ col c b a :=
begin
intro h,
cases h with h1 h2,
  have := h1.symm,
  repeat {split}; unfold col;
  simp *,
cases h2 with h2 h3,
  have := h2.symm,
  repeat {split};unfold col;
  simp *,
have := h3.symm,
repeat {split}; unfold col;
simp *
end

theorem four10 {a b c : point} : ¬col a b c → ¬col a c b ∧ ¬col b a c ∧ ¬col b c a ∧ ¬col c a b ∧ ¬col c b a :=
begin
intro h,
split,
  intro h_1,
  exact h (four11 h_1).1,
split,
  intro h_1,
  exact h (four11 h_1).2.1,
split,
  intro h_1,
  exact h (four11 h_1).2.2.2.1,
split,
  intro h_1,
  exact h (four11 h_1).2.2.1,
intro h_1,
exact h (four11 h_1).2.2.2.2
end

theorem four12 (a b : point) : col a a b :=
or.inl (three3 a b)

theorem four13 {a b c a' b' c' : point} : col a b c → cong a b c a' b' c' → col a' b' c' :=
begin
intros h h1,
unfold col,
cases h,
  have := four6 h h1,
  simp *,
cases h,
  have := four6 h (four4 h1).2.2.1,
  simp *,
have := four6 h (four4 h1).2.2.2.1,
simp *
end

def four14 {a b c a' b' : point} (h : col a b c) (h1 : eqd a b a' b') : {c' // cong a b c a' b' c'} :=
begin
cases dec_B a b c,
  cases dec_B b c a,
    replace h : B c a b,
      unfold col at h,
      simpa [h_1, h_2] using h,
      cases seg_cons a' a c b' with c' hc,
    exact ⟨c', h1, two11 h.symm hc.1 h1.flip hc.2.symm, hc.2.symm⟩,
  cases four5 h_2 h1.flip with c' hc,
  exact ⟨c', (four4 hc.2).2.2.2.1⟩,
cases seg_cons b' b c a' with c' hc,
exact ⟨c', h1, hc.2.symm, two11 h_1 hc.1 h1 hc.2.symm⟩
end

def fs (a b c d a' b' c' d' : point) : Prop := col a b c ∧ cong a b c a' b' c' ∧
eqd a d a' d' ∧ eqd b d b' d'

theorem four16 {a b c d a' b' c' d' : point} : fs a b c d a' b' c' d' → a ≠ b → eqd c d c' d' :=
begin
intros h1 h,
cases h1 with h1 h2,
cases h2 with h2 h3,
cases h3 with h3 h4,
cases h1 with ha hbc,
  exact five_seg h ha (four6 ha h2) h2.1 h2.2.1 h3 h4,
cases hbc with hb hc,
  have : ifs b c a d b' c' a' d',
    repeat {split};
      try {assumption},
        exact four6 hb (four4 h2).2.2.1,
      exact h2.1.flip,
    exact h2.2.2.flip,
  exact four2 this,
rw three2 at hc,
have : cong b a c b' a' c',
  unfold cong,
  split,
    exact h2.1.flip,
  split,
    exact h2.2.2,
  exact h2.2.1,
exact five_seg h.symm hc (four6 hc this) h2.1.flip h2.2.2 h4 h3
end

theorem four17 {a b c p q : point} : a ≠ b → col a b c → eqd a p a q → eqd b p b q → eqd c p c q :=
begin
intros h h1 h2 h3,
have : fs a b c p a b c q,
  unfold fs,
  repeat {split}; try {assumption};
  exact eqd.refl _ _,
exact four16 this h
end

theorem four18 {a b c c' : point} : a ≠ b → col a b c → eqd a c a c' → eqd b c b c' → c = c':=
begin
intros h h3 h1 h2,
have : eqd c c c c',
  exact four17 h h3 h1 h2,
exact id_eqd this.symm
end

theorem four19 {a b c b' : point} : B a b c → eqd a b a b' → eqd b c b' c → b = b' :=
begin
intros h h1 h2,
cases em (a = c) with h3 h4,
  rw ←h3 at *,
  have : a = b, exact bet_same h,
  rw this at *,
  exact id_eqd h1.symm,
have : col a c b,
  right, left,
  exact h.symm,
exact four18 h4 this h1 h2.flip
end

-- Ordering collinear points & Comparing distances

theorem five1 {a b c d : point} : a ≠ b → B a b c → B a b d → B a c d ∨ B a d c :=
begin
intros h h1 h2,
cases em (c = d),
  left, rw h_1 at *, exact three1 a d,
cases seg_cons d d c a with c' hc,
cases seg_cons c c d a with d' hd,
cases seg_cons c' c b d with b' ha,
cases seg_cons d' d b c with b'' hb,
have h_2 : d ≠ c',
  intro h_2,
  rw ←h_2 at hc,
  have : c = d,
    exact id_eqd hc.2.symm.flip,
  contradiction,
have h_3 : d' ≠ c,
  intro h_3,
  rw h_3 at hd,
  have : c = d,
    exact id_eqd hd.2.symm,
  contradiction,
have h3 : B b d c',
  exact three6a h2 hc.1,
have h4 : eqd b c' b'' c,
  exact two11 h3 hb.1.symm hb.2.symm.flip (eqd.trans hc.2 hd.2.symm.flip),
have h5 : B b c' b',
  exact three7a h3 ha.1 h_2,
have h_4 : B b c d',
  exact three6a h1 hd.1,
have h6 : B b'' c b,
  exact three7a hb.1.symm h_4.symm h_3,
have h7 : eqd b b' b'' b,
  exact two11 h5 h6 h4 ha.2,
have h_5 : B a b b',
  have : B a d b',
    exact three7b hc.1 ha.1 h_2,
  exact three6b h2 this,
have h_6 : B a b b'',
  have : B a c b'',
    exact three7b hd.1 hb.1 h_3.symm,
  exact three6b h1 this,
have h8 : b' = b'',
  apply two12 h h_5 (eqd.refl b b') h_6,
  exact two4 h7.symm,
rw ←h8 at *,
have h9 : afs b c d' c' b' c' d c,
  repeat {split}; try {assumption},
    exact ha.1.symm,
    exact ha.2.symm.flip,
    exact eqd.trans hd.2 hc.2.symm.flip,
  exact two5 (eqd.refl c c'),
cases em (b = c),
  left,
  rw ←h_7, exact h2,
have h10 : eqd c d c' d',
  exact (afive_seg h9 h_7).symm.flip,
cases pasch hd.1.symm hc.1.symm with e he,
have h11 : ifs d e d' c d e d' c',
  repeat {split}; try {assumption},
    exact he.2,
    exact he.2,
    exact eqd.refl d d',
    exact eqd.refl e d',
    exact hc.2.symm,
  exact eqd.trans hd.2.flip h10.flip,
have h12 : ifs c e c' d c e c' d',
  repeat {split}; try {assumption},
    exact he.1,
    exact he.1,
    exact eqd.refl c c',
    exact eqd.refl e c',
    exact hd.2.symm,
  exact eqd.trans hc.2.flip h10,
have h_8 : eqd e c e c',
  exact four2 h11,
have h_9 : eqd e d e d',
  exact four2 h12,
cases em (c = c'),
  rw ←h_10 at hc,
  right, exact hc.1,
cases seg_cons c c d' c' with p hp,
cases seg_cons c c e d' with r hr,
cases seg_cons r r p p with q hq,
have h13 : afs d' c r p p c e d',
  repeat {split},
    exact hr.1,
    exact three5a hp.1.symm he.1,
    exact hp.2.symm.flip,
    exact hr.2,
    exact two4 (eqd.refl p d'),
  exact hp.2,
have h_11 : eqd r p e d',
  exact afive_seg h13 h_3,
have h_12 : eqd r q e d,
  exact eqd.trans hq.2 (eqd.trans h_11 h_9.symm),
have h14 : afs d' e d c p r q c,
  repeat {split},
    exact he.2.symm,
    exact hq.1,
    exact h_11.symm.flip,
    exact h_12.symm,
    exact hp.2.symm.flip,
  exact hr.2.symm.flip,
have h_13 : eqd d' d p q,
  exact two11 he.2.symm hq.1 h_11.symm.flip h_12.symm,
cases em (d' = e),
  rw ←h_14 at *,
  have : d' = d,
    exact id_eqd h_9,
  rw this at *,
  left, exact hd.1,
have h_15 : eqd c q c d,
  exact (afive_seg h14 h_14).symm.flip,
have h15 : eqd c p c q,
  exact eqd.trans hp.2 (eqd.trans hd.2 h_15.symm),
have h_16 : r ≠ c,
  intro hrc,
  rw hrc at *,
  have : c = e,
    exact id_eqd hr.2.symm,
  rw ←this at *,
  have : c = c',
    exact id_eqd h_8.symm,
  exact h_10 this,
have h16 : col r c d',
  left, exact hr.1.symm,
have h_17 : eqd d' p d' q,
  exact four17 h_16 h16 hq.2.symm h15,
have h17 : col c d' b,
  right, right, exact h_4,
have h18 : col c d' b',
  left, exact hb.1,
have h_18 : eqd b p b q,
  exact four17 h_3.symm h17 h15 h_17,
have h_19 : eqd b' p b' q,
  exact four17 h_3.symm h18 h15 h_17,
have h19 : col b b' c',
  right, left, exact h5.symm,
have h_20 : b ≠ b',
  intro hbb,
  rw ←hbb at *,
  have : b = c,
    exact bet_same h6,
  exact h_7 this,
have h_21 : eqd c' p c' q,
  exact four17 h_20 h19 h_18 h_19,
have h20 : col c' c p,
  left, exact hp.1,
have h_22 : eqd p p p q,
  exact four17 (ne.symm h_10) h20 h_21 h15,
have h21 : p = q,
  exact id_eqd h_22.symm,
rw h21 at *,
have : d' = d,
  exact id_eqd h_13,
rw this at *,
left,
exact hd.1
end

theorem five2 {a b c d : point} : a ≠ b → B a b c → B a b d → B b c d ∨ B b d c :=
begin
intros h h1 h2,
cases five1 h h1 h2,
  left,
  exact three6a h1 h_1,
right,
exact three6a h2 h_1
end

theorem five3 {a b c d : point} : B a b d → B a c d → B a b c ∨ B a c b :=
begin
intros h h1,
cases three14 d a with p hp,
have h2 : B p a b,
  exact three5a hp.1.symm h,
have h3 : B p a c,
  exact three5a hp.1.symm h1,
cases five1 hp.2.symm h2 h3 with hb hc,
  left,
  exact three6a h2 hb,
right,
exact three6a h3 hc
end

theorem five4 {a b c d : point} : a ≠ b → col a b c → col a b d → col a c d :=
begin
intros h h1 h2,
cases h1,
  cases h2,
    cases five1 h h1 h2,
      left,
      assumption,
    right, left,
    exact h_1.symm,
  cases h2,
    right, left,
    exact (three6b h2.symm h1).symm,
  right, right,
  exact three7b h2 h1 h,
cases h1,
  cases h2,
    left,
    exact three6b h1.symm h2,
  cases h2,
    cases five3 h1.symm h2.symm,
      left,
      assumption,
    right, left,
    exact h_1.symm,
  right, right,
  exact three5a h2 h1.symm,
cases h2,
  right, right,
  exact (three7b h1 h2 h).symm,
cases h2,
  right, right,
  exact three6a h2 h1.symm,
cases five2 h.symm h1.symm h2.symm,
  left,
  assumption,
right, left,
exact h_1.symm
end

theorem five7 {a b x y z : point} : B a x b → B a z b → B x y z → B a y b :=
begin
intros h h1 h2,
cases five3 h h1,
  apply three6b _ h1,
  exact three5b h_1 h2,
apply three6b _ h,
exact three5b h_1 h2.symm
end

def distle (a b c d : point) : Prop := ∃ y, B c y d ∧ eqd a b c y

theorem five5 {a b c d : point} : distle a b c d ↔ ∃ x, B a b x ∧ eqd a x c d :=
begin
split,
  intro h,
  cases h with y hy,
  have : col c y d,
    left,
    exact hy.1,
  cases four14 this hy.2.symm with x hx,
  constructor,
    split,
    exact four6 hy.1 hx,
    exact hx.2.2.symm,
intro h,
cases h with x hx,
unfold distle,
have : col a x b,
  right, left,
  exact hx.1.symm,
cases four14 this hx.2 with y hy,
constructor,
  split,
    exact (four6 hx.1.symm (four4 hy).2.2.1).symm,
exact hy.2.2
end

theorem five6 {a b c d a' b' c' d' : point} : distle a b c d → eqd a b a' b' →
eqd c d c' d' → distle a' b' c' d' :=
begin
intros h h1 h2,
cases h with x hx,
cases four5 hx.1 h2 with y hy,
constructor,
  split,
  exact hy.1,
exact eqd.trans h1.symm (eqd.trans hx.2 hy.2.1)
end

theorem distle.refl (a b : point) : distle a b a b :=
begin
constructor,
  split,
    exact three1 a b,
exact eqd.refl a b
end

theorem distle.trans {a b c d e f : point} : distle a b c d → distle c d e f → distle a b e f :=
begin
intros h h1,
cases h with x hx,
cases h1 with y hy,
cases four5 hx.1 hy.2 with z hz,
constructor,
  split,
    exact three6b hz.1 hy.1,
exact eqd.trans hx.2 hz.2.1
end

theorem distle.flip {a b c d : point} : distle a b c d → distle b a d c :=
λ h, five6 h (two5 (eqd.refl a b)) (two5 (eqd.refl c d))

theorem five9 {a b c d : point} : distle a b c d → distle c d a b → eqd a b c d :=
begin
intros h h1,
cases h1 with x hx,
cases five5.mp h with z hz,
cases three14 b a with p hp,
cases hp with h1 h2,
rw three2 at h1,
cases em (a = b),
  rw h_1 at *,
  have : b = x,
    exact bet_same hx.1,
  rw this at *,
  exact hx.2.symm,
have h2 : p ≠ a,
  exact h2.symm,
have : x = z,
  exact two12 h2 (three5a h1 hx.1) hx.2.symm (three7b h1 hz.1 h_1) hz.2,
rw this at *,
have : b = z,
  exact three4 hx.1.symm hz.1.symm,
rw this at *,
exact hz.2
end

theorem five10 (a b c d : point) : distle a b c d ∨ distle c d a b :=
begin
cases three14 b a with p hp,
cases seg_cons a c d p with x hx,
cases five1 hp.2.symm hp.1.symm hx.1,
  have : B a b x,
    exact three6a hp.1.symm h,
  left,
  apply five5.mpr,
  constructor,
    split,
      exact this,
  exact hx.2,
  have : B a x b,
    exact three6a hx.1 h,
  right,
  constructor,
    split,
      exact this,
  exact hx.2.symm
end

theorem five11 (a b c : point) : distle a a b c :=
begin
cases five10 a a b c with h,
  assumption,
cases h with x hx,
have : a = x ,
  exact bet_same hx.1,
rw this at *,
have : b = c,
  exact id_eqd hx.2,
rw this at *,
existsi c,
split,
  exact three1 c c,
exact hx.2.symm
end

theorem five12 {a b c : point} : col a b c → (B a b c ↔ distle a b a c ∧ distle b c a c) :=
begin
intro h,
split,
  intro h1,
  split,
    constructor,
      split,
        exact h1,
    exact eqd.refl a b,
    have h2 : distle c b c a,
      constructor,
        split,
          exact h1.symm,
    exact eqd.refl c b,
  apply five6 h2,
    exact two5 (eqd.refl c b),
  exact two5 (eqd.refl c a),
intro h1,
cases h1 with h1 h2,
cases h1 with x hx,
have : distle c b c a,
  exact five6 h2 (two5 (eqd.refl b c)) (two5 (eqd.refl a c)),
cases this with y hy,
cases h with h,
  assumption,
cases h with h3 h4,
  rw three2 at h3,
  cases three14 b a with p hp,
  have : B p a c,
    exact three5a hp.1.symm h3,
  have : B p a x,
    exact three5a this hx.1,
  have : b = x,
    exact two12 hp.2.symm hp.1.symm (eqd.refl a b) this hx.2.symm,
  rw ←this at *,
  exact hx.1,
rw three2 at h4,
cases three14 b c with q hq,
have : B q c a,
  exact three5a hq.1.symm h4.symm,
have : B q c y,
  exact three5a this hy.1,
 have : b = y,
  exact two12 hq.2.symm hq.1.symm (eqd.refl c b) this hy.2.symm,
rw ←this at *,
exact hy.1.symm
end

def distlt (a b c d : point) : Prop := distle a b c d ∧ ¬eqd a b c d

theorem five13 {a b c d : point} : distlt a b c d ↔ ∃ y, B c y d ∧ eqd a b c y ∧ y ≠ d :=
begin
split,
  rintros ⟨⟨y, hy⟩, h1⟩,
  refine ⟨y, hy.1, hy.2, _⟩,
  intro h_1,
  subst y,
  exact h1 hy.2,
rintros ⟨y, h, h1, h2⟩,
refine ⟨⟨y, h, h1⟩, _⟩,
intro h_1,
exact h2 (three15 h (h1.symm.trans h_1))
end

theorem five14 {a b c d a' b' c' d' : point} : distlt a b c d → eqd a b a' b' →
eqd c d c' d' → distlt a' b' c' d' :=
λ h h1 h2, ⟨five6 h.1 h1 h2, λ h_1, h.2 (h1.trans (h_1.trans h2.symm))⟩

theorem distlt.trans {a b c d e f : point} : distlt a b c d → distlt c d e f → distlt a b e f :=
λ h h1, ⟨h.1.trans h1.1, λ h_1, h.2 (five9 h.1 (five6 h1.1 (eqd.refl c d) h_1.symm))⟩

theorem distlt.flip {a b c d : point} : distlt a b c d → distlt b a d c :=
λ h, ⟨h.1.flip, λ h_1, h.2 h_1.flip⟩

theorem five15 {a b c d : point} : distlt a b c d → distlt c d a b → false :=
λ h h1, (h.trans h1).2 (eqd.refl a b)

theorem dist_lt_or_eq_of_le {a b c d : point} : distle a b c d → distlt a b c d ∨ eqd a b c d :=
begin
intro h,
cases em (eqd a b c d),
  exact or.inr h_1,
exact or.inl ⟨h, h_1⟩
end

theorem dist_lt_iff_not_le {a b c d : point} : distlt a b c d ↔ ¬distle c d a b :=
begin
split,
  intros h h1,
  exact h.2 (five9 h.1 h1),
intro h,
split,
  have h1 := five10 a b c d,
  simp [h] at h1,
  exact h1,
intro h1,
exact h (five6 (distle.refl a b) h1 (eqd.refl a b))
end

theorem dist_le_iff_not_lt {a b c d : point} : distle a b c d ↔ ¬distlt c d a b :=
begin
split,
  intros h h1,
  exact dist_lt_iff_not_le.1 h1 h,
intro h,
by_contradiction h_1,
exact h (dist_lt_iff_not_le.2 h_1)
end

theorem dist_total (a b c d : point) : distlt a b c d ∨ eqd a b c d ∨ distlt c d a b :=
begin
cases em (distle a b c d),
  cases dist_lt_or_eq_of_le h;
  simp *,
simp [dist_lt_iff_not_le.2 h]
end

-- Rays and Lines

def sided (p a b : point) : Prop := a ≠ p ∧ b ≠ p ∧ (B p a b ∨ B p b a)

theorem six1 {a b p : point} : col a p b → B a p b ∨ sided p a b :=
begin
intro h,
cases em (B a p b),
  exact or.inl h_1,
unfold col at h,
simp * at *,
rw [three2 b a p] at h,
refine ⟨_, _, h.symm⟩;
intro h_1;
subst p,
  exact h_1 (three3 a b),
exact h_1 (three1 a b)
end

theorem six2 {a b c p : point} : a ≠ p → b ≠ p → c ≠ p → B a p c → (B b p c ↔ sided p a b) :=
begin
intros h h1 h2 h3,
split,
  intro h4,
    unfold sided; repeat {split}; try {assumption},
  exact five2 h2 h3.symm h4.symm,
intro h4,
cases h4 with h h1,
cases h1 with h1 ha,
cases ha with ha hb,
  exact three7a ha.symm h3 h,
exact three6a hb.symm h3
end

theorem six3 {a b p : point} : sided p a b ↔ a ≠ p ∧ b ≠ p ∧ ∃ c, c ≠ p ∧ B a p c ∧ B b p c :=
begin
split,
  intro h,
  cases h with h h1,
  cases h1 with h1 h2,
  split, exact h,
    split, exact h1,
    cases three14 a p with c hc,
    constructor, split,
      exact hc.2.symm,
  split, exact hc.1,
  cases h2,
    exact three7a h2.symm hc.1 h,
  exact three6a h2.symm hc.1,
intro h,
cases h with h h1,
cases h1 with h1 h2,
split, exact h,
split, exact h1,
cases h2 with c h2,
exact five2 h2.1 h2.2.1.symm h2.2.2.symm
end

theorem six4 {a b p : point} : sided p a b ↔ col a p b ∧ ¬B a p b :=
begin
split,
  rintros ⟨h, h1, h2⟩,
  cases h2 with ha hb,
    split,
      unfold col,
      simp [ha.symm],
    intro h2,
    exact h (three4 h2 ha),
  split,
    unfold col,
    simp [hb],
  intro h2,
  exact h1 (three4 h2.symm hb),
rintros ⟨h, h1⟩,
split,
  intro h1,
  subst p,
  exact h1 (three3 a b),
split,
  intro h1,
  subst p,
  exact h1 (three1 a b),
unfold col at h,
simp [h1] at h,
rw [three2 b a p] at h,
exact h.symm
end

theorem six5 {a p : point} : a ≠ p → sided p a a :=
begin
intro h,
apply six4.2,
split,
  right, left,
  exact three1 p a,
intro h1,
exact h (bet_same h1)
end

theorem six6 {a b c d : point} : B a b c → sided b c d → B a b d :=
begin
intros h h1,
cases h1.2.2,
  exact three7b h h_1 h1.1.symm,
exact three5a h h_1
end

theorem six7 {a b p : point} : B p a b → a ≠ p → sided p a b :=
begin
intros h h1,
refine ⟨h1, _, or.inl h⟩,
intro h_1,
subst h_1,
exact h1.symm (bet_same h)
end

theorem sided.symm {a b p : point} : sided p a b → sided p b a :=
begin
intro h,
cases six3.1 h with h h1,
cases h1 with h1 h2,
cases h2 with c hc,
apply six3.2,
split, exact h1,
split, exact h,
constructor,
  split,
    exact hc.1,
split,
  exact hc.2.2,
exact hc.2.1
end

theorem sided.trans {a b c p : point} : sided p a b → sided p b c → sided p a c :=
begin
intros h1 h,
cases six3.1 h1 with h1 h2,
cases h2 with h2 h3,
cases h3 with q hq,
have h3 : c ≠ p,
  exact h.2.1,
have : B c p q,
  exact (six2 h2 h3 hq.1 hq.2.2).2 h,
exact (six2 h1 h3 hq.1 hq.2.1).1 this
end

theorem six6a {a b c d : point} : sided a b c → B b d c → sided a b d :=
begin
intros h h1,
cases h.2.2,
  exact six7 (three5a h_1 h1) h.1,
exact h.trans (six7 (three5a h_1 h1.symm) h.2.1)
end

theorem six7a {a b c p : point} : B p a b → sided p a c → sided p b c :=
begin
intros h h1,
apply sided.trans _ h1,
exact (six7 h h1.1).symm
end

theorem six8 {a b c p q : point} : sided b p a → sided b q c → B a b c → B p b q :=
begin
intros h h1 h2,
have h3 : B p b c,
  cases h.2.2,
    exact three6a h_1.symm h2,
  exact three7a h_1.symm h2 h.2.1,
cases h1.2.2,
  exact three5a h3 h_1,
exact three7b h3 h_1 h1.2.1.symm
end

def ray (p a : point) : set point := {x | sided p a x}

def hline (k : set point) : Prop := ∃ p a, a ≠ p ∧ k = ray p a

theorem six11 {a b c r : point} : r ≠ a → b ≠ c → ∃! x, sided a x r ∧ eqd a x b c :=
begin
intros h h1,
cases three14 r a with p hp,
cases seg_cons a b c p with x hx,
have h2 : x ≠ a,
  intro ha,
  rw ha at hx,
  have : b = c,
    exact id_eqd hx.2.symm,
  contradiction,
have h3 : sided a x r,
  split,
    exact h2,
  split,
    exact h,
  exact five2 hp.2.symm hx.1 hp.1.symm,
apply exists_unique.intro,
  exact ⟨h3, hx.2⟩,
intros y hy,
have : B p a y,
  exact ((six2 h2 hy.1.1 hp.2.symm hx.1.symm).2 (sided.trans h3 hy.1.symm)).symm,
exact two12 hp.2.symm this hy.2 hx.1 hx.2
end

theorem six11a {p a b : point} : sided p a b → eqd p a p b → a = b :=
λ h h1, unique_of_exists_unique (six11 h.1 h.1.symm) ⟨(six5 h.1), eqd.refl p a⟩ ⟨h.symm, h1.symm⟩

theorem six12 {a b p : point} : sided p a b → (distle p a p b ↔ B p a b) :=
begin
intro h1,
have hp : sided p a b, exact h1,
split,
  intro h,
  cases h1 with h1 h2,
  cases h2 with h2 h3,
  cases h3,
    exact h3,
  have : col p b a,
    left, exact h3,
  have : distle p b p a,
    exact ((five12 this).1 h3).1,
  have : eqd p a p b,
    exact five9 h this,
  cases three14 a p with q hq,
  have h4 : B q p b,
    exact ((six2 h1 h2 hq.2.symm hq.1).2 hp).symm,
  have : a = b,
    exact two12 hq.2.symm hq.1.symm (eqd.refl p a) h4 this.symm,
  rw this,
  exact three1 p b,
intro h,
unfold distle,
existsi a,
split,
  exact h,
exact eqd.refl p a
end

end Euclidean_plane


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

import data.mv_polynomial.counit
import data.mv_polynomial.invertible
import ring_theory.witt_vector.defs

/-!
# Witt vectors

This file verifies that the ring operations on `witt_vector p R`
satisfy the axioms of a commutative ring.

## Main definitions

* `witt_vector.map`: lifts a ring homomorphism `R →+* S` to a ring homomorphism `𝕎 R →+* 𝕎 S`.
* `witt_vector.ghost_component n x`: evaluates the `n`th Witt polynomial
  on the first `n` coefficients of `x`, producing a value in `R`.
  This is a ring homomorphism.
* `witt_vector.ghost_map`: a ring homomorphism `𝕎 R →+* (ℕ → R)`, obtained by packaging
  all the ghost components together.
  If `p` is invertible in `R`, then the ghost map is an equivalence,
  which we use to define the ring operations on `𝕎 R`.
* `witt_vector.comm_ring`: the ring structure induced by the ghost components.

## Notation

We use notation `𝕎 R`, entered `\bbW`, for the Witt vectors over `R`.

## Implementation details

As we prove that the ghost components respect the ring operations, we face a number of repetitive
proofs. To avoid duplicating code we factor these proofs into a custom tactic, only slightly more
powerful than a tactic macro. This tactic is not particularly useful outside of its applications
in this file.

## References

* [Hazewinkel, *Witt Vectors*][Haze09]

* [Commelin and Lewis, *Formalizing the Ring of Witt Vectors*][CL21]

-/

noncomputable theory

open mv_polynomial function

open_locale big_operators

variables {p : ℕ} {R S T : Type*} [hp : fact p.prime] [comm_ring R] [comm_ring S] [comm_ring T]
variables {α : Type*} {β : Type*}

local notation `𝕎` := witt_vector p -- type as `\bbW`
open_locale witt

namespace witt_vector

/-- `f : α → β` induces a map from `𝕎 α` to `𝕎 β` by applying `f` componentwise.
If `f` is a ring homomorphism, then so is `f`, see `witt_vector.map f`. -/
def map_fun (f : α → β) : 𝕎 α → 𝕎 β :=
λ x, mk _ (f ∘ x.coeff)

namespace map_fun

lemma injective (f : α → β) (hf : injective f) : injective (map_fun f : 𝕎 α → 𝕎 β) :=
λ x y h, ext $ λ n, hf (congr_arg (λ x, coeff x n) h : _)

lemma surjective (f : α → β) (hf : surjective f) : surjective (map_fun f : 𝕎 α → 𝕎 β) :=
λ x, ⟨mk _ (λ n, classical.some $ hf $ x.coeff n),
by { ext n, dsimp [map_fun], rw classical.some_spec (hf (x.coeff n)) }⟩

variables (f : R →+* S) (x y : 𝕎 R)

/-- Auxiliary tactic for showing that `map_fun` respects the ring operations. -/
meta def map_fun_tac : tactic unit :=
`[ext n,
  show f (aeval _ _) = aeval _ _,
  rw map_aeval,
  apply eval₂_hom_congr (ring_hom.ext_int _ _) _ rfl,
  ext ⟨i, k⟩,
  fin_cases i; refl]

include hp

/- We do not tag these lemmas as `@[simp]` because they will be bundled in `map` later on. -/

lemma zero : map_fun f (0 : 𝕎 R) = 0 := by map_fun_tac

lemma one : map_fun f (1 : 𝕎 R) = 1 := by map_fun_tac

lemma add : map_fun f (x + y) = map_fun f x + map_fun f y := by map_fun_tac

lemma sub : map_fun f (x - y) = map_fun f x - map_fun f y := by map_fun_tac

lemma mul : map_fun f (x * y) = map_fun f x * map_fun f y := by map_fun_tac

lemma neg : map_fun f (-x) = -map_fun f x := by map_fun_tac

lemma nsmul (n : ℕ) : map_fun f (n • x) = n • map_fun f x := by map_fun_tac

lemma zsmul (z : ℤ) : map_fun f (z • x) = z • map_fun f x := by map_fun_tac

lemma pow (n : ℕ) : map_fun f (x^ n) = map_fun f x ^ n := by map_fun_tac

lemma nat_cast (n : ℕ) : map_fun f (n : 𝕎 R) = n :=
show map_fun f n.unary_cast = coe n,
by induction n; simp [*, nat.unary_cast, add, one, zero]; refl

lemma int_cast (n : ℤ) : map_fun f (n : 𝕎 R) = n :=
show map_fun f n.cast_def = coe n,
by cases n; simp [*, int.cast_def, add, one, neg, zero, nat_cast]; refl

end map_fun

end witt_vector

section tactic
setup_tactic_parser
open tactic

/-- An auxiliary tactic for proving that `ghost_fun` respects the ring operations. -/
meta def tactic.interactive.ghost_fun_tac (φ fn : parse parser.pexpr) : tactic unit := do
fn ← to_expr ```(%%fn : fin _ → ℕ → R),
`(fin %%k → _ → _) ← infer_type fn,
`[ext n],
`[dunfold
  witt_vector.has_zero witt_zero
  witt_vector.has_one witt_one
  witt_vector.has_neg witt_neg
  witt_vector.has_mul witt_mul
  witt_vector.has_sub witt_sub
  witt_vector.has_add witt_add
  witt_vector.has_nat_scalar witt_nsmul
  witt_vector.has_int_scalar witt_zsmul
  witt_vector.has_nat_pow witt_pow
  ],
to_expr ```(congr_fun (congr_arg (@peval R _ %%k) (witt_structure_int_prop p %%φ n)) %%fn) >>=
  note `this none,
`[simpa [ghost_fun, aeval_rename, aeval_bind₁, (∘), uncurry, peval, eval] using this]

end tactic

namespace witt_vector

/-- Evaluates the `n`th Witt polynomial on the first `n` coefficients of `x`,
producing a value in `R`.
This function will be bundled as the ring homomorphism `witt_vector.ghost_map`
once the ring structure is available,
but we rely on it to set up the ring structure in the first place. -/
private def ghost_fun : 𝕎 R → (ℕ → R) := λ x n, aeval x.coeff (W_ ℤ n)

section ghost_fun
include hp

/- The following lemmas are not `@[simp]` because they will be bundled in `ghost_map` later on. -/

variables (x y : 𝕎 R)

omit hp
local attribute [simp]
lemma matrix_vec_empty_coeff {R} (i j) :
  @coeff p R (matrix.vec_empty i) j = (matrix.vec_empty i : ℕ → R) j :=
by rcases i with ⟨_ | _ | _ | _ | i_val, ⟨⟩⟩
include hp

private lemma ghost_fun_zero : ghost_fun (0 : 𝕎 R) = 0 := by ghost_fun_tac 0 ![]

private lemma ghost_fun_one : ghost_fun (1 : 𝕎 R) = 1 := by ghost_fun_tac 1 ![]

private lemma ghost_fun_add : ghost_fun (x + y) = ghost_fun x + ghost_fun y :=
by ghost_fun_tac (X 0 + X 1) ![x.coeff, y.coeff]

private lemma ghost_fun_nat_cast (i : ℕ) : ghost_fun (i : 𝕎 R) = i :=
show ghost_fun i.unary_cast = _,
by induction i; simp [*, nat.unary_cast, ghost_fun_zero, ghost_fun_one, ghost_fun_add, -pi.coe_nat]

private lemma ghost_fun_sub : ghost_fun (x - y) = ghost_fun x - ghost_fun y :=
by ghost_fun_tac (X 0 - X 1) ![x.coeff, y.coeff]

private lemma ghost_fun_mul : ghost_fun (x * y) = ghost_fun x * ghost_fun y :=
by ghost_fun_tac (X 0 * X 1) ![x.coeff, y.coeff]

private lemma ghost_fun_neg : ghost_fun (-x) = - ghost_fun x :=
by ghost_fun_tac (-X 0) ![x.coeff]

private lemma ghost_fun_int_cast (i : ℤ) : ghost_fun (i : 𝕎 R) = i :=
show ghost_fun i.cast_def = _,
by cases i; simp [*, int.cast_def, ghost_fun_nat_cast, ghost_fun_neg, -pi.coe_nat, -pi.coe_int]

private lemma ghost_fun_nsmul (m : ℕ) : ghost_fun (m • x) = m • ghost_fun x :=
by ghost_fun_tac (m • X 0) ![x.coeff]

private lemma ghost_fun_zsmul (m : ℤ) : ghost_fun (m • x) = m • ghost_fun x :=
by ghost_fun_tac (m • X 0) ![x.coeff]

private lemma ghost_fun_pow (m : ℕ) : ghost_fun (x ^ m) = ghost_fun x ^ m :=
by ghost_fun_tac (X 0 ^ m) ![x.coeff]

end ghost_fun

variables (p) (R)

/-- The bijection between `𝕎 R` and `ℕ → R`, under the assumption that `p` is invertible in `R`.
In `witt_vector.ghost_equiv` we upgrade this to an isomorphism of rings. -/
private def ghost_equiv' [invertible (p : R)] : 𝕎 R ≃ (ℕ → R) :=
{ to_fun := ghost_fun,
  inv_fun := λ x, mk p $ λ n, aeval x (X_in_terms_of_W p R n),
  left_inv :=
  begin
    intro x,
    ext n,
    have := bind₁_witt_polynomial_X_in_terms_of_W p R n,
    apply_fun (aeval x.coeff) at this,
    simpa only [aeval_bind₁, aeval_X, ghost_fun, aeval_witt_polynomial]
  end,
  right_inv :=
  begin
    intro x,
    ext n,
    have := bind₁_X_in_terms_of_W_witt_polynomial p R n,
    apply_fun (aeval x) at this,
    simpa only [aeval_bind₁, aeval_X, ghost_fun, aeval_witt_polynomial]
  end }

include hp

local attribute [instance]
private def comm_ring_aux₁ : comm_ring (𝕎 (mv_polynomial R ℚ)) :=
by letI : comm_ring (mv_polynomial R ℚ) := mv_polynomial.comm_ring; exact
(ghost_equiv' p (mv_polynomial R ℚ)).injective.comm_ring (ghost_fun)
  ghost_fun_zero ghost_fun_one ghost_fun_add ghost_fun_mul ghost_fun_neg ghost_fun_sub
  ghost_fun_nsmul ghost_fun_zsmul ghost_fun_pow ghost_fun_nat_cast ghost_fun_int_cast

local attribute [instance]
private def comm_ring_aux₂ : comm_ring (𝕎 (mv_polynomial R ℤ)) :=
(map_fun.injective _ $ map_injective (int.cast_ring_hom ℚ) int.cast_injective).comm_ring _
  (map_fun.zero _) (map_fun.one _) (map_fun.add _) (map_fun.mul _) (map_fun.neg _) (map_fun.sub _)
  (map_fun.nsmul _) (map_fun.zsmul _) (map_fun.pow _) (map_fun.nat_cast _) (map_fun.int_cast _)

attribute [reducible] comm_ring_aux₂

/-- The commutative ring structure on `𝕎 R`. -/
instance : comm_ring (𝕎 R) :=
(map_fun.surjective _ $ counit_surjective _).comm_ring (map_fun $ mv_polynomial.counit _)
  (map_fun.zero _) (map_fun.one _) (map_fun.add _) (map_fun.mul _) (map_fun.neg _) (map_fun.sub _)
  (map_fun.nsmul _) (map_fun.zsmul _) (map_fun.pow _) (map_fun.nat_cast _) (map_fun.int_cast _)

variables {p R}

/-- `witt_vector.map f` is the ring homomorphism `𝕎 R →+* 𝕎 S` naturally induced
by a ring homomorphism `f : R →+* S`. It acts coefficientwise. -/
noncomputable! def map (f : R →+* S) : 𝕎 R →+* 𝕎 S :=
{ to_fun := map_fun f,
  map_zero' := map_fun.zero f,
  map_one' := map_fun.one f,
  map_add' := map_fun.add f,
  map_mul' := map_fun.mul f }

lemma map_injective (f : R →+* S) (hf : injective f) : injective (map f : 𝕎 R → 𝕎 S) :=
map_fun.injective f hf

lemma map_surjective (f : R →+* S) (hf : surjective f) : surjective (map f : 𝕎 R → 𝕎 S) :=
map_fun.surjective f hf

@[simp] lemma map_coeff (f : R →+* S) (x : 𝕎 R) (n : ℕ) :
  (map f x).coeff n = f (x.coeff n) := rfl

/-- `witt_vector.ghost_map` is a ring homomorphism that maps each Witt vector
to the sequence of its ghost components. -/
def ghost_map : 𝕎 R →+* ℕ → R :=
{ to_fun := ghost_fun,
  map_zero' := ghost_fun_zero,
  map_one' := ghost_fun_one,
  map_add' := ghost_fun_add,
  map_mul' := ghost_fun_mul }

/-- Evaluates the `n`th Witt polynomial on the first `n` coefficients of `x`,
producing a value in `R`. -/
def ghost_component (n : ℕ) : 𝕎 R →+* R := (pi.eval_ring_hom _ n).comp ghost_map

@[simp] lemma ghost_map_apply (x : 𝕎 R) (n : ℕ) : ghost_map x n = ghost_component n x := rfl

section invertible

variables (p R) [invertible (p : R)]

/-- `witt_vector.ghost_map` is a ring isomorphism when `p` is invertible in `R`. -/
def ghost_equiv : 𝕎 R ≃+* (ℕ → R) :=
{ .. (ghost_map : 𝕎 R →+* (ℕ → R)), .. (ghost_equiv' p R) }

@[simp] lemma ghost_equiv_coe : (ghost_equiv p R : 𝕎 R →+* (ℕ → R)) = ghost_map := rfl

lemma ghost_map.bijective_of_invertible : function.bijective (ghost_map : 𝕎 R → ℕ → R) :=
(ghost_equiv p R).bijective

end invertible

/-- `witt_vector.coeff x 0` as a `ring_hom` -/
@[simps]
noncomputable! def constant_coeff : 𝕎 R →+* R :=
{ to_fun := λ x, x.coeff 0,
  map_zero' := by simp,
  map_one' := by simp,
  map_add' := add_coeff_zero,
  map_mul' := mul_coeff_zero }

instance [nontrivial R] : nontrivial (𝕎 R) :=
constant_coeff.domain_nontrivial

end witt_vector