/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.limits.shapes.terminal

/-!

# `with_initial` and `with_terminal`

Given a category `C`, this file constructs two objects:
1. `with_terminal C`, the category built from `C` by formally adjoining a terminal object.
2. `with_initial C`, the category built from `C` by formally adjoining an initial object.

The terminal resp. initial object is `with_terminal.star` resp. `with_initial.star`, and
the proofs that these are terminal resp. initial are in `with_terminal.star_terminal`
and `with_initial.star_initial`.

The inclusion from `C` intro `with_terminal C` resp. `with_initial C` is denoted
`with_terminal.incl` resp. `with_initial.incl`.

The relevant constructions needed for the universal properties of these constructions are:
1. `lift`, which lifts `F : C ⥤ D` to a functor from `with_terminal C` resp. `with_initial C` in
  the case where an object `Z : D` is provided satisfying some additional conditions.
2. `incl_lift` shows that the composition of `lift` with `incl` is isomorphic to the
  functor which was lifted.
3. `lift_unique` provides the uniqueness property of `lift`.

In addition to this, we provide `with_terminal.map` and `with_initinal.map` providing the
functoriality of these constructions with respect to functors on the base categories.

-/

namespace category_theory

universes v u

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

/-- Formally adjoin a terminal object to a category. -/
@[derive inhabited]
inductive with_terminal : Type u
| of : C → with_terminal
| star : with_terminal

/-- Formally adjoin an initial object to a category. -/
@[derive inhabited]
inductive with_initial : Type u
| of : C → with_initial
| star : with_initial

namespace with_terminal

local attribute [tidy] tactic.case_bash
variable {C}

/-- Morphisms for `with_terminal C`. -/
@[simp, nolint has_inhabited_instance]
def hom : with_terminal C → with_terminal C → Type v
| (of X) (of Y) := X ⟶ Y
| star (of X) := pempty
| _ star := punit

/-- Identity morphisms for `with_terminal C`. -/
@[simp]
def id : Π (X : with_terminal C), hom X X
| (of X) := 𝟙 _
| star := punit.star

/-- Composition of morphisms for `with_terminal C`. -/
@[simp]
def comp : Π {X Y Z : with_terminal C}, hom X Y → hom Y Z → hom X Z
| (of X) (of Y) (of Z) := λ f g, f ≫ g
| (of X) _ star := λ f g, punit.star
| star (of X) _ := λ f g, pempty.elim f
| _ star (of Y) := λ f g, pempty.elim g
| star star star := λ _ _, punit.star

instance : category.{v} (with_terminal C) :=
{ hom := λ X Y, hom X Y,
  id := λ X, id _,
  comp := λ X Y Z f g, comp f g }

/-- The inclusion from `C` into `with_terminal C`. -/
def incl : C ⥤ (with_terminal C) :=
{ obj := of,
  map := λ X Y f, f }

instance : full (incl : C ⥤ _) :=
{ preimage := λ X Y f, f }

instance : faithful (incl : C ⥤ _) := {}

/-- Map `with_terminal` with respect to a functor `F : C ⥤ D`. -/
def map {D : Type*} [category D] (F : C ⥤ D) : with_terminal C ⥤ with_terminal D :=
{ obj := λ X,
    match X with
    | of x := of $ F.obj x
    | star := star
    end,
  map := λ X Y f,
    match X, Y, f with
    | of x, of y, f := F.map f
    | of x, star, punit.star := punit.star
    | star, star, punit.star := punit.star
    end }

instance {X : with_terminal C} : unique (X ⟶ star) :=
{ default :=
    match X with
    | of x := punit.star
    | star := punit.star
    end,
  uniq := by tidy }

/-- `with_terminal.star` is terminal. -/
def star_terminal : limits.is_terminal (star : with_terminal C) :=
limits.is_terminal.of_unique _

/-- Lift a functor `F : C ⥤ D` to `with_term C ⥤ D`. -/
@[simps]
def lift {D : Type*} [category D] {Z : D} (F : C ⥤ D) (M : Π (x : C), F.obj x ⟶ Z)
  (hM : ∀ (x y : C) (f : x ⟶ y), F.map f ≫ M y = M x) :
  (with_terminal C) ⥤ D :=
{ obj := λ X,
    match X with
    | of x := F.obj x
    | star := Z
    end,
  map := λ X Y f,
    match X, Y, f with
    | of x, of y, f := F.map f
    | of x, star, punit.star := M x
    | star, star, punit.star := 𝟙 Z
    end }

/-- The isomorphism between `incl ⋙ lift F _ _` with `F`. -/
@[simps]
def incl_lift {D : Type*} [category D] {Z : D} (F : C ⥤ D) (M : Π (x : C), F.obj x ⟶ Z)
  (hM : ∀ (x y : C) (f : x ⟶ y), F.map f ≫ M y = M x) :
  incl ⋙ lift F M hM ≅ F :=
{ hom := { app := λ X, 𝟙 _ },
  inv := { app := λ X, 𝟙 _ } }

/-- The isomorphism between `(lift F _ _).obj with_terminal.star` with `Z`. -/
@[simps]
def lift_star {D : Type*} [category D] {Z : D} (F : C ⥤ D) (M : Π (x : C), F.obj x ⟶ Z)
  (hM : ∀ (x y : C) (f : x ⟶ y), F.map f ≫ M y = M x) :
  (lift F M hM).obj star ≅ Z := eq_to_iso rfl

lemma lift_map_lift_star {D : Type*} [category D] {Z : D} (F : C ⥤ D) (M : Π (x : C), F.obj x ⟶ Z)
  (hM : ∀ (x y : C) (f : x ⟶ y), F.map f ≫ M y = M x) (x : C) :
  (lift F M hM).map (star_terminal.from (incl.obj x)) ≫ (lift_star F M hM).hom =
  (incl_lift F M hM).hom.app x ≫ M x :=
begin
  erw [category.id_comp, category.comp_id],
  refl,
end

/-- The uniqueness of `lift`. -/
@[simp]
def lift_unique {D : Type*} [category D] {Z : D} (F : C ⥤ D)
  (M : Π (x : C), F.obj x ⟶ Z) (hM : ∀ (x y : C) (f : x ⟶ y), F.map f ≫ M y = M x)
  (G : with_terminal C ⥤ D) (h : incl ⋙ G ≅ F) (hG : G.obj star ≅ Z)
  (hh : ∀ x : C, G.map (star_terminal.from (incl.obj x)) ≫ hG.hom = h.hom.app x ≫ M x) :
  G ≅ lift F M hM :=
nat_iso.of_components (λ X,
  match X with
  | of x := h.app x
  | star := hG
  end)
begin
  rintro (X|X) (Y|Y) f,
  { apply h.hom.naturality },
  { cases f, exact hh _ },
  { cases f, },
  { cases f,
    change G.map (𝟙 _) ≫ hG.hom = hG.hom ≫ 𝟙 _,
    simp }
end

/-- A variant of `lift` with `Z` a terminal object. -/
@[simps]
def lift_to_terminal {D : Type*} [category D] {Z : D} (F : C ⥤ D) (hZ : limits.is_terminal Z) :
  with_terminal C ⥤ D :=
lift F (λ x, hZ.from _) (λ x y f, hZ.hom_ext _ _)

/-- A variant of `incl_lift` with `Z` a terminal object. -/
@[simps]
def incl_lift_to_terminal {D : Type*} [category D] {Z : D} (F : C ⥤ D) (hZ : limits.is_terminal Z) :
  incl ⋙ lift_to_terminal F hZ ≅ F := incl_lift _ _ _

/-- A variant of `lift_unique` with `Z` a terminal object. -/
@[simps]
def lift_to_terminal_unique {D : Type*} [category D] {Z : D} (F : C ⥤ D) (hZ : limits.is_terminal Z)
  (G : with_terminal C ⥤ D) (h : incl ⋙ G ≅ F) (hG : G.obj star ≅ Z) :
  G ≅ lift_to_terminal F hZ :=
lift_unique F (λ z, hZ.from _) (λ x y f, hZ.hom_ext _ _) G h hG (λ x, hZ.hom_ext _ _)

/-- Constructs a morphism to `star` from `of X`. -/
@[simp]
def hom_from (X : C) : incl.obj X ⟶ star := star_terminal.from _

instance is_iso_of_from_star {X : with_terminal C} (f : star ⟶ X) : is_iso f :=
by tidy

end with_terminal

namespace with_initial

local attribute [tidy] tactic.case_bash
variable {C}

/-- Morphisms for `with_initial C`. -/
@[simp, nolint has_inhabited_instance]
def hom : with_initial C → with_initial C → Type v
| (of X) (of Y) := X ⟶ Y
| (of X) _ := pempty
| star _ := punit

/-- Identity morphisms for `with_initial C`. -/
@[simp]
def id : Π (X : with_initial C), hom X X
| (of X) := 𝟙 _
| star := punit.star

/-- Composition of morphisms for `with_initial C`. -/
@[simp]
def comp : Π {X Y Z : with_initial C}, hom X Y → hom Y Z → hom X Z
| (of X) (of Y) (of Z) := λ f g, f ≫ g
| star _ (of X) := λ f g, punit.star
| _ (of X) star := λ f g, pempty.elim g
| (of Y) star _ := λ f g, pempty.elim f
| star star star := λ _ _, punit.star

instance : category.{v} (with_initial C) :=
{ hom := λ X Y, hom X Y,
  id := λ X, id _,
  comp := λ X Y Z f g, comp f g }

/-- The inclusion of `C` into `with_initial C`. -/
def incl : C ⥤ (with_initial C) :=
{ obj := of,
  map := λ X Y f, f }

instance : full (incl : C ⥤ _) :=
{ preimage := λ X Y f, f }

instance : faithful (incl : C ⥤ _) := {}

/-- Map `with_initial` with respect to a functor `F : C ⥤ D`. -/
def map {D : Type*} [category D] (F : C ⥤ D) : with_initial C ⥤ with_initial D :=
{ obj := λ X,
    match X with
    | of x := of $ F.obj x
    | star := star
    end,
  map := λ X Y f,
    match X, Y, f with
    | of x, of y, f := F.map f
    | star, of x, punit.star := punit.star
    | star, star, punit.star := punit.star
    end }

instance {X : with_initial C} : unique (star ⟶ X) :=
{ default :=
    match X with
    | of x := punit.star
    | star := punit.star
    end,
  uniq := by tidy }

/-- `with_initial.star` is initial. -/
def star_initial : limits.is_initial (star : with_initial C) :=
limits.is_initial.of_unique _

/-- Lift a functor `F : C ⥤ D` to `with_initial C ⥤ D`. -/
@[simps]
def lift {D : Type*} [category D] {Z : D} (F : C ⥤ D) (M : Π (x : C), Z ⟶ F.obj x)
  (hM : ∀ (x y : C) (f : x ⟶ y), M x ≫ F.map f = M y) :
  (with_initial C) ⥤ D :=
{ obj := λ X,
    match X with
    | of x := F.obj x
    | star := Z
    end,
  map := λ X Y f,
    match X, Y, f with
    | of x, of y, f := F.map f
    | star, of x, punit.star := M _
    | star, star, punit.star := 𝟙 _
    end }

/-- The isomorphism between `incl ⋙ lift F _ _` with `F`. -/
@[simps]
def incl_lift {D : Type*} [category D] {Z : D} (F : C ⥤ D)
  (M : Π (x : C), Z ⟶ F.obj x) (hM : ∀ (x y : C) (f : x ⟶ y), M x ≫ F.map f = M y) :
  incl ⋙ lift F M hM ≅ F :=
{ hom := { app := λ X, 𝟙 _ },
  inv := { app := λ X, 𝟙 _ } }

/-- The isomorphism between `(lift F _ _).obj with_term.star` with `Z`. -/
@[simps]
def lift_star {D : Type*} [category D] {Z : D} (F : C ⥤ D)
  (M : Π (x : C), Z ⟶ F.obj x) (hM : ∀ (x y : C) (f : x ⟶ y), M x ≫ F.map f = M y) :
  (lift F M hM).obj star ≅ Z := eq_to_iso rfl

lemma lift_star_lift_map {D : Type*} [category D] {Z : D} (F : C ⥤ D)
  (M : Π (x : C), Z ⟶ F.obj x) (hM : ∀ (x y : C) (f : x ⟶ y), M x ≫ F.map f = M y) (x : C) :
  (lift_star F M hM).hom ≫ (lift F M hM).map (star_initial.to (incl.obj x)) =
  M x ≫ (incl_lift F M hM).hom.app x :=
begin
  erw [category.id_comp, category.comp_id],
  refl,
end

/-- The uniqueness of `lift`. -/
@[simp]
def lift_unique {D : Type*} [category D] {Z : D} (F : C ⥤ D)
  (M : Π (x : C), Z ⟶ F.obj x) (hM : ∀ (x y : C) (f : x ⟶ y), M x ≫ F.map f = M y)
  (G : with_initial C ⥤ D) (h : incl ⋙ G ≅ F) (hG : G.obj star ≅ Z)
  (hh : ∀ x : C, hG.symm.hom ≫ G.map (star_initial.to (incl.obj x)) = M x ≫ h.symm.hom.app x) :
  G ≅ lift F M hM :=
nat_iso.of_components
(λ X,
  match X with
  | of x := h.app x
  | star := hG
  end)
begin
  rintro (X|X) (Y|Y) f,
  { apply h.hom.naturality },
  { cases f, },
  { cases f,
    change G.map _ ≫ h.hom.app _ = hG.hom ≫ _,
    symmetry,
    erw [← iso.eq_inv_comp, ← category.assoc, hh],
    simpa },
  { cases f,
    change G.map (𝟙 _) ≫ hG.hom = hG.hom ≫ 𝟙 _,
    simp }
end

/-- A variant of `lift` with `Z` an initial object. -/
@[simps]
def lift_to_initial {D : Type*} [category D] {Z : D} (F : C ⥤ D) (hZ : limits.is_initial Z) :
  with_initial C ⥤ D :=
lift F (λ x, hZ.to _) (λ x y f, hZ.hom_ext _ _)

/-- A variant of `incl_lift` with `Z` an initial object. -/
@[simps]
def incl_lift_to_initial {D : Type*} [category D] {Z : D} (F : C ⥤ D) (hZ : limits.is_initial Z) :
  incl ⋙ lift_to_initial F hZ ≅ F := incl_lift _ _ _

/-- A variant of `lift_unique` with `Z` an initial object. -/
@[simps]
def lift_to_initial_unique {D : Type*} [category D] {Z : D} (F : C ⥤ D) (hZ : limits.is_initial Z)
  (G : with_initial C ⥤ D) (h : incl ⋙ G ≅ F) (hG : G.obj star ≅ Z) :
  G ≅ lift_to_initial F hZ :=
lift_unique F (λ z, hZ.to _) (λ x y f, hZ.hom_ext _ _) G h hG (λ x, hZ.hom_ext _ _)

/-- Constructs a morphism from `star` to `of X`. -/
@[simp]
def hom_to (X : C) : star ⟶ incl.obj X := star_initial.to _

instance is_iso_of_to_star {X : with_initial C} (f : X ⟶ star) : is_iso f :=
by tidy

end with_initial

end category_theory


import fol
import Rings.Notation
import Rings.Rings
import Rings.ToMathlib.algebraic_closure
import Rings.ToMathlib.char_p
import field_theory.is_alg_closed.classification
import set_theory.continuum
import Rings.vaught

universe u

notation h :: t  := dvector.cons h t
notation `[` l:(foldr `, ` (h t, dvector.cons h t) dvector.nil `]`) := l

local infix ` ≃ `:64 := fol.bounded_preformula.bd_equal

namespace Fields

open fol Rings Rings.ring_signature Rings.struc_to_ring_struc

/-- The sentence "every non-zero element has a multiplicative inverse" -/
def mul_inv : sentence ring_signature :=
∀' (x_ 1 ≃ 0) ⊔ (∃' x_ 1 * x_ 0 ≃ 1)

/-- The sentence "zero is not equal to one", implying the ring is non-trivial -/
def non_triv : sentence ring_signature := 0 ≄ 1

/-- The theory of fields in the language of rings -/
def field_theory : Theory ring_signature := ring_theory ∪ {mul_inv , non_triv}

lemma mul_inv_in_field_theory : mul_inv ∈ field_theory :=
begin right, left, refl end

lemma non_triv_in_field_theory : non_triv ∈ field_theory :=
begin right, right, exact set.mem_singleton _ end

lemma ring_theory_sub_field_theory : ring_theory ⊆ field_theory :=
begin intros f hf, left, exact hf end

namespace field_to

variables (K : Type u) [field K]

lemma K_is_field : is_field K := field.to_is_field K

open Rings.models_ring_theory_to_comm_ring

lemma realize_field_theory :
  Structure K ⊨ field_theory :=
begin
  intros ϕ h,
  cases h,
  {apply (comm_ring_to_model.realize_ring_theory K h)},
  repeat {cases h},
   { intro,
     simp only [fol.bd_or, models_ring_theory_to_comm_ring.realize_one,
       struc_to_ring_struc.func_map, fin.val_zero', realize_bounded_formula_not,
       struc_to_ring_struc.binaries_map, fin.val_eq_coe, dvector.last,
       realize_bounded_formula_ex, realize_bounded_term_bd_app,
       realize_bounded_formula, realize_bounded_term,
       fin.val_one, dvector.nth, models_ring_theory_to_comm_ring.realize_zero],
     apply is_field.mul_inv_cancel (K_is_field K) },
  { simp [fol.realize_sentence] },
end

/-- Fields are models of the theory of fields -/
def models_field_theory : Model field_theory.{u} :=
⟨ Structure K ,  realize_field_theory _ ⟩

end field_to

namespace models_theory_of_fields_to_is_field

variables {M : Structure ring_signature} [h : fact (M ⊨ field_theory)]
-- M inherits instances of 0 1 - + * from Rings.ModelTo

include h

instance ring_model : fact (M ⊨ ring_theory) :=
⟨ all_realize_sentence_of_subset h.1 ring_theory_sub_field_theory ⟩

lemma zero_ne_one : (0 : M) ≠ 1 :=
by { have h1 := h.1, have h2 := h1 non_triv_in_field_theory, simpa [h2] }

lemma mul_inv (a : M) (ha : a ≠ 0) : (∃ (b : M), a * b = 1) :=
by { have h1 := h.1, have hmulinv := h1 mul_inv_in_field_theory, by simpa using hmulinv a ha }

lemma is_field : is_field M :=
{ exists_pair_ne := ⟨ 0 , 1 , zero_ne_one ⟩,
  mul_comm := mul_comm,
  mul_inv_cancel := mul_inv }

noncomputable instance field : field M :=
is_field.to_field M is_field

end models_theory_of_fields_to_is_field

/-- GenPoly n is the polynomial aₙ₊₁ xⁿ + ⋯ + a₂ x + a₁
 where aₖ = x_ k and x = x_ 0, i.e. we are seeing the variables x_ k with 0 < k as coefficients
 and x_ 0 as the indeterminate -/
@[simp] def gen_poly : Π (n : ℕ), bounded_ring_term (n + 2)
| 0       := x_ ⟨ 1 , dec_trivial ⟩
| (n + 1) :=
  (x_ ⟨ n + 2 , add_lt_add_right (nat.lt_succ_self _) _ ⟩)
  * (npow_rec (n + 1) (x_ ⟨ 0 , nat.zero_lt_succ _ ⟩)) +
  bounded_preterm.lift_succ (gen_poly n)

/-- Adds a monic term at the beginning of gen_poly.
 We will require that these polynomials have solutions for `algebraically closed`.
 We cannot just use gen_poly as we need the polynomials to have 0 < deg -/
@[simp] def gen_monic_poly (n : ℕ) : bounded_term ring_signature (n + 2) :=
npow_rec (n + 1) (x_ 0) + gen_poly n

section poly_lemmas

variables {A : Type u} [hcomm : comm_ring A] [hnt : nontrivial A] [hde : decidable_eq A]

include hcomm hnt hde

/-- xᵐ has degree m -/
lemma deg_pow {n m : ℕ} {as : dvector A (n + 1)} :
  (polynomial.term_evaluated_at_coeffs as
    (npow_rec m x_ ⟨ 0 , nat.zero_lt_succ _ ⟩)).degree = m :=
begin
  rw polynomial.term_evaluated_at_coeffs_pow,
  apply polynomial.degree_X_pow,
end

/-- degree of gen_poly n < n + 1 -/
lemma gen_poly_degree : Π {n} {as : dvector A (n + 1)},
  (polynomial.term_evaluated_at_coeffs as (gen_poly n)).degree < n.succ
| nat.zero as :=
begin
  simp only [gen_poly],
  have h : polynomial.term_evaluated_at_coeffs as x_ ⟨ 1 , _ ⟩
    = polynomial.C (as.nth' 0),
  {rw ← polynomial.term_evaluated_at_coeffs_coeff, simp only [fin.val_zero'] },
  rw h,
  by_cases h0 : as.nth' 0 = 0,
  { rw [h0, polynomial.C_0, polynomial.degree_zero],
    dec_trivial },
  { rw polynomial.degree_C h0,
    dec_trivial }
end
| (nat.succ n) as :=
begin
  simp only [gen_poly, polynomial.term_evaluated_at_coeffs_add,
    polynomial.term_evaluated_at_coeffs_monomial' (nat.lt_succ_self _),
    polynomial.lift_succ_remove_last],
  apply has_le.le.trans_lt (polynomial.degree_add_le _ _),
  apply max_lt,
  { apply has_le.le.trans_lt (polynomial.degree_monomial_le _ _),
    exact with_bot.succ_lt_succ_succ },
  { apply lt_trans (@gen_poly_degree n (dvector.remove_mth (n.succ + 2) as)),
    exact with_bot.succ_lt_succ_succ },
end

/-- gen_monic_poly has non-zero degree -/
lemma gen_monic_poly_non_const {n} {as : dvector A (n + 1)} :
  polynomial.degree (polynomial.term_evaluated_at_coeffs as (gen_monic_poly n)) ≠ 0 :=
begin
  apply ne_of_gt,
  have hp : (polynomial.term_evaluated_at_coeffs as (npow_rec (n + 1) x_ 0)).degree = n + 1,
  {apply deg_pow},
  have hq : (polynomial.term_evaluated_at_coeffs as (gen_poly n)).degree < (n + 1),
  { apply lt_of_lt_of_le gen_poly_degree,
    { rw le_iff_eq_or_lt,
      left, refl },
    exact hnt,
    exact hde },
  have hle : (polynomial.term_evaluated_at_coeffs as (gen_poly n)).degree
    < (polynomial.term_evaluated_at_coeffs as (npow_rec (n + 1) x_ 0)).degree,
  { rw hp, exact hq },
  rw [gen_monic_poly, polynomial.term_evaluated_at_coeffs_add,
    (polynomial.degree_add_eq_left_of_degree_lt hle), hp],
  dec_trivial,
end

end poly_lemmas

/-- ∀ a₁ ⋯ ∀ aₙ, ∃ x₀, (aₙ x₀ⁿ⁻¹ + ⋯ + a₂ x₀+ a₁ = 0) -/
@[simp] def all_gen_monic_poly_has_root (n : ℕ) :
  sentence ring_signature :=
fol.bd_alls (n + 1) (∃' gen_monic_poly n ≃ 0)

/-- The theory of algebraically closed fields -/
def ACF : Theory ring_signature :=
field_theory ∪ (set.range all_gen_monic_poly_has_root)
-- the latter stands for {gen_monic_polyHasSolution n | n : ℕ}

/-- The theory of algebraically closed fields of prime characteristic -/
def ACFₚ {p : ℕ} (h : nat.prime p) : Theory ring_signature :=
set.insert (p ≃ 0) ACF

/-- The sentence "`p + 1` is non-zero" for a natural p -/
@[reducible] def plus_one_ne_zero (p : ℕ) : sentence ring_signature :=
p + 1 ≄ 0

lemma injective_plus_one_ne_zero : function.injective plus_one_ne_zero :=
begin
  intros n m himage,
  simp only [plus_one_ne_zero] at himage,
  have h := (bd_app.inj (bd_app.inj (bd_notequal.inj himage).1).1).2,
  apply instances.nat_cast_bd_ring_term_inj h,
end

/-- The theory of algebraically closed fields of characterstic zero -/
def ACF₀ : Theory ring_signature := ACF ∪ (set.range plus_one_ne_zero)

lemma ACF_subset_ACFₚ {p} {h : nat.prime p} : ACF ⊆ ACFₚ h :=
set.subset_insert _ _

lemma ACF_subset_ACF₀ : ACF ⊆ ACF₀ :=
set.subset_union_left _ _

lemma realize_plus_one_ne_zero {M : Structure ring_signature} {p} :
  (M ⊨ plus_one_ne_zero p) ↔ (p.succ : M) ≠ 0 :=
by simpa only [plus_one_ne_zero, bd_notequal, realize_sentence_not,
    realize_sentence_equal, realize_closed_term,
    models_ring_theory_to_comm_ring.realize_nat,
    not_iff_not, Rings.models_ring_theory_to_comm_ring.realize_zero,
    models_ring_theory_to_comm_ring.realize_one,
    realize_bounded_term_bd_app, nat.cast_succ,
    realize_bounded_term.equations._eqn_2,
    models_ring_theory_to_comm_ring.realize_add]

namespace is_alg_closed_to

variables {K : Type u} [field K] [is_alg_closed K] [decidable_eq K]

open Rings.struc_to_ring_struc

lemma is_alg_closed.exists_root (f : polynomial K) (h : f.degree ≠ 0) :
  ∃ x : K, f.eval x = 0 :=
polynomial.exists_root_of_splits _ (is_alg_closed.splits f) h

/-- Algebraically closed fields model the theory ACF-/
lemma realize_ACF : Structure K ⊨ ACF :=
begin
  intros ϕ h,
  cases h,
  { apply field_to.realize_field_theory _ h },
  { cases h with n hϕ,
    rw ← hϕ,
    simp only [all_gen_monic_poly_has_root, realize_sentence_bd_alls,
      realize_bounded_formula_ex, realize_bounded_formula,
      models_ring_theory_to_comm_ring.realize_zero],
    intro as,
    have root := is_alg_closed.exists_root
      (polynomial.term_evaluated_at_coeffs as (gen_monic_poly n)) gen_monic_poly_non_const,
    cases root with x hx,
    rw polynomial.eval_term_evaluated_at_coeffs_eq_realize_bounded_term at hx,
    exact ⟨ x , hx ⟩ },
end

lemma realize_ACF₀ [char_zero K] : Structure K ⊨ ACF₀ :=
begin
  simp only [ACF₀, all_realize_sentence_union, all_realize_sentence_range,
    bd_notequal, realize_sentence_not, realize_sentence_equal],
  refine ⟨ realize_ACF , λ n, _ ⟩,
  simp only [realize_plus_one_ne_zero],
  intro hbot,
  have hbot1 : (n.succ : K) = ((0 : ℕ) : K) := hbot,
  have hbot2 := char_zero.cast_injective hbot1,
  exact nat.succ_ne_zero _ hbot2,
end

end is_alg_closed_to

namespace models_ACF_to
noncomputable theory

variables {M : Structure ring_signature} [hM : fact (M ⊨ ACF)]

include hM

instance models_field_theory : fact (M ⊨ field_theory) :=
by { rw [ACF, all_realize_sentence_union] at hM, exact ⟨ hM.1.1 ⟩ }

lemma realize_npow_rec
  {m n} {as : dvector M m} {t : bounded_term ring_signature m} :
  realize_bounded_term as (npow_rec n t) dvector.nil =
  (realize_bounded_term as t dvector.nil) ^ n :=
begin
  induction n with n hn,
  { simpa only [npow_rec, realize_one, realize_bounded_term,
    _root_.pow_zero] },
  { simpa only [npow_rec, models_ring_theory_to_comm_ring.realize_mul,
      realize_bounded_term, hn] },
end

lemma realize_gen_poly {n : ℕ} {root} {c : ℕ → M} :
realize_bounded_term
  (dvector.cons root (dvector.of_fn (λ (i : fin (n + 1)), c i)))
  (gen_poly n) dvector.nil =
(finset.range (n + 1)).sum (λ (x : ℕ), c x * root ^ x) :=
begin
  induction n with n hn,
  { simpa only [finset.sum_range_one, _root_.pow_zero, mul_one,
      gen_poly, dvector.nth_of_fn,
      realize_bounded_term, dvector.nth_cons _ _ _ (nat.zero_lt_one)] },
  { simp only [finset.sum_range_add, hn, finset.sum_range_one, mul_one,
      gen_poly, dvector.nth_of_fn, add_zero, fin.mk_zero, fin.val_zero',
      models_ring_theory_to_comm_ring.realize_add,
      models_ring_theory_to_comm_ring.realize_mul, realize_bounded_term,
      dvector.nth, realize_lift_succ, dvector.remove_mth,
      dvector.remove_mth_of_fn_last, hn,
      add_comm ((finset.range (n + 1)).sum (λ (x : ℕ), c x * root ^ x))],
    congr1,
    simp only [fin.val_zero', models_ring_theory_to_comm_ring.realize_mul,
      realize_bounded_term, dvector.nth, dvector.nth_of_fn,
      fin.coe_mk, realize_npow_rec] }
end

instance is_alg_closed : is_alg_closed M :=
begin
  apply is_alg_closed.of_exists_root_nat_degree,
  intros p hmonic hirr hdeg,
  simp only [ACF, all_realize_sentence_union, all_realize_sentence_range,
    all_gen_monic_poly_has_root, realize_sentence_bd_alls,
    realize_bounded_formula, models_ring_theory_to_comm_ring.realize_zero,
    realize_bounded_formula_ex] at hM,
  obtain ⟨ _ , halg_closed ⟩ := hM.1,
  set n := polynomial.nat_degree p - 1 with hn,
  set xs := dvector.of_fn (λ (i : fin (n + 1)), polynomial.coeff p i) with hxs,
  obtain ⟨ root , hroot ⟩ := halg_closed n xs,
  use root,
  convert hroot,
  rw polynomial.eval_eq_finset_sum,
  simp only [
    gen_monic_poly, models_ring_theory_to_comm_ring.realize_add,
    fin.val_zero', models_ring_theory_to_comm_ring.realize_mul,
    realize_bounded_term, dvector.nth, models_ring_theory_to_comm_ring.realize_pow],
  simp only [polynomial.monic, polynomial.leading_coeff] at hmonic,
  have hpow : npow_rec (n + 1) root = root ^ p.nat_degree,
  { simp only [pow, hn], rw nat.sub_add_cancel, refl,
    rw ← nat.one_lt_bit0_iff, exact nat.one_lt_bit0 hdeg },
  simp only [finset.sum_range_add, finset.sum_range_one,
    add_zero, hmonic, one_mul, add_comm _ (root ^ p.nat_degree), hpow, hxs, hn],
  congr,
  rw [realize_gen_poly, nat.sub_add_cancel],
  rw ← nat.one_lt_bit0_iff,
  exact nat.one_lt_bit0 hdeg,
end

variables {p : ℕ}

end models_ACF_to

variables {M : Structure ring_signature} {p : ℕ}

lemma models_ACFₚ_iff' {hp : nat.prime p} :
  M ⊨ ACFₚ hp ↔ (p : M) = 0 ∧ M ⊨ ACF :=
by simp only [ACFₚ, all_realize_sentence_insert, realize_sentence_equal,
    realize_closed_term, models_ring_theory_to_comm_ring.realize_nat,
    models_ring_theory_to_comm_ring.realize_zero]

lemma models_ACFₚ_iff [hM : fact (M ⊨ ACF)] {hp : nat.prime p} :
  M ⊨ ACFₚ hp ↔ ring_char M = p :=
begin
  rw models_ACFₚ_iff',
  split,
  { intro hmodel, apply char_p.ring_char_of_prime_eq_zero hp hmodel.1 },
  { intro hchar, refine ⟨ _ , hM.1 ⟩, rw [← hchar, ring_char.spec] },
end

instance models_ACFₚ_to_models_ACF [hp : fact (nat.prime p)] [hM : fact (M ⊨ ACFₚ hp.1)] :
  fact (M ⊨ ACF) := by { rw [models_ACFₚ_iff'] at hM, exact ⟨ hM.1.2 ⟩ }

lemma models_ACFₚ_char_p [hp : fact (nat.prime p)] [hM : fact (M ⊨ ACFₚ hp.1)] : char_p M p :=
by { convert ring_char.char_p M, rw ((@models_ACFₚ_iff _ _ _ hp.1).1 hM.1) }

instance models_ACF₀_to_models_ACF [hM : fact (M ⊨ ACF₀)] : fact (M ⊨ ACF) :=
by { rw [ACF₀, all_realize_sentence_union] at hM, exact ⟨ hM.1.1 ⟩ }

lemma models_ACF₀_char_zero [hM : fact (M ⊨ ACF)] (hM : M ⊨ ACF₀) : char_zero M :=
begin
  simp only [ACF₀, all_realize_sentence_union,
  all_realize_sentence_range, realize_plus_one_ne_zero] at hM,
  split,
  intros n,
  induction n with n hn,
  { intro m, induction m with m hm,
    { intro, refl },
    { intro hnm, exfalso, apply hM.2 m, simpa only [← realize_nat_succ, ← hnm] }},
  { intro m, induction m with m hm,
    { intro hnm, exfalso, exact hM.2 n hnm },
    { intro hnm, rw nat.succ_inj', apply hn, simp only [realize_nat_succ] at hnm,
      apply add_right_cancel hnm }}
end

instance models_ACF₀_char_zero' [hM : fact (M ⊨ ACF₀)] : char_zero M :=
models_ACF₀_char_zero hM.1

lemma models_ACF₀_iff [hM : fact (M ⊨ ACF)] :
  M ⊨ ACF₀ ↔ ring_char M = 0 :=
begin
  split,
  { intro hmodel, apply @ring_char.eq_zero _ _ (models_ACF₀_char_zero hmodel) },
  { intro hchar,
    simp only [ACF₀, all_realize_sentence_union, all_realize_sentence_range,
      plus_one_ne_zero, realize_bounded_formula_not],
    refine ⟨ hM.1 , _ ⟩, intros n hn,
    rw ring_char.eq_iff at hchar, have hchar1 := hchar.1, have hcharn := hchar1 (n + 1),
    simp only [zero_dvd_iff, nat.succ_ne_zero, nat.cast_add, nat.cast_one, iff_false] at hcharn,
    apply hcharn, convert hn, convert (@realize_nat M _ _ _ _ _ dvector.nil n).symm,
    rw Structure_structure_eq_self },
end

namespace instances

/-- alg_cl (ℤ/p) : Type* as a ring structure -/
@[reducible] def algebraic_closure_of_zmod {p : ℕ} (hp : nat.prime p) :
  Structure ring_signature :=
Rings.struc_to_ring_struc.Structure (@algebraic_closure.of_ulift_zmod p ⟨ hp ⟩)

/-- alg_cl (ℤ/p) : Type* is algebraically closed of characteristic p -/
theorem algebraic_closure_of_zmod_models_ACFₚ {p : ℕ} (hp : nat.prime p) :
  algebraic_closure_of_zmod hp ⊨ ACFₚ hp :=
begin
  rw models_ACFₚ_iff',
  split,
  { have h := @algebraic_closure.of_ulift_zmod.char_p p ⟨ hp ⟩,
    rw ← ring_char.eq_iff at h,
    rw ring_char.spec,
    have hrw : ring_char (@algebraic_closure.of_ulift_zmod p ⟨ hp ⟩) =
      ring_char ↥(Structure (@algebraic_closure.of_ulift_zmod p ⟨ hp ⟩)),
    { refl },
    rw hrw at h,
    rw h },
  { classical,
    apply is_alg_closed_to.realize_ACF },
end

/-- ℚ̅ : Type* as a ring structure -/
@[reducible] def algebraic_closure_of_rat :
  Structure ring_signature :=
Rings.struc_to_ring_struc.Structure algebraic_closure.of_ulift_rat

instance algebraic_closure_of_rat_models_ACF : fact (algebraic_closure_of_rat ⊨ ACF) :=
by {split, classical, apply is_alg_closed_to.realize_ACF }

instance : char_zero algebraic_closure_of_rat :=
{ cast_injective :=
begin
  intros n m hnm,
  apply algebraic_closure.of_ulift_rat.char_zero.1,
  exact hnm,
end }

/-- ℚ̅ : Type* is algebraically closed of characteristic zero -/
theorem algebraic_closure_of_rat_models_ACF₀ :
  algebraic_closure_of_rat ⊨ ACF₀ :=
models_ACF₀_iff.2 ring_char.eq_zero

end instances

namespace is_complete_ACF₀

open_locale fol cardinal
open Rings dvector fol cardinal

@[reducible] def comm_ring_ulift : comm_ring (ulift.{u} ℤ) := equiv.comm_ring equiv.ulift
local attribute [instance] comm_ring_ulift

def ulift.down_ring_hom_int : ulift.{u} ℤ →+* ℤ :=
{ to_fun := equiv.ulift.to_fun,
  map_one' := rfl,
  map_mul' := by finish,
  map_zero' := rfl,
  map_add' := by finish }

def ulift.down_ring_hom_zmod {p : ℕ} [fact p.prime] : ulift.{u} (zmod p) →+* zmod p :=
{ to_fun := equiv.ulift.to_fun,
  map_one' := rfl,
  map_mul' := by finish,
  map_zero' := rfl,
  map_add' := by finish }

@[reducible] def algebra_ulift_int {A : Type u} [comm_ring A] : algebra (ulift.{u} ℤ) A :=
ring_hom.to_algebra (ring_hom.comp (algebra_map ℤ A) ulift.down_ring_hom_int)
local attribute [instance] algebra_ulift_int

lemma injective_alg_map_int {K : Type u} [field K] (hK : char_zero K) :
  function.injective (algebra_map (ulift.{u} ℤ) K) :=
function.injective.comp (@int.cast_injective _ _ _ hK) equiv.ulift.injective

@[reducible] def algebra_ulift_zmod {A : Type u} [comm_ring A] {p : ℕ}
  [fact p.prime] [char_p A p] : algebra (ulift.{u} (zmod p)) A :=
ring_hom.to_algebra (ring_hom.comp (algebra_map (zmod p) A) ulift.down_ring_hom_zmod)
local attribute [instance] algebra_ulift_int

lemma injective_alg_map_zmod {K : Type u} [field K] {p : ℕ} [fact p.prime]
  [char_p K p] :
  function.injective (@algebra_map (ulift.{u} (zmod p)) K _ _ algebra_ulift_zmod) :=
function.injective.comp ((algebra_map (zmod p) _).injective) equiv.ulift.injective

/-- Two uncountable algebraically closed fields of characteristic zero are isomorphic
if they have the same cardinality. -/ --credit to Chris Hughes
lemma ring_equiv_of_cardinal_eq_of_char_zero
  {K L : Type u} (hKf : field K) (hLf : field L)
  (hK1 : is_alg_closed K) (hL1 : is_alg_closed L)
  (hK2 : char_zero K) (hL2 : char_zero L)
  (hK : ω < #K) (hKL : #K = #L) : nonempty (K ≃+* L) :=
begin
  have hinjK := injective_alg_map_int hK2,
  have hinjL := injective_alg_map_int hL2,
  have mk_ulift_int : #(ulift.{u} ℤ) = ω := by simp,
  cases exists_is_transcendence_basis (ulift.{u} ℤ)
    (show function.injective (algebra_map (ulift.{u} ℤ) K),
      from hinjK) with s hs,
  cases exists_is_transcendence_basis (ulift.{u} ℤ)
    (show function.injective (algebra_map (ulift.{u} ℤ) L),
      from hinjL) with t ht,
  have : #s = #t,
  { rw [← is_alg_closed.cardinal_eq_cardinal_transcendence_basis_of_omega_lt _ hs (le_of_eq mk_ulift_int) hK,
      ← is_alg_closed.cardinal_eq_cardinal_transcendence_basis_of_omega_lt _ ht (le_of_eq mk_ulift_int), hKL],
    rwa ← hKL },
  cases cardinal.eq.1 this with e,
  exact ⟨is_alg_closed.equiv_of_transcendence_basis _ _ e hs ht⟩,
end

lemma ring_equiv_of_cardinal_eq_of_char_p -- credit to Chris Hughes
  {K L : Type u} (hKf : field K) (hLf : field L)
  (hK1 : is_alg_closed K) (hL1 : is_alg_closed L) (p : ℕ) [fact p.prime]
  [char_p K p] [char_p L p] (hK : ω < #K) (hKL : #K = #L) : nonempty (K ≃+* L) :=
begin
  cases @exists_is_transcendence_basis (ulift.{u} (zmod p)) _ _ _ algebra_ulift_zmod
    (show function.injective (@algebra_map (ulift.{u} (zmod p)) K _ _ algebra_ulift_zmod),
      from injective_alg_map_zmod) with s hs,
  cases @exists_is_transcendence_basis (ulift.{u} (zmod p)) _ _ _ algebra_ulift_zmod
    (show function.injective (@algebra_map (ulift.{u} (zmod p)) L _ _ algebra_ulift_zmod),
      from injective_alg_map_zmod) with t ht,
  have : #s = #t,
  { rw [← @is_alg_closed.cardinal_eq_cardinal_transcendence_basis_of_omega_lt
          (ulift.{u} (zmod p)) K _ _ algebra_ulift_zmod _ _ _ _ hs
      (le_of_lt $ lt_omega_iff_fintype.2 ⟨infer_instance⟩) hK,
        ← @is_alg_closed.cardinal_eq_cardinal_transcendence_basis_of_omega_lt
          (ulift.{u} (zmod p)) L _ _ algebra_ulift_zmod _ _ _ _ ht
      (le_of_lt $ lt_omega_iff_fintype.2 ⟨infer_instance⟩), hKL],
    rwa ← hKL },
  cases cardinal.eq.1 this with e,
  exact ⟨@is_alg_closed.equiv_of_transcendence_basis
   (ulift.{u} (zmod p)) L K _ _ algebra_ulift_zmod _ algebra_ulift_zmod
     _ _ _ _ _ _ e hs ht⟩,
end

/-- Two uncountable algebraically closed fields are isomorphic
if they have the same cardinality and the same characteristic. -/
lemma ring_equiv_of_cardinal_eq_of_char_eq
  {K L : Type u} [hKf : field K] [hLf : field L]
  (hKalg : is_alg_closed K) (hLalg : is_alg_closed L)
  (p : ℕ) [char_p K p] [char_p L p]
  (hKω : ω < #K) (hKL : #K = #L) : nonempty (K ≃+* L) :=
begin
  rcases char_p.char_is_prime_or_zero K p with hp | hp,
  { haveI : fact p.prime := ⟨hp⟩,
    exact ⟨(ring_equiv_of_cardinal_eq_of_char_p hKf hLf hKalg hLalg p hKω hKL).some⟩ },
  { rw [hp] at *,
    resetI,
    letI : char_zero K := char_p.char_p_to_char_zero K,
    letI : char_zero L := char_p.char_p_to_char_zero L,
    exact ⟨(ring_equiv_of_cardinal_eq_of_char_zero hKf hLf hKalg hLalg _inst _inst_3 hKω hKL).some⟩ }
end

lemma categorical_ACF₀ {κ} (hκ : ω < κ) : fol.categorical κ ACF₀ :=
begin
  intros M N hM hN hMκ hNκ,
  haveI : fact (M ⊨ ACF₀) := ⟨ hM ⟩, haveI : fact (N ⊨ ACF₀) := ⟨ hN ⟩,
  split,
  apply equiv_of_ring_equiv,
  apply classical.choice,
  apply ring_equiv_of_cardinal_eq_of_char_zero,
  repeat { apply_instance },
  repeat { cc },
end

lemma categorical_ACFₚ {κ} (hκ : ω < κ) {p : ℕ} (hp : nat.prime p) :
  fol.categorical κ (ACFₚ hp) :=
begin
  intros M N hM hN hMκ hNκ,
  haveI : fact (nat.prime p) := ⟨ hp ⟩,
  haveI : fact (M ⊨ ACFₚ hp) := ⟨ hM ⟩, haveI : fact (N ⊨ ACFₚ hp) := ⟨ hN ⟩,
  split,
  apply equiv_of_ring_equiv,
  apply classical.choice,
  subst hMκ,
  refine @ring_equiv_of_cardinal_eq_of_char_eq _ _ _ _ _ _ p
    models_ACFₚ_char_p models_ACFₚ_char_p hκ hNκ.symm,
  { apply_instance },
  { apply_instance },
end

def unit_equiv_ring_unaries : _root_.equiv unit ring_unaries :=
{ to_fun := λ x, match x with | unit.star := ring_unaries.neg end,
  inv_fun := λ x, match x with | ring_unaries.neg := unit.star end,
  left_inv := λ x, match x with | unit.star := rfl end,
  right_inv := λ x, match x with | ring_unaries.neg := rfl end }

def bool_equiv_ring_binaries : _root_.equiv bool ring_binaries :=
{ to_fun := λ x, match x with | ff := ring_binaries.add | tt := ring_binaries.mul end,
  inv_fun := λ c, match c with | ring_binaries.add := ff | ring_binaries.mul := tt end,
  left_inv := λ x, match x with | ff := rfl | tt := rfl end,
  right_inv := λ c, match c with | ring_binaries.add := rfl | ring_binaries.mul := rfl end }

lemma ring_signature.fintype_functions : ∀ n, fintype (ring_signature.functions n)
| 0 := fintype.of_equiv bool bool_equiv_ring_consts
| 1 := fintype.of_equiv unit unit_equiv_ring_unaries
| 2 := fintype.of_equiv bool bool_equiv_ring_binaries
| (n+3) := by { dsimp [ring_signature, ring_funcs], exact fintype.of_is_empty }

lemma functions_le_omega : ∀ n, # (Rings.ring_signature.functions n) ≤ ω :=
begin
  intro n,
  apply le_of_lt,
  simp only [lt_omega_iff_fintype, ring_signature, ring_funcs],
  exact ⟨ ring_signature.fintype_functions _ ⟩,
end

lemma card_functions_omega_le_continuum : ∀ (n : ℕ), mk (ring_signature.functions n) ≤ continuum :=
λ n, (functions_le_omega _).trans omega_le_continuum

lemma only_infinite_ACF : only_infinite ACF :=
by { intro M, haveI : fact (M.1 ⊨ ACF) := ⟨ M.2 ⟩, exact is_alg_closed.infinite }

end is_complete_ACF₀

open is_complete_ACF₀ cardinal

/-- a.k.a Lefschetz part 1. Any sentence or its negation can be deduced in ACF₀-/
theorem is_complete'_ACF₀ : is_complete' ACF₀ :=
is_complete'_of_only_infinite_of_categorical
    instances.algebraic_closure_of_rat
    instances.algebraic_closure_of_rat_models_ACF₀ -- ℚ̅ is a model of ACF₀
    (only_infinite_subset ACF_subset_ACF₀ only_infinite_ACF) -- alg closed fields are infinite
    -- pick the cardinal κ := 𝔠
    card_functions_omega_le_continuum
    omega_le_continuum
    -- (max_le (functions_le_omega.trans $ omega_le_continuum) omega_le_continuum)
    (categorical_ACF₀ omega_lt_continuum)

/-- a.k.a Lefschetz part 3. Any sentence or its negation can be deduced in ACF₀-/
theorem is_complete'_ACFₚ {p : ℕ} (hp : nat.prime p) : is_complete' (ACFₚ hp) :=
is_complete'_of_only_infinite_of_categorical
    (instances.algebraic_closure_of_zmod hp)
    (instances.algebraic_closure_of_zmod_models_ACFₚ hp) -- alg_closure (ℤ / p) is a model of ACFₚ
    (only_infinite_subset ACF_subset_ACFₚ only_infinite_ACF) -- alg closed fields are infinite
    -- pick the cardinal κ := 𝔠
    card_functions_omega_le_continuum
    omega_le_continuum
    -- (max_le (functions_le_omega.trans $ omega_le_continuum) omega_le_continuum)
    (categorical_ACFₚ omega_lt_continuum hp)

end Fields


import .basic

namespace polya.field

open nterm

--@[derive decidable_eq]
structure xterm (γ : Type) [const_space γ] : Type :=
(term : nterm γ)
(exp : znum)

namespace xterm
variables {α : Type} [discrete_field α]
variables {γ : Type} [const_space γ]
variables [morph γ α] {ρ : dict α}

def to_nterm (x : xterm γ) : nterm γ :=
if x.exp = 0 then x.term / x.term
else if x.exp = 1 then x.term
else x.term ^ x.exp

def eval (ρ : dict α) (x : xterm γ) : α :=
let a := nterm.eval ρ x.term in
if a = 0 then 0 else a ^ (x.exp : ℤ)

def eval_to_nterm {x : xterm γ} :
 nterm.eval ρ x.to_nterm = xterm.eval ρ x :=
begin
  by_cases hx : nterm.eval ρ x.term = 0;
  { by_cases h1 : x.exp = 0,
    { simp [hx, h1, nterm.eval, xterm.eval, to_nterm] },
    { have : (x.exp : ℤ) ≠ 0, by {rw ← znum.cast_zero, exact_mod_cast h1 },
      by_cases h2 : x.exp = 1;
      simp [hx, h1, h2, nterm.eval, xterm.eval, to_nterm, zero_fpow, this] }}
end

theorem eval_to_nterm' :
  nterm.eval ρ ∘ @xterm.to_nterm γ _ = xterm.eval ρ :=
begin
  unfold function.comp,
  simp [eval_to_nterm]
end

theorem eval_def {x : nterm γ} {n : znum} :
  xterm.eval ρ ⟨x, n⟩ =
    if nterm.eval ρ x = 0 then 0
    else nterm.eval ρ x ^ (n : ℤ) :=
rfl

theorem eval_add {x : nterm γ} {n m : znum} :
  xterm.eval ρ ⟨x, n + m⟩ = xterm.eval ρ ⟨x, n⟩ * xterm.eval ρ ⟨x, m⟩ :=
begin
  by_cases hx : nterm.eval ρ x = 0;
  simp [xterm.eval, fpow_add, hx]
end

def pmerge : list (xterm γ) → list (xterm γ) → list (xterm γ)
| (x::xs) (y::ys) :=
  if x.term = y.term then
    ⟨x.term, x.exp + y.exp⟩ :: pmerge xs ys
  else if x.term < y.term then
    x :: pmerge xs (y::ys)
  else
    y :: pmerge (x::xs) ys
| xs [] := xs
| [] ys := ys

lemma pmerge_nil_left {ys : list (xterm γ)} :
  pmerge [] ys = ys :=
begin
  induction ys with y ys ih,
  { unfold pmerge },
  { unfold pmerge }
end

lemma pmerge_nil_right {xs : list (xterm γ)} :
  pmerge xs [] = xs :=
begin
  induction xs with x xs ih,
  { unfold pmerge },
  { unfold pmerge }
end

lemma pmerge_def1 {x y : xterm γ} {xs ys : list (xterm γ)} :
  x.term = y.term →
  pmerge (x::xs) (y::ys) = ⟨x.term, x.exp + y.exp⟩ :: pmerge xs ys :=
by intro h; simp [pmerge, h]
lemma pmerge_def2 {x y : xterm γ} {xs ys : list (xterm γ)} :
  x.term ≠ y.term → x.term < y.term →
  pmerge (x::xs) (y::ys) = x :: pmerge xs (y :: ys) :=
by intros h1 h2; simp [pmerge, h1, h2]
lemma pmerge_def3 {x y : xterm γ} {xs ys : list (xterm γ)} :
  x.term ≠ y.term → ¬ x.term < y.term →
  pmerge (x::xs) (y::ys) = y :: pmerge (x::xs) ys :=
by intros h1 h2; simp [pmerge, h1, h2]

theorem eval_pmerge (xs ys : list (xterm γ)) :
  list.prod (list.map (xterm.eval ρ) (pmerge xs ys))
  = list.prod (list.map (xterm.eval ρ) xs)
    * list.prod (list.map (xterm.eval ρ) ys) :=
begin
  revert ys,
  induction xs with x xs ihx,
  { intro ys, simp [pmerge_nil_left] },
  { intro ys, induction ys with y ys ihy,
    { simp [pmerge_nil_right] },
    { by_cases h1 : x.term = y.term,
      { rw pmerge_def1 h1,
        cases x with x n, cases y with y m,
        simp only [] at h1, rw h1 at *,
        repeat {rw [list.map_cons, list.prod_cons]},
        rw [eval_add, ihx ys], ring },
      { by_cases h2 : x.term < y.term,
        { rw pmerge_def2 h1 h2,
          repeat {rw [list.map_cons, list.prod_cons]},
          rw [ihx (y::ys), list.map_cons, list.prod_cons],
          ring},
        { rw pmerge_def3 h1 h2,
          repeat {rw [list.map_cons, list.prod_cons]},
          rw [ihy, list.map_cons, list.prod_cons],
          ring }}}}
end

theorem eval_pow {x : xterm γ} {n : znum} :
  n ≠ 0 → xterm.eval ρ ⟨x.term, x.exp * n⟩ = xterm.eval ρ x ^ (n : ℤ) :=
begin
  intro h0,
  have h1 : (n : ℤ) ≠ 0, by {rw ← znum.cast_zero, exact_mod_cast h0},
  by_cases hx : nterm.eval ρ x.term = 0,
  { simp [hx, xterm.eval, zero_fpow, h1] },
  { simp [hx, xterm.eval, fpow_mul] }
end

theorem eval_prod_pow {xs : list (xterm γ)} {n : znum} :
  n ≠ 0 → list.prod (list.map (xterm.eval ρ) xs) ^ (n : ℤ)
    = list.prod (list.map (λ x : xterm γ, xterm.eval ρ ⟨x.term, x.exp * n⟩) xs) :=
begin
  intro hn,
  induction xs with x xs ih,
  { simp },
  { repeat {rw [list.map_cons, list.prod_cons]},
    rw [eval_pow hn, mul_fpow, ih] }
end

end xterm

structure pterm (γ : Type) [const_space γ] : Type :=
(terms : list (xterm γ))
(coeff : γ)

namespace pterm
variables {α : Type} [discrete_field α]
variables {γ : Type} [const_space γ]
variables [morph γ α] {ρ : dict α}

def of_const (a : γ) : pterm γ :=
{ terms := [], coeff := a, }

def singleton (x : nterm γ) : pterm γ :=
{ terms := [⟨x, 1⟩], coeff := 1 }

def eval (ρ : dict α) (P : pterm γ) : α :=
list.prod (P.terms.map (xterm.eval ρ)) * ↑P.coeff

theorem eval_of_const (a : γ) :
  pterm.eval ρ (of_const a) = ↑a :=
by simp [of_const, pterm.eval, xterm.eval]

theorem eval_singleton (x : nterm γ) :
  pterm.eval ρ (singleton x) = nterm.eval ρ x :=
begin
  by_cases hx : nterm.eval ρ x = 0,
  repeat {simp [singleton, pterm.eval, xterm.eval, hx]}
end

def mul (P1 P2 : pterm γ) : pterm γ :=
if P1.coeff = 0 ∨ P2.coeff = 0 then
  { terms := [],
    coeff := 0,
  }
else
  { terms := xterm.pmerge P1.terms P2.terms,
    coeff := P1.coeff * P2.coeff,
  }

def pow (P : pterm γ) (n : znum) : pterm γ :=
if n = 0 then
  of_const 1
else
  { terms := P.terms.map (λ x, ⟨x.term, x.exp * n⟩),
    coeff := P.coeff ^ (n : ℤ),
  }

instance : has_mul (pterm γ) := ⟨mul⟩
instance : has_pow (pterm γ) znum := ⟨pow⟩

theorem mul_terms {P Q : pterm γ} :
  P.coeff ≠ 0 ∧ Q.coeff ≠ 0 →
  (P * Q).terms = xterm.pmerge P.terms Q.terms :=
begin
  intro h,
  simp [has_mul.mul, mul, h]
end

theorem mul_terms' {P Q : pterm γ} :
  P.coeff = 0 ∨ Q.coeff = 0 →
  (P * Q).terms = [] :=
begin
  intro h,
  simp [has_mul.mul, mul, h]
end

theorem mul_coeff {P Q : pterm γ} :
  (P * Q).coeff = P.coeff * Q.coeff :=
begin
  by_cases h : P.coeff = 0 ∨ Q.coeff = 0,
  { apply eq.trans,
    { show (P * Q).coeff = 0, simp [has_mul.mul, mul, h] },
    { simp [h] }},
  { simp [has_mul.mul, mul, h] }
end

theorem eval_mul {P Q : pterm γ} :
  pterm.eval ρ (P * Q) = pterm.eval ρ P * pterm.eval ρ Q :=
begin
  unfold pterm.eval, rw mul_coeff,
  by_cases h0 : P.coeff = 0 ∨ Q.coeff = 0,
  { cases h0; simp [h0, morph.morph_zero'] },
  { have : P.coeff ≠ 0 ∧ Q.coeff ≠ 0,
    from (decidable.not_or_iff_and_not _ _).mp h0,
    rw [mul_terms this, xterm.eval_pmerge, morph.morph_mul],
    ring }
end

theorem pow_def {P : pterm γ} {n : znum} :
  n ≠ 0 → pterm.eval ρ (P.pow n) =
    list.prod (list.map (λ x : xterm γ, xterm.eval ρ ⟨x.term, x.exp * n⟩) P.terms) * ↑P.coeff ^ (n : ℤ) :=
begin
  intro hn,
  rw [← morph.morph_pow],
  simp [has_pow.pow, pow, hn, pterm.eval]
end

theorem eval_pow {P : pterm γ} {n : znum} :
  pterm.eval ρ (P ^ n) = pterm.eval ρ P ^ (n : ℤ) :=
begin
  by_cases hn : n = 0,
  { rw [hn, znum.cast_zero, fpow_zero],
    simp [has_pow.pow, pow, of_const, pterm.eval] },
  { cases P with xs c,
    simp only [pterm.eval],
    rw [mul_fpow, ← morph.morph_pow],
    congr,
    { rw xterm.eval_prod_pow hn,
      simp [has_pow.pow, pow, hn] },
    { simp [has_pow.pow, pow, hn] }}
end

def to_nterm (P : pterm γ) : nterm γ :=
prod (P.terms.map xterm.to_nterm) * P.coeff

theorem eval_to_nterm {P : pterm γ} :
  pterm.eval ρ P = nterm.eval ρ P.to_nterm :=
begin
  --cases P with xs c,
  --by_cases h1 : xs.empty = ff,
  --{ by_cases h2 : c = 1,
  --  { rw h2, simp [pterm.eval, to_nterm, h1, eval_prod, xterm.eval_to_nterm'] },
  --  { suffices : list.prod (list.map (xterm.eval ρ) xs) * ↑c =
  --      nterm.eval ρ (prod (list.map xterm.to_nterm xs)) * ↑c,
  --    by { simp [to_nterm, pterm.eval, this, h1, h2] },
  --    rw [eval_prod, list.map_map],
  --    rw xterm.eval_to_nterm' }},
  ----this is silly TODO
  --{ have h1' : xs.empty = tt, by { cases xs,
  --    { refl },
  --    { by_contradiction, apply h1, unfold list.empty }},
  --  cases xs,
  --  { simp [pterm.eval, nterm.eval, to_nterm, h1'] },
  --  { by_contradiction, apply h1, unfold list.empty }
  --}
  cases P with xs c,
  suffices : list.prod (list.map (xterm.eval ρ) xs) * ↑c =
    nterm.eval ρ (prod (list.map xterm.to_nterm xs)) * ↑c,
  by { simp [to_nterm, pterm.eval, this] },
  rw [eval_prod, list.map_map],
  rw xterm.eval_to_nterm'
end

def reduce (P : pterm γ) : pterm γ :=
{ terms := P.terms.filter (λ x, x.exp ≠ 0),
  coeff := P.coeff
}

def reduce_hyps (P : pterm γ) : list (nterm γ) :=
list.map xterm.term (P.terms.filter (λ x, x.exp = 0))

private lemma lemma_eval_reduce {x : xterm γ} :
  x.exp = 0 ∧ nterm.eval ρ x.term ≠ 0 →
  xterm.eval ρ x = 1 :=
begin
  cases x with x n,
  simp only [],
  intro h, cases h with hn hx,
  simp [xterm.eval, hn, hx]
end

theorem eval_reduce {P : pterm γ} :
  nonzero ρ P.reduce_hyps →
  pterm.eval ρ P = pterm.eval ρ P.reduce :=
begin
  intro H,
  have H1 : ∀ x : xterm γ, x ∈ P.terms → x.exp = 0 → nterm.eval ρ (x.term) ≠ 0,
  by { intros x h1 h2, apply H, simp [reduce_hyps], existsi x, simp [h1, h2] },
  have H2 : ∀ x : xterm γ, x ∈ P.terms.filter (λ x, x.exp = 0) → nterm.eval ρ (x.term) ≠ 0,
  by { intros x hx, have : x ∈ P.terms ∧ x.exp = 0, from list.mem_filter.mp hx,
       cases this, apply H1; assumption },

  have : P.terms ~ P.terms.filter (λ x, x.exp = 0) ++ P.terms.filter (λ x, x.exp ≠ 0),
  from list.filter_perm,

  unfold pterm.eval,
  rw list.prod_eq_of_perm (list.perm_map _ this),
  rw [list.map_append, list.prod_append],

  have : ∀ x ∈ P.terms.filter (λ x, x.exp = 0), xterm.eval ρ x = 1,
  by {
    intros x hx,
    apply lemma_eval_reduce,
    split,
    { exact (list.mem_filter.mp hx).right },
    { apply H2, exact hx }},

  have : ∀ a ∈ (list.map (xterm.eval ρ) (P.terms.filter (λ x, x.exp = 0))), a = 1,
  by { intros a ha, rw list.mem_map at ha,
    cases ha with x hx,
    cases hx with hx ha,
    rw ← ha, apply this,
    assumption },

  simp [reduce, list.prod_ones this]
end

def of_nterm : nterm γ → pterm γ
| (nterm.mul x y) := of_nterm x * of_nterm y
| (nterm.pow x n) := of_nterm x ^ n
| (nterm.const a) := of_const a
| x := singleton x

theorem eval_of_nterm {x : nterm γ} :
  pterm.eval ρ (of_nterm x) = nterm.eval ρ x :=
begin
  induction x with i c x y ihx ihy x y ihx ihy x n ihx,
  { simp [of_nterm, eval_singleton] },
  { simp [of_nterm, eval_of_const, nterm.eval] },
  { simp [of_nterm, eval_singleton] },
  { simp [of_nterm, eval_mul, nterm.eval, ihx, ihy] },
  { simp [of_nterm, eval_pow, nterm.eval, ihx] }
end

end pterm

end polya.field


import .preterm ..simp_omega  ..logic

namespace nat

@[derive has_reflect]
inductive form
| eq  : preterm → preterm → form
| le  : preterm → preterm → form
| not : form → form
| or  : form → form → form
| and : form → form → form

notation x `=*` y := form.eq x y
notation x `≤*` y := form.le x y
notation `¬*` p := form.not p
notation p `∨*` q := form.or p q
notation p `∧*` q := form.and p q

-- | (t =* s) :=
-- | (t ≤* s) :=
-- | (¬* p)   :=
-- | (p ∨* q) :=
-- | (p ∧* q) :=

def valuation.cons (i : nat) (v : nat → nat) : nat → nat
| 0     := i
| (k+1) := v k

notation i `::` v := valuation.cons i v

open tactic

namespace form

@[omega] def holds (v : nat → nat) : form → Prop
| (t =* s) := t.val v = s.val v
| (t ≤* s) := t.val v ≤ s.val v
| (¬* p)   := ¬ p.holds
| (p ∨* q) := p.holds ∨ q.holds
| (p ∧* q) := p.holds ∧ q.holds

end form

@[omega] def uniclo (p : form) : (nat → nat) → nat → Prop
| v 0     := p.holds v
| v (k+1) := ∀ i : nat, uniclo (i::v) k

namespace form

def neg_free : form → Prop
| (t =* s) := true
| (t ≤* s) := true
| (p ∨* q) := neg_free p ∧ neg_free q
| (p ∧* q) := neg_free p ∧ neg_free q
| _        := false

def sub_free : form → Prop
| (t =* s) := t.sub_free ∧ s.sub_free
| (t ≤* s) := t.sub_free ∧ s.sub_free
| (¬* p)   := p.sub_free
| (p ∨* q) := p.sub_free ∧ q.sub_free
| (p ∧* q) := p.sub_free ∧ q.sub_free

def fresh_idx : form → nat
| (t =* s) := max t.fresh_idx s.fresh_idx
| (t ≤* s) := max t.fresh_idx s.fresh_idx
| (¬* p)   := p.fresh_idx
| (p ∨* q) := max p.fresh_idx q.fresh_idx
| (p ∧* q) := max p.fresh_idx q.fresh_idx

def holds_constant {v w : nat → nat} :
  ∀ p : form,
  ( (∀ x < p.fresh_idx, v x = w x) →
    (p.holds v ↔ p.holds w) )
| (t =* s) h1 :=
  begin
    simp_omega, apply pred_mono_2;
    apply preterm.val_constant;
    intros x h2; apply h1 _ (lt_of_lt_of_le h2 _),
    apply le_max_left, apply le_max_right
  end
| (t ≤* s) h1 :=
  begin
    simp_omega, apply pred_mono_2;
    apply preterm.val_constant;
    intros x h2; apply h1 _ (lt_of_lt_of_le h2 _),
    apply le_max_left, apply le_max_right
  end
| (¬* p)   h1 :=
  begin
    apply not_iff_not_of_iff,
    apply holds_constant p h1
  end
| (p ∨* q) h1 :=
  begin
    simp_omega, apply or_iff_or;
    apply holds_constant;
    intros x h2; apply h1 _ (lt_of_lt_of_le h2 _),
    apply le_max_left, apply le_max_right
  end
| (p ∧* q) h1 :=
  begin
    simp_omega, apply and_iff_and;
    apply holds_constant;
    intros x h2; apply h1 _ (lt_of_lt_of_le h2 _),
    apply le_max_left, apply le_max_right
  end

--def uniclo (p : form) : Prop :=
--uniclo_core p p.fresh_idx (λ _, 0)

def valid (p : form) : Prop :=
∀ v, holds v p

def sat (p : form) : Prop :=
∃ v, holds v p

def implies (p q : form) : Prop :=
∀ v, (holds v p → holds v q)

def equiv (p q : form) : Prop :=
∀ v, (holds v p ↔ holds v q)

lemma sat_of_implies_of_sat {p q} :
  implies p q → sat p → sat q :=
begin intros h1 h2, apply exists_of_exists h1 h2 end

lemma sat_or {p q : form} :
  sat (p ∨* q) ↔ sat p ∨ sat q :=
begin
  constructor; intro h1,
  { cases h1 with v h1, cases h1 with h1 h1;
    [left,right]; refine ⟨v,_⟩; assumption },
  { cases h1 with h1 h1; cases h1 with v h1;
    refine ⟨v,_⟩; [left,right]; assumption }
end

def unsat (p : form) : Prop := ¬ sat p

def repr : form → string
| (t =* s) := "(" ++ t.repr ++ " = " ++ s.repr ++ ")"
| (t ≤* s) := "(" ++ t.repr ++ " ≤ " ++ s.repr ++ ")"
| (¬* p)   := "¬" ++ p.repr
| (p ∨* q) := "(" ++ p.repr ++ " ∨  " ++ q.repr ++ ")"
| (p ∧* q) := "(" ++ p.repr ++ " ∧ " ++ q.repr ++ ")"

instance has_repr : has_repr form := ⟨repr⟩
meta instance has_to_format : has_to_format form := ⟨λ x, x.repr⟩

end form

lemma uniclo_of_valid {p : form} :
  ∀ {m v}, p.valid → uniclo p v m
| 0 v h1     := h1 _
| (m+1) v h1 := λ i, uniclo_of_valid h1

--lemma uniclo_of_valid {p : form} (h : p.valid) : p.uniclo :=
--uniclo_core_of_valid h

lemma valid_of_unsat_not {p : form} : (¬*p).unsat → p.valid :=
begin
  simp only [form.sat, form.unsat, form.valid, form.holds],
  rw classical.not_exists_not, intro h, assumption
end

open tactic

meta def form.induce (t : tactic unit := skip) : tactic unit :=
`[ intro p, induction p with t s t s p ih p q ihp ihq p q ihp ihq; t]

end nat


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

From https://github.com/leanprover-community/mathlib/blob/6b93ea7e4bbe7822960e821141e5a931537cd755/src/ring_theory/polynomial/homogeneous.lean

Only the `homogeneous_submodule.gcomm_semiring` result is relevant to this repository, much of the
other theory predates the associated paper.
-/

import data.fintype.card
import data.mv_polynomial.variables

import cicm2022.internal.internal
import cicm2022.graded_monoid

/-!
# Homogeneous polynomials

A multivariate polynomial `φ` is homogeneous of degree `n`
if all monomials occuring in `φ` have degree `n`.

## Main definitions/lemmas

* `is_homogeneous φ n`: a predicate that asserts that `φ` is homogeneous of degree `n`.
* `homogeneous_submodule σ R n`: the submodule of homogeneous polynomials of degree `n`.
* `homogeneous_component n`: the additive morphism that projects polynomials onto
  their summand that is homogeneous of degree `n`.
* `sum_homogeneous_component`: every polynomial is the sum of its homogeneous components

-/

open_locale big_operators

namespace mv_polynomial
variables {σ : Type*} {τ : Type*} {R : Type*} {S : Type*}

/-
TODO
* create definition for `∑ i in d.support, d i`
* show that `mv_polynomial σ R ≃ₐ[R] ⨁ i, homogeneous_submodule σ R i`
-/

/-- A multivariate polynomial `φ` is homogeneous of degree `n`
if all monomials occuring in `φ` have degree `n`. -/
def is_homogeneous [comm_semiring R] (φ : mv_polynomial σ R) (n : ℕ) :=
∀ ⦃d⦄, coeff d φ ≠ 0 → ∑ i in d.support, d i = n

variables (σ R)

/-- The submodule of homogeneous `mv_polynomial`s of degree `n`. -/
def homogeneous_submodule [comm_semiring R] (n : ℕ) :
  submodule R (mv_polynomial σ R) :=
{ carrier := { x | x.is_homogeneous n },
  smul_mem' := λ r a ha c hc, begin
    rw coeff_smul at hc,
    apply ha,
    intro h,
    apply hc,
    rw h,
    exact smul_zero r,
  end,
  zero_mem' := λ d hd, false.elim (hd $ coeff_zero _),
  add_mem' := λ a b ha hb c hc, begin
    rw coeff_add at hc,
    obtain h|h : coeff c a ≠ 0 ∨ coeff c b ≠ 0,
    { contrapose! hc, simp only [hc, add_zero] },
    { exact ha h },
    { exact hb h }
  end }

variables {σ R}

@[simp] lemma mem_homogeneous_submodule [comm_semiring R] (n : ℕ) (p : mv_polynomial σ R) :
  p ∈ homogeneous_submodule σ R n ↔ p.is_homogeneous n := iff.rfl

variables (σ R)

/-- While equal, the former has a convenient definitional reduction. -/
lemma homogeneous_submodule_eq_finsupp_supported [comm_semiring R] (n : ℕ) :
  homogeneous_submodule σ R n = finsupp.supported _ R {d | ∑ i in d.support, d i = n} :=
begin
  ext,
  rw [finsupp.mem_supported, set.subset_def],
  simp only [finsupp.mem_support_iff, finset.mem_coe],
  refl,
end

variables {σ R}

lemma homogeneous_submodule_mul [comm_semiring R] (m n : ℕ) :
  homogeneous_submodule σ R m * homogeneous_submodule σ R n ≤ homogeneous_submodule σ R (m + n) :=
begin
  rw submodule.mul_le,
  intros φ hφ ψ hψ c hc,
  rw [coeff_mul] at hc,
  obtain ⟨⟨d, e⟩, hde, H⟩ := finset.exists_ne_zero_of_sum_ne_zero hc,
  have aux : coeff d φ ≠ 0 ∧ coeff e ψ ≠ 0,
  { contrapose! H,
    by_cases h : coeff d φ = 0;
    simp only [*, ne.def, not_false_iff, zero_mul, mul_zero] at * },
  specialize hφ aux.1, specialize hψ aux.2,
  rw finsupp.mem_antidiagonal at hde,
  classical,
  have hd' : d.support ⊆ d.support ∪ e.support := finset.subset_union_left _ _,
  have he' : e.support ⊆ d.support ∪ e.support := finset.subset_union_right _ _,
  rw [← hde, ← hφ, ← hψ, finset.sum_subset (finsupp.support_add),
    finset.sum_subset hd', finset.sum_subset he', ← finset.sum_add_distrib],
  { congr },
  all_goals { intros i hi, apply finsupp.not_mem_support_iff.mp },
end

section
variables [comm_semiring R]

variables {σ R}

lemma is_homogeneous_monomial (d : σ →₀ ℕ) (r : R) (n : ℕ) (hn : ∑ i in d.support, d i = n) :
  is_homogeneous (monomial d r) n :=
begin
  intros c hc,
  classical,
  rw coeff_monomial at hc,
  split_ifs at hc with h,
  { subst c, exact hn },
  { contradiction }
end
variables (σ) {R}

lemma is_homogeneous_of_total_degree_zero {p : mv_polynomial σ R} (hp : p.total_degree = 0) :
  is_homogeneous p 0 :=
begin
  erw [total_degree, finset.sup_eq_bot_iff] at hp,
  -- we have to do this in two steps to stop simp changing bot to zero
  simp_rw [mem_support_iff] at hp,
  exact hp,
end

lemma is_homogeneous_C (r : R) :
  is_homogeneous (C r : mv_polynomial σ R) 0 :=
begin
  apply is_homogeneous_monomial,
  simp only [finsupp.zero_apply, finset.sum_const_zero],
end

variables (σ R)

lemma is_homogeneous_zero (n : ℕ) : is_homogeneous (0 : mv_polynomial σ R) n :=
(homogeneous_submodule σ R n).zero_mem

lemma is_homogeneous_one : is_homogeneous (1 : mv_polynomial σ R) 0 :=
is_homogeneous_C _ _

variables {σ} (R)

lemma is_homogeneous_X (i : σ) :
  is_homogeneous (X i : mv_polynomial σ R) 1 :=
begin
  apply is_homogeneous_monomial,
  simp only [finsupp.support_single_ne_zero _ one_ne_zero, finset.sum_singleton],
  exact finsupp.single_eq_same
end

end

namespace is_homogeneous
variables [comm_semiring R] {φ ψ : mv_polynomial σ R} {m n : ℕ}

lemma coeff_eq_zero (hφ : is_homogeneous φ n) (d : σ →₀ ℕ) (hd : ∑ i in d.support, d i ≠ n) :
  coeff d φ = 0 :=
by { have aux := mt (@hφ d) hd, classical, rwa not_not at aux }

lemma inj_right (hm : is_homogeneous φ m) (hn : is_homogeneous φ n) (hφ : φ ≠ 0) :
  m = n :=
begin
  obtain ⟨d, hd⟩ : ∃ d, coeff d φ ≠ 0 := exists_coeff_ne_zero hφ,
  rw [← hm hd, ← hn hd]
end

lemma add (hφ : is_homogeneous φ n) (hψ : is_homogeneous ψ n) :
  is_homogeneous (φ + ψ) n :=
(homogeneous_submodule σ R n).add_mem hφ hψ

lemma sum {ι : Type*} (s : finset ι) (φ : ι → mv_polynomial σ R) (n : ℕ)
  (h : ∀ i ∈ s, is_homogeneous (φ i) n) :
  is_homogeneous (∑ i in s, φ i) n :=
(homogeneous_submodule σ R n).sum_mem h

lemma mul (hφ : is_homogeneous φ m) (hψ : is_homogeneous ψ n) :
  is_homogeneous (φ * ψ) (m + n) :=
homogeneous_submodule_mul m n $ submodule.mul_mem_mul hφ hψ

lemma prod {ι : Type*} (s : finset ι) (φ : ι → mv_polynomial σ R) (n : ι → ℕ)
  (h : ∀ i ∈ s, is_homogeneous (φ i) (n i)) :
  is_homogeneous (∏ i in s, φ i) (∑ i in s, n i) :=
begin
  classical,
  revert h,
  apply finset.induction_on s,
  { intro, simp only [is_homogeneous_one, finset.sum_empty, finset.prod_empty] },
  { intros i s his IH h,
    simp only [his, finset.prod_insert, finset.sum_insert, not_false_iff],
    apply (h i (finset.mem_insert_self _ _)).mul (IH _),
    intros j hjs,
    exact h j (finset.mem_insert_of_mem hjs) }
end

lemma total_degree (hφ : is_homogeneous φ n) (h : φ ≠ 0) :
  total_degree φ = n :=
begin
  rw total_degree,
  apply le_antisymm,
  { apply finset.sup_le,
    intros d hd,
    rw mem_support_iff at hd,
    rw [finsupp.sum, hφ hd], },
  { obtain ⟨d, hd⟩ : ∃ d, coeff d φ ≠ 0 := exists_coeff_ne_zero h,
    simp only [← hφ hd, finsupp.sum],
    replace hd := finsupp.mem_support_iff.mpr hd,
    exact finset.le_sup hd, }
end

/--
The homogeneous submodules form a graded ring. This instance is used by `direct_sum.comm_semiring`
and `direct_sum.algebra`. -/
instance homogeneous_submodule.gcomm_semiring :
  set_like.graded_monoid (homogeneous_submodule σ R) :=
{ one_mem := is_homogeneous_one σ R,
  mul_mem := λ i j xi xj, is_homogeneous.mul}

open_locale direct_sum
noncomputable example : comm_semiring (⨁ i, homogeneous_submodule σ R i) := infer_instance
noncomputable example : algebra R (⨁ i, homogeneous_submodule σ R i) := infer_instance

end is_homogeneous

section
noncomputable theory
open_locale classical
open finset

/-- `homogeneous_component n φ` is the part of `φ` that is homogeneous of degree `n`.
See `sum_homogeneous_component` for the statement that `φ` is equal to the sum
of all its homogeneous components. -/
def homogeneous_component [comm_semiring R] (n : ℕ) :
  mv_polynomial σ R →ₗ[R] mv_polynomial σ R :=
(submodule.subtype _).comp $ finsupp.restrict_dom _ _ {d | ∑ i in d.support, d i = n}

section homogeneous_component
open finset
variables [comm_semiring R] (n : ℕ) (φ ψ : mv_polynomial σ R)

lemma coeff_homogeneous_component (d : σ →₀ ℕ) :
  coeff d (homogeneous_component n φ) = if ∑ i in d.support, d i = n then coeff d φ else 0 :=
by convert finsupp.filter_apply (λ d : σ →₀ ℕ, ∑ i in d.support, d i = n) φ d

lemma homogeneous_component_apply :
  homogeneous_component n φ =
  ∑ d in φ.support.filter (λ d, ∑ i in d.support, d i = n), monomial d (coeff d φ) :=
by convert finsupp.filter_eq_sum (λ d : σ →₀ ℕ, ∑ i in d.support, d i = n) φ

lemma homogeneous_component_is_homogeneous :
  (homogeneous_component n φ).is_homogeneous n :=
begin
  intros d hd,
  contrapose! hd,
  rw [coeff_homogeneous_component, if_neg hd]
end

@[simp]
lemma homogeneous_component_zero : homogeneous_component 0 φ = C (coeff 0 φ) :=
begin
  ext1 d,
  rcases em (d = 0) with (rfl|hd),
  { simp only [coeff_homogeneous_component, sum_eq_zero_iff, finsupp.zero_apply, if_true, coeff_C,
      eq_self_iff_true, forall_true_iff] },
  { rw [coeff_homogeneous_component, if_neg, coeff_C, if_neg (ne.symm hd)],
    simp only [finsupp.ext_iff, finsupp.zero_apply] at hd,
    simp [hd] }
end

@[simp]
lemma homogeneous_component_C_mul (n : ℕ) (r : R) :
  homogeneous_component n (C r * φ) = C r * homogeneous_component n φ :=
by simp only [C_mul', linear_map.map_smul]

lemma homogeneous_component_eq_zero' (h : ∀ d : σ →₀ ℕ, d ∈ φ.support → ∑ i in d.support, d i ≠ n) :
  homogeneous_component n φ = 0 :=
begin
  rw [homogeneous_component_apply, sum_eq_zero],
  intros d hd, rw mem_filter at hd,
  exfalso, exact h _ hd.1 hd.2
end

lemma homogeneous_component_eq_zero (h : φ.total_degree < n) :
  homogeneous_component n φ = 0 :=
begin
  apply homogeneous_component_eq_zero',
  rw [total_degree, finset.sup_lt_iff] at h,
  { intros d hd, exact ne_of_lt (h d hd), },
  { exact lt_of_le_of_lt (nat.zero_le _) h, }
end

lemma sum_homogeneous_component :
  ∑ i in range (φ.total_degree + 1), homogeneous_component i φ = φ :=
begin
  ext1 d,
  suffices : φ.total_degree < d.support.sum d → 0 = coeff d φ,
    by simpa [coeff_sum, coeff_homogeneous_component],
  exact λ h, (coeff_eq_zero_of_total_degree_lt h).symm
end

lemma homogeneous_component_homogeneous_polynomial (m n : ℕ)
  (p : mv_polynomial σ R) (h : p ∈ homogeneous_submodule σ R n) :
  homogeneous_component m p = if m = n then p else 0 :=
begin
  simp only [mem_homogeneous_submodule] at h,
  ext x,
  rw coeff_homogeneous_component,
  by_cases zero_coeff : coeff x p = 0,
  { split_ifs,
    all_goals { simp only [zero_coeff, coeff_zero], }, },
  { rw h zero_coeff,
    simp only [show n = m ↔ m = n, from eq_comm],
    split_ifs with h1,
    { refl },
    { simp only [coeff_zero] } }
end

end homogeneous_component

end

end mv_polynomial


namespace Bla

inductive Nat where
  | z : Nat
  | s : Nat → Nat

def add : Nat → Nat → Nat
  | a, Nat.z => a
  | a, Nat.s b => Nat.s (add a b)

theorem ex (x : Nat) : add Nat.z x = x := by
  induction x
  done

end Bla


import topology.basic
import topology.metric_space.basic
import topology.continuous_function.basic
import topology.homotopy.fundamental_groupoid
import category_theory.endomorphism
import category_theory.groupoid
import algebra.category.Group.basic
import category_theory.category.basic
import data.complex.exponential
import analysis.special_functions.trigonometric.basic

import .disk
import .fundamental_group

/--
A retraction is a continuous map r from a space to a subset of itself where
r restricted to that subset is the identity.
-/
structure retraction {α : Type} [topological_space α] {X Y : set α} (r : C(X, Y)) : Prop :=
(hy_sub_x : Y ⊆ X)
(inclusion_right_inv : function.right_inverse (set.inclusion hy_sub_x) r)

lemma surjective_of_retraction {α : Type} [topological_space α] {X Y : set α} (r : C(X, Y)) :
  retraction r → function.surjective r :=
begin
  intro hret,
  apply function.has_right_inverse.surjective,
  apply exists.intro (set.inclusion hret.hy_sub_x),
  exact hret.inclusion_right_inv,
end

noncomputable def nth_winding_loop (n : ℤ) : path pt pt :=
path.mk
  (continuous_map.mk
    (λt, (real.cos (2 * real.pi * n * t), real.sin (2 * real.pi * n * t)))
    (by continuity))
  (by simp [pt])
  begin
    simp [pt],
    rw mul_comm _ ↑n,
    apply and.intro,
    apply real.cos_int_mul_two_pi,
    rw ← zero_add (↑n * (2 * real.pi)),
    rw real.sin_add_int_mul_two_pi 0 n,
    simp,
  end

def nth_winding_loop_class (n : ℤ) : circle.pointed_space.basepoint ⟶ circle.pointed_space.basepoint :=
sorry
-- @quotient.mk
--   (path pt pt)
--   (path.homotopic.setoid pt pt)
--   (nth_winding_loop n)

noncomputable lemma fg_circle_iso_int : fundamental_group circle.pointed_space ≅ ℤ := {
  hom := (λγ, sorry),
  inv := (λn, sorry),
  hom_inv_id' := sorry,
  inv_hom_id' := sorry,
}

noncomputable lemma fg_disk_iso_0 : fundamental_group disk.pointed_space ≅ unit :=
category_theory.iso.mk
  (λγ, 0)
  (λn, 1)
  (begin
    ext γ,
    simp, -- 1, γ are elements in fundamental group i.e. 1.hom and γ.hom are arrows in fundamental groupoid
    -- apply quotient.sound,
    sorry,
  end)
  (by {funext, simp})

-- instance mul_one_class.π₁_D₂ : mul_one_class (fundamental_group disk.pointed_space) := sorry
-- instance mul_one_class.π₁_S₁ : mul_one_class (fundamental_group circle.pointed_space) := sorry

instance unit.has_zero : has_zero unit := {
  zero := unit.star,
}

instance unit.add_group : add_group unit := {
  add := λ_ _, 0,
  zero := 0,
  neg := λ_, 0,
  add_assoc := by cc,
  add_zero := by cc,
  zero_add := by cc,
  add_left_neg := by cc,
}

lemma no_surj_hom_π₁D₂_to_π₁S₁ (φ : (fundamental_group disk.pointed_space) →* (fundamental_group circle.pointed_space)) :
  ¬ function.surjective φ :=
begin
  by_contradiction,
  let ψ := fg_disk_iso_0.inv ≫ φ ≫ fg_circle_iso_int.hom,

  have hψ_epi : category_theory.epi ψ := begin
    -- apply @category_theory.epi_of_epi_fac _ _ _ _ _ fg_disk_iso_0.inv (φ ≫ fg_circle_iso_int.hom) ψ _,
    sorry,
  end,

  have hψ_not_epi : ¬ category_theory.epi ψ := begin
    rw category_theory.epi_iff_surjective,
    apply not_surjective_fintype_infinite,
  end,
  contradiction,
end

lemma no_surj_hom_π₁D₂_to_frontier (φ : (fundamental_group disk.pointed_space) →* (fundamental_group frontier_disk.pointed_space)) :
  ¬ function.surjective φ :=
begin
  by_contradiction,
  let φ' : (fundamental_group disk.pointed_space) →* (fundamental_group circle.pointed_space) := sorry,
    -- (pointed_map_of_continuous_map frontier_disk_homeo_circle.to_fun) ∘ φ,
    -- compose these somehow

  have h_φ'_surj : function.surjective φ' :=
    begin
      apply function.surjective.comp,
      { sorry },
      { sorry },
    end,
  have h_φ'_not_surj : ¬ function.surjective φ' := no_surj_hom_π₁D₂_to_π₁S₁ φ',
  contradiction,
end

/--
The 2-dimensional no retraction theorem asserts that there is no retraction
from the disk D² to its boundary circle S¹.
-/
theorem no_retraction_theorem (f : C(disk, frontier disk)) :
  ¬ retraction f :=
begin
  by_contradiction,

  let codomain_ptd_space : pointed_space (frontier disk) := ⟨f disk.pointed_space.basepoint⟩,

  have h_iso : fundamental_group codomain_ptd_space ≃* fundamental_group frontier_disk.pointed_space :=
    mulequiv_fg_of_path_conn codomain_ptd_space frontier_disk.pointed_space,

  let f_ptd : Cp(disk.pointed_space, codomain_ptd_space) := {
    to_fun := f,
    pointed_map := by refl,
  },
  have h_fptd_eq_f : f_ptd.to_continuous_map = f := begin
    ext,
    repeat {simp [f_ptd]},
  end,

  let φ_pre : (fundamental_group disk.pointed_space) →* (fundamental_group codomain_ptd_space) :=
    induced_hom f_ptd,
  have h_φpre_surj : function.surjective φ_pre :=
    surj_hom_of_surj f_ptd begin
      apply surjective_of_retraction,
      rw h_fptd_eq_f,
      exact h,
    end,

  let φ : (fundamental_group disk.pointed_space) →* (fundamental_group frontier_disk.pointed_space) :=
    monoid_hom.comp (mul_equiv.to_monoid_hom h_iso) φ_pre,

  have h_φ_surj : function.surjective φ :=
    begin
      apply function.surjective.comp,
      { exact mul_equiv.surjective h_iso, },
      { exact h_φpre_surj, },
    end,
  have hnot_surj : ¬ function.surjective φ := no_surj_hom_π₁D₂_to_frontier φ,

  contradiction,
end


import data.list.sort

-- set_option trace.eqn_compiler.elim_match true

universe variables u v
variables {α : Type} (r : α → α → Prop) [decidable_rel r]
local infix ` ≼ ` : 50 := r

namespace timeMonad

    inductive Timed (A : Sort u) (n : ℕ) : Sort (u + 1)
    | box : A → Timed

    open Timed

    infixl ` inTime `:55 := Timed

    @[simp] def untime {n : ℕ} {A : Sort u} : A inTime n → A
    | (box a) := a

    def bind {A : Sort u} {B : Sort v} {n m : ℕ} : A inTime n → (A → B inTime m) → B inTime (n + m)
    | (box a) f := box (untime (f a))

    def pure {A : Sort u} : A → A inTime 0 := box

    infixl ` >>= `:55 := bind

    def fmap {A : Sort u} {B : Sort v} {n : ℕ} : (A → B) → A inTime n → B inTime n
    | f (box a) := box (f a)
infixl ` <$> `:55 := fmap

    def eqBound {A : Sort u} {n m : ℕ} : (n = m) → A inTime n → A inTime m
    | _ (box a) := box a

    def relaxBound {A : Sort u} {n m : ℕ} : (n ≤ m) → A inTime n → A inTime m
    | _ (box a) := box a

    axiom timedQuery' : ∀ (a b : α), psum (r a b) (r b a) inTime 1

end timeMonad

open timeMonad

namespace insertionSort

/- theorem ff : ∀ {A : Sort u} (a : A),  untime (pure a) = a := -/
/- begin -/
/-   intros, -/

/- end -/

noncomputable def insert (a : α) : Π (xs : list α) , list α inTime xs.length
| []         := pure [a]
| (x :: xs') := have eqProof : (1 + xs'.length = (x :: xs').length),
                by { simp, exact add_comm 1 xs'.length, },
  eqBound eqProof $ timedQuery' r a x >>= λ cmp,
                   match cmp with
                     | (psum.inl ax) := relaxBound bot_le $ pure (a :: x :: xs')
                     | (psum.inr xa) := (λ z , x :: z) <$> insert xs'
                   end

noncomputable def insertion_sort : Π (xs : list α) , list α inTime (xs.length * xs.length)
| []         := pure []
| (x :: xs') := have time_bound: xs'.length * xs'.length ≤ (x :: xs').length * xs'.length,
                by { simp, rw mul_comm (xs'.length + 1) xs'.length, exact le_self_add, },
  relaxBound time_bound (insertion_sort xs') >>=
                (λ sorted_xs' ,
                  let same_lengths : sorted_xs'.length = xs'.length := sorry,
                      cons_inc_size: xs'.length ≤ (x :: xs').length := nat.le.intro rfl
                  in relaxBound cons_inc_size (eqBound same_lengths (insert r x sorted_xs')))

theorem insertion_sort_preserves_length :
  ∀ (xs : list α), xs.length = (untime (insertion_sort r xs)).length
| [] := begin simp, unfold insertion_sort, unfold timeMonad.pure, refl,  end
| (x :: xs') :=
begin
  simp,
  have ih := insertion_sort_preserves_length xs',
  cases insertion_sort r (x :: xs') with sorted_xs',
  simp,
  sorry,
end

end insertionSort


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.category.Module.basic
import Mathlib.PostPort

universes u v u_1

namespace Mathlib

/-!
# The concrete (co)kernels in the category of modules are (co)kernels in the categorical sense.
-/

namespace Module

/-- The kernel cone induced by the concrete kernel. -/
def kernel_cone {R : Type u} [ring R] {M : Module R} {N : Module R} (f : M ⟶ N) :
    category_theory.limits.kernel_fork f :=
  category_theory.limits.kernel_fork.of_ι (as_hom (submodule.subtype (linear_map.ker f))) sorry

/-- The kernel of a linear map is a kernel in the categorical sense. -/
def kernel_is_limit {R : Type u} [ring R] {M : Module R} {N : Module R} (f : M ⟶ N) :
    category_theory.limits.is_limit (kernel_cone f) :=
  category_theory.limits.fork.is_limit.mk (kernel_cone f)
    (fun (s : category_theory.limits.fork f 0) =>
      linear_map.cod_restrict (linear_map.ker f) (category_theory.limits.fork.ι s) sorry)
    sorry sorry

/-- The cokernel cocone induced by the projection onto the quotient. -/
def cokernel_cocone {R : Type u} [ring R] {M : Module R} {N : Module R} (f : M ⟶ N) :
    category_theory.limits.cokernel_cofork f :=
  category_theory.limits.cokernel_cofork.of_π (as_hom (submodule.mkq (linear_map.range f))) sorry

/-- The projection onto the quotient is a cokernel in the categorical sense. -/
def cokernel_is_colimit {R : Type u} [ring R] {M : Module R} {N : Module R} (f : M ⟶ N) :
    category_theory.limits.is_colimit (cokernel_cocone f) :=
  category_theory.limits.cofork.is_colimit.mk (cokernel_cocone f)
    (fun (s : category_theory.limits.cofork f 0) =>
      submodule.liftq (linear_map.range f) (category_theory.limits.cofork.π s) sorry)
    sorry sorry

/-- The category of R-modules has kernels, given by the inclusion of the kernel submodule. -/
theorem has_kernels_Module {R : Type u} [ring R] : category_theory.limits.has_kernels (Module R) :=
  category_theory.limits.has_kernels.mk
    fun (X Y : Module R) (f : X ⟶ Y) =>
      category_theory.limits.has_limit.mk
        (category_theory.limits.limit_cone.mk (kernel_cone f) (kernel_is_limit f))

/-- The category or R-modules has cokernels, given by the projection onto the quotient. -/
theorem has_cokernels_Module {R : Type u} [ring R] :
    category_theory.limits.has_cokernels (Module R) :=
  sorry

end Mathlib


/-
Author: <Redacted for anonymized submission>
-/
import data.mv_polynomial.basic
import data.polynomial.div
import data.polynomial.field_division
import algebra.polynomial.big_operators
import ...general_lemmas.polynomial_mv_sv_cast
import ...general_lemmas.mv_divisability
import ...general_lemmas.single_antidiagonal
import ...general_lemmas.polynomial_smul_eq_C_mul
import ...general_lemmas.single_injective
import .vars
import ...attributes

/-!
# Knowledge Soundness

This file proves the knowledge-soundness property of the
[Baby SNARK](https://github.com/initc3/babySNARK) system,
as described in section 5 of the paper.

NOTE: Currently we are not "in the exponent", we just prove things ignoring an explicit formalization of the Algebraic Group Model. Perhaps with more development, we can incorporate more of the background of this assumption

TODO: Many of the lemmas are poorly named, this file should be given a once-over to rename the lemmas'

TODO: remove lambdas where possible

TODO: Abstract more lemmas from the main theorem. A nice goal would be to make it so that the main points in the proof from the paper appear as have statements, with a comment giving an english description of the statement

TODO : move all mv forms of polynomial defs later and name them consistently

-/

open_locale big_operators

section

noncomputable theory

universes u

/-- The finite field parameter of our SNARK -/
parameter {F : Type u}
parameter [field F]

/-- The naturals representing:
  m - the number of gates in the circuit,
  n_stmt - the statement size,
  n_wit - the witness size -/
parameters {m n_stmt n_wit : ℕ}
def n := n_stmt + n_wit

-- NOTE: In the paper, n_stmt is l and n_wit is n-l. Here, n is defined from these values.

/-- u_stmt and u_wit are fin-indexed collections of polynomials from the square span program -/
parameter {u_stmt : fin n_stmt → (polynomial F) }
parameter {u_wit : fin n_wit → (polynomial F) }

/-- The roots of the polynomial t -/
parameter {r : fin m → F}
/-- t is the polynomial divisibility by which is used to verify satisfaction of the SSP -/
def t : polynomial F := ∏ i in (finset.fin_range m), (polynomial.X - polynomial.C (r i))
-- TODO this and the following lemmas about this could potentially be spun off
-- make a `monic_from_roots` function for mathlib

/-- t has degree m -/
lemma nat_degree_t : t.nat_degree = m
:=
begin
  -- rw polynomial.nat_degree,
  rw t,
  rw polynomial.nat_degree_prod,
  simp,
  intros i hi,
  exact polynomial.X_sub_C_ne_zero (r i),
end

lemma monic_t : t.monic
:=
begin
  rw t,
  apply polynomial.monic_prod_of_monic,
  intros i hi,
  exact polynomial.monic_X_sub_C (r i),
end

lemma degree_t_pos : 0 < m → 0 < t.degree
:=
begin
  intro hm,
  suffices h : t.degree = some m,
    rw h,
    apply with_bot.some_lt_some.2,
    exact hm,

  have h := nat_degree_t,
  rw polynomial.nat_degree at h,

  induction h1 : t.degree,

  rw h1 at h,
  rw option.get_or_else at h,
  rw h at hm,
  have h2 := has_lt.lt.false hm,
  exfalso,
  exact h2,

  rw h1 at h,
  rw option.get_or_else at h,
  rw h,
end

-- Single variable form of V_wit
def V_wit_sv (a_wit : fin n_wit → F) : polynomial F
:= ∑ i in finset.fin_range n_wit, a_wit i • u_wit i

/-- The statement polynomial that the verifier computes from the statement bits, as a single variable polynomial -/
def V_stmt_sv (a_stmt : fin n_stmt → F) : polynomial F
:= ∑ i in (finset.fin_range n_stmt), a_stmt i • u_stmt i

/-- Checks whether a statement witness pair satisfies the SSP -/
def satisfying (a_stmt : fin n_stmt → F ) (a_wit : fin n_wit → F) :=
(∑ i in (finset.fin_range n_stmt), a_stmt i • u_stmt i
  + (∑ i in (finset.fin_range n_wit), a_wit i • u_wit i))^2 %ₘ t = 1

/- Multivariable polynomial definititons and ultilities -/

/-- Helper for converting mv_polynomial to single -/
@[simp]
def singlify : vars -> polynomial F
| vars.X := polynomial.X
| vars.Y := 1
| vars.Z := 1

/-- Helpers for representing X, Y, Z as 3-variable polynomials -/
def X_poly : mv_polynomial vars F := mv_polynomial.X vars.X
def Y_poly : mv_polynomial vars F := mv_polynomial.X vars.Y
def Z_poly : mv_polynomial vars F := mv_polynomial.X vars.Z

/-- Multivariable version of t -/
def t_mv : mv_polynomial vars F := t.eval₂ mv_polynomial.C X_poly

/-- V_stmt as a multivariable polynomial of vars.X -/
def V_stmt_mv (a_stmt : fin n_stmt → F) : mv_polynomial vars F
:= (V_stmt_sv a_stmt).eval₂ mv_polynomial.C X_poly

/-- Converting a single variable polynomial to a multivariable polynomial and back yields the same polynomial -/
lemma my_multivariable_to_single_variable (p : polynomial F) : ((p.eval₂ mv_polynomial.C X_poly).eval₂ polynomial.C singlify) = p
:=
begin
  apply multivariable_to_single_variable,
  simp,
end

/-- The crs elements as multivariate polynomials of the toxic waste samples -/
def crs_powers_of_τ (i : fin m) : (mv_polynomial vars F) := X_poly^(i : ℕ)
def crs_γ : mv_polynomial vars F := Z_poly
def crs_γβ : mv_polynomial vars F := Z_poly * Y_poly
def crs_β_ssps (i : fin n_wit) : (mv_polynomial vars F) := (Y_poly) * (u_wit i).eval₂ mv_polynomial.C X_poly

/-- The coefficients of the CRS elements in the algebraic adversary's representation -/
parameters {b v h : fin m → F}
parameters {b_γ v_γ h_γ b_γβ v_γβ h_γβ : F}
parameters {b' v' h' : fin n_wit → F}

/-- Polynomial forms of the adversary's proof representation -/
def B_wit : mv_polynomial vars F :=
  ∑ i in (finset.fin_range m), (b i) • (crs_powers_of_τ i)
  +
  b_γ • crs_γ
  +
  b_γβ • crs_γβ
  +
  ∑ i in (finset.fin_range n_wit),  (b' i) • (crs_β_ssps i)

def V_wit : mv_polynomial vars F :=
  ∑ i in (finset.fin_range m), (v i) • (crs_powers_of_τ i)
  +
  v_γ • crs_γ
  +
  v_γβ • crs_γβ
  +
  ∑ i in (finset.fin_range n_wit), (v' i) • (crs_β_ssps i)

def H : mv_polynomial vars F :=
  ∑ i in (finset.fin_range m), (h i) • (crs_powers_of_τ i)
  +
  h_γ • crs_γ
  +
  h_γβ • crs_γβ
  +
  ∑ i in (finset.fin_range n_wit), (h' i) • (crs_β_ssps i)

/-- V as a multivariable polynomial -/
def V (a_stmt : fin n_stmt → F) : mv_polynomial vars F
:= V_stmt_mv a_stmt + V_wit

/- Lemmas for proof -/

lemma eq_helper (x j : ℕ) : x = j ∨ (x = 0 ∧ j = 0) ↔ x = j :=
begin
  split,
  intro h,
  cases h,
  exact h,
  rw [h.left, h.right],
  intro h,
  left,
  exact h,
end

lemma h2_1 : (∀ (i : fin m), B_wit.coeff (finsupp.single vars.X i) = b i) :=
begin
  intro j,
  rw B_wit,
  simp [crs_powers_of_τ, crs_γ, crs_γβ, crs_β_ssps],
  simp [X_poly, Y_poly, Z_poly],
  simp with coeff_simp,
  unfold_coes,
  --TODO is this best?
  -- TODO improve ite_finsupp_simplify with this
  -- simp [],
  -- ite_finsupp_simplify,
  -- simp only [single_injective_iff],
  -- simp [finsupp.single_eq_single_iff, ←fin.eq_iff_veq],
  simp [finsupp.single_eq_single_iff],
  simp only [eq_helper],
  unfold_coes,
  simp [←fin.eq_iff_veq],
end

lemma h3_1 : B_wit.coeff (finsupp.single vars.Z 1) = b_γ
:=
begin
  rw B_wit,
  simp [crs_powers_of_τ, crs_γ, crs_γβ, crs_β_ssps],
  simp [X_poly, Y_poly, Z_poly],
  simp with coeff_simp,
  simp [finsupp.single_eq_single_iff],
  -- -- simp? [-finsupp.single_nat_sub],
  -- simp?,
  -- ite_finsupp_simplify,
  -- simp only with coeff_simp,
  -- ite_finsupp_simplify,

end

lemma h4_1 : (∀ i, b i = 0) -> (λ (i : fin m), b i • crs_powers_of_τ i) = (λ (i : fin m), 0)
:=
begin
  intro tmp,
  apply funext,
  intro x,
  rw tmp x,
  simp,
end

lemma h5_1 : b_γβ • (Z_poly * Y_poly) = Y_poly * b_γβ • Z_poly :=
begin
  rw mv_polynomial.smul_eq_C_mul,
  rw mv_polynomial.smul_eq_C_mul,
  ring,
end

lemma h6_2 : (H * t_mv + mv_polynomial.C 1).coeff (finsupp.single vars.Z 2) = 0
:=
begin
  rw mv_polynomial.coeff_add,
  rw mv_polynomial.coeff_C,
  rw if_neg,
  rw mv_polynomial.coeff_mul,
  rw single_2_antidiagonal,
  rw finset.sum_insert,
  rw finset.sum_insert,
  rw finset.sum_singleton,
  simp [H, t_mv, crs_powers_of_τ, crs_γ, crs_γβ, crs_β_ssps, X_poly, Y_poly, Z_poly],
  simp only with coeff_simp polynomial_nf,
  -- unfold_coes,

  -- ite_finsupp_simplify,
  -- simp only with coeff_simp,

  simp [-finsupp.single_zero, finsupp.single_eq_single_iff],
  rw finset.mem_singleton,
  simp,
  simp [finset.mem_insert, finset.mem_singleton],
  simp,
  -- -- dec_trivial,

  -- rw finsupp.eq_single_iff,
  -- dec_trivial,

end

-- TODO check all lemmas are used

lemma h6_3 (a_stmt : fin n_stmt -> F) : (
    (b_γβ • Z_poly
      + ∑ (i : fin n_stmt) in finset.fin_range n_stmt, a_stmt i • polynomial.eval₂ mv_polynomial.C X_poly (u_stmt i)
      + ∑ (i : fin n_wit) in finset.fin_range n_wit, b' i • polynomial.eval₂ mv_polynomial.C X_poly (u_wit i)
    ) ^ 2).coeff (finsupp.single vars.Z 2) = b_γβ ^ 2
:=
begin
  rw pow_succ,
  rw pow_one,
  rw mv_polynomial.coeff_mul,
  rw single_2_antidiagonal,

  rw finset.sum_insert,
  rw finset.sum_insert,
  rw finset.sum_singleton,

  -- NOTE The simp only with coeff_simp and ite_finsupp_simplify tactic work here
  --      But I used to get deterministic timeout - i fixed this by making simp only with coeff_simp do simp only instead
  --
  simp [X_poly, Y_poly, Z_poly],
  simp only with coeff_simp polynomial_nf,
  -- simp only with coeff_simp,
  -- ite_finsupp_simplify,
  rw pow_succ,
  rw pow_one,

  simp,
  simp [-finsupp.single_zero, finsupp.single_eq_single_iff],
  simp [finset.mem_insert, finset.mem_singleton],
  simp,
  -- finish,
end

/-- This function represents the exctractor in the AGM. -/
def extractor : fin n_wit -> F := b'

/-- Show that if the adversary polynomials obey the equations,
then the coefficients give a satisfying witness.
This theorem appears in the Baby SNARK paper as Theorem 1 case 1. -/
theorem case_1 (a_stmt : fin n_stmt → F ) :
  (0 < m)
  -> (B_wit = V_wit * Y_poly)
  -> (H * t_mv + mv_polynomial.C 1 = (V a_stmt)^2)
  -> (satisfying a_stmt extractor)
:=
begin
  rw extractor,
  intros hm eqnI eqnII,
  -- TODO eqnI should have a Z term on both sides
  -- "B_wit only has terms with a Y component"
  have h1 : (∀ m : vars →₀ ℕ, m vars.Y = 0 -> B_wit.coeff m = 0),
    rw eqnI,
    apply mul_var_no_constant V_wit vars.Y,
  -- "b_0 b_1, ..., b_m, ... are all zero"
  have h2 : ∀ i : fin m, b i = 0,
    intro i,
    rw ← (h2_1 i),
    rw eqnI,
    apply mul_var_no_constant,
    rw finsupp.single_apply,
    simp,
  -- b_γ = 0
  have h3 : b_γ = 0,
    rw ← h3_1,
    rw eqnI,
    apply mul_var_no_constant,
    rw finsupp.single_apply,
    simp,
  -- "We can write B_wit as ..."
  have h4 : B_wit = b_γβ • crs_γβ + ∑ i in (finset.fin_range n_wit), (b' i) • (crs_β_ssps i),
    rw B_wit,
    rw h4_1 h2,
    rw h3,
    simp,
  -- "... we also see that V_wit must not have any Y terms at all"
  have h5 : V_wit = b_γβ • Z_poly + ∑ i in (finset.fin_range n_wit), (b' i) • ((u_wit i).eval₂ mv_polynomial.C X_poly),
    apply left_cancel_X_mul vars.Y,
    rw ←Y_poly,
    rw mul_comm,
    rw ←eqnI,
    rw h4,
    simp only [crs_γβ, crs_β_ssps],
    rw mul_add,
    rw h5_1,
    rw finset.mul_sum,
    simp,
  -- "... write V(.) as follows ..."
  have h6 : V a_stmt = b_γβ • Z_poly
      + ∑ i in (finset.fin_range n_stmt), (a_stmt i) • ((u_stmt i).eval₂ mv_polynomial.C X_poly)
      + ∑ i in (finset.fin_range n_wit), (b' i) • ((u_wit i).eval₂ mv_polynomial.C X_poly),
    rw V,
    rw V_stmt_mv,
    rw h5,
    rw V_stmt_sv,
    rw polynomial.eval₂_finset_sum,
    simp only [polynomial.eval₂_smul],
    simp only [←mv_polynomial.smul_eq_C_mul],
    ring,
  -- ... we can conclude that b_γβ = 0.
  have h7 : b_γβ = 0,
    let eqnII' := eqnII,
    rw h6 at eqnII',
    have h6_1 := congr_arg (mv_polynomial.coeff (finsupp.single vars.Z 2)) eqnII',
    rw h6_2 at h6_1,
    rw h6_3 at h6_1,
    exact pow_eq_zero (eq.symm h6_1),
  -- Finally, we arrive at the conclusion that the coefficients define a satisfying witness such that ...
  have h8 : V a_stmt =
      ∑ i in (finset.fin_range n_stmt), (a_stmt i) • ((u_stmt i).eval₂ mv_polynomial.C X_poly)
      + ∑ i in (finset.fin_range n_wit), (b' i) • ((u_wit i).eval₂ mv_polynomial.C X_poly),
    rw h6,
    rw h7,
    simp,
  -- Treat both sides of this a single variable polynomial
  have h9 := congr_arg (mv_polynomial.eval₂ (@polynomial.C F _) singlify) h8,
  rw mv_polynomial.eval₂_add at h9,
  rw mv_polynomial.eval₂_sum at h9,
  simp [mv_polynomial.smul_eq_C_mul] at h9,
  simp [my_multivariable_to_single_variable] at h9,
  simp [←polynomial.smul_eq_C_mul] at h9,
  -- Now we solve the main goal. First, we expand the definition of "satisfying"
  rw satisfying,
  rw ←h9,
  clear h8 h9,

  -- TODO is there a more efficient way to simply say (evaluate f on both sides of this hypothesis)? Yes the congr tactic does this
  have h10 : ((H * t_mv + mv_polynomial.C 1).eval₂ polynomial.C singlify) %ₘ t = (((V a_stmt)^2).eval₂ polynomial.C singlify) %ₘ t,
    rw eqnII,
  -- h10 done
  rw mv_polynomial.eval₂_add at h10,
  rw mv_polynomial.eval₂_mul at h10,

  rw ←mv_polynomial.eval₂_pow,

  rw ←h10,
  rw t_mv,
  rw my_multivariable_to_single_variable t,
  have h12: mv_polynomial.C 1 = (polynomial.C 1 : polynomial F).eval₂ mv_polynomial.C X_poly,
    rw polynomial.eval₂_C,
  -- h12 done
  rw h12,
  rw my_multivariable_to_single_variable,
  have h13 : (mv_polynomial.eval₂ polynomial.C singlify H * t + polynomial.C 1 : polynomial F) /ₘ t = (mv_polynomial.eval₂ polynomial.C singlify H : polynomial F) ∧ (mv_polynomial.eval₂ polynomial.C singlify H * t + polynomial.C 1 : polynomial F) %ₘ t = (polynomial.C 1 : polynomial F),
    apply polynomial.div_mod_by_monic_unique,
    exact monic_t,
    split,
    rw [add_comm, mul_comm],
    rw polynomial.degree_C,
    exact degree_t_pos hm,
    exact one_ne_zero,
  -- h13 done
  rw h13.2,
  simp,
end

end


import group_theory.free_group

import sub_pq

universe u

section pq_group_sub_pq_free_rel

variables {Q : Type u} [power_quandle Q] {Q1 : sub_power_quandle Q}

inductive pq_rel : free_group Q → Prop
| incl_conj (x y : Q) (hx : x ∈ (↑Q1 : set Q)) (hy : y ∈ (↑Q1 : set Q)) : pq_rel ((free_group.of x)*(free_group.of y)*(free_group.of x)⁻¹*(free_group.of (x ▷ y))⁻¹)
| incl_pow (x : Q) (hx : x ∈ (↑Q1 : set Q)) (n : ℤ) : pq_rel ((free_group.of x) ^ n * (free_group.of (x ^ n))⁻¹)
| mul (x y : free_group Q) (hx : pq_rel x) (hy : pq_rel y) : pq_rel (x * y)
| inv (x : free_group Q) (hx : pq_rel x) : pq_rel (x⁻¹)
| one : pq_rel 1

def pq_rel_subgroup (Q1 : sub_power_quandle Q) : subgroup (free_group Q) := {
  carrier := @pq_rel Q _ Q1,
  one_mem' := pq_rel.one,
  mul_mem' := pq_rel.mul,
  inv_mem' := pq_rel.inv }

inductive sub_free_rel : free_group Q → Prop
| incl (x : Q) (hx : x ∈ (↑Q1 : set Q)) : sub_free_rel (free_group.of x)
| mul (x y : free_group Q) (hx : sub_free_rel x) (hy : sub_free_rel y) : sub_free_rel (x * y)
| inv (x : free_group Q) (hx : sub_free_rel x) : sub_free_rel (x⁻¹)
| one : sub_free_rel 1

def sub_free_subgroup (Q1 : sub_power_quandle Q) : subgroup (free_group Q) := {
  carrier := @sub_free_rel Q _ Q1,
  one_mem' := sub_free_rel.one,
  mul_mem' := sub_free_rel.mul,
  inv_mem' := sub_free_rel.inv }

lemma sub_free_subgroup_of_mem (Q1 : sub_power_quandle Q) (x : Q) : x ∈ (↑Q1 : set Q) ↔ free_group.of x ∈ sub_free_subgroup Q1 :=
begin
  split,
  {
    intro hx,
    apply sub_free_rel.incl x hx,
  },
  {
    generalize hx : free_group.of x = y,
    intro hy,
    induction y,
    {
      induction y,
      {
        clear hy,
        exfalso,
        rw free_group.of at hx,
        have hx1 := free_group.red.exact.mp hx,
        sorry,
      },
      {
        sorry,
      },
    },
    {
      refl,
    },
  },
end

lemma pq_rel_sub_pq (Q1 : sub_power_quandle Q) (Q2 : sub_power_quandle Q) (hQ2 : Q1 ≤ Q2) : pq_rel_subgroup Q1 ≤ pq_rel_subgroup Q2 :=
begin
  intros x hx,
  induction hx,
  {
    apply pq_rel.incl_conj,
    {
      apply hQ2,
      exact hx_hx,
    },
    {
      apply hQ2,
      exact hx_hy,
    },
  },
  {
    apply pq_rel.incl_pow,
    {
      apply hQ2,
      exact hx_hx,
    },
  },
  {
    exact (pq_rel_subgroup Q2).mul_mem hx_ih_hx hx_ih_hy,
  },
  {
    exact (pq_rel_subgroup Q2).inv_mem hx_ih,
  },
  {
    exact (pq_rel_subgroup Q2).one_mem,
  },
end

lemma pq_rel_sub_sub_free (Q1 : sub_power_quandle Q) : pq_rel_subgroup Q1 ≤ sub_free_subgroup Q1 :=
begin
  intros x hx,
  induction hx,
  {
    apply (sub_free_subgroup Q1).mul_mem,
    apply (sub_free_subgroup Q1).mul_mem,
    apply (sub_free_subgroup Q1).mul_mem,
    apply sub_free_rel.incl, assumption,
    apply sub_free_rel.incl, assumption,
    apply (sub_free_subgroup Q1).inv_mem,
    apply sub_free_rel.incl, assumption,
    apply (sub_free_subgroup Q1).inv_mem,
    apply sub_free_rel.incl,
    exact Q1.closed_rhd hx_x hx_y hx_hx hx_hy,
  },
  {
    apply (sub_free_subgroup Q1).mul_mem,
    apply (sub_free_subgroup Q1).gpow_mem,
    apply sub_free_rel.incl, assumption,
    apply (sub_free_subgroup Q1).inv_mem,
    apply sub_free_rel.incl,
    exact Q1.closed_pow hx_x hx_n hx_hx,
  },
  {
    exact (sub_free_subgroup Q1).mul_mem hx_ih_hx hx_ih_hy,
  },
  {
    exact (sub_free_subgroup Q1).inv_mem hx_ih,
  },
  {
    exact (sub_free_subgroup Q1).one_mem,
  },
end

inductive pq_rel_element (Q1 : sub_power_quandle Q) : Type u
| conj_incl (x y : Q) (hx : x ∈ (↑Q1 : set Q)) (hy : y ∈ (↑Q1 : set Q)) : pq_rel_element
| conj_incl_inv (x y : Q) (hx : x ∈ (↑Q1 : set Q)) (hy : y ∈ (↑Q1 : set Q)) : pq_rel_element
| pow_incl (x : Q) (n : ℤ) (hx : x ∈ (↑Q1 : set Q)) : pq_rel_element
| pow_incl_inv (x : Q) (n : ℤ) (hx : x ∈ (↑Q1 : set Q)) : pq_rel_element

def pq_rel_element_to_free (Q1 : sub_power_quandle Q) : pq_rel_element Q1 → free_group Q
| (pq_rel_element.conj_incl x y hx hy) := (free_group.of x)*(free_group.of y)*(free_group.of x)⁻¹*(free_group.of (x ▷ y))⁻¹
| (pq_rel_element.conj_incl_inv x y hx hy) := (free_group.of (x ▷ y))*(free_group.of x)*(free_group.of y)⁻¹*(free_group.of x)⁻¹
| (pq_rel_element.pow_incl x n hx) := ((free_group.of x) ^ n * (free_group.of (x ^ n))⁻¹)
| (pq_rel_element.pow_incl_inv x n hx) := ((free_group.of (x ^ n)) * (free_group.of x) ^ (-n))

def pq_rel_element_inv (Q1 : sub_power_quandle Q) : pq_rel_element Q1 → pq_rel_element Q1
| (pq_rel_element.conj_incl x y hx hy) := (pq_rel_element.conj_incl_inv x y hx hy)
| (pq_rel_element.conj_incl_inv x y hx hy) := (pq_rel_element.conj_incl x y hx hy)
| (pq_rel_element.pow_incl x n hx) := (pq_rel_element.pow_incl_inv x n hx)
| (pq_rel_element.pow_incl_inv x n hx) := (pq_rel_element.pow_incl x n hx)

theorem pq_rel_element_inv_to_free (Q1 : sub_power_quandle Q) (x : pq_rel_element Q1) : pq_rel_element_to_free Q1 (pq_rel_element_inv Q1 x) = (pq_rel_element_to_free Q1 x)⁻¹ :=
begin
  cases x,
  {
    unfold pq_rel_element_inv,
    unfold pq_rel_element_to_free,
    group,
  },
  {
    unfold pq_rel_element_inv,
    unfold pq_rel_element_to_free,
    group,
  },
  {
    unfold pq_rel_element_inv,
    unfold pq_rel_element_to_free,
    group,
  },
  {
    unfold pq_rel_element_inv,
    unfold pq_rel_element_to_free,
    group,
  },
end

theorem pq_rel_construction (x : free_group Q) (hx : x ∈ pq_rel_subgroup Q1) : ∃ y : list (pq_rel_element Q1), x = list.prod (list.map (pq_rel_element_to_free Q1) y) :=
begin
  induction hx,
  {
    use pq_rel_element.conj_incl hx_x hx_y hx_hx hx_hy :: list.nil,
    simp only [mul_one, list.prod_cons, list.prod_nil, list.map],
    refl,
  },
  {
    use pq_rel_element.pow_incl hx_x hx_n hx_hx :: list.nil,
    simp only [mul_one, list.prod_cons, list.prod_nil, list.map],
    refl,
  },
  {
    cases hx_ih_hx with a ha,
    cases hx_ih_hy with b hb,
    use a ++ b,
    simp only [list.map_append, list.prod_append],
    rw ha,
    rw hb,
  },
  {
    cases hx_ih with a ha,
    use (list.reverse (list.map (pq_rel_element_inv Q1) a)),
    rw ha,
    clear ha,
    simp only [list.map_reverse, list.map_map],
    induction a,
    {
      simp only [inv_eq_one, list.prod_nil, list.map, list.reverse_nil],
    },
    {
      simp only [list.reverse_cons, mul_inv_rev, mul_one, list.prod_append, function.comp_app, list.prod_cons, list.prod_nil, list.map],
      rw pq_rel_element_inv_to_free,
      simp only [mul_left_inj],
      rw a_ih,
    },
  },
  {
    use list.nil,
    simp only [list.prod_nil, list.map],
  },
end

theorem intersection_is_sub_pq_rel : (sub_free_subgroup Q1) ⊓ (pq_rel_subgroup (sub_pq_univ Q)) = (pq_rel_subgroup Q1) :=
begin
  ext1,
  split,
  {
    intro hx,
    rw subgroup.mem_inf at hx,
    cases hx with hx1 hx2,
    have hx3 := pq_rel_construction x hx2,
    cases hx3 with y hy,
    rw hy,
    rw hy at hx1,
    clear hx2,
    clear hy,
    clear x,
    rename hx1 hy,
    induction y,
    {
      simp only [list.prod_nil, list.map],
      exact (pq_rel_subgroup Q1).one_mem,
    },
    {
      simp only [list.prod_cons, list.map],
      simp only [list.prod_cons, list.map] at hy,
      by_cases (pq_rel_element_to_free (sub_pq_univ Q) y_hd ∈ pq_rel_subgroup Q1),
      {
        apply subgroup.mul_mem,
        apply h,
        apply y_ih,
        have alg_rw : (list.map (pq_rel_element_to_free (sub_pq_univ Q)) y_tl).prod = (pq_rel_element_to_free (sub_pq_univ Q) y_hd)⁻¹ * ((pq_rel_element_to_free (sub_pq_univ Q) y_hd) * (list.map (pq_rel_element_to_free (sub_pq_univ Q)) y_tl).prod),
        {
          group,
        },
        rw alg_rw,
        clear alg_rw,
        apply subgroup.mul_mem,
        {
          apply subgroup.inv_mem,
          apply pq_rel_sub_sub_free Q1 h,
        },
        {
          apply hy,
        },
      },
      {
        rename h hy1,
        cases y_hd,
        {
          rename y_hd_x a,
          rename y_hd_y b,
          unfold pq_rel_element_to_free at *,
          induction y_tl,
          {
            simp only [mul_one, list.prod_nil, list.map],
            simp only [mul_one, list.prod_nil, list.map] at hy,
            apply pq_rel.incl_conj,
            {
              suffices : free_group.of a ∈ sub_free_subgroup Q1,
              {
                rw sub_free_subgroup_of_mem,
                assumption,
              },
              sorry,
            },
            {
              sorry,
            },
          },
          {
            sorry,
          },
        },
        {
          sorry,
        },
        {
          sorry,
        },
        {
          sorry,
        },
      },
    },
  },
  {
    intro hx,
    rw subgroup.mem_inf,
    split,
    {
      apply pq_rel_sub_sub_free Q1 hx,
    },
    {
      apply pq_rel_sub_pq Q1 (sub_pq_univ Q) (sub_pq_univ_le Q1) hx,
    },
  },
end

end pq_group_sub_pq_free_rel