/-
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.geometry.manifold.algebra.monoid
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4 l u_5 u_6 u_7 u_8

namespace Mathlib

/-!
# Lie groups

A Lie group is a group that is also a smooth manifold, in which the group operations of
multiplication and inversion are smooth maps. Smoothness of the group multiplication means that
multiplication is a smooth mapping of the product manifold `G` × `G` into `G`.

Note that, since a manifold here is not second-countable and Hausdorff a Lie group here is not
guaranteed to be second-countable (even though it can be proved it is Hausdorff). Note also that Lie
groups here are not necessarily finite dimensional.

## Main definitions and statements

* `lie_add_group I G` : a Lie additive group where `G` is a manifold on the model with corners `I`.
* `lie_group I G`     : a Lie multiplicative group where `G` is a manifold on the model with
                        corners `I`.
* `lie_add_group_morphism I I' G G'`  : morphism of addittive Lie groups
* `lie_group_morphism I I' G G'`      : morphism of Lie groups
* `lie_add_group_core I G`            : allows to define a Lie additive group without first proving
                                        it is a topological additive group.
* `lie_group_core I G`                : allows to define a Lie group without first proving
                                        it is a topological group.

* `reals_lie_group`                   : real numbers are a Lie group

## Implementation notes
A priori, a Lie group here is a manifold with corners.

The definition of Lie group cannot require `I : model_with_corners 𝕜 E E` with the same space as the
model space and as the model vector space, as one might hope, beause in the product situation,
the model space is `model_prod E E'` and the model vector space is `E × E'`, which are not the same,
so the definition does not apply. Hence the definition should be more general, allowing
`I : model_with_corners 𝕜 E H`.
-/

/-- A Lie (additive) group is a group and a smooth manifold at the same time in which
the addition and negation operations are smooth. -/
class lie_add_group {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {H : Type u_2} [topological_space H] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] (I : model_with_corners 𝕜 E H) (G : Type u_4) [add_group G] [topological_space G] [topological_add_group G] [charted_space H G]
extends has_smooth_add I G
where
  smooth_neg : smooth I I fun (a : G) => -a

/-- A Lie group is a group and a smooth manifold at the same time in which
the multiplication and inverse operations are smooth. -/
class lie_group {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {H : Type u_2} [topological_space H] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] (I : model_with_corners 𝕜 E H) (G : Type u_4) [group G] [topological_space G] [topological_group G] [charted_space H G]
extends has_smooth_mul I G
where
  smooth_inv : smooth I I fun (a : G) => a⁻¹

theorem smooth_pow {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {H : Type u_2} [topological_space H] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E H} {G : Type u_5} [topological_space G] [charted_space H G] [group G] [topological_group G] [lie_group I G] (n : ℕ) : smooth I I fun (a : G) => a ^ n := sorry

theorem smooth_inv {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {H : Type u_2} [topological_space H] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E H} {G : Type u_5} [topological_space G] [charted_space H G] [group G] [topological_group G] [lie_group I G] : smooth I I fun (x : G) => x⁻¹ :=
  lie_group.smooth_inv

theorem smooth.neg {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {H : Type u_2} [topological_space H] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E H} {G : Type u_5} [topological_space G] [charted_space H G] [add_group G] [topological_add_group G] [lie_add_group I G] {E' : Type u_6} [normed_group E'] [normed_space 𝕜 E'] {H' : Type u_7} [topological_space H'] {I' : model_with_corners 𝕜 E' H'} {M : Type u_8} [topological_space M] [charted_space H' M] [smooth_manifold_with_corners I' M] {f : M → G} (hf : smooth I' I f) : smooth I' I fun (x : M) => -f x :=
  times_cont_mdiff.comp lie_add_group.smooth_neg hf

theorem smooth_on.neg {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {H : Type u_2} [topological_space H] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E H} {G : Type u_5} [topological_space G] [charted_space H G] [add_group G] [topological_add_group G] [lie_add_group I G] {E' : Type u_6} [normed_group E'] [normed_space 𝕜 E'] {H' : Type u_7} [topological_space H'] {I' : model_with_corners 𝕜 E' H'} {M : Type u_8} [topological_space M] [charted_space H' M] [smooth_manifold_with_corners I' M] {f : M → G} {s : set M} (hf : smooth_on I' I f s) : smooth_on I' I (fun (x : M) => -f x) s :=
  smooth.comp_smooth_on smooth_neg hf

/- Instance of product group -/

protected instance prod.lie_group {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {H : Type u_2} [topological_space H] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E H} {G : Type u_4} [topological_space G] [charted_space H G] [group G] [topological_group G] [lie_group I G] {E' : Type u_5} [normed_group E'] [normed_space 𝕜 E'] {H' : Type u_6} [topological_space H'] {I' : model_with_corners 𝕜 E' H'} {G' : Type u_7} [topological_space G'] [charted_space H' G'] [group G'] [topological_group G'] [lie_group I' G'] : lie_group (model_with_corners.prod I I') (G × G') :=
  lie_group.mk has_smooth_mul.compatible has_smooth_mul.smooth_mul
    (smooth.prod_mk (smooth.inv smooth_fst) (smooth.inv smooth_snd))

/-- Morphism of additive Lie groups. -/
structure lie_add_group_morphism {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] (I : model_with_corners 𝕜 E E) (I' : model_with_corners 𝕜 E' E') (G : Type u_4) [topological_space G] [charted_space E G] [add_group G] [topological_add_group G] [lie_add_group I G] (G' : Type u_5) [topological_space G'] [charted_space E' G'] [add_group G'] [topological_add_group G'] [lie_add_group I' G']
extends smooth_add_monoid_morphism I I' G G'
where

/-- Morphism of Lie groups. -/
structure lie_group_morphism {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] (I : model_with_corners 𝕜 E E) (I' : model_with_corners 𝕜 E' E') (G : Type u_4) [topological_space G] [charted_space E G] [group G] [topological_group G] [lie_group I G] (G' : Type u_5) [topological_space G'] [charted_space E' G'] [group G'] [topological_group G'] [lie_group I' G']
extends smooth_monoid_morphism I I' G G'
where

protected instance lie_group_morphism.has_one {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {I : model_with_corners 𝕜 E E} {I' : model_with_corners 𝕜 E' E'} {G : Type u_4} [topological_space G] [charted_space E G] [group G] [topological_group G] [lie_group I G] {G' : Type u_5} [topological_space G'] [charted_space E' G'] [group G'] [topological_group G'] [lie_group I' G'] : HasOne (lie_group_morphism I I' G G') :=
  { one := lie_group_morphism.mk (smooth_monoid_morphism.mk (smooth_monoid_morphism.to_monoid_hom 1) sorry) }

protected instance lie_add_group_morphism.inhabited {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {I : model_with_corners 𝕜 E E} {I' : model_with_corners 𝕜 E' E'} {G : Type u_4} [topological_space G] [charted_space E G] [add_group G] [topological_add_group G] [lie_add_group I G] {G' : Type u_5} [topological_space G'] [charted_space E' G'] [add_group G'] [topological_add_group G'] [lie_add_group I' G'] : Inhabited (lie_add_group_morphism I I' G G') :=
  { default := 0 }

protected instance lie_add_group_morphism.has_coe_to_fun {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {I : model_with_corners 𝕜 E E} {I' : model_with_corners 𝕜 E' E'} {G : Type u_4} [topological_space G] [charted_space E G] [add_group G] [topological_add_group G] [lie_add_group I G] {G' : Type u_5} [topological_space G'] [charted_space E' G'] [add_group G'] [topological_add_group G'] [lie_add_group I' G'] : has_coe_to_fun (lie_add_group_morphism I I' G G') :=
  has_coe_to_fun.mk (fun (a : lie_add_group_morphism I I' G G') => G → G')
    fun (a : lie_add_group_morphism I I' G G') =>
      add_monoid_hom.to_fun
        (smooth_add_monoid_morphism.to_add_monoid_hom (lie_add_group_morphism.to_smooth_add_monoid_morphism a))

/-- Sometimes one might want to define a Lie additive group `G` without having proved previously
that `G` is a topological additive group. In such case it is possible to use `lie_add_group_core`
that does not require such instance, and then get a Lie group by invoking `to_lie_add_group`. -/
structure lie_add_group_core {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] (I : model_with_corners 𝕜 E E) (G : Type u_3) [add_group G] [topological_space G] [charted_space E G]
extends smooth_manifold_with_corners I G
where
  smooth_add : smooth (model_with_corners.prod I I) I fun (p : G × G) => prod.fst p + prod.snd p
  smooth_neg : smooth I I fun (a : G) => -a

/-- Sometimes one might want to define a Lie group `G` without having proved previously that `G` is
a topological group. In such case it is possible to use `lie_group_core` that does not require such
instance, and then get a Lie group by invoking `to_lie_group` defined below. -/
structure lie_group_core {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] (I : model_with_corners 𝕜 E E) (G : Type u_3) [group G] [topological_space G] [charted_space E G]
extends smooth_manifold_with_corners I G
where
  smooth_mul : smooth (model_with_corners.prod I I) I fun (p : G × G) => prod.fst p * prod.snd p
  smooth_inv : smooth I I fun (a : G) => a⁻¹

-- The linter does not recognize that the followings are structure projections, disable it

namespace lie_group_core

protected theorem Mathlib.lie_add_group_core.to_topological_add_group {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E E} {G : Type u_4} [topological_space G] [charted_space E G] [add_group G] (c : lie_add_group_core I G) : topological_add_group G :=
  topological_add_group.mk (times_cont_mdiff.continuous (lie_add_group_core.smooth_neg c))

protected theorem to_lie_group {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E E} {G : Type u_4} [topological_space G] [charted_space E G] [group G] (c : lie_group_core I G) : lie_group I G :=
  lie_group.mk smooth_manifold_with_corners.compatible (smooth_mul c) (smooth_inv c)

end lie_group_core

/-! ### Normed spaces are Lie groups -/

protected instance normed_space_lie_group {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] : lie_add_group (model_with_corners_self 𝕜 E) E := sorry


import ring_theory.adjoin_root data.equiv.algebra algebra.direct_limit
import set_theory.schroeder_bernstein field_theory.subfield
import ring_theory.integral_closure ring_theory.algebra

universes u v w
open polynomial zorn set function
variables {K : Type u} [discrete_field K]
noncomputable theory

instance equiv.is_ring_hom {α β : Type*} [ring β] (e : α ≃ β) :
  @is_ring_hom α β (equiv.ring e) _ e :=
by split; simp [equiv.mul_def, equiv.add_def, equiv.one_def]

instance equiv.is_ring_hom.symm {α β : Type*} [ring β] (e : α ≃ β) :
  @is_ring_hom β α _ (equiv.ring e) e.symm :=
by letI := equiv.ring e; exact (show α ≃r β, from ⟨e, equiv.is_ring_hom e⟩).symm.2

namespace algebraic_closure
section map

local attribute [instance] classical.dec

lemma map_aux {X : Type u} {Y : Type v} {Z : Type w} (fxy : X ↪ Y) (fxz : X ↪ Z)
  (hYZ : (Z ↪ Y) → false) : ↥-range fxy.1 ↪ ↥-range fxz.1 :=
classical.choice $ or.resolve_left embedding.total $
  λ ⟨f⟩, hYZ $
    calc Z ↪ range fxz ⊕ ↥-range fxz :
      (equiv.set.sum_compl _).symm.to_embedding
    ... ↪ range fxy ⊕ ↥-range fxy :
      embedding.sum_congr
        (((equiv.set.range _ fxz.2).symm.to_embedding).trans
          (equiv.set.range _ fxy.2).to_embedding)
        f
    ... ↪ Y : (equiv.set.sum_compl _).to_embedding

def map {X : Type u} {Y : Type v} {Z : Type w} (fxy : X ↪ Y) (fxz : X ↪ Z)
  (hYZ : (Z ↪ Y) → false) : Y ↪ Z :=
calc Y ↪ range fxy ⊕ ↥-range fxy : (equiv.set.sum_compl _).symm.to_embedding
... ↪ range fxz ⊕ ↥-range fxz : embedding.sum_congr
  ((equiv.set.range _ fxy.2).symm.to_embedding.trans
    (equiv.set.range _ fxz.2).to_embedding)
  (map_aux fxy fxz hYZ)
... ↪ Z : (equiv.set.sum_compl _).to_embedding

lemma map_commutes {X : Type u} {Y : Type v} {Z : Type w}  (fxy : X ↪ Y) (fxz : X ↪ Z)
  (hYZ : (Z ↪ Y) → false) (x : X) : map fxy fxz hYZ (fxy x) = fxz x :=
have (⟨fxy x, mem_range_self _⟩ : range fxy) = equiv.set.range _ fxy.2 x, from rfl,
begin
  dsimp only [map, embedding.trans_apply, equiv.trans_apply, function.comp,
    equiv.to_embedding_coe_fn],
  simp only [equiv.set.sum_compl_symm_apply_of_mem (mem_range_self _),
    embedding.sum_congr_apply_inl, equiv.set.sum_compl_apply_inl,
    embedding.trans_apply, equiv.to_embedding_coe_fn, this, equiv.symm_apply_apply],
  refl
end

end map
end algebraic_closure

class is_algebraically_closed (K : Type u) [nonzero_comm_ring K] [decidable_eq K] :=
(exists_root : ∀ f : polynomial K, 0 < degree f → ∃ x, is_root f x)

-- lemma algebraic_comp {L M : Type*} [comm_ring L] [decidable_eq L] [comm_ring M] [decidable_eq M]
--   (i : K → L) (j : L → M) [is_ring_hom i] [is_ring_hom j] {x : L} :
--   algebraic K i x → algebraic K (j ∘ i) (j x) :=
-- λ ⟨f, hf⟩, ⟨f, hf.1, by rw [← eval_map, function.comp, ← polynomial.map_map i j, eval_map,
--     eval₂_hom, eval_map, hf.2, is_ring_hom.map_zero j]⟩

-- lemma algebraic_id (x : K) : algebraic K id x :=
-- ⟨X - C x, ne_zero_of_monic (monic_X_sub_C _), by simp⟩

-- lemma algebraic_equiv {L : Type*} [discrete_field L] (e : K ≃ L) [is_ring_hom e] (x : L) :
--   algebraic K e x :=
-- ⟨X - C (e.symm x), ne_zero_of_monic (monic_X_sub_C _),
--   by rw [← eval_map, map_sub, map_X, map_C, equiv.apply_symm_apply,
--       eval_sub, eval_X, eval_C, sub_self]⟩

-- lemma algebraic_adjoin_root (f : polynomial K) [irreducible f] :
--   ∀ x, algebraic K (adjoin_root.of : K → adjoin_root f) x := sorry

-- lemma algebraic_comp' {L M : Type*} [discrete_field L] [discrete_field M]
--   (i : K → L) (j : L → M) [is_field_hom i] [is_field_hom j] :
--   (∀ x, algebraic K i x) → (∀ x, algebraic L j  x) → ∀ x, algebraic K (j ∘ i) x := sorry

section classical

local attribute [instance, priority 1] classical.dec

/-- The `big_type` with cardinality strictly larger than any algebraic extension -/
def big_type (K : Type u) [discrete_field K] := set (ℕ × polynomial K)

def algebraic_embedding_aux {L : Type*} [discrete_field L] [algebra K L]
  (h : ∀ l : L, is_integral K l) (x : L) : ℕ × polynomial K :=
let f := classical.some (h x) in
⟨list.index_of x (quotient.out ((f.map (algebra_map L)).roots.1)), f⟩

lemma algebraic_embedding_aux_injective
  {L : Type*} [discrete_field L] [algebra K L]
  (h : ∀ l : L, is_integral K l) : injective (algebraic_embedding_aux h) :=
λ x y hxy,
let f := classical.some (h x) in
let g := classical.some (h y) in
have hf : monic f ∧ aeval K L x f = 0, from classical.some_spec (h x),
have hg : monic g ∧ aeval K L y g = 0, from classical.some_spec (h y),
have hfg : f = g, from (prod.ext_iff.1 hxy).2,
have hfg' : list.index_of x (quotient.out ((f.map (algebra_map L)).roots.1)) =
    list.index_of y (quotient.out ((f.map (algebra_map L)).roots.1)),
  from (prod.ext_iff.1 hxy).1.trans (hfg.symm ▸ rfl),
have hx : x ∈ quotient.out ((f.map (algebra_map L)).roots.1),
  from multiset.mem_coe.1 begin
    show x ∈ quotient.mk _,
    rw [quotient.out_eq, ← finset.mem_def, mem_roots (mt (map_eq_zero (algebra_map L)).1
      (ne_zero_of_monic hf.1)), is_root.def, eval_map, ← aeval_def, hf.2],
  end,
have hy : y ∈ quotient.out ((g.map (algebra_map L)).roots.1),
  from multiset.mem_coe.1 begin
    show y ∈ quotient.mk _,
    rw [quotient.out_eq, ← finset.mem_def, mem_roots (mt (map_eq_zero (algebra_map L)).1
      (ne_zero_of_monic hg.1)), is_root.def, eval_map, ← aeval_def, hg.2],
  end,
(list.index_of_inj hx (by rwa hfg)).1 hfg'

lemma injective_eq {α : Sort*} : injective (eq : α → α → Prop) :=
λ _ _ h, h.symm ▸ rfl

def algebraic_embedding_big_type {L : Type*} [discrete_field L] [algebra K L]
  (h : ∀ l : L, is_integral K l) : L ↪ big_type K :=
⟨_, injective_comp injective_eq $ algebraic_embedding_aux_injective h⟩

def algebraic_embedding {L : Type*} [discrete_field L] [algebra K L]
  (h : ∀ l : L, is_integral K l) : L ↪ ℕ × polynomial K :=
⟨_, algebraic_embedding_aux_injective h⟩

def bembedding (K : Type u) [discrete_field K] : K ↪ big_type K :=
⟨λ a, show set _, from {(0, X - C a)}, λ a b, by simp [C_inj]⟩

instance : discrete_field (set.range (bembedding K)) :=
equiv.discrete_field (equiv.set.range _ (bembedding K).2).symm

structure extension (K : Type u) [discrete_field K] : Type u :=
(carrier : set (big_type K))
[field : discrete_field ↥carrier]
[algebra : algebra K ↥carrier]
--(algebraic : ∀ x : carrier, is_integral K x)

local attribute [instance] extension.field extension.algebra

def base_extension (K : Type u) [discrete_field K] : extension K :=
{ carrier := set.range (bembedding K),
  algebra := algebra.of_ring_hom (equiv.set.range _ (bembedding K).2).symm.symm
    (equiv.is_ring_hom.symm _) }

-- instance : preorder (extension K) :=
-- { le := λ L M, ∃ hLM : L.carrier ⊆ M.carrier, is_ring_hom (inclusion hLM)
--     ∧ ∀ x : K, inclusion hLM (algebra_map L.carrier x) = algebra_map M.carrier x,
--   le_refl := λ _, ⟨set.subset.refl _, by convert is_ring_hom.id; ext; simp, by simp⟩,
--   le_trans := λ L M N ⟨hLM₁, hLM₂, hLM₃⟩ ⟨hMN₁, hMN₂, hMN₃⟩, ⟨set.subset.trans hLM₁ hMN₁,
--     by resetI; convert is_ring_hom.comp (inclusion hLM₁) (inclusion hMN₁),
--     λ _, by rw [← hMN₃, ← hLM₃, inclusion_inclusion]⟩ }

instance : preorder (extension K) :=
{ le := λ L M, ∃ hLM : L.carrier ⊆ M.carrier, is_ring_hom (inclusion hLM),
  le_refl := λ _, ⟨set.subset.refl _, by convert is_ring_hom.id; ext; simp⟩,
  le_trans := λ L M N ⟨hLM₁, hLM₂⟩ ⟨hMN₁, hMN₂⟩, ⟨set.subset.trans hLM₁ hMN₁,
    by resetI; convert is_ring_hom.comp (inclusion hLM₁) (inclusion hMN₁)⟩ }

-- def hom_of_le {L M : extension K} (h : L ≤ M) : L.carrier →ₐ[K] M.carrier :=
-- { to_fun := inclusion (classical.some h),
--   hom := (classical.some_spec h).1,
--   commutes' := (classical.some_spec h).2 }

private structure chain' (c : set (extension K)) : Prop :=
(chain : chain (≤) c)

local attribute [class] chain'

lemma is_chain (c : set (extension K)) [chain' c]: chain (≤) c :=
chain'.chain (by apply_instance)

section chain

variables (c : set (extension K)) [hcn : nonempty c]
include c  hcn

variable [hcn' : chain' c]
include hcn'

instance chain_directed_order : directed_preorder c :=
⟨λ ⟨i, hi⟩ ⟨j, hj⟩, let ⟨k, hkc, hk⟩ := chain.directed_on
  (is_chain c) i hi j hj in ⟨⟨k, hkc⟩, hk⟩⟩

def chain_map (i j : c) (hij : i ≤ j) : i.1.carrier → j.1.carrier :=
inclusion (exists.elim hij (λ h _, h))

instance chain_field_hom (i j : c) (hij : i ≤ j) : is_field_hom (chain_map c i j hij) :=
exists.elim hij (λ _, id)

instance chain_directed_system : directed_system (λ i : c, i.1.carrier) (chain_map c) :=
by split; intros; simp [chain_map]

def chain_limit : Type u := ring.direct_limit (λ i : c, i.1.carrier) (chain_map c)

lemma of_eq_of (x : big_type K) (i j : c) (hi : x ∈ i.1.carrier) (hj : x ∈ j.1.carrier) :
  ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map c) i ⟨x, hi⟩ =
  ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map c) j ⟨x, hj⟩ :=
have hij : i ≤ j ∨ j ≤ i,
  from show i.1 ≤ j.1 ∨ j.1 ≤ i.1, from chain.total (is_chain c) i.2 j.2,
hij.elim
  (λ hij, begin
    rw ← @ring.direct_limit.of_f c _ _ _ (λ i : c, i.1.carrier) _ _ (chain_map c) _
      _ _ _ hij,
    simp [chain_map, inclusion]
  end)
  (λ hij, begin
    rw ← @ring.direct_limit.of_f c _ _ _ (λ i : c, i.1.carrier) _ _ (chain_map c) _
      _ _ _ hij,
    simp [chain_map, inclusion]
  end)

lemma injective_aux (i j : c)
  (x y : ⋃ i : c, i.1.carrier) (hx : x.1 ∈ i.1.carrier) (hy : y.1 ∈ j.1.carrier) :
  ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map c) i ⟨x, hx⟩ =
  ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map c) j ⟨y, hy⟩ →
  x = y :=
have hij : i ≤ j ∨ j ≤ i,
  from show i.1 ≤ j.1 ∨ j.1 ≤ i.1, from chain.total (is_chain c) i.2 j.2,
have hinj : ∀ (i j : c) (hij : i ≤ j), injective (chain_map c i j hij),
  from λ _ _ _, is_field_hom.injective _,
hij.elim
  (λ hij h, begin
    rw ← @ring.direct_limit.of_f c _ _ _ (λ i : c, i.1.carrier) _ _ (chain_map c) _
      _ _ _ hij at h,
    simpa [chain_map, inclusion, subtype.coe_ext.symm] using ring.direct_limit.of_inj hinj j h,
  end)
  (λ hji h, begin
    rw ← @ring.direct_limit.of_f c _ _ _ (λ i : c, i.1.carrier) _ _ (chain_map c) _
      _ _ _ hji at h,
    simpa [chain_map, inclusion, subtype.coe_ext.symm] using ring.direct_limit.of_inj hinj i h,
  end)

def equiv_direct_limit : (⋃ (i : c), i.1.carrier) ≃
  ring.direct_limit (λ i : c, i.1.carrier) (chain_map c) :=
@equiv.of_bijective (⋃ i : c, i.1.carrier)
  (ring.direct_limit (λ i : c, i.1.carrier) (chain_map c))
  (λ x, ring.direct_limit.of _ _ (classical.some (set.mem_Union.1 x.2))
    ⟨_, classical.some_spec (set.mem_Union.1 x.2)⟩)
  ⟨λ x y, injective_aux _ _ _ _ _ _ _,
    λ x, let ⟨i, ⟨y, hy⟩, hy'⟩ := ring.direct_limit.exists_of x in
      ⟨⟨y, _, ⟨i, rfl⟩, hy⟩, begin
        convert hy',
        exact of_eq_of _ _ _ _ _ _
      end⟩⟩

instance Union_field : discrete_field (⋃ i : c, i.1.carrier) :=
@equiv.discrete_field _ _ (equiv_direct_limit c)
  (field.direct_limit.discrete_field _ _)

instance is_field_hom_Union (i : c) : is_field_hom
  (inclusion (set.subset_Union (λ i : c, i.1.carrier) i)) :=
suffices inclusion (set.subset_Union (λ i : c, i.1.carrier) i) =
    ((equiv_direct_limit c).symm ∘
    ring.direct_limit.of (λ i : c, i.1.carrier) (chain_map c) i),
  by rw this; exact is_ring_hom.comp _ _,
funext $ λ ⟨_, _⟩,
  (equiv_direct_limit c).injective $
    by rw [function.comp_app, equiv.apply_symm_apply];
      exact of_eq_of _ _ _ _ _ _

-- instance is_field_hom_range_Union [hc : nonempty c]
--   (h : set.range (bembedding K) ⊆ ⋃ i : c, i.1.carrier) :
--   is_field_hom (inclusion h) :=
-- let ⟨i⟩ := hc in
-- have h₁ : i.1.carrier ⊆ ⋃ i : c, i.1.carrier, from set.subset_Union _ i,
-- have h₂ : set.range (bembedding K) ⊆ i.1.carrier, from i.1.range_subset,
-- have inclusion h = inclusion h₁ ∘ inclusion h₂, by simp [function.comp],
-- by rw this; exact is_ring_hom.comp _ _

-- def chain_lift [nonempty c] (α : Type u) [discrete_field α] (i : set.range (bembedding K) → α)
--   [is_field_hom i] [is_algebraically_closed α] :
--   (⋃ i : c, i.1.carrier) → α :=
-- (ring.direct_limit.lift (λ j : c, j.1.carrier) (chain_map _ c) _
--   (λ j : c, j.1.lift i) (λ i j ⟨_, _, h⟩, by introsI; rw [h, chain_map])) ∘
--   (equiv_direct_limit K c)

-- def is_field_hom_chain_lift [nonempty c] (α : Type u) [discrete_field α]
--   (i : set.range (bembedding K) → α) [is_field_hom i]
--   [is_algebraically_closed α] : is_field_hom (chain_lift K c α i) :=
-- is_ring_hom.comp _ _

end chain

--def maximal_extension (c : set (extension K)) (hc : chain (≤) c) : extension K :=

def maximal_extension (c : set (extension K)) (hc : chain (≤) c) :
  { ub : extension K // ∀ L, L ∈ c → L ≤ ub } :=
if h : nonempty c
  then by letI : chain' c := ⟨hc⟩; exact
    ⟨{ carrier := ⋃ (i : c), i.1.carrier,
        /- The union is isomorphic to the direct limit. Suffices to prove the direct limit
          is an algebraic extension -/
        -- algebraic := sorry,
        algebra := sorry },
    λ e he, ⟨by convert subset_Union _ (⟨e, he⟩ : c); refl,
      is_field_hom_Union c ⟨e, he⟩⟩⟩
  else ⟨base_extension K, λ a ha, (h ⟨⟨a, ha⟩⟩).elim⟩

set_option old_structure_cmd true

structure algebraic_extension (K : Type u) [discrete_field K] extends extension K :=
(algebraic : ∀ x : carrier, is_integral K x)

open algebraic_extension

instance : preorder (algebraic_extension K) :=
preorder.lift algebraic_extension.to_extension (by apply_instance)

def maximal_algebraic_extension (c : set (algebraic_extension K)) (hc : chain (≤) c) :
  { ub : algebraic_extension K // ∀ L, L ∈ c → L ≤ ub } :=
let M := (maximal_extension (to_extension '' c) (chain.image (≤) _ _ (λ _ _, id) hc)) in
⟨{ algebraic := sorry, -- Field is isomorphic to direct limit of some algebraic extensions
    ..M.1 },
  λ L hL, M.2 _ (mem_image_of_mem _ hL)⟩

lemma exists_algebraic_closure (K : Type u) [discrete_field K] :
  ∃ m : algebraic_extension K, ∀ a, m ≤ a → a ≤ m :=
zorn (λ c hc, (maximal_algebraic_extension c hc).exists_of_subtype) (λ _ _ _, le_trans)

def closed_extension (K : Type u) [discrete_field K] :=
classical.some (exists_algebraic_closure K)

def algebraic_closure (K : Type u) [discrete_field K] : Type u :=
((classical.some (exists_algebraic_closure K))).carrier

end classical

namespace algebraic_closure

instance : discrete_field (algebraic_closure K) :=
{ has_decidable_eq := classical.dec_eq _,
  ..(classical.some (exists_algebraic_closure K)).field }

instance : algebra K (algebraic_closure K) :=
(classical.some (exists_algebraic_closure K)).algebra

def of : K → algebraic_closure K := algebra_map _

instance : is_ring_hom (@of K _) := by dunfold of; apply_instance

protected lemma is_integral (x : algebraic_closure K) : is_integral K x :=
(classical.some (exists_algebraic_closure K)).algebraic x

section lift
/- In this section, the homomorphism from any algebraic extension into an algebraic
  closure is proven to exist. -/
variables {L : Type v} {M : Type w} [discrete_field L] [algebra K L]
  [discrete_field M] [algebra K M] [is_algebraically_closed M] (hL : ∀ x : L, is_integral K x)

/-- This structure is used to prove the existence of a homomorphism from any algebraic extension
  into an algebraic closure -/
structure subfield_and_hom (K : Type u) (L : Type v) (M : Type w)
  [discrete_field K] [discrete_field L] [algebra K L] (hL : ∀ x : L, is_integral K x)
  [discrete_field M] [algebra K M] [is_algebraically_closed M] extends extension K :=
( to_algebraically_closed : carrier →ₐ[K] M )
( to_field : carrier → L )
( is_ring_hom_to_field : is_ring_hom to_field )

open subfield_and_hom

instance : preorder (subfield_and_hom K L M hL) :=
preorder.lift to_extension (by apply_instance)

def maximal_subfield_and_hom (c : set (subfield_and_hom K L M hL)) (hc : chain (≤) c) :
  { ub : subfield_and_hom K L M hL // ∀ N, N ∈ c → N ≤ ub } :=
let ub := (maximal_extension (to_extension '' c) (chain.image (≤) _ _ (λ _ _, id) hc)) in
⟨{ to_algebraically_closed := sorry, --field in question is direct limit of a bunch of fields with
      --algebra homs into M
    to_field := sorry, -- direct limit of a bunch of subfields is also a subfield
    is_ring_hom_to_field := sorry,
    ..ub.1 },
   λ n hN, ub.2 _ (mem_image_of_mem _ hN)⟩

end lift

section adjoin_root
variables {L : Type v} [discrete_field L] [algebra K L] (hL : ∀ x : L, is_integral K x)
  (f : polynomial L) [hif : irreducible f]
include hif

instance adjoin_root_algebraic_closure.field :
  discrete_field (adjoin_root f) := by apply_instance

instance adjoin_root_algebraic_closure.is_ring_hom :
  is_ring_hom (@adjoin_root.of _ _ _ f) := by apply_instance

def adjoin_root.of_embedding : L ↪ adjoin_root f :=
⟨adjoin_root.of, is_field_hom.injective _⟩

/-- TODO: move -/
instance adjoin_root.algebra : algebra K (adjoin_root f) :=
algebra.of_ring_hom (adjoin_root.of ∘ algebra_map _) (is_ring_hom.comp _ _)

def adjoin_root_extension_map : adjoin_root f ↪ big_type K :=
map (adjoin_root.of_embedding f) (algebraic_embedding_big_type hL)
  (λ i, let e : big_type K ↪ ℕ × polynomial K := i.trans
      (algebraic_embedding sorry) in --adjoining a root to an algebraic extension gives an algebraic extension
    cantor_injective e.1 e.2)

instance afhk : discrete_field (set.range (@adjoin_root_extension_map K _ _ _ _ hL f _)) :=
equiv.discrete_field (equiv.set.range _ (embedding.inj _)).symm

def adjoin_root_extension : extension K :=
{ carrier := set.range (@adjoin_root_extension_map K _ _ _ _ hL f _),
  algebra := algebra.of_ring_hom
    ((equiv.set.range _ (embedding.inj' (adjoin_root_extension_map hL f))).symm.symm ∘
      algebra_map _) (is_ring_hom.comp _ _) }

-- instance algebraic_closure_adjoin_root_comp.is_ring_hom :
--   is_ring_hom (@adjoin_root.of _ _ _ f ∘ of K) := is_ring_hom.comp _ _

-- lemma adjoin_root_extension_map_apply (x : algebraic_closure K) :
--   (adjoin_root_extension_map K f) (@adjoin_root.of _ _ _ f x) = x.val :=
-- map_commutes _ _ _ _

-- lemma closure_subset_adjoin_root :
--   (closed_extension K).carrier ⊆ set.range (adjoin_root_extension_map K f) :=
-- (λ x h, ⟨adjoin_root.of_embedding K f ⟨x, h⟩,
--   show (adjoin_root_extension_map K f)
--       (adjoin_root.of_embedding K f ⟨x, h⟩) =
--       (⟨x, h⟩ : algebraic_closure K).val,
--     from map_commutes _ _ _ _⟩)

-- lemma adjoin_root_range_subset :
--   (set.range (bembedding K)) ⊆ set.range (adjoin_root_extension_map K f) :=
-- set.subset.trans
--   (classical.some (exists_algebraic_closure K)).range_subset
--   (closure_subset_adjoin_root K f)

-- lemma adjoin_root_inclusion_eq :
--   inclusion (adjoin_root_range_subset K f) =
--   (equiv.set.range _ (adjoin_root_extension_map K f).2) ∘
--   (@adjoin_root.of (algebraic_closure K) _ _ f) ∘
--   inclusion (classical.some (exists_algebraic_closure K)).range_subset :=
-- funext $ λ x, subtype.eq $
--   by simp [inclusion, function.comp, adjoin_root_extension_map_apply]

-- lemma adjoin_root_inclusion_eq' :
--   inclusion (closure_subset_adjoin_root K f) =
--   (equiv.set.range _ (adjoin_root_extension_map K f).2) ∘
--   (@adjoin_root.of (algebraic_closure K) _ _ f) :=
-- funext $ λ x, subtype.eq $
--   by simp [inclusion, function.comp, adjoin_root_extension_map_apply]; refl

-- instance adjoin_root_range.discrete_field :
--   discrete_field (set.range (adjoin_root_extension_map K f)) :=
-- equiv.discrete_field (equiv.set.range _ (embedding.inj _)).symm

-- instance adjoin_root_inclusion.is_ring_hom :
--   is_ring_hom (inclusion (adjoin_root_range_subset K f)) :=
-- begin
--   letI := (classical.some (exists_algebraic_closure K)).is_field_hom,
--   rw [adjoin_root_inclusion_eq, ← equiv.symm_symm (equiv.set.range _ _)],
--   exact @is_ring_hom.comp _ _ _ _ _ (is_ring_hom.comp _ _) _ _ _
--     (equiv.is_ring_hom.symm _)
-- end
-- --set_option eqn_compiler.zeta true

-- def adjoin_root_lift {α : Type u} [_inst_2_1 : discrete_field α] (i : (range ⇑(bembedding K)) → α)
--   [is_field_hom i] [is_algebraically_closed α] :
--   (range ⇑(adjoin_root_extension_map K f)) → α :=
-- begin
--   have h : _ := is_algebraically_closed.exists_root
--     (f.map (lift_aux K i))
--     (by rw degree_map; exact degree_pos_of_ne_zero_of_nonunit
--       (ne_zero_of_irreducible hif) hif.1),
--   exact adjoin_root.lift (lift_aux K i) (classical.some h) (by rw [← eval_map];
--     exact (classical.some_spec h)) ∘
--   (equiv.set.range _ (adjoin_root_extension_map K f).2).symm
-- end

-- lemma adjoin_root_lift.is_ring_hom {α : Type u} [_inst_2_1 : discrete_field α]
--   (i : (range ⇑(bembedding K)) → α) [is_field_hom i] [is_algebraically_closed α] :
--   is_field_hom (adjoin_root_lift _ f i) :=
-- begin
--   letI := equiv.is_ring_hom.symm (equiv.set.range _ (adjoin_root_extension_map K f).2),
--   dsimp [adjoin_root_lift],
--   rw [← equiv.symm_symm (equiv.set.range _ _)],
--   exact is_ring_hom.comp _ _
-- end

instance adjoin_root_extension.field : discrete_field (adjoin_root_extension K f).carrier :=
extension.field _

local attribute [instance] extension.field extension.is_field_hom extension.lift_is_field_hom

lemma closed_extension_le_adjoin_root_extension :
  closed_extension K ≤ adjoin_root_extension K f :=
by letI : discrete_field (closed_extension K).carrier := extension.field _; exact
⟨closure_subset_adjoin_root K f, by rw [adjoin_root_inclusion_eq'];
  exact is_ring_hom.comp _ _, begin
  introsI,

end⟩

instance : is_algebraically_closed (algebraic_closure K) :=
⟨λ f hf0, let ⟨g, hg⟩ := is_noetherian_ring.exists_irreducible_factor
    (show ¬ is_unit f, from λ h, by rw [is_unit_iff_degree_eq_zero] at h;
      rw h at hf0; exact lt_irrefl _ hf0)
    (λ h, by rw [← degree_eq_bot] at h;
      rw h at hf0; exact absurd hf0 dec_trivial) in
  begin
    letI := hg.1,
    have := classical.some_spec (exists_algebraic_closure K)
      (adjoin_root_extension K g),

  end⟩

end adjoin_root

end algebraic_closure


import .size
open nnf list

namespace list
universes u v w

variables {α : Type u} {β : Type v} {γ : Type w}

theorem mapp {p : β → Prop} (f : α → β) : Π (l : list α) (h : ∀ x∈l, p (f x)) x, x ∈ list.map f l → p x
| [] h x := by simp
| (hd::tl) h x :=
begin
  intro hmem, cases hmem,
  {rw hmem, apply h, simp},
  {apply mapp tl, intros a ha, apply h, simp [ha], exact hmem}
end

@[simp] def ne_empty_head : Π l : list α, l ≠ [] → α
| []       h := by contradiction
| (a :: l) h := a

end list

@[simp] def unbox : list nnf → list nnf
| [] := []
| ((box φ) :: l) := φ :: unbox l
| (e :: l) := unbox l

theorem unbox_iff : Π {Γ φ}, box φ ∈ Γ ↔ φ ∈ unbox Γ
| [] φ := begin split, repeat {intro h, simpa using h} end
| (hd::tl) φ :=
begin
  split,
  { intro h, cases h₁ : hd,
    case nnf.box : ψ
    { dsimp [unbox], cases h,
       {left, rw h₁ at h, injection h},
       {right, exact (@unbox_iff tl φ).1 h} },
    all_goals
    { dsimp [unbox], cases h,
       {rw h₁ at h, contradiction},
       {exact (@unbox_iff tl φ).1 h} } },
  { intro h, cases h₁ : hd,
    case nnf.box : ψ
    { rw h₁ at h, dsimp [unbox] at h, cases h,
       {simp [h]}, {right, exact (@unbox_iff tl φ).2 h} },
    all_goals
    { rw h₁ at h, dsimp [unbox] at h, right, exact (@unbox_iff tl φ).2 h } }
end

theorem unbox_size_aux : Π {Γ}, node_size (unbox Γ) ≤ node_size Γ
| [] := by simp
| (hd::tl) :=
begin
  cases h : hd,
  case nnf.box : ψ
  { dsimp, apply add_le_add,
     { dsimp [sizeof, has_sizeof.sizeof, nnf.sizeof],
       rw add_comm, apply nat.le_succ },
     { apply unbox_size_aux } },
  all_goals
  { dsimp, apply le_add_of_nonneg_of_le,
    { dsimp [sizeof, has_sizeof.sizeof, nnf.sizeof], rw add_comm, apply nat.zero_le },
    { apply unbox_size_aux } }
end

theorem le_of_unbox_degree : Π {Γ}, modal_degree (unbox Γ) ≤ modal_degree Γ
| [] := by simp
| (hd::tl) :=
begin
  cases heq : hd,
  case nnf.box : ψ
  {dsimp, rw cons_degree, rw cons_degree,
  apply max_le_max, { simp }, { apply le_of_unbox_degree } },
  all_goals
  {dsimp, rw cons_degree, apply le_max_right_of_le, apply le_of_unbox_degree}
end

theorem zero_degree_of_eq_unbox : Π {Γ}, modal_degree (unbox Γ) = modal_degree Γ → modal_degree Γ = 0
| [] h := begin dsimp [maximum, modal_degree], refl end
| (hd::tl) h :=
begin
  cases heq : hd,
  case nnf.box : ψ
  {rw heq at h, dsimp at h, rw cons_degree at h, rw cons_degree at h,
  have := @le_of_unbox_degree tl,
  cases (lt_or_eq_of_le this) with h₁ h₂,
  {have hne : max (count_modal ψ) (modal_degree (unbox tl)) ≠ max (count_modal (box ψ)) (modal_degree tl),
    { apply ne_of_lt, apply max_lt_max, {simp}, {exact h₁} },
  contradiction },
  {rw [h₂, zero_degree_of_eq_unbox h₂] at h,
  have : max (count_modal ψ) 0 < max (count_modal (box ψ)) 0,
    {simp [_root_.max], by_cases hz : count_modal ψ = 0,
     repeat {simp [hz]} },
  have hne := ne_of_lt this, contradiction } },
  case nnf.dia : ψ
  {rw heq at h, dsimp at h, rw cons_degree at h,
  have := @le_of_unbox_degree tl,
  cases (lt_or_eq_of_le this) with h₁ h₂,
  {have hne : modal_degree (unbox tl) ≠ max (count_modal (box ψ)) (modal_degree tl),
    { apply ne_of_lt, rw lt_max_iff,  right, exact h₁},
  contradiction },
  {have : modal_degree (unbox tl) < max (count_modal (dia ψ)) (modal_degree tl),
    {rw [h₂, zero_degree_of_eq_unbox h₂],
     simp [_root_.max] },
  have hne := ne_of_lt this, contradiction } },
  case nnf.var : ψ
  {rw heq at h, dsimp at h, rw cons_degree at h,
   have hle : 0 ≤ modal_degree tl, { simp },
   have hz : modal_degree tl = 0, {apply zero_degree_of_eq_unbox, dsimp [_root_.max] at h, rw h, apply if_pos hle },
   rw cons_degree, simp [_root_.max, hz] },
  case nnf.neg : ψ
  {rw heq at h, dsimp at h, rw cons_degree at h,
   have hle : 0 ≤ modal_degree tl, { simp },
   have hz : modal_degree tl = 0, {apply zero_degree_of_eq_unbox, dsimp [_root_.max] at h, rw h, apply if_pos hle },
   rw cons_degree, simp [_root_.max, hz] },
  case nnf.and : ψ₁ ψ₂
  {rw heq at h, dsimp at h, rw cons_degree at h,
   by_cases hc : count_modal (and ψ₁ ψ₂) = 0,
   {rw hc at h,
    have hle : 0 ≤ modal_degree tl, { simp },
    have hz : modal_degree tl = 0, {apply zero_degree_of_eq_unbox, dsimp [_root_.max] at h, rw h, apply if_pos hle },
    rw cons_degree, simp [_root_.max, hc, hz] }, -- eq case end
   {have := @le_of_unbox_degree tl,
    cases (lt_or_eq_of_le this) with h₁ h₂,
    {have hne : modal_degree (unbox tl) ≠ max (count_modal (and ψ₁ ψ₂)) (modal_degree tl),
    { apply ne_of_lt, rw lt_max_iff, right, exact h₁},
  contradiction },
    {have : modal_degree (unbox tl) < max (count_modal (and ψ₁ ψ₂)) (modal_degree tl),
     {rw [h₂, zero_degree_of_eq_unbox h₂],
      rw lt_max_iff, left, exact nat.pos_of_ne_zero hc},
     have hne := ne_of_lt this, contradiction} } }, -- lt case end
  case nnf.or : ψ₁ ψ₂
  {rw heq at h, dsimp at h, rw cons_degree at h,
   by_cases hc : count_modal (or ψ₁ ψ₂) = 0,
   {rw hc at h,
    have hle : 0 ≤ modal_degree tl, { simp },
    have hz : modal_degree tl = 0, {apply zero_degree_of_eq_unbox, dsimp [_root_.max] at h, rw h, apply if_pos hle },
    rw cons_degree, simp [_root_.max, hc, hz] },
   {have := @le_of_unbox_degree tl,
    cases (lt_or_eq_of_le this) with h₁ h₂,
    {have hne : modal_degree (unbox tl) ≠ max (count_modal (and ψ₁ ψ₂)) (modal_degree tl),
    { apply ne_of_lt, rw lt_max_iff, right, exact h₁},
  contradiction },
    {have : modal_degree (unbox tl) < max (count_modal (and ψ₁ ψ₂)) (modal_degree tl),
     {rw [h₂, zero_degree_of_eq_unbox h₂],
      rw lt_max_iff, left, exact nat.pos_of_ne_zero hc},
     have hne := ne_of_lt this, contradiction} } }
end

theorem unbox_degree_aux : Π {Γ φ}, dia φ ∈ Γ → modal_degree (unbox Γ) < modal_degree Γ
| [] φ h := absurd h $ not_mem_nil _
| (hd::tl) φ h :=
begin
  cases heq : hd,
  case nnf.box : ψ
  {dsimp, rw cons_degree, rw cons_degree,
  apply max_lt_max,
  { simp },
  { apply unbox_degree_aux, swap, exact φ,
    cases h, {rw heq at h, contradiction}, {exact h} } },
  case nnf.dia : ψ
  {dsimp [-modal_degree], rw cons_degree,
  have := @le_of_unbox_degree tl,
  cases (lt_or_eq_of_le this) with h₁ h₂,
  {rw lt_max_iff, right, exact h₁},
  {rw [h₂, zero_degree_of_eq_unbox h₂], simp [_root_.max]} },
  all_goals
  {dsimp [-modal_degree], rw cons_degree,
  rw lt_max_iff, right,
  apply unbox_degree_aux, swap, exact φ,
  cases h, { rw heq at h, contradiction}, {exact h} }
end

theorem unbox_degree : Π {Γ φ}, dia φ ∈ Γ →
                     modal_degree (φ :: unbox Γ) < modal_degree Γ
| [] φ h := absurd h $ not_mem_nil _
| (hd::tl) φ h :=
begin
  rw cons_degree, apply max_lt,
  {apply lt_of_lt_of_le, swap 3, exact count_modal (dia φ), simp, apply le_of_mem_degree, exact h},
  {apply unbox_degree_aux, exact h}
end

@[simp] def rebox : list nnf → list nnf
| [] := []
| (hd::tl) := box hd :: rebox tl

theorem rebox_unbox_of_mem : Π {Γ} (h : ∀ {φ}, φ ∈ unbox Γ → box φ ∈ Γ), rebox (unbox Γ) ⊆ Γ
| [] h := by simp
| (hd::tl) h :=
begin
  cases hψ : hd,
  case nnf.box : φ {dsimp, simp [cons_subset_cons], apply subset_cons_of_subset, apply rebox_unbox_of_mem, simp [unbox_iff]},
  all_goals {dsimp, apply subset_cons_of_subset, apply rebox_unbox_of_mem, simp [unbox_iff]}
end

theorem unbox_rebox : Π {Γ}, unbox (rebox Γ) = Γ
| [] := by simp
| (hd::tl) := by simp [unbox_rebox]

-- Just that I don't want to say ∃ φ s.t. ...
def box_only_rebox : Π {Γ}, box_only (rebox Γ)
| [] := {no_var := by simp,
         no_neg := by simp,
         no_and := by simp,
         no_or  := by simp,
         no_dia := by simp}
| (hd::tl) :=
begin
  cases h : hd,
  all_goals {
  exact { no_var := begin
                      intros n h, cases h, contradiction,
                      apply (@box_only_rebox tl).no_var, assumption
                    end,
          no_neg := begin
                      intros n h, cases h, contradiction,
                      apply (@box_only_rebox tl).no_neg, assumption
                    end,
          no_and := begin
                      intros φ ψ h, cases h, contradiction,
                      apply (@box_only_rebox tl).no_and, assumption
                    end,
          no_or := begin
                     intros φ ψ h, cases h, contradiction,
                     apply (@box_only_rebox tl).no_or, assumption
                   end,
          no_dia := begin
                      intros φ h, cases h, contradiction,
                      apply (@box_only_rebox tl).no_dia, assumption
                    end} }
end

theorem rebox_iff : Π {φ Γ}, box φ ∈ rebox Γ ↔ φ ∈ Γ
| φ [] := by simp
| φ (hd::tl) :=
begin
  split,
  {intro h, cases h₁ : hd,
   all_goals { cases h,
               {left, rw ←h₁, injection h},
               {right,  have := (@rebox_iff φ tl).1, exact this h } }},
  {intro h, cases h₁ : hd,
   all_goals { dsimp, cases h,
               {left, rw ←h₁, rw h},
               {right, have := (@rebox_iff φ tl).2, exact this h } } }
end

@[simp] def undia : list nnf → list nnf
| [] := []
| ((dia φ) :: l) := φ :: undia l
| (e :: l) := undia l

theorem undia_iff : Π {Γ φ}, dia φ ∈ Γ ↔ φ ∈ undia Γ
| [] φ := begin split, repeat {intro h, simpa using h} end
| (hd::tl) φ :=
begin
  split,
  { intro h, cases h₁ : hd,
    case nnf.dia : ψ
    { dsimp [undia], cases h,
       {left, rw h₁ at h, injection h},
       {right, exact (@undia_iff tl φ).1 h} },
    all_goals
    { dsimp [undia], cases h,
       {rw h₁ at h, contradiction},
       {exact (@undia_iff tl φ).1 h} } },
  { intro h, cases h₁ : hd,
    case nnf.dia : ψ
    { rw h₁ at h, dsimp [undia] at h, cases h,
       {simp [h]}, {right, exact (@undia_iff tl φ).2 h} },
    all_goals
    { rw h₁ at h, dsimp [undia] at h, right, exact (@undia_iff tl φ).2 h } }
end

theorem undia_degree : Π {Γ φ}, φ ∈ undia Γ →
                     modal_degree (φ :: unbox Γ) < modal_degree Γ
:=
begin
  intros Γ φ h,
  rw ←undia_iff at h,
  apply unbox_degree h
end

def get_contra : Π Γ : list nnf,
                 psum {p : nat // var p ∈ Γ ∧ neg p ∈ Γ}
                      (∀ n, var n ∈ Γ → neg n ∉ Γ)
| []             := psum.inr $ λ _ h, absurd h $ not_mem_nil _
| (hd :: tl)     :=
begin
  cases h : hd,
  case nnf.var : n
  {apply dite (neg n ∈ tl),
    {intro t,
     exact psum.inl ⟨n, ⟨mem_cons_self _ _, mem_cons_of_mem _ t⟩⟩},
    {intro e,
     cases (get_contra tl),
     {left, constructor, constructor,
     apply mem_cons_of_mem, exact val.2.1,
     apply mem_cons_of_mem, exact val.2.2},
     {right,
      intros m hm hin,
      by_cases eq : m=n,
      {apply e, cases hin, contradiction, rw ←eq, assumption},
      {cases hm, apply eq, injection hm, apply val, exact hm,
       cases hin, contradiction, assumption} } }
  },
  case nnf.neg : n
  { apply dite (var n ∈ tl),
    { intro t,
      exact psum.inl ⟨n, ⟨mem_cons_of_mem _ t, mem_cons_self _ _⟩⟩ },
    { intro e,
      cases (get_contra tl),
      {left, constructor, constructor,
      apply mem_cons_of_mem, exact val.2.1,
      apply mem_cons_of_mem, exact val.2.2 },
      { right,
        intros m hm hin,
        by_cases eq : m=n,
        { apply e, cases hm, contradiction, rw ←eq, assumption },
        { cases hin, apply eq, injection hin, apply val,
          swap, exact hin, cases hm, contradiction, assumption }
      }
    }
  },
  all_goals
  {
  cases (get_contra tl),
  { left, constructor, constructor,
    apply mem_cons_of_mem, exact val.2.1,
    apply mem_cons_of_mem, exact val.2.2  },
  { right,
    intros m hm hin,
    {apply val, swap 3, exact m,
    cases hm, contradiction, assumption,
    cases hin, contradiction, assumption} }
  }
end

def get_contra_seqt : Π Γ : seqt,
                 psum {p : nat // var p ∈ Γ.main ∧ neg p ∈ Γ.main}
                      (∀ n, var n ∈ Γ.main → neg n ∉ Γ.main)
:= λ Γ, get_contra Γ.main

def get_and : Π Γ : list nnf,
              psum {p : nnf × nnf // and p.1 p.2 ∈ Γ}
                   (∀ φ ψ, nnf.and φ ψ ∉ Γ)
| []               := psum.inr $ λ _ _, not_mem_nil _
| (hd :: tl)       :=
begin
  cases h : hd,
  case nnf.and : φ ψ { left, constructor,swap,
                       constructor, exact φ, exact ψ, simp
                     },
  all_goals
  { cases (get_and tl),
    {left,
    constructor,
    apply mem_cons_of_mem,
    exact val.2},
    {right, intros γ ψ h,
     cases h, contradiction,
    apply val, assumption }
  }
end

def get_and_seqt : Π Γ : seqt,
              psum {p : nnf × nnf // and p.1 p.2 ∈ Γ.main}
                   (∀ φ ψ, nnf.and φ ψ ∉ Γ.main)
:= λ Γ, get_and Γ.main

def get_or : Π Γ : list nnf,
              psum {p : nnf × nnf // or p.1 p.2 ∈ Γ}
                   (∀ φ ψ, nnf.or φ ψ ∉ Γ)
| []               := psum.inr $ λ _ _, not_mem_nil _
| (hd :: tl)       :=
begin
  cases h : hd,
  case nnf.or : φ ψ { left, constructor,swap,
                       constructor, exact φ, exact ψ, simp },
  all_goals
  { cases (get_or tl),
    {left,
    constructor,
    apply mem_cons_of_mem,
    exact val.2},
    {right, intros γ ψ h,
     cases h, contradiction,
    apply val, assumption}
  }
end

def get_or_seqt : Π Γ : seqt,
              psum {p : nnf × nnf // or p.1 p.2 ∈ Γ.main}
                   (∀ φ ψ, nnf.or φ ψ ∉ Γ.main)
:= λ Γ, get_or Γ.main

def get_dia : Π Γ : list nnf,
              psum {p : nnf // dia p ∈ Γ}
                   (∀ φ, nnf.dia φ ∉ Γ)
| []               := psum.inr $ λ _, not_mem_nil _
| (hd :: tl)       :=
begin
  cases h : hd,
  case nnf.dia : φ { left, constructor, swap, exact φ, simp },
  all_goals
  { cases (get_dia tl),
    {left,
    constructor,
    apply mem_cons_of_mem,
    exact val.2},
    {right, intros γ h,
     cases h, contradiction,
     apply val, assumption } }
end

def get_dia_seqt : Π Γ : seqt,
              psum {p : nnf // dia p ∈ Γ.main}
                   (∀ φ, nnf.dia φ ∉ Γ.main)
:= λ Γ, get_dia Γ.main

def get_box : Π Γ : list nnf,
              psum {l : nnf // box l ∈ Γ}
                   (∀ φ, nnf.box φ ∉ Γ)
| [] := psum.inr $ λ _, not_mem_nil _
| (hd :: tl) :=
begin
  cases h : hd,
  case nnf.box : φ { left, constructor, swap, exact φ, simp },
  all_goals
  { cases (get_box tl),
    {left,
    constructor,
    apply mem_cons_of_mem,
    exact val.2},
    {right, intros γ h,
     cases h, contradiction,
     apply val, assumption } }
end

def get_box_seqt : Π Γ : seqt,
              psum {p : nnf // box p ∈ Γ.main}
                   (∀ φ, nnf.box φ ∉ Γ.main)
:= λ Γ, get_box Γ.main

@[simp] def get_var : list nnf → list ℕ
| [] := []
| ((var n) :: l) := n :: get_var l
| (e :: l) := get_var l

theorem get_var_iff : Π {Γ n}, var n ∈ Γ ↔ n ∈ get_var Γ
| [] φ := begin split, repeat {intro h, simpa using h} end
| (hd::tl) φ :=
begin
  split,
  { intro h, cases h₁ : hd,
    case nnf.var : n
    { dsimp, cases h,
       {left, rw h₁ at h, injection h},
       {right, exact (@get_var_iff tl φ).1 h} },
    all_goals
    { dsimp, cases h,
       {rw h₁ at h, contradiction},
       {exact (@get_var_iff tl φ).1 h} } },
  { intro h, cases h₁ : hd,
    case nnf.var : n
    { rw h₁ at h, dsimp at h, cases h,
       {simp [h]}, {right, exact (@get_var_iff tl φ).2 h} },
    all_goals
    { rw h₁ at h, dsimp [undia] at h, right, exact (@get_var_iff tl φ).2 h } }
end


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

/-!
# Connected category

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

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

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

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

universes v₁ v₂ u₁ u₂

noncomputable theory

open category_theory.category

namespace category_theory

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

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

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

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

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

attribute [instance, priority 100] is_connected.is_nonempty

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

instance nonempty_hom_of_connected_groupoid {G} [groupoid G] [is_connected G] (x y : G) :
  nonempty (x ⟶ y) :=
begin
  have h := is_connected_zigzag x y,
  induction h with z w _ h ih,
  { exact ⟨𝟙 x⟩ },
  { refine nonempty.map (λ f, f ≫ classical.choice _) ih,
    cases h,
    { assumption },
    { apply nonempty.map (λ f, inv f) h } }
end

end category_theory


import algebra.associated
import ring_theory.multiplicity

lemma multiplicity.eq_of_associated {α} [comm_monoid_with_zero α]
  [decidable_rel ((∣): α → α → Prop)]
  {a b c: α} (h: associated b c): multiplicity a b = multiplicity a c :=
begin
  have aux: ∀ a b c: α, associated b c → multiplicity a b ≤ multiplicity a c,
  { intros a b c h,
    rw multiplicity.multiplicity_le_multiplicity_iff,
    exact λ n, (associated.dvd_iff_dvd_right h).1, },
  exact le_antisymm (aux a b c h) (aux a c b h.symm),
end


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

/-!
# `ring`

Evaluate expressions in the language of commutative (semi)rings.
Based on <http://www.cs.ru.nl/~freek/courses/tt-2014/read/10.1.1.61.3041.pdf> .
-/

namespace tactic
namespace norm
namespace ring

/-- The normal form that `ring` uses is mediated by the function `horner a x n b := a * x ^ n + b`.
The reason we use a definition rather than the (more readable) expression on the right is because
this expression contains a number of typeclass arguments in different positions, while `horner`
contains only one `comm_semiring` instance at the top level. See also `horner_expr` for a
description of normal form. -/
def horner {α} [comm_semiring α] (a x : α) (n : ℕ) (b : α) := a * x ^ n + b

/-- This cache contains data required by the `ring` tactic during execution. -/
meta structure cache :=
(α : expr)
(univ : level)
(comm_semiring_inst : expr)
(red : transparency)
(ic : ref instance_cache)
(nc : ref instance_cache)
(atoms : ref (buffer expr))

/-- The monad that `ring` works in. This is a reader monad containing a mutable cache (using `ref`
for mutability), as well as the list of atoms-up-to-defeq encountered thus far, used for atom
sorting. -/
@[derive [monad, alternative]]
meta def ring_m (α : Type) : Type :=
reader_t cache tactic α

set_option old_structure_cmd true

meta class monad_ref (m : Type → Type) extends monad m :=
(read_ref : ∀ {α : Type}, ref α → m α)
(write_ref : ∀ {α : Type}, ref α → α → m unit)

meta class monad_tactic (m : Type → Type) extends monad m :=
(lift : ∀ {α : Type}, tactic α → m α)

meta instance monad_tactic.to_monad_ref (m : Type → Type) [h : monad_tactic m] : monad_ref m :=
monad_ref.mk
  (λ α r, monad_tactic.lift (read_ref r))
  (λ α r x, monad_tactic.lift (write_ref r x))

meta class monad_ring (m : Type → Type) extends monad_tactic m, alternative m :=
(get_cache : m cache)

/-- Get the `ring` data from the monad. -/
add_decl_doc monad_ring.get_cache

meta instance : monad_ring ring_m :=
⟨λ α, reader_t.lift,
 λ α, reader_t.lift $ failure,
 reader_t.read⟩

variables {m : Type → Type} [monad_ring m]

/-- Get an already encountered atom by its index. -/
meta def get_atom (n : ℕ) : m expr :=
do c ← monad_ring.get_cache, es ← monad_ref.read_ref c.atoms, pure (es.read' n)

/-- Get the index corresponding to an atomic expression, if it has already been encountered, or
put it in the list of atoms and return the new index, otherwise. -/
meta def add_atom (e : expr) : m ℕ :=
do
  c ← monad_ring.get_cache,
  let red := c.red,
  es ← monad_ref.read_ref c.atoms,
  es.iterate failure (λ n e' t, t <|> (monad_tactic.lift (is_def_eq e e' red) $> n.val)) <|>
    (es.size <$ monad_ref.write_ref c.atoms (es.push_back e))

/-- Run a `ring_m` tactic in the tactic monad. This version of `ring_m.run` uses an external
atoms ref, so that subexpressions can be named across multiple `ring_m` calls. -/
meta def ring_m.run' (red : transparency) (atoms : ref (buffer expr))
  (e : expr) {α} (m : ring_m α) : tactic α :=
do α ← infer_type e,
   u ← mk_meta_univ,
   infer_type α >>= unify (expr.sort (level.succ u)),
   u ← get_univ_assignment u,
   ic ← mk_instance_cache α,
   (ic, c) ← ic.get ``comm_semiring,
   nc ← mk_instance_cache `(ℕ),
   using_new_ref ic $ λ r,
   using_new_ref nc $ λ nr,
   reader_t.run m ⟨α, u, c, red, r, nr, atoms⟩

/-- Run a `ring_m` tactic in the tactic monad. -/
meta def ring_m.run (red : transparency) (e : expr) {α} (m : ring_m α) : tactic α :=
using_new_ref mk_buffer $ λ atoms, ring_m.run' red atoms e m

/-- Lift an instance cache tactic (probably from `norm_num`) to the `ring_m` monad. This version
is abstract over the instance cache in question (either the ring `α`, or `ℕ` for exponents). -/
@[inline] meta def ic_lift' (icf : cache → ref instance_cache) {α}
  (f : instance_cache → tactic (instance_cache × α)) : m α :=
do
  c ← monad_ring.get_cache,
  let r := icf c,
  ic ← monad_ref.read_ref r,
  (ic', a) ← monad_tactic.lift $ f ic,
  a <$ monad_ref.write_ref r ic'

/-- Lift an instance cache tactic (probably from `norm_num`) to the `ring_m` monad. This uses
the instance cache corresponding to the ring `α`. -/
@[inline] meta def ic_lift {α} : (instance_cache → tactic (instance_cache × α)) → m α :=
ic_lift' cache.ic

/-- Lift an instance cache tactic (probably from `norm_num`) to the `ring_m` monad. This uses
the instance cache corresponding to `ℕ`, which is used for computations in the exponent. -/
@[inline] meta def nc_lift {α} : (instance_cache → tactic (instance_cache × α)) → m α :=
ic_lift' cache.nc

/-- Apply a theorem that expects a `comm_semiring` instance. This is a special case of
`ic_lift mk_app`, but it comes up often because `horner` and all its theorems have this assumption;
it also does not require the tactic monad which improves access speed a bit. -/
meta def cache.cs_app (c : cache) (n : name) : list expr → expr :=
(@expr.const tt n [c.univ] c.α c.comm_semiring_inst).mk_app

/-- Every expression in the language of commutative semirings can be viewed as a sum of monomials,
where each monomial is a product of powers of atoms. We fix a global order on atoms (up to
definitional equality), and then separate the terms according to their smallest atom. So the top
level expression is `a * x^n + b` where `x` is the smallest atom and `n > 0` is a numeral, and
`n` is maximal (so `a` contains at least one monomial not containing an `x`), and `b` contains no
monomials with an `x` (hence all atoms in `b` are larger than `x`).

If there is no `x` satisfying these constraints, then the expression must be a numeral. Even though
we are working over rings, we allow rational constants when these can be interpreted in the ring,
so we can solve problems like `x / 3 = 1 / 3 * x` even though these are not technically in the
language of rings.

These constraints ensure that there is a unique normal form for each ring expression, and so the
algorithm is simply to calculate the normal form of each side and compare for equality.

To allow us to efficiently pattern match on normal forms, we maintain this inductive type that
holds a normalized expression together with its structure. All the `expr`s in this type could be
removed without loss of information, and conversely the `horner_expr` structure and the `ℕ` and
`ℚ` values can be recovered from the top level `expr`, but we keep both in order to keep proof
 producing normalization functions efficient. -/
meta inductive horner_expr (cf : Type) : Type
| const (e : expr) (coeff : cf) : horner_expr
| xadd (e : expr) (a : horner_expr) (x : expr × ℕ) (n : expr × ℕ) (b : horner_expr) : horner_expr

variables {cf : Type}

/-- Get the expression corresponding to a `horner_expr`. This can be calculated recursively from
the structure, but we cache the exprs in all subterms so that this function can be computed in
constant time. -/
meta def horner_expr.e : horner_expr cf → expr
| (horner_expr.const e _) := e
| (horner_expr.xadd e _ _ _ _) := e

/-- Is this expr the constant `0`? -/
meta def horner_expr.is_zero [has_zero cf] [decidable_eq cf] : horner_expr cf → bool
| (horner_expr.const _ c) := c = 0
| _ := ff

meta instance : has_coe (horner_expr cf) expr := ⟨horner_expr.e⟩
meta instance : has_coe_to_fun (horner_expr cf) (λ _, expr → expr) := ⟨λ e, ⇑(e : expr)⟩

/-- Construct a `xadd` node, generating the cached expr using the input cache. -/
meta def horner_expr.xadd' (c : cache) (a : horner_expr cf)
  (x : expr × ℕ) (n : expr × ℕ) (b : horner_expr cf) : horner_expr cf :=
horner_expr.xadd (c.cs_app ``horner [a, x.1, n.1, b]) a x n b

open horner_expr

/-- Pretty printer for `horner_expr`. -/
meta def horner_expr.to_string [has_to_string cf] : horner_expr cf → string
| (const e c) := to_string (e, c)
| (xadd e a x (_, n) b) :=
    "(" ++ a.to_string ++ ") * (" ++ to_string x.1 ++ ")^"
        ++ to_string n ++ " + " ++ b.to_string

/-- Pretty printer for `horner_expr`. -/
meta def horner_expr.pp [has_to_tactic_format cf] : horner_expr cf → tactic format
| (const e c) := pp (e, c)
| (xadd e a x (_, n) b) := do
  pa ← a.pp, pb ← b.pp, px ← pp x.1,
  return $ "(" ++ pa ++ ") * (" ++ px ++ ")^" ++ to_string n ++ " + " ++ pb

meta instance [has_to_tactic_format cf] : has_to_tactic_format (horner_expr cf) := ⟨horner_expr.pp⟩

/-- Reflexivity conversion for a `horner_expr`. -/
meta def horner_expr.refl_conv (e : horner_expr cf) : m (horner_expr cf × expr) :=
do p ← monad_tactic.lift $ mk_eq_refl e, return (e, p)

theorem zero_horner {α} [comm_semiring α] (x n b) :
  @horner α _ 0 x n b = b :=
by simp [horner]

theorem horner_horner {α} [comm_semiring α] (a₁ x n₁ n₂ b n')
  (h : n₁ + n₂ = n') :
  @horner α _ (horner a₁ x n₁ 0) x n₂ b = horner a₁ x n' b :=
by simp [h.symm, horner, pow_add, mul_assoc]

/-- Evaluate `horner a x n b` where `a` and `b` are already in normal form. -/
meta def eval_horner [has_zero cf] [decidable_eq cf] :
  horner_expr cf → expr × ℕ → expr × ℕ → horner_expr cf → m (horner_expr cf × expr)
| ha@(const a coeff) x n b := do
  c ← monad_ring.get_cache,
  if coeff = 0 then
    return (b, c.cs_app ``zero_horner [x.1, n.1, b])
  else (xadd' c ha x n b).refl_conv
| ha@(xadd a a₁ x₁ n₁ b₁) x n b := do
  c ← monad_ring.get_cache,
  if x₁.2 = x.2 ∧ b₁.e.to_nat = some 0 then do
    (n', h) ← nc_lift $ λ nc, norm_num.prove_add_nat' nc n₁.1 n.1,
    return (xadd' c a₁ x (n', n₁.2 + n.2) b,
      c.cs_app ``horner_horner [a₁, x.1, n₁.1, n.1, b, n', h])
  else (xadd' c ha x n b).refl_conv

theorem const_add_horner {α} [comm_semiring α] (k a x n b b') (h : k + b = b') :
  k + @horner α _ a x n b = horner a x n b' :=
by simp [h.symm, horner]; cc

theorem horner_add_const {α} [comm_semiring α] (a x n b k b') (h : b + k = b') :
  @horner α _ a x n b + k = horner a x n b' :=
by simp [h.symm, horner, add_assoc]

theorem horner_add_horner_lt {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ b₂ k a' b')
  (h₁ : n₁ + k = n₂) (h₂ : (a₁ + horner a₂ x k 0 : α) = a') (h₃ : b₁ + b₂ = b') :
  @horner α _ a₁ x n₁ b₁ + horner a₂ x n₂ b₂ = horner a' x n₁ b' :=
by simp [h₂.symm, h₃.symm, h₁.symm, horner, pow_add, mul_add, mul_comm, mul_left_comm]; cc

theorem horner_add_horner_gt {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ b₂ k a' b')
  (h₁ : n₂ + k = n₁) (h₂ : (horner a₁ x k 0 + a₂ : α) = a') (h₃ : b₁ + b₂ = b') :
  @horner α _ a₁ x n₁ b₁ + horner a₂ x n₂ b₂ = horner a' x n₂ b' :=
by simp [h₂.symm, h₃.symm, h₁.symm, horner, pow_add, mul_add, mul_comm, mul_left_comm]; cc

theorem horner_add_horner_eq {α} [comm_semiring α] (a₁ x n b₁ a₂ b₂ a' b' t)
  (h₁ : a₁ + a₂ = a') (h₂ : b₁ + b₂ = b') (h₃ : horner a' x n b' = t) :
  @horner α _ a₁ x n b₁ + horner a₂ x n b₂ = t :=
by simp [h₃.symm, h₂.symm, h₁.symm, horner, add_mul, mul_comm (x ^ n)]; cc

/-- Evaluate `a + b` where `a` and `b` are already in normal form. -/
meta def eval_add (eval_add_cf : (expr × cf) → (expr × cf) → m (expr × expr × cf))
  [has_zero cf] [decidable_eq cf] :
  horner_expr cf → horner_expr cf → m (horner_expr cf × expr)
| (const e₁ c₁) (const e₂ c₂) := do
  (e, p, n) ← eval_add_cf (e₁, c₁) (e₂, c₂),
  return (const e n, p)
| he₁@(const e₁ c₁) he₂@(xadd e₂ a x n b) := do
  c ← monad_ring.get_cache,
  if c₁ = 0 then ic_lift $ λ ic, do
    (ic, p) ← ic.mk_app ``zero_add [e₂],
    return (ic, he₂, p)
  else do
    (b', h) ← eval_add he₁ b,
    return (xadd' c a x n b',
      c.cs_app ``const_add_horner [e₁, a, x.1, n.1, b, b', h])
| he₁@(xadd e₁ a x n b) he₂@(const e₂ c₂) := do
  c ← monad_ring.get_cache,
  if c₂ = 0 then ic_lift $ λ ic, do
    (ic, p) ← ic.mk_app ``add_zero [e₁],
    return (ic, he₁, p)
  else do
    (b', h) ← eval_add b he₂,
    return (xadd' c a x n b',
      c.cs_app ``horner_add_const [a, x.1, n.1, b, e₂, b', h])
| he₁@(xadd e₁ a₁ x₁ n₁ b₁) he₂@(xadd e₂ a₂ x₂ n₂ b₂) := do
  c ← monad_ring.get_cache,
  if x₁.2 < x₂.2 then do
    (b', h) ← eval_add b₁ he₂,
    return (xadd' c a₁ x₁ n₁ b',
      c.cs_app ``horner_add_const [a₁, x₁.1, n₁.1, b₁, e₂, b', h])
  else if x₁.2 ≠ x₂.2 then do
    (b', h) ← eval_add he₁ b₂,
    return (xadd' c a₂ x₂ n₂ b',
      c.cs_app ``const_add_horner [e₁, a₂, x₂.1, n₂.1, b₂, b', h])
  else if n₁.2 < n₂.2 then do
    let k := n₂.2 - n₁.2,
    (ek, h₁) ← nc_lift (λ nc, do
      (nc, ek) ← nc.of_nat k,
      (nc, h₁) ← norm_num.prove_add_nat nc n₁.1 ek n₂.1,
      return (nc, ek, h₁)),
    α0 ← ic_lift $ λ ic, ic.mk_app ``has_zero.zero [],
    (a', h₂) ← eval_add a₁ (xadd' c a₂ x₁ (ek, k) (const α0 0)),
    (b', h₃) ← eval_add b₁ b₂,
    return (xadd' c a' x₁ n₁ b',
      c.cs_app ``horner_add_horner_lt [a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, b₂, ek, a', b', h₁, h₂, h₃])
  else if n₁.2 ≠ n₂.2 then do
    let k := n₁.2 - n₂.2,
    (ek, h₁) ← nc_lift (λ nc, do
      (nc, ek) ← nc.of_nat k,
      (nc, h₁) ← norm_num.prove_add_nat nc n₂.1 ek n₁.1,
      return (nc, ek, h₁)),
    α0 ← ic_lift $ λ ic, ic.mk_app ``has_zero.zero [],
    (a', h₂) ← eval_add (xadd' c a₁ x₁ (ek, k) (const α0 0)) a₂,
    (b', h₃) ← eval_add b₁ b₂,
    return (xadd' c a' x₁ n₂ b',
      c.cs_app ``horner_add_horner_gt [a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, b₂, ek, a', b', h₁, h₂, h₃])
  else do
    (a', h₁) ← eval_add a₁ a₂,
    (b', h₂) ← eval_add b₁ b₂,
    (t, h₃) ← eval_horner a' x₁ n₁ b',
    return (t, c.cs_app ``horner_add_horner_eq
      [a₁, x₁.1, n₁.1, b₁, a₂, b₂, a', b', t, h₁, h₂, h₃])

theorem horner_neg {α} [comm_ring α] (a x n b a' b')
  (h₁ : -a = a') (h₂ : -b = b') :
  -@horner α _ a x n b = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner]; cc

/-- Evaluate `-a` where `a` is already in normal form. -/
meta def eval_neg (eval_neg_cf : (expr × cf) → m (expr × expr × cf)) :
  horner_expr cf → m (horner_expr cf × expr)
| (const e coeff) := do
  (e', p, c) ← eval_neg_cf (e, coeff),
  return (const e' c, p)
| (xadd e a x n b) := do
  c ← monad_ring.get_cache,
  (a', h₁) ← eval_neg a,
  (b', h₂) ← eval_neg b,
  p ← ic_lift $ λ ic, ic.mk_app ``horner_neg [a, x.1, n.1, b, a', b', h₁, h₂],
  return (xadd' c a' x n b', p)

theorem horner_const_mul {α} [comm_semiring α] (c a x n b a' b')
  (h₁ : c * a = a') (h₂ : c * b = b') :
  c * @horner α _ a x n b = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner, mul_add, mul_assoc]

theorem horner_mul_const {α} [comm_semiring α] (a x n b c a' b')
  (h₁ : a * c = a') (h₂ : b * c = b') :
  @horner α _ a x n b * c = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner, add_mul, mul_right_comm]

/-- Evaluate `k * a` where `k` is a numeral and `a` is in normal form. -/
meta def eval_const_mul (eval_mul_cf : (expr × cf) → (expr × cf) → m (expr × expr × cf))
  (k : expr × cf) : horner_expr cf → m (horner_expr cf × expr)
| (const e coeff) := do
  (e', p, kc) ← eval_mul_cf k (e, coeff),
  return (const e' kc, p)
| (xadd e a x n b) := do
  c ← monad_ring.get_cache,
  (a', h₁) ← eval_const_mul a,
  (b', h₂) ← eval_const_mul b,
  return (xadd' c a' x n b',
    c.cs_app ``horner_const_mul [k.1, a, x.1, n.1, b, a', b', h₁, h₂])

theorem horner_mul_horner_zero {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ aa t)
  (h₁ : @horner α _ a₁ x n₁ b₁ * a₂ = aa)
  (h₂ : horner aa x n₂ 0 = t) :
  horner a₁ x n₁ b₁ * horner a₂ x n₂ 0 = t :=
by rw [← h₂, ← h₁];
   simp [horner, mul_add, mul_comm, mul_left_comm, mul_assoc]

theorem horner_mul_horner {α} [comm_semiring α]
  (a₁ x n₁ b₁ a₂ n₂ b₂ aa haa ab bb t)
  (h₁ : @horner α _ a₁ x n₁ b₁ * a₂ = aa)
  (h₂ : horner aa x n₂ 0 = haa)
  (h₃ : a₁ * b₂ = ab) (h₄ : b₁ * b₂ = bb)
  (H : haa + horner ab x n₁ bb = t) :
  horner a₁ x n₁ b₁ * horner a₂ x n₂ b₂ = t :=
by rw [← H, ← h₂, ← h₁, ← h₃, ← h₄];
   simp [horner, mul_add, mul_comm, mul_left_comm, mul_assoc]

/-- Evaluate `a * b` where `a` and `b` are in normal form. -/
meta def eval_mul [has_zero cf] [has_one cf] [decidable_eq cf]
  (eval_add_cf : (expr × cf) → (expr × cf) → m (expr × expr × cf))
  (eval_mul_cf : (expr × cf) → (expr × cf) → m (expr × expr × cf)) :
  horner_expr cf → horner_expr cf → m (horner_expr cf × expr)
| (const e₁ c₁) (const e₂ c₂) := do
  (e', p, n) ← eval_mul_cf (e₁, c₁) (e₂, c₂),
  return (const e' n, p)
| (const e₁ c₁) e₂ :=
  if c₁ = 0 then do
    c ← monad_ring.get_cache,
    α0 ← ic_lift $ λ ic, ic.mk_app ``has_zero.zero [],
    p ← ic_lift $ λ ic, ic.mk_app ``zero_mul [e₂],
    return (const α0 0, p)
  else if c₁ = 1 then do
    p ← ic_lift $ λ ic, ic.mk_app ``one_mul [e₂],
    return (e₂, p)
  else eval_const_mul eval_mul_cf (e₁, c₁) e₂
| e₁ he₂@(const e₂ c₂) := do
  p₁ ← ic_lift $ λ ic, ic.mk_app ``mul_comm [e₁, e₂],
  (e', p₂) ← eval_mul he₂ e₁,
  p ← monad_tactic.lift $ mk_eq_trans p₁ p₂, return (e', p)
| he₁@(xadd e₁ a₁ x₁ n₁ b₁) he₂@(xadd e₂ a₂ x₂ n₂ b₂) := do
  c ← monad_ring.get_cache,
  if x₁.2 < x₂.2 then do
    (a', h₁) ← eval_mul a₁ he₂,
    (b', h₂) ← eval_mul b₁ he₂,
    return (xadd' c a' x₁ n₁ b',
      c.cs_app ``horner_mul_const [a₁, x₁.1, n₁.1, b₁, e₂, a', b', h₁, h₂])
  else if x₁.2 ≠ x₂.2 then do
    (a', h₁) ← eval_mul he₁ a₂,
    (b', h₂) ← eval_mul he₁ b₂,
    return (xadd' c a' x₂ n₂ b',
      c.cs_app ``horner_const_mul [e₁, a₂, x₂.1, n₂.1, b₂, a', b', h₁, h₂])
  else do
    (aa, h₁) ← eval_mul he₁ a₂,
    α0 ← ic_lift $ λ ic, ic.mk_app ``has_zero.zero [],
    (haa, h₂) ← eval_horner aa x₁ n₂ (const α0 0),
    if b₂.is_zero then
      return (haa, c.cs_app ``horner_mul_horner_zero
        [a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, aa, haa, h₁, h₂])
    else do
      (ab, h₃) ← eval_mul a₁ b₂,
      (bb, h₄) ← eval_mul b₁ b₂,
      (t, H) ← eval_add eval_add_cf haa (xadd' c ab x₁ n₁ bb),
      return (t, c.cs_app ``horner_mul_horner
        [a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, b₂, aa, haa, ab, bb, t, h₁, h₂, h₃, h₄, H])

theorem horner_pow {α} [comm_semiring α] (a x n m n' a') (h₁ : n * m = n') (h₂ : a ^ m = a') :
  @horner α _ a x n 0 ^ m = horner a' x n' 0 :=
by simp [h₁.symm, h₂.symm, horner, mul_pow, pow_mul]

theorem pow_succ {α} [comm_semiring α] (a n b c)
  (h₁ : (a:α) ^ n = b) (h₂ : b * a = c) : a ^ (n + 1) = c :=
by rw [← h₂, ← h₁, pow_succ']

/-- Evaluate `a ^ n` where `a` is in normal form and `n` is a natural numeral. -/
meta def eval_pow [has_zero cf] [has_one cf] [decidable_eq cf]
  (eval_add_cf : (expr × cf) → (expr × cf) → m (expr × expr × cf))
  (eval_mul_cf : (expr × cf) → (expr × cf) → m (expr × expr × cf))
  (eval_pow_cf : (expr × cf) → (expr × ℕ) → m (expr × expr × cf)) :
  horner_expr cf → expr × ℕ → m (horner_expr cf × expr)
| e (_, 0) := do
  c ← monad_ring.get_cache,
  α1 ← ic_lift $ λ ic, ic.mk_app ``has_one.one [],
  p ← ic_lift $ λ ic, ic.mk_app ``pow_zero [e],
  return (const α1 1, p)
| e (_, 1) := do
  p ← ic_lift $ λ ic, ic.mk_app ``pow_one [e],
  return (e, p)
| (const e coeff) (e₂, m) := do
  (e', p, cm) ← eval_pow_cf (e, coeff) (e₂, m),
  return (const e' cm, p)
| he@(xadd e a x n b) m := do
  c ← monad_ring.get_cache,
  match b.e.to_nat with
  | some 0 := do
    (n', h₁) ← nc_lift $ λ nc, norm_num.prove_mul_rat nc n.1 m.1 n.2 m.2,
    (a', h₂) ← eval_pow a m,
    α0 ← ic_lift $ λ ic, ic.mk_app ``has_zero.zero [],
    return (xadd' c a' x (n', n.2 * m.2) (const α0 0),
      c.cs_app ``horner_pow [a, x.1, n.1, m.1, n', a', h₁, h₂])
  | _ := do
    e₂ ← nc_lift $ λ nc, nc.of_nat (m.2-1),
    (tl, hl) ← eval_pow he (e₂, m.2-1),
    (t, p₂) ← eval_mul eval_add_cf eval_mul_cf tl he,
    return (t, c.cs_app ``pow_succ [e, e₂, tl, t, hl, p₂])
  end

theorem horner_atom {α} [comm_semiring α] (x : α) : x = horner 1 x 1 0 :=
by simp [horner]

/-- Evaluate `a` where `a` is an atom. -/
meta def eval_atom [has_zero cf] [has_one cf] (e : expr) : m (horner_expr cf × expr) :=
do c ← monad_ring.get_cache,
  i ← add_atom e,
  α0 ← ic_lift $ λ ic, ic.mk_app ``has_zero.zero [],
  α1 ← ic_lift $ λ ic, ic.mk_app ``has_one.one [],
  return (xadd' c (const α1 1) (e, i) (`(1), 1) (const α0 0),
    c.cs_app ``horner_atom [e])

/-- Evaluate `a` where `a` is a coefficient or an atom. -/
meta def eval_base [has_zero cf] [has_one cf] (norm_cf : expr → m (expr × expr × cf))
  (e : expr) : m (horner_expr cf × expr) :=
(do (e', p, n) ← norm_cf e, return (const e' n, p)) <|> eval_atom e

lemma subst_into_pow {α} [monoid α] (l r tl tr t)
  (prl : (l : α) = tl) (prr : (r : ℕ) = tr) (prt : tl ^ tr = t) : l ^ r = t :=
by rw [prl, prr, prt]

lemma unfold_sub {α} [add_group α] (a b c : α)
  (h : a + -b = c) : a - b = c :=
by rw [sub_eq_add_neg, h]

lemma unfold_div {α} [division_ring α] (a b c : α)
  (h : a * b⁻¹ = c) : a / b = c :=
by rw [div_eq_mul_inv, h]

lemma subst_into_horner {α} [comm_semiring α] (a a' x : α) (n n' : ℕ) (b b' e' : α)
  (pa : a = a') (pb : b = b') (pn : n = n') (pe : horner a' x n' b' = e') :
  horner a x n b = e' :=
by rw [pa, pb, pn, pe]

/-- Evaluate a ring expression `e` recursively to normal form, together with a proof of
equality. -/
meta def eval [has_zero cf] [has_one cf] [decidable_eq cf]
  (norm_cf : expr → m (expr × expr × cf))
  (eval_add_cf : (expr × cf) → (expr × cf) → m (expr × expr × cf))
  (eval_neg_cf : (expr × cf) → m (expr × expr × cf))
  (eval_mul_cf : (expr × cf) → (expr × cf) → m (expr × expr × cf))
  (eval_pow_cf : (expr × cf) → (expr × ℕ) → m (expr × expr × cf)) :
  expr → m (horner_expr cf × expr)
| `(horner %%a %%x %%n %%b) := do
  (a', pa) ← eval a,
  (b', pb) ← eval b,
  i ← add_atom x,
  (n', pn) ← monad_tactic.lift $ or_refl_conv norm_num.derive n,
  match n.to_nat with
  | (some n'') := do
    (e', pe) ← eval_horner a' (x, i) (n', n'') b',
    p ← ic_lift $ λ ic, ic.mk_app ``subst_into_horner
      [a, a', x, n, n', b, b', e', pa, pb, pn, pe],
    pure (e', p)
  | none := monad_tactic.lift $ fail format!"not a natural numeral: {n}"
  end
| `(%%e₁ + %%e₂) := do
  (e₁', p₁) ← eval e₁,
  (e₂', p₂) ← eval e₂,
  (e', p') ← eval_add eval_add_cf e₁' e₂',
  p ← ic_lift $ λ ic, ic.mk_app ``norm_num.subst_into_add [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
  return (e', p)
| e@`(@has_sub.sub %%α %%inst %%e₁ %%e₂) :=
  mcond (succeeds (monad_tactic.lift $ mk_app ``comm_ring [α] >>= mk_instance))
    (do
      e₂' ← ic_lift $ λ ic, ic.mk_app ``has_neg.neg [e₂],
      e ← ic_lift $ λ ic, ic.mk_app ``has_add.add [e₁, e₂'],
      (e', p) ← eval e,
      p' ← ic_lift $ λ ic, ic.mk_app ``unfold_sub [e₁, e₂, e', p],
      return (e', p'))
    (eval_base norm_cf e)
| `(- %%e) := do
  (e₁, p₁) ← eval e,
  (e₂, p₂) ← eval_neg eval_neg_cf e₁,
  p ← ic_lift $ λ ic, ic.mk_app ``norm_num.subst_into_neg [e, e₁, e₂, p₁, p₂],
  return (e₂, p)
| `(%%e₁ * %%e₂) := do
  (e₁', p₁) ← eval e₁,
  (e₂', p₂) ← eval e₂,
  (e', p') ← eval_mul eval_add_cf eval_mul_cf e₁' e₂',
  p ← ic_lift $ λ ic, ic.mk_app ``norm_num.subst_into_mul [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
  return (e', p)
| e@`(has_inv.inv %%_) := eval_base norm_cf e
| e@`(@has_div.div _ %%inst %%e₁ %%e₂) := mcond
  (succeeds (do
    inst' ← ic_lift $ λ ic, ic.mk_app ``div_inv_monoid.to_has_div [],
    monad_tactic.lift $ is_def_eq inst inst'))
  (do
    e₂' ← ic_lift $ λ ic, ic.mk_app ``has_inv.inv [e₂],
    e ← ic_lift $ λ ic, ic.mk_app ``has_mul.mul [e₁, e₂'],
    (e', p) ← eval e,
    p' ← ic_lift $ λ ic, ic.mk_app ``unfold_div [e₁, e₂, e', p],
    return (e', p'))
  (eval_base norm_cf e)
| e@`(@has_pow.pow _ _ %%P %%e₁ %%e₂) := do
  (e₂', p₂) ← monad_tactic.lift $ or_refl_conv norm_num.derive e₂,
  match e₂'.to_nat, P with
  | some k, `(monoid.has_pow) := do
    (e₁', p₁) ← eval e₁,
    (e', p') ← eval_pow eval_add_cf eval_mul_cf eval_pow_cf e₁' (e₂, k),
    p ← ic_lift $ λ ic, ic.mk_app ``subst_into_pow [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
    return (e', p)
  | _, _ := eval_base norm_cf e
  end
| e := eval_base norm_cf e

end ring

end norm
end tactic