/-
Copyright (c) 2021 Aaron Anderson, Jesse Michael Han, Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson, Jesse Michael Han, Floris van Doorn
-/
import data.nat.basic
import data.set_like.basic
import data.set.lattice
import data.fin.tuple.basic
import data.fintype.basic
import order.closure

/-!
# Basics on First-Order Structures
This file defines first-order languages and structures in the style of the
[Flypitch project](https://flypitch.github.io/).

## Main Definitions
* A `first_order.language` defines a language as a pair of functions from the natural numbers to
  `Type l`. One sends `n` to the type of `n`-ary functions, and the other sends `n` to the type of
  `n`-ary relations.
* A `first_order.language.Structure` interprets the symbols of a given `first_order.language` in the
  context of a given type.
* A `first_order.language.hom`, denoted `M →[L] N`, is a map from the `L`-structure `M` to the
  `L`-structure `N` that commutes with the interpretations of functions, and which preserves the
  interpretations of relations (although only in the forward direction).
* A `first_order.language.embedding`, denoted `M ↪[L] N`, is an embedding from the `L`-structure `M`
  to the `L`-structure `N` that commutes with the interpretations of functions, and which preserves
  the interpretations of relations in both directions.
* A `first_order.language.elementary_embedding`, denoted `M ↪ₑ[L] N`, is an embedding from the
  `L`-structure `M` to the `L`-structure `N` that commutes with the realizations of all formulas.
* A `first_order.language.equiv`, denoted `M ≃[L] N`, is an equivalence from the `L`-structure `M`
  to the `L`-structure `N` that commutes with the interpretations of functions, and which preserves
  the interpretations of relations in both directions.
* A `first_order.language.term` is defined so that `L.term α` is the type of `L`-terms with free
  variables indexed by `α`.
* A `first_order.language.formula` is defined so that `L.formula α` is the type of `L`-formulas with
  free variables indexed by `α`.
* A `first_order.language.sentence` is a formula with no free variables.
* A `first_order.language.theory` is a set of sentences.
* A `first_order.language.definable_set` is defined so that `L.definable_set M α` is the boolean
  algebra of subsets of `α → M` defined by formulas.

## References
For the Flypitch project:
- [J. Han, F. van Doorn, *A formal proof of the independence of the continuum hypothesis*]
[flypitch_cpp]
- [J. Han, F. van Doorn, *A formalization of forcing and the unprovability of
the continuum hypothesis*][flypitch_itp]

-/
universes u v

namespace first_order

/-- A first-order language consists of a type of functions of every natural-number arity and a
  type of relations of every natural-number arity. -/
@[nolint check_univs] -- intended to be used with explicit universe parameters
structure language :=
(functions : ℕ → Type u) (relations : ℕ → Type v)

namespace language

/-- The empty language has no symbols. -/
def empty : language := ⟨λ _, pempty, λ _, pempty⟩

instance : inhabited language := ⟨empty⟩

/-- The type of constants in a given language. -/
@[nolint has_inhabited_instance] def const (L : language) := L.functions 0

variable (L : language.{u v})

/-- A language is relational when it has no function symbols. -/
class is_relational : Prop :=
(empty_functions : ∀ n, L.functions n → false)

/-- A language is algebraic when it has no relation symbols. -/
class is_algebraic : Prop :=
(empty_relations : ∀ n, L.relations n → false)

variable {L}

instance is_relational_of_empty_functions {symb : ℕ → Type*} : is_relational ⟨λ _, pempty, symb⟩ :=
⟨by { intro n, apply pempty.elim }⟩

instance is_algebraic_of_empty_relations {symb : ℕ → Type*}  : is_algebraic ⟨symb, λ _, pempty⟩ :=
⟨by { intro n, apply pempty.elim }⟩

instance is_relational_empty : is_relational (empty) := language.is_relational_of_empty_functions
instance is_algebraic_empty : is_algebraic (empty) := language.is_algebraic_of_empty_relations

variables (L) (M : Type*)

/-- A first-order structure on a type `M` consists of interpretations of all the symbols in a given
  language. Each function of arity `n` is interpreted as a function sending tuples of length `n`
  (modeled as `(fin n → M)`) to `M`, and a relation of arity `n` is a function from tuples of length
  `n` to `Prop`. -/
class Structure :=
(fun_map : ∀{n}, L.functions n → (fin n → M) → M)
(rel_map : ∀{n}, L.relations n → (fin n → M) → Prop)

variables (N : Type*) [L.Structure M] [L.Structure N]

open first_order.language.Structure

/-- A homomorphism between first-order structures is a function that commutes with the
  interpretations of functions and maps tuples in one structure where a given relation is true to
  tuples in the second structure where that relation is still true. -/
structure hom :=
(to_fun : M → N)
(map_fun' : ∀{n} (f : L.functions n) x, to_fun (fun_map f x) = fun_map f (to_fun ∘ x) . obviously)
(map_rel' : ∀{n} (r : L.relations n) x, rel_map r x → rel_map r (to_fun ∘ x) . obviously)

localized "notation A ` →[`:25 L `] ` B := L.hom A B" in first_order

/-- An embedding of first-order structures is an embedding that commutes with the
  interpretations of functions and relations. -/
structure embedding extends M ↪ N :=
(map_fun' : ∀{n} (f : L.functions n) x, to_fun (fun_map f x) = fun_map f (to_fun ∘ x) . obviously)
(map_rel' : ∀{n} (r : L.relations n) x, rel_map r (to_fun ∘ x) ↔ rel_map r x . obviously)

localized "notation A ` ↪[`:25 L `] ` B := L.embedding A B" in first_order

/-- An equivalence of first-order structures is an equivalence that commutes with the
  interpretations of functions and relations. -/
structure equiv extends M ≃ N :=
(map_fun' : ∀{n} (f : L.functions n) x, to_fun (fun_map f x) = fun_map f (to_fun ∘ x) . obviously)
(map_rel' : ∀{n} (r : L.relations n) x, rel_map r (to_fun ∘ x) ↔ rel_map r x . obviously)

localized "notation A ` ≃[`:25 L `] ` B := L.equiv A B" in first_order

variables {L M N} {P : Type*} [L.Structure P] {Q : Type*} [L.Structure Q]

instance : has_coe_t L.const M :=
⟨λ c, fun_map c fin.elim0⟩

lemma fun_map_eq_coe_const {c : L.const} {x : fin 0 → M} :
  fun_map c x = c := congr rfl (funext fin.elim0)

namespace hom

instance has_coe_to_fun : has_coe_to_fun (M →[L] N) (λ _, M → N) := ⟨to_fun⟩

@[simp] lemma to_fun_eq_coe {f : M →[L] N} : f.to_fun = (f : M → N) := rfl

lemma coe_injective : @function.injective (M →[L] N) (M → N) coe_fn
| f g h := by {cases f, cases g, cases h, refl}

@[ext]
lemma ext ⦃f g : M →[L] N⦄ (h : ∀ x, f x = g x) : f = g :=
coe_injective (funext h)

lemma ext_iff {f g : M →[L] N} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

@[simp] lemma map_fun (φ : M →[L] N) {n : ℕ} (f : L.functions n) (x : fin n → M) :
  φ (fun_map f x) = fun_map f (φ ∘ x) := φ.map_fun' f x

@[simp] lemma map_const (φ : M →[L] N) (c : L.const) : φ c = c :=
(φ.map_fun c fin.elim0).trans (congr rfl (funext fin.elim0))

@[simp] lemma map_rel (φ : M →[L] N) {n : ℕ} (r : L.relations n) (x : fin n → M) :
  rel_map r x → rel_map r (φ ∘ x) := φ.map_rel' r x

variables (L) (M)
/-- The identity map from a structure to itself -/
@[refl] def id : M →[L] M :=
{ to_fun := id }

variables {L} {M}

instance : inhabited (M →[L] M) := ⟨id L M⟩

@[simp] lemma id_apply (x : M) :
  id L M x = x := rfl

/-- Composition of first-order homomorphisms -/
@[trans] def comp (hnp : N →[L] P) (hmn : M →[L] N) : M →[L] P :=
{ to_fun := hnp ∘ hmn,
  map_rel' := λ _ _ _ h, by simp [h] }

@[simp] lemma comp_apply (g : N →[L] P) (f : M →[L] N) (x : M) :
  g.comp f x = g (f x) := rfl

/-- Composition of first-order homomorphisms is associative. -/
lemma comp_assoc (f : M →[L] N) (g : N →[L] P) (h : P →[L] Q) :
  (h.comp g).comp f = h.comp (g.comp f) := rfl

end hom

namespace embedding

instance has_coe_to_fun : has_coe_to_fun (M ↪[L] N) (λ _, M → N) := ⟨λ f, f.to_fun⟩

@[simp] lemma map_fun (φ : M ↪[L] N) {n : ℕ} (f : L.functions n) (x : fin n → M) :
  φ (fun_map f x) = fun_map f (φ ∘ x) := φ.map_fun' f x

@[simp] lemma map_const (φ : M ↪[L] N) (c : L.const) : φ c = c :=
(φ.map_fun c fin.elim0).trans (congr rfl (funext fin.elim0))

@[simp] lemma map_rel (φ : M ↪[L] N) {n : ℕ} (r : L.relations n) (x : fin n → M) :
  rel_map r (φ ∘ x) ↔ rel_map r x := φ.map_rel' r x

/-- A first-order embedding is also a first-order homomorphism. -/
def to_hom (f : M ↪[L] N) : M →[L] N :=
{ to_fun := f }

@[simp]
lemma coe_to_hom {f : M ↪[L] N} : (f.to_hom : M → N) = f := rfl

lemma coe_injective : @function.injective (M ↪[L] N) (M → N) coe_fn
| f g h :=
begin
  cases f,
  cases g,
  simp only,
  ext x,
  exact function.funext_iff.1 h x,
end

@[ext]
lemma ext ⦃f g : M ↪[L] N⦄ (h : ∀ x, f x = g x) : f = g :=
coe_injective (funext h)

lemma ext_iff {f g : M ↪[L] N} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

lemma injective (f : M ↪[L] N) : function.injective f := f.to_embedding.injective

/-- In an algebraic language, any injective homomorphism is an embedding. -/
@[simps] def of_injective [L.is_algebraic] {f : M →[L] N} (hf : function.injective f) : M ↪[L] N :=
{ inj' := hf,
  map_rel' := λ n r, (is_algebraic.empty_relations n r).elim,
  .. f }

@[simp] lemma coe_fn_of_injective [L.is_algebraic] {f : M →[L] N} (hf : function.injective f) :
  (of_injective hf : M → N) = f := rfl

@[simp] lemma of_injective_to_hom [L.is_algebraic] {f : M →[L] N} (hf : function.injective f) :
  (of_injective hf).to_hom = f :=
by { ext, simp }

variables (L) (M)
/-- The identity embedding from a structure to itself -/
@[refl] def refl : M ↪[L] M :=
{ to_embedding := function.embedding.refl M }

variables {L} {M}

instance : inhabited (M ↪[L] M) := ⟨refl L M⟩

@[simp] lemma refl_apply (x : M) :
  refl L M x = x := rfl

/-- Composition of first-order embeddings -/
@[trans] def comp (hnp : N ↪[L] P) (hmn : M ↪[L] N) : M ↪[L] P :=
{ to_fun := hnp ∘ hmn,
  inj' := hnp.injective.comp hmn.injective }

@[simp] lemma comp_apply (g : N ↪[L] P) (f : M ↪[L] N) (x : M) :
  g.comp f x = g (f x) := rfl

/-- Composition of first-order embeddings is associative. -/
lemma comp_assoc (f : M ↪[L] N) (g : N ↪[L] P) (h : P ↪[L] Q) :
  (h.comp g).comp f = h.comp (g.comp f) := rfl

end embedding

namespace equiv

/-- The inverse of a first-order equivalence is a first-order equivalence. -/
@[symm] def symm (f : M ≃[L] N) : N ≃[L] M :=
{ map_fun' := λ n f' x, begin
    simp only [equiv.to_fun_as_coe],
    rw [equiv.symm_apply_eq],
    refine eq.trans _ (f.map_fun' f' (f.to_equiv.symm ∘ x)).symm,
    rw [← function.comp.assoc, equiv.to_fun_as_coe, equiv.self_comp_symm, function.comp.left_id]
  end,
  map_rel' := λ n r x, begin
    simp only [equiv.to_fun_as_coe],
    refine (f.map_rel' r (f.to_equiv.symm ∘ x)).symm.trans _,
    rw [← function.comp.assoc, equiv.to_fun_as_coe, equiv.self_comp_symm, function.comp.left_id]
  end,
  .. f.to_equiv.symm }

instance has_coe_to_fun : has_coe_to_fun (M ≃[L] N) (λ _, M → N) := ⟨λ f, f.to_fun⟩

@[simp]
lemma apply_symm_apply (f : M ≃[L] N) (a : N) : f (f.symm a) = a := f.to_equiv.apply_symm_apply a

@[simp]
lemma symm_apply_apply (f : M ≃[L] N) (a : M) : f.symm (f a) = a := f.to_equiv.symm_apply_apply a

@[simp] lemma map_fun (φ : M ≃[L] N) {n : ℕ} (f : L.functions n) (x : fin n → M) :
  φ (fun_map f x) = fun_map f (φ ∘ x) := φ.map_fun' f x

@[simp] lemma map_const (φ : M ≃[L] N) (c : L.const) : φ c = c :=
(φ.map_fun c fin.elim0).trans (congr rfl (funext fin.elim0))

@[simp] lemma map_rel (φ : M ≃[L] N) {n : ℕ} (r : L.relations n) (x : fin n → M) :
  rel_map r (φ ∘ x) ↔ rel_map r x := φ.map_rel' r x

/-- A first-order equivalence is also a first-order embedding. -/
def to_embedding (f : M ≃[L] N) : M ↪[L] N :=
{ to_fun := f,
  inj' := f.to_equiv.injective }

/-- A first-order equivalence is also a first-order homomorphism. -/
def to_hom (f : M ≃[L] N) : M →[L] N :=
{ to_fun := f }

@[simp] lemma to_embedding_to_hom (f : M ≃[L] N) : f.to_embedding.to_hom = f.to_hom := rfl

@[simp]
lemma coe_to_hom {f : M ≃[L] N} : (f.to_hom : M → N) = (f : M → N) := rfl

@[simp] lemma coe_to_embedding (f : M ≃[L] N) : (f.to_embedding : M → N) = (f : M → N) := rfl

lemma coe_injective : @function.injective (M ≃[L] N) (M → N) coe_fn
| f g h :=
begin
  cases f,
  cases g,
  simp only,
  ext x,
  exact function.funext_iff.1 h x,
end

@[ext]
lemma ext ⦃f g : M ≃[L] N⦄ (h : ∀ x, f x = g x) : f = g :=
coe_injective (funext h)

lemma ext_iff {f g : M ≃[L] N} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

lemma injective (f : M ≃[L] N) : function.injective f := f.to_embedding.injective

variables (L) (M)
/-- The identity equivalence from a structure to itself -/
@[refl] def refl : M ≃[L] M :=
{ to_equiv := equiv.refl M }

variables {L} {M}

instance : inhabited (M ≃[L] M) := ⟨refl L M⟩

@[simp] lemma refl_apply (x : M) :
  refl L M x = x := rfl

/-- Composition of first-order equivalences -/
@[trans] def comp (hnp : N ≃[L] P) (hmn : M ≃[L] N) : M ≃[L] P :=
{ to_fun := hnp ∘ hmn,
  .. (hmn.to_equiv.trans hnp.to_equiv) }

@[simp] lemma comp_apply (g : N ≃[L] P) (f : M ≃[L] N) (x : M) :
  g.comp f x = g (f x) := rfl

/-- Composition of first-order homomorphisms is associative. -/
lemma comp_assoc (f : M ≃[L] N) (g : N ≃[L] P) (h : P ≃[L] Q) :
  (h.comp g).comp f = h.comp (g.comp f) := rfl

end equiv

section closed_under

open set

variables {n : ℕ} (f : L.functions n) (s : set M)

/-- Indicates that a set in a given structure is a closed under a function symbol. -/
def closed_under : Prop :=
∀ (x : fin n → M), (∀ i : fin n, x i ∈ s) → fun_map f x ∈ s

variable (L)

@[simp] lemma closed_under_univ : closed_under f (univ : set M) :=
λ _ _, mem_univ _

variables {L f s} {t : set M}

namespace closed_under

lemma inter (hs : closed_under f s) (ht : closed_under f t) :
  closed_under f (s ∩ t) :=
λ x h, mem_inter (hs x (λ i, mem_of_mem_inter_left (h i)))
  (ht x (λ i, mem_of_mem_inter_right (h i)))

lemma inf (hs : closed_under f s) (ht : closed_under f t) :
  closed_under f (s ⊓ t) := hs.inter ht

variables {S : set (set M)}

lemma Inf (hS : ∀ s, s ∈ S → closed_under f s) : closed_under f (Inf S) :=
λ x h s hs, hS s hs x (λ i, h i s hs)

end closed_under
end closed_under

variables (L) (M)

/-- A substructure of a structure `M` is a set closed under application of function symbols. -/
structure substructure :=
(carrier : set M)
(fun_mem : ∀{n}, ∀ (f : L.functions n), closed_under f carrier)

variables {L} {M}

namespace substructure

instance : set_like (L.substructure M) M :=
⟨substructure.carrier, λ p q h, by cases p; cases q; congr'⟩

/-- See Note [custom simps projection] -/
def simps.coe (S : L.substructure M) : set M := S
initialize_simps_projections substructure (carrier → coe)

@[simp]
lemma mem_carrier {s : L.substructure M} {x : M} : x ∈ s.carrier ↔ x ∈ s := iff.rfl

/-- Two substructures are equal if they have the same elements. -/
@[ext]
theorem ext {S T : L.substructure M}
  (h : ∀ x, x ∈ S ↔ x ∈ T) : S = T := set_like.ext h

/-- Copy a substructure replacing `carrier` with a set that is equal to it. -/
protected def copy (S : L.substructure M) (s : set M) (hs : s = S) : L.substructure M :=
{ carrier := s,
  fun_mem := λ n f, hs.symm ▸ (S.fun_mem f) }

variable {S : L.substructure M}

@[simp] lemma coe_copy {s : set M} (hs : s = S) :
  (S.copy s hs : set M) = s := rfl

lemma copy_eq {s : set M} (hs : s = S) : S.copy s hs = S :=
set_like.coe_injective hs

lemma const_mem {c : L.const} : ↑c ∈ S :=
mem_carrier.2 (S.fun_mem c _ fin.elim0)

/-- The substructure `M` of the structure `M`. -/
instance : has_top (L.substructure M) :=
⟨{ carrier := set.univ,
   fun_mem := λ n f x h, set.mem_univ _ }⟩

instance : inhabited (L.substructure M) := ⟨⊤⟩

@[simp] lemma mem_top (x : M) : x ∈ (⊤ : L.substructure M) := set.mem_univ x

@[simp] lemma coe_top : ((⊤ : L.substructure M) : set M) = set.univ := rfl

/-- The inf of two substructures is their intersection. -/
instance : has_inf (L.substructure M) :=
⟨λ S₁ S₂,
  { carrier := S₁ ∩ S₂,
    fun_mem := λ n f, (S₁.fun_mem f).inf (S₂.fun_mem f) }⟩

@[simp]
lemma coe_inf (p p' : L.substructure M) : ((p ⊓ p' : L.substructure M) : set M) = p ∩ p' := rfl

@[simp]
lemma mem_inf {p p' : L.substructure M} {x : M} : x ∈ p ⊓ p' ↔ x ∈ p ∧ x ∈ p' := iff.rfl

instance : has_Inf (L.substructure M) :=
⟨λ s, { carrier := ⋂ t ∈ s, ↑t,
        fun_mem := λ n f, closed_under.Inf begin
          rintro _ ⟨t, rfl⟩,
          by_cases h : t ∈ s,
          { simpa [h] using t.fun_mem f },
          { simp [h] }
        end }⟩

@[simp, norm_cast]
lemma coe_Inf (S : set (L.substructure M)) :
  ((Inf S : L.substructure M) : set M) = ⋂ s ∈ S, ↑s := rfl

lemma mem_Inf {S : set (L.substructure M)} {x : M} : x ∈ Inf S ↔ ∀ p ∈ S, x ∈ p := set.mem_Inter₂

lemma mem_infi {ι : Sort*} {S : ι → L.substructure M} {x : M} : (x ∈ ⨅ i, S i) ↔ ∀ i, x ∈ S i :=
by simp only [infi, mem_Inf, set.forall_range_iff]

@[simp, norm_cast]
lemma coe_infi {ι : Sort*} {S : ι → L.substructure M} : (↑(⨅ i, S i) : set M) = ⋂ i, S i :=
by simp only [infi, coe_Inf, set.bInter_range]

/-- Substructures of a structure form a complete lattice. -/
instance : complete_lattice (L.substructure M) :=
{ le           := (≤),
  lt           := (<),
  top          := (⊤),
  le_top       := λ S x hx, mem_top x,
  inf          := (⊓),
  Inf          := has_Inf.Inf,
  le_inf       := λ a b c ha hb x hx, ⟨ha hx, hb hx⟩,
  inf_le_left  := λ a b x, and.left,
  inf_le_right := λ a b x, and.right,
  .. complete_lattice_of_Inf (L.substructure M) $ λ s,
    is_glb.of_image (λ S T,
      show (S : set M) ≤ T ↔ S ≤ T, from set_like.coe_subset_coe) is_glb_binfi }

variable (L)

/-- The `L.substructure` generated by a set. -/
def closure : lower_adjoint (coe : L.substructure M → set M) := ⟨λ s, Inf {S | s ⊆ S},
  λ s S, ⟨set.subset.trans (λ x hx, mem_Inf.2 $ λ S hS, hS hx), λ h, Inf_le h⟩⟩

variables {L} {s : set M}

lemma mem_closure {x : M} : x ∈ closure L s ↔ ∀ S : L.substructure M, s ⊆ S → x ∈ S :=
mem_Inf

/-- The substructure generated by a set includes the set. -/
@[simp]
lemma subset_closure : s ⊆ closure L s := (closure L).le_closure s

lemma not_mem_of_not_mem_closure {P : M} (hP : P ∉ closure L s) : P ∉ s :=
λ h, hP (subset_closure h)

@[simp]
lemma closed (S : L.substructure M) : (closure L).closed (S : set M) :=
congr rfl ((closure L).eq_of_le set.subset.rfl (λ x xS, mem_closure.2 (λ T hT, hT xS)))

open set

/-- A substructure `S` includes `closure L s` if and only if it includes `s`. -/
@[simp]
lemma closure_le : closure L s ≤ S ↔ s ⊆ S := (closure L).closure_le_closed_iff_le s S.closed

/-- Substructure closure of a set is monotone in its argument: if `s ⊆ t`,
then `closure L s ≤ closure L t`. -/
lemma closure_mono ⦃s t : set M⦄ (h : s ⊆ t) : closure L s ≤ closure L t :=
(closure L).monotone h

lemma closure_eq_of_le (h₁ : s ⊆ S) (h₂ : S ≤ closure L s) : closure L s = S :=
(closure L).eq_of_le h₁ h₂

variable (S)

/-- An induction principle for closure membership. If `p` holds for all elements of `s`, and
is preserved under function symbols, then `p` holds for all elements of the closure of `s`. -/
@[elab_as_eliminator] lemma closure_induction {p : M → Prop} {x} (h : x ∈ closure L s)
  (Hs : ∀ x ∈ s, p x)
  (Hfun : ∀ {n : ℕ} (f : L.functions n), closed_under f (set_of p)) : p x :=
(@closure_le L M _ ⟨set_of p, λ n, Hfun⟩ _).2 Hs h

/-- If `s` is a dense set in a structure `M`, `substructure.closure L s = ⊤`, then in order to prove
that some predicate `p` holds for all `x : M` it suffices to verify `p x` for `x ∈ s`, and verify
that `p` is preserved under function symbols. -/
@[elab_as_eliminator] lemma dense_induction {p : M → Prop} (x : M) {s : set M}
  (hs : closure L s = ⊤) (Hs : ∀ x ∈ s, p x)
  (Hfun : ∀ {n : ℕ} (f : L.functions n), closed_under f (set_of p)) : p x :=
have ∀ x ∈ closure L s, p x, from λ x hx, closure_induction hx Hs (λ n, Hfun),
by simpa [hs] using this x

variables (L) (M)

/-- `closure` forms a Galois insertion with the coercion to set. -/
protected def gi : galois_insertion (@closure L M _) coe :=
{ choice := λ s _, closure L s,
  gc := (closure L).gc,
  le_l_u := λ s, subset_closure,
  choice_eq := λ s h, rfl }

variables {L} {M}

/-- Closure of a substructure `S` equals `S`. -/
@[simp] lemma closure_eq : closure L (S : set M) = S := (substructure.gi L M).l_u_eq S

@[simp] lemma closure_empty : closure L (∅ : set M) = ⊥ :=
(substructure.gi L M).gc.l_bot

@[simp] lemma closure_univ : closure L (univ : set M) = ⊤ :=
@coe_top L M _ ▸ closure_eq ⊤

lemma closure_union (s t : set M) : closure L (s ∪ t) = closure L s ⊔ closure L t :=
(substructure.gi L M).gc.l_sup

lemma closure_Union {ι} (s : ι → set M) : closure L (⋃ i, s i) = ⨆ i, closure L (s i) :=
(substructure.gi L M).gc.l_supr

/-!
### `comap` and `map`
-/

/-- The preimage of a substructure along a homomorphism is a substructure. -/
@[simps] def comap (φ : M →[L] N) (S : L.substructure N) : L.substructure M :=
{ carrier := (φ ⁻¹' S),
  fun_mem := λ n f x hx, begin
    rw [mem_preimage, φ.map_fun],
    exact S.fun_mem f (φ ∘ x) hx,
  end }

@[simp]
lemma mem_comap {S : L.substructure N} {f : M →[L] N} {x : M} : x ∈ S.comap f ↔ f x ∈ S := iff.rfl

lemma comap_comap (S : L.substructure P) (g : N →[L] P) (f : M →[L] N) :
  (S.comap g).comap f = S.comap (g.comp f) :=
rfl

@[simp]
lemma comap_id (S : L.substructure P) : S.comap (hom.id _ _) = S :=
ext (by simp)

/-- The image of a substructure along a homomorphism is a substructure. -/
@[simps] def map (φ : M →[L] N) (S : L.substructure M) : L.substructure N :=
{ carrier := (φ '' S),
  fun_mem := λ n f x hx, (mem_image _ _ _).1
    ⟨fun_map f (λ i, classical.some (hx i)),
     S.fun_mem f _ (λ i, (classical.some_spec (hx i)).1),
     begin
       simp only [hom.map_fun, set_like.mem_coe],
       exact congr rfl (funext (λ i, (classical.some_spec (hx i)).2)),
     end⟩ }

@[simp]
lemma mem_map {f : M →[L] N} {S : L.substructure M} {y : N} :
  y ∈ S.map f ↔ ∃ x ∈ S, f x = y :=
mem_image_iff_bex

lemma mem_map_of_mem (f : M →[L] N) {S : L.substructure M} {x : M} (hx : x ∈ S) : f x ∈ S.map f :=
mem_image_of_mem f hx

lemma apply_coe_mem_map (f : M →[L] N) (S : L.substructure M) (x : S) : f x ∈ S.map f :=
mem_map_of_mem f x.prop

lemma map_map (g : N →[L] P) (f : M →[L] N) : (S.map f).map g = S.map (g.comp f) :=
set_like.coe_injective $ image_image _ _ _

lemma map_le_iff_le_comap {f : M →[L] N} {S : L.substructure M} {T : L.substructure N} :
  S.map f ≤ T ↔ S ≤ T.comap f :=
image_subset_iff

lemma gc_map_comap (f : M →[L] N) : galois_connection (map f) (comap f) :=
λ S T, map_le_iff_le_comap

lemma map_le_of_le_comap {T : L.substructure N} {f : M →[L] N} : S ≤ T.comap f → S.map f ≤ T :=
(gc_map_comap f).l_le

lemma le_comap_of_map_le {T : L.substructure N} {f : M →[L] N} : S.map f ≤ T → S ≤ T.comap f :=
(gc_map_comap f).le_u

lemma le_comap_map {f : M →[L] N} : S ≤ (S.map f).comap f :=
(gc_map_comap f).le_u_l _

lemma map_comap_le {S : L.substructure N} {f : M →[L] N} : (S.comap f).map f ≤ S :=
(gc_map_comap f).l_u_le _

lemma monotone_map {f : M →[L] N} : monotone (map f) :=
(gc_map_comap f).monotone_l

lemma monotone_comap {f : M →[L] N} : monotone (comap f) :=
(gc_map_comap f).monotone_u

@[simp]
lemma map_comap_map {f : M →[L] N} : ((S.map f).comap f).map f = S.map f :=
(gc_map_comap f).l_u_l_eq_l _

@[simp]
lemma comap_map_comap {S : L.substructure N} {f : M →[L] N} :
  ((S.comap f).map f).comap f = S.comap f :=
(gc_map_comap f).u_l_u_eq_u _

lemma map_sup (S T : L.substructure M) (f : M →[L] N) : (S ⊔ T).map f = S.map f ⊔ T.map f :=
(gc_map_comap f).l_sup

lemma map_supr {ι : Sort*} (f : M →[L] N) (s : ι → L.substructure M) :
  (supr s).map f = ⨆ i, (s i).map f :=
(gc_map_comap f).l_supr

lemma comap_inf (S T : L.substructure N) (f : M →[L] N) : (S ⊓ T).comap f = S.comap f ⊓ T.comap f :=
(gc_map_comap f).u_inf

lemma comap_infi {ι : Sort*} (f : M →[L] N) (s : ι → L.substructure N) :
  (infi s).comap f = ⨅ i, (s i).comap f :=
(gc_map_comap f).u_infi

@[simp] lemma map_bot (f : M →[L] N) : (⊥ : L.substructure M).map f = ⊥ :=
(gc_map_comap f).l_bot

@[simp] lemma comap_top (f : M →[L] N) : (⊤ : L.substructure N).comap f = ⊤ :=
(gc_map_comap f).u_top

@[simp] lemma map_id (S : L.substructure M) : S.map (hom.id L M) = S :=
ext (λ x, ⟨λ ⟨_, h, rfl⟩, h, λ h, ⟨_, h, rfl⟩⟩)

section galois_coinsertion

variables {ι : Type*} {f : M →[L] N} (hf : function.injective f)

include hf

/-- `map f` and `comap f` form a `galois_coinsertion` when `f` is injective. -/
def gci_map_comap : galois_coinsertion (map f) (comap f) :=
(gc_map_comap f).to_galois_coinsertion
  (λ S x, by simp [mem_comap, mem_map, hf.eq_iff])

lemma comap_map_eq_of_injective (S : L.substructure M) : (S.map f).comap f = S :=
(gci_map_comap hf).u_l_eq _

lemma comap_surjective_of_injective : function.surjective (comap f) :=
(gci_map_comap hf).u_surjective

lemma map_injective_of_injective : function.injective (map f) :=
(gci_map_comap hf).l_injective

lemma comap_inf_map_of_injective (S T : L.substructure M) : (S.map f ⊓ T.map f).comap f = S ⊓ T :=
(gci_map_comap hf).u_inf_l _ _

lemma comap_infi_map_of_injective (S : ι → L.substructure M) :
  (⨅ i, (S i).map f).comap f = infi S :=
(gci_map_comap hf).u_infi_l _

lemma comap_sup_map_of_injective (S T : L.substructure M) : (S.map f ⊔ T.map f).comap f = S ⊔ T :=
(gci_map_comap hf).u_sup_l _ _

lemma comap_supr_map_of_injective (S : ι → L.substructure M) :
  (⨆ i, (S i).map f).comap f = supr S :=
(gci_map_comap hf).u_supr_l _

lemma map_le_map_iff_of_injective {S T : L.substructure M} : S.map f ≤ T.map f ↔ S ≤ T :=
(gci_map_comap hf).l_le_l_iff

lemma map_strict_mono_of_injective : strict_mono (map f) :=
(gci_map_comap hf).strict_mono_l

end galois_coinsertion

section galois_insertion

variables {ι : Type*} {f : M →[L] N} (hf : function.surjective f)

include hf

/-- `map f` and `comap f` form a `galois_insertion` when `f` is surjective. -/
def gi_map_comap : galois_insertion (map f) (comap f) :=
(gc_map_comap f).to_galois_insertion
  (λ S x h, let ⟨y, hy⟩ := hf x in mem_map.2 ⟨y, by simp [hy, h]⟩)

lemma map_comap_eq_of_surjective (S : L.substructure N) : (S.comap f).map f = S :=
(gi_map_comap hf).l_u_eq _

lemma map_surjective_of_surjective : function.surjective (map f) :=
(gi_map_comap hf).l_surjective

lemma comap_injective_of_surjective : function.injective (comap f) :=
(gi_map_comap hf).u_injective

lemma map_inf_comap_of_surjective (S T : L.substructure N) :
  (S.comap f ⊓ T.comap f).map f = S ⊓ T :=
(gi_map_comap hf).l_inf_u _ _

lemma map_infi_comap_of_surjective (S : ι → L.substructure N) :
  (⨅ i, (S i).comap f).map f = infi S :=
(gi_map_comap hf).l_infi_u _

lemma map_sup_comap_of_surjective (S T : L.substructure N) :
  (S.comap f ⊔ T.comap f).map f = S ⊔ T :=
(gi_map_comap hf).l_sup_u _ _

lemma map_supr_comap_of_surjective (S : ι → L.substructure N) :
  (⨆ i, (S i).comap f).map f = supr S :=
(gi_map_comap hf).l_supr_u _

lemma comap_le_comap_iff_of_surjective {S T : L.substructure N} :
  S.comap f ≤ T.comap f ↔ S ≤ T :=
(gi_map_comap hf).u_le_u_iff

lemma comap_strict_mono_of_surjective : strict_mono (comap f) :=
(gi_map_comap hf).strict_mono_u

end galois_insertion

instance induced_Structure {S : L.substructure M} : L.Structure S :=
{ fun_map := λ n f x, ⟨fun_map f (λ i, x i), S.fun_mem f (λ i, x i) (λ i, (x i).2)⟩,
  rel_map := λ n r x, rel_map r (λ i, (x i : M)) }

/-- The natural embedding of an `L.substructure` of `M` into `M`. -/
def subtype (S : L.substructure M) : S ↪[L] M :=
{ to_fun := coe,
  inj' := subtype.coe_injective }

@[simp] theorem coe_subtype : ⇑S.subtype = coe := rfl

/-- The equivalence between the maximal substructure of a structure and the structure itself. -/
def top_equiv : (⊤ : L.substructure M) ≃[L] M  :=
{ to_fun := subtype ⊤,
  inv_fun := λ m, ⟨m, mem_top m⟩,
  left_inv := λ m, by simp,
  right_inv := λ m, rfl }

@[simp] lemma coe_top_equiv : ⇑(top_equiv : (⊤ : L.substructure M) ≃[L] M) = coe := rfl

/-- A dependent version of `substructure.closure_induction`. -/
@[elab_as_eliminator] lemma closure_induction' (s : set M) {p : Π x, x ∈ closure L s → Prop}
  (Hs : ∀ x (h : x ∈ s), p x (subset_closure h))
  (Hfun : ∀ {n : ℕ} (f : L.functions n), closed_under f {x | ∃ hx, p x hx})
  {x} (hx : x ∈ closure L s) :
  p x hx :=
begin
  refine exists.elim _ (λ (hx : x ∈ closure L s) (hc : p x hx), hc),
  exact closure_induction hx (λ x hx, ⟨subset_closure hx, Hs x hx⟩) @Hfun
end

end substructure

namespace hom

open substructure

/-- The substructure of elements `x : M` such that `f x = g x` -/
def eq_locus (f g : M →[L] N) : substructure L M :=
{ carrier := {x : M | f x = g x},
  fun_mem := λ n fn x hx, by
  { have h : f ∘ x = g ∘ x := by { ext, repeat {rw function.comp_apply}, apply hx, },
    simp [h], } }

/-- If two `L.hom`s are equal on a set, then they are equal on its substructure closure. -/
lemma eq_on_closure {f g : M →[L] N} {s : set M} (h : set.eq_on f g s) :
  set.eq_on f g (closure L s) :=
show closure L s ≤ f.eq_locus g, from closure_le.2 h

lemma eq_of_eq_on_top {f g : M →[L] N} (h : set.eq_on f g (⊤ : substructure L M)) :
  f = g :=
ext $ λ x, h trivial

variable {s : set M}

lemma eq_of_eq_on_dense (hs : closure L s = ⊤) {f g : M →[L] N} (h : s.eq_on f g) :
  f = g :=
eq_of_eq_on_top $ hs ▸ eq_on_closure h

end hom

variable (L)
/-- A term on `α` is either a variable indexed by an element of `α`
  or a function symbol applied to simpler terms. -/
inductive term (α : Type) : Type u
| var {} : ∀ (a : α), term
| func {} : ∀ {l : ℕ} (f : L.functions l) (ts : fin l → term), term
export term

variable {L}

/-- Relabels a term's variables along a particular function. -/
@[simp] def term.relabel {α β : Type} (g : α → β) : L.term α → L.term β
| (var i) := var (g i)
| (func f ts) := func f (λ i, (ts i).relabel)

instance {α : Type} [inhabited α] : inhabited (L.term α) :=
⟨var default⟩

instance {α} : has_coe L.const (L.term α) :=
⟨λ c, func c fin_zero_elim⟩

/-- A term `t` with variables indexed by `α` can be evaluated by giving a value to each variable. -/
@[simp] def realize_term {α : Type} (v : α → M) :
  ∀ (t : L.term α), M
| (var k)         := v k
| (func f ts)     := fun_map f (λ i, realize_term (ts i))

@[simp] lemma realize_term_relabel {α β : Type} (g : α → β) (v : β → M) (t : L.term α) :
  realize_term v (t.relabel g) = realize_term (v ∘ g) t :=
begin
  induction t with _ n f ts ih,
  { refl, },
  { simp [ih] }
end

@[simp] lemma hom.realize_term {α : Type} (v : α → M)
  (t : L.term α) (g : M →[L] N) :
  realize_term (g ∘ v) t = g (realize_term v t) :=
begin
  induction t,
  { refl },
  { rw [realize_term, realize_term, g.map_fun],
    refine congr rfl _,
    ext x,
    simp [t_ih x], },
end

@[simp] lemma embedding.realize_term {α : Type}  (v : α → M)
  (t : L.term α) (g : M ↪[L] N) :
  realize_term (g ∘ v) t = g (realize_term v t) :=
g.to_hom.realize_term v t

@[simp] lemma equiv.realize_term {α : Type}  (v : α → M)
  (t : L.term α) (g : M ≃[L] N) :
  realize_term (g ∘ v) t = g (realize_term v t) :=
g.to_hom.realize_term v t

@[simp] lemma realize_term_substructure {α : Type} {S : L.substructure M} (v : α → S)
  (t : L.term α) :
  realize_term (coe ∘ v) t = (↑(realize_term v t) : M) :=
S.subtype.realize_term v t

variable (L)
/-- `bounded_formula α n` is the type of formulas with free variables indexed by `α` and up to `n`
  additional free variables. -/
inductive bounded_formula (α : Type) : ℕ → Type (max u v)
| bd_falsum {} {n} : bounded_formula n
| bd_equal {n} (t₁ t₂ : L.term (α ⊕ fin n)) : bounded_formula n
| bd_rel {n l : ℕ} (R : L.relations l) (ts : fin l → L.term (α ⊕ fin n)) : bounded_formula n
| bd_imp {n} (f₁ f₂ : bounded_formula n) : bounded_formula n
| bd_all {n} (f : bounded_formula (n+1)) : bounded_formula n

export bounded_formula

instance {α : Type} {n : ℕ} : inhabited (L.bounded_formula α n) :=
⟨bd_falsum⟩

/-- `formula α` is the type of formulas with all free variables indexed by `α`. -/
@[reducible] def formula (α : Type) := L.bounded_formula α 0

/-- A sentence is a formula with no free variables. -/
@[reducible] def sentence           := L.formula pempty

/-- A theory is a set of sentences. -/
@[reducible] def theory := set L.sentence

variables {L} {α : Type}

section formula
variable {n : ℕ}

@[simps] instance : has_bot (L.bounded_formula α n) := ⟨bd_falsum⟩

/-- The negation of a bounded formula is also a bounded formula. -/
@[reducible] def bd_not (φ : L.bounded_formula α n) : L.bounded_formula α n :=
  bd_imp φ ⊥

@[simps] instance : has_top (L.bounded_formula α n) := ⟨bd_not bd_falsum⟩

@[simps] instance : has_inf (L.bounded_formula α n) := ⟨λ f g, bd_not (bd_imp f (bd_not g))⟩

@[simps] instance : has_sup (L.bounded_formula α n) := ⟨λ f g, bd_imp (bd_not f) g⟩

/-- Relabels a bounded formula's variables along a particular function. -/
@[simp] def bounded_formula.relabel {α β : Type} (g : α → β) :
  ∀ {n : ℕ}, L.bounded_formula α n → L.bounded_formula β n
| n bd_falsum := bd_falsum
| n (bd_equal t₁ t₂) := bd_equal (t₁.relabel (sum.elim (sum.inl ∘ g) sum.inr))
    (t₂.relabel (sum.elim (sum.inl ∘ g) sum.inr))
| n (bd_rel R ts) := bd_rel R ((term.relabel (sum.elim (sum.inl ∘ g) sum.inr)) ∘ ts)
| n (bd_imp f₁ f₂) := bd_imp f₁.relabel f₂.relabel
| n (bd_all f) := bd_all f.relabel

namespace formula

/-- The equality of two terms as a first-order formula. -/
def equal (t₁ t₂ : L.term α) : (L.formula α) :=
bd_equal (t₁.relabel sum.inl) (t₂.relabel sum.inl)

/-- The graph of a function as a first-order formula. -/
def graph (f : L.functions n) : L.formula (fin (n + 1)) :=
equal (func f (λ i, var i)) (var n)

end formula
end formula

variable {L}

instance nonempty_bounded_formula {α : Type} (n : ℕ) : nonempty $ L.bounded_formula α n :=
  nonempty.intro (by constructor)

variables (M)

/-- A bounded formula can be evaluated as true or false by giving values to each free variable. -/
@[simp] def realize_bounded_formula :
  ∀ {l} (f : L.bounded_formula α l) (v : α → M) (xs : fin l → M), Prop
| _ bd_falsum  v     xs := false
| _ (bd_equal t₁ t₂) v xs := realize_term (sum.elim v xs) t₁ = realize_term (sum.elim v xs) t₂
| _ (bd_rel R ts)   v   xs := rel_map R (λ i, realize_term (sum.elim v xs) (ts i))
| _ (bd_imp f₁ f₂)  v xs := realize_bounded_formula f₁ v xs → realize_bounded_formula f₂ v xs
| _ (bd_all f)     v   xs := ∀(x : M), realize_bounded_formula f v (fin.cons x xs)

@[simp] lemma realize_not {l} (f : L.bounded_formula α l) (v : α → M) (xs : fin l → M) :
  realize_bounded_formula M (bd_not f) v xs = ¬ realize_bounded_formula M f v xs :=
rfl

/-- A bounded formula can be evaluated as true or false by giving values to each free variable. -/
@[reducible] def realize_formula (f : L.formula α) (v : α → M) : Prop :=
realize_bounded_formula M f v fin_zero_elim

/-- A sentence can be evaluated as true or false in a structure. -/
@[reducible] def realize_sentence (φ : L.sentence) : Prop :=
realize_formula M φ pempty.elim

variable {M}

@[simp] lemma realize_bounded_formula_relabel {α β : Type} {n : ℕ}
  (g : α → β) (v : β → M) (xs : fin n → M) (φ : L.bounded_formula α n) :
  realize_bounded_formula M (φ.relabel g) v xs ↔ realize_bounded_formula M φ (v ∘ g) xs :=
begin
  have h : ∀ (m : ℕ) (xs' : fin m → M), sum.elim v xs' ∘
    sum.elim (sum.inl ∘ g) sum.inr = sum.elim (v ∘ g) xs',
  { intros m xs',
    ext x,
    cases x;
    simp, },
  induction φ with _ _ _ _ _ _ _ _ _ _ _ ih1 ih2 _ _ ih3,
  { refl },
  { simp [h _ xs] },
  { simp [h _ xs] },
  { simp [ih1, ih2] },
  { simp [ih3] }
end

@[simp] lemma equiv.realize_bounded_formula {α : Type} {n : ℕ}  (v : α → M)
  (xs : fin n → M) (φ : L.bounded_formula α n) (g : M ≃[L] N) :
  realize_bounded_formula N φ (g ∘ v) (g ∘ xs) ↔ realize_bounded_formula M φ v xs :=
begin
  induction φ with _ _ _ _ _ _ _ _ _ _ _ ih1 ih2 _ _ ih3,
  { refl },
  { simp only [realize_bounded_formula, ← sum.comp_elim, equiv.realize_term, g.injective.eq_iff] },
  { simp only [realize_bounded_formula, ← sum.comp_elim, equiv.realize_term, g.map_rel], },
  { rw [realize_bounded_formula, ih1, ih2, realize_bounded_formula] },
  { rw [realize_bounded_formula, realize_bounded_formula],
    split,
    { intros h a,
      have h' := h (g a),
      rw [← fin.comp_cons, ih3] at h',
      exact h' },
    { intros h a,
      have h' := h (g.symm a),
      rw [← ih3, fin.comp_cons, g.apply_symm_apply] at h',
      exact h' }}
end

@[simp] lemma realize_bounded_formula_top {α : Type} {n : ℕ} (v : α → (⊤ : L.substructure M))
  (xs : fin n → (⊤ : L.substructure M)) (φ : L.bounded_formula α n) :
  realize_bounded_formula (⊤ : L.substructure M) φ v xs ↔
  realize_bounded_formula M φ (coe ∘ v) (coe ∘ xs) :=
begin
  rw ← substructure.top_equiv.realize_bounded_formula v xs φ,
  simp,
end

@[simp] lemma realize_formula_relabel {α β : Type}
  (g : α → β) (v : β → M) (φ : L.formula α) :
  realize_formula M (φ.relabel g) v ↔ realize_formula M φ (v ∘ g) :=
by rw [realize_formula, realize_formula, realize_bounded_formula_relabel]

@[simp] lemma realize_formula_equiv {α : Type}  (v : α → M) (φ : L.formula α)
  (g : M ≃[L] N) :
  realize_formula N φ (g ∘ v) ↔ realize_formula M φ v :=
begin
  rw [realize_formula, realize_formula, ← equiv.realize_bounded_formula v fin_zero_elim φ g,
    iff_eq_eq],
  exact congr rfl (funext fin_zero_elim),
end

@[simp]
lemma realize_equal {α : Type*} (t₁ t₂ : L.term α) (x : α → M) :
  realize_formula M (formula.equal t₁ t₂) x ↔ realize_term x t₁ = realize_term x t₂ :=
by simp [formula.equal, realize_formula]

@[simp]
lemma realize_graph {l : ℕ} (f : L.functions l) (x : fin l → M) (y : M) :
  realize_formula M (formula.graph f) (fin.snoc x y) ↔ fun_map f x = y :=
begin
  simp only [formula.graph, realize_term, fin.coe_eq_cast_succ, realize_equal, fin.snoc_cast_succ],
  rw [fin.coe_nat_eq_last, fin.snoc_last],
end

section definability

variables (L) [fintype α]

/-- A subset of a finite Cartesian product of a structure is definable when membership in
  the set is given by a first-order formula. -/
structure is_definable (s : set (α → M)) : Prop :=
(exists_formula : ∃ (φ : L.formula α), s = set_of (realize_formula M φ))

variables {L}

@[simp]
lemma is_definable_empty : L.is_definable (∅ : set (α → M)) :=
⟨⟨⊥, by {ext, simp} ⟩⟩

@[simp]
lemma is_definable_univ : L.is_definable (set.univ : set (α → M)) :=
⟨⟨⊤, by {ext, simp} ⟩⟩

@[simp]
lemma is_definable.inter {f g : set (α → M)} (hf : L.is_definable f) (hg : L.is_definable g) :
  L.is_definable (f ∩ g) :=
⟨begin
  rcases hf.exists_formula with ⟨φ, hφ⟩,
  rcases hg.exists_formula with ⟨θ, hθ⟩,
  refine ⟨φ ⊓ θ, _⟩,
  ext,
  simp [hφ, hθ],
end⟩

@[simp]
lemma is_definable.union {f g : set (α → M)} (hf : L.is_definable f) (hg : L.is_definable g) :
  L.is_definable (f ∪ g) :=
⟨begin
  rcases hf.exists_formula with ⟨φ, hφ⟩,
  rcases hg.exists_formula with ⟨θ, hθ⟩,
  refine ⟨φ ⊔ θ, _⟩,
  ext,
  simp only [hφ, hθ, set.sup_eq_union, realize_not, realize_bounded_formula,
    bounded_formula.has_sup_sup, set.mem_union_eq, set.mem_set_of_eq],
  tauto,
end⟩

@[simp]
lemma is_definable.compl {s : set (α → M)} (hf : L.is_definable s) :
  L.is_definable sᶜ :=
⟨begin
  rcases hf.exists_formula with ⟨φ, hφ⟩,
  refine ⟨bd_not φ, _⟩,
  rw hφ,
  refl,
end⟩

@[simp]
lemma is_definable.sdiff {s t : set (α → M)} (hs : L.is_definable s)
  (ht : L.is_definable t) :
  L.is_definable (s \ t) :=
hs.inter ht.compl

variables (L) (M) (α)

/-- Definable sets are subsets of finite Cartesian products of a structure such that membership is
  given by a first-order formula. -/
def definable_set := subtype (λ s : set (α → M), is_definable L s)

namespace definable_set
variables {M} {α}

instance : has_top (L.definable_set M α) := ⟨⟨⊤, is_definable_univ⟩⟩

instance : has_bot (L.definable_set M α) := ⟨⟨⊥, is_definable_empty⟩⟩

instance : inhabited (L.definable_set M α) := ⟨⊥⟩

instance : set_like (L.definable_set M α) (α → M) :=
{ coe := subtype.val,
  coe_injective' := subtype.val_injective }

@[simp]
lemma mem_top {x : α → M} : x ∈ (⊤ : L.definable_set M α) := set.mem_univ x

@[simp]
lemma coe_top : ((⊤ : L.definable_set M α) : set (α → M)) = ⊤ := rfl

@[simp]
lemma not_mem_bot {x : α → M} : ¬ x ∈ (⊥ : L.definable_set M α) := set.not_mem_empty x

@[simp]
lemma coe_bot : ((⊥ : L.definable_set M α) : set (α → M)) = ⊥ := rfl

instance : lattice (L.definable_set M α) :=
subtype.lattice (λ _ _, is_definable.union) (λ _ _, is_definable.inter)

lemma le_iff {s t : L.definable_set M α} : s ≤ t ↔ (s : set (α → M)) ≤ (t : set (α → M)) := iff.rfl

@[simp]
lemma coe_sup {s t : L.definable_set M α} : ((s ⊔ t : L.definable_set M α) : set (α → M)) = s ∪ t :=
rfl

@[simp]
lemma mem_sup {s t : L.definable_set M α} {x : α → M} : x ∈ s ⊔ t ↔ x ∈ s ∨ x ∈ t := iff.rfl

@[simp]
lemma coe_inf {s t : L.definable_set M α} : ((s ⊓ t : L.definable_set M α) : set (α → M)) = s ∩ t :=
rfl

@[simp]
lemma mem_inf {s t : L.definable_set M α} {x : α → M} : x ∈ s ⊓ t ↔ x ∈ s ∧ x ∈ t := iff.rfl

instance : bounded_order (L.definable_set M α) :=
{ bot_le := λ s x hx, false.elim hx,
  le_top := λ s x hx, set.mem_univ x,
  .. definable_set.has_top L,
  .. definable_set.has_bot L }

instance : distrib_lattice (L.definable_set M α) :=
{ le_sup_inf := begin
    intros s t u x,
    simp only [and_imp, set.mem_inter_eq, set_like.mem_coe, coe_sup, coe_inf, set.mem_union_eq,
      subtype.val_eq_coe],
    tauto,
  end,
  .. definable_set.lattice L }

/-- The complement of a definable set is also definable. -/
@[reducible] instance : has_compl (L.definable_set M α) :=
⟨λ ⟨s, hs⟩, ⟨sᶜ, hs.compl⟩⟩

@[simp]
lemma mem_compl {s : L.definable_set M α} {x : α → M} : x ∈ sᶜ ↔ ¬ x ∈ s :=
begin
  cases s with s hs,
  refl,
end

@[simp]
lemma coe_compl {s : L.definable_set M α} : ((sᶜ : L.definable_set M α) : set (α → M)) = sᶜ :=
begin
  ext,
  simp,
end

instance : boolean_algebra (L.definable_set M α) :=
{ sdiff := λ s t, s ⊓ tᶜ,
  sdiff_eq := λ s t, rfl,
  sup_inf_sdiff := λ ⟨s, hs⟩ ⟨t, ht⟩,
  begin
    apply le_antisymm;
    simp [le_iff],
  end,
  inf_inf_sdiff := λ ⟨s, hs⟩ ⟨t, ht⟩, begin
    rw eq_bot_iff,
    simp only [coe_compl, le_iff, coe_bot, coe_inf, subtype.coe_mk,
      set.le_eq_subset],
    intros x hx,
    simp only [set.mem_inter_eq, set.mem_compl_eq] at hx,
    tauto,
  end,
  inf_compl_le_bot := λ ⟨s, hs⟩, by simp [le_iff],
  top_le_sup_compl := λ ⟨s, hs⟩, by simp [le_iff],
  .. definable_set.has_compl L,
  .. definable_set.bounded_order L,
  .. definable_set.distrib_lattice L }

end definable_set
end definability

section quotients

variables (L) {M' : Type*}

/-- A prestructure is a first-order structure with a `setoid` equivalence relation on it,
  such that quotienting by that equivalence relation is still a structure. -/
class prestructure (s : setoid M') :=
(to_structure : L.Structure M')
(fun_equiv : ∀{n} {f : L.functions n} (x y : fin n → M'),
  x ≈ y → fun_map f x ≈ fun_map f y)
(rel_equiv : ∀{n} {r : L.relations n} (x y : fin n → M') (h : x ≈ y),
  (rel_map r x = rel_map r y))

variables {L} {M'} {s : setoid M'} [ps : L.prestructure s]

instance quotient_structure :
  L.Structure (quotient s) :=
{ fun_map := λ n f x, quotient.map (@fun_map L M' ps.to_structure n f) prestructure.fun_equiv
    (quotient.fin_choice x),
  rel_map := λ n r x, quotient.lift (@rel_map L M' ps.to_structure n r) prestructure.rel_equiv
    (quotient.fin_choice x) }

variables [s]
include s

lemma fun_map_quotient_mk {n : ℕ} (f : L.functions n) (x : fin n → M') :
  fun_map f (λ i, ⟦x i⟧) = ⟦@fun_map _ _ ps.to_structure _ f x⟧ :=
begin
  change quotient.map (@fun_map L M' ps.to_structure n f) prestructure.fun_equiv
    (quotient.fin_choice _) = _,
  rw [quotient.fin_choice_eq, quotient.map_mk],
end

lemma realize_term_quotient_mk {β : Type*} (x : β → M') (t : L.term β) :
  realize_term (λ i, ⟦x i⟧) t = ⟦@realize_term _ _ ps.to_structure _ x t⟧ :=
begin
  induction t with a1 a2 a3 a4 ih a6 a7 a8 a9 a0,
  { refl },
  simp only [ih, fun_map_quotient_mk, realize_term],
end

end quotients

end language
end first_order


/-
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.fin.fin2
import data.pfun
import data.vector3
import number_theory.pell

/-!
# Diophantine functions and Matiyasevic's theorem

Hilbert's tenth problem asked whether there exists an algorithm which for a given integer polynomial
determines whether this polynomial has integer solutions. It was answered in the negative in 1970,
the final step being completed by Matiyasevic who showed that the power function is Diophantine.

Here a function is called Diophantine if its graph is Diophantine as a set. A subset `S ⊆ ℕ ^ α` in
turn is called Diophantine if there exists an integer polynomial on `α ⊕ β` such that `v ∈ S` iff
there exists `t : ℕ^β` with `p (v, t) = 0`.

## Main definitions

* `is_poly`: a predicate stating that a function is a multivariate integer polynomial.
* `poly`: the type of multivariate integer polynomial functions.
* `dioph`: a predicate stating that a set is Diophantine, i.e. a set `S ⊆ ℕ^α` is
  Diophantine if there exists a polynomial on `α ⊕ β` such that `v ∈ S` iff there
  exists `t : ℕ^β` with `p (v, t) = 0`.
* `dioph_fn`: a predicate on a function stating that it is Diophantine in the sense that its graph
  is Diophantine as a set.

## Main statements

* `pell_dioph` states that solutions to Pell's equation form a Diophantine set.
* `pow_dioph` states that the power function is Diophantine, a version of Matiyasevic's theorem.

## References

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

## Tags

Matiyasevic's theorem, Hilbert's tenth problem

## TODO

* Finish the solution of Hilbert's tenth problem.
* Connect `poly` to `mv_polynomial`
-/

universe u

open nat function

namespace int

lemma eq_nat_abs_iff_mul (x n) : nat_abs x = n ↔ (x - n) * (x + n) = 0 :=
begin
  refine iff.trans _ mul_eq_zero.symm,
  refine iff.trans _ (or_congr sub_eq_zero add_eq_zero_iff_eq_neg).symm,
  exact ⟨λe, by rw ← e; apply nat_abs_eq,
    λo, by cases o; subst x; simp [nat_abs_of_nat]⟩
end

end int

open fin2

/-- `list_all p l` is equivalent to `∀ a ∈ l, p a`, but unfolds directly to a conjunction,
  i.e. `list_all p [0, 1, 2] = p 0 ∧ p 1 ∧ p 2`. -/
@[simp] def list_all {α} (p : α → Prop) : list α → Prop
| []        := true
| (x :: []) := p x
| (x :: l)  := p x ∧ list_all l

@[simp] theorem list_all_cons {α} (p : α → Prop) (x : α) :
  ∀ (l : list α), list_all p (x :: l) ↔ p x ∧ list_all p l
| []       := (and_true _).symm
| (x :: l) := iff.rfl

theorem list_all_iff_forall {α} (p : α → Prop) : ∀ (l : list α), list_all p l ↔ ∀ x ∈ l, p x
| []       := (iff_true_intro $ list.ball_nil _).symm
| (x :: l) := by rw [list.ball_cons, ← list_all_iff_forall l]; simp

theorem list_all.imp {α} {p q : α → Prop} (h : ∀ x, p x → q x) :
  ∀ {l : list α}, list_all p l → list_all q l
| []       := id
| (x :: l) := by simpa using and.imp (h x) list_all.imp

@[simp] theorem list_all_map {α β} {p : β → Prop} (f : α → β) {l : list α} :
  list_all p (l.map f) ↔ list_all (p ∘ f) l :=
by induction l; simp *

theorem list_all_congr {α} {p q : α → Prop} (h : ∀ x, p x ↔ q x) {l : list α} :
  list_all p l ↔ list_all q l :=
⟨list_all.imp (λx, (h x).1), list_all.imp (λx, (h x).2)⟩

instance decidable_list_all {α} (p : α → Prop) [decidable_pred p] (l : list α) :
  decidable (list_all p l) :=
decidable_of_decidable_of_iff (by apply_instance) (list_all_iff_forall _ _).symm

/- poly -/

/-- A predicate asserting that a function is a multivariate integer polynomial.
  (We are being a bit lazy here by allowing many representations for multiplication,
  rather than only allowing monomials and addition, but the definition is equivalent
  and this is easier to use.) -/
inductive is_poly {α} : ((α → ℕ) → ℤ) → Prop
| proj : ∀ i, is_poly (λx : α → ℕ, x i)
| const : Π (n : ℤ), is_poly (λx : α → ℕ, n)
| sub : Π {f g : (α → ℕ) → ℤ}, is_poly f → is_poly g → is_poly (λx, f x - g x)
| mul : Π {f g : (α → ℕ) → ℤ}, is_poly f → is_poly g → is_poly (λx, f x * g x)

/-- The type of multivariate integer polynomials -/
def poly (α : Type u) := {f : (α → ℕ) → ℤ // is_poly f}

namespace poly
section
parameter {α : Type u}

instance : has_coe_to_fun (poly α) (λ _, (α → ℕ) → ℤ) := ⟨λ f, f.1⟩

/-- The underlying function of a `poly` is a polynomial -/
lemma isp (f : poly α) : is_poly f := f.2

/-- Extensionality for `poly α` -/
lemma ext {f g : poly α} (e : ∀x, f x = g x) : f = g :=
subtype.eq (funext e)

/-- Construct a `poly` given an extensionally equivalent `poly`. -/
def subst (f : poly α) (g : (α → ℕ) → ℤ) (e : ∀x, f x = g x) : poly α :=
⟨g, by rw ← (funext e : coe_fn f = g); exact f.isp⟩
@[simp] theorem subst_eval (f g e x) : subst f g e x = g x := rfl

/-- The `i`th projection function, `x_i`. -/
def proj (i) : poly α := ⟨_, is_poly.proj i⟩
@[simp] theorem proj_eval (i x) : proj i x = x i := rfl

/-- The constant function with value `n : ℤ`. -/
def const (n) : poly α := ⟨_, is_poly.const n⟩
@[simp] theorem const_eval (n x) : const n x = n := rfl

/-- The zero polynomial -/
def zero : poly α := const 0
instance : has_zero (poly α) := ⟨poly.zero⟩
@[simp] theorem zero_eval (x) : (0 : poly α) x = 0 := rfl

/-- The zero polynomial -/
def one : poly α := const 1
instance : has_one (poly α) := ⟨poly.one⟩
@[simp] theorem one_eval (x) : (1 : poly α) x = 1 := rfl

/-- Subtraction of polynomials -/
def sub : poly α → poly α → poly α | ⟨f, pf⟩ ⟨g, pg⟩ :=
⟨_, is_poly.sub pf pg⟩
instance : has_sub (poly α) := ⟨poly.sub⟩
@[simp] theorem sub_eval : Π (f g x), (f - g : poly α) x = f x - g x
| ⟨f, pf⟩ ⟨g, pg⟩ x := rfl

/-- Negation of a polynomial -/
def neg (f : poly α) : poly α := 0 - f
instance : has_neg (poly α) := ⟨poly.neg⟩
@[simp] theorem neg_eval (f x) : (-f : poly α) x = -f x :=
show (0-f) x = _, by simp

/-- Addition of polynomials -/
def add : poly α → poly α → poly α | ⟨f, pf⟩ ⟨g, pg⟩ :=
subst (⟨f, pf⟩ - -⟨g, pg⟩) _
 (λx, show f x - (0 - g x) = f x + g x, by simp)
instance : has_add (poly α) := ⟨poly.add⟩
@[simp] theorem add_eval : Π (f g x), (f + g : poly α) x = f x + g x
| ⟨f, pf⟩ ⟨g, pg⟩ x := rfl

/-- Multiplication of polynomials -/
def mul : poly α → poly α → poly α | ⟨f, pf⟩ ⟨g, pg⟩ :=
⟨_, is_poly.mul pf pg⟩
instance : has_mul (poly α) := ⟨poly.mul⟩
@[simp] theorem mul_eval : Π (f g x), (f * g : poly α) x = f x * g x
| ⟨f, pf⟩ ⟨g, pg⟩ x := rfl

instance : comm_ring (poly α) := by refine_struct
{ add   := ((+) : poly α → poly α → poly α),
  zero  := 0,
  neg   := (has_neg.neg : poly α → poly α),
  mul   := ((*)),
  one   := 1,
  sub   := (has_sub.sub),
  npow  := @npow_rec _ ⟨(1 : poly α)⟩ ⟨(*)⟩,
  nsmul := @nsmul_rec _ ⟨(0 : poly α)⟩ ⟨(+)⟩,
  zsmul := @zsmul_rec _ ⟨(0 : poly α)⟩ ⟨(+)⟩ ⟨neg⟩ };
intros; try { refl }; refine ext (λ _, _);
simp [sub_eq_add_neg, mul_add, mul_left_comm, mul_comm, add_comm, add_assoc]

lemma induction {C : poly α → Prop}
  (H1 : ∀i, C (proj i)) (H2 : ∀n, C (const n))
  (H3 : ∀f g, C f → C g → C (f - g))
  (H4 : ∀f g, C f → C g → C (f * g)) (f : poly α) : C f :=
begin
  cases f with f pf,
  induction pf with i n f g pf pg ihf ihg f g pf pg ihf ihg,
  apply H1, apply H2, apply H3 _ _ ihf ihg, apply H4 _ _ ihf ihg
end

/-- The sum of squares of a list of polynomials. This is relevant for
  Diophantine equations, because it means that a list of equations
  can be encoded as a single equation: `x = 0 ∧ y = 0 ∧ z = 0` is
  equivalent to `x^2 + y^2 + z^2 = 0`. -/
def sumsq : list (poly α) → poly α
| []      := 0
| (p::ps) := p*p + sumsq ps

theorem sumsq_nonneg (x) : ∀ l, 0 ≤ sumsq l x
| []      := le_refl 0
| (p::ps) := by rw sumsq; simp [-add_comm];
                exact add_nonneg (mul_self_nonneg _) (sumsq_nonneg ps)

theorem sumsq_eq_zero (x) : ∀ l, sumsq l x = 0 ↔ list_all (λa : poly α, a x = 0) l
| []      := eq_self_iff_true _
| (p::ps) := by rw [list_all_cons, ← sumsq_eq_zero ps]; rw sumsq; simp [-add_comm]; exact
  ⟨λ(h : p x * p x + sumsq ps x = 0),
   have p x = 0, from eq_zero_of_mul_self_eq_zero $ le_antisymm
     (by rw ← h; have t := add_le_add_left (sumsq_nonneg x ps) (p x * p x); rwa [add_zero] at t)
     (mul_self_nonneg _),
   ⟨this, by simp [this] at h; exact h⟩,
  λ⟨h1, h2⟩, by rw [h1, h2]; refl⟩

end

/-- Map the index set of variables, replacing `x_i` with `x_(f i)`. -/
def remap {α β} (f : α → β) (g : poly α) : poly β :=
⟨λv, g $ v ∘ f, g.induction
  (λi, by simp; apply is_poly.proj)
  (λn, by simp; apply is_poly.const)
  (λf g pf pg, by simp; apply is_poly.sub pf pg)
  (λf g pf pg, by simp; apply is_poly.mul pf pg)⟩
@[simp] theorem remap_eval {α β} (f : α → β) (g : poly α) (v) : remap f g v = g (v ∘ f) := rfl

end poly

namespace sum

/-- combine two functions into a function on the disjoint union -/
def join {α β γ} (f : α → γ) (g : β → γ) : α ⊕ β → γ :=
by {refine sum.rec _ _, exacts [f, g]}

end sum

local infixr ` ⊗ `:65 := sum.join

open sum

namespace option

/-- Functions from `option` can be combined similarly to `vector.cons` -/
def cons {α β} (a : β) (v : α → β) : option α → β :=
by {refine option.rec _ _, exacts [a, v]}

notation a :: b := cons a b

@[simp] theorem cons_head_tail {α β} (v : option α → β) : v none :: v ∘ some = v :=
funext $ λo, by cases o; refl
end option

/- dioph -/

/-- A set `S ⊆ ℕ^α` is Diophantine if there exists a polynomial on
  `α ⊕ β` such that `v ∈ S` iff there exists `t : ℕ^β` with `p (v, t) = 0`. -/
def dioph {α : Type u} (S : set (α → ℕ)) : Prop :=
∃ {β : Type u} (p : poly (α ⊕ β)), ∀ (v : α → ℕ), S v ↔ ∃t, p (v ⊗ t) = 0

namespace dioph
section
variables {α β γ : Type u}
theorem ext {S S' : set (α → ℕ)} (d : dioph S) (H : ∀v, S v ↔ S' v) : dioph S' :=
eq.rec d $ show S = S', from set.ext H

theorem of_no_dummies (S : set (α → ℕ)) (p : poly α) (h : ∀ (v : α → ℕ), S v ↔ p v = 0) :
  dioph S :=
⟨ulift empty, p.remap inl, λv, (h v).trans
  ⟨λh, ⟨λt, empty.rec _ t.down, by simp; rw [
    show (v ⊗ λt:ulift empty, empty.rec _ t.down) ∘ inl = v, from rfl, h]⟩,
  λ⟨t, ht⟩, by simp at ht; rwa [show (v ⊗ t) ∘ inl = v, from rfl] at ht⟩⟩

lemma inject_dummies_lem (f : β → γ) (g : γ → option β) (inv : ∀ x, g (f x) = some x)
  (p : poly (α ⊕ β)) (v : α → ℕ) : (∃t, p (v ⊗ t) = 0) ↔
    (∃t, p.remap (inl ⊗ (inr ∘ f)) (v ⊗ t) = 0) :=
begin
  simp, refine ⟨λt, _, λt, _⟩; cases t with t ht,
  { have : (v ⊗ (0 :: t) ∘ g) ∘ (inl ⊗ inr ∘ f) = v ⊗ t :=
    funext (λs, by cases s with a b; dsimp [join, (∘)]; try {rw inv}; refl),
    exact ⟨(0 :: t) ∘ g, by rwa this⟩ },
  { have : v ⊗ t ∘ f = (v ⊗ t) ∘ (inl ⊗ inr ∘ f) :=
    funext (λs, by cases s with a b; refl),
    exact ⟨t ∘ f, by rwa this⟩ }
end

theorem inject_dummies {S : set (α → ℕ)} (f : β → γ) (g : γ → option β)
  (inv : ∀ x, g (f x) = some x) (p : poly (α ⊕ β)) (h : ∀ (v : α → ℕ), S v ↔ ∃t, p (v ⊗ t) = 0) :
  ∃ q : poly (α ⊕ γ), ∀ (v : α → ℕ), S v ↔ ∃t, q (v ⊗ t) = 0 :=
⟨p.remap (inl ⊗ (inr ∘ f)), λv, (h v).trans $ inject_dummies_lem f g inv _ _⟩

theorem reindex_dioph {S : set (α → ℕ)} : Π (d : dioph S) (f : α → β), dioph (λv, S (v ∘ f))
| ⟨γ, p, pe⟩ f := ⟨γ, p.remap ((inl ∘ f) ⊗ inr), λv, (pe _).trans $ exists_congr $ λt,
  suffices v ∘ f ⊗ t = (v ⊗ t) ∘ (inl ∘ f ⊗ inr), by simp [this],
  funext $ λs, by cases s with a b; refl⟩

theorem dioph_list_all (l) (d : list_all dioph l) :
  dioph (λv, list_all (λS : set (α → ℕ), S v) l) :=
suffices ∃ β (pl : list (poly (α ⊕ β))), ∀ v,
  list_all (λS : set _, S v) l ↔ ∃t, list_all (λp : poly (α ⊕ β), p (v ⊗ t) = 0) pl,
from let ⟨β, pl, h⟩ := this
  in ⟨β, poly.sumsq pl, λv, (h v).trans $ exists_congr $ λt, (poly.sumsq_eq_zero _ _).symm⟩,
begin
  induction l with S l IH,
  exact ⟨ulift empty, [], λv, by simp; exact ⟨λ⟨t⟩, empty.rec _ t, trivial⟩⟩,
  simp at d,
  exact let ⟨⟨β, p, pe⟩, dl⟩ := d, ⟨γ, pl, ple⟩ := IH dl in
  ⟨β ⊕ γ, p.remap (inl ⊗ inr ∘ inl) :: pl.map (λq, q.remap (inl ⊗ (inr ∘ inr))), λv,
    by simp; exact iff.trans (and_congr (pe v) (ple v))
    ⟨λ⟨⟨m, hm⟩, ⟨n, hn⟩⟩,
      ⟨m ⊗ n, by rw [
        show (v ⊗ m ⊗ n) ∘ (inl ⊗ inr ∘ inl) = v ⊗ m,
        from funext $ λs, by cases s with a b; refl]; exact hm,
      by { refine list_all.imp (λq hq, _) hn, dsimp [(∘)],
           rw [show (λ (x : α ⊕ γ), (v ⊗ m ⊗ n) ((inl ⊗ λ (x : γ), inr (inr x)) x)) = v ⊗ n,
               from funext $ λs, by cases s with a b; refl]; exact hq }⟩,
    λ⟨t, hl, hr⟩,
      ⟨⟨t ∘ inl, by rwa [
        show (v ⊗ t) ∘ (inl ⊗ inr ∘ inl) = v ⊗ t ∘ inl,
        from funext $ λs, by cases s with a b; refl] at hl⟩,
      ⟨t ∘ inr, by
      { refine list_all.imp (λq hq, _) hr, dsimp [(∘)] at hq,
        rwa [show (λ (x : α ⊕ γ), (v ⊗ t) ((inl ⊗ λ (x : γ), inr (inr x)) x)) = v ⊗ t ∘ inr,
             from funext $ λs, by cases s with a b; refl] at hq }⟩⟩⟩⟩
end

theorem and_dioph {S S' : set (α → ℕ)} (d : dioph S) (d' : dioph S') : dioph (λv, S v ∧ S' v) :=
dioph_list_all [S, S'] ⟨d, d'⟩

theorem or_dioph {S S' : set (α → ℕ)} : ∀ (d : dioph S) (d' : dioph S'), dioph (λv, S v ∨ S' v)
| ⟨β, p, pe⟩ ⟨γ, q, qe⟩ := ⟨β ⊕ γ, p.remap (inl ⊗ inr ∘ inl) * q.remap (inl ⊗ inr ∘ inr), λv,
  begin
    refine iff.trans (or_congr ((pe v).trans _) ((qe v).trans _))
      (exists_or_distrib.symm.trans (exists_congr $ λt,
      (@mul_eq_zero _ _ _ (p ((v ⊗ t) ∘ (inl ⊗ inr ∘ inl)))
        (q ((v ⊗ t) ∘ (inl ⊗ inr ∘ inr)))).symm)),
    exact inject_dummies_lem _ (some ⊗ (λ_, none)) (λx, rfl) _ _,
    exact inject_dummies_lem _ ((λ_, none) ⊗ some) (λx, rfl) _ _,
  end⟩

/-- A partial function is Diophantine if its graph is Diophantine. -/
def dioph_pfun (f : (α → ℕ) →. ℕ) := dioph (λv : option α → ℕ, f.graph (v ∘ some, v none))

/-- A function is Diophantine if its graph is Diophantine. -/
def dioph_fn (f : (α → ℕ) → ℕ) := dioph (λv : option α → ℕ, f (v ∘ some) = v none)

theorem reindex_dioph_fn {f : (α → ℕ) → ℕ} (d : dioph_fn f) (g : α → β) :
  dioph_fn (λv, f (v ∘ g)) :=
reindex_dioph d (functor.map g)

theorem ex_dioph {S : set (α ⊕ β → ℕ)} : dioph S → dioph (λv, ∃x, S (v ⊗ x))
| ⟨γ, p, pe⟩ := ⟨β ⊕ γ, p.remap ((inl ⊗ inr ∘ inl) ⊗ inr ∘ inr), λv,
  ⟨λ⟨x, hx⟩, let ⟨t, ht⟩ := (pe _).1 hx in ⟨x ⊗ t, by simp; rw [
    show (v ⊗ x ⊗ t) ∘ ((inl ⊗ inr ∘ inl) ⊗ inr ∘ inr) = (v ⊗ x) ⊗ t,
    from funext $ λs, by cases s with a b; try {cases a}; refl]; exact ht⟩,
  λ⟨t, ht⟩, ⟨t ∘ inl, (pe _).2 ⟨t ∘ inr, by simp at ht; rwa [
    show (v ⊗ t) ∘ ((inl ⊗ inr ∘ inl) ⊗ inr ∘ inr) = (v ⊗ t ∘ inl) ⊗ t ∘ inr,
    from funext $ λs, by cases s with a b; try {cases a}; refl] at ht⟩⟩⟩⟩

theorem ex1_dioph {S : set (option α → ℕ)} : dioph S → dioph (λv, ∃x, S (x :: v))
| ⟨β, p, pe⟩ := ⟨option β, p.remap (inr none :: inl ⊗ inr ∘ some), λv,
  ⟨λ⟨x, hx⟩, let ⟨t, ht⟩ := (pe _).1 hx in ⟨x :: t, by simp; rw [
    show (v ⊗ x :: t) ∘ (inr none :: inl ⊗ inr ∘ some) = x :: v ⊗ t,
    from funext $ λs, by cases s with a b; try {cases a}; refl]; exact ht⟩,
  λ⟨t, ht⟩, ⟨t none, (pe _).2 ⟨t ∘ some, by simp at ht; rwa [
    show (v ⊗ t) ∘ (inr none :: inl ⊗ inr ∘ some) = t none :: v ⊗ t ∘ some,
    from funext $ λs, by cases s with a b; try {cases a}; refl] at ht⟩⟩⟩⟩

theorem dom_dioph {f : (α → ℕ) →. ℕ} (d : dioph_pfun f) : dioph f.dom :=
cast (congr_arg dioph $ set.ext $ λv, (pfun.dom_iff_graph _ _).symm) (ex1_dioph d)

theorem dioph_fn_iff_pfun (f : (α → ℕ) → ℕ) : dioph_fn f = @dioph_pfun α f :=
by refine congr_arg dioph (set.ext $ λv, _); exact pfun.lift_graph.symm

theorem abs_poly_dioph (p : poly α) : dioph_fn (λv, (p v).nat_abs) :=
by refine of_no_dummies _ ((p.remap some - poly.proj none) * (p.remap some + poly.proj none))
  (λv, _); apply int.eq_nat_abs_iff_mul

theorem proj_dioph (i : α) : dioph_fn (λv, v i) :=
abs_poly_dioph (poly.proj i)

theorem dioph_pfun_comp1 {S : set (option α → ℕ)} (d : dioph S) {f} (df : dioph_pfun f) :
  dioph (λv : α → ℕ, ∃ h : f.dom v, S (f.fn v h :: v)) :=
ext (ex1_dioph (and_dioph d df)) $ λv,
⟨λ⟨x, hS, (h: Exists _)⟩, by
  rw [show (x :: v) ∘ some = v, from funext $ λs, rfl] at h;
  cases h with hf h; refine ⟨hf, _⟩; rw [pfun.fn, h]; exact hS,
λ⟨x, hS⟩, ⟨f.fn v x, hS, show Exists _,
  by rw [show (f.fn v x :: v) ∘ some = v, from funext $ λs, rfl]; exact ⟨x, rfl⟩⟩⟩

theorem dioph_fn_comp1 {S : set (option α → ℕ)} (d : dioph S) {f : (α → ℕ) → ℕ} (df : dioph_fn f) :
  dioph (λv : α → ℕ, S (f v :: v)) :=
ext (dioph_pfun_comp1 d (cast (dioph_fn_iff_pfun f) df)) $ λv,
⟨λ⟨_, h⟩, h, λh, ⟨trivial, h⟩⟩

end

section
variables {α β γ : Type}
open vector3
open_locale vector3
theorem dioph_fn_vec_comp1 {n} {S : set (vector3 ℕ (succ n))} (d : dioph S) {f : (vector3 ℕ n) → ℕ}
  (df : dioph_fn f) :
  dioph (λv : vector3 ℕ n, S (cons (f v) v)) :=
ext (dioph_fn_comp1 (reindex_dioph d (none :: some)) df) $ λv, by rw [
  show option.cons (f v) v ∘ (cons none some) = f v :: v,
  from funext $ λs, by cases s with a b; refl]

theorem vec_ex1_dioph (n) {S : set (vector3 ℕ (succ n))} (d : dioph S) :
  dioph (λv : vector3 ℕ n, ∃x, S (x :: v)) :=
ext (ex1_dioph $ reindex_dioph d (none :: some)) $ λv, exists_congr $ λx, by rw [
  show (option.cons x v) ∘ (cons none some) = x :: v,
  from funext $ λs, by cases s with a b; refl]

theorem dioph_fn_vec {n} (f : vector3 ℕ n → ℕ) :
  dioph_fn f ↔ dioph (λv : vector3 ℕ (succ n), f (v ∘ fs) = v fz) :=
⟨λh, reindex_dioph h (fz :: fs), λh, reindex_dioph h (none :: some)⟩

theorem dioph_pfun_vec {n} (f : vector3 ℕ n →. ℕ) :
  dioph_pfun f ↔ dioph (λv : vector3 ℕ (succ n), f.graph (v ∘ fs, v fz)) :=
⟨λh, reindex_dioph h (fz :: fs), λh, reindex_dioph h (none :: some)⟩

theorem dioph_fn_compn {α : Type} : ∀ {n} {S : set (α ⊕ fin2 n → ℕ)} (d : dioph S)
  {f : vector3 ((α → ℕ) → ℕ) n} (df : vector_allp dioph_fn f),
  dioph (λv : α → ℕ, S (v ⊗ λi, f i v))
| 0 S d f := λdf, ext (reindex_dioph d (id ⊗ fin2.elim0)) $ λv,
  by refine eq.to_iff (congr_arg S $ funext $ λs, _); {cases s with a b, refl, cases b}
| (succ n) S d f := f.cons_elim $ λf fl, by simp; exact λ df dfl,
  have dioph (λv, S (v ∘ inl ⊗ f (v ∘ inl) :: v ∘ inr)),
  from ext (dioph_fn_comp1 (reindex_dioph d (some ∘ inl ⊗ none :: some ∘ inr))
    (reindex_dioph_fn df inl)) $
    λv, by {refine eq.to_iff (congr_arg S $ funext $ λs, _); cases s with a b, refl, cases b; refl},
  have dioph (λv, S (v ⊗ f v :: λ (i : fin2 n), fl i v)),
  from @dioph_fn_compn n (λv, S (v ∘ inl ⊗ f (v ∘ inl) :: v ∘ inr)) this _ dfl,
  ext this $ λv, by rw [
    show cons (f v) (λ (i : fin2 n), fl i v) = λ (i : fin2 (succ n)), (f :: fl) i v,
    from funext $ λs, by cases s with a b; refl]

theorem dioph_comp {n} {S : set (vector3 ℕ n)} (d : dioph S)
  (f : vector3 ((α → ℕ) → ℕ) n) (df : vector_allp dioph_fn f) : dioph (λv, S (λi, f i v)) :=
dioph_fn_compn (reindex_dioph d inr) df

theorem dioph_fn_comp {n} {f : vector3 ℕ n → ℕ} (df : dioph_fn f)
  (g : vector3 ((α → ℕ) → ℕ) n) (dg : vector_allp dioph_fn g) : dioph_fn (λv, f (λi, g i v)) :=
dioph_comp ((dioph_fn_vec _).1 df) ((λv, v none) :: λi v, g i (v ∘ some)) $
by simp; exact ⟨proj_dioph none, (vector_allp_iff_forall _ _).2 $ λi,
  reindex_dioph_fn ((vector_allp_iff_forall _ _).1 dg _) _⟩

localized "notation x ` D∧ `:35 y := dioph.and_dioph x y" in dioph
localized "notation x ` D∨ `:35 y := dioph.or_dioph x y" in dioph

localized "notation `D∃`:30 := dioph.vec_ex1_dioph" in dioph

localized "prefix `&`:max := fin2.of_nat'" in dioph
theorem proj_dioph_of_nat {n : ℕ} (m : ℕ) [is_lt m n] : dioph_fn (λv : vector3 ℕ n, v &m) :=
proj_dioph &m
localized "prefix `D&`:100 := dioph.proj_dioph_of_nat" in dioph

theorem const_dioph (n : ℕ) : dioph_fn (const (α → ℕ) n) :=
abs_poly_dioph (poly.const n)
localized "prefix `D.`:100 := dioph.const_dioph" in dioph

variables {f g : (α → ℕ) → ℕ} (df : dioph_fn f) (dg : dioph_fn g)
include df dg

theorem dioph_comp2 {S : ℕ → ℕ → Prop} (d : dioph (λv:vector3 ℕ 2, S (v &0) (v &1))) :
  dioph (λv, S (f v) (g v)) :=
dioph_comp d [f, g] (by exact ⟨df, dg⟩)

theorem dioph_fn_comp2 {h : ℕ → ℕ → ℕ} (d : dioph_fn (λv:vector3 ℕ 2, h (v &0) (v &1))) :
  dioph_fn (λv, h (f v) (g v)) :=
dioph_fn_comp d [f, g] (by exact ⟨df, dg⟩)

theorem eq_dioph : dioph (λv, f v = g v) :=
dioph_comp2 df dg $ of_no_dummies _ (poly.proj &0 - poly.proj &1)
  (λv, (int.coe_nat_eq_coe_nat_iff _ _).symm.trans
  ⟨@sub_eq_zero_of_eq ℤ _ (v &0) (v &1), eq_of_sub_eq_zero⟩)
localized "infix ` D= `:50 := dioph.eq_dioph" in dioph

theorem add_dioph : dioph_fn (λv, f v + g v) :=
dioph_fn_comp2 df dg $ abs_poly_dioph (poly.proj &0 + poly.proj &1)
localized "infix ` D+ `:80 := dioph.add_dioph" in dioph

theorem mul_dioph : dioph_fn (λv, f v * g v) :=
dioph_fn_comp2 df dg $ abs_poly_dioph (poly.proj &0 * poly.proj &1)
localized "infix ` D* `:90 := dioph.mul_dioph" in dioph

theorem le_dioph : dioph (λv, f v ≤ g v) :=
dioph_comp2 df dg $ ext (D∃2 $ D&1 D+ D&0 D= D&2) (λv, ⟨λ⟨x, hx⟩, le.intro hx, le.dest⟩)
localized "infix ` D≤ `:50 := dioph.le_dioph" in dioph

theorem lt_dioph : dioph (λv, f v < g v) := df D+ (D. 1) D≤ dg
localized "infix ` D< `:50 := dioph.lt_dioph" in dioph

theorem ne_dioph : dioph (λv, f v ≠ g v) :=
ext (df D< dg D∨ dg D< df) $ λv, ne_iff_lt_or_gt.symm
localized "infix ` D≠ `:50 := dioph.ne_dioph" in dioph

theorem sub_dioph : dioph_fn (λv, f v - g v) :=
dioph_fn_comp2 df dg $ (dioph_fn_vec _).2 $
ext (D&1 D= D&0 D+ D&2 D∨ D&1 D≤ D&2 D∧ D&0 D= D.0) $ (vector_all_iff_forall _).1 $ λx y z,
show (y = x + z ∨ y ≤ z ∧ x = 0) ↔ y - z = x, from
⟨λo, begin
  rcases o with ae | ⟨yz, x0⟩,
  { rw [ae, add_tsub_cancel_right] },
  { rw [x0, tsub_eq_zero_iff_le.mpr yz] }
end, λh, begin
  subst x,
  cases le_total y z with yz zy,
  { exact or.inr ⟨yz, tsub_eq_zero_iff_le.mpr yz⟩ },
  { exact or.inl (tsub_add_cancel_of_le zy).symm },
end⟩
localized "infix ` D- `:80 := dioph.sub_dioph" in dioph

theorem dvd_dioph : dioph (λv, f v ∣ g v) :=
dioph_comp (D∃2 $ D&2 D= D&1 D* D&0) [f, g] (by exact ⟨df, dg⟩)
localized "infix ` D∣ `:50 := dioph.dvd_dioph" in dioph

theorem mod_dioph : dioph_fn (λv, f v % g v) :=
have dioph (λv : vector3 ℕ 3, (v &2 = 0 ∨ v &0 < v &2) ∧ ∃ (x : ℕ), v &0 + v &2 * x = v &1),
from (D&2 D= D.0 D∨ D&0 D< D&2) D∧ (D∃3 $ D&1 D+ D&3 D* D&0 D= D&2),
dioph_fn_comp2 df dg $ (dioph_fn_vec _).2 $ ext this $ (vector_all_iff_forall _).1 $ λz x y,
show ((y = 0 ∨ z < y) ∧ ∃ c, z + y * c = x) ↔ x % y = z, from
⟨λ⟨h, c, hc⟩, begin rw ← hc; simp; cases h with x0 hl, rw [x0, mod_zero], exact mod_eq_of_lt hl end,
λe, by rw ← e; exact ⟨or_iff_not_imp_left.2 $ λh, mod_lt _ (nat.pos_of_ne_zero h), x / y,
  mod_add_div _ _⟩⟩

localized "infix ` D% `:80 := dioph.mod_dioph" in dioph

theorem modeq_dioph {h : (α → ℕ) → ℕ} (dh : dioph_fn h) : dioph (λv, f v ≡ g v [MOD h v]) :=
df D% dh D= dg D% dh
localized "notation `D≡` := dioph.modeq_dioph" in dioph

theorem div_dioph : dioph_fn (λv, f v / g v) :=
have dioph (λv : vector3 ℕ 3, v &2 = 0 ∧ v &0 = 0 ∨ v &0 * v &2 ≤ v &1 ∧ v &1 < (v &0 + 1) * v &2),
from (D&2 D= D.0 D∧ D&0 D= D.0) D∨ D&0 D* D&2 D≤ D&1 D∧ D&1 D< (D&0 D+ D.1) D* D&2,
dioph_fn_comp2 df dg $ (dioph_fn_vec _).2 $ ext this $ (vector_all_iff_forall _).1 $ λz x y,
show y = 0 ∧ z = 0 ∨ z * y ≤ x ∧ x < (z + 1) * y ↔ x / y = z,
by refine iff.trans _ eq_comm; exact y.eq_zero_or_pos.elim
  (λy0, by rw [y0, nat.div_zero]; exact
    ⟨λo, (o.resolve_right $ λ⟨_, h2⟩, nat.not_lt_zero _ h2).right, λz0, or.inl ⟨rfl, z0⟩⟩)
  (λypos, iff.trans ⟨λo, o.resolve_left $ λ⟨h1, _⟩, ne_of_gt ypos h1, or.inr⟩
    (le_antisymm_iff.trans $ and_congr (nat.le_div_iff_mul_le _ _ ypos) $
      iff.trans ⟨lt_succ_of_le, le_of_lt_succ⟩ (div_lt_iff_lt_mul _ _ ypos)).symm)
localized "infix ` D/ `:80 := dioph.div_dioph" in dioph

omit df dg
open pell

theorem pell_dioph : dioph (λv:vector3 ℕ 4, ∃ h : 1 < v &0,
  xn h (v &1) = v &2 ∧ yn h (v &1) = v &3) :=
have dioph {v : vector3 ℕ 4 |
1 < v &0 ∧ v &1 ≤ v &3 ∧
(v &2 = 1 ∧ v &3 = 0 ∨
∃ (u w s t b : ℕ),
  v &2 * v &2 - (v &0 * v &0 - 1) * v &3 * v &3 = 1 ∧
  u * u - (v &0 * v &0 - 1) * w * w = 1 ∧
  s * s - (b * b - 1) * t * t = 1 ∧
  1 < b ∧ (b ≡ 1 [MOD 4 * v &3]) ∧ (b ≡ v &0 [MOD u]) ∧
  0 < w ∧ v &3 * v &3 ∣ w ∧
  (s ≡ v &2 [MOD u]) ∧
  (t ≡ v &1 [MOD 4 * v &3]))}, from
D.1 D< D&0 D∧ D&1 D≤ D&3 D∧
((D&2 D= D.1 D∧ D&3 D= D.0) D∨
 (D∃4 $ D∃5 $ D∃6 $ D∃7 $ D∃8 $
  D&7 D* D&7 D- (D&5 D* D&5 D- D.1) D* D&8 D* D&8 D= D.1 D∧
  D&4 D* D&4 D- (D&5 D* D&5 D- D.1) D* D&3 D* D&3 D= D.1 D∧
  D&2 D* D&2 D- (D&0 D* D&0 D- D.1) D* D&1 D* D&1 D= D.1 D∧
  D.1 D< D&0 D∧ (D≡ (D&0) (D.1) (D.4 D* D&8)) D∧ (D≡ (D&0) (D&5) D&4) D∧
  D.0 D< D&3 D∧ D&8 D* D&8 D∣ D&3 D∧
  (D≡ (D&2) (D&7) D&4) D∧
  (D≡ (D&1) (D&6) (D.4 D* D&8)))),
dioph.ext this $ λv, matiyasevic.symm

theorem xn_dioph : dioph_pfun (λv:vector3 ℕ 2, ⟨1 < v &0, λh, xn h (v &1)⟩) :=
have dioph (λv:vector3 ℕ 3, ∃ y, ∃ h : 1 < v &1, xn h (v &2) = v &0 ∧ yn h (v &2) = y), from
let D_pell := @reindex_dioph _ (fin2 4) _ pell_dioph [&2, &3, &1, &0] in D∃3 D_pell,
(dioph_pfun_vec _).2 $ dioph.ext this $ λv, ⟨λ⟨y, h, xe, ye⟩, ⟨h, xe⟩, λ⟨h, xe⟩, ⟨_, h, xe, rfl⟩⟩

include df dg
/-- A version of **Matiyasevic's theorem** -/
theorem pow_dioph : dioph_fn (λv, f v ^ g v) :=
have dioph {v : vector3 ℕ 3 |
v &2 = 0 ∧ v &0 = 1 ∨ 0 < v &2 ∧
(v &1 = 0 ∧ v &0 = 0 ∨ 0 < v &1 ∧
∃ (w a t z x y : ℕ),
  (∃ (a1 : 1 < a), xn a1 (v &2) = x ∧ yn a1 (v &2) = y) ∧
  (x ≡ y * (a - v &1) + v &0 [MOD t]) ∧
  2 * a * v &1 = t + (v &1 * v &1 + 1) ∧
  v &0 < t ∧ v &1 ≤ w ∧ v &2 ≤ w ∧
  a * a - ((w + 1) * (w + 1) - 1) * (w * z) * (w * z) = 1)}, from
let D_pell := @reindex_dioph _ (fin2 9) _ pell_dioph [&4, &8, &1, &0] in
(D&2 D= D.0 D∧ D&0 D= D.1) D∨ (D.0 D< D&2 D∧
((D&1 D= D.0 D∧ D&0 D= D.0) D∨ (D.0 D< D&1 D∧
 (D∃3 $ D∃4 $ D∃5 $ D∃6 $ D∃7 $ D∃8 $ D_pell D∧
  (D≡ (D&1) (D&0 D* (D&4 D- D&7) D+ D&6) (D&3)) D∧
  D.2 D* D&4 D* D&7 D= D&3 D+ (D&7 D* D&7 D+ D.1) D∧
  D&6 D< D&3 D∧ D&7 D≤ D&5 D∧ D&8 D≤ D&5 D∧
  D&4 D* D&4 D- ((D&5 D+ D.1) D* (D&5 D+ D.1) D- D.1) D* (D&5 D* D&2) D* (D&5 D* D&2) D= D.1)))),
dioph_fn_comp2 df dg $ (dioph_fn_vec _).2 $ dioph.ext this $ λv, iff.symm $
eq_pow_of_pell.trans $ or_congr iff.rfl $ and_congr iff.rfl $ or_congr iff.rfl $ and_congr iff.rfl $
⟨λ⟨w, a, t, z, a1, h⟩, ⟨w, a, t, z, _, _, ⟨a1, rfl, rfl⟩, h⟩,
 λ⟨w, a, t, z, ._, ._, ⟨a1, rfl, rfl⟩, h⟩, ⟨w, a, t, z, a1, h⟩⟩

end
end dioph


import data.int.basic
import data.int.parity
import data.nat.prime
import data.rat.basic
import number_theory.pythagorean_triples
import tests.test157lemmas
import tactic

noncomputable theory

def is_congr_num (n : ℤ) := 0 < n ∧ (∃ x y z : ℚ, x ^ 2 + y ^ 2 = z ^ 2 ∧ x * y / 2 = n)

lemma is_congr_num_iff_xyzZpos (n : ℤ) :
is_congr_num n ↔ 0 < n ∧ (∃ (x y z : ℤ) (m : ℚ), 0 < x ∧ 0 < y ∧ 0 < z ∧ 0 < m
∧ x ^ 2 + y ^ 2 = z ^ 2 ∧ (x : ℚ) * y / 2 = n * m ^ 2) :=
begin
  split, {
    rintros ⟨ hn, x, y, z, h1, h2 ⟩,
    split, { exact hn, },
    have hn' : n ≠ 0 := by linarith only [hn],
    cancel_denoms at h2,
    have h2' : x ≠ 0 ∧ y ≠ 0 := by { rw [← mul_ne_zero_iff, h2], field_simp [hn'], },
    have h3 : z ≠ 0 := by {
      by_contradiction,
      push_neg at h,
      have := calc 0 = x^2+y^2 : by { rw [h1, h], ring, }
      ... > 0 : add_pos (pow_two_pos_of_ne_zero x h2'.1) (pow_two_pos_of_ne_zero y h2'.2),
      linarith only [this],
    },
    rcases rat.stupid x with ⟨ x1, x2, x2pos, hx ⟩,
    rcases rat.stupid y with ⟨ y1, y2, y2pos, hy ⟩,
    rcases rat.stupid z with ⟨ z1, z2, z2pos, hz ⟩,
    have x2nz : x2 ≠ 0 := by linarith only [x2pos],
    have y2nz : y2 ≠ 0 := by linarith only [y2pos],
    have z2nz : z2 ≠ 0 := by linarith only [z2pos],
    have x1nz : x1 ≠ 0 := by { have := h2'.1, rw hx at this, field_simp [x2nz] at this, exact this, },
    have y1nz : y1 ≠ 0 := by { have := h2'.2, rw hy at this, field_simp [y2nz] at this, exact this, },
    have z1nz : z1 ≠ 0 := by { have := h3, rw hz at this, field_simp [z2nz] at this, exact this, },
    set! x' := abs x1 * y2 * z2 with hx', clear_value x',
    set! y' := abs y1 * z2 * x2 with hy', clear_value y',
    set! z' := abs z1 * x2 * y2 with hz', clear_value z',
    set! m' := x2 * y2 * z2 with hm', clear_value m',
    use [x', y', z', m'],
    split, { rw hx', exact mul_pos (mul_pos (abs_pos.2 x1nz) y2pos) z2pos, },
    split, { rw hy', exact mul_pos (mul_pos (abs_pos.2 y1nz) z2pos) x2pos, },
    split, { rw hz', exact mul_pos (mul_pos (abs_pos.2 z1nz) x2pos) y2pos, },
    split, { rw hm', norm_cast, exact mul_pos (mul_pos x2pos y2pos) z2pos, },
    split, {
      rw [hx', hy', hz'],
      rw [hx, hy, hz] at h1,
      field_simp [x2nz, y2nz, z2nz] at h1,
      norm_cast at h1,
      ring at h1 ⊢,
      rw [abs.stupid_sqr x1, abs.stupid_sqr y1, abs.stupid_sqr z1, ← h1],
      ring,
    },
    cancel_denoms, norm_cast,
    rw [hx', hy', hm'],
    rw [hx, hy] at h2,
    field_simp [x2nz, y2nz] at h2,
    norm_cast at h2,
    have := calc x1 * y1 = 2 * n * (y2 * x2) : h2
    ... > 0 : mul_pos (by linarith only [hn]) (mul_pos y2pos x2pos),
    replace := abs_of_pos this,
    rw abs_mul at this,
    calc abs x1 * y2 * z2 * (abs y1 * z2 * x2) = abs x1 * abs y1 * y2 * z2 * z2 * x2 : by ring
    ... = 2 * n * (y2 * x2) * y2 * z2 * z2 * x2 : by rw [this, h2]
    ... = 2 * n * (x2 * y2 * z2) ^ 2 : by ring,
  },
  rintros ⟨ hn, x, y, z, m, hx, hy, hz, hm, h1, h2 ⟩,
  split, { exact hn, },
  use [(x:ℚ)/m, (y:ℚ)/m, (z:ℚ)/m],
  replace hm : (m:ℚ) ≠ 0 := by { norm_cast, linarith only [hm], },
  field_simp [hm],
  norm_cast,
  split, { exact h1, },
  field_simp at h2, norm_cast at h2, rw h2, ring,
end

lemma is_congr_num_iff_xyzZpos_coprime (n : ℤ) :
is_congr_num n ↔ 0 < n ∧ (∃ (x y z : ℤ) (m : ℚ), 0 < x ∧ 0 < y ∧ 0 < z ∧ 0 < m
∧ x.gcd y = 1 ∧ x ^ 2 + y ^ 2 = z ^ 2 ∧ (x : ℚ) * y / 2 = n * m ^ 2) :=
begin
  rw is_congr_num_iff_xyzZpos n,
  split, {
    rintros ⟨ hn, x, y, z, m, hx, hy, hz, hm, h1, h2 ⟩,
    split, { exact hn, },
    let d := ((x.gcd y) : ℤ),
    let x' := x/d,
    let y' := y/d,
    let z' := z/d,
    have tx : x = x' * d := int.eq_mul_of_div_eq_left (int.gcd_dvd_left x y) rfl,
    have ty : y = y' * d := int.eq_mul_of_div_eq_left (int.gcd_dvd_right x y) rfl,
    have tz := dvd_add
      ((int.pow_dvd_pow_iff zero_lt_two).2 (int.gcd_dvd_left x y))
      ((int.pow_dvd_pow_iff zero_lt_two).2 (int.gcd_dvd_right x y)),
    rw [h1, int.pow_dvd_pow_iff zero_lt_two] at tz,
    replace tz : z = z' * d := int.eq_mul_of_div_eq_left tz rfl,
    have hd : 0 < d := by { norm_cast, exact int.gcd_pos_of_non_zero_right x (calc y ≠ 0 : by linarith only [hy]), },
    have t3 := int.gcd_mul_right x' d y',
    rw [← tx, ← ty] at t3,
    simp at t3,
    zify at t3,
    replace t3 := int.eq_one_of_mul_eq_self_left (calc d ≠ 0 : by linarith only [hd]) t3.symm,
    norm_cast at t3,
    use [x', y', z', m/d],
    split, { rw [tx, mul_pos_iff] at hx, cases hx with hx hx, exact hx.1, exfalso, linarith, },
    split, { rw [ty, mul_pos_iff] at hy, cases hy with hy hy, exact hy.1, exfalso, linarith, },
    split, { rw [tz, mul_pos_iff] at hz, cases hz with hz hz, exact hz.1, exfalso, linarith, },
    split, { refine div_pos hm _, norm_cast at ⊢ hd, exact hd, },
    split, { exact t3, },
    split, {
      replace h1 := calc (x'^2+y'^2)*d^2 = (x'*d) ^ 2 + (y'*d) ^ 2 : by ring
      ... = (z'*d) ^ 2 : by rw [← tx, ← ty, ← tz, h1]
      ... = z'^2*d^2 : by ring,
      exact mul_right_cancel' (calc d^2≠0 : by linarith only [pow_pos hd 2]) h1,
    },
    rw [tx, ty] at h2,
    have : (d:ℚ)≠0 := by { norm_cast at ⊢ hd, linarith only [hd], },
    clear_value d,
    field_simp [this] at ⊢ h2,
    rw ← h2, ring,
  },
  rintros ⟨ hn, x, y, z, m, hx, hy, hz, hm, hgcd, h1, h2 ⟩,
  exact ⟨ hn, x, y, z, m, hx, hy, hz, hm, h1, h2 ⟩,
end

lemma is_congr_num_iff_rsQ (n : ℤ) :
is_congr_num n ↔ 0 < n ∧ (∃ r s m : ℚ, m ≠ 0 ∧ r * s * (r + s) * (r - s) = n * m ^ 2) :=
begin
  split, {
    rintros ⟨ h1, x, y, z, h2, h3 ⟩,
    split, { exact h1, },
    replace h1 : n ≠ 0 := by linarith only [h1],
    have t1 : x ≠ 0 ∧ y ≠ 0 := by {
      cancel_denoms at h3,
      have := mul_ne_zero (calc (2 : ℚ) ≠ 0 : by norm_num) (calc (n : ℚ) ≠ 0 : int.cast_ne_zero.mpr h1),
      rw [← h3, mul_ne_zero_iff] at this,
      exact this,
    },
    have t3 : z ≠ 0 := by {
      by_contradiction,
      push_neg at h,
      have := calc 0 = x^2+y^2 : by { rw [h2, h], ring, }
      ... > 0 : add_pos (pow_two_pos_of_ne_zero x t1.1) (pow_two_pos_of_ne_zero y t1.2),
      linarith only [this],
    },
    set! k := y / (x + z) with hk, clear_value k,
    have tk : 1+k^2 ≠ 0 := by linarith only [pow_two_nonneg k],
    have t5 : x + z ≠ 0 := by {
      by_contradiction,
      push_neg at h,
      have := calc y^2 = (x+z)*(z-x) : by { ring, rw ← h2, ring, }
      ... = 0 : by { rw h, ring, },
      have : y = 0 := pow_eq_zero this,
      exact t1.2 this,
    },
    have hk': y = k * (x + z) := by { rw hk, field_simp [t5], },
    have t6 : x = (1-k^2)/(1+k^2)*z := by {
      have := calc 0 = x^2+y^2-z^2 : by { rw h2, ring, }
      ... = (x+z)*((1+k^2)*x-(1-k^2)*z) : by { rw hk', ring, },
      field_simp [t5] at this,
      field_simp [tk],
      linarith only [this],
    },
    have t7 : y = (2*k)/(1+k^2)*z := by {
      rw [hk', t6],
      field_simp [tk],
      ring,
    },
    use [1, k, (1+k^2)/z],
    split, { exact div_ne_zero tk t3, },
    rw [← h3, t6, t7],
    field_simp [t3, tk],
    ring,
  },
  rintros ⟨ h1, r, s, m, h2, h3 ⟩,
  unfold is_congr_num,
  split, { exact h1, },
  use [(r^2-s^2)/m, 2*r*s/m, (r^2+s^2)/m],
  split, { ring, },
  calc (r ^ 2 - s ^ 2) / m * (2 * r * s / m) / 2 = r * s * (r + s) * (r - s) / m ^ 2 : by { field_simp [h2], ring, }
  ... = n * m ^ 2 / m ^ 2 : by rw h3
  ... = n : by field_simp [h2],
end

lemma is_congr_num_iff_ec (n : ℤ) :
is_congr_num n ↔ 0 < n ∧ (∃ x y : ℚ, y ≠ 0 ∧ y ^ 2 = x ^ 3 - n ^ 2 * x) :=
begin
  rw is_congr_num_iff_rsQ,
  split, {
    rintros ⟨ h1, r, s, m, h2, h3 ⟩,
    split, { exact h1, },
    replace h1 : n ≠ 0 := by linarith only [h1],
    have t1 : s ≠ 0 := by {
      by_contradiction, push_neg at h,
      have := calc r * s * (r + s) * (r - s) = n * m ^ 2 : h3
      ... ≠ 0 : mul_ne_zero (calc (n : ℚ) ≠ 0 : int.cast_ne_zero.mpr h1) (pow_ne_zero 2 h2),
      rw h at this,
      simp at this,
      exact this,
    },
    use [n*r/s, n^2*m/s^2],
    split, { field_simp [t1, h1, h2], },
    have t2 : (n : ℚ) = r * s * (r + s) * (r - s) / m ^ 2 := by { field_simp [h2], exact h3.symm, },
    rw t2,
    field_simp [h2, t1],
    ring,
  },
  rintros ⟨ h1, x, y, h2, h3 ⟩,
  split, { exact h1, },
  replace h1 : n ≠ 0 := by linarith only [h1],
  use [x/n, 1, y/n^2],
  split, { exact div_ne_zero h2 (pow_ne_zero 2 (calc (n : ℚ) ≠ 0 : int.cast_ne_zero.mpr h1)), },
  field_simp [h1],
  rw h3,
  ring,
end

example : is_congr_num 5 :=
begin
  unfold is_congr_num,
  split, { norm_num, },
  use [3/2, 20/3, 41/6],
  norm_num,
end

example : is_congr_num 6 :=
begin
  unfold is_congr_num,
  split, { norm_num, },
  use [3, 4, 5],
  norm_num,
end

example : is_congr_num 7 :=
begin
  unfold is_congr_num,
  split, { norm_num, },
  use [35/12, 24/5, 337/60],
  norm_num,
end

-- just slow
/- example : is_congr_num 157 :=
begin
  unfold is_congr_num,
  split, { norm_num, },
  use [411340519227716149383203/21666555693714761309610,
    6803298487826435051217540/411340519227716149383203,
    224403517704336969924557513090674863160948472041/8912332268928859588025535178967163570016480830],
  norm_num,
end -/

def heegner7 := ∀ p : ℕ, nat.prime p → p % 8 = 7 → is_congr_num p

def cnp := ∀ n : ℕ, (n % 8 = 5 ∨ n % 8 = 6 ∨ n % 8 = 7) → is_congr_num n

theorem fermat123 (n : ℕ) (hn : n = 1 ∨ n = 2 ∨ (nat.prime n ∧ n % 8 = 3)) : ¬ is_congr_num n :=
begin
  intro h0,
  have hn' : n > 0 := by {
    rcases hn with hn | hn | hn,
    { linarith only [hn], },
    { linarith only [hn], },
    exact nat.prime.pos hn.1,
  },
  have h_infinite_descent : ∀ N : ℕ, ¬ (∃ (x y z : ℤ) (m : ℚ), 0 < x ∧ 0 < y ∧ 0 < z ∧ 0 < m
  ∧ x.gcd y = 1 ∧ x ^ 2 + y ^ 2 = z ^ 2 ∧ (x : ℚ) * y / 2 = n * m ^ 2 ∧ z ≤ N) := by {
    intro N,
    induction N with N hind, {
      rintros ⟨ x, y, z, m, hxpos, hypos, hzpos, hmpos, h1, h2, h3, h4 ⟩,
      norm_cast at h4,
      linarith only [hzpos, h4],
    },
    rintros ⟨ x, y, z, m', hxpos, hypos, hzpos, hmpos, h1, h2, h3, h4 ⟩,
    rcases pythagorean_triple.coprime_classification_pos hxpos hypos hzpos h2 h1
      with ⟨ a, b, ha, hb, hab, hxy, hz, h12cop, hparity ⟩,
    have h3' : (a:ℚ)*b*(a+b)*(a-b)=(x:ℚ)*y/2 := by {
      rcases hxy with ⟨ t1a, t1b ⟩ | ⟨ t1a, t1b ⟩,
      { rw [t1a, t1b], cancel_denoms, norm_cast, ring, },
      { rw [t1a, t1b], cancel_denoms, norm_cast, ring, },
    },
    rw h3 at h3', norm_cast at h3',
    have : ∃ m : ℤ, m' = m := by {
      sorry,
    },
    cases this with m hm,
    rw hm at hmpos h3 h3',
    norm_cast at hmpos h3',
    clear hm m',
    have key : ∃ r s u v : ℤ, a=r^2 ∧ b=n*s^2 ∧ a+b=u^2 ∧ a-b=v^2 ∧ r%2=1 ∧ s%2=0 := by {
      have h13cop : a.gcd (a+b) = 1 := by { rw gcd_add a b 1 at h12cop, rw ← h12cop, rw add_comm, ring, },
      have h14cop : a.gcd (a-b) = 1 := by { rw [gcd_neg a b, gcd_add a (-b) 1] at h12cop, rw ← h12cop, rw add_comm, ring, },
      have h23cop : b.gcd (a+b) = 1 := by { rw [int.gcd_comm, gcd_add b a 1] at h12cop, rw ← h12cop, ring, },
      have h24cop : b.gcd (a-b) = 1 := by { rw [int.gcd_comm, gcd_add b a (-1)] at h12cop, rw ← h12cop, ring, },
      have h34cop : (a+b).gcd (a-b) = 1 := by sorry,
      have h123cop : (a*b).gcd (a+b) = 1 := by { rw [mul_gcd a b (a+b) h12cop, h13cop, h23cop], ring, },
      have h124cop : (a*b).gcd (a-b) = 1 := by { rw [mul_gcd a b (a-b) h12cop, h14cop, h24cop], ring, },
      -- have h134cop : (a*(a+b)).gcd (a-b) = 1 := by { rw [mul_gcd a (a+b) (a-b) h13cop, h14cop, h34cop], ring, },
      have h1234cop : (a*b*(a+b)).gcd (a-b) = 1 := by { rw [mul_gcd (a*b) (a+b) (a-b) h123cop, h124cop, h34cop], ring, },
      have haplusb : 0 < a + b := by linarith only [ha, hb],
      have haminusb : 0 < a - b := by linarith only [hab],
      have hpos2 := mul_pos ha hb,
      have hpos3 := mul_pos hpos2 haplusb,
      -- have hpos4 := mul_pos hpos3 haminusb,
      cases hn with hn hn, {
        rw hn at h3' ⊢,
        norm_cast at h3' ⊢,
        rw one_mul at h3',
        rcases int_pow_coprime hpos3 haminusb h1234cop h3' with ⟨ a3, v, ha3p, hvp, hab3cop, ha3, hv ⟩,
        rcases int_pow_coprime hpos2 haplusb h123cop ha3 with ⟨ a2, u, ha2p, hup, hab2cop, ha2, hu ⟩,
        rcases int_pow_coprime ha hb h12cop ha2 with ⟨ r, s, hrp, hsp, hab1cop, hr, hs ⟩,
        use [r, s, u, v, hr],
        split, { ring, exact hs, },
        use [hu, hv],
        rcases hparity with ⟨ hpa, hpb ⟩ | ⟨ hpa, hpb ⟩, {
          exfalso,
          rw hr at hpa,
          replace hpa := int_even_sq_mod_4 r ((int_even_iff_sq_even r).2 hpa),
          rw ← hr at hpa,
          rw hs at hpb,
          replace hpb := int_odd_sq_mod_4 s ((int_odd_iff_sq_odd s).2 hpb),
          rw ← hs at hpb,
          apply_fun (λ x : ℤ, x % 4) at hv,
          rw [int.sub_mod, hpa, hpb] at hv,
          cases int_sq_mod_4 v with h h,
          { rw h at hv, norm_num at hv, },
          { rw h at hv, norm_num at hv, },
        }, {
          rw hr at hpa,
          use (int_odd_iff_sq_odd r).2 hpa,
          rw hs at hpb,
          use (int_even_iff_sq_even s).2 hpb,
        },
      },
      have hnp : nat.prime n := by {
        cases hn with hn hn,
        { rw hn, exact nat.prime_two, },
        exact hn.1,
      },
      rcases int_pow_coprime_prime hpos3 haminusb h1234cop hnp h3' with
      ⟨ a3, v, ha3p, hvp, hab3cop, ⟨ ha3, hv ⟩ | ⟨ ha3, hv ⟩ ⟩, {
        rcases int_pow_coprime_prime hpos2 haplusb h123cop hnp ha3 with
        ⟨ a2, u, ha2p, hup, hab2cop, ⟨ ha2, hu ⟩ | ⟨ ha2, hu ⟩ ⟩, {
          rcases int_pow_coprime_prime ha hb h12cop hnp ha2 with
          ⟨ r, s, hrp, hsp, hab1cop, ⟨ hr, hs ⟩ | ⟨ hr, hs ⟩ ⟩, {
            exfalso,
            sorry,
          }, {
            use [r, s, u, v, hr, hs, hu, hv],
            rcases hparity with ⟨ hpa, hpb ⟩ | ⟨ hpa, hpb ⟩, {
              exfalso,
              rw hs at hpb,
              cases hn with hn hn,
              { rw [hn, int.mul_mod] at hpb, simp at hpb, exact hpb, },
              rw hr at hpa,
              replace hpa := int_even_sq_mod_4 r ((int_even_iff_sq_even r).2 hpa),
              rw ← hr at hpa,
              rw [← int.not_even_iff, int.even_mul, not_or_distrib] at hpb,
              replace hpb := int_odd_sq_mod_4 s ((int_odd_iff_sq_odd s).2 (int.not_even_iff.1 hpb.2)),
              replace hn : (n : ℤ) % 4 = 3 := by {
                norm_cast,
                rw [← nat.mod_mod_of_dvd n (calc 4 ∣ 8 : by norm_num), hn.2],
                norm_num,
              },
              apply_fun (λ x : ℤ, x % 4) at hu,
              rw [int.add_mod, hpa, hs, int.mul_mod, hpb, hn] at hu,
              cases int_sq_mod_4 u with h h,
              { rw h at hu, norm_num at hu, },
              { rw h at hu, norm_num at hu, },
            }, {
              rw hr at hpa,
              replace hpa := (int_odd_iff_sq_odd r).2 hpa,
              use hpa,
              cases hn with hn hn, {
                by_contradiction,
                rw int.mod_two_ne_zero at h,
                apply_fun (λ x : ℤ, x % 4) at hu,
                rw [int.add_mod, hr, hs, int.mul_mod, int_odd_sq_mod_4 r hpa, int_odd_sq_mod_4 s h, hn] at hu,
                cases int_sq_mod_4 u with h h,
                { rw h at hu, norm_num at hu, },
                { rw h at hu, norm_num at hu, },
              },
              rw [← int.even_iff, hs, int.even_mul] at hpb,
              replace hn : ¬ even (n : ℤ) := by {
                rw int.not_even_iff,
                norm_cast,
                rw [← nat.mod_mod_of_dvd n (calc 2 ∣ 8 : by norm_num), hn.2],
                norm_num,
              },
              cases hpb with hpb hpb, { exfalso, exact hn hpb, },
              rw [int.even_iff, ← int_even_iff_sq_even s] at hpb,
              exact hpb,
            },
          },
        }, {
          exfalso,
          rcases int_pow_coprime ha hb h12cop ha2 with ⟨ r, s, hrp, hsp, hab1cop, hr, hs ⟩,
          have k1 : (a+b)%4=1 := by {
            rcases hparity with ⟨ hpa, hpb ⟩ | ⟨ hpa, hpb ⟩, {
              rw hr at hpa,
              replace hpa := int_even_sq_mod_4 r ((int_even_iff_sq_even r).2 hpa),
              rw ← hr at hpa,
              rw hs at hpb,
              replace hpb := int_odd_sq_mod_4 s ((int_odd_iff_sq_odd s).2 hpb),
              rw ← hs at hpb,
              rw [int.add_mod, hpa, hpb], norm_num,
            }, {
              rw hr at hpa,
              replace hpa := int_odd_sq_mod_4 r ((int_odd_iff_sq_odd r).2 hpa),
              rw ← hr at hpa,
              rw hs at hpb,
              replace hpb := int_even_sq_mod_4 s ((int_even_iff_sq_even s).2 hpb),
              rw ← hs at hpb,
              rw [int.add_mod, hpa, hpb], norm_num,
            },
          },
          rw [hu, int.mul_mod] at k1,
          cases int_sq_mod_4 u with k2 k2, {
            rw k2 at k1, norm_num at k1, exact k1,
          },
          cases hn with hn hn, {
            rw [k2, hn] at k1, norm_num at k1,
          },
          replace hn : (n : ℤ) % 4 = 3 := by {
            norm_cast,
            rw [← nat.mod_mod_of_dvd n (calc 4 ∣ 8 : by norm_num), hn.2],
            norm_num,
          },
          rw [k2, hn] at k1, norm_num at k1,
        },
      }, {
        exfalso,
        rcases int_pow_coprime hpos2 haplusb h123cop ha3 with ⟨ a2, u, ha2p, hup, hab2cop, ha2, hu ⟩,
        rcases int_pow_coprime ha hb h12cop ha2 with ⟨ r, s, hrp, hsp, hab1cop, hr, hs ⟩,
        sorry,
      },
    },
    rcases key with ⟨ r, s, u, v, hr, hs, hu, hv, hpa, hpb ⟩,
    clear hparity,
    set! x' := (u-v)/2 with hx', clear_value x',
    replace hx' : x'*2=u-v := by {
      rw hx',
      have : (u-v)%2=0 := by {
        have t1 := calc 2*(a-u*v) = (a+b)+(a-b)-2*u*v : by ring
        ... = u^2+v^2-2*u*v : by rw [hu, hv]
        ... = (u-v)^2 : by ring,
        have t2 : (2*(a-u*v))%2=0 := int.mul_mod_right 2 (a-u*v),
        rw [← int.even_iff, t1, int.even_pow, int.even_iff] at t2,
        exact t2.1,
      },
      exact int.div_mul_cancel_of_mod_eq_zero this,
    },
    set! y' := x'+v with hy', clear_value y',
    replace hy' := calc y'*2=(x'+v)*2 : by rw hy'
    ... = x'*2+v*2 : by ring
    ... = (u-v)+v*2 : by rw hx'
    ... = u+v : by ring,
    have hbxy := calc b*2=(a+b)-(a-b) : by ring
    ... = (u+v)*(u-v) : by { rw [hu, hv], ring, }
    ... = x'*y'*2*2 : by { rw [← hx', ← hy'], ring, },
    rw mul_left_inj' (calc (2:ℤ) ≠ 0 : by norm_num) at hbxy,
    set! s' := s/2 with hs', clear_value s',
    replace hs' : s'*2=s := by { rw hs', exact int.div_mul_cancel_of_mod_eq_zero hpb, },
    have hpy := calc 4*(x'^2+y'^2) = (x'*2)^2+(y'*2)^2 : by ring
    ... = 2*u^2 + 2*v^2 : by { rw [hx', hy'], ring, }
    ... = 4*(r^2) : by { rw [← hu, ← hv, hr], ring, },
    rw mul_right_inj' (calc (4 : ℤ) ≠ 0 : by norm_num) at hpy,
    have hcoprime : x'.gcd y' = 1 := by {
      sorry,
    },
    apply hind,
    use [x', y', r, s'],
    split, { exact hpy, },
    split, { exact hcoprime, },
    sorry,
  },
  rw is_congr_num_iff_xyzZpos_coprime n at h0,
  replace h0 := h0.2,
  rcases h0 with ⟨ x, y, z, m, hxpos, hypos, hzpos, hmpos, h1, h2, h3 ⟩,
  set! N := z with hN, clear_value N,
  lift N to ℕ using (calc N ≥ 0 : by linarith only [hzpos, hN]),
  apply h_infinite_descent N,
  use [x, y, z, m],
  replace hN : z ≤ (N : ℤ) := by linarith only [hN],
  exact ⟨ hxpos, hypos, hzpos, hmpos, h1, h2, h3, hN ⟩,
end