/- In this file, we define more and more expressive syntax
   for arithmetic expressions and formulae, over
   ℚ, ℤ, and ℕ, give procedures for transforming these formulae
   to the linear arithmetic expressions defined for Fourier-Motzkin
   elimination, and prove that these procedures preserve validity
   of the logical formulae.

   We then construct a suite of reflective tactics that use
   Fourier-Motzkin elimination to solve goals of the form

   H1 : aexpr OP aexpr
   ...
   Hn : aexpr OP aexpr
   -----
   false

   where OP ∈ (<, ≤, =, ≥, >) and an `aexpr` looks like
   expressions of linear arithmetic over ℚ, ℤ, or ℕ.
   Any non-linear expressions, or expressions that otherwise
   fail to have the syntactic structure represent by the
   `aexpr` datatype defined below, are interpreted as variables.

   If the Fourier-Motzkin procedure finds that the generated
   problem is unsatisfiable, it solves the goal.
-/

import .dense_linear

universes u v

/-- A typeclass that is inhabited by ℕ and ℤ, that enables rephrasing
    strict inequalities (<, >) in terms of weak inequalities (≤, ≥).
-/
class discrete_order_ring (α : Type u) extends semiring α, decidable_linear_order α :=
(lt_iff_add_one_le : ∀ (a b : α), a < b ↔ a + 1 ≤ b)
(gt_iff_add_one_le : ∀ (a b : α), a > b ↔ b + 1 ≤ a)

lemma int.gt_iff_add_one_le (a b : ℤ) : a > b ↔ b + 1 ≤ a  := iff.refl _

instance discrete_order_ring_ℤ : discrete_order_ring ℤ :=
begin
constructor, apply int.lt_iff_add_one_le, apply int.gt_iff_add_one_le
end

instance discrete_order_ring_ℕ : discrete_order_ring ℕ :=
begin
constructor, intros a b, reflexivity, intros a b, reflexivity,
apply_instance,
end

open linear_expr

/-- Arithmetic expressions in a (restricted) language of
    linear arithmetic.
-/
inductive aexpr (A : Type u) (vTy : Type) : Type u
-- a variable multiplied on the left by a scalar constant
| var {} : A → vTy → aexpr
-- a variable without any scalar multiplier
| var1 {} : vTy → aexpr
-- a constant term
| const {} : A → aexpr
-- a sum
| add {} : aexpr → aexpr → aexpr

inductive eqn (A : Type u) (vTy : Type) : Type u
-- the first expression is at most the second
| le {} : aexpr A vTy → aexpr A vTy → eqn

namespace aexpr
/-- Map a function over the underlying element type. -/
def map {A : Type u} {B : Type v} (f : A → B) {vTy : Type}
  : aexpr A vTy → aexpr B vTy
| (var c x) := var (f c) x
| (var1 x) := var1 x
| (const q) := const (f q)
| (add x y) := add (map x) (map y)

/-- Multiply an arithmetic expression by a (constant) scalar
-/
def scale {A : Type u} [semiring A] {vTy : Type}
  (c : A)
  : aexpr A vTy → aexpr A vTy
| (var c' x) := var (c * c') x
| (var1 x) := var c x
| (const q) := const (c * q)
| (add x y) := add (scale x) (scale y)

/-- Given a context `ctxt` defining what each variable should
    be interpreted as, compute what the expression is.
-/
def interp {A : Type u} [semiring A] {vTy : Type} (ctxt : vTy → A)
  : aexpr A vTy → A
| (var c x) := c * ctxt x
| (var1 x) := ctxt x
| (const q) := q
| (add x y) := interp x + interp y

lemma interp_scale {A : Type u} [semiring A] {vTy : Type} (ctxt : vTy → A)
  (c : A)
  (e : aexpr A vTy) : (e.scale c).interp ctxt = c * e.interp ctxt
:= begin
induction e; simp [scale, interp],
rw [ih_1, ih_2, mul_add]
end

/-- Convert arithmetic expressions to `linear_expr`s, which is
    the expression type over which the Fourier-Motzkin
    decision procedure is defined. If the type of variables
    of the `aexprs` is `fin n`, then we produce ` linear_expr n`,
    i.e., linear expression with `n` variables.
-/
def to_linear_expr {n : ℕ}
  : aexpr ℚ (fin n) → linear_expr n
| (var c x) := linear_expr.var c x
| (var1 x) := linear_expr.var 1 x
| (const q) := linear_expr.const _ q
| (add x y) := add_expr (to_linear_expr x) (to_linear_expr y)

lemma to_linear_expr_sound {n : ℕ}
  (e : aexpr ℚ (fin n))
  (ctxt : fin n → ℚ)
  : e.interp ctxt = e.to_linear_expr.evaluate (vector.of_fn ctxt)
:= begin
induction e; dsimp [interp, to_linear_expr],
case var c i
{ rw var_evaluate, rw vector.nth_of_fn, },
{ rw var_evaluate, rw vector.nth_of_fn, rw [mul_comm, mul_one], },
{ unfold evaluate, dsimp [linear_expr.const],
  rw ← vector.generate_const_repeat,
  rw dot_product_0, simp,
},
{ rw [ih_1, ih_2],
  dsimp [evaluate, linear_expr.add_expr],
  rw dot_product_sum_l, simp,
}
end

def var_map {A : Type u} {vTy vTy' : Type} (f : vTy → vTy')
  : aexpr A vTy → aexpr A vTy'
| (var c x) := var c (f x)
| (var1 x) := var1 (f x)
| (const q) := const q
| (add x y) := add (var_map x) (var_map y)

def var_map_default {A : Type u} [has_mul A]
  {vTy vTy' : Type} (f : vTy → option vTy')
  (default : A)
  : aexpr A vTy → aexpr A vTy'
| (var c x) := match f x with
   | some y := var c y
   | none := const (c * default)
   end
| (var1 x) := match f x with
   | some y := var1 y
   | none := const default
   end
| (const q) := const q
| (add x y) := add (var_map_default x) (var_map_default y)
end aexpr

namespace eqn
def interp {A} [semiring A] [decidable_linear_order A] {vTy : Type} (ctxt : vTy → A)
  : eqn A vTy → Prop
| (le e e') := e.interp ctxt ≤ e'.interp ctxt

def map_aexpr {A B} {vTy : Type} (f : aexpr A vTy → aexpr B vTy)
  : eqn A vTy → eqn B vTy
| (le e e') := le (f e) (f e')

lemma map_aexpr_compose {A B C} {vTy : Type} (f : aexpr A vTy → aexpr B vTy)
  (g : aexpr B vTy → aexpr C vTy)
  : map_aexpr g ∘ map_aexpr f = map_aexpr (g ∘ f)
:= begin
apply funext, intros e,
induction e with e e', simp [function.comp, map_aexpr],
end

def to_aexpr {vTy : Type} {A} [ring A]
  : eqn A vTy → aexpr A vTy
| (le e e') := aexpr.add e (aexpr.scale (-1) e')
end eqn

inductive cmp_op : Type
  | le
  | lt
  | eq
  | gt
  | ge

namespace cmp_op
def interp (A : Type) [decidable_linear_order A]
  : cmp_op → A → A → Prop
| le := (≤)
| lt := (<)
| eq := (=)
| gt := (>)
| ge := (≥)

end cmp_op

inductive eqnd (Z : Type) (vTy : Type) : Type u
| mk : cmp_op → aexpr Z vTy → aexpr Z vTy → eqnd

namespace eqnd
def interp {Z : Type} {vTy : Type}
  [semiring Z] [decidable_linear_order Z]
   (ctxt : vTy → Z)
  : eqnd Z vTy → Prop
| (mk op e e') := (op.interp Z) (e.interp ctxt) (e'.interp ctxt)

def to_eqns {Z} {vTy : Type}
  [has_one Z]
  : eqnd Z vTy → list (eqn Z vTy)
| (mk cmp_op.le e e') := [eqn.le e e']
| (mk cmp_op.lt e e') := [eqn.le (aexpr.add e (aexpr.const 1)) e']
| (mk cmp_op.eq e e') := [eqn.le e e', eqn.le e' e]
| (mk cmp_op.ge e e') := [eqn.le e' e]
| (mk cmp_op.gt e e') := [eqn.le (aexpr.add e' (aexpr.const 1)) e]

def map_aexpr {Z Z'} {vTy : Type} (f : aexpr Z vTy → aexpr Z' vTy)
  : eqnd Z vTy → eqnd Z' vTy
| (mk op e e') := mk op (f e) (f e')

lemma map_aexpr_compose {A B C} {vTy : Type} (f : aexpr A vTy → aexpr B vTy)
  (g : aexpr B vTy → aexpr C vTy)
  : map_aexpr g ∘ map_aexpr f = map_aexpr (g ∘ f)
:= begin
apply funext, intros e,
induction e with e e'; simp [function.comp, map_aexpr],
end

lemma to_eqns_interp {A} [discrete_order_ring A]
  {vTy} (x : eqnd A vTy) (ctxt : vTy → A)
  : x.interp ctxt ↔ list.foldr (∧) true (x.to_eqns.map (eqn.interp ctxt))
:= begin
induction x with op e e',
induction op; dsimp [cmp_op.interp, to_eqns, interp, eqn.interp],
case cmp_op.le { simp, },
case cmp_op.lt {
  dsimp [aexpr.interp],
  rw discrete_order_ring.lt_iff_add_one_le, simp,
 },
case cmp_op.eq {
  rw le_antisymm_iff, simp,
},
case cmp_op.gt {
  dsimp [aexpr.interp],
  rw discrete_order_ring.gt_iff_add_one_le, simp,
 },
case cmp_op.ge { simp, },
end

end eqnd

namespace aexpr
def interp_expr_context (hyp : aexpr ℚ ℕ)
  (n : ℕ) : linear_expr n
  := (aexpr.var_map_default (nat_to_fin_option _) 0 hyp).to_linear_expr

def instantiate_head {A} [semiring A]
  (c' : A) : aexpr A ℕ → aexpr A ℕ
| (var c n) := match n with
  | 0 := const (c * c')
  | (nat.succ n') := var c n'
  end
| (var1 n) := match n with
  | 0 := const c'
  | (nat.succ n') := var1 n'
  end
| (const q) := const q
| (add x y) := add (instantiate_head x) (instantiate_head y)

def no_big_vars_bool {A} (nvars : ℕ) : aexpr A ℕ → bool
| (var c x) := decidable.to_bool (x < nvars)
| (var1 x) := decidable.to_bool (x < nvars)
| (const q) := tt
| (add x y) := band (no_big_vars_bool x) (no_big_vars_bool y)

def no_big_vars {A} (nvars : ℕ) : aexpr A ℕ → Prop
| (var c x) := x < nvars
| (var1 x) := x < nvars
| (const q) := true
| (add x y) := no_big_vars x ∧ no_big_vars y

instance no_big_vars_decidable {A} (nvars : ℕ)
  : decidable_pred (@no_big_vars A nvars)
:= begin
intros x, induction x; dsimp [no_big_vars]; apply_instance,
end

lemma to_bool_and (P Q : Prop) [decP : decidable P]
  [decQ : decidable Q]
  : to_bool P && to_bool Q = to_bool (P ∧ Q)
:= begin
unfold to_bool, cases (@and.decidable _ _ decP decQ) with H H;
cases decP with HP HP; cases decQ with HQ HQ;
dsimp;
try {reflexivity}; exfalso, apply H, split; assumption,
{ induction H with H H', apply HP, assumption },
{ induction H with H H', apply HP, assumption },
{ induction H with H H', apply HQ, assumption },
end

lemma no_big_vars_equiv {A} (nvars : ℕ)
  : @no_big_vars_bool A nvars = λ e, to_bool (no_big_vars nvars e)
:= begin
apply funext; intros e,
induction e; dsimp [no_big_vars, no_big_vars_bool],
reflexivity, reflexivity, rw to_bool_tt, trivial,
rw [ih_1, ih_2], rw to_bool_and,
end

end aexpr

def interp_list_exprs (hyps : list (aexpr ℚ ℕ))
  (n : ℕ) : list (linear_expr n)
:= hyps.map (λ hyp : aexpr ℚ ℕ, hyp.interp_expr_context n)

open linear_expr

def negation_statement_0 {A} (f : A → Prop)
  : list A → Prop
| [] := false
| (e :: es) := f e → negation_statement_0 es

def linear_expr_negation_statement :
  ∀ {n : ℕ}, list (linear_expr n) → Prop
| 0 := negation_statement_0 (λ e, e.evaluate vector.nil ≤ 0)
| (nat.succ n) := λ es, ∀ x : ℚ, linear_expr_negation_statement
    (es.map (λ e, e.instantiate_head x))

def aexpr_negation_statement {A} [semiring A] [decidable_linear_order A] :
  ∀ nvars : ℕ, list (aexpr A ℕ) → Prop
| 0 := negation_statement_0 (λ e, e.interp (λ _, 0) ≤ 0)
| (nat.succ n) := λ es, ∀ x : A, aexpr_negation_statement n
    (es.map (λ e, e.instantiate_head x))

def eqn_negation_statement {A} [semiring A] [decidable_linear_order A]
  : ∀ nvars : ℕ, list (eqn A ℕ) → Prop
| 0 := negation_statement_0 (λ e, e.interp (λ _, (0 : A)))
| (nat.succ n) := λ es, ∀ x : A, eqn_negation_statement n
    (es.map (λ e, e.map_aexpr (aexpr.instantiate_head x)))

def eqnd_negation_statement {Z} [semiring Z] [decidable_linear_order Z]
  : ∀ nvars : ℕ, list (eqnd Z ℕ) → Prop
| 0 := negation_statement_0 (λ e, e.interp (λ _, (0 : Z)))
| (nat.succ n) := λ es, ∀ x : Z, eqnd_negation_statement n
    (es.map (λ e, e.map_aexpr (aexpr.instantiate_head x)))

def eqnd_negation_statement_nonneg {Z} [semiring Z] [decidable_linear_order Z]
  : ∀ nvars : ℕ, list (eqnd Z ℕ) → Prop
| 0 := negation_statement_0 (λ e, e.interp (λ _, (0 : Z)))
| (nat.succ n) := λ es, ∀ x : Z, 0 ≤ x → eqnd_negation_statement_nonneg n
    (es.map (λ e, e.map_aexpr (aexpr.instantiate_head x)))

def nonzero_constraints {Z : Type} [has_zero Z]
  : ℕ → list (eqn Z ℕ)
| 0 := []
| (nat.succ n) := eqn.le (aexpr.const 0) (aexpr.var1 n)
               :: nonzero_constraints n

lemma coe_rat_of_int (x : ℤ)
  : ↑ x = rat.of_int x := rfl

lemma rat.coe_int_mul (x y : ℤ)
  : (↑ (x * y) : ℚ) = (↑ x) * (↑ y)
:= begin
simp [rat.coe_int_eq_mk],
end

lemma rat.coe_int_neg (x : ℤ)
  : (↑ (- x) : ℚ) = - ↑ x
:= rfl

lemma nonneg_rat_nonneg (x : ℤ)
  (H : 0 ≤ x) : rat.nonneg (↑ x)
:= begin
rw coe_rat_of_int, dsimp [rat.nonneg, rat.of_int],
assumption,
end

lemma Z_to_Q_le_iff (x y : ℤ)
  : x ≤ y ↔ (↑ x : ℚ) ≤ ↑ y
:= begin
split; intros H,
{ dsimp [has_le.le, rat.le],
  rw ← rat.coe_int_neg, rw ← rat.coe_int_add,
  apply nonneg_rat_nonneg,
  rw ← sub_eq_add_neg,
  apply sub_nonneg_of_le, assumption,
 },
{ apply rat.le_of_of_int_le_of_int, assumption, }
end

lemma Z_to_Q_interp (e : aexpr ℤ ℕ) (ctxt : ℕ → ℤ)
  : (↑ (e.interp ctxt) : ℚ)
  = (e.map coe).interp (λ x, ↑ (ctxt x))
:= begin
induction e; dsimp [aexpr.interp, aexpr.map],
rw rat.coe_int_mul, reflexivity, reflexivity,
rw [rat.coe_int_add, ih_1, ih_2],
end

lemma rat.coe_int_zero
  : ↑ (0 : ℤ) = (0 : ℚ)
:= rfl

lemma instantiate_head_Z_to_Q
  (c : ℤ)
  : aexpr.map coe ∘ aexpr.instantiate_head c = aexpr.instantiate_head (↑ c : ℚ) ∘ aexpr.map coe
:= begin
apply funext; intros e; dsimp [function.comp],
induction e; dsimp [aexpr.instantiate_head, aexpr.map],
cases a_1; dsimp [aexpr.instantiate_head, aexpr.map],
rw rat.coe_int_mul, reflexivity,
cases a; dsimp [aexpr.instantiate_head, aexpr.map],
reflexivity,
reflexivity, reflexivity,
rw [ih_1, ih_2],
end

lemma instantiate_head_N_to_Z
  (c : ℕ)
  : aexpr.map coe ∘ aexpr.instantiate_head c = aexpr.instantiate_head (↑ c : ℤ) ∘ aexpr.map coe
:= begin
apply funext; intros e; dsimp [function.comp],
induction e; dsimp [aexpr.instantiate_head, aexpr.map],
cases a_1; dsimp [aexpr.instantiate_head, aexpr.map],
rw int.coe_nat_mul, reflexivity,
cases a; dsimp [aexpr.instantiate_head, aexpr.map],
reflexivity,
reflexivity, reflexivity,
rw [ih_1, ih_2],
end

lemma nonneg_sub2 {A} [linear_ordered_comm_ring A] (x y : A)
  : x ≤ y ↔ x - y ≤ 0
:= begin
rw sub_eq_add_neg,
rw add_neg_le_l x (-y),
rw neg_neg,
end

lemma eqn_aexpr_interp {vTy} (e : eqn ℚ vTy)
  (ctxt : _) :
  eqn.interp ctxt e ↔ aexpr.interp ctxt e.to_aexpr ≤ 0
:= begin
induction e with e e',
dsimp [eqn.interp, eqn.to_aexpr, aexpr.interp],
rw aexpr.interp_scale,
rw ← neg_mul_eq_neg_mul,
rw mul_comm, rw mul_one,
rw ← sub_eq_add_neg,
rw nonneg_sub2,
end

lemma aexpr_instantiate_head_add {A} [semiring A] (x : A) (e e' : _)
  : aexpr.instantiate_head x (aexpr.add e e')
  = aexpr.add (aexpr.instantiate_head x e) (aexpr.instantiate_head x e')
:= rfl

lemma aexpr_instantiate_head_scale {A} [semiring A] (x c : A) (e : _)
  : aexpr.instantiate_head x (aexpr.scale c e)
  = aexpr.scale c (aexpr.instantiate_head x e)
:= begin
induction e; dsimp [aexpr.instantiate_head, aexpr.scale],
cases a_1; dsimp [aexpr.instantiate_head, aexpr.scale],
rw mul_assoc, reflexivity,
cases a; dsimp [aexpr.instantiate_head, aexpr.scale],
reflexivity,
reflexivity, reflexivity,
rw [ih_1, ih_2],
end

lemma eqn_aexpr_instantiate_head {A} [ring A] (x : A) :
   aexpr.instantiate_head x ∘ eqn.to_aexpr
 = eqn.to_aexpr ∘ eqn.map_aexpr (aexpr.instantiate_head x)
:= begin
dsimp [function.comp], apply funext, intros e,
induction e with e e',
dsimp [eqn.to_aexpr, eqn.map_aexpr],
rw aexpr_instantiate_head_add,
rw aexpr_instantiate_head_scale,
end

lemma eqn_to_aexpr_sound (nvars : ℕ) (xs : list (eqn ℚ ℕ))
  : aexpr_negation_statement nvars (xs.map (eqn.to_aexpr))
  → eqn_negation_statement nvars xs
:= begin
revert xs,
induction nvars; intros xs; dsimp [aexpr_negation_statement],
{ induction xs; dsimp [negation_statement_0],
  { intros H, assumption },
  { intros H H', apply ih_1, apply H,
    rw ← eqn_aexpr_interp, assumption,
  }
},
{ intros H, dsimp [eqn_negation_statement], intros x,
  specialize (H x), rw list.map_map at H,
  rw eqn_aexpr_instantiate_head at H,
  apply ih_1, rw list.map_map, assumption
}
end

def eqnd_to_aexprs {Z} [has_one Z]
  : list (eqnd Z ℕ) → list (eqn Z ℕ)
| [] := []
| (x :: xs) := x.to_eqns ++ eqnd_to_aexprs xs

lemma eqnd_map_aexpr_commute {Z} [has_one Z] [semiring Z]
  (x : Z) (a : eqnd Z ℕ) :
  list.map (eqn.map_aexpr (aexpr.instantiate_head x)) (eqnd.to_eqns a) =
    (eqnd.to_eqns (eqnd.map_aexpr (aexpr.instantiate_head x) a))
:= begin
induction a with op e e', induction op; reflexivity
end

lemma eqnd_to_aexprs_map_aexpr_commutes {Z}
  [has_one Z] [semiring Z]
   (x : Z) (xs : list (eqnd Z ℕ))
  : list.map (eqn.map_aexpr (aexpr.instantiate_head x)) (eqnd_to_aexprs xs)
  = eqnd_to_aexprs (list.map (eqnd.map_aexpr (aexpr.instantiate_head x)) xs)
:= begin
induction xs; dsimp [eqnd_to_aexprs, list.map],
{ reflexivity },
{ rw ← ih_1, rw list.map_append, f_equal,
  rw eqnd_map_aexpr_commute,
}
end

lemma negation_statement_0_app_conjunction {A}
  (f : A → Prop) (xs ys : list A)
  : negation_statement_0 f (xs ++ ys)
  ↔ (list.foldr and true (list.map f xs) → negation_statement_0 f ys)
:= begin
induction xs; dsimp [list.foldr, negation_statement_0],
{ rw true_implies_iff, },
{ split; intros H,
  { intros H', induction H' with H1 H2,
    revert H2, rw ← ih_1, apply H, assumption,
  },
  { intros H', rw ih_1, intros H'',
    apply H, split; assumption }
}
end

lemma eqn_interp_map_aexpr_Z_Q
  : eqn.interp (λ (_x : ℕ), (0 : ℤ))
  = eqn.interp (λ (_x : ℕ), (0 : ℚ)) ∘ eqn.map_aexpr (aexpr.map coe)
:= begin
apply funext, intros e,
induction e with e e'; dsimp [function.comp, eqn.interp, eqn.map_aexpr],
rw Z_to_Q_le_iff,
rw Z_to_Q_interp, rw Z_to_Q_interp,
rw rat.coe_int_zero,
end

lemma eqnd_to_eqn_sound {A} [discrete_order_ring A]
  (nvars : ℕ) (xs : list (eqnd A ℕ))
  : eqn_negation_statement nvars (eqnd_to_aexprs xs)
  ↔ eqnd_negation_statement nvars xs
:= begin
revert xs,
induction nvars; intros xs; dsimp [eqn_negation_statement, eqnd_negation_statement],
{ induction xs; dsimp [negation_statement_0],
  { reflexivity },
  { rw eqnd.to_eqns_interp,
    dsimp [eqnd_to_aexprs],
    rw ← ih_1, rw negation_statement_0_app_conjunction,
  }
},
{ split; intros H,
  { intros x, specialize (H x),
    rw ← ih_1, rw ← eqnd_to_aexprs_map_aexpr_commutes,
    assumption, },
  { intros x, specialize (H x),
    rw ← ih_1 at H, rw ← eqnd_to_aexprs_map_aexpr_commutes at H,
    assumption }
 }
end

lemma Z_to_Q_sound_eqn (nvars : ℕ) (xs : list (eqn ℤ ℕ))
  : eqn_negation_statement nvars (xs.map (eqn.map_aexpr (aexpr.map coe)) : list (eqn ℚ ℕ))
  → eqn_negation_statement nvars xs
:= begin
revert xs,
induction nvars; intros xs; dsimp [eqn_negation_statement],
{ induction xs; dsimp [negation_statement_0],
  { intros H, assumption },
  { intros H H', apply ih_1, apply H,
    induction a with e e',
    dsimp [eqn.interp] at *,
    rw Z_to_Q_le_iff at H', repeat { rw Z_to_Q_interp at H' },
    dsimp [eqn.map_aexpr, eqn.interp],
    repeat { rw ← rat.coe_int_zero },
    assumption,
  }
},
{ intros H x, specialize (H x), rw list.map_map at H,
  rw eqn.map_aexpr_compose at H,
  rw ← instantiate_head_Z_to_Q at H,
  apply ih_1, rw list.map_map,
  rw eqn.map_aexpr_compose, assumption }
end

lemma aexpr_interp_N_Z (e : aexpr ℕ ℕ) (ctxt : ℕ → ℕ)
  : (↑(aexpr.interp ctxt e) : ℤ)
  = aexpr.interp (λ (x : ℕ), ↑(ctxt x)) (aexpr.map coe e)
:= begin
induction e; dsimp [aexpr.map, aexpr.interp],
rw int.coe_nat_mul, reflexivity, reflexivity,
rw int.coe_nat_add, rw [ih_1, ih_2],
end

lemma gt_lt {A} [has_lt A] (x y : A)
  : x > y = (y < x)
  := rfl

lemma ge_le {A} [has_le A] (x y : A)
  : x ≥ y = (y ≤ x)
  := rfl

lemma eqn_interp_N_Z (a : eqn ℕ ℕ) (ctxt : ℕ → ℕ)
  : eqn.interp ctxt a
  ↔ eqn.interp (λ x, (↑ (ctxt x) : ℤ)) (eqn.map_aexpr (aexpr.map coe) a)
:= begin
induction a with e e'; simp [eqn.interp, eqn.map_aexpr, aexpr.map],
{ rw ← int.coe_nat_le_coe_nat_iff,
  repeat {rw aexpr_interp_N_Z}, },
end

lemma eqnd_interp_N_Z (a : eqnd ℕ ℕ) (ctxt : ℕ → ℕ)
  : eqnd.interp ctxt a
  ↔ eqnd.interp (λ x, (↑ (ctxt x) : ℤ)) (eqnd.map_aexpr (aexpr.map coe) a)
:= begin
induction a with op e e',
induction op;
 simp [cmp_op.interp, eqnd.interp, eqnd.map_aexpr, aexpr.map],
{ rw ← int.coe_nat_le_coe_nat_iff,
  repeat {rw aexpr_interp_N_Z}, },
{ rw ← int.coe_nat_lt_coe_nat_iff,
  repeat {rw aexpr_interp_N_Z}, },
{ rw ← int.coe_nat_eq_coe_nat_iff,
  repeat {rw aexpr_interp_N_Z}, },
{ repeat { rw gt_lt },
  rw ← int.coe_nat_lt_coe_nat_iff,
  repeat {rw aexpr_interp_N_Z}, },
{ repeat { rw ge_le },
  rw ← int.coe_nat_le_coe_nat_iff,
  repeat {rw aexpr_interp_N_Z}, },
end

lemma Z_nonneg_roundtrip_N {x : ℤ}
  (H : 0 ≤ x)
  : ↑(int.to_nat x) = x
:= begin
induction x, reflexivity,
cases H,
end

lemma N_to_Z_sound_eqn (nvars : ℕ) (xs : list (eqn ℕ ℕ))
  : eqn_negation_statement nvars (xs.map (eqn.map_aexpr (aexpr.map coe)) : list (eqn ℤ ℕ))
  → eqn_negation_statement nvars xs
:= begin
revert xs,
induction nvars; intros xs; dsimp [eqn_negation_statement],
{ induction xs; dsimp [negation_statement_0],
  { intros H, assumption },
  { intros H H', apply ih_1, apply H,
    rw eqn_interp_N_Z at H',
    rw ← int.coe_nat_zero, assumption,
  }
},
{ intros H x, specialize (H x), rw list.map_map at H,
  rw eqn.map_aexpr_compose at H,
  rw ← instantiate_head_N_to_Z at H,
  apply ih_1, rw list.map_map,
  rw eqn.map_aexpr_compose, apply H,
}
end

lemma N_to_Z_sound_eqnd (nvars : ℕ) (xs : list (eqnd ℕ ℕ))
  : eqnd_negation_statement_nonneg nvars (xs.map (eqnd.map_aexpr (aexpr.map coe)) : list (eqnd ℤ ℕ))
  ↔ eqnd_negation_statement nvars xs
:= begin
revert xs,
induction nvars; intros xs; dsimp [eqnd_negation_statement_nonneg, eqnd_negation_statement],
{ induction xs; dsimp [negation_statement_0],
  { reflexivity },
  { rw ih_1,
    rw eqnd_interp_N_Z,
    rw ← int.coe_nat_zero,
  }
},
{ split,
  { intros H x, specialize (H x), rw list.map_map at H,
    rw eqnd.map_aexpr_compose at H,
    rw ← instantiate_head_N_to_Z at H,
    rw ← ih_1, rw list.map_map,
    rw eqnd.map_aexpr_compose, apply H,
    apply int.coe_zero_le
  },
  { intros H x x0,
    specialize (H x.to_nat),
    rw ← ih_1 at H,
    rw list.map_map at H, rw list.map_map,
    rw eqnd.map_aexpr_compose at H, rw eqnd.map_aexpr_compose,
    rw instantiate_head_N_to_Z at H,
    rw Z_nonneg_roundtrip_N at H, assumption, assumption,
  }
}
end

def always_true {A} [decidable_linear_order A] [semiring A]
  (e : eqn A ℕ)
  := ∀ ctxt, e.interp ctxt

def ctxt_extend {A} (f : ℕ → A) (x : A) : ℕ → A
| 0 := x
| (nat.succ n) := f n

lemma aexpr_interp_instantiate_head
  {A} [semiring A] (ctxt : ℕ → A)
  (e : aexpr A ℕ) (x : A)
  : (e.instantiate_head x).interp ctxt
  = e.interp (ctxt_extend ctxt x)
:= begin
induction e; dsimp [aexpr.instantiate_head, aexpr.interp],
{ cases a_1; reflexivity },
{ cases a; reflexivity },
{ reflexivity },
{ rw [ih_1, ih_2] }
end

lemma eqn_interp_instantiate_head
  {A} [semiring A] [decidable_linear_order A] (ctxt : ℕ → A)
  (e : eqn A ℕ) (x : A)
  : (e.map_aexpr (aexpr.instantiate_head x)).interp ctxt
  = e.interp (ctxt_extend ctxt x)
:= begin
induction e; dsimp [eqn.map_aexpr, eqn.interp],
repeat { rw aexpr_interp_instantiate_head },
end

lemma eqnd_interp_instantiate_head
  {A} [linear_ordered_comm_ring A] [decidable_linear_order A] (ctxt : ℕ → A)
  (e : eqnd A ℕ) (x : A)
  : (e.map_aexpr (aexpr.instantiate_head x)).interp ctxt
  = e.interp (ctxt_extend ctxt x)
:= begin
induction e; dsimp [eqnd.map_aexpr, eqnd.interp];
repeat { rw aexpr_interp_instantiate_head },
end

lemma always_true_instantiate_head
  {A} [semiring A] [decidable_linear_order A]
  (e : eqn A ℕ) (H : always_true e) (x : A)
  : always_true (e.map_aexpr (aexpr.instantiate_head x))
:= begin
dsimp [always_true] at *, intros ctxt,
rw eqn_interp_instantiate_head, apply H,
end

lemma eqn_negation_statement_always_true
  {A} [semiring A] [decidable_linear_order A]
  (nvars : ℕ) (xs : list (eqn A ℕ))
  (x : eqn A ℕ) (Hx : always_true x)
  : eqn_negation_statement nvars (x :: xs)
  → eqn_negation_statement nvars xs
:= begin
intros H, revert xs Hx x,
induction nvars;
  dsimp [eqn_negation_statement];
  intros xs x Hx H,
{ dsimp [negation_statement_0] at H,
  apply H, apply Hx },
{ intros x, specialize (H x),
  apply ih_1, tactic.swap, assumption,
  apply always_true_instantiate_head,
  assumption
}
end

lemma nonzero_constraints_nat_no_op (nvars nvars' : ℕ) (xs : list (eqn ℕ ℕ))
  : eqn_negation_statement nvars (nonzero_constraints nvars' ++ xs)
  → eqn_negation_statement nvars xs
:= begin
revert xs;
induction nvars'; dsimp [nonzero_constraints]; intros xs H,
{ apply H },
{ apply ih_1, apply eqn_negation_statement_always_true _ _ _ _ _,
  tactic.rotate 2, assumption,
  dsimp [always_true], intros ctxt,
  dsimp [eqn.interp, aexpr.interp], apply nat.zero_le,
}
end

lemma satisfiable_bool_correct_linear {n : ℕ} (e : list (linear_expr n))
  : satisfiable_bool' e = ff →
    linear_expr_negation_statement e
:= begin
rw ← satisfiable_bool_equiv,
unfold satisfiable_bool,
rw to_bool_ff_iff,
intros H,
revert e,
induction n; intros; dsimp [linear_expr_negation_statement],
{ induction e; dsimp [linear_expr_negation_statement],
  { exfalso, apply H, unfold satisfiable,
    rw vector_nil_exists, constructor,
  },
  { intros H', apply ih_1, intros contra,
    apply H, unfold satisfiable at contra,
    rw vector_nil_exists at contra,
    unfold satisfiable,
    rw vector_nil_exists, constructor;
    assumption, }
},
{ intros x, apply ih_1, intros contra, apply H,
  induction contra with asn Hasn,
  existsi (x :: asn), rw list.map_Forall_iff at Hasn,
  apply list.impl_Forall, assumption,
  intros expr H, dsimp [evaluate, instantiate_head] at H,
  dsimp [evaluate],
  apply le_trans, tactic.swap, apply H_1,
  rw ← add_assoc, apply add_le_add, clear H_1,
  generalize Hys : expr.coef = ys,
  have Hys' := ys.invert_succ, induction Hys',
  rw equiv, rw dot_product_cons,
  rw vector.tail_cons, rw vector.head_cons, simp,
  apply le_refl,
}
end

lemma to_bool_tt_iff (P : Prop) [decP : decidable P]
  : to_bool P = tt ↔ P
:= begin
unfold to_bool, cases decP; dsimp,
split; intros; contradiction,
split; intros H, assumption, reflexivity,
end

lemma  no_vars_nil_interp (e : aexpr ℚ ℕ)
  (H : e.no_big_vars 0)
  : e.interp (λ _, 0) = evaluate (e.interp_expr_context 0) vector.nil
:= begin
dsimp [aexpr.interp_expr_context],
rw vector.nil_of_fn,
rw ← aexpr.to_linear_expr_sound,
induction e; dsimp [aexpr.interp, aexpr.var_map_default];
  dsimp [aexpr.no_big_vars] at H,
{ exfalso, apply nat.not_lt_zero, assumption },
{ reflexivity },
{ reflexivity },
{ induction H with H1 H2,
  specialize (ih_1 H1), specialize (ih_2 H2),
  rw [ih_1, ih_2], }
end

lemma no_big_vars_instantiate_head {n : ℕ} {e : aexpr ℚ ℕ} (x : ℚ)
  : aexpr.no_big_vars (nat.succ n) e
  → (e.instantiate_head x).no_big_vars n
:= begin
induction e with;
  dsimp [aexpr.no_big_vars, aexpr.instantiate_head];
  intros H,
{ induction a_1; dsimp [aexpr.instantiate_head, aexpr.no_big_vars],
  { constructor },
  { rw ← nat.succ_lt_succ_iff, assumption }
},
{ induction a; dsimp [aexpr.instantiate_head, aexpr.no_big_vars],
  { constructor },
  { rw ← nat.succ_lt_succ_iff, assumption }
},
{ assumption },
{ induction H with H1 H2,
  split, apply ih_1, assumption, apply ih_2, assumption,
}
end

lemma instantiate_head_var_0 (n : ℕ) (a x : ℚ)
  (i : fin n.succ) (Hi : i.val = 0)
  : instantiate_head (var a i) x = const n (a * x)
:= begin
dsimp [var, const, instantiate_head], f_equal,
{ dsimp [vector.generate], rw vector.tail_cons,
  rw ← vector.generate_const_repeat,
  f_equal, apply funext, intros x,
  dsimp [function.comp], rw Hi,
  rw (if_neg), contradiction,
 },
{ dsimp [vector.generate], rw vector.head_cons,
  rw (if_pos), simp, assumption,
}
end

lemma instantiate_head_var_succ {n : ℕ} (a x : ℚ)
  (i : fin n.succ) (H : i ≠ 0)
  :
  instantiate_head (var a i) x = var a (fin.pred i H)
:= begin
dsimp [var, const, instantiate_head], f_equal,
{ dsimp [vector.generate], rw vector.tail_cons,
  f_equal, apply funext, intros x,
  dsimp [function.comp], rw (ite_iff (fin.succ_pred_equiv _ _ _)),
 },
{ dsimp [vector.generate], rw vector.head_cons,
  rw (if_neg), simp, intros contra, apply H,
  apply fin.val_inj, rw contra, reflexivity,
}
end

lemma instantiate_head_commutes {n : ℕ} (x : ℚ)
  (e : aexpr ℚ ℕ)
  : (e.interp_expr_context n.succ).instantiate_head x
  = (e.instantiate_head x).interp_expr_context n
:= begin
dsimp [aexpr.interp_expr_context],
induction e; dsimp [aexpr.instantiate_head
  , aexpr.var_map_default],
{ destruct (nat_to_fin_option n.succ a_1),
  { intros Hnone, rw Hnone, dsimp [aexpr.var_map_default],
    cases a_1; dsimp [aexpr.instantiate_head],
    dsimp [nat_to_fin_option] at Hnone,
    rw (dif_pos (nat.zero_lt_succ _)) at Hnone, contradiction,
    dsimp [aexpr.var_map_default],
    apply_in Hnone nat_to_fin_option_pred_none,
    rw Hnone,
    dsimp [aexpr.var_map_default],
    dsimp [aexpr.to_linear_expr],
    dsimp [instantiate_head, const],
    repeat { rw vector.repeat_unfold },
    rw vector.head_cons, rw vector.tail_cons,
    f_equal, simp, },
  { intros i Hi, rw Hi, dsimp [aexpr.var_map_default],
    cases a_1; dsimp [aexpr.instantiate_head, aexpr.var_map_default],
    { dsimp [aexpr.to_linear_expr],
      rw instantiate_head_var_0,
      apply nat_to_fin_option_val, assumption,
    },
    { rw nat_to_fin_option_pred_some, tactic.swap, assumption,
      dsimp [aexpr.var_map_default],
      dsimp [aexpr.to_linear_expr],
      apply instantiate_head_var_succ,
    }
  },
},
{ destruct (nat_to_fin_option n.succ a),
  { intros Hnone, rw Hnone, dsimp [aexpr.var_map_default],
    cases a; dsimp [aexpr.instantiate_head],
    dsimp [nat_to_fin_option] at Hnone,
    rw (dif_pos (nat.zero_lt_succ _)) at Hnone, contradiction,
    dsimp [aexpr.var_map_default],
    apply_in Hnone nat_to_fin_option_pred_none,
    rw Hnone,
    dsimp [aexpr.var_map_default],
    dsimp [aexpr.to_linear_expr],
    dsimp [instantiate_head, const],
    repeat { rw vector.repeat_unfold },
    rw vector.head_cons, rw vector.tail_cons,
    f_equal, simp, },
  { intros i Hi, rw Hi, dsimp [aexpr.var_map_default],
    cases a; dsimp [aexpr.instantiate_head, aexpr.var_map_default],
    { dsimp [aexpr.to_linear_expr],
      rw instantiate_head_var_0,
      rw [mul_comm, mul_one],
      apply nat_to_fin_option_val, assumption,
    },
    { rw nat_to_fin_option_pred_some, tactic.swap, assumption,
      dsimp [aexpr.var_map_default],
      dsimp [aexpr.to_linear_expr],
      apply instantiate_head_var_succ,
    }
  },
},
{ dsimp [instantiate_head, aexpr.to_linear_expr, const],
  repeat { rw vector.repeat_unfold }, rw vector.tail_cons,
  rw vector.head_cons, f_equal, simp, },
{ dsimp [aexpr.to_linear_expr],
  rw instantiate_head_add_expr, f_equal; assumption, }
end

lemma instantiate_head_commutes_list {n : ℕ} (x : ℚ)
  (es : list (aexpr ℚ ℕ))
  : list.map (λ e, instantiate_head e x) (interp_list_exprs es (nat.succ n))
  = list.map (λ e, aexpr.interp_expr_context (aexpr.instantiate_head x e) n) es
:= begin
dsimp [interp_list_exprs, list.map],
rw list.map_map, f_equal, dsimp [function.comp],
apply funext, intros e,
rw instantiate_head_commutes,
end

lemma linear_implies_aexpr_negation (es : list (aexpr ℚ ℕ))
  (nvars : ℕ)
  (H : list.Forall (λ (x : aexpr ℚ ℕ), aexpr.no_big_vars nvars x) es)
  : linear_expr_negation_statement (interp_list_exprs es nvars)
  → aexpr_negation_statement nvars es
:= begin
revert es,
induction nvars;
  dsimp [linear_expr_negation_statement, aexpr_negation_statement];
  intros,
{ induction es; dsimp [negation_statement_0],
    dsimp [interp_list_exprs, negation_statement_0] at a,
  { assumption },
  { intros H', apply_in H list.Forall_invert,
    dsimp at H, induction H with H1 H2, apply ih_1, assumption,
    apply a, dsimp, rw ← no_vars_nil_interp; assumption
  }
},
{ apply ih_1; clear ih_1, apply list.map_Forall,
  apply list.impl_Forall, assumption,
  intros e He, apply no_big_vars_instantiate_head, assumption,
  specialize (a_1 x), unfold interp_list_exprs,
  rw list.map_map, dsimp [function.comp],
  rw ← instantiate_head_commutes_list; assumption,
}
end

lemma satisfiable_bool_correct  (es : list (aexpr ℚ ℕ))
  (nvars : ℕ)
  : list.band (es.map (aexpr.no_big_vars_bool nvars)) = tt →
    satisfiable_bool' (interp_list_exprs es nvars) = ff →
    aexpr_negation_statement nvars es
:= begin
rw aexpr.no_big_vars_equiv,
rw ← to_bool_Forall,
rw to_bool_tt_iff,
intros H1 H2, apply linear_implies_aexpr_negation,
assumption,
apply satisfiable_bool_correct_linear, assumption,
end

lemma satisfiable_bool_correct_eqn  (es : list (eqn ℚ ℕ))
  (nvars : ℕ)
  : list.band ((es.map eqn.to_aexpr).map (aexpr.no_big_vars_bool nvars)) = tt →
    satisfiable_bool' (interp_list_exprs (es.map eqn.to_aexpr) nvars) = ff →
    eqn_negation_statement nvars es
:= begin
intros H H',
apply eqn_to_aexpr_sound,
apply satisfiable_bool_correct; assumption,
end

lemma satisfiable_bool_correct_eqn_Z  (es : list (eqn ℤ ℕ))
  (nvars : ℕ)
  : list.band (((es.map (eqn.map_aexpr (aexpr.map coe)) : list (eqn ℚ ℕ)).map eqn.to_aexpr).map (aexpr.no_big_vars_bool nvars)) = tt →
    satisfiable_bool' (interp_list_exprs ((es.map (eqn.map_aexpr (aexpr.map coe))).map eqn.to_aexpr) nvars) = ff →
    eqn_negation_statement nvars es
:= begin
intros H H',
apply Z_to_Q_sound_eqn,
apply eqn_to_aexpr_sound,
apply satisfiable_bool_correct; assumption,
end

def eqn_Z_to_aexprs (es : list (eqnd ℤ ℕ))
  : list (aexpr ℚ ℕ)
  := ((eqnd_to_aexprs es).map (eqn.map_aexpr (aexpr.map coe))).map eqn.to_aexpr

lemma satisfiable_bool_correct_eqn_Z' (es : list (eqnd ℤ ℕ))
  (nvars : ℕ)
  : list.band ((eqn_Z_to_aexprs es).map (aexpr.no_big_vars_bool nvars)) = tt →
    satisfiable_bool' (interp_list_exprs (eqn_Z_to_aexprs es) nvars) = ff →
    eqnd_negation_statement nvars es
:= begin
intros H H',
rw ← eqnd_to_eqn_sound,
apply satisfiable_bool_correct_eqn_Z; assumption,
end

def eqn_N_to_aexprs (nvars : ℕ) (es : list (eqnd ℕ ℕ))
  : list (aexpr ℚ ℕ)
  := (((nonzero_constraints nvars ++ eqnd_to_aexprs es).map
       (eqn.map_aexpr (aexpr.map coe)) : list (eqn ℤ ℕ)).map
       (eqn.map_aexpr (aexpr.map coe)) : list (eqn ℚ ℕ)).map
        eqn.to_aexpr

lemma satisfiable_bool_correct_eqn_N (es : list (eqnd ℕ ℕ))
  (nvars : ℕ)
  : list.band ((eqn_N_to_aexprs nvars es).map (aexpr.no_big_vars_bool nvars)) = tt →
    satisfiable_bool' (interp_list_exprs (eqn_N_to_aexprs nvars es) nvars) = ff →
    eqnd_negation_statement nvars es
:= begin
intros H H',
rw ← eqnd_to_eqn_sound nvars es,
apply nonzero_constraints_nat_no_op,
apply N_to_Z_sound_eqn,
apply satisfiable_bool_correct_eqn_Z;
assumption,
end

open tactic

/- In this section, we define meta defs to create
   the reflective tactic that uses the Fourier-Motzkin
   decision procedure.
-/
namespace fourier

/- This definition "interns" variables. Given a list of expressions
   of expressions that have already been interned as variables,
   and a new expression to intern, we check to see if the expression
   has already been seen. If so, we don't need to add the new expression,
   and return the index of that expression in the list. If the expression
   hasn't been seen before, we concatenate it to the end of the list.
   Since `list.index_of` returns the length of the list if the element
   wasn't found in the list, the result will in fact give the index
   of the newly interned expression in the new list of interned
   expressions.
-/
meta def intern_var (xs : list expr) (e : expr) : list expr × ℕ
  := (if e ∈ xs then xs else xs ++ [e], xs.index_of e)

/-- Attempt to reify an expression as a constant numeric literal,
    returning `none` if the expression is not a constant literal.
-/
meta def reify_constant_helper
  : expr → option (expr ff)
| `(@@has_one.one %%TT %%Tc) := pure (``(has_one.one %%TT))
| `(@@has_zero.zero %%TT %%Tc) := pure (``(has_zero.zero %%TT))
| `(bit0 %%x) := do
  x' ← reify_constant_helper x,
  pure (``(bit0 %%x))
| `(has_neg.neg %%x) := do
  x' ← reify_constant_helper x,
  pure (``(has_neg.neg %%x))
| `(bit1 %%x) := do
  x' ← reify_constant_helper x,
  pure (``(bit1 %%x))
| _ := none

/-- Reify an arithmetic expression. -/
meta def reify_aexpr_helper
  : list expr → expr → tactic (expr ff × list expr)
| xs `(%%P + %%Q) := do
    (P', xs') ← reify_aexpr_helper xs P,
    (Q', xs'') ← reify_aexpr_helper xs' Q,
    pure (``(aexpr.add %%P' %%Q'), xs'')
| xs `(%%P * %%Q) := do
  P' ← reify_constant_helper P,
  let (xs', n) := intern_var xs Q in
  pure (``(aexpr.var %%P' %%(n.reflect)), xs')
| xs P := (do
  C ← reify_constant_helper P,
  pure (``(aexpr.const %%C), xs)
  ) <|>
  let (xs', n) := intern_var xs P in pure (``(aexpr.var1 %%(n.reflect)), xs')

/-- Reify a hypothesis in context into the
    `eqn` expression datatype
-/
meta def reify_eqn_helper (num_ty : expr)
  : list expr → expr → tactic (option (expr ff × list expr))
| xs `(@has_le.le %%ty %%tyc %%ee %%ee') :=
    if ty = num_ty then do
      (e, xs') ← reify_aexpr_helper xs ee,
      (e', xs'') ← reify_aexpr_helper xs' ee',
      pure (``(eqn.le %%e %%e'), xs'')
    else pure none
| xs other := pure none

meta def build_eqnd_formula (num_ty : expr) (xs : list expr)
  (ty ee ee' : expr) (op : expr) : tactic (option (expr ff × list expr))
  := if ty = num_ty then do
      (e, xs') ← reify_aexpr_helper xs ee,
      (e', xs'') ← reify_aexpr_helper xs' ee',
      pure (``(eqnd.mk %%op %%e %%e'), xs'')
    else pure none

/-- Reify a hypothesis in context into the
    `eqnd` expression datatype (suitable for ℕ or ℤ)
-/
meta def reify_eqnd_helper (num_ty : expr) (xs : list expr)
  : expr → tactic (option (expr ff × list expr))
| `(@has_le.le %%ty %%tyc %%ee %%ee') :=
  build_eqnd_formula num_ty xs ty ee ee' `(cmp_op.le)
| `(@has_lt.lt %%ty %%tyc %%ee %%ee') :=
  build_eqnd_formula num_ty xs ty ee ee' `(cmp_op.lt)
| `(@eq %%ty %%ee %%ee') :=
  build_eqnd_formula num_ty xs ty ee ee' `(cmp_op.eq)
| `(@gt %%ty %%tyc %%ee %%ee') :=
  build_eqnd_formula num_ty xs ty ee ee' `(cmp_op.gt)
| `(@ge %%ty %%tyc %%ee %%ee') :=
  build_eqnd_formula num_ty xs ty ee ee' `(cmp_op.ge)
| other := pure none

meta def reify_all_helper (f : list expr → expr → tactic (option (expr ff × list expr)))
  : list expr → list expr → tactic (list (expr ff) × list expr)
| ctxt [] := pure ([], ctxt)
| ctxt (x :: xs) := do
  r ← f ctxt x,
  match r with
  | some (x', ctxt') := do
    (xs', ctxt'') ← reify_all_helper ctxt' xs,
    pure (x' :: xs', ctxt'')
  | none := reify_all_helper ctxt xs
  end

meta def my_reify (f : list expr → expr → tactic (option (expr ff × list expr))) (es : list expr)
  : tactic (list (expr ff) × list expr)
  := reify_all_helper f [] es

meta def make_list : list expr → expr ff
| [] := ``(list.nil)
| (x :: xs) := ``(list.cons %%x %%(make_list xs))

meta def make_nat : ℕ → expr
| 0 := `(0)
| (nat.succ n) := `(nat.succ %%(make_nat n))

meta def reify_hyps_numvars (f : list expr → expr → tactic (option (expr ff × list expr)))
   : tactic (expr × expr) := do
    ctx ← local_context,
    ctx_types ← ctx.mmap infer_type,
    (hyps, ctxt) ← my_reify f ctx_types,
    hyps' ← mmap i_to_expr hyps,
    let ctxt' := make_list ctxt,
    let num_vars := make_nat ctxt.length,
    let hyps'' := make_list hyps',
    hyps''' ← i_to_expr hyps'',
    return (hyps''', num_vars)

meta def Q_core : tactic unit := do
    (hyps, num_vars) ← reify_hyps_numvars (reify_eqn_helper `(ℚ)),
    ap_expr ← i_to_expr ``(satisfiable_bool_correct_eqn %%hyps %%num_vars),
    tactic.apply ap_expr

meta def Z_core : tactic unit := do
    (hyps, num_vars) ← reify_hyps_numvars (reify_eqnd_helper `(ℤ)),
    ap_expr ← i_to_expr ``(satisfiable_bool_correct_eqn_Z' %%hyps %%num_vars),
    tactic.apply ap_expr

meta def N_core : tactic unit := do
    (hyps, num_vars) ← reify_hyps_numvars (reify_eqnd_helper `(ℕ)),
    ap_expr ← i_to_expr ``(satisfiable_bool_correct_eqn_N %%hyps %%num_vars),
    tactic.apply ap_expr

meta def solve (t : tactic unit) : tactic unit := do
  t,
  all_goals (reflexivity <|> assumption)

end fourier

/-- A collection of example uses of the Fourier tactics tactic. -/
lemma my_lemma
  (x y z : ℚ)
  (Hx : x + 3 ≤ 0)
  (Hy : -5 ≤ 2 * x)
  (Hz : (0 : ℚ) ≤ 0)
  : false
:= by fourier.solve fourier.Q_core

lemma my_lemma2
  (x y z : ℤ)
  (Hx : x + 3 ≤ 0)
  (Hy : -2 * x ≤ 5)
  (Hz : (0 : ℤ) ≤ 0)
  : false
:= by fourier.solve fourier.Z_core

lemma my_lemma3
  (x y z : ℤ)
  (Hx : x + 3 < 0)
  (Hy : -2 * x ≤ 5)
  (Hz : (0 : ℤ) ≤ 0)
  : false
:= by fourier.solve fourier.Z_core

lemma my_lemma4
  (x : ℤ)
  (Hx : x < 3)
  (Hy : x ≥ 3)
  : false
:= by fourier.solve fourier.Z_core

lemma my_lemma5
  (n : ℕ)
  (H : n < 0)
  : false
:= by fourier.solve fourier.N_core

lemma my_lemma6
  (m n k : ℕ)
  (H : m + n = k)
  (H' : k < n + m)
  : false
:= by fourier.solve fourier.N_core

lemma de_morgan (P Q : Prop)
  [decP : decidable P] [decQ : decidable Q]
  : P ∧ Q
  ↔ ¬ (¬ P ∨ ¬ Q)
:= begin
split; intros H,
{ induction H with H1 H2,
  intros contra, induction contra with HP HQ;
  contradiction,
},
{ induction decP; induction decQ;
  try { split; assumption };
  exfalso; apply H,
  left, assumption, left, assumption,
  right, assumption,
}
end

lemma my_lemma7
  (m n : ℕ)
  (H : m + n ≤ n)
  : m = 0
:= begin
rw le_antisymm_iff,
rw de_morgan, repeat { rw ← lt_iff_not_ge },
intros contra, induction contra with contra contra;
fourier.solve fourier.N_core
end


import Mathlib.Tactic.Basic

/-!
## Structured Proofs

As a first example, consider the following structured proof:
-/
lemma t1 : ∀ a b : Prop, a → b → a :=
  fun {a b : Prop} (ha : a) (hb : b) =>
  show a from ha

/-!
Each variable bound by a ∀-quantifier and each assumption of an implication is introduced explicitly
in the proof using a lambda function with parameters. Several variables or hypotheses can be introduced
simultaneously. We will often omit the types of variables, especially when they can be guessed from
their names; however, we will usually spell out the propositions and put them one per line, to
increase readability—which is, after all, one of the main potential advantages of the structured
style. The `show . . . from` command at the end repeats the proposition to prove, for the sake of
readability, and gives the proof after the keyword `from`. The goal at this point is
`a b : Prop, ha : a, hb : b ⊢ a`.

Informally, we could write the proof as follows:

- Given some propositions `a` and `b`.
- And given `(ha) a` and `(hb) b` are true.
- We must show `a`. This follows trivially from `ha`.

Some authors would insert some qualifiers such as “arbitrary but fixed” in front
of “propositions,” especially in textbooks for first-year bachelor students, or they
would write “Let `a` and `b` be some propositions.” All these variants are equivalent.
And instead of “∎” some authors would write “QED” to conclude the proof.

The Lean proof above is atypical in that the goal’s target appears among the hypotheses. Usually, we
must perform some intermediate reasoning steps, essentially of the form “from such-and-such, we have
so-and-so.” In Lean, each intermediate step takes the form of a `have` command, as in the following
example:

-/
lemma prop_comp (a b c : Prop) (hab : a → b) (hbc : b → c) :
  a → c :=
  fun (ha : a) =>
  have hb : b :=
  hab ha
  have hc : c :=
  hbc hb
  show c from
  hc
/-!
Informally:

- Assume `(ha) a` is true.
- From `ha` and `hab`, we have `(hb) b`.
- From `hb` and `hbc`, we have `(hc) c`.
- We must show `c`. This follows trivially from `hc`.

Notice that this is a forward proof: It progresses one theorem at a time from the hypothesis `a` to
the desired theorem `c`.

In general, the above proof skeleton simply repeats the lemma’s statement. In between, as many
`have` commands as desired may appear, depending on how detailed we want the argument to be. Details
can increase readability, but providing too many details can overwhelm even the most persistent
reader.

The `have` command has a similar syntax to `lemma` but appears inside a structured proof.
We can think of a `have` as a definition. In `have hb : b := hab ha`, the
right-hand side `hab ha` is a proof term for `b`, and the left-hand side `hb` is defined
as a synonym for that proof term. From that point on, `hb` and `hab ha` can be used
interchangeably. Since `hb` and `hc` are used only once and their proofs are very
short, experts would tend to inline their proofs, replacing `hc` by `hbc hb` and `hb` by
`hab ha`, yielding

-/
lemma prop_comp₂ (a b c : Prop) (hab : a → b) (hbc : b → c) :
  a → c :=
fun (ha : a) =>
show c from
  hbc (hab ha)
/-!

-- BUGBUG : delete the following?

A typical structured proof has the following fix–assume–have–show format:
```lean
lemma l :
∀(c1 : σ1) . . . (cl : σl), P1 → · · · → Pm → R :=
fix (c1 : σ1) . . . (cl : σl),
assume h1 : P1,
...
assume hm : Pm,
have k1 : Q1 :=
. . .,
...
have kn : Qn :=
. . .,
show R, from
. . .
```
-/


/-
Copyright (c) 2022 Jireh Loreaux. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jireh Loreaux

! This file was ported from Lean 3 source module algebra.star.pointwise
! leanprover-community/mathlib commit 30413fc89f202a090a54d78e540963ed3de0056e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Star.Basic
import Mathlib.Data.Set.Finite
import Mathlib.Data.Set.Pointwise.Basic

/-!
# Pointwise star operation on sets

This file defines the star operation pointwise on sets and provides the basic API.
Besides basic facts about about how the star operation acts on sets (e.g., `(s ∩ t)⋆ = s⋆ ∩ t⋆`),
if `s t : Set α`, then under suitable assumption on `α`, it is shown

* `(s + t)⋆ = s⋆ + t⋆`
* `(s * t)⋆ = t⋆ + s⋆`
* `(s⁻¹)⋆ = (s⋆)⁻¹`
-/

namespace Set

open Pointwise

local postfix:max "⋆" => star

variable {α : Type _} {s t : Set α} {a : α}

/-- The set `(star s : Set α)` is defined as `{x | star x ∈ s}` in locale `pointwise`.
In the usual case where `star` is involutive, it is equal to `{star s | x ∈ s}`, see
`Set.image_star`. -/
protected def star [Star α] : Star (Set α) := ⟨preimage Star.star⟩
#align set.has_star Set.star

scoped[Pointwise] attribute [instance] Set.star

@[simp]
theorem star_empty [Star α] : (∅ : Set α)⋆ = ∅ := rfl
#align set.star_empty Set.star_empty

@[simp]
theorem star_univ [Star α] : (univ : Set α)⋆ = univ := rfl
#align set.star_univ Set.star_univ

@[simp]
theorem nonempty_star [InvolutiveStar α] {s : Set α} : s⋆.Nonempty ↔ s.Nonempty :=
  star_involutive.surjective.nonempty_preimage
#align set.nonempty_star Set.nonempty_star

theorem Nonempty.star [InvolutiveStar α] {s : Set α} (h : s.Nonempty) : s⋆.Nonempty :=
  nonempty_star.2 h
#align set.nonempty.star Set.Nonempty.star

@[simp]
theorem mem_star [Star α] : a ∈ s⋆ ↔ a⋆ ∈ s := Iff.rfl
#align set.mem_star Set.mem_star

theorem star_mem_star [InvolutiveStar α] : a⋆ ∈ s⋆ ↔ a ∈ s := by simp only [mem_star, star_star]
#align set.star_mem_star Set.star_mem_star

@[simp]
theorem star_preimage [Star α] : Star.star ⁻¹' s = s⋆ := rfl
#align set.star_preimage Set.star_preimage

@[simp]
theorem image_star [InvolutiveStar α] : Star.star '' s = s⋆ := by
  simp only [← star_preimage]
  rw [image_eq_preimage_of_inverse] <;> intro <;> simp only [star_star]
#align set.image_star Set.image_star

@[simp]
theorem inter_star [Star α] : (s ∩ t)⋆ = s⋆ ∩ t⋆ := preimage_inter
#align set.inter_star Set.inter_star

@[simp]
theorem union_star [Star α] : (s ∪ t)⋆ = s⋆ ∪ t⋆ := preimage_union
#align set.union_star Set.union_star

@[simp]
theorem interᵢ_star {ι : Sort _} [Star α] (s : ι → Set α) : (⋂ i, s i)⋆ = ⋂ i, (s i)⋆ :=
  preimage_interᵢ
#align set.Inter_star Set.interᵢ_star

@[simp]
theorem unionᵢ_star {ι : Sort _} [Star α] (s : ι → Set α) : (⋃ i, s i)⋆ = ⋃ i, (s i)⋆ :=
  preimage_unionᵢ
#align set.Union_star Set.unionᵢ_star

@[simp]
theorem compl_star [Star α] : (sᶜ)⋆ = s⋆ᶜ := preimage_compl
#align set.compl_star Set.compl_star

-- Porting note: add noncomputable to instance
@[simp]
noncomputable instance [InvolutiveStar α] : InvolutiveStar (Set α)
    where
  star := Star.star
  star_involutive s := by simp only [← star_preimage, preimage_preimage, star_star, preimage_id']

@[simp]
theorem star_subset_star [InvolutiveStar α] {s t : Set α} : s⋆ ⊆ t⋆ ↔ s ⊆ t :=
  Equiv.star.surjective.preimage_subset_preimage_iff
#align set.star_subset_star Set.star_subset_star

theorem star_subset [InvolutiveStar α] {s t : Set α} : s⋆ ⊆ t ↔ s ⊆ t⋆ := by
  rw [← star_subset_star, star_star]
#align set.star_subset Set.star_subset

theorem Finite.star [InvolutiveStar α] {s : Set α} (hs : s.Finite) : s⋆.Finite :=
  hs.preimage <| star_injective.injOn _
#align set.finite.star Set.Finite.star

theorem star_singleton {β : Type _} [InvolutiveStar β] (x : β) : ({x} : Set β)⋆ = {x⋆} := by
  ext1 y
  rw [mem_star, mem_singleton_iff, mem_singleton_iff, star_eq_iff_star_eq, eq_comm]
#align set.star_singleton Set.star_singleton

protected

protected theorem star_add [AddMonoid α] [StarAddMonoid α] (s t : Set α) : (s + t)⋆ = s⋆ + t⋆ := by
 simp_rw [← image_star, ← image2_add, image_image2, image2_image_left, image2_image_right,
   star_add]
#align set.star_add Set.star_add

@[simp]
instance [Star α] [TrivialStar α] : TrivialStar (Set α) where
  star_trivial s := by
    rw [← star_preimage]
    ext1
    simp [star_trivial]

protected theorem star_inv [Group α] [StarSemigroup α] (s : Set α) : s⁻¹⋆ = s⋆⁻¹ := by
  ext
  simp only [mem_star, mem_inv, star_inv]
#align set.star_inv Set.star_inv

protected theorem star_inv' [DivisionSemiring α] [StarRing α] (s : Set α) : s⁻¹⋆ = s⋆⁻¹ := by
  ext
  simp only [mem_star, mem_inv, star_inv']
#align set.star_inv' Set.star_inv'

end Set


/-
Copyright (c) 2021 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Ines Wright, Joachim Breitner
-/

import group_theory.quotient_group
import group_theory.solvable
import group_theory.p_group
import group_theory.sylow
import data.nat.factorization
import tactic.tfae

/-!

# Nilpotent groups

An API for nilpotent groups, that is, groups for which the upper central series
reaches `⊤`.

## Main definitions

Recall that if `H K : subgroup G` then `⁅H, K⁆ : subgroup G` is the subgroup of `G` generated
by the commutators `hkh⁻¹k⁻¹`. Recall also Lean's conventions that `⊤` denotes the
subgroup `G` of `G`, and `⊥` denotes the trivial subgroup `{1}`.

* `upper_central_series G : ℕ → subgroup G` : the upper central series of a group `G`.
     This is an increasing sequence of normal subgroups `H n` of `G` with `H 0 = ⊥` and
     `H (n + 1) / H n` is the centre of `G / H n`.
* `lower_central_series G : ℕ → subgroup G` : the lower central series of a group `G`.
     This is a decreasing sequence of normal subgroups `H n` of `G` with `H 0 = ⊤` and
     `H (n + 1) = ⁅H n, G⁆`.
* `is_nilpotent` : A group G is nilpotent if its upper central series reaches `⊤`, or
    equivalently if its lower central series reaches `⊥`.
* `nilpotency_class` : the length of the upper central series of a nilpotent group.
* `is_ascending_central_series (H : ℕ → subgroup G) : Prop` and
* `is_descending_central_series (H : ℕ → subgroup G) : Prop` : Note that in the literature
    a "central series" for a group is usually defined to be a *finite* sequence of normal subgroups
    `H 0`, `H 1`, ..., starting at `⊤`, finishing at `⊥`, and with each `H n / H (n + 1)`
    central in `G / H (n + 1)`. In this formalisation it is convenient to have two weaker predicates
    on an infinite sequence of subgroups `H n` of `G`: we say a sequence is a *descending central
    series* if it starts at `G` and `⁅H n, ⊤⁆ ⊆ H (n + 1)` for all `n`. Note that this series
    may not terminate at `⊥`, and the `H i` need not be normal. Similarly a sequence is an
    *ascending central series* if `H 0 = ⊥` and `⁅H (n + 1), ⊤⁆ ⊆ H n` for all `n`, again with no
    requirement that the series reaches `⊤` or that the `H i` are normal.

## Main theorems

`G` is *defined* to be nilpotent if the upper central series reaches `⊤`.
* `nilpotent_iff_finite_ascending_central_series` : `G` is nilpotent iff some ascending central
    series reaches `⊤`.
* `nilpotent_iff_finite_descending_central_series` : `G` is nilpotent iff some descending central
    series reaches `⊥`.
* `nilpotent_iff_lower` : `G` is nilpotent iff the lower central series reaches `⊥`.
* The `nilpotency_class` can likeways be obtained from these equivalent
  definitions, see `least_ascending_central_series_length_eq_nilpotency_class`,
  `least_descending_central_series_length_eq_nilpotency_class` and
  `lower_central_series_length_eq_nilpotency_class`.
* If `G` is nilpotent, then so are its subgroups, images, quotients and preimages.
  Binary and finite products of nilpotent groups are nilpotent.
  Infinite products are nilpotent if their nilpotent class is bounded.
  Corresponding lemmas about the `nilpotency_class` are provided.
* The `nilpotency_class` of `G ⧸ center G` is given explicitly, and an induction principle
  is derived from that.
* `is_nilpotent.to_is_solvable`: If `G` is nilpotent, it is solvable.

## Warning

A "central series" is usually defined to be a finite sequence of normal subgroups going
from `⊥` to `⊤` with the property that each subquotient is contained within the centre of
the associated quotient of `G`. This means that if `G` is not nilpotent, then
none of what we have called `upper_central_series G`, `lower_central_series G` or
the sequences satisfying `is_ascending_central_series` or `is_descending_central_series`
are actually central series. Note that the fact that the upper and lower central series
are not central series if `G` is not nilpotent is a standard abuse of notation.

-/

open subgroup

section with_group

variables {G : Type*} [group G] (H : subgroup G) [normal H]

/-- If `H` is a normal subgroup of `G`, then the set `{x : G | ∀ y : G, x*y*x⁻¹*y⁻¹ ∈ H}`
is a subgroup of `G` (because it is the preimage in `G` of the centre of the
quotient group `G/H`.)
-/
def upper_central_series_step : subgroup G :=
{ carrier := {x : G | ∀ y : G, x * y * x⁻¹ * y⁻¹ ∈ H},
  one_mem' := λ y, by simp [subgroup.one_mem],
  mul_mem' := λ a b ha hb y, begin
    convert subgroup.mul_mem _ (ha (b * y * b⁻¹)) (hb y) using 1,
    group,
  end,
  inv_mem' := λ x hx y, begin
    specialize hx y⁻¹,
    rw [mul_assoc, inv_inv] at ⊢ hx,
    exact subgroup.normal.mem_comm infer_instance hx,
  end }

lemma mem_upper_central_series_step (x : G) :
  x ∈ upper_central_series_step H ↔ ∀ y, x * y * x⁻¹ * y⁻¹ ∈ H := iff.rfl

open quotient_group

/-- The proof that `upper_central_series_step H` is the preimage of the centre of `G/H` under
the canonical surjection. -/
lemma upper_central_series_step_eq_comap_center :
  upper_central_series_step H = subgroup.comap (mk' H) (center (G ⧸ H)) :=
begin
  ext,
  rw [mem_comap, mem_center_iff, forall_coe],
  apply forall_congr,
  intro y,
  rw [coe_mk', ←quotient_group.coe_mul, ←quotient_group.coe_mul, eq_comm, eq_iff_div_mem,
    div_eq_mul_inv, mul_inv_rev, mul_assoc],
end

instance : normal (upper_central_series_step H) :=
begin
  rw upper_central_series_step_eq_comap_center,
  apply_instance,
end

variable (G)

/-- An auxiliary type-theoretic definition defining both the upper central series of
a group, and a proof that it is normal, all in one go. -/
def upper_central_series_aux : ℕ → Σ' (H : subgroup G), normal H
| 0 := ⟨⊥, infer_instance⟩
| (n + 1) := let un := upper_central_series_aux n, un_normal := un.2 in
   by exactI ⟨upper_central_series_step un.1, infer_instance⟩

/-- `upper_central_series G n` is the `n`th term in the upper central series of `G`. -/
def upper_central_series (n : ℕ) : subgroup G := (upper_central_series_aux G n).1

instance (n : ℕ) : normal (upper_central_series G n) := (upper_central_series_aux G n).2

@[simp] lemma upper_central_series_zero : upper_central_series G 0 = ⊥ := rfl

@[simp] lemma upper_central_series_one : upper_central_series G 1 = center G :=
begin
  ext,
  simp only [upper_central_series, upper_central_series_aux, upper_central_series_step, center,
    set.center, mem_mk, mem_bot, set.mem_set_of_eq],
  exact forall_congr (λ y, by rw [mul_inv_eq_one, mul_inv_eq_iff_eq_mul, eq_comm]),
end

/-- The `n+1`st term of the upper central series `H i` has underlying set equal to the `x` such
that `⁅x,G⁆ ⊆ H n`-/
lemma mem_upper_central_series_succ_iff (n : ℕ) (x : G) :
  x ∈ upper_central_series G (n + 1) ↔
  ∀ y : G, x * y * x⁻¹ * y⁻¹ ∈ upper_central_series G n := iff.rfl

-- is_nilpotent is already defined in the root namespace (for elements of rings).
/-- A group `G` is nilpotent if its upper central series is eventually `G`. -/
class group.is_nilpotent (G : Type*) [group G] : Prop :=
(nilpotent [] : ∃ n : ℕ, upper_central_series G n = ⊤)

open group

variable {G}

/-- A sequence of subgroups of `G` is an ascending central series if `H 0` is trivial and
  `⁅H (n + 1), G⁆ ⊆ H n` for all `n`. Note that we do not require that `H n = G` for some `n`. -/
def is_ascending_central_series (H : ℕ → subgroup G) : Prop :=
  H 0 = ⊥ ∧ ∀ (x : G) (n : ℕ), x ∈ H (n + 1) → ∀ g, x * g * x⁻¹ * g⁻¹ ∈ H n

/-- A sequence of subgroups of `G` is a descending central series if `H 0` is `G` and
  `⁅H n, G⁆ ⊆ H (n + 1)` for all `n`. Note that we do not requre that `H n = {1}` for some `n`. -/
def is_descending_central_series (H : ℕ → subgroup G) := H 0 = ⊤ ∧
  ∀ (x : G) (n : ℕ), x ∈ H n → ∀ g, x * g * x⁻¹ * g⁻¹ ∈ H (n + 1)

/-- Any ascending central series for a group is bounded above by the upper central series. -/
lemma ascending_central_series_le_upper (H : ℕ → subgroup G) (hH : is_ascending_central_series H) :
  ∀ n : ℕ, H n ≤ upper_central_series G n
| 0 := hH.1.symm ▸ le_refl ⊥
| (n + 1) := begin
  intros x hx,
  rw mem_upper_central_series_succ_iff,
  exact λ y, ascending_central_series_le_upper n (hH.2 x n hx y),
end

variable (G)

/-- The upper central series of a group is an ascending central series. -/
lemma upper_central_series_is_ascending_central_series :
  is_ascending_central_series (upper_central_series G) :=
⟨rfl, λ x n h, h⟩

lemma upper_central_series_mono : monotone (upper_central_series G) :=
begin
  refine monotone_nat_of_le_succ _,
  intros n x hx y,
  rw [mul_assoc, mul_assoc, ← mul_assoc y x⁻¹ y⁻¹],
  exact mul_mem (upper_central_series G n) hx
    (normal.conj_mem (upper_central_series.subgroup.normal G n) x⁻¹ (inv_mem _ hx) y),
end

/-- A group `G` is nilpotent iff there exists an ascending central series which reaches `G` in
  finitely many steps. -/
theorem nilpotent_iff_finite_ascending_central_series :
  is_nilpotent G ↔ ∃ n : ℕ, ∃ H : ℕ → subgroup G, is_ascending_central_series H ∧ H n = ⊤ :=
begin
  split,
  { rintro ⟨n, nH⟩,
    refine ⟨_, _, upper_central_series_is_ascending_central_series G, nH⟩ },
  { rintro ⟨n, H, hH, hn⟩,
    use n,
    rw [eq_top_iff, ←hn],
    exact ascending_central_series_le_upper H hH n }
end

lemma is_decending_rev_series_of_is_ascending
  {H: ℕ → subgroup G} {n : ℕ} (hn : H n = ⊤) (hasc : is_ascending_central_series H) :
  is_descending_central_series (λ (m : ℕ), H (n - m)) :=
begin
  cases hasc with h0 hH,
  refine ⟨hn, λ x m hx g, _⟩,
  dsimp at hx,
  by_cases hm : n ≤ m,
  { rw [tsub_eq_zero_of_le hm, h0, subgroup.mem_bot] at hx,
    subst hx,
    convert subgroup.one_mem _,
    group },
  { push_neg at hm,
    apply hH,
    convert hx,
    rw [tsub_add_eq_add_tsub (nat.succ_le_of_lt hm), nat.succ_sub_succ] },
end

lemma is_ascending_rev_series_of_is_descending
  {H: ℕ → subgroup G} {n : ℕ} (hn : H n = ⊥) (hdesc : is_descending_central_series H) :
  is_ascending_central_series (λ (m : ℕ), H (n - m)) :=
begin
  cases hdesc with h0 hH,
  refine ⟨hn, λ x m hx g, _⟩,
  dsimp only at hx ⊢,
  by_cases hm : n ≤ m,
  { have hnm : n - m = 0 := tsub_eq_zero_iff_le.mpr hm,
    rw [hnm, h0],
    exact mem_top _ },
  { push_neg at hm,
    convert hH x _ hx g,
    rw [tsub_add_eq_add_tsub (nat.succ_le_of_lt hm), nat.succ_sub_succ] },
end

/-- A group `G` is nilpotent iff there exists a descending central series which reaches the
  trivial group in a finite time. -/
theorem nilpotent_iff_finite_descending_central_series :
  is_nilpotent G ↔ ∃ n : ℕ, ∃ H : ℕ → subgroup G, is_descending_central_series H ∧ H n = ⊥ :=
begin
  rw nilpotent_iff_finite_ascending_central_series,
  split,
  { rintro ⟨n, H, hH, hn⟩,
    refine ⟨n, λ m, H (n - m), is_decending_rev_series_of_is_ascending G hn hH, _⟩,
    rw tsub_self,
    exact hH.1 },
  { rintro ⟨n, H, hH, hn⟩,
    refine ⟨n, λ m, H (n - m), is_ascending_rev_series_of_is_descending G hn hH, _⟩,
    rw tsub_self,
    exact hH.1 },
end

/-- The lower central series of a group `G` is a sequence `H n` of subgroups of `G`, defined
  by `H 0` is all of `G` and for `n≥1`, `H (n + 1) = ⁅H n, G⁆` -/
def lower_central_series (G : Type*) [group G] : ℕ → subgroup G
| 0 := ⊤
| (n+1) := ⁅lower_central_series n, ⊤⁆

variable {G}

@[simp] lemma lower_central_series_zero : lower_central_series G 0 = ⊤ := rfl

@[simp] lemma lower_central_series_one : lower_central_series G 1 = commutator G := rfl

lemma mem_lower_central_series_succ_iff (n : ℕ) (q : G) :
  q ∈ lower_central_series G (n + 1) ↔
  q ∈ closure {x | ∃ (p ∈ lower_central_series G n) (q ∈ (⊤ : subgroup G)), p * q * p⁻¹ * q⁻¹ = x}
:= iff.rfl

lemma lower_central_series_succ (n : ℕ) :
  lower_central_series G (n + 1) =
  closure {x | ∃ (p ∈ lower_central_series G n) (q ∈ (⊤ : subgroup G)), p * q * p⁻¹ * q⁻¹ = x} :=
rfl

instance (n : ℕ) : normal (lower_central_series G n) :=
begin
  induction n with d hd,
  { exact (⊤ : subgroup G).normal_of_characteristic },
  { exactI subgroup.commutator_normal (lower_central_series G d) ⊤ },
end

lemma lower_central_series_antitone :
  antitone (lower_central_series G) :=
begin
  refine antitone_nat_of_succ_le (λ n x hx, _),
  simp only [mem_lower_central_series_succ_iff, exists_prop, mem_top, exists_true_left, true_and]
    at hx,
  refine closure_induction hx _ (subgroup.one_mem _) (@subgroup.mul_mem _ _ _)
    (@subgroup.inv_mem _ _ _),
  rintros y ⟨z, hz, a, ha⟩,
  rw [← ha, mul_assoc, mul_assoc, ← mul_assoc a z⁻¹ a⁻¹],
  exact mul_mem (lower_central_series G n) hz
    (normal.conj_mem (lower_central_series.subgroup.normal n) z⁻¹ (inv_mem _ hz) a),
end

/-- The lower central series of a group is a descending central series. -/
theorem lower_central_series_is_descending_central_series :
  is_descending_central_series (lower_central_series G) :=
begin
  split, refl,
  intros x n hxn g,
  exact commutator_mem_commutator hxn (mem_top g),
end

/-- Any descending central series for a group is bounded below by the lower central series. -/
lemma descending_central_series_ge_lower (H : ℕ → subgroup G)
  (hH : is_descending_central_series H) : ∀ n : ℕ, lower_central_series G n ≤ H n
| 0 := hH.1.symm ▸ le_refl ⊤
| (n + 1) := commutator_le.mpr (λ x hx q _, hH.2 x n (descending_central_series_ge_lower n hx) q)

/-- A group is nilpotent if and only if its lower central series eventually reaches
  the trivial subgroup. -/
theorem nilpotent_iff_lower_central_series : is_nilpotent G ↔ ∃ n, lower_central_series G n = ⊥ :=
begin
  rw nilpotent_iff_finite_descending_central_series,
  split,
  { rintro ⟨n, H, ⟨h0, hs⟩, hn⟩,
    use n,
    rw [eq_bot_iff, ←hn],
    exact descending_central_series_ge_lower H ⟨h0, hs⟩ n },
  { rintro ⟨n, hn⟩,
    exact ⟨n, lower_central_series G, lower_central_series_is_descending_central_series, hn⟩ },
end

section classical

open_locale classical

variables [hG : is_nilpotent G]
include hG

variable (G)

/-- The nilpotency class of a nilpotent group is the smallest natural `n` such that
the `n`'th term of the upper central series is `G`. -/
noncomputable def group.nilpotency_class : ℕ :=
nat.find (is_nilpotent.nilpotent G)

variable {G}

@[simp]
lemma upper_central_series_nilpotency_class :
  upper_central_series G (group.nilpotency_class G) = ⊤ :=
nat.find_spec (is_nilpotent.nilpotent G)

lemma upper_central_series_eq_top_iff_nilpotency_class_le {n : ℕ} :
  (upper_central_series G n = ⊤) ↔ (group.nilpotency_class G ≤ n) :=
begin
  split,
  { intro h,
    exact (nat.find_le h), },
  { intro h,
    apply eq_top_iff.mpr,
    rw ← upper_central_series_nilpotency_class,
    exact (upper_central_series_mono _ h), }
end

/-- The nilpotency class of a nilpotent `G` is equal to the smallest `n` for which an ascending
central series reaches `G` in its `n`'th term. -/
lemma least_ascending_central_series_length_eq_nilpotency_class :
  nat.find ((nilpotent_iff_finite_ascending_central_series G).mp hG) = group.nilpotency_class G :=
begin
  refine le_antisymm (nat.find_mono _) (nat.find_mono _),
  { intros n hn,
    exact ⟨upper_central_series G, upper_central_series_is_ascending_central_series G, hn ⟩, },
  { rintros n ⟨H, ⟨hH, hn⟩⟩,
    rw [←top_le_iff, ←hn],
    exact ascending_central_series_le_upper H hH n, }
end

/-- The nilpotency class of a nilpotent `G` is equal to the smallest `n` for which the descending
central series reaches `⊥` in its `n`'th term. -/
lemma least_descending_central_series_length_eq_nilpotency_class :
  nat.find ((nilpotent_iff_finite_descending_central_series G).mp hG) = group.nilpotency_class G :=
begin
  rw ← least_ascending_central_series_length_eq_nilpotency_class,
  refine le_antisymm (nat.find_mono _) (nat.find_mono _),
  { rintros n ⟨H, ⟨hH, hn⟩⟩,
    refine ⟨(λ m, H (n - m)), is_decending_rev_series_of_is_ascending G hn hH, _⟩,
    rw tsub_self,
    exact hH.1 },
  { rintros n ⟨H, ⟨hH, hn⟩⟩,
    refine ⟨(λ m, H (n - m)), is_ascending_rev_series_of_is_descending G hn hH, _⟩,
    rw tsub_self,
    exact hH.1 },
end

/-- The nilpotency class of a nilpotent `G` is equal to the length of the lower central series. -/
lemma lower_central_series_length_eq_nilpotency_class :
  nat.find (nilpotent_iff_lower_central_series.mp hG) = @group.nilpotency_class G _ _ :=
begin
  rw ← least_descending_central_series_length_eq_nilpotency_class,
  refine le_antisymm (nat.find_mono _) (nat.find_mono _),
  { rintros n ⟨H, ⟨hH, hn⟩⟩,
    rw [←le_bot_iff, ←hn],
    exact (descending_central_series_ge_lower H hH n), },
  { rintros n h,
    exact ⟨lower_central_series G, ⟨lower_central_series_is_descending_central_series, h⟩⟩ },
end

@[simp]
lemma lower_central_series_nilpotency_class :
  lower_central_series G (group.nilpotency_class G) = ⊥ :=
begin
  rw ← lower_central_series_length_eq_nilpotency_class,
  exact (nat.find_spec (nilpotent_iff_lower_central_series.mp _))
end

lemma lower_central_series_eq_bot_iff_nilpotency_class_le {n : ℕ} :
  (lower_central_series G n = ⊥) ↔ (group.nilpotency_class G ≤ n) :=
begin
  split,
  { intro h,
    rw ← lower_central_series_length_eq_nilpotency_class,
    exact (nat.find_le h), },
  { intro h,
    apply eq_bot_iff.mpr,
    rw ← lower_central_series_nilpotency_class,
    exact (lower_central_series_antitone h), }
end

end classical

lemma lower_central_series_map_subtype_le (H : subgroup G) (n : ℕ) :
  (lower_central_series H n).map H.subtype ≤ lower_central_series G n :=
begin
  induction n with d hd,
  { simp },
  { rw [lower_central_series_succ, lower_central_series_succ, monoid_hom.map_closure],
    apply subgroup.closure_mono,
    rintros x1 ⟨x2, ⟨x3, hx3, x4, hx4, rfl⟩, rfl⟩,
    exact ⟨x3, (hd (mem_map.mpr ⟨x3, hx3, rfl⟩)), x4, by simp⟩ }
end

/-- A subgroup of a nilpotent group is nilpotent -/
instance subgroup.is_nilpotent (H : subgroup G) [hG : is_nilpotent G] :
  is_nilpotent H :=
begin
  rw nilpotent_iff_lower_central_series at *,
  rcases hG with ⟨n, hG⟩,
  use n,
  have := lower_central_series_map_subtype_le H n,
  simp only [hG, set_like.le_def, mem_map, forall_apply_eq_imp_iff₂, exists_imp_distrib] at this,
  exact eq_bot_iff.mpr (λ x hx, subtype.ext (this x hx)),
end

/-- A the nilpotency class of a subgroup is less or equal the the nilpotency class of the group -/
lemma subgroup.nilpotency_class_le (H : subgroup G) [hG : is_nilpotent G] :
  group.nilpotency_class H ≤ group.nilpotency_class G :=
begin
  repeat { rw ← lower_central_series_length_eq_nilpotency_class },
  apply nat.find_mono,
  intros n hG,
  have := lower_central_series_map_subtype_le H n,
  simp only [hG, set_like.le_def, mem_map, forall_apply_eq_imp_iff₂, exists_imp_distrib] at this,
  exact eq_bot_iff.mpr (λ x hx, subtype.ext (this x hx)),
end

@[priority 100]
instance is_nilpotent_of_subsingleton [subsingleton G] : is_nilpotent G :=
nilpotent_iff_lower_central_series.2 ⟨0, subsingleton.elim ⊤ ⊥⟩

lemma upper_central_series.map {H : Type*} [group H] {f : G →* H} (h : function.surjective f)
  (n : ℕ) : subgroup.map f (upper_central_series G n) ≤ upper_central_series H n :=
begin
  induction n with d hd,
  { simp },
  { rintros _ ⟨x, hx : x ∈ upper_central_series G d.succ, rfl⟩ y',
    rcases h y' with ⟨y, rfl⟩,
    simpa using hd (mem_map_of_mem f (hx y)) }
end

lemma lower_central_series.map {H : Type*} [group H] (f : G →* H) (n : ℕ) :
  subgroup.map f (lower_central_series G n) ≤ lower_central_series H n :=
begin
  induction n with d hd,
  { simp [nat.nat_zero_eq_zero] },
  { rintros a ⟨x, hx : x ∈ lower_central_series G d.succ, rfl⟩,
    refine closure_induction hx _ (by simp [f.map_one, subgroup.one_mem _])
      (λ y z hy hz, by simp [monoid_hom.map_mul, subgroup.mul_mem _ hy hz])
      (λ y hy, by simp [f.map_inv, subgroup.inv_mem _ hy]),
    rintros a ⟨y, hy, z, ⟨-, rfl⟩⟩,
    apply mem_closure.mpr,
    exact λ K hK, hK ⟨f y, hd (mem_map_of_mem f hy), by simp [commutator_element_def]⟩ }
end

lemma lower_central_series_succ_eq_bot {n : ℕ} (h : lower_central_series G n ≤ center G) :
  lower_central_series G (n + 1) = ⊥ :=
begin
  rw [lower_central_series_succ, closure_eq_bot_iff, set.subset_singleton_iff],
  rintro x ⟨y, hy1, z, ⟨⟩, rfl⟩,
  rw [mul_assoc, ←mul_inv_rev, mul_inv_eq_one, eq_comm],
  exact mem_center_iff.mp (h hy1) z,
end

/-- The preimage of a nilpotent group is nilpotent if the kernel of the homomorphism is contained
in the center -/
lemma is_nilpotent_of_ker_le_center {H : Type*} [group H] (f : G →* H)
  (hf1 : f.ker ≤ center G) (hH : is_nilpotent H) : is_nilpotent G :=
begin
  rw nilpotent_iff_lower_central_series at *,
  rcases hH with ⟨n, hn⟩,
  use (n + 1),
  refine lower_central_series_succ_eq_bot (le_trans ((map_eq_bot_iff _).mp _) hf1),
  exact eq_bot_iff.mpr (hn ▸ (lower_central_series.map f n)),
end

lemma nilpotency_class_le_of_ker_le_center {H : Type*} [group H] (f : G →* H)
  (hf1 : f.ker ≤ center G) (hH : is_nilpotent H) :
  @group.nilpotency_class G _ (is_nilpotent_of_ker_le_center f hf1 hH) ≤
    group.nilpotency_class H + 1 :=
begin
  rw ← lower_central_series_length_eq_nilpotency_class,
  apply nat.find_min',
  refine lower_central_series_succ_eq_bot (le_trans ((map_eq_bot_iff _).mp _) hf1),
  apply eq_bot_iff.mpr,
  apply (le_trans (lower_central_series.map f _)),
  simp only [lower_central_series_nilpotency_class, le_bot_iff],
end

/-- The range of a surjective homomorphism from a nilpotent group is nilpotent -/
lemma nilpotent_of_surjective {G' : Type*} [group G'] [h : is_nilpotent G]
  (f : G →* G') (hf : function.surjective f) :
  is_nilpotent G' :=
begin
  unfreezingI { rcases h with ⟨n, hn⟩ },
  use n,
  apply eq_top_iff.mpr,
  calc ⊤ = f.range : symm (f.range_top_of_surjective hf)
    ... = subgroup.map f ⊤ : monoid_hom.range_eq_map _
    ... = subgroup.map f (upper_central_series G n) : by rw hn
    ... ≤ upper_central_series G' n : upper_central_series.map hf n,
end

/-- The nilpotency class of the range of a surejctive homomorphism from a
nilpotent group is less or equal the nilpotency class of the domain -/
lemma nilpotency_class_le_of_surjective
  {G' : Type*} [group G'] (f : G →* G') (hf : function.surjective f) [h : is_nilpotent G] :
  @group.nilpotency_class G' _ (nilpotent_of_surjective _ hf) ≤
    group.nilpotency_class G :=
begin
  apply nat.find_mono,
  intros n hn,
  apply eq_top_iff.mpr,
  calc ⊤ = f.range : symm (f.range_top_of_surjective hf)
    ... = subgroup.map f ⊤ : monoid_hom.range_eq_map _
    ... = subgroup.map f (upper_central_series G n) : by rw hn
    ... ≤ upper_central_series G' n : upper_central_series.map hf n,
end

/-- Nilpotency respects isomorphisms -/
lemma nilpotent_of_mul_equiv {G' : Type*} [group G'] [h : is_nilpotent G] (f : G ≃* G') :
  is_nilpotent G' :=
nilpotent_of_surjective f.to_monoid_hom (mul_equiv.surjective f)

/-- A quotient of a nilpotent group is nilpotent -/
instance nilpotent_quotient_of_nilpotent (H : subgroup G) [H.normal] [h : is_nilpotent G] :
  is_nilpotent (G ⧸ H) :=
 nilpotent_of_surjective _ (show function.surjective (quotient_group.mk' H), by tidy)

/-- The nilpotency class of a quotient of `G` is less or equal the nilpotency class of `G` -/
lemma nilpotency_class_quotient_le (H : subgroup G) [H.normal] [h : is_nilpotent G] :
  group.nilpotency_class (G ⧸ H) ≤ group.nilpotency_class G := nilpotency_class_le_of_surjective _ _

-- This technical lemma helps with rewriting the subgroup, which occurs in indices
private lemma comap_center_subst {H₁ H₂ : subgroup G} [normal H₁] [normal H₂] (h : H₁ = H₂) :
  comap (mk' H₁) (center (G ⧸ H₁)) = comap (mk' H₂) (center (G ⧸ H₂)) :=
by unfreezingI { subst h }

lemma comap_upper_central_series_quotient_center (n : ℕ) :
  comap (mk' (center G)) (upper_central_series (G ⧸ center G) n) = upper_central_series G n.succ :=
begin
  induction n with n ih,
  { simp, },
  { let Hn := upper_central_series (G ⧸ center G) n,
    calc comap (mk' (center G)) (upper_central_series_step Hn)
        = comap (mk' (center G)) (comap (mk' Hn) (center ((G ⧸ center G) ⧸ Hn))) :
        by rw upper_central_series_step_eq_comap_center
    ... = comap (mk' (comap (mk' (center G)) Hn)) (center (G ⧸ (comap (mk' (center G)) Hn))) :
        quotient_group.comap_comap_center
    ... = comap (mk' (upper_central_series G n.succ)) (center (G ⧸ upper_central_series G n.succ)) :
        comap_center_subst ih
    ... = upper_central_series_step (upper_central_series G n.succ) :
        symm (upper_central_series_step_eq_comap_center _), }
end

lemma nilpotency_class_zero_iff_subsingleton [is_nilpotent G] :
  group.nilpotency_class G = 0 ↔ subsingleton G :=
by simp [group.nilpotency_class, nat.find_eq_zero, subsingleton_iff_bot_eq_top]

/-- Quotienting the `center G` reduces the nilpotency class by 1 -/
lemma nilpotency_class_quotient_center [hH : is_nilpotent G] :
  group.nilpotency_class (G ⧸ center G) = group.nilpotency_class G - 1 :=
begin
  generalize hn : group.nilpotency_class G = n,
  rcases n with rfl | n,
  { simp [nilpotency_class_zero_iff_subsingleton] at *,
    haveI := hn,
    apply_instance, },
  { suffices : group.nilpotency_class (G ⧸ center G) = n, by simpa,
    apply le_antisymm,
    { apply upper_central_series_eq_top_iff_nilpotency_class_le.mp,
      apply (@comap_injective G _ _ _ (mk' (center G)) (surjective_quot_mk _)),
      rw [ comap_upper_central_series_quotient_center, comap_top, ← hn],
      exact upper_central_series_nilpotency_class, },
    { apply le_of_add_le_add_right,
      calc n + 1 = n.succ : rfl
        ... = group.nilpotency_class G : symm hn
        ... ≤ group.nilpotency_class (G ⧸ center G) + 1
            : nilpotency_class_le_of_ker_le_center _ (le_of_eq (ker_mk _)) _, } }
end

/-- The nilpotency class of a non-trivial group is one more than its quotient by the center -/
lemma nilpotency_class_eq_quotient_center_plus_one [hH : is_nilpotent G] [nontrivial G] :
  group.nilpotency_class G = group.nilpotency_class (G ⧸ center G) + 1 :=
begin
  rw nilpotency_class_quotient_center,
  rcases h : group.nilpotency_class G,
  { exfalso,
    rw nilpotency_class_zero_iff_subsingleton at h, resetI,
    apply (false_of_nontrivial_of_subsingleton G), },
  { simp }
end

/-- If the quotient by `center G` is nilpotent, then so is G. -/
lemma of_quotient_center_nilpotent (h : is_nilpotent (G ⧸ center G)) : is_nilpotent G :=
begin
  obtain ⟨n, hn⟩ := h.nilpotent,
  use n.succ,
  simp [← comap_upper_central_series_quotient_center, hn],
end

/-- A custom induction principle for nilpotent groups. The base case is a trivial group
(`subsingleton G`), and in the induction step, one can assume the hypothesis for
the group quotiented by its center. -/
@[elab_as_eliminator]
lemma nilpotent_center_quotient_ind
  {P : Π G [group G], by exactI ∀ [is_nilpotent G], Prop}
  (G : Type*) [group G] [is_nilpotent G]
  (hbase : ∀ G [group G] [subsingleton G], by exactI P G)
  (hstep : ∀ G [group G], by exactI ∀ [is_nilpotent G], by exactI ∀ (ih : P (G ⧸ center G)), P G) :
  P G :=
begin
  obtain ⟨n, h⟩ : ∃ n, group.nilpotency_class G = n := ⟨ _, rfl⟩,
  unfreezingI { induction n with n ih generalizing G },
  { haveI := nilpotency_class_zero_iff_subsingleton.mp h,
    exact hbase _, },
  { have hn : group.nilpotency_class (G ⧸ center G) = n :=
      by simp [nilpotency_class_quotient_center, h],
    exact hstep _ (ih _ hn), },
end

lemma derived_le_lower_central (n : ℕ) : derived_series G n ≤ lower_central_series G n :=
by { induction n with i ih, { simp }, { apply commutator_mono ih, simp } }

/-- Abelian groups are nilpotent -/
@[priority 100]
instance comm_group.is_nilpotent {G : Type*} [comm_group G] : is_nilpotent G :=
begin
  use 1,
  rw upper_central_series_one,
  apply comm_group.center_eq_top,
end

/-- Abelian groups have nilpotency class at most one -/
lemma comm_group.nilpotency_class_le_one {G : Type*} [comm_group G] :
  group.nilpotency_class G ≤ 1 :=
begin
  apply upper_central_series_eq_top_iff_nilpotency_class_le.mp,
  rw upper_central_series_one,
  apply comm_group.center_eq_top,
end

/-- Groups with nilpotency class at most one are abelian -/
def comm_group_of_nilpotency_class [is_nilpotent G] (h : group.nilpotency_class G ≤ 1) :
  comm_group G :=
group.comm_group_of_center_eq_top $
begin
  rw ← upper_central_series_one,
  exact upper_central_series_eq_top_iff_nilpotency_class_le.mpr h,
end

section prod

variables {G₁ G₂ : Type*} [group G₁] [group G₂]

lemma lower_central_series_prod (n : ℕ):
  lower_central_series (G₁ × G₂) n = (lower_central_series G₁ n).prod (lower_central_series G₂ n) :=
begin
  induction n with n ih,
  { simp, },
  { calc lower_central_series (G₁ × G₂) n.succ
        = ⁅lower_central_series (G₁ × G₂) n, ⊤⁆  : rfl
    ... = ⁅(lower_central_series G₁ n).prod (lower_central_series G₂ n), ⊤⁆ : by rw ih
    ... = ⁅(lower_central_series G₁ n).prod (lower_central_series G₂ n), (⊤ : subgroup G₁).prod ⊤⁆ :
      by simp
    ... = ⁅lower_central_series G₁ n, (⊤ : subgroup G₁)⁆.prod ⁅lower_central_series G₂ n, ⊤⁆ :
      commutator_prod_prod _ _ _ _
    ... = (lower_central_series G₁ n.succ).prod (lower_central_series G₂ n.succ) : rfl }
end

/-- Products of nilpotent groups are nilpotent -/
instance is_nilpotent_prod [is_nilpotent G₁] [is_nilpotent G₂] :
  is_nilpotent (G₁ × G₂) :=
begin
  rw nilpotent_iff_lower_central_series,
  refine ⟨max (group.nilpotency_class G₁) (group.nilpotency_class G₂), _ ⟩,
  rw [lower_central_series_prod,
    lower_central_series_eq_bot_iff_nilpotency_class_le.mpr (le_max_left _ _),
    lower_central_series_eq_bot_iff_nilpotency_class_le.mpr (le_max_right _ _), bot_prod_bot],
end

/-- The nilpotency class of a product is the max of the nilpotency classes of the factors -/
lemma nilpotency_class_prod [is_nilpotent G₁] [is_nilpotent G₂] :
  group.nilpotency_class (G₁ × G₂) = max (group.nilpotency_class G₁) (group.nilpotency_class G₂) :=
begin
  refine eq_of_forall_ge_iff (λ k, _),
  simp only [max_le_iff, ← lower_central_series_eq_bot_iff_nilpotency_class_le,
    lower_central_series_prod, prod_eq_bot_iff ],
end

end prod

section bounded_pi

-- First the case of infinite products with bounded nilpotency class

variables {η : Type*} {Gs : η → Type*} [∀ i, group (Gs i)]

lemma lower_central_series_pi_le (n : ℕ):
  lower_central_series (Π i, Gs i) n ≤ subgroup.pi set.univ (λ i, lower_central_series (Gs i) n) :=
begin
  let pi := λ (f : Π i, subgroup (Gs i)), subgroup.pi set.univ f,
  induction n with n ih,
  { simp [pi_top] },
  { calc lower_central_series (Π i, Gs i) n.succ
        = ⁅lower_central_series (Π i, Gs i) n, ⊤⁆           : rfl
    ... ≤ ⁅pi (λ i, (lower_central_series (Gs i) n)), ⊤⁆    : commutator_mono ih (le_refl _)
    ... = ⁅pi (λ i, (lower_central_series (Gs i) n)), pi (λ i, ⊤)⁆ : by simp [pi, pi_top]
    ... ≤ pi (λ i, ⁅(lower_central_series (Gs i) n), ⊤⁆)    : commutator_pi_pi_le _ _
    ... = pi (λ i, lower_central_series (Gs i) n.succ)      : rfl }
end

/-- products of nilpotent groups are nilpotent if their nipotency class is bounded -/
lemma is_nilpotent_pi_of_bounded_class [∀ i, is_nilpotent (Gs i)]
  (n : ℕ) (h : ∀ i, group.nilpotency_class (Gs i) ≤ n) :
  is_nilpotent (Π i, Gs i) :=
begin
  rw nilpotent_iff_lower_central_series,
  refine ⟨n, _⟩,
  rw eq_bot_iff,
  apply le_trans (lower_central_series_pi_le _),
  rw [← eq_bot_iff, pi_eq_bot_iff],
  intros i,
  apply lower_central_series_eq_bot_iff_nilpotency_class_le.mpr (h i),
end

end bounded_pi

section finite_pi

-- Now for finite products

variables {η : Type*} [fintype η] {Gs : η → Type*} [∀ i, group (Gs i)]

lemma lower_central_series_pi_of_fintype (n : ℕ):
  lower_central_series (Π i, Gs i) n = subgroup.pi set.univ (λ i, lower_central_series (Gs i) n) :=
begin
  let pi := λ (f : Π i, subgroup (Gs i)), subgroup.pi set.univ f,
  induction n with n ih,
  { simp [pi_top] },
  { calc lower_central_series (Π i, Gs i) n.succ
        = ⁅lower_central_series (Π i, Gs i) n, ⊤⁆          : rfl
    ... = ⁅pi (λ i, (lower_central_series (Gs i) n)), ⊤⁆   : by rw ih
    ... = ⁅pi (λ i, (lower_central_series (Gs i) n)), pi (λ i, ⊤)⁆ : by simp [pi, pi_top]
    ... = pi (λ i, ⁅(lower_central_series (Gs i) n), ⊤⁆)   : commutator_pi_pi_of_fintype _ _
    ... = pi (λ i, lower_central_series (Gs i) n.succ)     : rfl }
end

/-- n-ary products of nilpotent groups are nilpotent -/
instance is_nilpotent_pi [∀ i, is_nilpotent (Gs i)] :
  is_nilpotent (Π i, Gs i) :=
begin
  rw nilpotent_iff_lower_central_series,
  refine ⟨finset.univ.sup (λ i, group.nilpotency_class (Gs i)), _⟩,
  rw [lower_central_series_pi_of_fintype, pi_eq_bot_iff],
  intros i,
  apply lower_central_series_eq_bot_iff_nilpotency_class_le.mpr,
  exact @finset.le_sup _ _ _ _ finset.univ (λ i, group.nilpotency_class (Gs i)) _
    (finset.mem_univ i),
end

/-- The nilpotency class of an n-ary product is the sup of the nilpotency classes of the factors -/
lemma nilpotency_class_pi [∀ i, is_nilpotent (Gs i)] :
  group.nilpotency_class (Π i, Gs i) = finset.univ.sup (λ i, group.nilpotency_class (Gs i)) :=
begin
  apply eq_of_forall_ge_iff,
  intros k,
  simp only [finset.sup_le_iff, ← lower_central_series_eq_bot_iff_nilpotency_class_le,
    lower_central_series_pi_of_fintype, pi_eq_bot_iff, finset.mem_univ, true_implies_iff ],
end

end finite_pi

/-- A nilpotent subgroup is solvable -/
@[priority 100]
instance is_nilpotent.to_is_solvable [h : is_nilpotent G]: is_solvable G :=
begin
  obtain ⟨n, hn⟩ := nilpotent_iff_lower_central_series.1 h,
  use n,
  rw [eq_bot_iff, ←hn],
  exact derived_le_lower_central n,
end

lemma normalizer_condition_of_is_nilpotent [h : is_nilpotent G] : normalizer_condition G :=
begin
  -- roughly based on https://groupprops.subwiki.org/wiki/Nilpotent_implies_normalizer_condition
  rw normalizer_condition_iff_only_full_group_self_normalizing,
  unfreezingI
  { induction h using nilpotent_center_quotient_ind with G' _ _ G' _ _ ih;
    clear _inst_1 G; rename G' → G, },
  { rintros H -, apply subsingleton.elim, },
  { intros H hH,

    have hch : center G ≤ H := subgroup.center_le_normalizer.trans (le_of_eq hH),
    have hkh : (mk' (center G)).ker ≤ H, by simpa using hch,
    have hsur : function.surjective (mk' (center G)), by exact surjective_quot_mk _,

    let H' := H.map (mk' (center G)),
    have hH' : H'.normalizer = H',
    { apply comap_injective hsur,
      rw [comap_normalizer_eq_of_surjective _ hsur, comap_map_eq_self hkh],
      exact hH, },
    apply map_injective_of_ker_le (mk' (center G)) hkh le_top,
    exact (ih H' hH').trans (symm (map_top_of_surjective _ hsur)), },
end

end with_group

section with_finite_group

open group fintype

variables {G : Type*} [hG : group G] [hf : fintype G]
include hG hf

/-- A p-group is nilpotent -/
lemma is_p_group.is_nilpotent {p : ℕ} [hp : fact (nat.prime p)] (h : is_p_group p G) :
  is_nilpotent G :=
begin
  classical,
  unfreezingI
  { revert hG,
    induction hf using fintype.induction_subsingleton_or_nontrivial with G hG hS G hG hN ih },
  { apply_instance, },
  { introI _, intro h,
    have hcq : fintype.card (G ⧸ center G) < fintype.card G,
    { rw card_eq_card_quotient_mul_card_subgroup (center G),
      apply lt_mul_of_one_lt_right,
      exact (fintype.card_pos_iff.mpr has_one.nonempty),
      exact ((subgroup.one_lt_card_iff_ne_bot _).mpr (ne_of_gt h.bot_lt_center)), },
    have hnq : is_nilpotent (G ⧸ center G) := ih _ hcq (h.to_quotient (center G)),
    exact (of_quotient_center_nilpotent hnq), }
end

/-- If a finite group is the direct product of its Sylow groups, it is nilpotent -/
theorem is_nilpotent_of_product_of_sylow_group
  (e : (Π p : (fintype.card G).factorization.support, Π P : sylow p G, (↑P : subgroup G)) ≃* G) :
  is_nilpotent G :=
begin
  classical,
  let ps := (fintype.card G).factorization.support,
  haveI : ∀ (p : ps) (P : sylow p G), is_nilpotent (↑P : subgroup G),
  { intros p P,
    haveI : fact (nat.prime ↑p) := fact.mk (nat.prime_of_mem_factorization (finset.coe_mem p)),
    exact P.is_p_group'.is_nilpotent, },
  exact nilpotent_of_mul_equiv e,
end

/-- A finite group is nilpotent iff the normalizer condition holds, and iff all maximal groups are
normal and iff all sylow groups are normal and iff the group is the direct product of its sylow
groups. -/
theorem is_nilpotent_of_finite_tfae : tfae
  [ is_nilpotent G,
    normalizer_condition G,
    ∀ (H : subgroup G), is_coatom H → H.normal,
    ∀ (p : ℕ) (hp : fact p.prime) (P : sylow p G), (↑P : subgroup G).normal,
    nonempty ((Π p : (card G).factorization.support, Π P : sylow p G, (↑P : subgroup G)) ≃* G) ] :=
begin
  tfae_have : 1 → 2, { exact @normalizer_condition_of_is_nilpotent _ _ },
  tfae_have : 2 → 3, { exact λ h H, normalizer_condition.normal_of_coatom H h },
  tfae_have : 3 → 4, { introsI h p _ P, exact sylow.normal_of_all_max_subgroups_normal h _ },
  tfae_have : 4 → 5, { exact λ h, nonempty.intro (sylow.direct_product_of_normal h) },
  tfae_have : 5 → 1, { rintros ⟨e⟩, exact is_nilpotent_of_product_of_sylow_group e },
  tfae_finish,
end

end with_finite_group


import linear_algebra
import field_theory.finite.basic

open_locale big_operators

lemma card_subtype_eq_iff (α : Type*) (p : α → Prop) [decidable_pred p] [fintype α] :
  fintype.card ({x // p x}) = fintype.card α ↔ ∀ x, p x :=
begin
  rw [fintype.card_subtype p, finset.card_eq_iff_eq_univ, finset.eq_univ_iff_forall],
  refine forall_congr (λ x, _),
  rw [finset.mem_filter],
  exact ⟨λ ⟨_, h⟩, h, λ h, ⟨finset.mem_univ x, h⟩⟩
end

lemma set.card_coe_sort_eq_iff (α : Type*) (S : set α) [decidable_pred (λ x, x ∈ S)] [fintype α] :
  fintype.card S = fintype.card α ↔ ∀ x, x ∈ S :=
card_subtype_eq_iff α (λ x, x ∈ S)

lemma card_eq_pow_finrank' {K V : Type*} [division_ring K] [add_comm_group V] [module K V] [fintype K] [fintype V] :
  fintype.card V = (fintype.card K) ^ (finite_dimensional.finrank K V) :=
begin
  let b := is_noetherian.finset_basis K V,
  rw [module.card_fintype b, ← finite_dimensional.finrank_eq_card_basis b],
end

lemma subsemiring.center_eq_top_iff (R : Type*) [semiring R] :
  subsemiring.center R = ⊤ ↔ commutative ((*) : R → R → R) :=
begin
  simp_rw [subsemiring.eq_top_iff', subsemiring.mem_center_iff],
  rw forall_swap,
  refl
end

lemma subring.center_eq_top_iff (R : Type*) [ring R] :
  subring.center R = ⊤ ↔ commutative ((*) : R → R → R) :=
begin
  simp_rw [subring.eq_top_iff', subring.mem_center_iff],
  rw forall_swap,
  refl
end

def submonoid.centralizer {M : Type*} [monoid M] (x : M) : submonoid M :=
{ carrier := {y | commute x y},
  one_mem' := commute.one_right x,
  mul_mem' := λ a b, commute.mul_right }

def subgroup.centralizer {G : Type*} [group G] (x : G) : subgroup G :=
{ inv_mem' := λ a, commute.inv_right,
  ..submonoid.centralizer x }

def subsemiring.centralizer {R : Type*} [semiring R] (x : R) : subsemiring R :=
{ zero_mem' := commute.zero_right x,
  add_mem' := λ a b, commute.add_right,
  ..submonoid.centralizer x }

def subring.centralizer {R : Type*} [ring R] (x : R) : subring R :=
{ neg_mem' := λ a, commute.neg_right,
  ..subsemiring.centralizer x }

instance subring.centralizer.division_ring {R : Type*} [division_ring R] (x : R) :
division_ring (subring.centralizer x) :=
{ inv := λ ⟨y, hy⟩, ⟨y⁻¹, commute.inv_right' hy⟩,
  mul_inv_cancel := λ ⟨a, ha⟩ h, subtype.ext $ mul_inv_cancel $ subtype.coe_injective.ne h,
  inv_zero := subtype.ext inv_zero,
  ..(subring.centralizer x).nontrivial,
  ..(subring.centralizer x).to_ring }

def submodule.centralizer {R : Type*} [ring R] (x : R) :
  submodule (subring.center R) R :=
{ smul_mem' := λ c y (hy : commute x y),
    calc x * c • y
        = x * (c * y) : by rw [subring.smul_def, smul_eq_mul]
    ... = (x * c) * y : by rw mul_assoc
    ... = (c * x) * y : by have : x * ↑c = ↑c * x := c.2 x; rw this
    ... = c * (x * y) : by rw mul_assoc
    ... = c * (y * x) : by rw hy.eq
    ... = (c * y) * x : by rw mul_assoc
    ... = c • y * x : by rw [subring.smul_def, smul_eq_mul],
  ..subring.centralizer x }

def units_submonoid_equiv {M : Type*} [monoid M] (S : submonoid M)
  (hS : ∀ x : units M, (x : M) ∈ S → ((x⁻¹ : units M) : M) ∈ S) :
  units S ≃ {x : units M // (x : M) ∈ S} :=
{ to_fun := λ x, ⟨units.map S.subtype x, (coe x : S).2⟩,
  inv_fun := λ x, ⟨⟨x.1, x.2⟩, ⟨coe (x.1⁻¹), hS x.1 x.2⟩,
    by ext; rw submonoid.coe_mul; exact x.1.mul_inv,
    by ext; rw submonoid.coe_mul; exact x.1.inv_mul⟩,
  left_inv := λ x, by ext; refl,
  right_inv := λ x, by ext; refl }

lemma card_units' {A : Type*} [fintype A] [division_ring A] :
  fintype.card (units A) = fintype.card A - 1 :=
begin
  classical,
  rw [eq_comm, nat.sub_eq_iff_eq_add (fintype.card_pos_iff.2 ⟨(0 : A)⟩)],
  haveI := set_fintype {a : A | a ≠ 0},
  haveI := set_fintype (@set.univ A),
  rw [fintype.card_congr (equiv.units_equiv_ne_zero _),
    ← @set.card_insert _ _ {a : A | a ≠ 0} _ (not_not.2 (eq.refl (0 : A)))
    (set.fintype_insert _ _), fintype.card_congr (equiv.set.univ A).symm],
  congr; simp [set.ext_iff, classical.em]
end

section class_formula

/-!
## Class formula corollary on the number of fixed points
-/

open fintype mul_action function

variables {G X : Type*} [group G] [mul_action G X] [fintype X] [Π (x : X), fintype (orbit G x)]
  [fintype (quotient $ orbit_rel G X)] [fintype (mul_action.fixed_points G X)]

local notation `Ω` := (quotient $ orbit_rel G X)

lemma card_eq_sum_card_orbits' {φ : Ω → X} (hφ : left_inverse quotient.mk' φ) :
  card X = ∑ (ω : Ω), card (orbit G (φ ω)) :=
by rw [card_congr (self_equiv_sigma_orbits' G X hφ), card_sigma]

lemma card_eq_card_fixed_points_add_sum_card_nontrivial_orbits'
  {φ : Ω → X} (hφ : left_inverse quotient.mk' φ)
  [decidable_pred (λ (ω : Ω), φ ω ∈ mul_action.fixed_points G X)] :
  card X =
    (∑ ω in finset.filter (λ (ω : Ω), φ ω ∉ mul_action.fixed_points G X) finset.univ,
      card (orbit G (φ ω))) +
    card (mul_action.fixed_points G X) :=
calc card X
      = ∑ (ω : Ω), card (orbit G (φ ω)) : card_eq_sum_card_orbits' hφ
  ... = ∑ ω in finset.filter (λ (ω : Ω), φ ω ∈ mul_action.fixed_points G X) finset.univ,
          card (orbit G (φ ω)) +
        ∑ ω in finset.filter (λ (ω : Ω), φ ω ∉ mul_action.fixed_points G X) finset.univ,
          card (orbit G (φ ω)) : (finset.sum_filter_add_sum_filter_not _ _ _).symm
  ... = ∑ ω in finset.filter (λ (ω : Ω), φ ω ∈ mul_action.fixed_points G X) finset.univ,
          1 +
        ∑ ω in finset.filter (λ (ω : Ω), φ ω ∉ mul_action.fixed_points G X) finset.univ,
          card (orbit G (φ ω)) :
        by {congr' 1, conv {congr, congr,  } }
  ... = _ : sorry

lemma dvd_card_trivial_orbit'
  {φ : Ω → X} (hφ : left_inverse quotient.mk' φ) {n : ℕ} (hn₁ : n ∣ card X)
  (hn₂ : ∀ (x : X), x ∉ mul_action.fixed_points G X → n ∣ card (orbit G x)) :
  n ∣ card (mul_action.fixed_points G X) :=
begin

end

end class_formula