/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.limits
import Mathlib.category_theory.concrete_category.basic
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# Facts about (co)limits of functors into concrete categories
-/

namespace category_theory.limits

-- We now prove a lemma about naturality of cones over functors into bundled categories.

namespace cone

/-- Naturality of a cone over functors to a concrete category. -/
@[simp] theorem w_apply {J : Type v} [small_category J] {C : Type u} [category C] [concrete_category C] {F : J ⥤ C} (s : cone F) {j : J} {j' : J} (f : j ⟶ j') (x : ↥(X s)) : coe_fn (functor.map F f) (coe_fn (nat_trans.app (π s) j) x) = coe_fn (nat_trans.app (π s) j') x := sorry

@[simp] theorem w_forget_apply {J : Type v} [small_category J] {C : Type u} [category C] [concrete_category C] (F : J ⥤ C) (s : cone (F ⋙ forget C)) {j : J} {j' : J} (f : j ⟶ j') (x : X s) : coe_fn (functor.map F f) (nat_trans.app (π s) j x) = nat_trans.app (π s) j' x :=
  congr_fun (w s f) x

end cone

namespace cocone

/-- Naturality of a cocone over functors into a concrete category. -/
@[simp] theorem w_apply {J : Type v} [small_category J] {C : Type u} [category C] [concrete_category C] {F : J ⥤ C} (s : cocone F) {j : J} {j' : J} (f : j ⟶ j') (x : ↥(functor.obj F j)) : coe_fn (nat_trans.app (ι s) j') (coe_fn (functor.map F f) x) = coe_fn (nat_trans.app (ι s) j) x := sorry

@[simp] theorem w_forget_apply {J : Type v} [small_category J] {C : Type u} [category C] [concrete_category C] (F : J ⥤ C) (s : cocone (F ⋙ forget C)) {j : J} {j' : J} (f : j ⟶ j') (x : ↥(functor.obj F j)) : nat_trans.app (ι s) j' (coe_fn (functor.map F f) x) = nat_trans.app (ι s) j x :=
  congr_fun (w s f) x

end cocone

@[simp] theorem limit.lift_π_apply {J : Type v} [small_category J] {C : Type u} [category C] [concrete_category C] (F : J ⥤ C) [has_limit F] (s : cone F) (j : J) (x : ↥(cone.X s)) : coe_fn (limit.π F j) (coe_fn (limit.lift F s) x) = coe_fn (nat_trans.app (cone.π s) j) x := sorry

@[simp] theorem limit.w_apply {J : Type v} [small_category J] {C : Type u} [category C] [concrete_category C] (F : J ⥤ C) [has_limit F] {j : J} {j' : J} (f : j ⟶ j') (x : ↥(limit F)) : coe_fn (functor.map F f) (coe_fn (limit.π F j) x) = coe_fn (limit.π F j') x := sorry

@[simp] theorem colimit.ι_desc_apply {J : Type v} [small_category J] {C : Type u} [category C] [concrete_category C] (F : J ⥤ C) [has_colimit F] (s : cocone F) (j : J) (x : ↥(functor.obj F j)) : coe_fn (colimit.desc F s) (coe_fn (colimit.ι F j) x) = coe_fn (nat_trans.app (cocone.ι s) j) x := sorry

@[simp] theorem colimit.w_apply {J : Type v} [small_category J] {C : Type u} [category C] [concrete_category C] (F : J ⥤ C) [has_colimit F] {j : J} {j' : J} (f : j ⟶ j') (x : ↥(functor.obj F j)) : coe_fn (colimit.ι F j') (coe_fn (functor.map F f) x) = coe_fn (colimit.ι F j) x := sorry


import topology.sheaves.functors
import topology.sheaves.sheaf_condition.sites

namespace Top.sheaf

universes w v u

open category_theory category_theory.limits topological_space

variables (A : Type*) [category.{w} A] [concrete_category.{w} A] [has_colimits A] [has_limits A]
variables [preserves_limits (category_theory.forget A)]
variables [preserves_filtered_colimits (category_theory.forget A)]
variables [reflects_isomorphisms (category_theory.forget A)]

variables {C : Type u} [category.{v} C]
variables {X Y Z : Top.{w}} (f : X ⟶ Y)
variables ⦃ι : Type w⦄ {U : ι → opens Y}

noncomputable theory

lemma pushforward_forget (f : X ⟶ Y) :
  pushforward f ⋙ forget C Y = forget C X ⋙ Top.presheaf.pushforward C f := rfl

/--
Pushforward of sheaves is isomorphic (actually definitionally equal) to pushforward of presheaves.
-/
def pushforward_forget_iso (f : X ⟶ Y) :
  pushforward f ⋙ forget C Y ≅ forget C X ⋙ Top.presheaf.pushforward C f := iso.refl _

variables {C}

@[simp] lemma pushforward_obj_val (f : X ⟶ Y) (F : X.sheaf C) :
  ((pushforward f).obj F).1 = f _* F.1 := rfl

@[simp] lemma pushforward_map (f : X ⟶ Y) {F F' : X.sheaf C} (α : F ⟶ F') :
  ((pushforward f).map α).1 = (Top.presheaf.pushforward C f).map α.1 := rfl

/--
The pushforward functor.
-/
def pullback (f : X ⟶ Y) : Y.sheaf A ⥤ X.sheaf A :=
sites.pushforward A _ _ (opens.map f)

lemma pullback_eq (f : X ⟶ Y) :
  pullback A f = forget A Y ⋙ Top.presheaf.pullback A f ⋙ presheaf_to_Sheaf _ _ := rfl

/--
The pullback of a sheaf is isomorphic (actually definitionally equal) to the sheafification
of the pullback as a presheaf.
-/
def pullback_iso (f : X ⟶ Y) :
  pullback A f ≅ forget A Y ⋙ Top.presheaf.pullback A f ⋙ presheaf_to_Sheaf _ _ := iso.refl _

instance : representably_flat (opens.map f) :=
begin
  constructor,
  intro U,
  apply_with is_cofiltered.mk { instances := ff },
  constructor,
  { intros V W,
    refine ⟨⟨⟨punit.star⟩, V.right ⊓ W.right, hom_of_le $ le_inf V.hom.le W.hom.le⟩,
      { right := hom_of_le inf_le_left }, { right := hom_of_le inf_le_right }, trivial⟩ },
  { intros U V i j, refine ⟨_, 𝟙 _, by ext; congr⟩ },
  { exact ⟨structured_arrow.mk $ show U ⟶ (opens.map f).obj ⊤, from hom_of_le le_top⟩ },
end

lemma compatible_preserving_opens_map :
  compatible_preserving (opens.grothendieck_topology X) (opens.map f) :=
compatible_preserving_of_flat _ _

lemma cover_preserving_opens_map :
  cover_preserving (opens.grothendieck_topology Y)
    (opens.grothendieck_topology X) (opens.map f) :=
begin
  constructor,
  intros U S hS x hx,
  obtain ⟨V, i, hi, hxV⟩ := hS (f x) hx,
  exact ⟨_, (opens.map f).map i, ⟨_, _, 𝟙 _, hi, subsingleton.elim _ _⟩, hxV⟩
end

/-- The adjunction between pullback and pushforward for sheaves on topological spaces. -/
def pullback_pushforward_adjunction (f : X ⟶ Y) :
  pullback A f ⊣ pushforward f :=
sites.pullback_pushforward_adjunction _ _ _ (compatible_preserving_opens_map f)
  (cover_preserving_opens_map f)

instance : is_left_adjoint (pullback A f) := ⟨_, pullback_pushforward_adjunction A f⟩
instance : is_right_adjoint (pushforward f : X.sheaf A ⥤ Y.sheaf A) :=
⟨_, pullback_pushforward_adjunction A f⟩

variables (g : Y ⟶ Z)

noncomputable!
def pushforward_comp :
  pushforward f ⋙ pushforward g ≅ (pushforward (f ≫ g) : X.sheaf C ⥤ Z.sheaf C) :=
iso.refl _

noncomputable!
def pullback_comp :
  pullback A g ⋙ pullback A f ≅ pullback A (f ≫ g) :=
adjunction.nat_iso_of_right_adjoint_nat_iso
  ((pullback_pushforward_adjunction A g).comp (pullback_pushforward_adjunction A f))
  (pullback_pushforward_adjunction A (f ≫ g)) (pushforward_comp f g)

def pullback_congr {f g : X ⟶ Y} (e : f = g) :
  pullback A f ≅ pullback A g :=
eq_to_iso (by subst e)

end Top.sheaf


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.homology.homotopy
import category_theory.quotient

/-!
# The homotopy category

`homotopy_category V c` gives the category of chain complexes of shape `c` in `V`,
with chain maps identified when they are homotopic.
-/

universes v u

open_locale classical
noncomputable theory

open category_theory category_theory.limits homological_complex

variables {ι : Type*}
variables (V : Type u) [category.{v} V] [preadditive V]
variables (c : complex_shape ι)

/--
The congruence on `homological_complex V c` given by the existence of a homotopy.
-/
def homotopic : hom_rel (homological_complex V c) := λ C D f g, nonempty (homotopy f g)

instance homotopy_congruence : congruence (homotopic V c) :=
{ is_equiv := λ C D,
  { refl := λ C, ⟨homotopy.refl C⟩,
    symm := λ f g ⟨w⟩, ⟨w.symm⟩,
    trans := λ f g h ⟨w₁⟩ ⟨w₂⟩, ⟨w₁.trans w₂⟩, },
  comp_left := λ E F G m₁ m₂ g ⟨i⟩, ⟨i.comp_left _⟩,
  comp_right := λ E F G f m₁ m₂ ⟨i⟩, ⟨i.comp_right _⟩, }

/-- `homotopy_category V c` is the category of chain complexes of shape `c` in `V`,
with chain maps identified when they are homotopic. -/
@[derive category]
def homotopy_category := category_theory.quotient (homotopic V c)

-- TODO the homotopy_category is preadditive

namespace homotopy_category

/-- The quotient functor from complexes to the homotopy category. -/
def quotient : homological_complex V c ⥤ homotopy_category V c :=
category_theory.quotient.functor _

open_locale zero_object

-- TODO upgrade this to `has_zero_object`, presumably for any `quotient`.
instance [has_zero_object V] : inhabited (homotopy_category V c) := ⟨(quotient V c).obj 0⟩

variables {V c}

@[simp] lemma quotient_obj_as (C : homological_complex V c) :
  ((quotient V c).obj C).as = C := rfl

@[simp] lemma quotient_map_out {C D : homotopy_category V c} (f : C ⟶ D) :
  (quotient V c).map f.out = f :=
quot.out_eq _

lemma eq_of_homotopy {C D : homological_complex V c} (f g : C ⟶ D) (h : homotopy f g) :
  (quotient V c).map f = (quotient V c).map g :=
category_theory.quotient.sound _ ⟨h⟩

/-- If two chain maps become equal in the homotopy category, then they are homotopic. -/
def homotopy_of_eq {C D : homological_complex V c} (f g : C ⟶ D)
  (w : (quotient V c).map f = (quotient V c).map g) : homotopy f g :=
((quotient.functor_map_eq_iff _ _ _).mp w).some

/--
An arbitrarily chosen representation of the image of a chain map in the homotopy category
is homotopic to the original chain map.
-/
def homotopy_out_map {C D : homological_complex V c} (f : C ⟶ D) :
  homotopy ((quotient V c).map f).out f :=
begin
  apply homotopy_of_eq,
  simp,
end

@[simp] lemma quotient_map_out_comp_out {C D E : homotopy_category V c} (f : C ⟶ D) (g : D ⟶ E) :
  (quotient V c).map (quot.out f ≫ quot.out g) = f ≫ g :=
by conv_rhs { erw [←quotient_map_out f, ←quotient_map_out g, ←(quotient V c).map_comp], }

/-- Homotopy equivalent complexes become isomorphic in the homotopy category. -/
@[simps]
def iso_of_homotopy_equiv {C D : homological_complex V c} (f : homotopy_equiv C D) :
  (quotient V c).obj C ≅ (quotient V c).obj D :=
{ hom := (quotient V c).map f.hom,
  inv := (quotient V c).map f.inv,
  hom_inv_id' := begin
    rw [←(quotient V c).map_comp, ←(quotient V c).map_id],
    exact eq_of_homotopy _ _ f.homotopy_hom_inv_id,
  end,
  inv_hom_id' := begin
    rw [←(quotient V c).map_comp, ←(quotient V c).map_id],
    exact eq_of_homotopy _ _ f.homotopy_inv_hom_id,
  end }

/-- If two complexes become isomorphic in the homotopy category,
  then they were homotopy equivalent. -/
def homotopy_equiv_of_iso
  {C D : homological_complex V c} (i : (quotient V c).obj C ≅ (quotient V c).obj D) :
  homotopy_equiv C D :=
{ hom := quot.out i.hom,
  inv := quot.out i.inv,
  homotopy_hom_inv_id := homotopy_of_eq _ _ (by { simp, refl, }),
  homotopy_inv_hom_id := homotopy_of_eq _ _ (by { simp, refl, }), }

variables (V c) [has_equalizers V] [has_images V] [has_image_maps V]
  [has_cokernels V]

/-- The `i`-th homology, as a functor from the homotopy category. -/
def homology_functor (i : ι) : homotopy_category V c ⥤ V :=
category_theory.quotient.lift _ (homology_functor V c i)
  (λ C D f g ⟨h⟩, homology_map_eq_of_homotopy h i)

/-- The homology functor on the homotopy category is just the usual homology functor. -/
def homology_factors (i : ι) :
  quotient V c ⋙ homology_functor V c i ≅ _root_.homology_functor V c i :=
category_theory.quotient.lift.is_lift _ _ _

@[simp] lemma homology_factors_hom_app (i : ι) (C : homological_complex V c) :
  (homology_factors V c i).hom.app C = 𝟙 _ :=
rfl

@[simp] lemma homology_factors_inv_app (i : ι) (C : homological_complex V c) :
  (homology_factors V c i).inv.app C = 𝟙 _ :=
rfl

lemma homology_functor_map_factors (i : ι) {C D : homological_complex V c} (f : C ⟶ D) :
  (_root_.homology_functor V c i).map f =
    ((homology_functor V c i).map ((quotient V c).map f) : _) :=
(category_theory.quotient.lift_map_functor_map _ (_root_.homology_functor V c i) _ f).symm

end homotopy_category

namespace category_theory

variables {V} {W : Type*} [category W] [preadditive W]

/-- An additive functor induces a functor between homotopy categories. -/
@[simps]
def functor.map_homotopy_category (c : complex_shape ι) (F : V ⥤ W) [F.additive] :
  homotopy_category V c ⥤ homotopy_category W c :=
{ obj := λ C, (homotopy_category.quotient W c).obj ((F.map_homological_complex c).obj C.as),
  map := λ C D f,
    (homotopy_category.quotient W c).map ((F.map_homological_complex c).map (quot.out f)),
  map_id' := λ C, begin
    rw ←(homotopy_category.quotient W c).map_id,
    apply homotopy_category.eq_of_homotopy,
    rw ←(F.map_homological_complex c).map_id,
    apply F.map_homotopy,
    apply homotopy_category.homotopy_of_eq,
    exact quot.out_eq _,
  end,
  map_comp' := λ C D E f g, begin
    rw ←(homotopy_category.quotient W c).map_comp,
    apply homotopy_category.eq_of_homotopy,
    rw ←(F.map_homological_complex c).map_comp,
    apply F.map_homotopy,
    apply homotopy_category.homotopy_of_eq,
    convert quot.out_eq _,
    exact homotopy_category.quotient_map_out_comp_out _ _,
  end }.

-- TODO `F.map_homotopy_category c` is additive (and linear when `F` is linear).

/-- A natural transformation induces a natural transformation between
  the induced functors on the homotopy category. -/
@[simps]
def nat_trans.map_homotopy_category {F G : V ⥤ W} [F.additive] [G.additive]
  (α : F ⟶ G) (c : complex_shape ι) : F.map_homotopy_category c ⟶ G.map_homotopy_category c :=
{ app := λ C,
    (homotopy_category.quotient W c).map ((nat_trans.map_homological_complex α c).app C.as),
  naturality' := λ C D f,
  begin
    dsimp,
    simp only [←functor.map_comp],
    congr' 1,
    ext,
    dsimp,
    simp,
  end }

@[simp] lemma nat_trans.map_homotopy_category_id (c : complex_shape ι) (F : V ⥤ W) [F.additive] :
  nat_trans.map_homotopy_category (𝟙 F) c = 𝟙 (F.map_homotopy_category c) :=
by tidy

@[simp] lemma nat_trans.map_homotopy_category_comp (c : complex_shape ι)
  {F G H : V ⥤ W} [F.additive] [G.additive] [H.additive]
  (α : F ⟶ G) (β : G ⟶ H):
  nat_trans.map_homotopy_category (α ≫ β) c =
    nat_trans.map_homotopy_category α c ≫ nat_trans.map_homotopy_category β c :=
by tidy

end category_theory


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

! This file was ported from Lean 3 source module combinatorics.quiver.arborescence
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.WellFounded
import Mathbin.Data.Nat.Basic
import Mathbin.Combinatorics.Quiver.Subquiver
import Mathbin.Combinatorics.Quiver.Path

/-!
# Arborescences

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

A quiver `V` is an arborescence (or directed rooted tree) when we have a root vertex `root : V` such
that for every `b : V` there is a unique path from `root` to `b`.

## Main definitions

- `quiver.arborescence V`: a typeclass asserting that `V` is an arborescence
- `arborescence_mk`: a convenient way of proving that a quiver is an arborescence
- `rooted_connected r`: a typeclass asserting that there is at least one path from `r` to `b` for
every `b`.
- `geodesic_subtree r`: given `[rooted_conntected r]`, this is a subquiver of `V` which contains
just enough edges to include a shortest path from `r` to `b` for every `b`.
- `geodesic_arborescence : arborescence (geodesic_subtree r)`: an instance saying that the geodesic
subtree is an arborescence. This proves the directed analogue of 'every connected graph has a
spanning tree'. This proof avoids the use of Zorn's lemma.
-/

open Opposite

universe v u

namespace Quiver

#print Quiver.Arborescence /-
/-- A quiver is an arborescence when there is a unique path from the default vertex
    to every other vertex. -/
class Arborescence (V : Type u) [Quiver.{v} V] : Type max u v where
  root : V
  uniquePath : ∀ b : V, Unique (Path root b)
#align quiver.arborescence Quiver.Arborescence
-/

#print Quiver.root /-
/-- The root of an arborescence. -/
def root (V : Type u) [Quiver V] [Arborescence V] : V :=
  Arborescence.root
#align quiver.root Quiver.root
-/

instance {V : Type u} [Quiver V] [Arborescence V] (b : V) : Unique (Path (root V) b) :=
  Arborescence.uniquePath b

#print Quiver.arborescenceMk /-
/-- To show that `[quiver V]` is an arborescence with root `r : V`, it suffices to
  - provide a height function `V → ℕ` such that every arrow goes from a
    lower vertex to a higher vertex,
  - show that every vertex has at most one arrow to it, and
  - show that every vertex other than `r` has an arrow to it. -/
noncomputable def arborescenceMk {V : Type u} [Quiver V] (r : V) (height : V → ℕ)
    (height_lt : ∀ ⦃a b⦄, (a ⟶ b) → height a < height b)
    (unique_arrow : ∀ ⦃a b c : V⦄ (e : a ⟶ c) (f : b ⟶ c), a = b ∧ HEq e f)
    (root_or_arrow : ∀ b, b = r ∨ ∃ a, Nonempty (a ⟶ b)) : Arborescence V
    where
  root := r
  uniquePath b :=
    ⟨Classical.inhabited_of_nonempty
        (by
          rcases show ∃ n, height b < n from ⟨_, Nat.lt.base _⟩ with ⟨n, hn⟩
          induction' n with n ih generalizing b
          · exact False.elim (Nat.not_lt_zero _ hn)
          rcases root_or_arrow b with (⟨⟨⟩⟩ | ⟨a, ⟨e⟩⟩)
          · exact ⟨path.nil⟩
          · rcases ih a (lt_of_lt_of_le (height_lt e) (nat.lt_succ_iff.mp hn)) with ⟨p⟩
            exact ⟨p.cons e⟩),
      by
      have height_le : ∀ {a b}, Path a b → height a ≤ height b :=
        by
        intro a b p
        induction' p with b c p e ih
        rfl
        exact le_of_lt (lt_of_le_of_lt ih (height_lt e))
      suffices ∀ p q : Path r b, p = q by
        intro p
        apply this
      intro p q
      induction' p with a c p e ih <;> cases' q with b _ q f
      · rfl
      · exact False.elim (lt_irrefl _ (lt_of_le_of_lt (height_le q) (height_lt f)))
      · exact False.elim (lt_irrefl _ (lt_of_le_of_lt (height_le p) (height_lt e)))
      · rcases unique_arrow e f with ⟨⟨⟩, ⟨⟩⟩
        rw [ih]⟩
#align quiver.arborescence_mk Quiver.arborescenceMk
-/

#print Quiver.RootedConnected /-
/-- `rooted_connected r` means that there is a path from `r` to any other vertex. -/
class RootedConnected {V : Type u} [Quiver V] (r : V) : Prop where
  nonempty_path : ∀ b : V, Nonempty (Path r b)
#align quiver.rooted_connected Quiver.RootedConnected
-/

attribute [instance] rooted_connected.nonempty_path

section GeodesicSubtree

variable {V : Type u} [Quiver.{v + 1} V] (r : V) [RootedConnected r]

#print Quiver.shortestPath /-
/-- A path from `r` of minimal length. -/
noncomputable def shortestPath (b : V) : Path r b :=
  WellFounded.min (measure_wf Path.length) Set.univ Set.univ_nonempty
#align quiver.shortest_path Quiver.shortestPath
-/

#print Quiver.shortest_path_spec /-
/-- The length of a path is at least the length of the shortest path -/
theorem shortest_path_spec {a : V} (p : Path r a) : (shortestPath r a).length ≤ p.length :=
  not_lt.mp (WellFounded.not_lt_min (measure_wf _) Set.univ _ trivial)
#align quiver.shortest_path_spec Quiver.shortest_path_spec
-/

#print Quiver.geodesicSubtree /-
/-- A subquiver which by construction is an arborescence. -/
def geodesicSubtree : WideSubquiver V := fun a b =>
  { e | ∃ p : Path r a, shortestPath r b = p.cons e }
#align quiver.geodesic_subtree Quiver.geodesicSubtree
-/

#print Quiver.geodesicArborescence /-
noncomputable instance geodesicArborescence : Arborescence (geodesicSubtree r) :=
  arborescenceMk r (fun a => (shortestPath r a).length)
    (by
      rintro a b ⟨e, p, h⟩
      rw [h, path.length_cons, Nat.lt_succ_iff]
      apply shortest_path_spec)
    (by
      rintro a b c ⟨e, p, h⟩ ⟨f, q, j⟩
      cases h.symm.trans j
      constructor <;> rfl)
    (by
      intro b
      rcases hp : shortest_path r b with (_ | ⟨p, e⟩)
      · exact Or.inl rfl
      · exact Or.inr ⟨_, ⟨⟨e, p, hp⟩⟩⟩)
#align quiver.geodesic_arborescence Quiver.geodesicArborescence
-/

end GeodesicSubtree

end Quiver


import Mathlib.Data.Fintype.Card
import Mathlib.Data.Fintype.Sum
import Mathlib.Data.Fintype.Sigma
import Mathlib.Data.Fintype.BigOperators
import Mathlib.Tactic.Zify
import Mathlib.Tactic.Ring
import SSA.Bits.Defs

open Sum

variable {α β α' β' : Type} {γ : β → Type}

def propagateAux (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
      (α → Bool) × Bool)
    (x : β → ℕ → Bool) : ℕ → (α → Bool) × Bool
  | 0 => next_bit init_carry (fun i => x i 0)
  | n+1 => next_bit (propagateAux init_carry next_bit x n).1 (fun i => x i (n+1))

def propagate (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
      (α → Bool) × Bool)
    (x : β → ℕ → Bool) (i : ℕ) : Bool :=
  (propagateAux init_carry next_bit x i).2

@[simp] def propagateCarry (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
      (α → Bool))
    (x : β → ℕ → Bool) : ℕ → (α → Bool)
  | 0 => next_bit init_carry (fun i => x i 0)
  | n+1 => next_bit (propagateCarry init_carry next_bit x n) (fun i => x i (n+1))

@[simp] def propagateCarry2 (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
      (α → Bool))
    (x : β → ℕ → Bool) : ℕ → (α → Bool)
  | 0 => init_carry
  | n+1 => next_bit (propagateCarry2 init_carry next_bit x n) (fun i => x i n)

lemma propagateCarry2_succ (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
      (α → Bool))
    (x : β → ℕ → Bool) : ∀ (n : ℕ),
    propagateCarry2 init_carry next_bit x (n+1) =
    propagateCarry init_carry next_bit x n
  | 0 => rfl
  | n+1 => by rw [propagateCarry2, propagateCarry2_succ _ _ _ n, propagateCarry]

@[simp] lemma propagateAux_fst_eq_carry (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
      (α → Bool) × Bool)
    (x : β → ℕ → Bool) : ∀ n : ℕ,
    (propagateAux init_carry next_bit x n).1 =
    propagateCarry init_carry (fun c b => (next_bit c b).1) x n
  | 0 => rfl
  | n+1 => by rw [propagateAux, propagateCarry, propagateAux_fst_eq_carry _ _ _ n]

@[simp] lemma propagate_zero (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
    (α → Bool) × Bool)
    (x : β → ℕ → Bool) :
    propagate init_carry next_bit x 0 = (next_bit init_carry (fun i => x i 0)).2 :=
  rfl

lemma propagate_succ (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
      (α → Bool) × Bool)
    (x : β → ℕ → Bool) (i : ℕ) :
    propagate init_carry next_bit x (i+1) = (next_bit
      (propagateCarry init_carry (fun c b => (next_bit c b).1) x i)
      (λ j => x j (i+1))).2 :=
  by rw [← propagateAux_fst_eq_carry]; rfl

lemma propagate_succ2 (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
      (α → Bool) × Bool)
    (x : β → ℕ → Bool) (i : ℕ) :
    propagate init_carry next_bit x (i+1) = (next_bit
      (propagateCarry2 init_carry (λ c b => (next_bit c b).1) x (i+1))
      (λ j => x j (i+1))).2 :=
  by rw [propagateCarry2_succ, ← propagateAux_fst_eq_carry]; rfl

lemma propagateCarry_propagate {δ : β → Type} {β' : Type}
      (f : ∀ a, δ a → β') : ∀ (n : ℕ) (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
      (α → Bool))
    (init_carry_x : ∀ a, γ a → Bool)
    (next_bit_x : ∀ a (_carry : γ a → Bool) (_bits : δ a → Bool),
      (γ a → Bool) × Bool)
    (x : β' → ℕ → Bool),
    propagateCarry init_carry next_bit (λ a => propagate (init_carry_x a)
      (next_bit_x a) (λ d => x (f a d))) n =
    propagateCarry
      (λ a : α ⊕ (Σ a, γ a) => Sum.elim init_carry (λ b : Σ a, γ a =>
        init_carry_x b.1 b.2) a)
      (λ (carry : (α ⊕ (Σ a, γ a)) → Bool) (bits : β' → Bool) =>
    -- first compute (propagate (init_carry_x a) (next_bit_x a) (x a) n)
        let f : ∀ (a : β), (γ a → Bool) × Bool := λ a => next_bit_x a
          (λ d => carry (inr ⟨a, d⟩)) (λ d => bits (f a d))
        let g : (α → Bool) := (next_bit (carry ∘ inl) (λ a => (f a).2))
        Sum.elim g (λ x => (f x.1).1 x.2))
      x n ∘ inl
  | 0, init_carry, next_bit, init_carry_x, next_bit_x, x => rfl
  | n+1, init_carry, next_bit, init_carry_x, next_bit_x, x => by
    have := propagateCarry_propagate f n
    simp only [propagateCarry, propagate_succ, elim_inl, Nat.add] at *
    conv_lhs => simp only [this]
    clear this
    dsimp
    congr
    ext a
    dsimp
    congr
    ext b
    dsimp [propagateCarry, propagate_succ, elim_inl, Nat.add]
    congr
    dsimp
    induction' n with n ih
    . simp
    . simp [ih]

lemma propagate_propagate {δ : β → Type} {β' : Type}
      (f : ∀ a, δ a → β') : ∀ (n : ℕ) (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
      (α → Bool) × Bool)
    (init_carry_x : ∀ a, γ a → Bool)
    (next_bit_x : ∀ a (_carry : γ a → Bool) (_bits : δ a → Bool),
      (γ a → Bool) × Bool)
    (x : β' → ℕ → Bool),
    propagate init_carry next_bit (λ a => propagate (init_carry_x a)
      (next_bit_x a) (λ d => x (f a d))) n =
    propagate
      (λ a : α ⊕ (Σ a, γ a) => Sum.elim init_carry (λ b : Σ a, γ a =>
        init_carry_x b.1 b.2) a)
      (λ (carry : (α ⊕ (Σ a, γ a)) → Bool) (bits : β' → Bool) =>
        -- first compute (propagate (init_carry_x a) (next_bit_x a) (x a) n)
        let f : ∀ (a : β), (γ a → Bool) × Bool := λ a => next_bit_x a (λ d =>
          carry (inr ⟨a, d⟩)) (λ d => bits (f a d))
        let g : (α → Bool) × Bool := (next_bit (carry ∘ inl) (λ a => (f a).2))
        (Sum.elim g.1 (λ x => (f x.1).1 x.2), g.2)
      )
    x n
  | 0, init_carry, next_bit, init_carry_x, next_bit_x, x => rfl
  | n+1, init_carry, next_bit, init_carry_x, next_bit_x, x => by
    simp only [propagate_succ]
    rw [propagateCarry_propagate]
    congr
    ext
    congr
    induction' n with n ih
    . simp
    . simp [ih]

lemma propagateCarry_changeVars {β' : Type}
    (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
      (α → Bool))
    (x : β' → ℕ → Bool) (i : ℕ)
    (changeVars : β → β') :
    propagateCarry init_carry next_bit (λ b => x (changeVars b)) i =
    propagateCarry init_carry (λ (carry : α → Bool) (bits : β' → Bool) =>
      next_bit carry (λ b => bits (changeVars b))) x i := by
  induction i
  . simp
  . simp [*]

lemma propagate_changeVars {β' : Type}
    (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
      (α → Bool) × Bool)
    (x : β' → ℕ → Bool) (i : ℕ)
    (changeVars : β → β') :
    propagate init_carry next_bit (λ b => x (changeVars b)) i =
    propagate init_carry (λ (carry : α → Bool) (bits : β' → Bool) =>
      next_bit carry (λ b => bits (changeVars b))) x i := by
  induction' i with i ih
  . rfl
  . simp only [propagate_succ, propagateCarry_changeVars, ih]

open Term

@[simp] def arity : Term → ℕ
| (var n) => n+1
| zero => 0
| one => 0
| negOne => 0
| Term.and t₁ t₂ => max (arity t₁) (arity t₂)
| Term.or t₁ t₂ => max (arity t₁) (arity t₂)
| Term.xor t₁ t₂ => max (arity t₁) (arity t₂)
| Term.not t => arity t
| ls t => arity t
| add t₁ t₂ => max (arity t₁) (arity t₂)
| sub t₁ t₂ => max (arity t₁) (arity t₂)
| neg t => arity t
| incr t => arity t
| decr t => arity t

@[simp] def Term.evalFin : ∀ (t : Term) (_vars : Fin (arity t) → ℕ → Bool), ℕ → Bool
| var n, vars => vars (Fin.last n)
| zero, _vars => zeroSeq
| one, _vars => oneSeq
| negOne, _vars => negOneSeq
| Term.and t₁ t₂, vars =>
  andSeq (Term.evalFin t₁
    (fun i => vars (Fin.castLe (by simp [arity]) i)))
  (Term.evalFin t₂
    (fun i => vars (Fin.castLe (by simp [arity]) i)))
| Term.or t₁ t₂, vars =>
  orSeq (Term.evalFin t₁
    (fun i => vars (Fin.castLe (by simp [arity]) i)))
  (Term.evalFin t₂
    (fun i => vars (Fin.castLe (by simp [arity]) i)))
| Term.xor t₁ t₂, vars =>
  xorSeq (Term.evalFin t₁
    (fun i => vars (Fin.castLe (by simp [arity]) i)))
  (Term.evalFin t₂
    (fun i => vars (Fin.castLe (by simp [arity]) i)))
| not t, vars => notSeq (Term.evalFin t vars)
| ls t, vars => lsSeq (Term.evalFin t vars)
| add t₁ t₂, vars =>
  addSeq (Term.evalFin t₁
    (fun i => vars (Fin.castLe (by simp [arity]) i)))
  (Term.evalFin t₂
    (fun i => vars (Fin.castLe (by simp [arity]) i)))
| sub t₁ t₂, vars =>
  subSeq (Term.evalFin t₁
    (fun i => vars (Fin.castLe (by simp [arity]) i)))
  (Term.evalFin t₂
    (fun i => vars (Fin.castLe (by simp [arity]) i)))
| neg t, vars => negSeq (Term.evalFin t vars)
| incr t, vars => incrSeq (Term.evalFin t vars)
| decr t, vars => decrSeq (Term.evalFin t vars)

lemma evalFin_eq_eval (t : Term) (vars : ℕ → ℕ → Bool) :
    Term.evalFin t (fun i => vars i) = Term.eval t vars := by
  induction t <;>
  dsimp [Term.evalFin, Term.eval, arity] at * <;> simp [*]

lemma id_eq_propagate (x : ℕ → Bool) :
    x = propagate Empty.elim (λ _ (y : Unit → Bool) => (Empty.elim, y ())) (λ _ => x) := by
  ext n; cases n <;> rfl

lemma zero_eq_propagate :
    zeroSeq = propagate Empty.elim (λ (_ _ : Empty → Bool) => (Empty.elim, false)) Empty.elim := by
  ext n; cases n <;> rfl

lemma one_eq_propagate :
    oneSeq = propagate (λ _ : Unit => true)
      (λ f (_ : Empty → Bool) => (λ _ => false, f ())) Empty.elim := by
  ext n
  match n with
  | 0 => rfl
  | 1 => rfl
  | n+2 => simp [oneSeq, propagate_succ]

lemma and_eq_propagate (x y : ℕ → Bool) :
    andSeq x y = propagate Empty.elim
      (λ _ (y : Bool → Bool) => (Empty.elim, y true && y false)) (λ b => cond b x y) := by
  ext n; cases n <;> simp [propagate, propagateAux, andSeq]

lemma or_eq_propagate (x y : ℕ → Bool) :
    orSeq x y = propagate Empty.elim
      (λ _ (y : Bool → Bool) => (Empty.elim, y true || y false)) (λ b => cond b x y) := by
  ext n; cases n <;> simp [propagate, propagateAux, orSeq]

lemma xor_eq_propagate (x y : ℕ → Bool) :
    xorSeq x y = propagate Empty.elim
      (λ _ (y : Bool → Bool) => (Empty.elim, xor (y true) (y false))) (λ b => cond b x y) := by
  ext n; cases n <;> simp [propagate, propagateAux, xorSeq]

lemma not_eq_propagate (x : ℕ → Bool) :
    notSeq x = propagate Empty.elim (λ _ (y : Unit → Bool) => (Empty.elim, !(y ()))) (λ _ => x) := by
  ext n; cases n <;> simp [propagate, propagateAux, notSeq]

lemma ls_eq_propagate (x : ℕ → Bool) :
    lsSeq x = propagate (λ _ : Unit => false)
      (λ (carry x : Unit → Bool) => (x, carry ())) (λ _ => x) := by
  ext n
  match n with
  | 0 => rfl
  | 1 => rfl
  | n+2 => simp [lsSeq, propagate_succ]

lemma addSeqAux_eq_propagateCarry (x y : ℕ → Bool) (n : ℕ) :
    (addSeqAux x y n).2 = propagateCarry (λ _ => false)
      (λ (carry : Unit → Bool) (bits : Bool → Bool) =>
        λ _ => (bits true && bits false) || (bits false && carry ()) || (bits true && carry ()))
    (λ b => cond b x y) n () := by
  induction n <;> simp [addSeqAux, *]

lemma add_eq_propagate (x y : ℕ → Bool) :
    addSeq x y = propagate (λ _ => false)
      (λ (carry : Unit → Bool) (bits : Bool → Bool) =>
        (λ _ => (bits true && bits false) || (bits false && carry ()) || (bits true && carry ()),
          _root_.xor (bits true) (_root_.xor (bits false) (carry ()))))
    (λ b => cond b x y) := by
  ext n
  match n with
  | 0 => simp [addSeq, addSeqAux]
  | 1 => simp [addSeq, addSeqAux, propagate, propagateAux]
  | n+2 => simp [addSeq, addSeqAux, addSeqAux_eq_propagateCarry, propagate_succ]

lemma subSeqAux_eq_propagateCarry (x y : ℕ → Bool) (n : ℕ) :
    (subSeqAux x y n).2 = propagateCarry (λ _ => false)
      (λ (carry : Unit → Bool) (bits : Bool → Bool) =>
        λ _ => (!(bits true) && (bits false)) ||
          (!(_root_.xor (bits true) (bits false))) && carry ())
    (λ b => cond b x y) n () := by
  induction n <;> simp [subSeqAux, *]

lemma sub_eq_propagate (x y : ℕ → Bool) :
    subSeq x y = propagate (λ _ => false)
      (λ (carry : Unit → Bool) (bits : Bool → Bool) =>
        (λ _ => (!(bits true) && (bits false)) ||
          ((!(_root_.xor (bits true) (bits false))) && carry ()),
          _root_.xor (bits true) (_root_.xor (bits false) (carry ()))))
    (λ b => cond b x y) := by
  ext n
  match n with
  | 0 => simp [subSeq, subSeqAux]
  | 1 => simp [subSeq, subSeqAux, propagate, propagateAux]
  | n+2 => simp [subSeq, subSeqAux, subSeqAux_eq_propagateCarry, propagate_succ]

lemma negSeqAux_eq_propagateCarry (x : ℕ → Bool) (n : ℕ) :
    (negSeqAux x n).2 = propagateCarry (λ _ => true)
      (λ (carry : Unit → Bool) (bits : Unit → Bool) =>
        λ _ => (!(bits ())) && (carry ()))
    (λ _ => x) n () := by
  induction n <;> simp [negSeqAux, *]

lemma neg_eq_propagate (x : ℕ → Bool) :
    negSeq x = propagate (λ _ => true)
      (λ (carry : Unit → Bool) (bits : Unit → Bool) =>
        (λ _ => (!(bits ())) && (carry ()), _root_.xor (!(bits ())) (carry ())))
    (λ _ => x) := by
  ext n
  match n with
  | 0 => simp [negSeq, negSeqAux]
  | 1 => simp [negSeq, negSeqAux, propagate, propagateAux]
  | n+2 => simp [negSeq, negSeqAux, negSeqAux_eq_propagateCarry, propagate_succ]

lemma incrSeqAux_eq_propagateCarry (x : ℕ → Bool) (n : ℕ) :
    (incrSeqAux x n).2 = propagateCarry (λ _ => true)
      (λ (carry : Unit → Bool) (bits : Unit → Bool) =>
        λ _ => (bits ()) && carry ())
    (λ _ => x) n () := by
  induction n <;> simp [incrSeqAux, *]

lemma incr_eq_propagate (x : ℕ → Bool) :
    incrSeq x = propagate (λ _ => true)
      (λ (carry : Unit → Bool) (bits : Unit → Bool) =>
        (λ _ => (bits ()) && carry (), _root_.xor (bits ()) (carry ())))
    (λ _ => x) := by
  ext n
  match n with
  | 0 => simp [incrSeq, incrSeqAux]
  | 1 => simp [incrSeq, incrSeqAux, propagate, propagateAux]
  | n+2 => simp [incrSeq, incrSeqAux, incrSeqAux_eq_propagateCarry, propagate_succ]

lemma decrSeqAux_eq_propagateCarry (x : ℕ → Bool) (n : ℕ) :
    (decrSeqAux x n).2 = propagateCarry (λ _ => true)
      (λ (carry : Unit → Bool) (bits : Unit → Bool) =>
        λ _ => (!(bits ())) && carry ())
    (λ _ => x) n () := by
  induction n <;> simp [decrSeqAux, *]

lemma decr_eq_propagate (x : ℕ → Bool) :
    decrSeq x = propagate (λ _ => true)
      (λ (carry : Unit → Bool) (bits : Unit → Bool) =>
        (λ _ => (!(bits ())) && carry (), _root_.xor (bits ()) (carry ())))
    (λ _ => x) := by
  ext n
  match n with
  | 0 => simp [decrSeq, decrSeqAux]
  | 1 => simp [decrSeq, decrSeqAux, propagate, propagateAux]
  | n+2 => simp [decrSeq, decrSeqAux, decrSeqAux_eq_propagateCarry, propagate_succ]

structure PropagateStruc (arity : Type) : Type 1 :=
  ( α  : Type )
  [ i : Fintype α ]
  ( init_carry : α → Bool )
  ( next_bit : ∀ (_carry : α → Bool) (_bits : arity → Bool),
      (α → Bool) × Bool )

attribute [instance] PropagateStruc.i

namespace PropagateStruc

variable {arity : Type} (p : PropagateStruc arity)

def eval : (arity → ℕ → Bool) → ℕ → Bool :=
  propagate p.init_carry p.next_bit

def changeVars {arity2 : Type} (changeVars : arity → arity2) :
    PropagateStruc arity2 :=
  { α := p.α,
    i := p.i,
    init_carry := p.init_carry,
    next_bit := λ carry bits => p.next_bit carry (fun i => bits (changeVars i)) }

def compose [Fintype arity]
  (new_arity : Type)
    (q_arity : arity → Type)
    (vars : ∀ (a : arity), q_arity a → new_arity)
    (q : ∀ (a : arity), PropagateStruc (q_arity a)) :
    PropagateStruc (new_arity) :=
  { α := p.α ⊕ (Σ a, (q a).α),
    i := by letI := p.i;  infer_instance,
    init_carry := Sum.elim p.init_carry (λ x => (q x.1).init_carry x.2),
    next_bit := λ carry bits =>
      let f : ∀ (a : arity), ((q a).α → Bool) × Bool := λ a => (q a).next_bit (λ d =>
          carry (inr ⟨a, d⟩)) (λ d => bits (vars a d))
      let g : (p.α → Bool) × Bool := (p.next_bit (carry ∘ inl) (λ a => (f a).2))
      (Sum.elim g.1 (λ x => (f x.1).1 x.2), g.2) }

lemma eval_compose [Fintype arity]
    (new_arity : Type)
    (q_arity : arity → Type)
    (vars : ∀ (a : arity), q_arity a → new_arity)
    (q : ∀ (a : arity), PropagateStruc (q_arity a))
    (x : new_arity → ℕ → Bool):
    (p.compose new_arity q_arity vars q).eval x =
    p.eval (λ a => (q a).eval (fun i => x (vars _ i))) := by
  ext n; simp only [eval, compose, propagate_propagate]

def and : PropagateStruc Bool :=
  { α := Empty,
    i := by infer_instance,
    init_carry := Empty.elim,
    next_bit := λ _carry bits => (Empty.elim, bits true && bits false) }

@[simp] lemma eval_and (x : Bool → ℕ → Bool) : and.eval x = andSeq (x true) (x false) := by
  ext n; cases n <;> simp [and, andSeq, eval, propagate_succ]

def or : PropagateStruc Bool :=
  { α := Empty,
    i := by infer_instance,
    init_carry := Empty.elim,
    next_bit := λ _carry bits => (Empty.elim, bits true || bits false) }

@[simp] lemma eval_or (x : Bool → ℕ → Bool) : or.eval x = orSeq (x true) (x false) := by
  ext n; cases n <;> simp [or, orSeq, eval, propagate_succ]

def xor : PropagateStruc Bool :=
  { α := Empty,
    i := by infer_instance,
    init_carry := Empty.elim,
    next_bit := λ _carry bits => (Empty.elim, _root_.xor (bits true) (bits false)) }

@[simp] lemma eval_xor (x : Bool → ℕ → Bool) : xor.eval x = xorSeq (x true) (x false) := by
  ext n; cases n <;> simp [xor, xorSeq, eval, propagate_succ]

  def add : PropagateStruc Bool :=
  { α := Unit,
    i := by infer_instance,
    init_carry := λ _ => false,
    next_bit := λ (carry : Unit → Bool) (bits : Bool → Bool) =>
        (λ _ => (bits true && bits false) || (bits false && carry ()) || (bits true && carry ()),
          _root_.xor (bits true) (_root_.xor (bits false) (carry ()))) }

@[simp] lemma eval_add (x : Bool → ℕ → Bool) : add.eval x = addSeq (x true) (x false) := by
  dsimp [add, eval]
  rw [add_eq_propagate]
  congr
  funext b
  cases b; rfl
  simp
  congr
  funext i
  cases i <;> simp

def sub : PropagateStruc Bool :=
  { α := Unit,
    i := by infer_instance,
    init_carry := λ _ => false,
    next_bit := λ (carry : Unit → Bool) (bits : Bool → Bool) =>
        (λ _ => (!(bits true) && (bits false)) ||
          ((!(_root_.xor (bits true) (bits false))) && carry ()),
          _root_.xor (bits true) (_root_.xor (bits false) (carry ()))) }

@[simp] lemma eval_sub (x : Bool → ℕ → Bool) : sub.eval x = subSeq (x true) (x false) := by
  dsimp [sub, eval]
  rw [sub_eq_propagate]
  congr
  funext b
  cases b;  rfl
  simp
  congr
  funext i
  cases i <;> simp

def neg : PropagateStruc Unit :=
  { α := Unit,
    i := by infer_instance,
    init_carry := λ _ => true,
    next_bit := λ (carry : Unit → Bool) (bits : Unit → Bool) =>
      (λ _ => (!(bits ())) && (carry ()), _root_.xor (!(bits ())) (carry ())) }

@[simp] lemma eval_neg (x : Unit → ℕ → Bool) : neg.eval x = negSeq (x ()) := by
  dsimp [neg, eval]
  rw [neg_eq_propagate]

def not : PropagateStruc Unit :=
{ α := Empty,
  i := by infer_instance,
  init_carry := Empty.elim,
  next_bit := λ _carry bits => (Empty.elim, !(bits ())) }

@[simp] lemma eval_not (x : Unit → ℕ → Bool) : not.eval x = notSeq (x ()) := by
  ext n; cases n <;> simp [not, notSeq, eval, propagate_succ]

def zero : PropagateStruc (Fin 0) :=
  { α := Empty,
    i := by infer_instance,
    init_carry := Empty.elim,
    next_bit := λ _carry _bits => (Empty.elim, false) }

@[simp] lemma eval_zero (x : Fin 0 → ℕ → Bool) : zero.eval x = zeroSeq := by
  ext n; cases n <;> simp [zero, zeroSeq, eval, propagate_succ]

def one : PropagateStruc (Fin 0) :=
  { α := Unit,
    i := by infer_instance,
    init_carry := λ _ => true,
    next_bit := λ carry _bits => (λ _ => false, carry ()) }

@[simp] lemma eval_one (x : Fin 0 → ℕ → Bool) : one.eval x = oneSeq := by
  ext n; cases n <;> simp [one, oneSeq, eval, propagate_succ2, @eq_comm _ false]

def negOne : PropagateStruc (Fin 0) :=
  { α := Empty,
    i := by infer_instance,
    init_carry := Empty.elim,
    next_bit := λ _carry _bits => (Empty.elim, true) }

@[simp] lemma eval_negOne (x : Fin 0 → ℕ → Bool) : negOne.eval x = negOneSeq := by
  ext n; cases n <;> simp [negOne, negOneSeq, eval, propagate_succ2]

def ls : PropagateStruc Unit :=
  { α := Unit,
    i := by infer_instance,
    init_carry := λ _ => false,
    next_bit := λ carry bits => (bits, carry ()) }

@[simp] lemma eval_ls (x : Unit → ℕ → Bool) : ls.eval x = lsSeq (x ()) := by
  ext n; cases n <;> simp [ls, lsSeq, eval, propagate_succ2]

def var (n : ℕ) : PropagateStruc (Fin (n+1)) :=
  { α := Empty,
    i := by infer_instance,
    init_carry := Empty.elim,
    next_bit := λ _carry bits => (Empty.elim, bits (Fin.last n)) }

@[simp] lemma eval_var (n : ℕ) (x : Fin (n+1) → ℕ → Bool) : (var n).eval x = x (Fin.last n) := by
  ext m; cases m <;> simp [var, eval, propagate_succ]

def incr : PropagateStruc Unit :=
  { α := Unit,
    i := by infer_instance,
    init_carry := λ _ => true,
    next_bit := λ carry bits => (λ _ => bits () && carry (), _root_.xor (bits ()) (carry ())) }

@[simp] lemma eval_incr (x : Unit → ℕ → Bool) : incr.eval x = incrSeq (x ()) := by
  dsimp [incr, eval]
  rw [incr_eq_propagate]

def decr : PropagateStruc Unit :=
  { α := Unit,
    i := by infer_instance,
    init_carry := λ _ => true,
    next_bit := λ carry bits => (λ _ => !(bits ()) && carry (), _root_.xor (bits ()) (carry ())) }

@[simp] lemma eval_decr (x : Unit → ℕ → Bool) : decr.eval x = decrSeq (x ()) := by
  dsimp [decr, eval]
  rw [decr_eq_propagate]

end PropagateStruc

structure PropagateSolution (t : Term) extends PropagateStruc (Fin (arity t)) :=
( good : t.evalFin = toPropagateStruc.eval )

def composeUnary
    (p : PropagateStruc Unit)
    {t : Term}
    (q : PropagateSolution t) :
    PropagateStruc (Fin (arity t)) :=
  p.compose
    (Fin (arity t))
    _
    (λ _ => id)
    (λ _ => q.toPropagateStruc)
def X := @Bool.casesOn
def composeBinary
    (p : PropagateStruc Bool)
    {t₁ t₂ : Term}
    (q₁ : PropagateSolution t₁)
    (q₂ : PropagateSolution t₂) :
    PropagateStruc (Fin (max (arity t₁) (arity t₂))) :=
  p.compose (Fin (max (arity t₁) (arity t₂)))
    (λ b => Fin (cond b (arity t₁) (arity t₂)))
    (λ b i => Fin.castLe (by cases b <;> simp) i)
    (λ b => match b with
      | true => q₁.toPropagateStruc
      | false => q₂.toPropagateStruc)

@[simp] lemma composeUnary_eval
    (p : PropagateStruc Unit)
    {t : Term}
    (q : PropagateSolution t)
    (x : Fin (arity t) → ℕ → Bool) :
    (composeUnary p q).eval x = p.eval (λ _ => t.evalFin x) := by
  rw [composeUnary, PropagateStruc.eval_compose, q.good]; rfl

@[simp] lemma composeBinary_eval
    (p : PropagateStruc Bool)
    {t₁ t₂ : Term}
    (q₁ : PropagateSolution t₁)
    (q₂ : PropagateSolution t₂)
    (x : Fin (max (arity t₁) (arity t₂)) → ℕ → Bool) :
    (composeBinary p q₁ q₂).eval x = p.eval
      (λ b => cond b (t₁.evalFin (fun i => x (Fin.castLe (by simp) i)))
                  (t₂.evalFin (fun i => x (Fin.castLe (by simp) i)))) := by
  rw [composeBinary, PropagateStruc.eval_compose, q₁.good, q₂.good]
  congr
  ext b
  cases b <;> dsimp <;> congr <;> funext b <;> cases b <;> simp

instance {α β : Type} [Fintype α] [Fintype β] (b : Bool) :
    Fintype (cond b α β) :=
  by cases b <;> simp <;> infer_instance

lemma cond_propagate {α α' β β' : Type}
    (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool),
      (α → Bool) × Bool)
    (init_carry' : α' → Bool)
    (next_bit' : ∀ (_carry : α' → Bool) (_bits : β' → Bool),
      (α' → Bool) × Bool)
    {γ : Type} (fβ : β → γ) (fβ' : β' → γ)
    (x : γ → ℕ → Bool) (b : Bool) :
    cond b (propagate init_carry next_bit (λ b => (x (fβ b))))
      (propagate init_carry' next_bit' (λ b => (x (fβ' b)))) =
    propagate (show cond b α α' → Bool from Bool.rec init_carry' init_carry b)
      (show ∀ (_carry : cond b α α' → Bool) (_bits : cond b β β' → Bool),
          (cond b α α' → Bool) × Bool
        from Bool.rec next_bit' next_bit b)
      (show cond b β β' → ℕ → Bool from Bool.rec (λ b => (x (fβ' b))) (λ b => (x (fβ b))) b) :=
  by cases b <;> rfl

def termEvalEqPropagate : ∀ (t : Term),
  PropagateSolution t
| var n =>
  { toPropagateStruc := PropagateStruc.var n,
    good := by ext; simp [Term.evalFin] }
| zero =>
  { toPropagateStruc := PropagateStruc.zero,
    good := by ext; simp [Term.evalFin] }
| one =>
  { toPropagateStruc := PropagateStruc.one,
    good := by ext; simp [Term.evalFin] }
| negOne =>
  { toPropagateStruc := PropagateStruc.negOne,
    good := by ext; simp [Term.evalFin] }
| Term.and t₁ t₂ =>
  let q₁ := termEvalEqPropagate t₁
  let q₂ := termEvalEqPropagate t₂
  { toPropagateStruc := composeBinary PropagateStruc.and q₁ q₂,
    good := by ext; simp }
| Term.or t₁ t₂ =>
  let q₁ := termEvalEqPropagate t₁
  let q₂ := termEvalEqPropagate t₂
  { toPropagateStruc := composeBinary PropagateStruc.or q₁ q₂,
    good := by ext; simp }
| Term.xor t₁ t₂ =>
  let q₁ := termEvalEqPropagate t₁
  let q₂ := termEvalEqPropagate t₂
  { toPropagateStruc := composeBinary PropagateStruc.xor q₁ q₂,
    good := by ext; simp }
| ls t =>
  let q := termEvalEqPropagate t
  { toPropagateStruc := by dsimp [arity]; exact composeUnary PropagateStruc.ls q,
    good := by ext; simp }
| Term.not t =>
  let q := termEvalEqPropagate t
  { toPropagateStruc := by dsimp [arity]; exact composeUnary PropagateStruc.not q,
    good := by ext; simp }
| add t₁ t₂ =>
  let q₁ := termEvalEqPropagate t₁
  let q₂ := termEvalEqPropagate t₂
  { toPropagateStruc := composeBinary PropagateStruc.add q₁ q₂,
    good := by ext; simp }
| sub t₁ t₂ =>
  let q₁ := termEvalEqPropagate t₁
  let q₂ := termEvalEqPropagate t₂
  { toPropagateStruc := composeBinary PropagateStruc.sub q₁ q₂,
    good := by ext; simp }
| neg t =>
  let q := termEvalEqPropagate t
  { toPropagateStruc := by dsimp [arity]; exact composeUnary PropagateStruc.neg q,
    good := by ext; simp }
| incr t =>
  let q := termEvalEqPropagate t
  { toPropagateStruc := by dsimp [arity]; exact composeUnary PropagateStruc.incr q,
    good := by ext; simp }
| decr t =>
  let q := termEvalEqPropagate t
  { toPropagateStruc := by dsimp [arity]; exact composeUnary PropagateStruc.decr q,
    good := by ext; simp }

variable
  (init_carry : α → Bool)
  (next_carry : ∀ (_carry : α → Bool) (_bits : β → Bool), (α → Bool))
  (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool), (α → Bool) × Bool)

variable [Fintype α] [Fintype α']

open Fintype

lemma exists_repeat_carry (seq : β → ℕ → Bool) :
    ∃ n m : Fin (2 ^ (card α) + 1),
      propagateCarry2 init_carry next_carry seq n =
      propagateCarry2 init_carry next_carry seq m ∧
      n < m := by
  by_contra h
  haveI := Classical.decEq α
  push_neg at h
  have := λ a b hab => (le_antisymm (h a b hab) (h b a hab.symm)).symm
  have := Fintype.card_le_of_injective _ this
  simp at this

lemma propagateCarry2_eq_of_seq_eq_lt (seq₁ seq₂ : β → ℕ → Bool)
    (init_carry : α → Bool)
    (next_carry : ∀ (_carry : α → Bool) (_bits : β → Bool), (α → Bool))
    (i : ℕ) (h : ∀ (b) (j) (_hj : j < i), seq₁ b j = seq₂ b j) :
    propagateCarry2 init_carry next_carry seq₁ i =
      propagateCarry2 init_carry next_carry seq₂ i := by
  induction' i with i ih
  { simp [propagateCarry2] }
  { simp only [propagateCarry2, h _ i (Nat.lt_succ_self i)]
    rw [ih]
    exact λ b j hj => h b j (Nat.lt_succ_of_lt hj) }

lemma propagate_eq_of_seq_eq_le (seq₁ seq₂ : β → ℕ → Bool)
    (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool), (α → Bool) × Bool)
    (i : ℕ) (h : ∀ (b) (j) (_hj : j ≤ i), seq₁ b j = seq₂ b j) :
    propagate init_carry next_bit seq₁ i =
      propagate init_carry next_bit seq₂ i := by
  cases i
  { simp [propagate_zero, h _ 0 (le_refl _)] }
  { simp only [propagate_succ2, propagate_succ2, h _ _ (le_refl _)]
    congr 2
    apply propagateCarry2_eq_of_seq_eq_lt
    exact λ b j hj => h b j (le_of_lt hj) }

lemma propagateCarry2_eq_of_carry_eq (seq₁ seq₂ : β → ℕ → Bool)
    (m n : ℕ)
    (h₁ : propagateCarry2 init_carry
      (λ carry bits => (next_bit carry bits).1) seq₁ m =
        propagateCarry2 init_carry
      (λ carry bits => (next_bit carry bits).1) seq₂ n) (x : ℕ)
    (h₃ : ∀ y b, y ≤ x → seq₁ b (m + y) = seq₂ b (n + y))  :
    propagateCarry2 init_carry
      (λ carry bits => (next_bit carry bits).1) seq₁ (m + x) =
    propagateCarry2 init_carry
      (λ carry bits => (next_bit carry bits).1) seq₂ (n + x) := by
  induction' x with x ih generalizing seq₁ seq₂
  { simp [*] at * }
  { simp only [propagateCarry2, Nat.add_eq, h₃ x _ (Nat.le_succ _)] at *
    rw [ih]
    assumption
    exact λ y b h => h₃ y b (Nat.le_succ_of_le h) }

lemma propagate_eq_of_carry_eq (seq₁ seq₂ : β → ℕ → Bool)
    (m n : ℕ)
    (h₁ : propagateCarry2 init_carry
      (λ carry bits => (next_bit carry bits).1) seq₁ m =
        propagateCarry2 init_carry
      (λ carry bits => (next_bit carry bits).1) seq₂ n) (x : ℕ)
    (h₃ : ∀ y b, y ≤ x → seq₁ b (m + y) = seq₂ b (n + y))  :
    propagate init_carry next_bit seq₁ (m + x) =
    propagate init_carry next_bit seq₂ (n + x) := by
  cases x
  { cases m
    { cases n
      { simp [h₃ 0 _ (le_refl _), propagateCarry2, *] at * }
      { simp [*, h₃ 0 _ (le_refl _), propagate_succ2] at *
        rw [← h₁] } }
    { cases n
      { simp [*, propagate_succ2] at *
        have := fun i => h₃ 0 i rfl
        dsimp at this
        simp [this]
        simp [h₁] }
      { rw [propagate_succ2, h₁, propagate_succ2]
        have := h₃ 0
        simp [*] at * } } }
  { erw [Nat.add_succ, propagate_succ2, propagate_succ2, Nat.add_eq, Nat.add_eq]
    simp [← Nat.succ_eq_add_one, ← Nat.add_succ, h₃ _ _ (le_refl _)]
    congr
    . apply propagateCarry2_eq_of_carry_eq
      . assumption
      . exact λ y b h => h₃ y b (Nat.le_succ_of_le h)
    . funext i
      rw [h₃]
      exact Nat.le_succ _ }

lemma propagateCarry_propagateCarry_add (x : β → ℕ → Bool) :
    ∀ (init_carry : α → Bool)
      (next_carry : ∀ (_carry : α → Bool) (_bits : β → Bool), (α → Bool)),
    ∀ n i : ℕ,
    propagateCarry2 (propagateCarry2 init_carry next_carry x n)
      next_carry (λ b k => x b (k + n)) i =
    propagateCarry2 init_carry next_carry x (i + n)
  | init_carry, _next_carry, 0, 0 => by simp [propagateCarry2]
  | init_carry, next_carr, n+1, 0 =>
    by simp [propagateCarry, propagateCarry2_succ]
  | init_carry, next_carry, n, i+1 => by
    rw [propagateCarry2, add_assoc,
      propagateCarry_propagateCarry_add _ _ _ _ i]
    simp only [Nat.one_add, Nat.add_one, Nat.succ_add, Nat.add_succ,
      add_zero, propagateCarry2, zero_add]

lemma exists_repeat : ∀ (seq : β → ℕ → Bool)
    (n : ℕ),
    ∃ (m : ℕ) (_hm : m < 2 ^ (card α)) (seq2 : β → ℕ → Bool),
      propagate init_carry next_bit seq2 m = propagate init_carry next_bit seq n
  | seq, n => by
    by_cases hn2 : n < 2 ^ card α
    { exact ⟨n, hn2, seq, rfl⟩ }
    { rcases exists_repeat_carry
        (propagateCarry2 init_carry (λ c b => (next_bit c b).1) seq
          (n - 2 ^ card α))
        (λ carry bits => (next_bit  carry bits).1)
        (λ b i => seq b (i + (n - 2^ (card α)))) with ⟨a, b, h₁, h₂⟩
      simp only [propagateCarry_propagateCarry_add] at h₁
      rcases have _wf : n - (b - a) < n :=
         Nat.sub_lt (lt_of_lt_of_le (pow_pos (by norm_num) _) (le_of_not_lt hn2)) (Nat.sub_pos_of_lt h₂)
        exists_repeat (λ c i => if i < a + (n - 2 ^ card α) then seq c i else
          seq c (i + (b - a))) (n - (b - a)) with ⟨m, hmle, seq2, hm⟩
      use m; use hmle; use seq2
      rw [hm]; clear hm
      have h1 : n - (b - a) = (a + (n - 2 ^ (card α))) + (2 ^ card α - b) := by
      { zify
        rw [Nat.cast_sub, Nat.cast_sub, Nat.cast_sub, Nat.cast_sub]
        ring_nf
        exact Nat.le_of_lt_succ b.2
        simp [*] at *
        exact hn2
        exact le_of_lt h₂
        exact le_trans (Nat.sub_le _ _) (le_trans (Nat.le_of_lt_succ b.2)
          (le_of_not_lt hn2)) }
      rw [h1]
      have h2 : n = (b + (n - 2 ^ card α)) + (2 ^ card α - b) := by
      { zify
        rw [Nat.cast_sub, Nat.cast_sub]
        ring
        exact Nat.le_of_lt_succ b.2
        simp [*] at *
        exact hn2 }
      conv_rhs => rw [h2]
      refine' propagate_eq_of_carry_eq _ _ _ _ _ _ _ _ _
      { have _h : ↑b + (n - 2 ^ card α) = (a + (n - 2 ^ card α)) + (b - a) := by
        { zify
          rw [Nat.cast_sub, Nat.cast_sub]
          ring_nf
          exact le_of_lt h₂
          exact le_of_not_lt hn2 }
        rw [← h₁]
        apply propagateCarry2_eq_of_seq_eq_lt
        simp (config := { contextual := true }) }
      { intro y c _hc
        simp only [add_lt_iff_neg_left, not_lt_zero', if_false]
        congr 1
        zify
        rw [Nat.cast_sub, Nat.cast_sub]
        ring
        exact le_of_lt h₂
        exact le_of_not_lt hn2 } }

lemma propagate_eq_zero_iff (init_carry : α → Bool)
    (next_bit : ∀ (_carry : α → Bool) (_bits : β → Bool), (α → Bool) × Bool) :
    (∀ seq, propagate init_carry next_bit seq = zeroSeq) ↔
    (∀ seq, ∀ i < 2 ^ (card α), propagate init_carry next_bit seq i = false) := by
  constructor
  { intro h i _
    simp [h, zeroSeq] }
  { intro h seq
    funext i
    rcases exists_repeat init_carry next_bit seq i with ⟨j, hj, seq2, hseq2⟩
    rw [← hseq2, h seq2 j hj, zeroSeq] }

lemma eq_iff_xorSeq_eq_zero (seq₁ seq₂ : ℕ → Bool) :
    (∀ i, seq₁ i = seq₂ i) ↔ (∀ i, xorSeq seq₁ seq₂ i = zeroSeq i) := by
  simp [Function.funext_iff, xorSeq, zeroSeq]
  constructor
  { intro i _; simp [*] }
  { intro h a
    specialize h a
    revert h
    cases (seq₁ a) <;> cases (seq₂ a) <;> simp [*] at * }

lemma eval_eq_iff_xorSeq_eq_zero (t₁ t₂ : Term) :
    t₁.eval = t₂.eval ↔ (t₁.xor t₂).evalFin = λ _ => zeroSeq := by
  simp only [Function.funext_iff, Term.eval, Term.evalFin,
    ← eq_iff_xorSeq_eq_zero, ← evalFin_eq_eval]
  constructor
  { intro h seq n
    have := h (λ j => if hj : j < (arity (t₁.xor t₂)) then seq ⟨j, hj⟩ else λ _ => false) n
    simp at this
    convert this }
  { intro h seq m
    exact h (λ j => seq j) _ }


import Rings.AxGroth
import completeness

----
namespace finset

variables {α : Type*}

lemma filter_mem_set_of_subset_set {s : set α} [decidable_pred (λ x, x ∈ s)]
  {fs : finset α} (h : ↑fs ⊆ s) :
  filter (λ x, x ∈ s) fs = fs :=
begin
  ext x,
  split,
  { apply filter_subset },
  { intro hmem, rw mem_filter, exact ⟨ hmem , h hmem ⟩ },
end

end finset
----

namespace fol

open fol

variables {L : Language}

namespace bounded_preformula

lemma bd_not.inj {n} {f0 f1 : bounded_formula L n} :
  ∼ f0 = ∼ f1 → f0 = f1 := λ h, (bd_imp.inj h).1

lemma bd_notequal.inj {n} {t0 t1 s0 s1 : bounded_term L n} :
  t0 ≄ s0 = t1 ≄ s1 → t0 = t1 ∧ s0 = s1 :=
bd_equal.inj ∘ bd_not.inj

end bounded_preformula

def is_complete' (T : Theory L) : Prop :=
∀ (ϕ : sentence L), T ⊨ ϕ ∨ T ⊨ ∼ ϕ

def is_complete'' (T : Theory L) : Prop :=
∀ (M : Structure L) (ϕ : sentence L), M ⊨ T → M ⊨ ϕ → T ⊨ ϕ

end fol

namespace Rings

def nat_ring_consts :
  ring_consts → dvector ℕ 0 → ℕ
| zero as := 0
-- | one as := 1

def nat_ring_structure_funcs :
  Π {n}, ring_signature.functions n → dvector ℕ n → ℕ
| 0 ring_consts.zero as := 0
| 0 ring_consts.one as := 1
| 1 ring_unaries.neg as := 0
| 2 ring_binaries.add (dvector.cons a (dvector.cons b nil)) := a + b
| 2 ring_binaries.mul (dvector.cons a (dvector.cons b nil)) := a * b
| (n+3) f as := pempty.elim f

def nat_ring_structure : fol.Structure ring_signature :=
⟨ ℕ , λ _, nat_ring_structure_funcs , λ _, pempty.elim ⟩

lemma nat_ring_structure_realize_nat :
  Π (n : ℕ) {k : ℕ} (v : dvector nat_ring_structure k),
  realize_bounded_ring_term v
    (n : fol.bounded_preterm ring_signature k 0) dvector.nil = n
| 0 _ _ := rfl
| (n+1) k v :=
begin
  have h := @nat_ring_structure_realize_nat n k v,
  rw [realize_bounded_ring_term] at h,
  simpa only [nat.cast_succ, ring_signature.add, realize_bounded_ring_term,
    fol.realize_bounded_term, h],
end

lemma nat_cast_bd_ring_term_inj {k n m : ℕ} :
  (n : fol.bounded_preterm.{0} ring_signature k 0) = ↑m → n = m :=
begin
  let v : dvector nat_ring_structure k := dvector.of_fn (λ i, 0),
  intro hnm,
  rw ← nat_ring_structure_realize_nat n v,
  rw ← nat_ring_structure_realize_nat m v,
  exact @congr_arg (fol.bounded_preterm ring_signature k 0)
    nat_ring_structure n m
    (λ t : fol.bounded_preterm ring_signature k 0,
      realize_bounded_ring_term v t dvector.nil) hnm,
end

end Rings

namespace Lefschetz

open fol
open Rings
open Fields

-- I imagine this is constructive but I don't want to spend time proving it
instance dec_eq_sentence_ring_signature :
  decidable_eq (sentence ring_signature) := sorry

lemma injective_plus_one_ne_zero : function.injective plus_one_ne_zero.{0} :=
begin
  intros n m himage,
  simp only [plus_one_ne_zero, ring_signature.one,
    ring_signature.add, ring_signature.zero] at himage,
  have h := (bd_app.inj (bd_app.inj (bd_notequal.inj himage).1).1).2,
  apply nat_cast_bd_ring_term_inj h,
end

-- lemma equal_instances_of_zero {M : Structure ring_signature} [mul_zero_class M] :
--   mul_zero_class.to_has_zero M.carrier = models_ring_theory_to_comm_ring.has_zero :=
-- begin

-- end
--
theorem is_complete'_ACF₀ : is_complete' ACF₀ :=
begin
  sorry
end

lemma characteristic_change_left (ϕ : sentence ring_signature.{0}) :
ACF₀ ⊨ ϕ → ∃ (n : ℕ), ∀ {p : ℕ} (hp : nat.prime p), n < p → ACFₚ hp ⊨ ϕ :=
begin
  rw compactness,
  intro hsatis,
  obtain ⟨ fs , hsatis , hsub ⟩ := hsatis,
  obtain ⟨ fsACF , fsrange , hunion, hACF , hrange ⟩ :=
    finset.subset_union_elim hsub,
  set fsnat : finset ℕ := finset.preimage fsrange plus_one_ne_zero.{0}
      (set.inj_on_of_injective injective_plus_one_ne_zero _) with hfsnat,
  use fsnat.sup id + 1,
  intros p hp hlt M hMx hmodel,
  have _inst_1 : fact (M ⊨ ACF) := ⟨ (models_ACFₚ_iff.mp hmodel).2 ⟩,
  have hchar := @models_ACFₚ_char _ _ _inst_1 _ hmodel,
  apply hsatis hMx,
  rw [← hunion, finset.coe_union, all_realize_sentence_union],
  split,
  {
    apply all_realize_sentence_of_subset _ hACF,
    exact all_realize_sentence_of_subset hmodel ACF_subset_ACFₚ,
  },
  {
    have hSTS :(∀ n : ℕ, n ∈ fsnat → M ⊨ plus_one_ne_zero n) → M ⊨ fsrange,
    {
      classical,
      have hrw0 := finset.image_preimage plus_one_ne_zero fsrange
        (set.inj_on_of_injective injective_plus_one_ne_zero _),
      rw [← hfsnat, finset.filter_mem_set_of_subset_set (λ x hx, (hrange hx).1)]
        at hrw0,
      rw ← hrw0,
      simp only [all_realize_sentence],
      intros hrealize ϕ hϕ,
      simp only [set.mem_preimage, set.mem_image,
        finset.coe_preimage, finset.mem_coe, finset.coe_image] at hϕ,
      obtain ⟨ n , hn , hϕ ⟩ := hϕ,
      rw [← hϕ],
      apply hrealize,
      rw [hfsnat, finset.mem_preimage],
      exact hn,
    },
    apply hSTS,
    intros n hnp,
    rw realize_plus_one_ne_zero,
    have hne_zero_of_le_char :
      ∀ x : ℕ, x.succ < p → (x.succ : M) ≠ 0,
    {
      intros x hx hbot,
      apply nat.succ_ne_zero x,
      have hfield : field M.carrier := @models_ACF_to.Field _ _inst_1,
      apply @ring_char.lt_char_field _ (models_ACF_to.Field),
      { exact hbot },
      rw ← hchar at hx,
      exact hx,
    },
    apply hne_zero_of_le_char _,
    apply lt_of_le_of_lt (nat.succ_le_succ _) hlt,
    exact finset.le_sup hnp,
  },
end

/-- Any ring fact holds in ACF₀ if and only if for all large p it holds for all ACFₚ-/
theorem characteristic_change (ϕ : sentence ring_signature.{0}) :
ACF₀ ⊨ ϕ ↔ (∃ (n : ℕ), ∀ {p : ℕ} (hp : nat.prime p), n < p → ACFₚ hp ⊨ ϕ) :=
begin
  split,
  { apply characteristic_change_left },
  {
    intro hn,
    cases is_complete'_ACF₀ ϕ with hsatis hsatis,
    { exact hsatis },
    {
      have hm := characteristic_change_left (∼ ϕ) hsatis, clear hsatis, --R
      cases hn with n hn,
      cases hm with m hm,
      obtain ⟨ p , hle , hp ⟩ := nat.exists_infinite_primes (max n m).succ,
      have hnp : n < p :=
        lt_of_lt_of_le (nat.lt_succ_of_le (le_max_left _ _)) hle,
      have hmp : m < p :=
        lt_of_lt_of_le (nat.lt_succ_of_le (le_max_right _ _)) hle,
      have hS := instances.algebraic_closure_of_zmod_models_ACFₚ hp,
      specialize @hn p hp hnp _ ⟨ 0 ⟩ hS,
      specialize @hm p hp hmp _ ⟨ 0 ⟩ hS,
      simp only [realize_sentence_not] at hm,
      exfalso,
      apply hm hn,
    },
  },
end

open Rings.ring_signature

lemma nat_cast_eq {M : Structure ring_signature} (n : ℕ)
  [non_assoc_semiring M.carrier] : (n : M)
  =
  (@nat.cast M.carrier (by apply_instance) _ _ n) := rfl

lemma something_spec {M : Structure ring_signature} (h : M ⊨ ACF)
  {p n : ℕ} (hp : prime p) (hchar : (p : M) = 0) (hnp : n < p) :
  (n : M) ≠ 0 :=
begin
  intro hn0,
  have hNASR : non_assoc_semiring M.carrier :=
  @semiring.to_non_assoc_semiring M (
    @comm_semiring.to_semiring M (
      @comm_ring.to_comm_semiring M (
        @field.to_comm_ring M (
          @models_ACF_to.Field M ⟨ h ⟩)))),
  have hrw := @ring_char.spec M hNASR n,
  rw @nat_cast_eq M n hNASR at hn0,
  -- rw hrw at hn0,

  -- rw hn0 at hrw,

  -- simp only [symm hn0] at hrw,
  sorry
end

example {R : Type*} [non_assoc_semiring R] (n : ℕ) : R := n.cast

#check ring_char.spec

#check char_p.exists_unique

end Lefschetz


structure S :=
(x := true)

def f (s : S) : Bool :=
s.x

#eval f {}

theorem ex : f {} = true :=
rfl


import algebra.group.basic
import analysis.convex.cone.basic
import linear_algebra.dual
import algebra.order.ring
import algebra.module.hom
import ring_theory.finiteness

import for_mathlib.Gordan

/-!

# Lemma 9.7 of [Analytic]

In this file we state and prove 9.7 of [Analytic]. The proof in the pdf is short, but
combinatorics can be fiddly. However it is almost certain that this file could be
a lot shorter.

-/

open_locale nnreal big_operators classical

variables {Λ : Type*} [add_comm_group Λ]
variable {ι : Type*}

noncomputable theory

open classical subtype function embedding

/-- A technical auxiliary lemma used in the proof of `lem97_pos`. -/
lemma aux_1 {N : ℕ} {l : ι → Λ} {S₀ : finset (Λ →+ ℤ)}
  (hS₀ : submodule.span ℕ ↑S₀ = explicit_dual_set l) :
  let ψ : ({x // x ∈ S₀} → fin N) → Λ →+ ℤ :=
        λ (y : {x // x ∈ S₀} → fin N), ∑ (s : {x // x ∈ S₀}) in S₀.attach, (y s).val • s.val,
      B : finset (Λ →+ ℤ) := finset.image ψ finset.univ
  in ∀ (b : Λ →+ ℤ), b ∈ B → b ∈ explicit_dual_set l :=
begin
  intros ψ B b hb,
  rcases finset.mem_image.mp hb with ⟨y, ⟨hy₁, rfl⟩⟩,
  rw [← hS₀],
  apply mem_span_finset.mpr,
  refine ⟨λ x : (Λ →+ ℤ), if H: x ∈ S₀ then (y ⟨x, H⟩ : ℕ) else 0, _⟩,
  rw ← finset.sum_attach,
  refine finset.sum_congr rfl (λ s hs, _),
  simp only [finset.coe_mem, finset.mk_coe, dite_eq_ite, if_true, fin.val_eq_coe, val_eq_coe]
end

/-- A technical auxiliary lemma used in the proof of `lem97_pos`. -/
lemma aux_2 {N : ℕ} (hN : 0 < N) {l : ι → Λ} {S₀ : finset (Λ →+ ℤ)}
  (hS₀ : submodule.span ℕ ↑S₀ = explicit_dual_set l) {f r : (Λ →+ ℤ) → ℕ} :
  let Y : Type u_1 := {x // x ∈ S₀} → fin N,
      ψ : Y → Λ →+ ℤ := λ (y : Y), ∑ (s : {x // x ∈ S₀}) in S₀.attach, (y s).val • s.val,
      B : finset (Λ →+ ℤ) := finset.image ψ finset.univ,
      g : (Λ →+ ℤ) → fin N := λ (i : Λ →+ ℤ), ⟨f i % N, nat.mod_lt _ hN⟩,
      x' : Λ →+ ℤ := ∑ (i : Λ →+ ℤ) in S₀, (g i).val • i
  in f = ↑g + N • r → x' = ∑ (i : Λ →+ ℤ) in S₀, (g i).val • i → x' ∈ B →
    ∀ (i : ι), x' (l i) ≤ (⇑∑ (i : Λ →+ ℤ) in S₀, f i • i) (l i) :=
begin
  intros Y ψ B g x' hr hx' H i,
  dsimp [x'],
  rw [sub_nonpos.symm, sub_eq_add_neg, ← add_monoid_hom.neg_apply, ← finset.sum_neg_distrib,
    add_monoid_hom.finset_sum_apply, add_monoid_hom.finset_sum_apply, ← finset.sum_add_distrib],
  swap, apply_instance,
  simp only [← add_monoid_hom.add_apply, ← nsmul_eq_smul, ← coe_nat_zsmul, ← neg_zsmul,
     zsmul_eq_smul, ← add_smul],
  simp only [add_monoid_hom.add_apply, add_monoid_hom.smul_apply, pi.add_apply, pi.neg_apply,
     int.coe_nat_mod, pi.smul_apply, add_monoid_hom.neg_apply],
  apply finset.sum_nonpos,
  intros z hz,
  replace hz : z ∈ explicit_dual_set l,
  { rw [← submodule.span_singleton_le_iff_mem, ← hS₀],
    exact submodule.span_mono (set.singleton_subset_iff.mpr hz) },
  replace hz : 0 ≤ z (l i) := rfl.mpr hz i,
  simp only [- add_neg_le_iff_le_add', tactic.ring.add_neg_eq_sub, smul_sub],
  rw sub_smul,
  rw [← int.coe_nat_mod, sub_le_iff_le_add, zero_add],
  simp only [has_smul.smul, zsmul_int_int],
  exact (mul_le_mul_of_nonneg_right (int.coe_nat_le.mpr (nat.mod_le (f z) N)) hz),
end

/-- A technical auxiliary lemma used in the proof of `lem97_pos`. -/
lemma aux_3 {N : ℕ} (hN : 0 < N) {l : ι → Λ} {S₀ : finset (Λ →+ ℤ)}
  (hS₀ : submodule.span ℕ ↑S₀ = explicit_dual_set l) :
  let Y : Type u_1 := {x // x ∈ S₀} → fin N,
      ψ : Y → Λ →+ ℤ := λ (y : Y), ∑ (s : {x // x ∈ S₀}) in S₀.attach, (y s).val • s.val,
      B : finset (Λ →+ ℤ) := finset.image ψ finset.univ
  in ∀ (x : Λ →+ ℤ), x ∈ explicit_dual_set l → (∃ (x' : Λ →+ ℤ) (H : x' ∈ B) (y : Λ →+ ℤ),
      x = N • y + x' ∧ ∀ (i : ι), x' (l i) ≤ x (l i)) :=
begin
  intros Y ψ B x hx,
  rw [← hS₀, mem_span_finset] at hx,
  rcases hx with ⟨f, rfl⟩,
  let g : (Λ →+ ℤ) → (fin N) := (λ i, ⟨f i % N, nat.mod_lt (f i) hN⟩),
  obtain ⟨r, hr⟩ : ∃ (r : (Λ →+ ℤ) → ℕ), f = ↑g + N • r,
  { use λ x, (f x - g x) / N,
    refine funext (λ z, (_ : f z = g z + N * ((f z - f z % N) / N))),
    rw [nat.mul_div_cancel' (nat.dvd_sub_mod _)],
    exact (add_tsub_cancel_of_le (nat.mod_le _ _)).symm },
  set x' := ∑ (i : Λ →+ ℤ) in S₀, (g i).val • i with hx',
  have H : x' ∈ B,
  { refine finset.mem_image.mpr ⟨g ∘ val, finset.mem_univ _, _⟩,
    convert finset.sum_attach,
    refl },
  refine ⟨x', _, ∑ (i : Λ →+ ℤ) in S₀, r i • i, _, _⟩,
  { refine finset.mem_image.mpr ⟨g ∘ val, finset.mem_univ _, _⟩,
    convert finset.sum_attach,
    refl },
  { rw [hr, finset.smul_sum, ← finset.sum_add_distrib],
    simp_rw [← smul_assoc, ← add_smul, add_comm (N • _) _],
    refl },
  exact aux_2 hN hS₀ hr hx' H,
end

/-- The proof of Lemma 9.7 of `Analytic.pdf` under the additional assumption
that (in the notation of the paper) λᵢ(x)≥0 for all i. -/
lemma lem97_pos [module.finite ℤ Λ] [module.free ℤ Λ] [fintype ι] (N : ℕ) (hN : 0 < N) (l : ι → Λ) :
  ∃ B : finset (Λ →+ ℤ), (∀ b ∈ B, b ∈ (explicit_dual_set l)) ∧
    ∀ x : Λ →+ ℤ, x ∈ (explicit_dual_set l) → ∃ (x' ∈ B) (y : Λ →+ ℤ),
    x = N • y + x' ∧ ∀ i, x' (l i) ≤ x (l i) :=
begin
  obtain ⟨S₀, hS₀⟩ := explicit_gordan l,
  let Y : Type* := { x // x ∈ S₀ } → (fin N),
  let ψ : Y → Λ →+ ℤ := λ y : Y, ∑ s in finset.attach S₀, (y s).1 • s.val,
  exact ⟨finset.image ψ finset.univ, aux_1 hS₀, aux_3 hN hS₀⟩,
end

section sign_vectors

def nonzero_sign : ℤ → units ℤ := λ n, if 0 ≤ n then 1 else -1

def sign_vectors (ι : Type*) := (ι → units ℤ)

instance sign_vectors_inhabited : inhabited (sign_vectors ι) := ⟨(λ i, 1)⟩

def fintype_sign_vectors [fintype ι] : fintype (sign_vectors ι) := pi.fintype

/-- Given a list l of elements of Λ and a functional x, (pos_vector l x) is the sign-vector of
the values of x (l i). -/
def pos_vector (l : ι → Λ) (x : Λ →+ ℤ) : sign_vectors ι :=
λ i, nonzero_sign (x (l i))

instance smul_signs : has_smul (sign_vectors ι) (ι → Λ) :=
{ smul := λ ε l i, (ε i : ℤ) • l i }

lemma pos_vector_nonneg (l : ι → Λ) (x : Λ →+ ℤ) (j : ι) :
  0 ≤ x ((pos_vector l x • l) j) :=
begin
  rw [pos_vector, nonzero_sign],
  simp only [has_smul.smul, add_monoid_hom.map_zsmul, zsmul_int_int],
  split_ifs,
  { convert h, simp },
  { simp, linarith }
end

lemma smul_to_explicit_dual_set (l : ι → Λ) (x : Λ →+ ℤ) :
  x ∈ (explicit_dual_set ((pos_vector l x) • l)) :=
λ j, pos_vector_nonneg l x j

lemma pos_vector_id_if_nonneg (l : ι → Λ) (x : Λ →+ ℤ) (i : ι) : 0 ≤ x (l i) →
    (pos_vector l x • l) i = l i :=
begin
  intro hx,
  simp only [pos_vector, nonzero_sign, has_smul.smul, id.def],
  rw [if_pos hx],-- units.coe_one, one_zsmul],
  simp,
end

lemma pos_vector_neg_if_neg (l : ι → Λ) (x : Λ →+ ℤ) (i : ι) : x (l i) < 0 →
    ((pos_vector l x) • l) i = - l i :=
begin
  intro hx,
  simp only [pos_vector, nonzero_sign, has_smul.smul, id.def],
  rw [if_neg (not_le.mpr hx)], simp,
end

end sign_vectors

/-- Given a list l, a vector of signs ε (and a positive integer N), (pos_A l ε) is a finite set of
functionals satisfying the requirements of Lemma 9.7 of [Analytic] with respect to all functionals
which are positive on all ((ε • l) i)'s. Its existence was established in lem97_pos above.
-/
def pos_A [fintype ι] [module.finite ℤ Λ] [module.free ℤ Λ] (N : ℕ) (hN : 0 < N)
  (l : ι → Λ) (ε : sign_vectors ι) : finset (Λ →+ ℤ) :=
some (lem97_pos N hN (ε • l))

lemma posA_to_explicit [fintype ι] [module.finite ℤ Λ] [module.free ℤ Λ]
  (N : ℕ) (hN : 0 < N) (l : ι → Λ) (ε : sign_vectors ι) (x' : Λ →+ ℤ) (H : x' ∈ pos_A N hN l ε) :
  x' ∈ explicit_dual_set (ε • l) :=
(some_spec (lem97_pos N hN (ε • l))).1 x' H

lemma exists_good_pair [fintype ι] [module.finite ℤ Λ] [module.free ℤ Λ]
  (N : ℕ) (hN : 0 < N) (l : ι → Λ)
  (ε : sign_vectors ι) (x : Λ →+ ℤ) (H : x ∈ (explicit_dual_set (ε • l))) :
  ∃ x' y : (Λ →+ ℤ),
    x' ∈ pos_A N hN l ε ∧ x = N • y + x' ∧ ∀ i, x' ((ε • l) i) ≤ x ((ε • l) i) :=
begin
  obtain ⟨x', hx', ⟨y, hy⟩⟩ := (some_spec (lem97_pos N hN (ε • l))).2 x H,
  exact ⟨x', y, hx', hy⟩,
end

/-

The remainder of this file is proofs of two versions of Lemma 9.7, namely
`lem97` and `lem97'`.

-/

/-- Lemma 9.7 of [Analytic]. See also the (mathematically indistinguishable) variant `lem97'`. -/
lemma lem97 [fintype ι] [module.finite ℤ Λ] [module.free ℤ Λ] (N : ℕ) (hN : 0 < N) (l : ι → Λ) :
  ∃ A : finset (Λ →+ ℤ), ∀ x : Λ →+ ℤ, ∃ (x' ∈ A) (y : Λ →+ ℤ),
    x = N • y + x' ∧
    ∀ i, (0 ≤ x' (l i) ∧ 0 ≤ (x - x') (l i)) ∨ (x' (l i) ≤ 0 ∧ (x - x') (l i) ≤ 0) :=
begin
  refine ⟨(@finset.univ (sign_vectors ι) (fintype_sign_vectors)).bUnion (pos_A N hN l), λ x, _⟩,
  have hx : x ∈ (explicit_dual_set ((pos_vector l x) • l)) := smul_to_explicit_dual_set l x,
  obtain ⟨x', y, mem_x', hy, hx'⟩ := exists_good_pair N hN l (pos_vector l x) x hx,
  refine ⟨x', _, _⟩,
  { refine finset.mem_bUnion.mpr ⟨pos_vector l x, _, mem_x'⟩,
    simp only [finset.mem_univ] },
  { refine ⟨y, hy, λ i, _⟩,
    have h_pos' : x' ∈ explicit_dual_set ((pos_vector l x) • l) :=
      posA_to_explicit N hN l (pos_vector l x) x' mem_x',
    replace h_pos' : 0 ≤ x' (((pos_vector l x) • l) i) := h_pos' _,
    by_cases h_pos : 0 ≤ x (l i),
    { have h_posvect_id : ((pos_vector l x) • l) i = l i := pos_vector_id_if_nonneg l x i h_pos,
      replace h_pos' : 0 ≤ x' (l i) := h_pos'.trans (le_of_eq (congr_arg x' h_posvect_id)),
      refine or.inl ⟨h_pos', _⟩,
      rw ← h_posvect_id,
      simp only [sub_nonneg, add_monoid_hom.sub_apply, hx'] },
    { specialize hx' i,
      have h_posvect_neg : ((pos_vector l x) • l) i = - l i :=
        pos_vector_neg_if_neg l x i (not_le.mp h_pos),
      rw [h_posvect_neg] at *,
      replace h_pos' : x' (l i) ≤ 0,
      { rw [x'.map_neg] at h_pos',
        exact neg_nonneg.mp h_pos' },
      refine or.inr ⟨h_pos', _⟩,
      simpa only [neg_le_neg_iff, add_monoid_hom.sub_apply, add_monoid_hom.map_neg, sub_nonpos]
        using hx' } }
end

lemma os.monotone_pow {R : Type*} [ordered_semiring R] (k : ℕ) (R0 : ∀ r : R, 0 ≤ r) :
  monotone (λ n : R, n ^ k) :=
λ x y xy, pow_le_pow_of_le_left (R0 _) xy k

lemma nat.monotone_pow (k : ℕ) : monotone (λ n : ℕ, n ^ k) :=
os.monotone_pow k nat.zero_le
--λ x y xy, pow_le_pow_of_le_left x.zero_le xy k

lemma nat.strict_mono_pow {k : ℕ} (k0 : 0 < k) : strict_mono (λ n : ℕ, n ^ k) :=
λ x y xy, pow_lt_pow_of_lt_left xy x.zero_le k0

lemma nat.injective_pow {k : ℕ} (k0 : 0 < k) : function.injective (λ n : ℕ, n ^ k) :=
injective_of_increasing (<) (<) _ (nat.strict_mono_pow k0)

lemma int.nat_abs_eq_self (a : ℤ) : (a.nat_abs : ℤ) = a ↔ 0 ≤ a :=
⟨λ h, by { rw ← h, exact int.coe_zero_le a.nat_abs }, λ h, int.nat_abs_of_nonneg h⟩

lemma abs_add_eq_iff_abs_mul_eq {R : Type*} [linear_ordered_comm_ring R] {a b : R} :
  abs (a + b) = abs a + abs b ↔ abs (a * b) = a * b :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { simpa only [abs_mul, add_pow_two, mul_assoc, pow_bit0_abs, add_left_inj, mul_eq_mul_left_iff,
      or_false, bit0_eq_zero, one_ne_zero, add_right_inj] using congr_arg (λ x : R, x ^ 2) h.symm },
  { rcases (mul_nonneg_iff.mp (abs_eq_self.mp h)) with ⟨a0, b0⟩ | ⟨a0, b0⟩,
    { rw [abs_of_nonneg a0, abs_of_nonneg b0, abs_of_nonneg (add_nonneg a0 b0)] },
    { rw [abs_of_nonpos a0, abs_of_nonpos b0, abs_of_nonpos (add_nonpos a0 b0), neg_add] } }
end

lemma nat_abs_add_eq_iff_nat_abs_mul_eq {a b : ℤ} :
  int.nat_abs (a + b) = a.nat_abs + b.nat_abs ↔ ((a * b).nat_abs : ℤ) = a * b :=
begin
  rw [← int.abs_eq_nat_abs, ← abs_add_eq_iff_abs_mul_eq, int.abs_eq_nat_abs, int.abs_eq_nat_abs,
    int.abs_eq_nat_abs],
  norm_cast,
end

lemma nat_abs_add_eq_iff (a b : ℤ) :
  int.nat_abs (a + b) = int.nat_abs a + int.nat_abs b ↔ (0 ≤ a ∧ 0 ≤ b ∨ a ≤ 0 ∧ b ≤ 0) :=
nat_abs_add_eq_iff_nat_abs_mul_eq.trans ((int.nat_abs_eq_self _).trans mul_nonneg_iff)

lemma nat_smul_nat_abs (a : ℕ) (b : ℤ) : a • b.nat_abs = (a • b).nat_abs :=
begin
  nth_rewrite 0 [← int.nat_abs_of_nat a],
  rw [smul_eq_mul, ← int.nat_abs_mul, ← smul_eq_mul],
  apply congr_arg,
  rw [algebra.id.smul_eq_mul, nsmul_eq_mul],
end

/-- Lemma 9.7 of [Analytic]. See also the (mathematically indistinguishable) variant `lem97`. -/
lemma lem97' [fintype ι] [module.finite ℤ Λ] [module.free ℤ Λ] (N : ℕ) (hN : 0 < N) (l : ι → Λ) :
  ∃ A : finset (Λ →+ ℤ), ∀ x : Λ →+ ℤ, ∃ (x' ∈ A) (y : Λ →+ ℤ),
    x = N • y + x' ∧
    ∀ i, (x (l i)).nat_abs = N * (y (l i)).nat_abs + (x' (l i)).nat_abs :=
begin
  obtain ⟨A, hA⟩ := lem97 N hN l,
  refine ⟨A, λ x, _⟩,
  rcases hA x with ⟨x', mem_x', y, rfl, hx'⟩,
  refine ⟨x', mem_x', y, rfl, λ i, _⟩,
  specialize hx' i,
  rw [← nat_abs_add_eq_iff, add_sub_cancel, add_monoid_hom.coe_smul, pi.smul_apply] at hx',
  rw [add_monoid_hom.add_apply, add_monoid_hom.coe_smul, pi.smul_apply, add_comm, hx', add_comm,
    add_left_inj, ← nat_smul_nat_abs, smul_eq_mul],
end

-- TODO
-- #lint-

-- /- The `doc_blame` linter reports: -/
-- /- DEFINITIONS ARE MISSING DOCUMENTATION STRINGS: -/
-- #print nonzero_sign /- def missing doc string -/
-- #print sign_vectors /- def missing doc string -/
-- #print fintype_sign_vectors /- def missing doc string -/


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Nicolò Cavalleri.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.lie.basic
import Mathlib.ring_theory.algebra_tower
import Mathlib.PostPort

universes u_1 u_2 u_3 l u_4

namespace Mathlib

/-!
# Derivations

This file defines derivation. A derivation `D` from the `R`-algebra `A` to the `A`-module `M` is an
`R`-linear map that satisfy the Leibniz rule `D (a * b) = a * D b + D a * b`.

## Notation

The notation `⁅D1, D2⁆` is used for the commutator of two derivations.

TODO: this file is just a stub to go on with some PRs in the geometry section. It only
implements the definition of derivations in commutative algebra. This will soon change: as soon
as bimodules will be there in mathlib I will change this file to take into account the
non-commutative case. Any development on the theory of derivations is discouraged until the
definitive definition of derivation will be implemented.
-/

/-- `D : derivation R A M` is an `R`-linear map from `A` to `M` that satisfies the `leibniz`
equality.
TODO: update this when bimodules are defined. -/
structure derivation (R : Type u_1) (A : Type u_2) [comm_semiring R] [comm_semiring A] [algebra R A]
    (M : Type u_3) [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M]
    extends linear_map R A M where
  leibniz' :
    ∀ (a b : A),
      linear_map.to_fun _to_linear_map (a * b) =
        a • linear_map.to_fun _to_linear_map b + b • linear_map.to_fun _to_linear_map a

namespace derivation

protected instance has_coe_to_fun {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] : has_coe_to_fun (derivation R A M) :=
  has_coe_to_fun.mk (fun (D : derivation R A M) => A → M)
    fun (D : derivation R A M) => linear_map.to_fun (derivation.to_linear_map D)

protected instance has_coe_to_linear_map {R : Type u_1} [comm_semiring R] {A : Type u_2}
    [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M]
    [semimodule R M] [is_scalar_tower R A M] : has_coe (derivation R A M) (linear_map R A M) :=
  has_coe.mk fun (D : derivation R A M) => derivation.to_linear_map D

@[simp] theorem to_fun_eq_coe {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] (D : derivation R A M) :
    linear_map.to_fun (derivation.to_linear_map D) = ⇑D :=
  rfl

@[simp] theorem coe_fn_coe {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] (f : derivation R A M) : ⇑↑f = ⇑f :=
  rfl

theorem coe_injective {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] {D1 : derivation R A M} {D2 : derivation R A M} (H : ⇑D1 = ⇑D2) :
    D1 = D2 :=
  sorry

theorem ext {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A]
    {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] {D1 : derivation R A M} {D2 : derivation R A M}
    (H : ∀ (a : A), coe_fn D1 a = coe_fn D2 a) : D1 = D2 :=
  coe_injective (funext H)

@[simp] theorem map_add {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] (D : derivation R A M) (a : A) (b : A) :
    coe_fn D (a + b) = coe_fn D a + coe_fn D b :=
  is_add_hom.map_add (⇑D) a b

@[simp] theorem map_zero {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] (D : derivation R A M) : coe_fn D 0 = 0 :=
  is_add_monoid_hom.map_zero ⇑D

@[simp] theorem map_smul {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] (D : derivation R A M) (r : R) (a : A) :
    coe_fn D (r • a) = r • coe_fn D a :=
  linear_map.map_smul (↑D) r a

@[simp] theorem leibniz {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] (D : derivation R A M) (a : A) (b : A) :
    coe_fn D (a * b) = a • coe_fn D b + b • coe_fn D a :=
  derivation.leibniz' D a b

@[simp] theorem map_one_eq_zero {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] (D : derivation R A M) : coe_fn D 1 = 0 :=
  sorry

@[simp] theorem map_algebra_map {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] (D : derivation R A M) (r : R) :
    coe_fn D (coe_fn (algebra_map R A) r) = 0 :=
  sorry

protected instance has_zero {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] : HasZero (derivation R A M) :=
  { zero := mk 0 sorry }

protected instance inhabited {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] : Inhabited (derivation R A M) :=
  { default := 0 }

protected instance add_comm_monoid {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] : add_comm_monoid (derivation R A M) :=
  add_comm_monoid.mk (fun (D1 D2 : derivation R A M) => mk (↑D1 + ↑D2) sorry) sorry 0 sorry sorry
    sorry

@[simp] theorem add_apply {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] {D1 : derivation R A M} {D2 : derivation R A M} (a : A) :
    coe_fn (D1 + D2) a = coe_fn D1 a + coe_fn D2 a :=
  rfl

protected instance derivation.Rsemimodule {R : Type u_1} [comm_semiring R] {A : Type u_2}
    [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M]
    [semimodule R M] [is_scalar_tower R A M] : semimodule R (derivation R A M) :=
  semimodule.mk sorry sorry

@[simp] theorem smul_to_linear_map_coe {R : Type u_1} [comm_semiring R] {A : Type u_2}
    [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M]
    [semimodule R M] [is_scalar_tower R A M] (D : derivation R A M) (r : R) : ↑(r • D) = r • ↑D :=
  rfl

@[simp] theorem Rsmul_apply {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] (D : derivation R A M) (r : R) (a : A) :
    coe_fn (r • D) a = r • coe_fn D a :=
  rfl

protected instance semimodule {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] : semimodule A (derivation R A M) :=
  semimodule.mk sorry sorry

@[simp] theorem smul_apply {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] (D : derivation R A M) (a : A) (b : A) :
    coe_fn (a • D) b = a • coe_fn D b :=
  rfl

protected instance is_scalar_tower {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    [is_scalar_tower R A M] : is_scalar_tower R A (derivation R A M) :=
  is_scalar_tower.mk
    fun (x : R) (y : A) (z : derivation R A M) => ext fun (a : A) => smul_assoc x y (coe_fn (↑z) a)

@[simp] theorem map_neg {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A]
    {M : Type u_3} [add_comm_group M] [module A M] [module R M] [is_scalar_tower R A M]
    (D : derivation R A M) (a : A) : coe_fn D (-a) = -coe_fn D a :=
  linear_map.map_neg (↑D) a

@[simp] theorem map_sub {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A]
    {M : Type u_3} [add_comm_group M] [module A M] [module R M] [is_scalar_tower R A M]
    (D : derivation R A M) (a : A) (b : A) : coe_fn D (a - b) = coe_fn D a - coe_fn D b :=
  linear_map.map_sub (↑D) a b

protected instance add_comm_group {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A]
    [algebra R A] {M : Type u_3} [add_comm_group M] [module A M] [module R M]
    [is_scalar_tower R A M] : add_comm_group (derivation R A M) :=
  add_comm_group.mk add_comm_monoid.add sorry add_comm_monoid.zero sorry sorry
    (fun (D : derivation R A M) => mk (-↑D) sorry)
    (fun (D1 D2 : derivation R A M) => mk (↑D1 - ↑D2) sorry) sorry sorry

@[simp] theorem sub_apply {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A]
    {M : Type u_3} [add_comm_group M] [module A M] [module R M] [is_scalar_tower R A M]
    {D1 : derivation R A M} {D2 : derivation R A M} (a : A) :
    coe_fn (D1 - D2) a = coe_fn D1 a - coe_fn D2 a :=
  rfl

/-! # Lie structures -/

/-- The commutator of derivations is again a derivation. -/
def commutator {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A]
    (D1 : derivation R A A) (D2 : derivation R A A) : derivation R A A :=
  mk (linear_map.mk (linear_map.to_fun (has_bracket.bracket ↑D1 ↑D2)) sorry sorry) sorry

protected instance has_bracket {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A]
    [algebra R A] : has_bracket (derivation R A A) (derivation R A A) :=
  has_bracket.mk commutator

@[simp] theorem commutator_coe_linear_map {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A]
    [algebra R A] {D1 : derivation R A A} {D2 : derivation R A A} :
    ↑(has_bracket.bracket D1 D2) = has_bracket.bracket ↑D1 ↑D2 :=
  rfl

theorem commutator_apply {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A]
    {D1 : derivation R A A} {D2 : derivation R A A} (a : A) :
    coe_fn (has_bracket.bracket D1 D2) a = coe_fn D1 (coe_fn D2 a) - coe_fn D2 (coe_fn D1 a) :=
  rfl

protected instance lie_ring {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A]
    [algebra R A] : lie_ring (derivation R A A) :=
  lie_ring.mk sorry sorry sorry sorry

protected instance lie_algebra {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A]
    [algebra R A] : lie_algebra R (derivation R A A) :=
  lie_algebra.mk sorry

end derivation

namespace linear_map

/-- The composition of a linear map and a derivation is a derivation. -/
def comp_der {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A]
    {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] {N : Type u_4}
    [add_cancel_comm_monoid N] [semimodule A N] [semimodule R N] [is_scalar_tower R A M]
    [is_scalar_tower R A N] (f : linear_map A M N) (D : derivation R A M) : derivation R A N :=
  derivation.mk (mk (fun (a : A) => coe_fn f (coe_fn D a)) sorry sorry) sorry

@[simp] theorem comp_der_apply {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A]
    [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
    {N : Type u_4} [add_cancel_comm_monoid N] [semimodule A N] [semimodule R N]
    [is_scalar_tower R A M] [is_scalar_tower R A N] (f : linear_map A M N) (D : derivation R A M)
    (a : A) : coe_fn (comp_der f D) a = coe_fn f (coe_fn D a) :=
  rfl

end Mathlib