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

! This file was ported from Lean 3 source module algebraic_geometry.projective_spectrum.topology
! leanprover-community/mathlib commit d39590fc8728fbf6743249802486f8c91ffe07bc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.GradedAlgebra.HomogeneousIdeal
import Mathbin.Topology.Category.Top.Basic
import Mathbin.Topology.Sets.Opens

/-!
# Projective spectrum of a graded ring

The projective spectrum of a graded commutative ring is the subtype of all homogenous ideals that
are prime and do not contain the irrelevant ideal.
It is naturally endowed with a topology: the Zariski topology.

## Notation
- `R` is a commutative semiring;
- `A` is a commutative ring and an `R`-algebra;
- `𝒜 : ℕ → submodule R A` is the grading of `A`;

## Main definitions

* `projective_spectrum 𝒜`: The projective spectrum of a graded ring `A`, or equivalently, the set of
  all homogeneous ideals of `A` that is both prime and relevant i.e. not containing irrelevant
  ideal. Henceforth, we call elements of projective spectrum *relevant homogeneous prime ideals*.
* `projective_spectrum.zero_locus 𝒜 s`: The zero locus of a subset `s` of `A`
  is the subset of `projective_spectrum 𝒜` consisting of all relevant homogeneous prime ideals that
  contain `s`.
* `projective_spectrum.vanishing_ideal t`: The vanishing ideal of a subset `t` of
  `projective_spectrum 𝒜` is the intersection of points in `t` (viewed as relevant homogeneous prime
  ideals).
* `projective_spectrum.Top`: the topological space of `projective_spectrum 𝒜` endowed with the
  Zariski topology.
-/

noncomputable section

open DirectSum BigOperators Pointwise

open DirectSum SetLike TopCat TopologicalSpace CategoryTheory Opposite

variable {R A : Type _}

variable [CommSemiring R] [CommRing A] [Algebra R A]

variable (𝒜 : ℕ → Submodule R A) [GradedAlgebra 𝒜]

/-- The projective spectrum of a graded commutative ring is the subtype of all homogenous ideals
that are prime and do not contain the irrelevant ideal. -/
@[ext, nolint has_nonempty_instance]
structure ProjectiveSpectrum where
  asHomogeneousIdeal : HomogeneousIdeal 𝒜
  IsPrime : as_homogeneous_ideal.toIdeal.IsPrime
  not_irrelevant_le : ¬HomogeneousIdeal.irrelevant 𝒜 ≤ as_homogeneous_ideal
#align projective_spectrum ProjectiveSpectrum

attribute [instance] ProjectiveSpectrum.isPrime

namespace ProjectiveSpectrum

/-- The zero locus of a set `s` of elements of a commutative ring `A` is the set of all relevant
homogeneous prime ideals of the ring that contain the set `s`.

An element `f` of `A` can be thought of as a dependent function on the projective spectrum of `𝒜`.
At a point `x` (a homogeneous prime ideal) the function (i.e., element) `f` takes values in the
quotient ring `A` modulo the prime ideal `x`. In this manner, `zero_locus s` is exactly the subset
of `projective_spectrum 𝒜` where all "functions" in `s` vanish simultaneously. -/
def zeroLocus (s : Set A) : Set (ProjectiveSpectrum 𝒜) :=
  { x | s ⊆ x.asHomogeneousIdeal }
#align projective_spectrum.zero_locus ProjectiveSpectrum.zeroLocus

@[simp]
theorem mem_zeroLocus (x : ProjectiveSpectrum 𝒜) (s : Set A) :
    x ∈ zeroLocus 𝒜 s ↔ s ⊆ x.asHomogeneousIdeal :=
  Iff.rfl
#align projective_spectrum.mem_zero_locus ProjectiveSpectrum.mem_zeroLocus

@[simp]
theorem zeroLocus_span (s : Set A) : zeroLocus 𝒜 (Ideal.span s) = zeroLocus 𝒜 s :=
  by
  ext x
  exact (Submodule.gi _ _).gc s x.as_homogeneous_ideal.to_ideal
#align projective_spectrum.zero_locus_span ProjectiveSpectrum.zeroLocus_span

variable {𝒜}

/-- The vanishing ideal of a set `t` of points of the projective spectrum of a commutative ring `R`
is the intersection of all the relevant homogeneous prime ideals in the set `t`.

An element `f` of `A` can be thought of as a dependent function on the projective spectrum of `𝒜`.
At a point `x` (a homogeneous prime ideal) the function (i.e., element) `f` takes values in the
quotient ring `A` modulo the prime ideal `x`. In this manner, `vanishing_ideal t` is exactly the
ideal of `A` consisting of all "functions" that vanish on all of `t`. -/
def vanishingIdeal (t : Set (ProjectiveSpectrum 𝒜)) : HomogeneousIdeal 𝒜 :=
  ⨅ (x : ProjectiveSpectrum 𝒜) (h : x ∈ t), x.asHomogeneousIdeal
#align projective_spectrum.vanishing_ideal ProjectiveSpectrum.vanishingIdeal

theorem coe_vanishingIdeal (t : Set (ProjectiveSpectrum 𝒜)) :
    (vanishingIdeal t : Set A) =
      { f | ∀ x : ProjectiveSpectrum 𝒜, x ∈ t → f ∈ x.asHomogeneousIdeal } :=
  by
  ext f
  rw [vanishing_ideal, SetLike.mem_coe, ← HomogeneousIdeal.mem_iff, HomogeneousIdeal.toIdeal_infᵢ,
    Submodule.mem_infᵢ]
  apply forall_congr' fun x => _
  rw [HomogeneousIdeal.toIdeal_infᵢ, Submodule.mem_infᵢ, HomogeneousIdeal.mem_iff]
#align projective_spectrum.coe_vanishing_ideal ProjectiveSpectrum.coe_vanishingIdeal

theorem mem_vanishingIdeal (t : Set (ProjectiveSpectrum 𝒜)) (f : A) :
    f ∈ vanishingIdeal t ↔ ∀ x : ProjectiveSpectrum 𝒜, x ∈ t → f ∈ x.asHomogeneousIdeal := by
  rw [← SetLike.mem_coe, coe_vanishing_ideal, Set.mem_setOf_eq]
#align projective_spectrum.mem_vanishing_ideal ProjectiveSpectrum.mem_vanishingIdeal

@[simp]
theorem vanishingIdeal_singleton (x : ProjectiveSpectrum 𝒜) :
    vanishingIdeal ({x} : Set (ProjectiveSpectrum 𝒜)) = x.asHomogeneousIdeal := by
  simp [vanishing_ideal]
#align projective_spectrum.vanishing_ideal_singleton ProjectiveSpectrum.vanishingIdeal_singleton

theorem subset_zeroLocus_iff_le_vanishingIdeal (t : Set (ProjectiveSpectrum 𝒜)) (I : Ideal A) :
    t ⊆ zeroLocus 𝒜 I ↔ I ≤ (vanishingIdeal t).toIdeal :=
  ⟨fun h f k => (mem_vanishingIdeal _ _).mpr fun x j => (mem_zeroLocus _ _ _).mpr (h j) k, fun h =>
    fun x j =>
    (mem_zeroLocus _ _ _).mpr (le_trans h fun f h => ((mem_vanishingIdeal _ _).mp h) x j)⟩
#align projective_spectrum.subset_zero_locus_iff_le_vanishing_ideal ProjectiveSpectrum.subset_zeroLocus_iff_le_vanishingIdeal

variable (𝒜)

/-- `zero_locus` and `vanishing_ideal` form a galois connection. -/
theorem gc_ideal :
    @GaloisConnection (Ideal A) (Set (ProjectiveSpectrum 𝒜))ᵒᵈ _ _ (fun I => zeroLocus 𝒜 I) fun t =>
      (vanishingIdeal t).toIdeal :=
  fun I t => subset_zeroLocus_iff_le_vanishingIdeal t I
#align projective_spectrum.gc_ideal ProjectiveSpectrum.gc_ideal

/-- `zero_locus` and `vanishing_ideal` form a galois connection. -/
theorem gc_set :
    @GaloisConnection (Set A) (Set (ProjectiveSpectrum 𝒜))ᵒᵈ _ _ (fun s => zeroLocus 𝒜 s) fun t =>
      vanishingIdeal t :=
  by
  have ideal_gc : GaloisConnection Ideal.span coe := (Submodule.gi A _).gc
  simpa [zero_locus_span, Function.comp] using GaloisConnection.compose ideal_gc (gc_ideal 𝒜)
#align projective_spectrum.gc_set ProjectiveSpectrum.gc_set

theorem gc_homogeneousIdeal :
    @GaloisConnection (HomogeneousIdeal 𝒜) (Set (ProjectiveSpectrum 𝒜))ᵒᵈ _ _
      (fun I => zeroLocus 𝒜 I) fun t => vanishingIdeal t :=
  fun I t => by
  simpa [show I.to_ideal ≤ (vanishing_ideal t).toIdeal ↔ I ≤ vanishing_ideal t from Iff.rfl] using
    subset_zero_locus_iff_le_vanishing_ideal t I.to_ideal
#align projective_spectrum.gc_homogeneous_ideal ProjectiveSpectrum.gc_homogeneousIdeal

theorem subset_zeroLocus_iff_subset_vanishingIdeal (t : Set (ProjectiveSpectrum 𝒜)) (s : Set A) :
    t ⊆ zeroLocus 𝒜 s ↔ s ⊆ vanishingIdeal t :=
  (gc_set _) s t
#align projective_spectrum.subset_zero_locus_iff_subset_vanishing_ideal ProjectiveSpectrum.subset_zeroLocus_iff_subset_vanishingIdeal

theorem subset_vanishingIdeal_zeroLocus (s : Set A) : s ⊆ vanishingIdeal (zeroLocus 𝒜 s) :=
  (gc_set _).le_u_l s
#align projective_spectrum.subset_vanishing_ideal_zero_locus ProjectiveSpectrum.subset_vanishingIdeal_zeroLocus

theorem ideal_le_vanishingIdeal_zeroLocus (I : Ideal A) :
    I ≤ (vanishingIdeal (zeroLocus 𝒜 I)).toIdeal :=
  (gc_ideal _).le_u_l I
#align projective_spectrum.ideal_le_vanishing_ideal_zero_locus ProjectiveSpectrum.ideal_le_vanishingIdeal_zeroLocus

theorem homogeneousIdeal_le_vanishingIdeal_zeroLocus (I : HomogeneousIdeal 𝒜) :
    I ≤ vanishingIdeal (zeroLocus 𝒜 I) :=
  (gc_homogeneousIdeal _).le_u_l I
#align projective_spectrum.homogeneous_ideal_le_vanishing_ideal_zero_locus ProjectiveSpectrum.homogeneousIdeal_le_vanishingIdeal_zeroLocus

theorem subset_zeroLocus_vanishingIdeal (t : Set (ProjectiveSpectrum 𝒜)) :
    t ⊆ zeroLocus 𝒜 (vanishingIdeal t) :=
  (gc_ideal _).l_u_le t
#align projective_spectrum.subset_zero_locus_vanishing_ideal ProjectiveSpectrum.subset_zeroLocus_vanishingIdeal

theorem zeroLocus_anti_mono {s t : Set A} (h : s ⊆ t) : zeroLocus 𝒜 t ⊆ zeroLocus 𝒜 s :=
  (gc_set _).monotone_l h
#align projective_spectrum.zero_locus_anti_mono ProjectiveSpectrum.zeroLocus_anti_mono

theorem zeroLocus_anti_mono_ideal {s t : Ideal A} (h : s ≤ t) :
    zeroLocus 𝒜 (t : Set A) ⊆ zeroLocus 𝒜 (s : Set A) :=
  (gc_ideal _).monotone_l h
#align projective_spectrum.zero_locus_anti_mono_ideal ProjectiveSpectrum.zeroLocus_anti_mono_ideal

theorem zeroLocus_anti_mono_homogeneousIdeal {s t : HomogeneousIdeal 𝒜} (h : s ≤ t) :
    zeroLocus 𝒜 (t : Set A) ⊆ zeroLocus 𝒜 (s : Set A) :=
  (gc_homogeneousIdeal _).monotone_l h
#align projective_spectrum.zero_locus_anti_mono_homogeneous_ideal ProjectiveSpectrum.zeroLocus_anti_mono_homogeneousIdeal

theorem vanishingIdeal_anti_mono {s t : Set (ProjectiveSpectrum 𝒜)} (h : s ⊆ t) :
    vanishingIdeal t ≤ vanishingIdeal s :=
  (gc_ideal _).monotone_u h
#align projective_spectrum.vanishing_ideal_anti_mono ProjectiveSpectrum.vanishingIdeal_anti_mono

theorem zeroLocus_bot : zeroLocus 𝒜 ((⊥ : Ideal A) : Set A) = Set.univ :=
  (gc_ideal 𝒜).l_bot
#align projective_spectrum.zero_locus_bot ProjectiveSpectrum.zeroLocus_bot

@[simp]
theorem zeroLocus_singleton_zero : zeroLocus 𝒜 ({0} : Set A) = Set.univ :=
  zeroLocus_bot _
#align projective_spectrum.zero_locus_singleton_zero ProjectiveSpectrum.zeroLocus_singleton_zero

@[simp]
theorem zeroLocus_empty : zeroLocus 𝒜 (∅ : Set A) = Set.univ :=
  (gc_set 𝒜).l_bot
#align projective_spectrum.zero_locus_empty ProjectiveSpectrum.zeroLocus_empty

@[simp]
theorem vanishingIdeal_univ : vanishingIdeal (∅ : Set (ProjectiveSpectrum 𝒜)) = ⊤ := by
  simpa using (gc_ideal _).u_top
#align projective_spectrum.vanishing_ideal_univ ProjectiveSpectrum.vanishingIdeal_univ

theorem zeroLocus_empty_of_one_mem {s : Set A} (h : (1 : A) ∈ s) : zeroLocus 𝒜 s = ∅ :=
  Set.eq_empty_iff_forall_not_mem.mpr fun x hx =>
    (inferInstance : x.asHomogeneousIdeal.toIdeal.IsPrime).ne_top <|
      x.asHomogeneousIdeal.toIdeal.eq_top_iff_one.mpr <| hx h
#align projective_spectrum.zero_locus_empty_of_one_mem ProjectiveSpectrum.zeroLocus_empty_of_one_mem

@[simp]
theorem zeroLocus_singleton_one : zeroLocus 𝒜 ({1} : Set A) = ∅ :=
  zeroLocus_empty_of_one_mem 𝒜 (Set.mem_singleton (1 : A))
#align projective_spectrum.zero_locus_singleton_one ProjectiveSpectrum.zeroLocus_singleton_one

@[simp]
theorem zeroLocus_univ : zeroLocus 𝒜 (Set.univ : Set A) = ∅ :=
  zeroLocus_empty_of_one_mem _ (Set.mem_univ 1)
#align projective_spectrum.zero_locus_univ ProjectiveSpectrum.zeroLocus_univ

theorem zeroLocus_sup_ideal (I J : Ideal A) :
    zeroLocus 𝒜 ((I ⊔ J : Ideal A) : Set A) = zeroLocus _ I ∩ zeroLocus _ J :=
  (gc_ideal 𝒜).l_sup
#align projective_spectrum.zero_locus_sup_ideal ProjectiveSpectrum.zeroLocus_sup_ideal

theorem zeroLocus_sup_homogeneousIdeal (I J : HomogeneousIdeal 𝒜) :
    zeroLocus 𝒜 ((I ⊔ J : HomogeneousIdeal 𝒜) : Set A) = zeroLocus _ I ∩ zeroLocus _ J :=
  (gc_homogeneousIdeal 𝒜).l_sup
#align projective_spectrum.zero_locus_sup_homogeneous_ideal ProjectiveSpectrum.zeroLocus_sup_homogeneousIdeal

theorem zeroLocus_union (s s' : Set A) : zeroLocus 𝒜 (s ∪ s') = zeroLocus _ s ∩ zeroLocus _ s' :=
  (gc_set 𝒜).l_sup
#align projective_spectrum.zero_locus_union ProjectiveSpectrum.zeroLocus_union

theorem vanishingIdeal_union (t t' : Set (ProjectiveSpectrum 𝒜)) :
    vanishingIdeal (t ∪ t') = vanishingIdeal t ⊓ vanishingIdeal t' := by
  ext1 <;> convert(gc_ideal 𝒜).u_inf
#align projective_spectrum.vanishing_ideal_union ProjectiveSpectrum.vanishingIdeal_union

theorem zeroLocus_supᵢ_ideal {γ : Sort _} (I : γ → Ideal A) :
    zeroLocus _ ((⨆ i, I i : Ideal A) : Set A) = ⋂ i, zeroLocus 𝒜 (I i) :=
  (gc_ideal 𝒜).l_supᵢ
#align projective_spectrum.zero_locus_supr_ideal ProjectiveSpectrum.zeroLocus_supᵢ_ideal

theorem zeroLocus_supᵢ_homogeneousIdeal {γ : Sort _} (I : γ → HomogeneousIdeal 𝒜) :
    zeroLocus _ ((⨆ i, I i : HomogeneousIdeal 𝒜) : Set A) = ⋂ i, zeroLocus 𝒜 (I i) :=
  (gc_homogeneousIdeal 𝒜).l_supᵢ
#align projective_spectrum.zero_locus_supr_homogeneous_ideal ProjectiveSpectrum.zeroLocus_supᵢ_homogeneousIdeal

theorem zeroLocus_unionᵢ {γ : Sort _} (s : γ → Set A) :
    zeroLocus 𝒜 (⋃ i, s i) = ⋂ i, zeroLocus 𝒜 (s i) :=
  (gc_set 𝒜).l_supᵢ
#align projective_spectrum.zero_locus_Union ProjectiveSpectrum.zeroLocus_unionᵢ

theorem zeroLocus_bUnion (s : Set (Set A)) :
    zeroLocus 𝒜 (⋃ s' ∈ s, s' : Set A) = ⋂ s' ∈ s, zeroLocus 𝒜 s' := by simp only [zero_locus_Union]
#align projective_spectrum.zero_locus_bUnion ProjectiveSpectrum.zeroLocus_bUnion

theorem vanishingIdeal_unionᵢ {γ : Sort _} (t : γ → Set (ProjectiveSpectrum 𝒜)) :
    vanishingIdeal (⋃ i, t i) = ⨅ i, vanishingIdeal (t i) :=
  HomogeneousIdeal.toIdeal_injective <| by
    convert(gc_ideal 𝒜).u_infᵢ <;> exact HomogeneousIdeal.toIdeal_infᵢ _
#align projective_spectrum.vanishing_ideal_Union ProjectiveSpectrum.vanishingIdeal_unionᵢ

theorem zeroLocus_inf (I J : Ideal A) :
    zeroLocus 𝒜 ((I ⊓ J : Ideal A) : Set A) = zeroLocus 𝒜 I ∪ zeroLocus 𝒜 J :=
  Set.ext fun x => x.IsPrime.inf_le
#align projective_spectrum.zero_locus_inf ProjectiveSpectrum.zeroLocus_inf

theorem union_zeroLocus (s s' : Set A) :
    zeroLocus 𝒜 s ∪ zeroLocus 𝒜 s' = zeroLocus 𝒜 (Ideal.span s ⊓ Ideal.span s' : Ideal A) :=
  by
  rw [zero_locus_inf]
  simp
#align projective_spectrum.union_zero_locus ProjectiveSpectrum.union_zeroLocus

theorem zeroLocus_mul_ideal (I J : Ideal A) :
    zeroLocus 𝒜 ((I * J : Ideal A) : Set A) = zeroLocus 𝒜 I ∪ zeroLocus 𝒜 J :=
  Set.ext fun x => x.IsPrime.mul_le
#align projective_spectrum.zero_locus_mul_ideal ProjectiveSpectrum.zeroLocus_mul_ideal

theorem zeroLocus_mul_homogeneousIdeal (I J : HomogeneousIdeal 𝒜) :
    zeroLocus 𝒜 ((I * J : HomogeneousIdeal 𝒜) : Set A) = zeroLocus 𝒜 I ∪ zeroLocus 𝒜 J :=
  Set.ext fun x => x.IsPrime.mul_le
#align projective_spectrum.zero_locus_mul_homogeneous_ideal ProjectiveSpectrum.zeroLocus_mul_homogeneousIdeal

theorem zeroLocus_singleton_mul (f g : A) :
    zeroLocus 𝒜 ({f * g} : Set A) = zeroLocus 𝒜 {f} ∪ zeroLocus 𝒜 {g} :=
  Set.ext fun x => by simpa using x.is_prime.mul_mem_iff_mem_or_mem
#align projective_spectrum.zero_locus_singleton_mul ProjectiveSpectrum.zeroLocus_singleton_mul

@[simp]
theorem zeroLocus_singleton_pow (f : A) (n : ℕ) (hn : 0 < n) :
    zeroLocus 𝒜 ({f ^ n} : Set A) = zeroLocus 𝒜 {f} :=
  Set.ext fun x => by simpa using x.is_prime.pow_mem_iff_mem n hn
#align projective_spectrum.zero_locus_singleton_pow ProjectiveSpectrum.zeroLocus_singleton_pow

theorem sup_vanishingIdeal_le (t t' : Set (ProjectiveSpectrum 𝒜)) :
    vanishingIdeal t ⊔ vanishingIdeal t' ≤ vanishingIdeal (t ∩ t') :=
  by
  intro r
  rw [← HomogeneousIdeal.mem_iff, HomogeneousIdeal.toIdeal_sup, mem_vanishing_ideal,
    Submodule.mem_sup]
  rintro ⟨f, hf, g, hg, rfl⟩ x ⟨hxt, hxt'⟩
  erw [mem_vanishing_ideal] at hf hg
  apply Submodule.add_mem <;> solve_by_elim
#align projective_spectrum.sup_vanishing_ideal_le ProjectiveSpectrum.sup_vanishingIdeal_le

theorem mem_compl_zeroLocus_iff_not_mem {f : A} {I : ProjectiveSpectrum 𝒜} :
    I ∈ (zeroLocus 𝒜 {f} : Set (ProjectiveSpectrum 𝒜))ᶜ ↔ f ∉ I.asHomogeneousIdeal := by
  rw [Set.mem_compl_iff, mem_zero_locus, Set.singleton_subset_iff] <;> rfl
#align projective_spectrum.mem_compl_zero_locus_iff_not_mem ProjectiveSpectrum.mem_compl_zeroLocus_iff_not_mem

/-- The Zariski topology on the prime spectrum of a commutative ring is defined via the closed sets
of the topology: they are exactly those sets that are the zero locus of a subset of the ring. -/
instance zariskiTopology : TopologicalSpace (ProjectiveSpectrum 𝒜) :=
  TopologicalSpace.ofClosed (Set.range (ProjectiveSpectrum.zeroLocus 𝒜)) ⟨Set.univ, by simp⟩
    (by
      intro Zs h
      rw [Set.interₛ_eq_interᵢ]
      let f : Zs → Set _ := fun i => Classical.choose (h i.2)
      have hf : ∀ i : Zs, ↑i = zero_locus 𝒜 (f i) := fun i => (Classical.choose_spec (h i.2)).symm
      simp only [hf]
      exact ⟨_, zero_locus_Union 𝒜 _⟩)
    (by
      rintro _ ⟨s, rfl⟩ _ ⟨t, rfl⟩
      exact ⟨_, (union_zero_locus 𝒜 s t).symm⟩)
#align projective_spectrum.zariski_topology ProjectiveSpectrum.zariskiTopology

/-- The underlying topology of `Proj` is the projective spectrum of graded ring `A`. -/
def top : TopCat :=
  TopCat.of (ProjectiveSpectrum 𝒜)
#align projective_spectrum.Top ProjectiveSpectrum.top

theorem isOpen_iff (U : Set (ProjectiveSpectrum 𝒜)) : IsOpen U ↔ ∃ s, Uᶜ = zeroLocus 𝒜 s := by
  simp only [@eq_comm _ (Uᶜ)] <;> rfl
#align projective_spectrum.is_open_iff ProjectiveSpectrum.isOpen_iff

theorem isClosed_iff_zeroLocus (Z : Set (ProjectiveSpectrum 𝒜)) :
    IsClosed Z ↔ ∃ s, Z = zeroLocus 𝒜 s := by rw [← isOpen_compl_iff, is_open_iff, compl_compl]
#align projective_spectrum.is_closed_iff_zero_locus ProjectiveSpectrum.isClosed_iff_zeroLocus

theorem isClosed_zeroLocus (s : Set A) : IsClosed (zeroLocus 𝒜 s) :=
  by
  rw [is_closed_iff_zero_locus]
  exact ⟨s, rfl⟩
#align projective_spectrum.is_closed_zero_locus ProjectiveSpectrum.isClosed_zeroLocus

theorem zeroLocus_vanishingIdeal_eq_closure (t : Set (ProjectiveSpectrum 𝒜)) :
    zeroLocus 𝒜 (vanishingIdeal t : Set A) = closure t :=
  by
  apply Set.Subset.antisymm
  · rintro x hx t' ⟨ht', ht⟩
    obtain ⟨fs, rfl⟩ : ∃ s, t' = zero_locus 𝒜 s := by rwa [is_closed_iff_zero_locus] at ht'
    rw [subset_zero_locus_iff_subset_vanishing_ideal] at ht
    exact Set.Subset.trans ht hx
  · rw [(is_closed_zero_locus _ _).closure_subset_iff]
    exact subset_zero_locus_vanishing_ideal 𝒜 t
#align projective_spectrum.zero_locus_vanishing_ideal_eq_closure ProjectiveSpectrum.zeroLocus_vanishingIdeal_eq_closure

theorem vanishingIdeal_closure (t : Set (ProjectiveSpectrum 𝒜)) :
    vanishingIdeal (closure t) = vanishingIdeal t :=
  by
  have := (gc_ideal 𝒜).u_l_u_eq_u t
  dsimp only at this
  ext1
  erw [zero_locus_vanishing_ideal_eq_closure 𝒜 t] at this
  exact this
#align projective_spectrum.vanishing_ideal_closure ProjectiveSpectrum.vanishingIdeal_closure

section BasicOpen

/-- `basic_open r` is the open subset containing all prime ideals not containing `r`. -/
def basicOpen (r : A) : TopologicalSpace.Opens (ProjectiveSpectrum 𝒜)
    where
  carrier := { x | r ∉ x.asHomogeneousIdeal }
  is_open' := ⟨{r}, Set.ext fun x => Set.singleton_subset_iff.trans <| Classical.not_not.symm⟩
#align projective_spectrum.basic_open ProjectiveSpectrum.basicOpen

@[simp]
theorem mem_basicOpen (f : A) (x : ProjectiveSpectrum 𝒜) :
    x ∈ basicOpen 𝒜 f ↔ f ∉ x.asHomogeneousIdeal :=
  Iff.rfl
#align projective_spectrum.mem_basic_open ProjectiveSpectrum.mem_basicOpen

theorem mem_coe_basicOpen (f : A) (x : ProjectiveSpectrum 𝒜) :
    x ∈ (↑(basicOpen 𝒜 f) : Set (ProjectiveSpectrum 𝒜)) ↔ f ∉ x.asHomogeneousIdeal :=
  Iff.rfl
#align projective_spectrum.mem_coe_basic_open ProjectiveSpectrum.mem_coe_basicOpen

theorem isOpen_basicOpen {a : A} : IsOpen (basicOpen 𝒜 a : Set (ProjectiveSpectrum 𝒜)) :=
  (basicOpen 𝒜 a).IsOpen
#align projective_spectrum.is_open_basic_open ProjectiveSpectrum.isOpen_basicOpen

@[simp]
theorem basicOpen_eq_zeroLocus_compl (r : A) :
    (basicOpen 𝒜 r : Set (ProjectiveSpectrum 𝒜)) = zeroLocus 𝒜 {r}ᶜ :=
  Set.ext fun x => by simpa only [Set.mem_compl_iff, mem_zero_locus, Set.singleton_subset_iff]
#align projective_spectrum.basic_open_eq_zero_locus_compl ProjectiveSpectrum.basicOpen_eq_zeroLocus_compl

@[simp]
theorem basicOpen_one : basicOpen 𝒜 (1 : A) = ⊤ :=
  TopologicalSpace.Opens.ext <| by simp
#align projective_spectrum.basic_open_one ProjectiveSpectrum.basicOpen_one

@[simp]
theorem basicOpen_zero : basicOpen 𝒜 (0 : A) = ⊥ :=
  TopologicalSpace.Opens.ext <| by simp
#align projective_spectrum.basic_open_zero ProjectiveSpectrum.basicOpen_zero

theorem basicOpen_mul (f g : A) : basicOpen 𝒜 (f * g) = basicOpen 𝒜 f ⊓ basicOpen 𝒜 g :=
  TopologicalSpace.Opens.ext <| by simp [zero_locus_singleton_mul]
#align projective_spectrum.basic_open_mul ProjectiveSpectrum.basicOpen_mul

theorem basicOpen_mul_le_left (f g : A) : basicOpen 𝒜 (f * g) ≤ basicOpen 𝒜 f :=
  by
  rw [basic_open_mul 𝒜 f g]
  exact inf_le_left
#align projective_spectrum.basic_open_mul_le_left ProjectiveSpectrum.basicOpen_mul_le_left

theorem basicOpen_mul_le_right (f g : A) : basicOpen 𝒜 (f * g) ≤ basicOpen 𝒜 g :=
  by
  rw [basic_open_mul 𝒜 f g]
  exact inf_le_right
#align projective_spectrum.basic_open_mul_le_right ProjectiveSpectrum.basicOpen_mul_le_right

@[simp]
theorem basicOpen_pow (f : A) (n : ℕ) (hn : 0 < n) : basicOpen 𝒜 (f ^ n) = basicOpen 𝒜 f :=
  TopologicalSpace.Opens.ext <| by simpa using zero_locus_singleton_pow 𝒜 f n hn
#align projective_spectrum.basic_open_pow ProjectiveSpectrum.basicOpen_pow

theorem basicOpen_eq_union_of_projection (f : A) :
    basicOpen 𝒜 f = ⨆ i : ℕ, basicOpen 𝒜 (GradedAlgebra.proj 𝒜 i f) :=
  TopologicalSpace.Opens.ext <|
    Set.ext fun z => by
      erw [mem_coe_basic_open, TopologicalSpace.Opens.mem_supₛ]
      constructor <;> intro hz
      · rcases show ∃ i, GradedAlgebra.proj 𝒜 i f ∉ z.as_homogeneous_ideal
            by
            contrapose! hz with H
            classical
              rw [← DirectSum.sum_support_decompose 𝒜 f]
              apply Ideal.sum_mem _ fun i hi => H i with
          ⟨i, hi⟩
        exact ⟨basic_open 𝒜 (GradedAlgebra.proj 𝒜 i f), ⟨i, rfl⟩, by rwa [mem_basic_open]⟩
      · obtain ⟨_, ⟨i, rfl⟩, hz⟩ := hz
        exact fun rid => hz (z.1.2 i rid)
#align projective_spectrum.basic_open_eq_union_of_projection ProjectiveSpectrum.basicOpen_eq_union_of_projection

theorem isTopologicalBasis_basic_opens :
    TopologicalSpace.IsTopologicalBasis
      (Set.range fun r : A => (basicOpen 𝒜 r : Set (ProjectiveSpectrum 𝒜))) :=
  by
  apply TopologicalSpace.isTopologicalBasis_of_open_of_nhds
  · rintro _ ⟨r, rfl⟩
    exact is_open_basic_open 𝒜
  · rintro p U hp ⟨s, hs⟩
    rw [← compl_compl U, Set.mem_compl_iff, ← hs, mem_zero_locus, Set.not_subset] at hp
    obtain ⟨f, hfs, hfp⟩ := hp
    refine' ⟨basic_open 𝒜 f, ⟨f, rfl⟩, hfp, _⟩
    rw [← Set.compl_subset_compl, ← hs, basic_open_eq_zero_locus_compl, compl_compl]
    exact zero_locus_anti_mono 𝒜 (set.singleton_subset_iff.mpr hfs)
#align projective_spectrum.is_topological_basis_basic_opens ProjectiveSpectrum.isTopologicalBasis_basic_opens

end BasicOpen

section Order

/-!
## The specialization order

We endow `projective_spectrum 𝒜` with a partial order,
where `x ≤ y` if and only if `y ∈ closure {x}`.
-/

instance : PartialOrder (ProjectiveSpectrum 𝒜) :=
  PartialOrder.lift asHomogeneousIdeal fun ⟨_, _, _⟩ ⟨_, _, _⟩ => mk.inj_eq.mpr

@[simp]
theorem as_ideal_le_as_ideal (x y : ProjectiveSpectrum 𝒜) :
    x.asHomogeneousIdeal ≤ y.asHomogeneousIdeal ↔ x ≤ y :=
  Iff.rfl
#align projective_spectrum.as_ideal_le_as_ideal ProjectiveSpectrum.as_ideal_le_as_ideal

@[simp]
theorem as_ideal_lt_as_ideal (x y : ProjectiveSpectrum 𝒜) :
    x.asHomogeneousIdeal < y.asHomogeneousIdeal ↔ x < y :=
  Iff.rfl
#align projective_spectrum.as_ideal_lt_as_ideal ProjectiveSpectrum.as_ideal_lt_as_ideal

theorem le_iff_mem_closure (x y : ProjectiveSpectrum 𝒜) :
    x ≤ y ↔ y ∈ closure ({x} : Set (ProjectiveSpectrum 𝒜)) :=
  by
  rw [← as_ideal_le_as_ideal, ← zero_locus_vanishing_ideal_eq_closure, mem_zero_locus,
    vanishing_ideal_singleton]
  simp only [coe_subset_coe, Subtype.coe_le_coe, coe_coe]
#align projective_spectrum.le_iff_mem_closure ProjectiveSpectrum.le_iff_mem_closure

end Order

end ProjectiveSpectrum


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov, Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.conditionally_complete_lattice
import Mathlib.logic.function.iterate
import Mathlib.order.rel_iso
import Mathlib.PostPort

universes u v w x

namespace Mathlib

/-!
# Order continuity

We say that a function is *left order continuous* if it sends all least upper bounds
to least upper bounds. The order dual notion is called *right order continuity*.

For monotone functions `ℝ → ℝ` these notions correspond to the usual left and right continuity.

We prove some basic lemmas (`map_sup`, `map_Sup` etc) and prove that an `rel_iso` is both left
and right order continuous.
-/

/-!
### Definitions
-/

/-- A function `f` between preorders is left order continuous if it preserves all suprema.  We
define it using `is_lub` instead of `Sup` so that the proof works both for complete lattices and
conditionally complete lattices. -/
def left_ord_continuous {α : Type u} {β : Type v} [preorder α] [preorder β] (f : α → β) :=
  ∀ {s : set α} {x : α}, is_lub s x → is_lub (f '' s) (f x)

/-- A function `f` between preorders is right order continuous if it preserves all infima.  We
define it using `is_glb` instead of `Inf` so that the proof works both for complete lattices and
conditionally complete lattices. -/
def right_ord_continuous {α : Type u} {β : Type v} [preorder α] [preorder β] (f : α → β) :=
  ∀ {s : set α} {x : α}, is_glb s x → is_glb (f '' s) (f x)

namespace left_ord_continuous

protected theorem id (α : Type u) [preorder α] : left_ord_continuous id := sorry

protected theorem order_dual {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β}
    (hf : left_ord_continuous f) : right_ord_continuous f :=
  hf

theorem map_is_greatest {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β}
    (hf : left_ord_continuous f) {s : set α} {x : α} (h : is_greatest s x) :
    is_greatest (f '' s) (f x) :=
  { left := set.mem_image_of_mem f (and.left h), right := and.left (hf (is_greatest.is_lub h)) }

theorem mono {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β}
    (hf : left_ord_continuous f) : monotone f :=
  sorry

theorem comp {α : Type u} {β : Type v} {γ : Type w} [preorder α] [preorder β] [preorder γ]
    {g : β → γ} {f : α → β} (hg : left_ord_continuous g) (hf : left_ord_continuous f) :
    left_ord_continuous (g ∘ f) :=
  sorry

protected theorem iterate {α : Type u} [preorder α] {f : α → α} (hf : left_ord_continuous f)
    (n : ℕ) : left_ord_continuous (nat.iterate f n) :=
  nat.rec_on n (left_ord_continuous.id α)
    fun (n : ℕ) (ihn : left_ord_continuous (nat.iterate f n)) => comp ihn hf

theorem map_sup {α : Type u} {β : Type v} [semilattice_sup α] [semilattice_sup β] {f : α → β}
    (hf : left_ord_continuous f) (x : α) (y : α) : f (x ⊔ y) = f x ⊔ f y :=
  sorry

theorem le_iff {α : Type u} {β : Type v} [semilattice_sup α] [semilattice_sup β] {f : α → β}
    (hf : left_ord_continuous f) (h : function.injective f) {x : α} {y : α} : f x ≤ f y ↔ x ≤ y :=
  sorry

theorem lt_iff {α : Type u} {β : Type v} [semilattice_sup α] [semilattice_sup β] {f : α → β}
    (hf : left_ord_continuous f) (h : function.injective f) {x : α} {y : α} : f x < f y ↔ x < y :=
  sorry

/-- Convert an injective left order continuous function to an order embedding. -/
def to_order_embedding {α : Type u} {β : Type v} [semilattice_sup α] [semilattice_sup β] (f : α → β)
    (hf : left_ord_continuous f) (h : function.injective f) : α ↪o β :=
  rel_embedding.mk (function.embedding.mk f h) sorry

@[simp] theorem coe_to_order_embedding {α : Type u} {β : Type v} [semilattice_sup α]
    [semilattice_sup β] {f : α → β} (hf : left_ord_continuous f) (h : function.injective f) :
    ⇑(to_order_embedding f hf h) = f :=
  rfl

theorem map_Sup' {α : Type u} {β : Type v} [complete_lattice α] [complete_lattice β] {f : α → β}
    (hf : left_ord_continuous f) (s : set α) : f (Sup s) = Sup (f '' s) :=
  Eq.symm (is_lub.Sup_eq (hf (is_lub_Sup s)))

theorem map_Sup {α : Type u} {β : Type v} [complete_lattice α] [complete_lattice β] {f : α → β}
    (hf : left_ord_continuous f) (s : set α) :
    f (Sup s) = supr fun (x : α) => supr fun (H : x ∈ s) => f x :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (f (Sup s) = supr fun (x : α) => supr fun (H : x ∈ s) => f x))
        (map_Sup' hf s)))
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (Sup (f '' s) = supr fun (x : α) => supr fun (H : x ∈ s) => f x))
          Sup_image))
      (Eq.refl (supr fun (a : α) => supr fun (H : a ∈ s) => f a)))

theorem map_supr {α : Type u} {β : Type v} {ι : Sort x} [complete_lattice α] [complete_lattice β]
    {f : α → β} (hf : left_ord_continuous f) (g : ι → α) :
    f (supr fun (i : ι) => g i) = supr fun (i : ι) => f (g i) :=
  sorry

theorem map_cSup {α : Type u} {β : Type v} [conditionally_complete_lattice α]
    [conditionally_complete_lattice β] {f : α → β} (hf : left_ord_continuous f) {s : set α}
    (sne : set.nonempty s) (sbdd : bdd_above s) : f (Sup s) = Sup (f '' s) :=
  Eq.symm (is_lub.cSup_eq (hf (is_lub_cSup sne sbdd)) (set.nonempty.image f sne))

theorem map_csupr {α : Type u} {β : Type v} {ι : Sort x} [conditionally_complete_lattice α]
    [conditionally_complete_lattice β] [Nonempty ι] {f : α → β} (hf : left_ord_continuous f)
    {g : ι → α} (hg : bdd_above (set.range g)) :
    f (supr fun (i : ι) => g i) = supr fun (i : ι) => f (g i) :=
  sorry

end left_ord_continuous

namespace right_ord_continuous

protected theorem id (α : Type u) [preorder α] : right_ord_continuous id := sorry

protected theorem order_dual {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β}
    (hf : right_ord_continuous f) : left_ord_continuous f :=
  hf

theorem map_is_least {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β}
    (hf : right_ord_continuous f) {s : set α} {x : α} (h : is_least s x) :
    is_least (f '' s) (f x) :=
  left_ord_continuous.map_is_greatest (right_ord_continuous.order_dual hf) h

theorem mono {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β}
    (hf : right_ord_continuous f) : monotone f :=
  monotone.order_dual (left_ord_continuous.mono (right_ord_continuous.order_dual hf))

theorem comp {α : Type u} {β : Type v} {γ : Type w} [preorder α] [preorder β] [preorder γ]
    {g : β → γ} {f : α → β} (hg : right_ord_continuous g) (hf : right_ord_continuous f) :
    right_ord_continuous (g ∘ f) :=
  left_ord_continuous.comp (right_ord_continuous.order_dual hg) (right_ord_continuous.order_dual hf)

protected theorem iterate {α : Type u} [preorder α] {f : α → α} (hf : right_ord_continuous f)
    (n : ℕ) : right_ord_continuous (nat.iterate f n) :=
  left_ord_continuous.iterate (right_ord_continuous.order_dual hf) n

theorem map_inf {α : Type u} {β : Type v} [semilattice_inf α] [semilattice_inf β] {f : α → β}
    (hf : right_ord_continuous f) (x : α) (y : α) : f (x ⊓ y) = f x ⊓ f y :=
  left_ord_continuous.map_sup (right_ord_continuous.order_dual hf) x y

theorem le_iff {α : Type u} {β : Type v} [semilattice_inf α] [semilattice_inf β] {f : α → β}
    (hf : right_ord_continuous f) (h : function.injective f) {x : α} {y : α} : f x ≤ f y ↔ x ≤ y :=
  left_ord_continuous.le_iff (right_ord_continuous.order_dual hf) h

theorem lt_iff {α : Type u} {β : Type v} [semilattice_inf α] [semilattice_inf β] {f : α → β}
    (hf : right_ord_continuous f) (h : function.injective f) {x : α} {y : α} : f x < f y ↔ x < y :=
  left_ord_continuous.lt_iff (right_ord_continuous.order_dual hf) h

/-- Convert an injective left order continuous function to a `order_embedding`. -/
def to_order_embedding {α : Type u} {β : Type v} [semilattice_inf α] [semilattice_inf β] (f : α → β)
    (hf : right_ord_continuous f) (h : function.injective f) : α ↪o β :=
  rel_embedding.mk (function.embedding.mk f h) sorry

@[simp] theorem coe_to_order_embedding {α : Type u} {β : Type v} [semilattice_inf α]
    [semilattice_inf β] {f : α → β} (hf : right_ord_continuous f) (h : function.injective f) :
    ⇑(to_order_embedding f hf h) = f :=
  rfl

theorem map_Inf' {α : Type u} {β : Type v} [complete_lattice α] [complete_lattice β] {f : α → β}
    (hf : right_ord_continuous f) (s : set α) : f (Inf s) = Inf (f '' s) :=
  left_ord_continuous.map_Sup' (right_ord_continuous.order_dual hf) s

theorem map_Inf {α : Type u} {β : Type v} [complete_lattice α] [complete_lattice β] {f : α → β}
    (hf : right_ord_continuous f) (s : set α) :
    f (Inf s) = infi fun (x : α) => infi fun (H : x ∈ s) => f x :=
  left_ord_continuous.map_Sup (right_ord_continuous.order_dual hf) s

theorem map_infi {α : Type u} {β : Type v} {ι : Sort x} [complete_lattice α] [complete_lattice β]
    {f : α → β} (hf : right_ord_continuous f) (g : ι → α) :
    f (infi fun (i : ι) => g i) = infi fun (i : ι) => f (g i) :=
  left_ord_continuous.map_supr (right_ord_continuous.order_dual hf) g

theorem map_cInf {α : Type u} {β : Type v} [conditionally_complete_lattice α]
    [conditionally_complete_lattice β] {f : α → β} (hf : right_ord_continuous f) {s : set α}
    (sne : set.nonempty s) (sbdd : bdd_below s) : f (Inf s) = Inf (f '' s) :=
  left_ord_continuous.map_cSup (right_ord_continuous.order_dual hf) sne sbdd

theorem map_cinfi {α : Type u} {β : Type v} {ι : Sort x} [conditionally_complete_lattice α]
    [conditionally_complete_lattice β] [Nonempty ι] {f : α → β} (hf : right_ord_continuous f)
    {g : ι → α} (hg : bdd_below (set.range g)) :
    f (infi fun (i : ι) => g i) = infi fun (i : ι) => f (g i) :=
  left_ord_continuous.map_csupr (right_ord_continuous.order_dual hf) hg

end right_ord_continuous

namespace order_iso

protected theorem left_ord_continuous {α : Type u} {β : Type v} [preorder α] [preorder β]
    (e : α ≃o β) : left_ord_continuous ⇑e :=
  sorry

protected theorem right_ord_continuous {α : Type u} {β : Type v} [preorder α] [preorder β]
    (e : α ≃o β) : right_ord_continuous ⇑e :=
  order_iso.left_ord_continuous (order_iso.dual e)

end Mathlib


inductive Sign where
  | zero | neg | pos
  deriving DecidableEq

instance : OfNat Sign (nat_lit 0) where
  ofNat := .zero

instance : OfNat Sign (nat_lit 1) where
  ofNat := .pos

instance : Neg Sign where
  neg | .zero => .zero
      | .pos  => .neg
      | .neg  => .pos

namespace Sign

@[simp] theorem zero_eq : zero = 0 := rfl
@[simp] theorem neg_eq : neg  = -1 := rfl
@[simp] theorem pos_eq : pos = 1 := rfl

def mul : Sign → Sign → Sign
  | neg,  neg  => pos
  | neg,  pos  => neg
  | neg,  zero => zero
  | zero, _    => zero
  | pos,  s    => s

instance : Mul Sign where
  mul a b := Sign.mul a b

def le : Sign → Sign → Bool
  | neg,  _    => true
  | zero, zero => true
  | _,    pos  => true
  | _,    _    => false

instance : LE Sign where
  le a b := Sign.le a b

instance : DecidableRel (· ≤ · : Sign → Sign → Prop) :=
  fun a b => inferInstanceAs (Decidable (le a b = true))

theorem neg_bot {s : Sign} : s ≤ -1 → s = -1 := by
  cases s <;> decide

theorem pos_top {s : Sign} : 1 ≤ s → s = 1 := by
  cases s <;> decide

end Sign


import tactic

#check dvd_mul_right

-- BEGIN

example {m n k : ℕ} (h : m ∣ n ∨ m ∣ k) : m ∣ n * k :=
begin
  cases h with hmn hmk,
    /- deconstruct the disjunction m ∣ n ∨ m ∣ k -/
  cases hmn with a ha,
    /- instantiate the existential quantifier a in ha -/
    rw ha,
    rw mul_assoc,
    apply dvd_mul_right,
  cases hmk with b hb,
    /- instantiate the existential quantifier b in hb -/
    rw hb,
    rw mul_comm,
    rw mul_assoc,
  apply dvd_mul_right,
end

-- END


import data.matrix data.rat.basic linear_algebra.basis data.fintype
import linear_algebra.determinant .misc order.pilex order.lexicographic .list_sup
import data.list.min_max .fin_find

open matrix fintype finset

variables {m n : ℕ}
variables (A : matrix (fin m) (fin n) ℚ)

local notation `rvec`:2000 n := matrix (fin 1) (fin n) ℚ
local notation `cvec`:2000 m := matrix (fin m) (fin 1) ℚ

-- def column (j : fin n) : cvec m := λ i _, A i j

-- def row (i : fin m) : rvec n := λ _ j, A i j

variables (b : cvec m) (c : cvec n)

def cvec.ordered_comm_group : ordered_comm_group (cvec n) :=
matrix.ordered_comm_group

local attribute [instance] cvec.ordered_comm_group

def cvec.decidable_le : decidable_rel ((≤) : (cvec n) → (cvec n) → Prop) :=
matrix.decidable_le

local attribute [instance] cvec.decidable_le

--instance : partial_order (matrix (fin m) (fin n) ℚ) := pi.partial_order

constant matrix.has_inv : has_inv (matrix (fin n) (fin n) ℚ)

local notation M `⬝` N := M.mul N
local postfix `ᵀ` : 1500 := transpose

def is_feasible (x : cvec n) : Prop :=
0 ≤ x ∧ A ⬝ x = b

instance (x : cvec n) : decidable (is_feasible A b x) :=
by dunfold is_feasible; apply_instance

def is_optimal (x : cvec n) : Prop :=
is_feasible A b x ∧ ∀ y, is_feasible A b y → cᵀ ⬝ y ≤ cᵀ ⬝ x

def is_invertible' (M : matrix (fin m) (fin n) ℚ) : Prop :=
∃ h : m = n, by rw h at M; exact det M ≠ 0

instance is_invertible'.decidable : decidable_pred (@is_invertible' m n) :=
λ _, by unfold is_invertible'; apply_instance

def comatrix (M : matrix (fin n) (fin n) ℚ) : matrix (fin n) (fin n) ℚ :=
begin
  cases n,
  { exact fin.elim0 },
  { exact λ i j, (-1) ^ (i + j : ℕ) * det (minor M
    (λ i' : fin n, if i'.1 < i.1 then i'.cast_le sorry
      else i'.succ)
    (λ j' : fin n, if j'.1 < j.1 then j'.cast_le sorry
      else j'.succ)) }
end

def inverse (M : matrix (fin m) (fin n) ℚ) : matrix (fin n) (fin m) ℚ :=
if h : m = n then by subst h; exact (det M)⁻¹ • (comatrix M)ᵀ else 0

def rvec.to_list {n : ℕ} (x : rvec n) : list ℚ :=
(vector.of_fn (x 0)).1

def lex_rvec : linear_order (rvec m) :=
@pilex.linear_order _ _ _ (is_well_order.wf _)
  (λ _, pilex.linear_order (is_well_order.wf _))

def lex_rvec_decidable_linear_order : decidable_linear_order (rvec m) :=
{ decidable_le := λ x y, decidable_of_iff
    (list.lex (<) (rvec.to_list x) (rvec.to_list y) ∨ x = y) sorry,
  ..lex_rvec }

local attribute [instance] lex_rvec_decidable_linear_order

def lex_ordered_comm_group_rvec : ordered_comm_group (rvec m) :=
@pilex.ordered_comm_group _ _ _ (λ _, pilex.ordered_comm_group)

-- local attribute [instance] lex_ordered_comm_group_rvec
--   lex_rvec_decidable_linear_order

def pert_rat (m : ℕ) : Type := ℚ × rvec m

instance : decidable_eq (pert_rat m) := by unfold pert_rat; apply_instance

instance : add_comm_group (pert_rat m) := prod.add_comm_group

instance : module ℚ (pert_rat m) := prod.module

instance : decidable_linear_order (pert_rat m) :=
by letI := @lex_rvec_decidable_linear_order m; exact
{ decidable_le := @prod.lex.decidable _ _ _ _ _ _ _
    (lex_rvec_decidable_linear_order).decidable_le,
  ..lex_linear_order }

instance pert_rat.decidable_le (i j : pert_rat m) : decidable (i ≤ j) :=
@decidable_linear_order.decidable_le _ pert_rat.decidable_linear_order i j

instance has_repr_fin_fun {n : ℕ} {α : Type*} [has_repr α] : has_repr (fin n → α) :=
⟨λ f, repr (vector.of_fn f).to_list⟩

instance {m n} : has_repr (matrix (fin m) (fin n) ℚ) := has_repr_fin_fun

instance : has_repr (pert_rat m) := prod.has_repr

def pivot (A : matrix (fin m) (fin n) ℚ) (c : rvec n) (b : cvec m)
  (B : array m (fin n))
  (NB : array (n - m) (fin n))
  (i : fin (n - m)) (j : fin m) :
  array m (fin n) × -- basis
  array (n - m) (fin n) × -- non basis
  matrix (fin m) (fin (n - m)) ℚ × -- A_bar
  (rvec m) × -- c_B
  (rvec (n - m)) × --c_N
  (cvec m) × --b_bar
  matrix (fin m) (fin m) ℚ -- pert
  :=
let NBi : fin n := NB.read i in
let Bj : fin n := B.read j in
let NB' := NB.write i Bj in
let B' := B.write j NBi in
let A_B'_inverse := inverse (minor A id B'.read) in
⟨B',
  NB',
  A_B'_inverse ⬝ minor A id NB'.read,
  minor c id B'.read,
  minor c id NB'.read,
  A_B'_inverse ⬝ b,
  A_B'_inverse⟩

lemma true_well_founded {α : Type*} :
  well_founded (λ (_ _ : α), true) := sorry

def simplex [inhabited (fin m)] (A : matrix (fin m) (fin n) ℚ)
  (c : rvec n) (b : cvec m) :
  Π (B : array m (fin n))
  (NB : array (n - m) (fin n))
  (A_bar : matrix (fin m) (fin (n - m)) ℚ)
  (c_B : rvec m) (c_N : rvec (n - m)) (b_bar : cvec m)
  (pert : (matrix (fin m) (fin m) ℚ))
  (pivots : ℕ),
  ℕ × option
  (array m (fin n) × -- basis
  array (n - m) (fin n) × -- non basis
  matrix (fin m) (fin (n - m)) ℚ × -- A_bar
  (rvec m) × -- c_B
  (rvec (n - m)) × --c_N
  (cvec m) × --b_bar
  matrix (fin m) (fin m) ℚ) -- pert)
| B NB A_bar c_B c_N b_bar pert pivots :=
let reduced_cost := c_N - c_B ⬝ A_bar in
let i' := (list.fin_range (n - m)).find (λ i, 0 < column reduced_cost (fin 1) i) in
match i' with
| none := (pivots, some (B, NB, A_bar, c_B, c_N, b_bar, pert))
| some i :=
  let ratio_pert : fin m → pert_rat m := λ j : fin m,
    (A_bar j i)⁻¹ • (b_bar j 0, row' pert (fin 1) j) in
  let l := (list.fin_range m).filter (λ j, 0 < ratio_pert j) in
  match l with
  | [] := (pivots + 1, none)
  | (a::l) :=
  let j : fin m := list.argmin ratio_pert (a :: l) in
  let ⟨B', NB', A_bar', c_B', c_N', b_bar', pert'⟩ :=
    pivot A c b B NB i j in
  have wf : true, from trivial,
  simplex B' NB' A_bar' c_B' c_N' b_bar' pert' (pivots + 1)
  end
end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, true_well_founded⟩],
  dec_tac := tactic.assumption}

instance read_dec_pred (a : array m (fin n)) (i : fin n) :
  decidable_pred (λ (k : fin m), array.read a k = i) := by apply_instance

instance array.mem_decidable {α : Type*} [decidable_eq α] (x : array m α) :
  decidable_pred (λ a : α, @array.mem m α a x) :=
by dunfold array.mem; apply_instance

def find_optimal_solution_from_starting_basis [inhabited (fin m)] (A : matrix (fin m) (fin n) ℚ)
  (c : rvec n) (b : cvec m) (B : array m (fin n)) : ℕ × option (cvec n) :=
let NB : array (n - m) (fin n) :=
  vector.to_array ⟨(list.fin_range n).filter (λ i, ¬ B.mem i), sorry⟩ in
let A_B := minor A id B.read in
let A_N := minor A id NB.read in
let pert := inverse A_B in
let A_bar := pert ⬝ A_N in
let c_B := minor c id B.read in
let c_N := minor c id NB.read in
let b_bar := pert ⬝ b in
match simplex A c b B NB A_bar c_B c_N b_bar pert 0 with
| (pivots, none) := (pivots, none)
| (pivots, some ⟨B', NB', A_bar', c_B', c_N', b_bar', pert'⟩) := prod.mk pivots $
some (λ i _,
  match @fin.find _ (λ k, B'.read k = i) (read_dec_pred _ _) with
  | none := 0
  | some k := b_bar' k 0
  end)
end

/- test code -/

instance {m : ℕ} : inhabited (fin m.succ) := ⟨0⟩

def list.to_matrix (m :ℕ) (n : ℕ) (l : list (list ℚ)) : matrix (fin m) (fin n) ℚ :=
λ i j, (l.nth_le i sorry).nth_le j sorry

def found_solution_is_feasible [inhabited (fin m)] (A : matrix (fin m) (fin n) ℚ)
  (c : rvec n) (b : cvec m) (B : array m (fin n)) : bool :=
match find_optimal_solution_from_starting_basis A c b B with
| (_, none) := tt
| (_, some x) := (A ⬝ x = b ∧ 0 ≤ x : bool)
end

def is_optimal_bool [inhabited (fin m)] (A : matrix (fin m) (fin n) ℚ)
  (c : rvec n) (b : cvec m) (B : array m (fin n)) : bool :=
let NB : array (n - m) (fin n) :=
  vector.to_array ⟨(list.fin_range n).filter (λ i, ¬ B.mem i), sorry⟩ in
let A_B := minor A id B.read in
let A_N := minor A id NB.read in
let pert := inverse A_B in
let A_bar := pert ⬝ A_N in
let c_B := minor c id B.read in
let c_N := minor c id NB.read in
let b_bar := pert ⬝ b in
match simplex A c b B NB A_N c_B c_N b_bar pert 0 with
| (_, none) := tt
| (_, some ⟨B', NB', A_bar', c_B', c_N', b_bar', pert'⟩) := c_N' - c_B' ⬝ A_bar' ≤ 0
end

def is_feasible_basis [inhabited (fin m)] (A : matrix (fin m) (fin n) ℚ)
  (c : rvec n) (b : cvec m) (B : array m (fin n)) : Prop :=
let A_B := minor A id B.read in
let NB : array (n - m) (fin n) :=
  vector.to_array ⟨(list.fin_range n).filter (λ i, ¬ B.mem i), sorry⟩ in
let A_N := minor A id NB.read in
let pert := inverse A_B in
let A_bar := pert ⬝ A_N in
let c_B := minor c id B.read in
let c_N := minor c id NB.read in
let b_bar := pert ⬝ b in
let x : cvec n := λ i _, match @fin.find _ (λ k, B.read k = i) (read_dec_pred _ _) with
  | none := 0
  | some k := b_bar k 0
  end in
(0 : cvec n) ≤ x ∧ A ⬝ x = b ∧ det A_B ≠ 0

def finishing_basis [inhabited (fin m)] (A : matrix (fin m) (fin n) ℚ)
  (c : rvec n) (b : cvec m) (B : array m (fin n)) : option (array m (fin n)) :=
let NB : array (n - m) (fin n) :=
  vector.to_array ⟨(list.fin_range n).filter (λ i, ¬ B.mem i), sorry⟩ in
let A_B := minor A id B.read in
let A_N := minor A id NB.read in
let pert := inverse A_B in
let A_bar := pert ⬝ A_N in
let c_B := minor c id B.read in
let c_N := minor c id NB.read in
let b_bar := pert ⬝ b in
option.map prod.fst (simplex A c b B NB A_N c_B c_N b_bar pert 0).2

def test  [inhabited (fin m)] (A : matrix (fin m) (fin n) ℚ)
  (c : rvec n) (b : cvec m) (B : array m (fin n)) :=
let NB : array (n - m) (fin n) :=
  vector.to_array ⟨(list.fin_range n).filter (λ i, ¬ B.mem i), sorry⟩ in
let A_B := minor A id B.read in
let A_N := minor A id NB.read in
let pert := inverse A_B in
let A_bar := pert ⬝ A_N in
let c_B := minor c id B.read in
let c_N := minor c id NB.read in
let b_bar := pert ⬝ b in
let reduced_cost := c_N - c_B ⬝ A_bar in
let b_pert : fin m → pert_rat m := λ j : fin m,
     (A_bar j ⟨0, sorry⟩)⁻¹ • (b_bar j 0, row' pert (fin 1) j) in
let reduced_cost := c_N - c_B ⬝ A_bar in
let i' := (list.fin_range (n - m)).find (λ i, 0 < column reduced_cost (fin 1) i) in
match i' with
| none := sorry
| some i :=
  let ratio_pert : fin m → pert_rat m := λ j : fin m,
     (A_bar j i)⁻¹ • (b_bar j 0, row' pert (fin 1) j) in
  let l := (list.fin_range m).filter (λ j, 0 < ratio_pert j) in ratio_pert end
--simplex A c b B NB A_N c_B c_N b_bar pert

def objective_function_value (c : rvec n) (x : cvec n) := c ⬝ x

-- (list.fin_range (n - m)).find (λ i, 0 < column reduced_cost (fin 1) i)

-- pivot A c b B NB

instance [inhabited (fin m)] (A : matrix (fin m) (fin n) ℚ)
  (c : rvec n) (b : cvec m) (B : array m (fin n)) :
  decidable (is_feasible_basis A c b B) :=
by dunfold is_feasible_basis; apply_instance

def X'  : pert_rat 2 := (0, X)
--#eval X
#eval X'
#eval  (0 = X' : bool)

-- def ex.A := list.to_matrix 3 4 [[12,-1,1,1],
--                      [1,1.45,1,0],
--                      [1,2,0,1]]

-- def ex.c : rvec 4 := λ _ i, (list.nth_le [1, 1.2, 1, 1.3] i sorry)
-- --#eval ex.c
-- def ex.b : cvec 3 := (λ i _, (list.nth_le [2, 2, 4] i sorry))
-- --#eval ex.b
-- def ex.B : array 3 (fin 4) := list.to_array [0, 1, 3]

-- def ex.NB : array 1 (fin 4) := list.to_array [2]

-- def ex.A := list.to_matrix 2 5 [[1,1,0,1,0], [0,1,-1,0,1]]

-- def ex.b : cvec 2 := (λ i _, (list.nth_le [8,0] i sorry))
-- --#eval ex.b
-- def ex.c : rvec 5 := λ _ i, (list.nth_le [1, 1, 1, 0, 0] i sorry)
-- --#eval ex.c
-- def ex.B : array 2 (fin 5) := list.to_array [3,4]

def ex.A := list.to_matrix 3 7 [[1/4, - 8, -  1, 9, 1, 0, 0],
                                [1/2, -12, -1/2, 3, 0, 1, 0],
                                [  0,   0,    1, 0, 0, 0, 1]]

def ex.b : cvec 3 := (λ i _, list.nth_le [0,0,1] i sorry)
--#eval ex.b
def ex.c : rvec 7 := λ _ i, (list.nth_le [3/4, -20, 1/2, -6, 0, 0, 0] i sorry)
--#eval ex.c
def ex.B : array 3 (fin 7) := list.to_array [4,5,6]

-- #eval (found_solution_is_feasible ex.A ex.c ex.b ex.B)

#eval (find_optimal_solution_from_starting_basis ex.A ex.c ex.b ex.B)
--set_option trace.fun_info true
#eval (is_optimal_bool ex.A ex.c ex.b ex.B)

-- (some [[2064/445]])
-- (some [[6401/1895]])
#eval (is_feasible_basis ex.A ex.c ex.b ex.B : bool)
-- #eval (show matrix _ _ ℚ, from minor ex.A id ex.B.read) *
--   inverse (show matrix _ _ ℚ, from minor ex.A id ex.B.read )
-- #eval ((1 : matrix (fin 1) (fin 1) ℚ) - (minor ex.c id ex.B.read) ⬝
--   inverse (minor ex.A id ex.B.read) ⬝
--   (minor ex.A id ex.NB.read))

#eval finishing_basis ex.A ex.c ex.b ex.B

#eval test ex.A ex.c ex.b ex.B

#eval (let x : cvec 4 := λ i _, list.nth_le [0, 80/89, 62/89, 196/89] i sorry in
  let A := list.to_matrix 3 4 [[12, -1, 1, 1],
                     [1, 1.45, 1, 0],
                     [1, 2, 0, 1]]
                     in A ⬝ x
 )


open function

variables {X: Type*} {Y : Type*} {Z : Type*} {f : X → Y} {g : Y → X} {g' : X → Z} {h : Z → Y}

theorem Q1007i (hp: surjective f) : ∃ g, f ∘ g = id := sorry

theorem Q1007ii (hp: injective f) : ∃g, (g ∘ f = id) → ff := sorry

theorem Q1007iii (hp: injective g') (hq: surjective h) :∃ g', f = h ∘ g' := sorry


theorem contrapositive (P Q : Prop) (HPQ : P → Q) : ¬ Q → ¬ P :=
begin
  sorry
end

theorem contrapositive_iff (P Q : Prop) : (P → Q) ↔ (¬ Q → ¬ P) :=
begin
  split,
    exact contrapositive P Q,
  intro HnQnP,
  intro HP,
end


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

import data.nat.modeq
import data.zsqrtd.basic

/-!
# Pell's equation and Matiyasevic's theorem

This file solves Pell's equation, i.e. integer solutions to `x ^ 2 - d * y ^ 2 = 1` in the special
case that `d = a ^ 2 - 1`. This is then applied to prove Matiyasevic's theorem that the power
function is Diophantine, which is the last key ingredient in the solution to Hilbert's tenth
problem. For the definition of Diophantine function, see `dioph.lean`.

## Main definition

* `pell` is a function assigning to a natural number `n` the `n`-th solution to Pell's equation
  constructed recursively from the intial solution `(0,1)`.

## Main statements

* `eq_pell` shows that every solution to Pell's equation is recursively obtained using `pell`
* `matiyasevic` shows that a certain system of Diophantine equations has a solution if and only if
  the first variable is the `x`-component in a solution to Pell's equation - the key step towards
  Hilbert's tenth problem in Davis' version of Matiyasevic's theorem.
* `eq_pow_of_pell` shows that the power function is Diophantine.

## Implementation notes

The proof of Matiyasevic's theorem doesn't follow Matiyasevic's original account of using Fibonacci
numbers but instead Davis' variant of using solutions to Pell's equation.

## References

* [M. Carneiro, _A Lean formalization of Matiyasiv's theorem_][carneiro2018matiysevic]
* [M. Davis, _Hilbert's tenth problem is unsolvable_][MR317916]

## Tags

Pell's equation, Matiyasevic's theorem, Hilbert's tenth problem

## TODO

* Please the unused arguments linter.
* Provide solutions to Pell's equation for the case of arbitrary `d` (not just `d = a ^ 2 - 1` like
  in the current version) and furthermore also for `x ^ 2 - d * y ^ 2 = -1`.
* Connect solutions to the continued fraction expansion of `√d`.
-/

namespace pell
open nat

section
  parameters {a : ℕ} (a1 : 1 < a)

  include a1
  private def d := a*a - 1

  @[simp] theorem d_pos : 0 < d :=
  nat.sub_pos_of_lt (mul_lt_mul a1 (le_of_lt a1) dec_trivial dec_trivial : 1*1<a*a)

  /-- The Pell sequences, i.e. the sequence of integer solutions to `x ^ 2 - d * y ^ 2 = 1`, where
  `d = a ^ 2 - 1`, defined together in mutual recursion. -/
  -- TODO(lint): Fix double namespace issue
  @[nolint dup_namespace] def pell : ℕ → ℕ × ℕ :=
  λn, nat.rec_on n (1, 0) (λn xy, (xy.1*a + d*xy.2, xy.1 + xy.2*a))

  /-- The Pell `x` sequence. -/
  def xn (n : ℕ) : ℕ := (pell n).1
  /-- The Pell `y` sequence. -/
  def yn (n : ℕ) : ℕ := (pell n).2

  @[simp] theorem pell_val (n : ℕ) : pell n = (xn n, yn n) :=
  show pell n = ((pell n).1, (pell n).2), from match pell n with (a, b) := rfl end

  @[simp] theorem xn_zero : xn 0 = 1 := rfl
  @[simp] theorem yn_zero : yn 0 = 0 := rfl

  @[simp] theorem xn_succ (n : ℕ) : xn (n+1) = xn n * a + d * yn n := rfl
  @[simp] theorem yn_succ (n : ℕ) : yn (n+1) = xn n + yn n * a := rfl

  @[simp] theorem xn_one : xn 1 = a := by simp
  @[simp] theorem yn_one : yn 1 = 1 := by simp

  /-- The Pell `x` sequence, considered as an integer sequence.-/
  def xz (n : ℕ) : ℤ := xn n
  /-- The Pell `y` sequence, considered as an integer sequence.-/
  def yz (n : ℕ) : ℤ := yn n
  /-- The element `a` such that `d = a ^ 2 - 1`, considered as an integer.-/
  def az : ℤ := a

  theorem asq_pos : 0 < a*a :=
  le_trans (le_of_lt a1) (by have := @nat.mul_le_mul_left 1 a a (le_of_lt a1); rwa mul_one at this)

  theorem dz_val : ↑d = az*az - 1 :=
  have 1 ≤ a*a, from asq_pos,
  show ↑(a*a - 1) = _, by rw int.coe_nat_sub this; refl

  @[simp] theorem xz_succ (n : ℕ) : xz (n+1) = xz n * az + ↑d * yz n := rfl
  @[simp] theorem yz_succ (n : ℕ) : yz (n+1) = xz n + yz n * az := rfl

  /-- The Pell sequence can also be viewed as an element of `ℤ√d` -/
  def pell_zd (n : ℕ) : ℤ√d := ⟨xn n, yn n⟩
  @[simp] theorem pell_zd_re (n : ℕ) : (pell_zd n).re = xn n := rfl
  @[simp] theorem pell_zd_im (n : ℕ) : (pell_zd n).im = yn n := rfl

  /-- The property of being a solution to the Pell equation, expressed
    as a property of elements of `ℤ√d`. -/
  def is_pell : ℤ√d → Prop | ⟨x, y⟩ := x*x - d*y*y = 1

  theorem is_pell_nat {x y : ℕ} : is_pell ⟨x, y⟩ ↔ x*x - d*y*y = 1 :=
  ⟨λh, int.coe_nat_inj
    (by rw int.coe_nat_sub (int.le_of_coe_nat_le_coe_nat $ int.le.intro_sub h); exact h),
  λh, show ((x*x : ℕ) - (d*y*y:ℕ) : ℤ) = 1,
    by rw [← int.coe_nat_sub $ le_of_lt $ nat.lt_of_sub_eq_succ h, h]; refl⟩

  theorem is_pell_norm : Π {b : ℤ√d}, is_pell b ↔ b * b.conj = 1
  | ⟨x, y⟩ := by simp [zsqrtd.ext, is_pell, mul_comm]; ring_nf

  theorem is_pell_mul {b c : ℤ√d} (hb : is_pell b) (hc : is_pell c) : is_pell (b * c) :=
  is_pell_norm.2 (by simp [mul_comm, mul_left_comm,
    zsqrtd.conj_mul, pell.is_pell_norm.1 hb, pell.is_pell_norm.1 hc])

  theorem is_pell_conj : ∀ {b : ℤ√d}, is_pell b ↔ is_pell b.conj | ⟨x, y⟩ :=
  by simp [is_pell, zsqrtd.conj]

  @[simp] theorem pell_zd_succ (n : ℕ) : pell_zd (n+1) = pell_zd n * ⟨a, 1⟩ :=
  by simp [zsqrtd.ext]

  theorem is_pell_one : is_pell ⟨a, 1⟩ :=
  show az*az-d*1*1=1, by simp [dz_val]; ring

  theorem is_pell_pell_zd : ∀ (n : ℕ), is_pell (pell_zd n)
  | 0     := rfl
  | (n+1) := let o := is_pell_one in by simp; exact pell.is_pell_mul (is_pell_pell_zd n) o

  @[simp] theorem pell_eqz (n : ℕ) : xz n * xz n - d * yz n * yz n = 1 := is_pell_pell_zd n

  @[simp] theorem pell_eq (n : ℕ) : xn n * xn n - d * yn n * yn n = 1 :=
  let pn := pell_eqz n in
  have h : (↑(xn n * xn n) : ℤ) - ↑(d * yn n * yn n) = 1,
    by repeat {rw int.coe_nat_mul}; exact pn,
  have hl : d * yn n * yn n ≤ xn n * xn n, from
    int.le_of_coe_nat_le_coe_nat $ int.le.intro $ add_eq_of_eq_sub' $ eq.symm h,
  int.coe_nat_inj (by rw int.coe_nat_sub hl; exact h)

  instance dnsq : zsqrtd.nonsquare d := ⟨λn h,
    have n*n + 1 = a*a, by rw ← h; exact nat.succ_pred_eq_of_pos (asq_pos a1),
    have na : n < a, from nat.mul_self_lt_mul_self_iff.2 (by rw ← this; exact nat.lt_succ_self _),
    have (n+1)*(n+1) ≤ n*n + 1, by rw this; exact nat.mul_self_le_mul_self na,
    have n+n ≤ 0, from @nat.le_of_add_le_add_right (n*n + 1) _ _ (by ring_nf at this ⊢; assumption),
    ne_of_gt d_pos $ by rwa nat.eq_zero_of_le_zero ((nat.le_add_left _ _).trans this) at h⟩

  theorem xn_ge_a_pow : ∀ (n : ℕ), a^n ≤ xn n
  | 0     := le_refl 1
  | (n+1) := by simp [pow_succ']; exact le_trans
    (nat.mul_le_mul_right _ (xn_ge_a_pow n)) (nat.le_add_right _ _)

  theorem n_lt_a_pow : ∀ (n : ℕ), n < a^n
  | 0     := nat.le_refl 1
  | (n+1) := begin have IH := n_lt_a_pow n,
    have : a^n + a^n ≤ a^n * a,
    { rw ← mul_two, exact nat.mul_le_mul_left _ a1 },
    simp [pow_succ'], refine lt_of_lt_of_le _ this,
    exact add_lt_add_of_lt_of_le IH (lt_of_le_of_lt (nat.zero_le _) IH)
  end

  theorem n_lt_xn (n) : n < xn n :=
  lt_of_lt_of_le (n_lt_a_pow n) (xn_ge_a_pow n)

  theorem x_pos (n) : 0 < xn n :=
  lt_of_le_of_lt (nat.zero_le n) (n_lt_xn n)

  lemma eq_pell_lem : ∀n (b:ℤ√d), 1 ≤ b → is_pell b → b ≤ pell_zd n → ∃n, b = pell_zd n
  | 0     b := λh1 hp hl, ⟨0, @zsqrtd.le_antisymm _ dnsq _ _ hl h1⟩
  | (n+1) b := λh1 hp h,
    have a1p : (0:ℤ√d) ≤ ⟨a, 1⟩, from trivial,
    have am1p : (0:ℤ√d) ≤ ⟨a, -1⟩, from show (_:nat) ≤ _, by simp; exact nat.pred_le _,
    have a1m : (⟨a, 1⟩ * ⟨a, -1⟩ : ℤ√d) = 1, from is_pell_norm.1 is_pell_one,
    if ha : (⟨↑a, 1⟩ : ℤ√d) ≤ b then
      let ⟨m, e⟩ := eq_pell_lem n (b * ⟨a, -1⟩)
        (by rw ← a1m; exact mul_le_mul_of_nonneg_right ha am1p)
        (is_pell_mul hp (is_pell_conj.1 is_pell_one))
        (by have t := mul_le_mul_of_nonneg_right h am1p;
          rwa [pell_zd_succ, mul_assoc, a1m, mul_one] at t) in
      ⟨m+1, by rw [show b = b * ⟨a, -1⟩ * ⟨a, 1⟩, by rw [mul_assoc, eq.trans (mul_comm _ _) a1m];
        simp, pell_zd_succ, e]⟩
    else
      suffices ¬1 < b, from ⟨0, show b = 1, from (or.resolve_left (lt_or_eq_of_le h1) this).symm⟩,
      λ h1l, by cases b with x y; exact
      have bm : (_*⟨_,_⟩ :ℤ√(d a1)) = 1, from pell.is_pell_norm.1 hp,
      have y0l : (0:ℤ√(d a1)) < ⟨x - x, y - -y⟩,
        from sub_lt_sub h1l $ λ(hn : (1:ℤ√(d a1)) ≤ ⟨x, -y⟩),
          by have t := mul_le_mul_of_nonneg_left hn (le_trans zero_le_one h1);
            rw [bm, mul_one] at t; exact h1l t,
      have yl2 : (⟨_, _⟩ : ℤ√_) < ⟨_, _⟩, from
        show (⟨x, y⟩ - ⟨x, -y⟩ : ℤ√(d a1)) < ⟨a, 1⟩ - ⟨a, -1⟩, from
        sub_lt_sub (by exact ha) $ λ(hn : (⟨x, -y⟩ : ℤ√(d a1)) ≤ ⟨a, -1⟩),
        by have t := mul_le_mul_of_nonneg_right
          (mul_le_mul_of_nonneg_left hn (le_trans zero_le_one h1)) a1p;
            rw [bm, one_mul, mul_assoc, eq.trans (mul_comm _ _) a1m, mul_one] at t; exact ha t,
      by simp at y0l; simp at yl2; exact
      match y, y0l, (yl2 : (⟨_, _⟩ : ℤ√_) < ⟨_, _⟩) with
      | 0, y0l, yl2 := y0l (le_refl 0)
      | (y+1 : ℕ), y0l, yl2 := yl2 (zsqrtd.le_of_le_le (le_refl 0)
          (let t := int.coe_nat_le_coe_nat_of_le (nat.succ_pos y) in add_le_add t t))
      | -[1+y], y0l, yl2 := y0l trivial
      end

  theorem eq_pell_zd (b : ℤ√d) (b1 : 1 ≤ b) (hp : is_pell b) : ∃n, b = pell_zd n :=
  let ⟨n, h⟩ := @zsqrtd.le_arch d b in
  eq_pell_lem n b b1 hp $ zsqrtd.le_trans h $ by rw zsqrtd.coe_nat_val; exact
  zsqrtd.le_of_le_le
    (int.coe_nat_le_coe_nat_of_le $ le_of_lt $ n_lt_xn _ _) (int.coe_zero_le _)

  /-- Every solution to Pell's equation is recursively obtained from the initial solution `(1,0)`
    using the recursion `pell`-/
  theorem eq_pell {x y : ℕ} (hp : x*x - d*y*y = 1) : ∃n, x = xn n ∧ y = yn n :=
  have (1:ℤ√d) ≤ ⟨x, y⟩, from match x, hp with
  | 0,    (hp : 0 - _ = 1) := by rw nat.zero_sub at hp; contradiction
  | (x+1), hp := zsqrtd.le_of_le_le (int.coe_nat_le_coe_nat_of_le $ nat.succ_pos x)
                 (int.coe_zero_le _)
  end,
  let ⟨m, e⟩ := eq_pell_zd ⟨x, y⟩ this (is_pell_nat.2 hp) in
  ⟨m, match x, y, e with ._, ._, rfl := ⟨rfl, rfl⟩ end⟩

  theorem pell_zd_add (m) : ∀ n, pell_zd (m + n) = pell_zd m * pell_zd n
  | 0     := (mul_one _).symm
  | (n+1) := by rw[← add_assoc, pell_zd_succ, pell_zd_succ, pell_zd_add n, ← mul_assoc]

  theorem xn_add (m n) : xn (m + n) = xn m * xn n + d * yn m * yn n :=
  by injection (pell_zd_add _ m n) with h _;
     repeat {rw ← int.coe_nat_add at h <|> rw ← int.coe_nat_mul at h};
     exact int.coe_nat_inj h

  theorem yn_add (m n) : yn (m + n) = xn m * yn n + yn m * xn n :=
  by injection (pell_zd_add _ m n) with _ h;
     repeat {rw ← int.coe_nat_add at h <|> rw ← int.coe_nat_mul at h};
     exact int.coe_nat_inj h

  theorem pell_zd_sub {m n} (h : n ≤ m) : pell_zd (m - n) = pell_zd m * (pell_zd n).conj :=
  let t := pell_zd_add n (m - n) in
  by rw [nat.add_sub_of_le h] at t;
     rw [t, mul_comm (pell_zd _ n) _, mul_assoc, (is_pell_norm _).1 (is_pell_pell_zd _ _), mul_one]

  theorem xz_sub {m n} (h : n ≤ m) : xz (m - n) = xz m * xz n - d * yz m * yz n :=
  by injection (pell_zd_sub _ h) with h _; repeat {rw ← neg_mul_eq_mul_neg at h}; exact h

  theorem yz_sub {m n} (h : n ≤ m) : yz (m - n) = xz n * yz m - xz m * yz n :=
  by injection (pell_zd_sub a1 h) with _ h; repeat {rw ← neg_mul_eq_mul_neg at h};
    rw [add_comm, mul_comm] at h; exact h

  theorem xy_coprime (n) : (xn n).coprime (yn n) :=
  nat.coprime_of_dvd' $ λk kp kx ky,
  let p := pell_eq n in by rw ← p; exact
  nat.dvd_sub (le_of_lt $ nat.lt_of_sub_eq_succ p)
    (dvd_mul_of_dvd_right kx _) (dvd_mul_of_dvd_right ky _)

  theorem y_increasing {m} : Π {n}, m < n → yn m < yn n
  | 0     h := absurd h $ nat.not_lt_zero _
  | (n+1) h :=
    have yn m ≤ yn n, from or.elim (lt_or_eq_of_le $ nat.le_of_succ_le_succ h)
      (λhl, le_of_lt $ y_increasing hl) (λe, by rw e),
    by simp; refine lt_of_le_of_lt _ (nat.lt_add_of_pos_left $ x_pos a1 n);
       rw ← mul_one (yn a1 m);
       exact mul_le_mul this (le_of_lt a1) (nat.zero_le _) (nat.zero_le _)

  theorem x_increasing {m} : Π {n}, m < n → xn m < xn n
  | 0     h := absurd h $ nat.not_lt_zero _
  | (n+1) h :=
    have xn m ≤ xn n, from or.elim (lt_or_eq_of_le $ nat.le_of_succ_le_succ h)
      (λhl, le_of_lt $ x_increasing hl) (λe, by rw e),
    by simp; refine lt_of_lt_of_le (lt_of_le_of_lt this _) (nat.le_add_right _ _);
       have t := nat.mul_lt_mul_of_pos_left a1 (x_pos a1 n); rwa mul_one at t

  theorem yn_ge_n : Π n, n ≤ yn n
  | 0 := nat.zero_le _
  | (n+1) := show n < yn (n+1), from lt_of_le_of_lt (yn_ge_n n) (y_increasing $ nat.lt_succ_self n)

  theorem y_mul_dvd (n) : ∀k, yn n ∣ yn (n * k)
  | 0     := dvd_zero _
  | (k+1) := by rw [nat.mul_succ, yn_add]; exact
    dvd_add (dvd_mul_left _ _) (dvd_mul_of_dvd_left (y_mul_dvd k) _)

  theorem y_dvd_iff (m n) : yn m ∣ yn n ↔ m ∣ n :=
  ⟨λh, nat.dvd_of_mod_eq_zero $ (nat.eq_zero_or_pos _).resolve_right $ λhp,
    have co : nat.coprime (yn m) (xn (m * (n / m))), from nat.coprime.symm $
      (xy_coprime _).coprime_dvd_right (y_mul_dvd m (n / m)),
    have m0 : 0 < m, from m.eq_zero_or_pos.resolve_left $
      λe, by rw [e, nat.mod_zero] at hp; rw [e] at h; exact
      ne_of_lt (y_increasing a1 hp) (eq_zero_of_zero_dvd h).symm,
    by rw [← nat.mod_add_div n m, yn_add] at h; exact
    not_le_of_gt (y_increasing _ $ nat.mod_lt n m0)
     (nat.le_of_dvd (y_increasing _ hp) $ co.dvd_of_dvd_mul_right $
      (nat.dvd_add_iff_right $ dvd_mul_of_dvd_right (y_mul_dvd _ _ _) _).2 h),
  λ⟨k, e⟩, by rw e; apply y_mul_dvd⟩

  theorem xy_modeq_yn (n) :
    ∀k, xn (n * k) ≡ (xn n)^k [MOD (yn n)^2]
      ∧ yn (n * k) ≡ k * (xn n)^(k-1) * yn n [MOD (yn n)^3]
  | 0     := by constructor; simp
  | (k+1) :=
    let ⟨hx, hy⟩ := xy_modeq_yn k in
    have L : xn (n * k) * xn n + d * yn (n * k) * yn n ≡ xn n^k * xn n + 0 [MOD yn n^2], from
    modeq.modeq_add (modeq.modeq_mul_right _ hx) $ modeq.modeq_zero_iff.2 $
      by rw pow_succ'; exact
      mul_dvd_mul_right (dvd_mul_of_dvd_right (modeq.modeq_zero_iff.1 $
        (hy.modeq_of_dvd_of_modeq $ by simp [pow_succ']).trans $ modeq.modeq_zero_iff.2 $
        by simp [-mul_comm, -mul_assoc]) _) _,
    have R : xn (n * k) * yn n + yn (n * k) * xn n ≡
             xn n^k * yn n + k * xn n^k * yn n [MOD yn n^3], from
    modeq.modeq_add (by rw pow_succ'; exact modeq.modeq_mul_right' _ hx) $
      have k * xn n^(k - 1) * yn n * xn n = k * xn n^k * yn n,
        by clear _let_match; cases k with k; simp [pow_succ', mul_comm, mul_left_comm],
      by rw ← this; exact modeq.modeq_mul_right _ hy,
    by rw [nat.add_sub_cancel, nat.mul_succ, xn_add, yn_add, pow_succ' (xn _ n),
           nat.succ_mul, add_comm (k * xn _ n^k) (xn _ n^k), right_distrib];
       exact ⟨L, R⟩

  theorem ysq_dvd_yy (n) : yn n * yn n ∣ yn (n * yn n) :=
  modeq.modeq_zero_iff.1 $
    ((xy_modeq_yn n (yn n)).right.modeq_of_dvd_of_modeq $ by simp [pow_succ]).trans
    (modeq.modeq_zero_iff.2 $ by simp [mul_dvd_mul_left, mul_assoc])

  theorem dvd_of_ysq_dvd {n t} (h : yn n * yn n ∣ yn t) : yn n ∣ t :=
  have nt : n ∣ t, from (y_dvd_iff n t).1 $ dvd_of_mul_left_dvd h,
  n.eq_zero_or_pos.elim (λn0, by rw n0; rw n0 at nt; exact nt) $ λ(n0l : 0 < n),
  let ⟨k, ke⟩ := nt in
  have yn n ∣ k * (xn n)^(k-1), from
  nat.dvd_of_mul_dvd_mul_right (y_increasing n0l) $ modeq.modeq_zero_iff.1 $
    by have xm := (xy_modeq_yn a1 n k).right; rw ← ke at xm; exact
    (xm.modeq_of_dvd_of_modeq $ by simp [pow_succ]).symm.trans
      (modeq.modeq_zero_iff.2 h),
  by rw ke; exact dvd_mul_of_dvd_right
    (((xy_coprime _ _).pow_left _).symm.dvd_of_dvd_mul_right this) _

  theorem pell_zd_succ_succ (n) : pell_zd (n + 2) + pell_zd n = (2 * a : ℕ) * pell_zd (n + 1) :=
  have (1:ℤ√d) + ⟨a, 1⟩ * ⟨a, 1⟩ = ⟨a, 1⟩ * (2 * a),
  by { rw zsqrtd.coe_nat_val, change (⟨_,_⟩:ℤ√(d a1))=⟨_,_⟩,
     rw dz_val, change az a1 with a, rw zsqrtd.ext, dsimp, split; ring },
  by simpa [mul_add, mul_comm, mul_left_comm, add_comm] using congr_arg (* pell_zd a1 n) this

  theorem xy_succ_succ (n) : xn (n + 2) + xn n = (2 * a) * xn (n + 1) ∧
                             yn (n + 2) + yn n = (2 * a) * yn (n + 1) := begin
    have := pell_zd_succ_succ a1 n, unfold pell_zd at this,
    rw [← int.cast_coe_nat, zsqrtd.smul_val] at this,
    injection this with h₁ h₂,
    split; apply int.coe_nat_inj; [simpa using h₁, simpa using h₂]
  end

  theorem xn_succ_succ (n) : xn (n + 2) + xn n = (2 * a) * xn (n + 1) := (xy_succ_succ n).1
  theorem yn_succ_succ (n) : yn (n + 2) + yn n = (2 * a) * yn (n + 1) := (xy_succ_succ n).2

  theorem xz_succ_succ (n) : xz (n + 2) = (2 * a : ℕ) * xz (n + 1) - xz n :=
  eq_sub_of_add_eq $ by delta xz; rw [← int.coe_nat_add, ← int.coe_nat_mul, xn_succ_succ]

  theorem yz_succ_succ (n) : yz (n + 2) = (2 * a : ℕ) * yz (n + 1) - yz n :=
  eq_sub_of_add_eq $ by delta yz; rw [← int.coe_nat_add, ← int.coe_nat_mul, yn_succ_succ]

  theorem yn_modeq_a_sub_one : ∀ n, yn n ≡ n [MOD a-1]
  | 0 := by simp
  | 1 := by simp
  | (n+2) := modeq.modeq_add_cancel_right (yn_modeq_a_sub_one n) $
    have 2*(n+1) = n+2+n, by ring,
    by rw [yn_succ_succ, ← this];
    refine modeq.modeq_mul (modeq.modeq_mul_left 2 (_ : a ≡ 1 [MOD a-1]))
      (yn_modeq_a_sub_one (n+1));
    exact (modeq.modeq_of_dvd $ by rw [int.coe_nat_sub $ le_of_lt a1]; apply dvd_refl).symm

  theorem yn_modeq_two : ∀ n, yn n ≡ n [MOD 2]
  | 0 := by simp
  | 1 := by simp
  | (n+2) := modeq.modeq_add_cancel_right (yn_modeq_two n) $
    have 2*(n+1) = n+2+n, by ring,
    by rw [yn_succ_succ, ← this];
    refine modeq.modeq_mul _ (yn_modeq_two (n+1));
    exact modeq.trans
      (modeq.modeq_zero_iff.2 $ by simp)
      (modeq.modeq_zero_iff.2 $ by simp).symm

  lemma x_sub_y_dvd_pow_lem (y2 y1 y0 yn1 yn0 xn1 xn0 ay a2 : ℤ) :
    (a2 * yn1 - yn0) * ay + y2 - (a2 * xn1 - xn0) =
      y2 - a2 * y1 + y0 + a2 * (yn1 * ay + y1 - xn1) - (yn0 * ay + y0 - xn0) := by ring

  theorem x_sub_y_dvd_pow (y : ℕ) :
    ∀ n, (2*a*y - y*y - 1 : ℤ) ∣ yz n * (a - y) + ↑(y^n) - xz n
  | 0 := by simp [xz, yz, int.coe_nat_zero, int.coe_nat_one]
  | 1 := by simp [xz, yz, int.coe_nat_zero, int.coe_nat_one]
  | (n+2) :=
    have (2*a*y - y*y - 1 : ℤ) ∣ ↑(y^(n + 2)) - ↑(2 * a) * ↑(y^(n + 1)) + ↑(y^n), from
    ⟨-↑(y^n), by simp [pow_succ, mul_add, int.coe_nat_mul,
        show ((2:ℕ):ℤ) = 2, from rfl, mul_comm, mul_left_comm]; ring ⟩,
    by rw [xz_succ_succ, yz_succ_succ, x_sub_y_dvd_pow_lem a1 ↑(y^(n+2)) ↑(y^(n+1)) ↑(y^n)]; exact
    dvd_sub (dvd_add this $ dvd_mul_of_dvd_right (x_sub_y_dvd_pow (n+1)) _) (x_sub_y_dvd_pow n)

  theorem xn_modeq_x2n_add_lem (n j) : xn n ∣ d * yn n * (yn n * xn j) + xn j :=
  have h1 : d * yn n * (yn n * xn j) + xn j = (d * yn n * yn n + 1) * xn j,
    by simp [add_mul, mul_assoc],
  have h2 : d * yn n * yn n + 1 = xn n * xn n, by apply int.coe_nat_inj;
    repeat {rw int.coe_nat_add <|> rw int.coe_nat_mul}; exact
    add_eq_of_eq_sub' (eq.symm $ pell_eqz _ _),
  by rw h2 at h1; rw [h1, mul_assoc]; exact dvd_mul_right _ _

  theorem xn_modeq_x2n_add (n j) : xn (2 * n + j) + xn j ≡ 0 [MOD xn n] :=
  by rw [two_mul, add_assoc, xn_add, add_assoc]; exact
  show _ ≡ 0+0 [MOD xn a1 n],
    from modeq.modeq_add (modeq.modeq_zero_iff.2 $ dvd_mul_right (xn a1 n) (xn a1 (n + j))) $
  by rw [yn_add, left_distrib, add_assoc]; exact
  show _ ≡ 0+0 [MOD xn a1 n],
    from modeq.modeq_add (modeq.modeq_zero_iff.2 $ dvd_mul_of_dvd_right (dvd_mul_right _ _) _) $
  modeq.modeq_zero_iff.2 $ xn_modeq_x2n_add_lem _ _ _

  lemma xn_modeq_x2n_sub_lem {n j} (h : j ≤ n) : xn (2 * n - j) + xn j ≡ 0 [MOD xn n] :=
  have h1 : xz n ∣ ↑d * yz n * yz (n - j) + xz j,
    by rw [yz_sub _ h, mul_sub_left_distrib, sub_add_eq_add_sub]; exact
  dvd_sub
    (by delta xz; delta yz;
        repeat {rw ← int.coe_nat_add <|> rw ← int.coe_nat_mul}; rw mul_comm (xn a1 j) (yn a1 n);
        exact int.coe_nat_dvd.2 (xn_modeq_x2n_add_lem _ _ _))
    (dvd_mul_of_dvd_right (dvd_mul_right _ _) _),
  by rw [two_mul, nat.add_sub_assoc h, xn_add, add_assoc]; exact
  show _ ≡ 0+0 [MOD xn a1 n], from modeq.modeq_add (modeq.modeq_zero_iff.2 $ dvd_mul_right _ _) $
  modeq.modeq_zero_iff.2 $ int.coe_nat_dvd.1 $ by simpa [xz, yz] using h1

  theorem xn_modeq_x2n_sub {n j} (h : j ≤ 2 * n) : xn (2 * n - j) + xn j ≡ 0 [MOD xn n] :=
  (le_total j n).elim xn_modeq_x2n_sub_lem
    (λjn, have 2 * n - j + j ≤ n + j, by rw [nat.sub_add_cancel h, two_mul];
      exact nat.add_le_add_left jn _,
      let t := xn_modeq_x2n_sub_lem (nat.le_of_add_le_add_right this) in
        by rwa [nat.sub_sub_self h, add_comm] at t)

  theorem xn_modeq_x4n_add (n j) : xn (4 * n + j) ≡ xn j [MOD xn n] :=
  modeq.modeq_add_cancel_right (modeq.refl $ xn (2 * n + j)) $
  by refine @modeq.trans _ _ 0 _ _ (by rw add_comm; exact (xn_modeq_x2n_add _ _ _).symm);
     rw [show 4*n = 2*n + 2*n, from right_distrib 2 2 n, add_assoc]; apply xn_modeq_x2n_add

  theorem xn_modeq_x4n_sub {n j} (h : j ≤ 2 * n) : xn (4 * n - j) ≡ xn j [MOD xn n] :=
  have h' : j ≤ 2*n, from le_trans h (by rw nat.succ_mul; apply nat.le_add_left),
  modeq.modeq_add_cancel_right (modeq.refl $ xn (2 * n - j)) $
  by refine @modeq.trans _ _ 0 _ _ (by rw add_comm; exact (xn_modeq_x2n_sub _ h).symm);
     rw [show 4*n = 2*n + 2*n, from right_distrib 2 2 n, nat.add_sub_assoc h'];
       apply xn_modeq_x2n_add

  theorem eq_of_xn_modeq_lem1 {i n} : Π {j}, i < j → j < n → xn i % xn n < xn j % xn n
  | 0     ij _  := absurd ij (nat.not_lt_zero _)
  | (j+1) ij jn :=
     suffices xn j % xn n < xn (j + 1) % xn n, from
     (lt_or_eq_of_le (nat.le_of_succ_le_succ ij)).elim
        (λh, lt_trans (eq_of_xn_modeq_lem1 h (le_of_lt jn)) this)
        (λh, by rw h; exact this),
    by rw [nat.mod_eq_of_lt (x_increasing _ (nat.lt_of_succ_lt jn)),
           nat.mod_eq_of_lt (x_increasing _ jn)];
       exact x_increasing _ (nat.lt_succ_self _)

  theorem eq_of_xn_modeq_lem2 {n} (h : 2 * xn n = xn (n + 1)) : a = 2 ∧ n = 0 :=
  by rw [xn_succ, mul_comm] at h; exact
  have n = 0, from n.eq_zero_or_pos.resolve_right $ λnp,
    ne_of_lt (lt_of_le_of_lt (nat.mul_le_mul_left _ a1)
      (nat.lt_add_of_pos_right $ mul_pos (d_pos a1) (y_increasing a1 np))) h,
  by cases this; simp at h; exact ⟨h.symm, rfl⟩

  theorem eq_of_xn_modeq_lem3 {i n} (npos : 0 < n) :
    Π {j}, i < j → j ≤ 2 * n → j ≠ n → ¬(a = 2 ∧ n = 1 ∧ i = 0 ∧ j = 2) → xn i % xn n < xn j % xn n
  | 0     ij _   _   _     := absurd ij (nat.not_lt_zero _)
  | (j+1) ij j2n jnn ntriv :=
    have lem2 : ∀k > n, k ≤ 2*n → (↑(xn k % xn n) : ℤ) = xn n - xn (2 * n - k), from λk kn k2n,
      let k2nl := lt_of_add_lt_add_right $ show 2*n-k+k < n+k, by
        {rw nat.sub_add_cancel, rw two_mul; exact (add_lt_add_left kn n), exact k2n } in
      have xle : xn (2 * n - k) ≤ xn n, from le_of_lt $ x_increasing k2nl,
      suffices xn k % xn n = xn n - xn (2 * n - k), by rw [this, int.coe_nat_sub xle],
      by {
        rw ← nat.mod_eq_of_lt (nat.sub_lt (x_pos a1 n) (x_pos a1 (2 * n - k))),
        apply modeq.modeq_add_cancel_right (modeq.refl (xn a1 (2 * n - k))),
        rw [nat.sub_add_cancel xle],
        have t := xn_modeq_x2n_sub_lem a1 (le_of_lt k2nl),
        rw nat.sub_sub_self k2n at t,
        exact t.trans (modeq.modeq_zero_iff.2 $ dvd_refl _).symm },
    (lt_trichotomy j n).elim
    (λ (jn : j < n), eq_of_xn_modeq_lem1 ij (lt_of_le_of_ne jn jnn)) $ λo, o.elim
    (λ (jn : j = n), by {
      cases jn,
      apply int.lt_of_coe_nat_lt_coe_nat,
      rw [lem2 (n+1) (nat.lt_succ_self _) j2n,
          show 2 * n - (n + 1) = n - 1, by rw[two_mul, ← nat.sub_sub, nat.add_sub_cancel]],
      refine lt_sub_left_of_add_lt (int.coe_nat_lt_coe_nat_of_lt _),
      cases (lt_or_eq_of_le $ nat.le_of_succ_le_succ ij) with lin ein,
      { rw nat.mod_eq_of_lt (x_increasing _ lin),
        have ll : xn a1 (n-1) + xn a1 (n-1) ≤ xn a1 n,
        { rw [← two_mul, mul_comm, show xn a1 n = xn a1 (n-1+1),
                                   by rw [nat.sub_add_cancel npos], xn_succ],
          exact le_trans (nat.mul_le_mul_left _ a1) (nat.le_add_right _ _) },
        have npm : (n-1).succ = n := nat.succ_pred_eq_of_pos npos,
        have il : i ≤ n - 1, { apply nat.le_of_succ_le_succ, rw npm, exact lin },
        cases lt_or_eq_of_le il with ill ile,
        { exact lt_of_lt_of_le (nat.add_lt_add_left (x_increasing a1 ill) _) ll },
        { rw ile,
          apply lt_of_le_of_ne ll,
          rw ← two_mul,
          exact λe, ntriv $
            let ⟨a2, s1⟩ := @eq_of_xn_modeq_lem2 _ a1 (n-1) (by rwa [nat.sub_add_cancel npos]) in
            have n1 : n = 1, from le_antisymm (nat.le_of_sub_eq_zero s1) npos,
            by rw [ile, a2, n1]; exact ⟨rfl, rfl, rfl, rfl⟩ } },
      { rw [ein, nat.mod_self, add_zero],
        exact x_increasing _ (nat.pred_lt $ ne_of_gt npos) } })
    (λ (jn : j > n),
      have lem1 : j ≠ n → xn j % xn n < xn (j + 1) % xn n → xn i % xn n < xn (j + 1) % xn n,
        from λjn s,
      (lt_or_eq_of_le (nat.le_of_succ_le_succ ij)).elim
        (λh, lt_trans (eq_of_xn_modeq_lem3 h (le_of_lt j2n) jn $ λ⟨a1, n1, i0, j2⟩,
          by rw [n1, j2] at j2n; exact absurd j2n dec_trivial) s)
        (λh, by rw h; exact s),
      lem1 (ne_of_gt jn) $ int.lt_of_coe_nat_lt_coe_nat $ by {
        rw [lem2 j jn (le_of_lt j2n), lem2 (j+1) (nat.le_succ_of_le jn) j2n],
        refine sub_lt_sub_left (int.coe_nat_lt_coe_nat_of_lt $ x_increasing _ _) _,
        rw [nat.sub_succ],
        exact nat.pred_lt (ne_of_gt $ nat.sub_pos_of_lt j2n) })

  theorem eq_of_xn_modeq_le {i j n} (npos : 0 < n) (ij : i ≤ j) (j2n : j ≤ 2 * n)
    (h : xn i ≡ xn j [MOD xn n]) (ntriv : ¬(a = 2 ∧ n = 1 ∧ i = 0 ∧ j = 2)) : i = j :=
  (lt_or_eq_of_le ij).resolve_left $ λij',
  if jn : j = n then by {
    refine ne_of_gt _ h,
    rw [jn, nat.mod_self],
    have x0 : 0 < xn a1 0 % xn a1 n := by rw [nat.mod_eq_of_lt (x_increasing a1 npos)];
      exact dec_trivial,
    cases i with i, exact x0,
    rw jn at ij',
    exact x0.trans (eq_of_xn_modeq_lem3 _ npos (nat.succ_pos _) (le_trans ij j2n) (ne_of_lt ij') $
      λ⟨a1, n1, _, i2⟩, by rw [n1, i2] at ij'; exact absurd ij' dec_trivial)
  } else ne_of_lt (eq_of_xn_modeq_lem3 npos ij' j2n jn ntriv) h

  theorem eq_of_xn_modeq {i j n} (npos : 0 < n) (i2n : i ≤ 2 * n) (j2n : j ≤ 2 * n)
    (h : xn i ≡ xn j [MOD xn n]) (ntriv : a = 2 → n = 1 → (i = 0 → j ≠ 2) ∧ (i = 2 → j ≠ 0)) :
    i = j :=
  (le_total i j).elim
    (λij, eq_of_xn_modeq_le npos ij j2n h $ λ⟨a2, n1, i0, j2⟩, (ntriv a2 n1).left i0 j2)
    (λij, (eq_of_xn_modeq_le npos ij i2n h.symm $ λ⟨a2, n1, j0, i2⟩,
      (ntriv a2 n1).right i2 j0).symm)

  theorem eq_of_xn_modeq' {i j n} (ipos : 0 < i) (hin : i ≤ n) (j4n : j ≤ 4 * n)
    (h : xn j ≡ xn i [MOD xn n]) : j = i ∨ j + i = 4 * n :=
  have i2n : i ≤ 2*n, by apply le_trans hin; rw two_mul; apply nat.le_add_left,
  have npos : 0 < n, from lt_of_lt_of_le ipos hin,
  (le_or_gt j (2 * n)).imp
    (λj2n : j ≤ 2 * n, eq_of_xn_modeq npos j2n i2n h $
      λa2 n1, ⟨λj0 i2, by rw [n1, i2] at hin; exact absurd hin dec_trivial,
               λj2 i0, ne_of_gt ipos i0⟩)
    (λj2n : 2 * n < j, suffices i = 4*n - j, by rw [this, nat.add_sub_of_le j4n],
     have j42n : 4*n - j ≤ 2*n, from @nat.le_of_add_le_add_right j _ _ $
     by rw [nat.sub_add_cancel j4n, show 4*n = 2*n + 2*n, from right_distrib 2 2 n];
        exact nat.add_le_add_left (le_of_lt j2n) _,
     eq_of_xn_modeq npos i2n j42n
       (h.symm.trans $ let t := xn_modeq_x4n_sub j42n in by rwa [nat.sub_sub_self j4n] at t)
       (λa2 n1, ⟨λi0, absurd i0 (ne_of_gt ipos), λi2, by { rw [n1, i2] at hin,
         exact absurd hin dec_trivial }⟩))

  theorem modeq_of_xn_modeq {i j n} (ipos : 0 < i) (hin : i ≤ n) (h : xn j ≡ xn i [MOD xn n]) :
    j ≡ i [MOD 4 * n] ∨ j + i ≡ 0 [MOD 4 * n] :=
  let j' := j % (4 * n) in
  have n4 : 0 < 4 * n, from mul_pos dec_trivial (lt_of_lt_of_le ipos hin),
  have jl : j' < 4 * n, from nat.mod_lt _ n4,
  have jj : j ≡ j' [MOD 4 * n], by delta modeq; rw nat.mod_eq_of_lt jl,
  have ∀j q, xn (j + 4 * n * q) ≡ xn j [MOD xn n], begin
    intros j q, induction q with q IH, { simp },
    rw[nat.mul_succ, ← add_assoc, add_comm],
    exact modeq.trans (xn_modeq_x4n_add _ _ _) IH
  end,
  or.imp
    (λ(ji : j' = i), by rwa ← ji)
    (λ(ji : j' + i = 4 * n), (modeq.modeq_add jj (modeq.refl _)).trans $
      by rw ji; exact modeq.modeq_zero_iff.2 (dvd_refl _))
    (eq_of_xn_modeq' ipos hin (le_of_lt jl) $
      (modeq.symm (by rw ← nat.mod_add_div j (4*n); exact this j' _)).trans h)
end

theorem xy_modeq_of_modeq {a b c} (a1 : 1 < a) (b1 : 1 < b) (h : a ≡ b [MOD c]) :
  ∀ n, xn a1 n ≡ xn b1 n [MOD c] ∧ yn a1 n ≡ yn b1 n [MOD c]
| 0 := by constructor; refl
| 1 := by simp; exact ⟨h, modeq.refl 1⟩
| (n+2) := ⟨
  modeq.modeq_add_cancel_right (xy_modeq_of_modeq n).left $
    by rw [xn_succ_succ a1, xn_succ_succ b1]; exact
    modeq.modeq_mul (modeq.modeq_mul_left _ h) (xy_modeq_of_modeq (n+1)).left,
  modeq.modeq_add_cancel_right (xy_modeq_of_modeq n).right $
    by rw [yn_succ_succ a1, yn_succ_succ b1]; exact
    modeq.modeq_mul (modeq.modeq_mul_left _ h) (xy_modeq_of_modeq (n+1)).right⟩

theorem matiyasevic {a k x y} : (∃ a1 : 1 < a, xn a1 k = x ∧ yn a1 k = y) ↔
1 < a ∧ k ≤ y ∧
(x = 1 ∧ y = 0 ∨
∃ (u v s t b : ℕ),
  x * x - (a * a - 1) * y * y = 1 ∧
  u * u - (a * a - 1) * v * v = 1 ∧
  s * s - (b * b - 1) * t * t = 1 ∧
  1 < b ∧ b ≡ 1 [MOD 4 * y] ∧ b ≡ a [MOD u] ∧
  0 < v ∧ y * y ∣ v ∧
  s ≡ x [MOD u] ∧
  t ≡ k [MOD 4 * y]) :=
⟨λ⟨a1, hx, hy⟩, by rw [← hx, ← hy];
  refine ⟨a1, (nat.eq_zero_or_pos k).elim
    (λk0, by rw k0; exact ⟨le_refl _, or.inl ⟨rfl, rfl⟩⟩) (λkpos, _)⟩; exact
  let x := xn a1 k, y := yn a1 k,
      m := 2 * (k * y),
      u := xn a1 m, v := yn a1 m in
  have ky : k ≤ y, from yn_ge_n a1 k,
  have yv : y * y ∣ v, from dvd_trans (ysq_dvd_yy a1 k) $
      (y_dvd_iff _ _ _).2 $ dvd_mul_left _ _,
  have uco : nat.coprime u (4 * y), from
    have 2 ∣ v, from modeq.modeq_zero_iff.1 $ (yn_modeq_two _ _).trans $
      modeq.modeq_zero_iff.2 (dvd_mul_right _ _),
    have nat.coprime u 2, from
      (xy_coprime a1 m).coprime_dvd_right this,
    (this.mul_right this).mul_right $
      (xy_coprime _ _).coprime_dvd_right (dvd_of_mul_left_dvd yv),
  let ⟨b, ba, bm1⟩ := modeq.chinese_remainder uco a 1 in
  have m1 : 1 < m, from
    have 0 < k * y, from mul_pos kpos (y_increasing a1 kpos),
    nat.mul_le_mul_left 2 this,
  have vp : 0 < v, from y_increasing a1 (lt_trans zero_lt_one m1),
  have b1 : 1 < b, from
    have xn a1 1 < u, from x_increasing a1 m1,
    have a < u, by simp at this; exact this,
    lt_of_lt_of_le a1 $ by delta modeq at ba;
      rw nat.mod_eq_of_lt this at ba; rw ← ba; apply nat.mod_le,
  let s := xn b1 k, t := yn b1 k in
  have sx : s ≡ x [MOD u], from (xy_modeq_of_modeq b1 a1 ba k).left,
  have tk : t ≡ k [MOD 4 * y], from
      have 4 * y ∣ b - 1, from int.coe_nat_dvd.1 $
        by rw int.coe_nat_sub (le_of_lt b1);
           exact modeq.dvd_of_modeq bm1.symm,
      modeq.modeq_of_dvd_of_modeq this $ yn_modeq_a_sub_one _ _,
  ⟨ky, or.inr ⟨u, v, s, t, b,
    pell_eq _ _, pell_eq _ _, pell_eq _ _, b1, bm1, ba, vp, yv, sx, tk⟩⟩,
λ⟨a1, ky, o⟩, ⟨a1, match o with
| or.inl ⟨x1, y0⟩ := by rw y0 at ky; rw [nat.eq_zero_of_le_zero ky, x1, y0]; exact ⟨rfl, rfl⟩
| or.inr ⟨u, v, s, t, b, xy, uv, st, b1, rem⟩ :=
  match x, y, eq_pell a1 xy, u, v, eq_pell a1 uv, s, t, eq_pell b1 st, rem, ky with
  | ._, ._, ⟨i, rfl, rfl⟩, ._, ._, ⟨n, rfl, rfl⟩, ._, ._, ⟨j, rfl, rfl⟩,
    ⟨(bm1 : b ≡ 1 [MOD 4 * yn a1 i]),
     (ba : b ≡ a [MOD xn a1 n]),
     (vp : 0 < yn a1 n),
     (yv : yn a1 i * yn a1 i ∣ yn a1 n),
     (sx : xn b1 j ≡ xn a1 i [MOD xn a1 n]),
     (tk : yn b1 j ≡ k [MOD 4 * yn a1 i])⟩,
     (ky : k ≤ yn a1 i) :=
    (nat.eq_zero_or_pos i).elim
      (λi0, by simp [i0] at ky; rw [i0, ky]; exact ⟨rfl, rfl⟩) $ λipos,
    suffices i = k, by rw this; exact ⟨rfl, rfl⟩,
    by clear _x o rem xy uv st _match _match _fun_match; exact
    have iln : i ≤ n, from le_of_not_gt $ λhin,
    not_lt_of_ge (nat.le_of_dvd vp (dvd_of_mul_left_dvd yv)) (y_increasing a1 hin),
    have yd : 4 * yn a1 i ∣ 4 * n, from mul_dvd_mul_left _ $ dvd_of_ysq_dvd a1 yv,
    have jk : j ≡ k [MOD 4 * yn a1 i], from
      have 4 * yn a1 i ∣ b - 1, from int.coe_nat_dvd.1 $
        by rw int.coe_nat_sub (le_of_lt b1); exact modeq.dvd_of_modeq bm1.symm,
      (modeq.modeq_of_dvd_of_modeq this (yn_modeq_a_sub_one b1 _)).symm.trans tk,
    have ki : k + i < 4 * yn a1 i, from
      lt_of_le_of_lt (add_le_add ky (yn_ge_n a1 i)) $
      by rw ← two_mul; exact nat.mul_lt_mul_of_pos_right dec_trivial (y_increasing a1 ipos),
    have ji : j ≡ i [MOD 4 * n], from
      have xn a1 j ≡ xn a1 i [MOD xn a1 n], from (xy_modeq_of_modeq b1 a1 ba j).left.symm.trans sx,
      (modeq_of_xn_modeq a1 ipos iln this).resolve_right $ λ (ji : j + i ≡ 0 [MOD 4 * n]),
      not_le_of_gt ki $ nat.le_of_dvd (lt_of_lt_of_le ipos $ nat.le_add_left _ _) $
      modeq.modeq_zero_iff.1 $ (modeq.modeq_add jk.symm (modeq.refl i)).trans $
      modeq.modeq_of_dvd_of_modeq yd ji,
    by have : i % (4 * yn a1 i) = k % (4 * yn a1 i) :=
         (modeq.modeq_of_dvd_of_modeq yd ji).symm.trans jk;
       rwa [nat.mod_eq_of_lt (lt_of_le_of_lt (nat.le_add_left _ _) ki),
            nat.mod_eq_of_lt (lt_of_le_of_lt (nat.le_add_right _ _) ki)] at this
  end
end⟩⟩

lemma eq_pow_of_pell_lem {a y k} (a1 : 1 < a) (ypos : 0 < y) : 0 < k → y^k < a →
  (↑(y^k) : ℤ) < 2*a*y - y*y - 1 :=
have y < a → a + (y*y + 1) ≤ 2*a*y, begin
  intro ya, induction y with y IH, exact absurd ypos (lt_irrefl _),
  cases nat.eq_zero_or_pos y with y0 ypos,
  { rw y0, simpa [two_mul], },
  { rw [nat.mul_succ, nat.mul_succ, nat.succ_mul y],
    have : y + nat.succ y ≤ 2 * a,
    { change y + y < 2 * a, rw ← two_mul,
      exact mul_lt_mul_of_pos_left (nat.lt_of_succ_lt ya) dec_trivial },
    have := add_le_add (IH ypos (nat.lt_of_succ_lt ya)) this,
    convert this using 1,
    ring }
end, λk0 yak,
lt_of_lt_of_le (int.coe_nat_lt_coe_nat_of_lt yak) $
by rw sub_sub; apply le_sub_right_of_add_le;
   apply int.coe_nat_le_coe_nat_of_le;
   have y1 := nat.pow_le_pow_of_le_right ypos k0; simp at y1;
   exact this (lt_of_le_of_lt y1 yak)

theorem eq_pow_of_pell {m n k} : (n^k = m ↔
k = 0 ∧ m = 1 ∨ 0 < k ∧
(n = 0 ∧ m = 0 ∨ 0 < n ∧
∃ (w a t z : ℕ) (a1 : 1 < a),
  xn a1 k ≡ yn a1 k * (a - n) + m [MOD t] ∧
  2 * a * n = t + (n * n + 1) ∧
  m < t ∧ n ≤ w ∧ k ≤ w ∧
  a * a - ((w + 1) * (w + 1) - 1) * (w * z) * (w * z) = 1)) :=
⟨λe, by rw ← e;
  refine (nat.eq_zero_or_pos k).elim
    (λk0, by rw k0; exact or.inl ⟨rfl, rfl⟩)
    (λkpos, or.inr ⟨kpos, _⟩);
  refine (nat.eq_zero_or_pos n).elim
    (λn0, by rw [n0, zero_pow kpos]; exact or.inl ⟨rfl, rfl⟩)
    (λnpos, or.inr ⟨npos, _⟩); exact
  let w := _root_.max n k in
  have nw : n ≤ w, from le_max_left _ _,
  have kw : k ≤ w, from le_max_right _ _,
  have wpos : 0 < w, from lt_of_lt_of_le npos nw,
  have w1 : 1 < w + 1, from nat.succ_lt_succ wpos,
  let a := xn w1 w in
  have a1 : 1 < a, from x_increasing w1 wpos,
  let x := xn a1 k, y := yn a1 k in
  let ⟨z, ze⟩ := show w ∣ yn w1 w, from modeq.modeq_zero_iff.1 $
    modeq.trans (yn_modeq_a_sub_one w1 w) (modeq.modeq_zero_iff.2 $ dvd_refl _) in
  have nt : (↑(n^k) : ℤ) < 2 * a * n - n * n - 1, from
    eq_pow_of_pell_lem a1 npos kpos $ calc
      n^k ≤ n^w       : nat.pow_le_pow_of_le_right npos kw
      ... < (w + 1)^w : nat.pow_lt_pow_of_lt_left (nat.lt_succ_of_le nw) wpos
      ... ≤ a         : xn_ge_a_pow w1 w,
  let ⟨t, te⟩ := int.eq_coe_of_zero_le $
    le_trans (int.coe_zero_le _) $ le_of_lt nt in
  have na : n ≤ a, from le_trans nw $ le_of_lt $ n_lt_xn w1 w,
  have tm : x ≡ y * (a - n) + n^k [MOD t], begin
    apply modeq.modeq_of_dvd,
    rw [int.coe_nat_add, int.coe_nat_mul, int.coe_nat_sub na, ← te],
    exact x_sub_y_dvd_pow a1 n k
  end,
  have ta : 2 * a * n = t + (n * n + 1), from int.coe_nat_inj $
    by rw [int.coe_nat_add, ← te, sub_sub];
       repeat {rw int.coe_nat_add <|> rw int.coe_nat_mul};
       rw [int.coe_nat_one, sub_add_cancel]; refl,
  have mt : n^k < t, from int.lt_of_coe_nat_lt_coe_nat $
    by rw ← te; exact nt,
  have zp : a * a - ((w + 1) * (w + 1) - 1) * (w * z) * (w * z) = 1,
    by rw ← ze; exact pell_eq w1 w,
  ⟨w, a, t, z, a1, tm, ta, mt, nw, kw, zp⟩,
λo, match o with
| or.inl ⟨k0, m1⟩ := by rw [k0, m1]; refl
| or.inr ⟨kpos, or.inl ⟨n0, m0⟩⟩ := by rw [n0, m0, zero_pow kpos]
| or.inr ⟨kpos, or.inr ⟨npos, w, a, t, z,
   (a1 : 1 < a),
   (tm : xn a1 k ≡ yn a1 k * (a - n) + m [MOD t]),
   (ta : 2 * a * n = t + (n * n + 1)),
   (mt : m < t),
   (nw : n ≤ w),
   (kw : k ≤ w),
   (zp : a * a - ((w + 1) * (w + 1) - 1) * (w * z) * (w * z) = 1)⟩⟩ :=
  have wpos : 0 < w, from lt_of_lt_of_le npos nw,
  have w1 : 1 < w + 1, from nat.succ_lt_succ wpos,
  let ⟨j, xj, yj⟩ := eq_pell w1 zp in
  by clear _match o _let_match; exact
  have jpos : 0 < j, from (nat.eq_zero_or_pos j).resolve_left $ λj0,
    have a1 : a = 1, by rw j0 at xj; exact xj,
    have 2 * n = t + (n * n + 1), by rw a1 at ta; exact ta,
    have n1 : n = 1, from
      have n * n < n * 2, by rw [mul_comm n 2, this]; apply nat.le_add_left,
      have n ≤ 1, from nat.le_of_lt_succ $ lt_of_mul_lt_mul_left this (nat.zero_le _),
      le_antisymm this npos,
    by rw n1 at this;
      rw ← @nat.add_right_cancel 0 2 t this at mt;
      exact nat.not_lt_zero _ mt,
  have wj : w ≤ j, from nat.le_of_dvd jpos $ modeq.modeq_zero_iff.1 $
    (yn_modeq_a_sub_one w1 j).symm.trans $
    modeq.modeq_zero_iff.2 ⟨z, yj.symm⟩,
  have nt : (↑(n^k) : ℤ) < 2 * a * n - n * n - 1, from
    eq_pow_of_pell_lem a1 npos kpos $ calc
      n^k ≤ n^j       : nat.pow_le_pow_of_le_right npos (le_trans kw wj)
      ... < (w + 1)^j : nat.pow_lt_pow_of_lt_left (nat.lt_succ_of_le nw) jpos
      ... ≤ xn w1 j   : xn_ge_a_pow w1 j
      ... = a         : xj.symm,
  have na : n ≤ a, by rw xj; exact
    le_trans (le_trans nw wj) (le_of_lt $ n_lt_xn _ _),
  have te : (t : ℤ) = 2 * ↑a * ↑n - ↑n * ↑n - 1, by
    rw sub_sub; apply eq_sub_of_add_eq; apply (int.coe_nat_eq_coe_nat_iff _ _).2;
    exact ta.symm,
  have xn a1 k ≡ yn a1 k * (a - n) + n^k [MOD t],
    by have := x_sub_y_dvd_pow a1 n k;
       rw [← te, ← int.coe_nat_sub na] at this; exact modeq.modeq_of_dvd this,
  have n^k % t = m % t, from
    modeq.modeq_add_cancel_left (modeq.refl _) (this.symm.trans tm),
  by rw ← te at nt;
     rwa [nat.mod_eq_of_lt (int.lt_of_coe_nat_lt_coe_nat nt), nat.mod_eq_of_lt mt] at this
end⟩

end pell


/-
Copyright (c) 2020 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash, Antoine Labelle
-/
import linear_algebra.dual
import linear_algebra.matrix.to_lin
import linear_algebra.tensor_product_basis
import linear_algebra.free_module.finite.rank

/-!
# Contractions

Given modules $M, N$ over a commutative ring $R$, this file defines the natural linear maps:
$M^* \otimes M \to R$, $M \otimes M^* \to R$, and $M^* \otimes N → Hom(M, N)$, as well as proving
some basic properties of these maps.

## Tags

contraction, dual module, tensor product
-/

variables {ι : Type*} (R M N P Q : Type*)

local attribute [ext] tensor_product.ext

section contraction

open tensor_product linear_map matrix module
open_locale tensor_product big_operators

section comm_semiring
variables [comm_semiring R]
variables [add_comm_monoid M] [add_comm_monoid N] [add_comm_monoid P] [add_comm_monoid Q]
variables [module R M] [module R N] [module R P] [module R Q]
variables [decidable_eq ι] [fintype ι] (b : basis ι R M)

/-- The natural left-handed pairing between a module and its dual. -/
def contract_left : (module.dual R M) ⊗ M →ₗ[R] R := (uncurry _ _ _ _).to_fun linear_map.id

/-- The natural right-handed pairing between a module and its dual. -/
def contract_right : M ⊗ (module.dual R M) →ₗ[R] R :=
(uncurry _ _ _ _).to_fun (linear_map.flip linear_map.id)

/-- The natural map associating a linear map to the tensor product of two modules. -/
def dual_tensor_hom : (module.dual R M) ⊗ N →ₗ[R] M →ₗ[R] N :=
  let M' := module.dual R M in
  (uncurry R M' N (M →ₗ[R] N) : _ → M' ⊗ N →ₗ[R] M →ₗ[R] N) linear_map.smul_rightₗ

variables {R M N P Q}

@[simp] lemma contract_left_apply (f : module.dual R M) (m : M) :
  contract_left R M (f ⊗ₜ m) = f m := by apply uncurry_apply

@[simp] lemma contract_right_apply (f : module.dual R M) (m : M) :
  contract_right R M (m ⊗ₜ f) = f m := by apply uncurry_apply

@[simp] lemma dual_tensor_hom_apply (f : module.dual R M) (m : M) (n : N) :
  dual_tensor_hom R M N (f ⊗ₜ n) m = (f m) • n :=
by { dunfold dual_tensor_hom, rw uncurry_apply, refl, }

@[simp] lemma transpose_dual_tensor_hom (f : module.dual R M) (m : M) :
  dual.transpose (dual_tensor_hom R M M (f ⊗ₜ m)) = dual_tensor_hom R _ _ (dual.eval R M m ⊗ₜ f) :=
by { ext f' m', simp only [dual.transpose_apply, coe_comp, function.comp_app, dual_tensor_hom_apply,
  linear_map.map_smulₛₗ, ring_hom.id_apply, algebra.id.smul_eq_mul, dual.eval_apply, smul_apply],
  exact mul_comm _ _ }

@[simp] lemma dual_tensor_hom_prod_map_zero (f : module.dual R M) (p : P) :
  ((dual_tensor_hom R M P) (f ⊗ₜ[R] p)).prod_map (0 : N →ₗ[R] Q) =
  dual_tensor_hom R (M × N) (P × Q) ((f ∘ₗ fst R M N) ⊗ₜ inl R P Q p) :=
by {ext; simp only [coe_comp, coe_inl, function.comp_app, prod_map_apply, dual_tensor_hom_apply,
fst_apply, prod.smul_mk, zero_apply, smul_zero]}

@[simp] lemma zero_prod_map_dual_tensor_hom (g : module.dual R N) (q : Q) :
  (0 : M →ₗ[R] P).prod_map ((dual_tensor_hom R N Q) (g ⊗ₜ[R] q)) =
  dual_tensor_hom R (M × N) (P × Q) ((g ∘ₗ snd R M N) ⊗ₜ inr R P Q q) :=
by {ext; simp only [coe_comp, coe_inr, function.comp_app, prod_map_apply, dual_tensor_hom_apply,
  snd_apply, prod.smul_mk, zero_apply, smul_zero]}

lemma map_dual_tensor_hom (f : module.dual R M) (p : P) (g : module.dual R N) (q : Q) :
  tensor_product.map (dual_tensor_hom R M P (f ⊗ₜ[R] p)) (dual_tensor_hom R N Q (g ⊗ₜ[R] q)) =
  dual_tensor_hom R (M ⊗[R] N) (P ⊗[R] Q) (dual_distrib R M N (f ⊗ₜ g) ⊗ₜ[R] (p ⊗ₜ[R] q)) :=
begin
  ext m n, simp only [compr₂_apply, mk_apply, map_tmul, dual_tensor_hom_apply,
  dual_distrib_apply, ←smul_tmul_smul],
end

@[simp] lemma comp_dual_tensor_hom (f : module.dual R M) (n : N) (g : module.dual R N) (p : P) :
  (dual_tensor_hom R N P (g ⊗ₜ[R] p)) ∘ₗ (dual_tensor_hom R M N (f ⊗ₜ[R] n)) =
  g n • dual_tensor_hom R M P (f ⊗ₜ p) :=
begin
  ext m, simp only [coe_comp, function.comp_app, dual_tensor_hom_apply, linear_map.map_smul,
                    ring_hom.id_apply, smul_apply], rw smul_comm,
end

/-- As a matrix, `dual_tensor_hom` evaluated on a basis element of `M* ⊗ N` is a matrix with a
single one and zeros elsewhere -/
theorem to_matrix_dual_tensor_hom
  {m : Type*} {n : Type*} [fintype m] [fintype n] [decidable_eq m] [decidable_eq n]
  (bM : basis m R M) (bN : basis n R N) (j : m) (i : n) :
    to_matrix bM bN (dual_tensor_hom R M N (bM.coord j ⊗ₜ bN i)) = std_basis_matrix i j 1 :=
begin
  ext i' j',
  by_cases hij : (i = i' ∧ j = j');
  simp [linear_map.to_matrix_apply, finsupp.single_eq_pi_single, hij],
  rw [and_iff_not_or_not, not_not] at hij, cases hij; simp [hij],
end

end comm_semiring

section comm_ring
variables [comm_ring R]
variables [add_comm_group M] [add_comm_group N] [add_comm_group P] [add_comm_group Q]
variables [module R M] [module R N] [module R P] [module R Q]
variables [decidable_eq ι] [fintype ι] (b : basis ι R M)

variables {R M N P Q}

/-- If `M` is free, the natural linear map $M^* ⊗ N → Hom(M, N)$ is an equivalence. This function
provides this equivalence in return for a basis of `M`. -/
@[simps apply]
noncomputable def dual_tensor_hom_equiv_of_basis :
  (module.dual R M) ⊗[R] N ≃ₗ[R] M →ₗ[R] N :=
linear_equiv.of_linear
  (dual_tensor_hom R M N)
  (∑ i, (tensor_product.mk R _ N (b.dual_basis i)) ∘ₗ linear_map.applyₗ (b i))
  (begin
    ext f m,
    simp only [applyₗ_apply_apply, coe_fn_sum, dual_tensor_hom_apply, mk_apply, id_coe, id.def,
      fintype.sum_apply, function.comp_app, basis.coe_dual_basis, coe_comp,
      basis.coord_apply, ← f.map_smul, (dual_tensor_hom R M N).map_sum, ← f.map_sum, b.sum_repr],
  end)
  (begin
    ext f m,
    simp only [applyₗ_apply_apply, coe_fn_sum, dual_tensor_hom_apply, mk_apply, id_coe, id.def,
      fintype.sum_apply, function.comp_app, basis.coe_dual_basis, coe_comp,
      compr₂_apply, tmul_smul, smul_tmul', ← sum_tmul, basis.sum_dual_apply_smul_coord],
end)

@[simp] lemma dual_tensor_hom_equiv_of_basis_to_linear_map :
  (dual_tensor_hom_equiv_of_basis b : (module.dual R M) ⊗[R] N ≃ₗ[R] M →ₗ[R] N).to_linear_map =
  dual_tensor_hom R M N :=
rfl

@[simp] lemma dual_tensor_hom_equiv_of_basis_symm_cancel_left (x : (module.dual R M) ⊗[R] N) :
  (dual_tensor_hom_equiv_of_basis b).symm (dual_tensor_hom R M N x) = x :=
by rw [←dual_tensor_hom_equiv_of_basis_apply b, linear_equiv.symm_apply_apply]

@[simp] lemma dual_tensor_hom_equiv_of_basis_symm_cancel_right (x : M →ₗ[R] N) :
  dual_tensor_hom R M N ((dual_tensor_hom_equiv_of_basis b).symm x)  = x :=
by rw [←dual_tensor_hom_equiv_of_basis_apply b, linear_equiv.apply_symm_apply]

variables (R M N P Q)

variables [module.free R M] [module.finite R M] [nontrivial R]

open_locale classical

/-- If `M` is finite free, the natural map $M^* ⊗ N → Hom(M, N)$ is an
equivalence. -/
@[simp] noncomputable def dual_tensor_hom_equiv : (module.dual R M) ⊗[R] N ≃ₗ[R] M →ₗ[R] N :=
dual_tensor_hom_equiv_of_basis (module.free.choose_basis R M)

end comm_ring

end contraction

section hom_tensor_hom

open_locale tensor_product

open module tensor_product linear_map

section comm_ring

variables [comm_ring R]
variables [add_comm_group M] [add_comm_group N] [add_comm_group P] [add_comm_group Q]
variables [module R M] [module R N] [module R P] [module R Q]
variables [free R M] [finite R M] [free R N] [finite R N] [nontrivial R]

/-- When `M` is a finite free module, the map `ltensor_hom_to_hom_ltensor` is an equivalence. Note
that `ltensor_hom_equiv_hom_ltensor` is not defined directly in terms of
`ltensor_hom_to_hom_ltensor`, but the equivalence between the two is given by
`ltensor_hom_equiv_hom_ltensor_to_linear_map` and `ltensor_hom_equiv_hom_ltensor_apply`. -/
noncomputable def ltensor_hom_equiv_hom_ltensor : P ⊗[R] (M →ₗ[R] Q) ≃ₗ[R] (M →ₗ[R] P ⊗[R] Q) :=
congr (linear_equiv.refl R P) (dual_tensor_hom_equiv R M Q).symm ≪≫ₗ
  tensor_product.left_comm R P _ Q ≪≫ₗ dual_tensor_hom_equiv R M _

/-- When `M` is a finite free module, the map `rtensor_hom_to_hom_rtensor` is an equivalence. Note
that `rtensor_hom_equiv_hom_rtensor` is not defined directly in terms of
`rtensor_hom_to_hom_rtensor`, but the equivalence between the two is given by
`rtensor_hom_equiv_hom_rtensor_to_linear_map` and `rtensor_hom_equiv_hom_rtensor_apply`. -/
noncomputable def rtensor_hom_equiv_hom_rtensor : (M →ₗ[R] P) ⊗[R] Q ≃ₗ[R] (M →ₗ[R] P ⊗[R] Q) :=
congr (dual_tensor_hom_equiv R M P).symm (linear_equiv.refl R Q) ≪≫ₗ
  tensor_product.assoc R _ P Q ≪≫ₗ dual_tensor_hom_equiv R M _

@[simp] lemma ltensor_hom_equiv_hom_ltensor_to_linear_map :
  (ltensor_hom_equiv_hom_ltensor R M P Q).to_linear_map = ltensor_hom_to_hom_ltensor R M P Q :=
begin
  let e := congr (linear_equiv.refl R P) (dual_tensor_hom_equiv R M Q),
  have h : function.surjective e.to_linear_map := e.surjective,
  refine (cancel_right h).1 _,
  ext p f q m,
  simp only [ltensor_hom_equiv_hom_ltensor, dual_tensor_hom_equiv, compr₂_apply, mk_apply, coe_comp,
  linear_equiv.coe_to_linear_map, function.comp_app, map_tmul, linear_equiv.coe_coe,
  dual_tensor_hom_equiv_of_basis_apply, linear_equiv.trans_apply, congr_tmul,
  linear_equiv.refl_apply, dual_tensor_hom_equiv_of_basis_symm_cancel_left, left_comm_tmul,
  dual_tensor_hom_apply, ltensor_hom_to_hom_ltensor_apply, tmul_smul],
end

@[simp] lemma rtensor_hom_equiv_hom_rtensor_to_linear_map :
  (rtensor_hom_equiv_hom_rtensor R M P Q).to_linear_map = rtensor_hom_to_hom_rtensor R M P Q :=
begin
  let e := congr (dual_tensor_hom_equiv R M P) (linear_equiv.refl R Q),
  have h : function.surjective e.to_linear_map := e.surjective,
  refine (cancel_right h).1 _,
  ext f p q m,
  simp only [rtensor_hom_equiv_hom_rtensor, dual_tensor_hom_equiv, compr₂_apply, mk_apply, coe_comp,
  linear_equiv.coe_to_linear_map, function.comp_app, map_tmul, linear_equiv.coe_coe,
  dual_tensor_hom_equiv_of_basis_apply, linear_equiv.trans_apply, congr_tmul,
  dual_tensor_hom_equiv_of_basis_symm_cancel_left, linear_equiv.refl_apply, assoc_tmul,
  dual_tensor_hom_apply, rtensor_hom_to_hom_rtensor_apply, smul_tmul'],
end

variables {R M N P Q}

@[simp] lemma ltensor_hom_equiv_hom_ltensor_apply (x : P ⊗[R] (M →ₗ[R] Q)) :
  ltensor_hom_equiv_hom_ltensor R M P Q x = ltensor_hom_to_hom_ltensor R M P Q x :=
by rw [←linear_equiv.coe_to_linear_map, ltensor_hom_equiv_hom_ltensor_to_linear_map]

@[simp] lemma rtensor_hom_equiv_hom_rtensor_apply (x : (M →ₗ[R] P) ⊗[R] Q) :
  rtensor_hom_equiv_hom_rtensor R M P Q x = rtensor_hom_to_hom_rtensor R M P Q x :=
by rw [←linear_equiv.coe_to_linear_map, rtensor_hom_equiv_hom_rtensor_to_linear_map]

variables (R M N P Q)

/--
When `M` and `N` are free `R` modules, the map `hom_tensor_hom_map` is an equivalence. Note that
`hom_tensor_hom_equiv` is not defined directly in terms of `hom_tensor_hom_map`, but the equivalence
between the two is given by `hom_tensor_hom_equiv_to_linear_map` and `hom_tensor_hom_equiv_apply`.
-/
noncomputable
def hom_tensor_hom_equiv : (M →ₗ[R] P) ⊗[R] (N →ₗ[R] Q) ≃ₗ[R] (M ⊗[R] N →ₗ[R] P ⊗[R] Q) :=
rtensor_hom_equiv_hom_rtensor R M P _ ≪≫ₗ
  (linear_equiv.refl R M).arrow_congr (ltensor_hom_equiv_hom_ltensor R N _ Q) ≪≫ₗ
  lift.equiv R M N _

@[simp]
lemma hom_tensor_hom_equiv_to_linear_map :
  (hom_tensor_hom_equiv R M N P Q).to_linear_map = hom_tensor_hom_map R M N P Q :=
begin
  ext f g m n,
  simp only [hom_tensor_hom_equiv, compr₂_apply, mk_apply, linear_equiv.coe_to_linear_map,
  linear_equiv.trans_apply, lift.equiv_apply, linear_equiv.arrow_congr_apply,
  linear_equiv.refl_symm, linear_equiv.refl_apply, rtensor_hom_equiv_hom_rtensor_apply,
  ltensor_hom_equiv_hom_ltensor_apply, ltensor_hom_to_hom_ltensor_apply,
  rtensor_hom_to_hom_rtensor_apply, hom_tensor_hom_map_apply, map_tmul],
end

variables {R M N P Q}

@[simp]
lemma hom_tensor_hom_equiv_apply (x : (M →ₗ[R] P) ⊗[R] (N →ₗ[R] Q)) :
  hom_tensor_hom_equiv R M N P Q x = hom_tensor_hom_map R M N P Q x :=
by rw [←linear_equiv.coe_to_linear_map, hom_tensor_hom_equiv_to_linear_map]

end comm_ring

end hom_tensor_hom