/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import analysis.special_functions.pow

/-!
# Convergence of `p`-series

In this file we prove that the series `∑' k in ℕ, 1 / k ^ p` converges if and only if `p > 1`.
The proof is based on the
[Cauchy condensation test](https://en.wikipedia.org/wiki/Cauchy_condensation_test): `∑ k, f k`
converges if and only if so does `∑ k, 2 ^ k f (2 ^ k)`. We prove this test in
`nnreal.summable_condensed_iff` and `summable_condensed_iff_of_nonneg`, then use it to prove
`summable_one_div_rpow`. After this transformation, a `p`-series turns into a geometric series.

## TODO

It should be easy to generalize arguments to Schlömilch's generalization of the Cauchy condensation
test once we need it.

## Tags

p-series, Cauchy condensation test
-/

open filter
open_locale big_operators ennreal nnreal topology

/-!
### Cauchy condensation test

In this section we prove the Cauchy condensation test: for `f : ℕ → ℝ≥0` or `f : ℕ → ℝ`,
`∑ k, f k` converges if and only if so does `∑ k, 2 ^ k f (2 ^ k)`. Instead of giving a monolithic
proof, we split it into a series of lemmas with explicit estimates of partial sums of each series in
terms of the partial sums of the other series.
-/

namespace finset

variables {M : Type*} [ordered_add_comm_monoid M] {f : ℕ → M}

lemma le_sum_condensed' (hf : ∀ ⦃m n⦄, 0 < m → m ≤ n → f n ≤ f m) (n : ℕ) :
  (∑ k in Ico 1 (2 ^ n), f k) ≤ ∑ k in range n, (2 ^ k) • f (2 ^ k) :=
begin
  induction n with n ihn, { simp },
  suffices : (∑ k in Ico (2 ^ n) (2 ^ (n + 1)), f k) ≤ (2 ^ n) • f (2 ^ n),
  { rw [sum_range_succ, ← sum_Ico_consecutive],
    exact add_le_add ihn this,
    exacts [n.one_le_two_pow, nat.pow_le_pow_of_le_right zero_lt_two n.le_succ] },
  have : ∀ k ∈ Ico (2 ^ n) (2 ^ (n + 1)), f k ≤ f (2 ^ n) :=
    λ k hk, hf (pow_pos zero_lt_two _) (mem_Ico.mp hk).1,
  convert sum_le_sum this,
  simp [pow_succ, two_mul]
end

lemma le_sum_condensed (hf : ∀ ⦃m n⦄, 0 < m → m ≤ n → f n ≤ f m) (n : ℕ) :
  (∑ k in range (2 ^ n), f k) ≤ f 0 + ∑ k in range n, (2 ^ k) • f (2 ^ k) :=
begin
  convert add_le_add_left (le_sum_condensed' hf n) (f 0),
  rw [← sum_range_add_sum_Ico _ n.one_le_two_pow, sum_range_succ, sum_range_zero, zero_add]
end

lemma sum_condensed_le' (hf : ∀ ⦃m n⦄, 1 < m → m ≤ n → f n ≤ f m) (n : ℕ) :
  (∑ k in range n, (2 ^ k) • f (2 ^ (k + 1))) ≤ ∑ k in Ico 2 (2 ^ n + 1), f k :=
begin
  induction n with n ihn, { simp },
  suffices : (2 ^ n) • f (2 ^ (n + 1)) ≤ ∑ k in Ico (2 ^ n + 1) (2 ^ (n + 1) + 1), f k,
  { rw [sum_range_succ, ← sum_Ico_consecutive],
    exact add_le_add ihn this,
    exacts [add_le_add_right n.one_le_two_pow _,
      add_le_add_right (nat.pow_le_pow_of_le_right zero_lt_two n.le_succ) _] },
  have : ∀ k ∈ Ico (2 ^ n + 1) (2 ^ (n + 1) + 1), f (2 ^ (n + 1)) ≤ f k :=
    λ k hk, hf (n.one_le_two_pow.trans_lt $ (nat.lt_succ_of_le le_rfl).trans_le (mem_Ico.mp hk).1)
      (nat.le_of_lt_succ $ (mem_Ico.mp hk).2),
  convert sum_le_sum this,
  simp [pow_succ, two_mul]
end

lemma sum_condensed_le (hf : ∀ ⦃m n⦄, 1 < m → m ≤ n → f n ≤ f m) (n : ℕ) :
  (∑ k in range (n + 1), (2 ^ k) • f (2 ^ k)) ≤ f 1 + 2 • ∑ k in Ico 2 (2 ^ n + 1), f k :=
begin
  convert add_le_add_left (nsmul_le_nsmul_of_le_right (sum_condensed_le' hf n) 2) (f 1),
  simp [sum_range_succ', add_comm, pow_succ, mul_nsmul, sum_nsmul]
end

end finset

namespace ennreal

variable {f : ℕ → ℝ≥0∞}

lemma le_tsum_condensed (hf : ∀ ⦃m n⦄, 0 < m → m ≤ n → f n ≤ f m) :
  ∑' k, f k ≤ f 0 + ∑' k : ℕ, (2 ^ k) * f (2 ^ k) :=
begin
  rw [ennreal.tsum_eq_supr_nat' (nat.tendsto_pow_at_top_at_top_of_one_lt _root_.one_lt_two)],
  refine supr_le (λ n, (finset.le_sum_condensed hf n).trans (add_le_add_left _ _)),
  simp only [nsmul_eq_mul, nat.cast_pow, nat.cast_two],
  apply ennreal.sum_le_tsum
end

lemma tsum_condensed_le (hf : ∀ ⦃m n⦄, 1 < m → m ≤ n → f n ≤ f m) :
  ∑' k : ℕ, (2 ^ k * f (2 ^ k)) ≤ f 1 + 2 * ∑' k, f k :=
begin
  rw [ennreal.tsum_eq_supr_nat' (tendsto_at_top_mono nat.le_succ tendsto_id), two_mul, ← two_nsmul],
  refine supr_le (λ n, le_trans _ (add_le_add_left (nsmul_le_nsmul_of_le_right
    (ennreal.sum_le_tsum $ finset.Ico 2 (2^n + 1)) _) _)),
  simpa using finset.sum_condensed_le hf n
end

end ennreal

namespace nnreal

/-- Cauchy condensation test for a series of `nnreal` version. -/
lemma summable_condensed_iff {f : ℕ → ℝ≥0} (hf : ∀ ⦃m n⦄, 0 < m → m ≤ n → f n ≤ f m) :
  summable (λ k : ℕ, (2 ^ k) * f (2 ^ k)) ↔ summable f :=
begin
  simp only [← ennreal.tsum_coe_ne_top_iff_summable, ne.def, not_iff_not, ennreal.coe_mul,
    ennreal.coe_pow, ennreal.coe_two],
  split; intro h,
  { replace hf : ∀ m n, 1 < m → m ≤ n → (f n : ℝ≥0∞) ≤ f m :=
      λ m n hm hmn, ennreal.coe_le_coe.2 (hf (zero_lt_one.trans hm) hmn),
    simpa [h, ennreal.add_eq_top, ennreal.mul_eq_top] using ennreal.tsum_condensed_le hf },
  { replace hf : ∀ m n, 0 < m → m ≤ n → (f n : ℝ≥0∞) ≤ f m :=
      λ m n hm hmn, ennreal.coe_le_coe.2 (hf hm hmn),
    simpa [h, ennreal.add_eq_top] using (ennreal.le_tsum_condensed hf) }
end

end nnreal

/-- Cauchy condensation test for series of nonnegative real numbers. -/
lemma summable_condensed_iff_of_nonneg {f : ℕ → ℝ} (h_nonneg : ∀ n, 0 ≤ f n)
  (h_mono : ∀ ⦃m n⦄, 0 < m → m ≤ n → f n ≤ f m) :
  summable (λ k : ℕ, (2 ^ k) * f (2 ^ k)) ↔ summable f :=
begin
  lift f to ℕ → ℝ≥0 using h_nonneg,
  simp only [nnreal.coe_le_coe] at *,
  exact_mod_cast nnreal.summable_condensed_iff h_mono
end

open real

/-!
### Convergence of the `p`-series

In this section we prove that for a real number `p`, the series `∑' n : ℕ, 1 / (n ^ p)` converges if
and only if `1 < p`. There are many different proofs of this fact. The proof in this file uses the
Cauchy condensation test we formalized above. This test implies that `∑ n, 1 / (n ^ p)` converges if
and only if `∑ n, 2 ^ n / ((2 ^ n) ^ p)` converges, and the latter series is a geometric series with
common ratio `2 ^ {1 - p}`. -/

/-- Test for convergence of the `p`-series: the real-valued series `∑' n : ℕ, (n ^ p)⁻¹` converges
if and only if `1 < p`. -/
@[simp] lemma real.summable_nat_rpow_inv {p : ℝ} : summable (λ n, (n ^ p)⁻¹ : ℕ → ℝ) ↔ 1 < p :=
begin
  cases le_or_lt 0 p with hp hp,
  /- Cauchy condensation test applies only to antitone sequences, so we consider the
  cases `0 ≤ p` and `p < 0` separately. -/
  { rw ← summable_condensed_iff_of_nonneg,
    { simp_rw [nat.cast_pow, nat.cast_two, ← rpow_nat_cast, ← rpow_mul zero_lt_two.le, mul_comm _ p,
        rpow_mul zero_lt_two.le, rpow_nat_cast, ← inv_pow, ← mul_pow,
        summable_geometric_iff_norm_lt_1],
      nth_rewrite 0 [← rpow_one 2],
      rw [← division_def, ← rpow_sub zero_lt_two, norm_eq_abs,
        abs_of_pos (rpow_pos_of_pos zero_lt_two _), rpow_lt_one_iff zero_lt_two.le],
      norm_num },
    { intro n,
      exact inv_nonneg.2 (rpow_nonneg_of_nonneg n.cast_nonneg _) },
    { intros m n hm hmn,
      exact inv_le_inv_of_le (rpow_pos_of_pos (nat.cast_pos.2 hm) _)
         (rpow_le_rpow m.cast_nonneg (nat.cast_le.2 hmn) hp) } },
  /- If `p < 0`, then `1 / n ^ p` tends to infinity, thus the series diverges. -/
  { suffices : ¬summable (λ n, (n ^ p)⁻¹ : ℕ → ℝ),
    { have : ¬(1 < p) := λ hp₁, hp.not_le (zero_le_one.trans hp₁.le),
      simpa [this, -one_div] },
    { intro h,
      obtain ⟨k : ℕ, hk₁ : ((k ^ p)⁻¹ : ℝ) < 1, hk₀ : k ≠ 0⟩ :=
        ((h.tendsto_cofinite_zero.eventually (gt_mem_nhds zero_lt_one)).and
          (eventually_cofinite_ne 0)).exists,
      apply hk₀,
      rw [← pos_iff_ne_zero, ← @nat.cast_pos ℝ] at hk₀,
      simpa [inv_lt_one_iff_of_pos (rpow_pos_of_pos hk₀ _), one_lt_rpow_iff_of_pos hk₀, hp,
        hp.not_lt, hk₀] using hk₁ } }
end

@[simp] lemma real.summable_nat_rpow {p : ℝ} : summable (λ n, n ^ p : ℕ → ℝ) ↔ p < -1 :=
by { rcases neg_surjective p with ⟨p, rfl⟩, simp [rpow_neg] }

/-- Test for convergence of the `p`-series: the real-valued series `∑' n : ℕ, 1 / n ^ p` converges
if and only if `1 < p`. -/
lemma real.summable_one_div_nat_rpow {p : ℝ} : summable (λ n, 1 / n ^ p : ℕ → ℝ) ↔ 1 < p :=
by simp

/-- Test for convergence of the `p`-series: the real-valued series `∑' n : ℕ, (n ^ p)⁻¹` converges
if and only if `1 < p`. -/
@[simp] lemma real.summable_nat_pow_inv {p : ℕ} : summable (λ n, (n ^ p)⁻¹ : ℕ → ℝ) ↔ 1 < p :=
by simp only [← rpow_nat_cast, real.summable_nat_rpow_inv, nat.one_lt_cast]

/-- Test for convergence of the `p`-series: the real-valued series `∑' n : ℕ, 1 / n ^ p` converges
if and only if `1 < p`. -/
lemma real.summable_one_div_nat_pow {p : ℕ} : summable (λ n, 1 / n ^ p : ℕ → ℝ) ↔ 1 < p :=
by simp

/-- Summability of the `p`-series over `ℤ`. -/
lemma real.summable_one_div_int_pow {p : ℕ} : summable (λ n:ℤ, 1 / (n : ℝ) ^ p) ↔ 1 < p :=
begin
  refine ⟨λ h, real.summable_one_div_nat_pow.mp (h.comp_injective nat.cast_injective),
    λ h, summable_int_of_summable_nat (real.summable_one_div_nat_pow.mpr h)
    (((real.summable_one_div_nat_pow.mpr h).mul_left $ 1 / (-1) ^ p).congr $ λ n, _)⟩,
  conv_rhs { rw [int.cast_neg, neg_eq_neg_one_mul, mul_pow, ←div_div] },
  conv_lhs { rw [mul_div, mul_one], },
  refl,
end

lemma real.summable_abs_int_rpow {b : ℝ} (hb : 1 < b) : summable (λ n : ℤ, |(n : ℝ)| ^ (-b)) :=
begin
  refine summable_int_of_summable_nat (_ : summable (λ n : ℕ, |(n : ℝ)| ^ _))
    (_ : summable (λ n : ℕ, |((-n : ℤ) : ℝ)| ^ _)),
  work_on_goal 2 { simp_rw [int.cast_neg, int.cast_coe_nat, abs_neg] },
  all_goals { simp_rw (λ n : ℕ, abs_of_nonneg (n.cast_nonneg : 0 ≤ (n : ℝ))),
    rwa [real.summable_nat_rpow, neg_lt_neg_iff] },
end

/-- Harmonic series is not unconditionally summable. -/
lemma real.not_summable_nat_cast_inv : ¬summable (λ n, n⁻¹ : ℕ → ℝ) :=
have ¬summable (λ n, (n^1)⁻¹ : ℕ → ℝ), from mt real.summable_nat_pow_inv.1 (lt_irrefl 1),
by simpa

/-- Harmonic series is not unconditionally summable. -/
lemma real.not_summable_one_div_nat_cast : ¬summable (λ n, 1 / n : ℕ → ℝ) :=
by simpa only [inv_eq_one_div] using real.not_summable_nat_cast_inv

/-- **Divergence of the Harmonic Series** -/
lemma real.tendsto_sum_range_one_div_nat_succ_at_top :
  tendsto (λ n, ∑ i in finset.range n, (1 / (i + 1) : ℝ)) at_top at_top :=
begin
  rw ← not_summable_iff_tendsto_nat_at_top_of_nonneg,
  { exact_mod_cast mt (summable_nat_add_iff 1).1 real.not_summable_one_div_nat_cast },
  { exact λ i, div_nonneg zero_le_one i.cast_add_one_pos.le }
end

@[simp] lemma nnreal.summable_rpow_inv {p : ℝ} : summable (λ n, (n ^ p)⁻¹ : ℕ → ℝ≥0) ↔ 1 < p :=
by simp [← nnreal.summable_coe]

@[simp] lemma nnreal.summable_rpow {p : ℝ} : summable (λ n, n ^ p : ℕ → ℝ≥0) ↔ p < -1 :=
by simp [← nnreal.summable_coe]

lemma nnreal.summable_one_div_rpow {p : ℝ} : summable (λ n, 1 / n ^ p : ℕ → ℝ≥0) ↔ 1 < p :=
by simp

section

open finset

variables {α : Type*} [linear_ordered_field α]

lemma sum_Ioc_inv_sq_le_sub {k n : ℕ} (hk : k ≠ 0) (h : k ≤ n) :
  ∑ i in Ioc k n, ((i ^ 2) ⁻¹ : α) ≤ k ⁻¹ - n ⁻¹ :=
begin
  refine nat.le_induction _ _ n h,
  { simp only [Ioc_self, sum_empty, sub_self] },
  assume n hn IH,
  rw [sum_Ioc_succ_top hn],
  apply (add_le_add IH le_rfl).trans,
  simp only [sub_eq_add_neg, add_assoc, nat.cast_add, nat.cast_one, le_add_neg_iff_add_le,
    add_le_iff_nonpos_right, neg_add_le_iff_le_add, add_zero],
  have A : 0 < (n : α), by simpa using hk.bot_lt.trans_le hn,
  have B : 0 < (n : α) + 1, by linarith,
  field_simp [B.ne'],
  rw [div_le_div_iff _ A, ← sub_nonneg],
  { ring_nf, exact B.le },
  { nlinarith },
end

lemma sum_Ioo_inv_sq_le (k n : ℕ) :
  ∑ i in Ioo k n, ((i ^ 2) ⁻¹ : α) ≤ 2 / (k + 1) :=
calc
∑ i in Ioo k n, ((i ^ 2) ⁻¹ : α) ≤ ∑ i in Ioc k (max (k+1) n), (i ^ 2) ⁻¹ :
begin
  apply sum_le_sum_of_subset_of_nonneg,
  { assume x hx,
    simp only [mem_Ioo] at hx,
    simp only [hx, hx.2.le, mem_Ioc, le_max_iff, or_true, and_self] },
  { assume i hi hident,
    exact inv_nonneg.2 (sq_nonneg _), }
end
... ≤ ((k + 1) ^ 2) ⁻¹ + ∑ i in Ioc k.succ (max (k + 1) n), (i ^ 2) ⁻¹ :
begin
  rw [← nat.Icc_succ_left, ← nat.Ico_succ_right, sum_eq_sum_Ico_succ_bot],
  swap, { exact nat.succ_lt_succ ((nat.lt_succ_self k).trans_le (le_max_left _ _)) },
  rw [nat.Ico_succ_right, nat.Icc_succ_left, nat.cast_succ],
end
... ≤ ((k + 1) ^ 2) ⁻¹ + (k + 1) ⁻¹ :
begin
  refine add_le_add le_rfl ((sum_Ioc_inv_sq_le_sub _ (le_max_left _ _)).trans _),
  { simp only [ne.def, nat.succ_ne_zero, not_false_iff] },
  { simp only [nat.cast_succ, one_div, sub_le_self_iff, inv_nonneg, nat.cast_nonneg] }
end
... ≤ 1 / (k + 1) + 1 / (k + 1) :
begin
  have A : (1 : α) ≤ k + 1, by simp only [le_add_iff_nonneg_left, nat.cast_nonneg],
  simp_rw ← one_div,
  apply add_le_add_right,
  refine div_le_div zero_le_one le_rfl (zero_lt_one.trans_le A) _,
  simpa using pow_le_pow A one_le_two,
end
... = 2 / (k + 1) : by ring

end


import group_theory.free_group
  group_theory.group_action
  logic.relation

noncomputable theory
open free_group mul_action classical
local attribute [instance] prop_decidable

section

parameters {α : Type}
@[reducible] private def G := free_group α

parameters (Q : Type) [mul_action G Q] (r : Q) (trans_act : orbit G r = set.univ)

@[simp] lemma nil_is_id : (mk [] : G) = 1 := rfl
lemma id_is_id (x : Q) : (mk [] : G) • x = x := by simp

lemma invinv (a : α) (b : bool) : mk [(a,b)] * mk [(a,!b)] = 1
:= mul_inv_self _

@[simp] lemma inv_is_inv (x : Q) (a : α) (b : bool)
: mk [(a,b)] • mk [(a,!b)] • x = x
:= by {rw [smul_smul, invinv _ _], simp}

@[simp] lemma is_inv_inv (x : Q) (a : α) (b : bool)
: mk [(a,!b)] • mk [(a,b)] • x = x := begin
  have h : mk [(a,!b)] • mk [(a,!!b)] • x = x,
  exact inv_is_inv x a (!b),
  rwa bnot_bnot at h,
end

lemma cons_smul (p : α × bool) (l : list (α × bool)) (x : Q)
: mk [p] • mk l • x = (mk (p::l):G) • x := by {rwa smul_smul, refl}

inductive edge (s : Q) : Q → Type
| intro (p : α × bool) : edge (mk [p] • s)

variables {s t : Q}
@[simp] def proj : Π {s t}, edge s t → α × bool
| _ _ ⟨_, p⟩ := p

def change_end {s t t'} (h : t = t') : edge s t → edge s t' := λ p, eq.rec p h

@[simp] lemma change_proj : Π {s t t'} (h : t = t') (e : edge s t),
proj (change_end h e) = proj e
| _ _ _ rfl _ := rfl

@[reducible] def pbnot {β : Type} : β × bool → β × bool
| (a, b) := (a, !b)

lemma pbnot_pbnot : ∀ p : α × bool, pbnot (pbnot p) = p
| (a, b) := by simp

@[reducible] def rev : Π {s t}, edge s t → edge t s
| _ _ ⟨s, (a,b)⟩ := change_end (is_inv_inv s a b) ⟨mk [(a,b)] • s, (a,!b)⟩

@[simp] lemma rev_proj : Π {s t} (e : edge s t), proj (rev e) = pbnot (proj e)
| _ _ ⟨s, (a,b)⟩ := by {rw change_proj, refl}

lemma edge_hext : Π {s t t'} {e : edge s t} {e' : edge s t'} (h : proj e = proj e'), e == e'
| _ _ _ ⟨_, _⟩ ⟨_, _⟩ rfl := heq.rfl

lemma edge_ext {s t} {e e' : edge s t} (h : proj e = proj e') : e = e'
:= eq_of_heq $ edge_hext h

@[simp] lemma rev_rev : Π {s t} (e : edge s t), rev (rev e) = e
| _ _ ⟨s, (a,b)⟩ := by {apply edge_ext, simp}

inductive path : Q → Q → Type
| nil (s : Q) : path s s
| cons {s t t' : Q} (p : path s t) (e : edge t t') : path s t'

instance e_to_p {s t : Q} : has_coe (edge s t) (path s t) := ⟨λ e, path.cons (path.nil _) e⟩

def path_length : Π {s t : Q} (p : path s t), ℕ
| _ _ (path.nil _) := 0
| _ _ (path.cons p _) := path_length p + 1

@[simp] def pconcat : Π {a b c : Q}, path a b → path b c → path a c
| _ _ _ p (path.nil _) := p
| _ _ _ p (path.cons q e) := path.cons (pconcat p q) e

@[simp] def prev : Π {a b : Q}, path a b → path b a
| _ _ (path.nil _) := path.nil _
| _ _ (path.cons q e) := pconcat ↑(rev e) (prev q)

@[simp] def pmul : Π {a b : Q}, path a b → G
| _ _ (path.nil _) := 1
| _ _ (path.cons q e) := mk [proj e] * pmul q

@[simp] lemma pconcat_mul : ∀ {a b c : Q} (p : path a b) (q : path b c),
pmul (pconcat p q) = pmul q * pmul p
| _ _ _ _ (path.nil _) := by simp
| _ _ _ _ (path.cons _ _) := by {simp, rw [pconcat_mul, mul_assoc]}

@[simp] lemma pmul_smul : ∀ {a b : Q} (p : path a b), pmul p • a = b
| _ _ (path.nil _) := by simp
| s _ (path.cons p ⟨t, x⟩) := by {simp, rw [←smul_smul, pmul_smul]}

@[simp] def path_from_list (s : Q) : Π (l : list (α × bool)), Σ t, path s t
| [] := ⟨s, path.nil s⟩
| (p :: l) := ⟨_, path.cons (path_from_list l).2 ⟨_, p⟩⟩

lemma pfl_cons (s : Q) (l : list (α × bool)) (p : α × bool) :
  (path_from_list s (p::l)).2 = path.cons (path_from_list s l).2 ⟨_, p⟩ := rfl

lemma pfl_cons' (s : Q) (l : list (α × bool)) (p : α × bool) :
  path_from_list s (p::l) = ⟨_, path.cons (path_from_list s l).2 ⟨_, p⟩⟩ := rfl

@[simp] lemma pfl_concat : Π (s : Q) (l : list (α × bool)) (l' : list (α × bool)),
  path_from_list s (l' ++ l) = ⟨_, pconcat (path_from_list s l).2
                                (path_from_list _ l').2⟩
| s l [] := sigma.eq rfl rfl
| s l (p::l') := begin
  have hh : (p::l') ++ l = p::(l'++l), from rfl,
  rw [hh, pfl_cons', pfl_concat, pfl_cons],
  simp,
end

lemma pfl_end (s : Q) : Π (l : list (α × bool)), (path_from_list s l).1 = mk l • s
| [] := by simp
| (p :: l) := by {simp, rw pfl_end, apply cons_smul}

@[reducible] def list_from_path : Π {s t : Q} (p : path s t), list (α × bool)
| _ _ (path.nil _) := []
| _ _ (path.cons p e) := (proj e) :: list_from_path p

lemma lfp_cons {s t t' : Q} {p : path s t} {e : edge t t'}
  : list_from_path (path.cons p e) = (proj e) :: list_from_path p := rfl

lemma path_cons_ext : Π {s t t' : Q} (p : path s t) (e : edge t t'),
  (⟨mk [proj e] • t, path.cons p ⟨t, proj e⟩⟩ : Σ x, path s x) = ⟨t', path.cons p e⟩
| s _ _ p ⟨t, a⟩ := rfl

lemma path_from_path : Π {s t : Q} (p : path s t), path_from_list s (list_from_path p) = ⟨t, p⟩
| _ _ (path.nil _) := by simp
| s t' (path.cons p (e:edge t _)) := begin
  have h : list_from_path (path.cons p e) = (proj e) :: list_from_path p, from rfl,
  rw [h, pfl_cons', path_from_path],
  exact path_cons_ext p e,
end

lemma list_from_list (s : Q) : Π (l : list (α × bool)), list_from_path (path_from_list s l).2 = l
| [] := rfl
| (x::l) := begin
  rw pfl_cons,
  rw lfp_cons,
  simp,
  apply list_from_list,
end

lemma pmul_list : Π {a b : Q} (p : path a b), pmul p = mk (list_from_path p)
| _ _ (path.nil _) := by simp
| _ _ (path.cons _ _) := by {simp, rw pmul_list, simp}

@[simp] lemma path_length_nil {s : Q} : path_length (path.nil s) = 0 := rfl

@[simp] lemma path_length_cons {s t t' : Q} (p : path s t) (e : edge t t')
: path_length (path.cons p e) = path_length p + 1 := rfl

lemma path_length_zero : Π {s t : Q} (p : path s t), path_length p = 0 → t = s
| _ _ (path.nil _) _ := rfl
| s t (path.cons p e) h := begin
  exfalso,
  rw path_length_cons at h,
  exact (nat.succ_ne_zero _) h
end

def dist_ub (t : Q) (n : ℕ) : Prop := ∃ p : path r t, path_length p = n

lemma dist_ub_from_path {t : Q} (p : path r t) : dist_ub t (path_length p) := ⟨p, rfl⟩

include trans_act
lemma connected (x : Q) : nonempty (path r x) := begin
  have hx : x ∈ orbit G r,
  rw trans_act,
  trivial,
  cases hx with g hg,
  simp at hg,
  induction g with l,
  apply nonempty.intro,
  rw ←hg,
  have p : path r (mk l • r),
  rw ←pfl_end,
  exact (path_from_list r l).2,
  exact p,
  simp,
end

lemma dist_is_bounded (t : Q) : ∃ n : ℕ, dist_ub t n := begin
  cases (connected t) with p,
  use path_length p,
  exact dist_ub_from_path p
end

def dist (t : Q) : ℕ := nat.find $ dist_is_bounded t
lemma dist_is_attained (t : Q) : ∃ p : path r t, path_length p = dist t
:= nat.find_spec $ dist_is_bounded t
lemma dist_is_dist (t : Q) (p : path r t) : dist t ≤ path_length p :=
nat.find_min' _ $ dist_ub_from_path p

lemma dist_zero_iff {t : Q} : dist t = 0 ↔ t = r := begin
  split,
  intro h,
  cases dist_is_attained t with p hp,
  rw h at hp,
  exact path_length_zero p hp,
  intro h,
  rw h,
  rw le_antisymm_iff,
  split,
  exact dist_is_dist r (path.nil r),
  simp,
end

@[simp] lemma dist_root : dist r = 0 := dist_zero_iff.mpr rfl

def inbhd (x : Q) : Type := Σ y : Q, edge y x
def onbhd (x : Q) : Type := Σ y : Q, edge x y

lemma dist_is_lipschitz (x : Q) (q : onbhd x) : dist q.1 ≤ dist x + 1 := begin
  cases dist_is_attained x with p hp,
  rw ←hp,
  exact dist_is_dist q.1 (path.cons p q.2),
end

lemma ex_closer_nbr (x : Q) (hx : x ≠ r) : ∃ p : inbhd x, dist x = dist p.1 + 1 := begin
  cases dist_is_attained x with p hp,
  cases p with p e,
  exfalso,
  apply hx,
  refl,
  use p_t,
  use p_e,
  rw le_antisymm_iff,
  split,
  exact dist_is_lipschitz p_t ⟨x, p_e⟩,
  rw ←hp,
  simp,
  exact dist_is_dist _ _
end

def my_closer_nbr (x : Q) (hx : x ≠ r) : {p : inbhd x // dist x = dist p.1 + 1} :=
  subtype_of_exists $ ex_closer_nbr x hx

def nb (t : Q) (hn : t ≠ r) : Q := (my_closer_nbr t hn).1.1
def nb_is_nb (t : Q) (hn : t ≠ r) : dist t = dist (nb t hn) + 1 := (my_closer_nbr t hn).2
def nb_edge (t : Q) (hn : t ≠ r) : edge (nb t hn) t := (my_closer_nbr t hn).1.2

section bar
universe v
@[simp] def rec_aux {P : ℕ → Sort v} (f : Π n, (Π m, n = m+1 → P m) → P n) : Π n, P n
| 0 := f 0 (λ m h, false.elim $ nat.succ_ne_zero m h.symm)
| (n+1) := f (n+1) (λ m h, eq.rec (rec_aux n) (nat.succ_inj h))
end bar

section tree_recursion
universe u
parameters {pt : Q → Sort u} (ptr : pt r) (pt_succ : Π t (hn : t ≠ r), pt (nb t hn) → pt t)

@[simp] def helper (n) (f : Π m : ℕ, n = m+1 → (Π x, dist x = m → pt x)) (t) (h : dist t = n) : pt t :=
dite (t=r) (λ hr, eq.rec ptr hr.symm) $ λ hnr,
pt_succ t hnr (f (dist $ nb t hnr) (eq.rec (nb_is_nb t hnr) h) _ rfl)

def tree_recursion (t : Q) : pt t := rec_aux helper (dist t) t rfl

lemma my_ext {t : Q} : Π n (h : dist t = n),
rec_aux helper n t h = rec_aux helper (dist t) t rfl | _ rfl := rfl

lemma recursion_at_root : tree_recursion r = ptr := begin
  have hh : tree_recursion r = rec_aux helper 0 r dist_root,
  exact (my_ext 0 dist_root).symm,
  rw hh,
  simp,
end

lemma recursion_away (t : Q) (h : t ≠ r) : tree_recursion t
= pt_succ t h (tree_recursion (nb t h)) := begin
  have hh : tree_recursion t = rec_aux helper (dist (nb t h) + 1) t (nb_is_nb t h),
  exact (my_ext _ (nb_is_nb t h)).symm,
  rw hh,
  simp,
  apply dif_neg,
end
end tree_recursion

def tree_path : Π t, path r t := tree_recursion (path.nil r)
(λ t hn p, path.cons p (nb_edge t hn))

def is_in_dir_tree {s t : Q} (e : edge s t) : Prop :=
  ∃ (hn : t ≠ r), (my_closer_nbr t hn).1 = ⟨s, e⟩

def is_in_tree {s t : Q} (e : edge s t) : Prop :=
  is_in_dir_tree e ∨ is_in_dir_tree (rev e)

lemma is_in_tree_unfold {s t : Q} (e : edge s t)
: is_in_tree e ↔ is_in_dir_tree e ∨ is_in_dir_tree (rev e) := by refl

lemma is_in_tree_rev {s t : Q} {e : edge s t} : is_in_tree (rev e) ↔ is_in_tree e :=
  by {repeat {rw is_in_tree_unfold}, simp, tauto}

lemma not_in_tree_rev {s t : Q} {e : edge s t} : ¬is_in_tree (rev e) ↔ ¬is_in_tree e
:= by {rw is_in_tree_rev}

def R : Type := {p : Σ s t, edge s t // ¬is_in_tree p.2.2 ∧ (proj p.2.2).2}
def to_s (x : R) : Q := x.1.1
def to_t (x : R) : Q := x.1.2.1
def to_edge (x : R) : edge (to_s x) (to_t x) := x.1.2.2
def rmk (s t : Q) (e : edge s t) (h : ¬ is_in_tree e) (hh : (proj e).2)
  : R := ⟨⟨s, t, e⟩, h, hh⟩

def rmk_ext : Π {s t : Q} {e e' : edge s t} {h : ¬is_in_tree e} {hh : (proj e).2}
  {h' : ¬is_in_tree e'} {hh' : (proj e').2} (he : e = e'), rmk s t e h hh = rmk s t e' h' hh'
| _ _ _ _ _ _ _ _ rfl := rfl

lemma rev_ori : Π {s t} {e : edge s t}, (proj (rev e)).2 ↔ ¬(proj e).2
| _ _ ⟨s, (a,tt)⟩ := by simp
| _ _ ⟨s, (a,ff)⟩ := by simp

def from_edge {s t : Q} (e : edge s t) (h : ¬is_in_tree e) : R × bool :=
dite (proj e).2 (λ hh, (rmk s t e h hh, tt))
                (λ hh, (rmk t s (rev e) (not_in_tree_rev.mpr h) (rev_ori.mpr hh), ff))

lemma from_edge_unfold {s t : Q} (e : edge s t) (h : ¬is_in_tree e) :
from_edge e h = dite (proj e).2 (λ hh, (rmk s t e h hh, tt))
       (λ hh, (rmk t s (rev e) (not_in_tree_rev.mpr h) (rev_ori.mpr hh), ff)) := rfl

lemma r_from_r : Π x : R, from_edge (to_edge x) x.2.1 = (x, tt)
| ⟨⟨s, ⟨t, e⟩⟩, ⟨h, hh⟩⟩ := begin
  rw [from_edge_unfold, dif_pos],
  refl,
  assumption,
end

lemma from_edge_rev : Π {s t : Q} (e : edge s t) (h : ¬ is_in_tree e)
  (h' : ¬ is_in_tree (rev e)), from_edge (rev e) h' = pbnot (from_edge e h)
| _ _ ⟨s, (a,tt)⟩ h h' := begin
  repeat {rw from_edge_unfold},
  rw [dif_neg, dif_pos, rmk_ext (rev_rev _)],
  refl,
  simp,
  simp,
end
| _ _ ⟨s, (a,ff)⟩ h h' :=
by {repeat {rw from_edge_unfold}, rw [dif_pos, dif_neg], refl, simp}

def from_edge_maybe {s t} (e : edge s t) : list (R × bool) :=
  dite (is_in_tree e) (λ _, []) (list.ret ∘ from_edge e)

lemma fem_unfold {s t} {e : edge s t} :
  from_edge_maybe e = dite (is_in_tree e) (λ _, []) (λ h, [from_edge e h]) := rfl

def to_loop (x : R) : path r r :=
  pconcat (path.cons (tree_path (to_s x)) (to_edge x)) $ prev $ tree_path (to_t x)

def F := free_group R
@[simp] private def H := stabilizer G r

instance H_is_subgroup : is_subgroup H := mul_action.is_subgroup r

@[simp] noncomputable def plist : Π {a b : Q}, path a b → list (R × bool)
| _ _ (path.nil _) := []
| _ _ (path.cons p e) := from_edge_maybe e ++ plist p

lemma plist_wd : Π {s s' : Q} (h : s = s') (l : list (α × bool)),
  plist (path_from_list s l).snd = plist (path_from_list s' l).snd
| _ _ rfl _ := rfl

lemma plist_concat : Π {a b c : Q} (p : path a b) (p' : path b c),
  plist (pconcat p p') = plist p' ++ plist p
| a _ _ p (path.nil b) := by simp
| a b c' p (path.cons p' e) := by {simp, rw plist_concat}

lemma tree_path_root : tree_path r = path.nil r
  := recursion_at_root _ _

lemma tree_path_away {x : Q} (hn : x ≠ r)
  : tree_path x = path.cons (tree_path (nb x hn)) (nb_edge x hn)
  := recursion_away _ _ _ _

@[reducible] def rlist : Q → list (α × bool) → list (R × bool)
  := λ s l, plist (path_from_list s l).2

@[simp] lemma rlist_concat (s : Q) (l l' : list (α × bool)) :
rlist s (l' ++ l) = rlist (mk l • s) l' ++ rlist s l := begin
  have h : rlist s (l' ++ l) = plist (path_from_list s (l' ++ l)).2, from rfl,
  rw [h, pfl_concat],
  simp,
  rw [plist_concat, plist_wd (pfl_end s l) l'],
end

@[simp] def rmul : Q → list (α × bool) → F := λ s l, mk (rlist s l)

lemma concat_to_mul {l l' : list (R × bool)} :
  mk (l++l') = mk l * mk l' := rfl

lemma rlist_singleton {t : Q} {p : α × bool} :
  rlist t [p] = plist (path.cons (path.nil t) (edge.intro t p)) := rfl

lemma plist_singleton {s t : Q} {e : edge s t} : plist (path.cons (path.nil s) e)
  = from_edge_maybe e := by simp

lemma change_fem : Π {s t t'} {e : edge s t} (h : t = t'),
  from_edge_maybe e = from_edge_maybe (change_end h e)
| _ _ _ _ rfl := rfl

lemma plist_tp : Π {x : Q}, plist (tree_path x) = []
  := tree_recursion (by {rw tree_path_root, simp}) begin
  intros x hn h,
  rw tree_path_away hn,
  simp,
  split,
  rw fem_unfold,
  rw dif_pos,
  apply or.inl,
  use hn,
  exact sigma.eq rfl rfl,
  assumption,
end

lemma plist_rev_tp : Π {x : Q}, plist (prev $ tree_path x) = []
  := tree_recursion (by {rw tree_path_root, simp}) begin
  intros x hn h,
  rw tree_path_away hn,
  simp,
  rw plist_concat,
  simp,
  split,
  assumption,
  have p : ↑(rev (nb_edge x hn)) = path.cons (path.nil _) (rev (nb_edge x hn)),
  refl,
  rw p,
  rw plist_singleton,
  rw fem_unfold,
  rw dif_pos,
  apply or.inr,
  rw rev_rev,
  use hn,
  exact sigma.eq rfl rfl,
end

lemma pbnot_inv {β : Type} : Π (p : β × bool), mk [pbnot p] * mk [p] = 1
| (a, b) := inv_mul_self $ mk [(a,b)]

lemma inv_pbnot {β : Type} : Π (p : β × bool), mk [p] * mk [pbnot p] = 1
| (a, b) := mul_inv_self $ mk [(a,b)]

lemma red_smul : ∀ {s l l'}, red.step l l' → rmul s l = rmul s l'
| s _ _ (@red.step.bnot _ L1 L2 a b) := begin
  simp,
  have h : (mk ((a,b)::(a,!b)::L2) : G) = mk L2,
  from quot.sound (@red.step.bnot _ [] L2 a b),
  rw h,
  suffices g : mk (rlist s ((a,b)::(a,!b)::L2)) = mk (rlist s L2),
  by {repeat {rw concat_to_mul}, cc},
  have h : (((a,b)::(a,!b)::L2):list(α×bool)) = [(a,b)] ++ [(a,!b)] ++ L2,
  from rfl,
  rw h,
  repeat {rw rlist_concat},
  repeat {rw concat_to_mul},
  set t := mk L2 • s,
  suffices g : mk (rlist (mk [(a,!b)] • t) [(a,b)]) * mk (rlist t [(a,!b)]) = 1,
  by {rw g, simp},
  repeat {rw rlist_singleton},
  repeat {rw plist_singleton},
  set e := edge.intro t (a,!b),
  have h : from_edge_maybe (edge.intro (mk [(a,!b)] • t) (a,!!b)) = from_edge_maybe (rev e),
  apply change_fem,
  rw bnot_bnot at h,
  rw h,
  repeat {rw fem_unfold},
  cases (em $ is_in_tree e) with pos neg,
  rw [dif_pos, dif_pos],
  simp,
  assumption,
  rwa is_in_tree_rev,
  rw [dif_neg, dif_neg, from_edge_rev],
  apply pbnot_inv,
  assumption,
  rwa is_in_tree_rev,
end

instance f_is_group : group F := free_group.group

def f_of_g : G → F := quot.lift (rmul r) (@red_smul r)
def f_of_h : H → F := f_of_g ∘ coe
def h_of_f : F → H := to_group $ λ a, ⟨pmul (to_loop a), by simp⟩

lemma f_of_g.mk (l : list (α × bool)) : f_of_g (mk l) = rmul r l := rfl
lemma f_of_h_mul : ∀ (x : G) (y : H), f_of_g (x*y) = f_of_g x * f_of_g y
| x ⟨y, h⟩ := begin
  induction x with l,
  induction y with l',
  simp,
  simp at h,
  repeat {rw f_of_g.mk},
  simp,
  rw h,
  simp,
  simp,
end

instance f_of_h.is_hom : is_group_hom f_of_h := {map_mul := λ x y, f_of_h_mul x y}
instance h_of_f.is_hom : is_group_hom h_of_f := to_group.is_group_hom

lemma coe_mul {a b : H} : ↑(a*b) = (↑a * ↑b:G) := rfl

lemma pmul_tp_change : Π {s t : Q} {e : edge s t} (h : is_in_dir_tree e),
  mk [proj e] * pmul (tree_path s) = pmul (tree_path t)
| s t e ⟨hn, he⟩ := begin
  have p : s = (my_closer_nbr t hn).1.1,
  rw he,
  have q : proj e = proj ((my_closer_nbr t hn).1.2),
  rw he,
  rw q,
  rw p,
  suffices g : mk [proj (nb_edge t hn)] * pmul (tree_path (nb t hn))
                = pmul (tree_path t),
  exact g,
  rw tree_path_away hn,
  simp,
end

lemma pmul_prev : Π {s t} (p : path s t), pmul (prev p) = (pmul p)⁻¹
| _ _ (path.nil s) := by simp
| s t' (path.cons p (e:edge t _)) := begin
  simp,
  rw pmul_prev,
  simp,
  have h : ↑(rev e) = path.cons (path.nil t') (rev e), from rfl,
  rw h,
  simp,
  cases proj e with a b,
  refl,
end

lemma h_of_f.from_edge {s t} {e : edge s t} (hn : ¬is_in_tree e) (h : (proj e).2) :
  ↑(h_of_f (mk [from_edge e hn])) = (pmul (tree_path t))⁻¹ * mk [proj e] *
                                    pmul (tree_path s) := begin
  rw from_edge_unfold,
  rw dif_pos h,
  have p : ∀ x, h_of_f x = to_group (λ a, ⟨pmul (to_loop a), by simp⟩) x,
  intro x,
  refl,
  rw p,
  have q : mk [(rmk s t e hn h, tt)] = of (rmk s t e hn h), from rfl,
  rw q,
  rw to_group.of,
  simp,
  have p' : to_loop (rmk s t e hn h) = pconcat (path.cons (tree_path s) e) (prev (tree_path t)),
  refl,
  rw p',
  simp,
  rw mul_assoc,
  simp,
  apply pmul_prev,
  exact r, -- TODO: where does this goal come from???
end

lemma pbnot_is_inv {β : Type} : Π (p : β × bool), mk [pbnot p] = (mk [p])⁻¹
| (x, b) := rfl

lemma coe_inv {x : H} : (↑x⁻¹ : G) = (↑x)⁻¹ := rfl

lemma h_of_f.from_edge' {s t} {e : edge s t} (hn : ¬is_in_tree e) (h : ¬(proj e).2) :
  ↑(h_of_f (mk [from_edge e hn])) = (pmul (tree_path t))⁻¹ * mk [proj e] *
                                    pmul (tree_path s) := begin
  have p : from_edge e hn = pbnot (from_edge (rev e) (not_in_tree_rev.mpr hn)),
  rw from_edge_unfold,
  rw from_edge_unfold,
  rw [dif_neg, dif_pos],
  refl,
  assumption,
  rw p,
  rw pbnot_is_inv,
  rw is_group_hom.map_inv h_of_f,
  have q : ↥(proj $ rev e).2,
  rw rev_ori,
  assumption,
  rw coe_inv,
  rw h_of_f.from_edge,
  repeat {rw mul_inv_rev},
  repeat {rw mul_assoc},
  rw mul_left_inj,
  rw inv_inv,
  rw mul_right_inj,
  rw rev_proj,
  rw pbnot_is_inv,
  simp,
  assumption,
end

lemma g_of_p : Π {s t} {p : path s t}, pmul p
  = pmul (tree_path t) * h_of_f (mk $ plist p) * (pmul (tree_path s))⁻¹
| _ _ (path.nil s) := begin
  have h : plist (path.nil s) = [], from rfl,
  rw h,
  have h' : h_of_f (mk []) = 1, from rfl,
  rw h',
  simp,
end
| s t' (path.cons p (e:edge t _)) := begin
  simp,
  rw g_of_p,
  rw ←mul_assoc,
  simp,
  have h : mk (from_edge_maybe e ++ plist p) =
    mk (from_edge_maybe e) * mk (plist p), from rfl,
  rw h,
  rw is_mul_hom.map_mul h_of_f,
  rw coe_mul,
  repeat {rw ←mul_assoc},
  simp,
  cases (em $ is_in_tree e) with pos neg,
  rw [fem_unfold, dif_pos pos],
  have h' : h_of_f (mk []) = 1, from rfl,
  rw h',
  simp,
  cases pos with a b,
  exact pmul_tp_change a,
  rw ←pmul_tp_change b,
  rw ←mul_assoc,
  simp,
  exact inv_pbnot _,
  rw [fem_unfold, dif_neg neg],
  cases (em (proj e).2) with x y,
  rw h_of_f.from_edge neg x,
  repeat {rw ←mul_assoc},
  simp,
  rw h_of_f.from_edge' neg y,
  repeat {rw ←mul_assoc},
  simp,
end

instance f_of_f_is_hom : is_group_hom (f_of_h ∘ h_of_f) := is_group_hom.comp _ _

lemma f_of_f (f : F) : f_of_h (h_of_f f) = f := begin
  suffices g : f_of_h (h_of_f f) = to_group of f,
  rw g,
  exact to_group.of_eq _,
  apply to_group.unique (f_of_h ∘ h_of_f),
  intro x,
  simp,
  have p : h_of_f (of x) = ⟨pmul (to_loop x), by simp⟩, from to_group.of,
  rw p,
  have p : f_of_h ⟨pmul (to_loop x), by simp⟩ = f_of_g (pmul (to_loop x)), from rfl,
  rw [p, pmul_list, f_of_g.mk],
  have p : rmul r (list_from_path (to_loop x)) = mk (plist (path_from_list r (list_from_path (to_loop x))).2),
  refl,
  rw [p, path_from_path],
  simp,
  have p : to_loop x = pconcat (path.cons (tree_path (to_s x)) (to_edge x))
                        (prev $ tree_path (to_t x)),
  refl,
  rw [p, plist_concat, plist_rev_tp],
  simp,
  rw plist_tp,
  simp,
  rw [fem_unfold, dif_neg, r_from_r],
  refl,
  exact r,
end

lemma h_of_h : ∀ h : H, h_of_f (f_of_h h) = h
| ⟨x, hh⟩ := begin
  induction x with l,
  have p : f_of_h = f_of_g ∘ coe, from rfl,
  rw p,
  rw subtype.ext,
  simp,
  rw f_of_g.mk,
  have h : rmul r l = mk (plist (path_from_list r l).2),
  refl,
  rw h,
  have q : mk l = mk (list_from_path (path_from_list r l).2),
  rw list_from_list r l,
  rw q,
  set pp := (path_from_list r l).2 with hpp,
  rw ←pmul_list,
  rw g_of_p,
  have h' : pmul (tree_path (path_from_list r l).1) = pmul (tree_path $ mk l • r),
  rw pfl_end r l,
  rw h',
  have hh' : mk l • r = r, from hh,
  rw hh',
  repeat {rw tree_path_root},
  simp,
  refl,
  exact r,
  simp, -- TODO: ???
end

def isom : stabilizer G r ≃* free_group R
  := ⟨f_of_h, h_of_f, h_of_h, f_of_f, is_mul_hom.map_mul _⟩

@[simp] def rhs_of_lhs : Q × α ⊕ unit → Q ⊕ R
| (sum.inl (s, a)) := dite (is_in_tree ⟨s, (a,tt)⟩)
  (λ _, sum.inl $ ite (is_in_dir_tree ⟨s, (a,tt)⟩) (of a • s) s)
  (λ hn, sum.inr $ (from_edge ⟨s, (a,tt)⟩ hn).1)
| (sum.inr ()) := sum.inl r

@[simp] def lhs_of_rhs : Q ⊕ R → Q × α ⊕ unit
| (sum.inl s) := dite (s = r) (λ _, sum.inr ())
  (λ hn, sum.inl (ite (proj $ nb_edge s hn).2 (nb s hn) s, (proj $ nb_edge s hn).1))
| (sum.inr ⟨⟨_, _, s, (a,b)⟩, _⟩) := sum.inl (s, a)

def lhs_of_lhs : ∀ x, lhs_of_rhs (rhs_of_lhs x) = x
| (sum.inl (s,a)) := dite (is_in_tree ⟨s, (a,tt)⟩)
begin
  intro pos,
  simp,
  rw dif_pos pos,
  simp,
  set e := edge.intro s (a,tt),
  cases (em $ is_in_dir_tree e) with vr rv,
  rw if_pos vr,
  cases vr with hn he,
  have p : mk [(a,tt)] = of a, from rfl,
  rw p at hn,
  rw dif_neg hn,
  rw sum.inl.inj_iff,
  set t := (my_closer_nbr (of a • s) hn).val,
  have hne : nb_edge (of a • s) hn_1 = t.2, from rfl,
  repeat {rw hne},
  have hnb : nb (of a • s) hn_1 = t.1, from rfl,
  have hv : t = ⟨s, e⟩, from he,
  have hp : proj t.2 = proj (⟨s, e⟩:inbhd (of a • s)).2,
  exact congr_arg (λ x : inbhd (of a • s), proj x.2) hv,
  repeat {rw hp},
  simp,
  rw hnb,
  rw hv,

  rw if_neg rv,
  have h : is_in_dir_tree (rev e),
  cases pos with le ri,
  exact false.elim (rv le),
  assumption,
  cases h with hn he,
  rw dif_neg hn,
  rw sum.inl.inj_iff,
  set t := (my_closer_nbr s hn).val,
  have hne : nb_edge s hn = t.2, from rfl,
  repeat {rw hne},
  have hnb : nb s hn = t.1, from rfl,
  have hv : t = ⟨of a • s, rev e⟩, from he,
  have hp : proj t.2 = proj (⟨of a • s, rev e⟩ : inbhd s).2,
  exact congr_arg (λ x : inbhd s, proj x.2) hv,
  repeat {rw hp},
  simp,
end begin
  intro neg,
  simp,
  rw dif_neg neg,
  rw from_edge_unfold,
  rw dif_pos,
  swap,
  simp,
  simp,
  have h : rmk s (mk [(a,tt)] • s) ⟨s, (a,tt)⟩ neg (by simp) = ⟨⟨s, of a • s, s, (a,tt)⟩, neg, (by simp)⟩,
  refl,
  rw h,
  refl,
end
| (sum.inr ()) := by simp

def end_is_end : Π {s t} (e : edge s t), mk [proj e] • s = t
| _ _ ⟨_, _⟩ := rfl

def change_is_in_dir_tree : Π {s t t'} {e : edge s t}
  (h : t = t'), is_in_dir_tree (change_end h e) ↔ is_in_dir_tree e
| _ _ _ _ rfl := by refl

def change_is_in_tree : Π {s t t'} {e : edge s t}
  (h : t = t'), is_in_tree (change_end h e) ↔ is_in_tree e
| _ _ _ _ rfl := by refl

lemma nb.unique : Π {s s'} {h : s ≠ r} {h' : s' ≠ r} (he : s = s'), nb s h = nb s' h'
| _ _ _ _ rfl := rfl

def not_in_2_cycle (s) : Prop
  := ∀ (h : s ≠ r) (h' : nb s h ≠ r), s ≠ nb (nb s h) h'

lemma no_2_cycle : ∀ (s) (h : s ≠ r) (h' : nb s h ≠ r), s ≠ nb (nb s h) h'
  := @tree_recursion not_in_2_cycle (λ h, false.elim (h rfl)) begin
  intros t hn f hn' h' he,
  rw he at hn,
  apply f h' hn,
  apply nb.unique,
  cc,
end

def rhs_of_rhs : ∀ x, rhs_of_lhs (lhs_of_rhs x) = x
| (sum.inl s) := dite (s = r) (λ h, eq.rec (by simp) h.symm) begin
  intro hn,
  simp,
  rw dif_neg hn,
  cases (em $ (proj (nb_edge s hn)).2) with le ri,
  rw if_pos le,
  simp,
  have h : ((proj $ nb_edge s hn).1, tt) = proj (nb_edge s hn),
  ext,
  refl,
  simp,
  symmetry,
  assumption,
  rw h,
  set t := proj (nb_edge s hn),
  have p : mk [t] • (nb s hn) = s,
  exact end_is_end _,
  have he : edge.intro (nb s hn) t = change_end p.symm (nb_edge s hn),
  apply edge_ext,
  simp,
  have hd : is_in_dir_tree (edge.intro (nb s hn) t),
  rw he,
  rw change_is_in_dir_tree,
  use hn,
  exact sigma.eq rfl rfl,
  have ht : is_in_tree (edge.intro (nb s hn) t),
  exact or.inl hd,
  rw dif_pos ht,
  rw sum.inl.inj_iff,
  rw if_pos hd,
  rw ←h at p,
  exact p,

  rw if_neg ri,
  simp,
  have hp : ((proj $ nb_edge s hn).1, tt) = proj (rev $ nb_edge s hn),
    rw rev_proj,
    ext,
    have ha : ∀ x, (pbnot x).1 = x.1,
    intro x,
    cases x with a b,
    refl,
    rw ha,
    simp,
    symmetry,
    have ha : ∀ x, (pbnot x).2 = !x.2,
    intro x,
    cases x with a b,
    refl,
    rw ha,
    simp,
    exact bool_eq_false ri,
  have hm : mk [proj $ rev $ nb_edge s hn] • s = nb s hn,
  exact end_is_end _,
  rw hp,
  rw dif_pos,
  rw sum.inl.inj_iff,
  rw if_neg,
  intro h,
  cases h with hn' hh,
  have hs : nb (mk [proj $ rev $ nb_edge s hn] • s) hn' = s,
  exact congr_arg _ hh,
  rw nb.unique hm at hs,
  swap,
  rw ←hm,
  assumption,
  apply no_2_cycle s,
  exact hs.symm,
  have he : edge.intro s (proj $ rev $ nb_edge s hn) = change_end hm.symm (rev $ nb_edge s hn),
  apply edge_ext,
  simp,
  rw he,
  rw change_is_in_tree,
  rw is_in_tree_rev,
  apply or.inl,
  use hn,
  exact sigma.eq rfl rfl,
end
| (sum.inr ⟨⟨_, _, s, (a, b)⟩, h, hh⟩) := begin
  simp,
  have hh' : b = tt, from hh,
  rw hh' at h,
  have h' : ¬is_in_tree ⟨s, (a, tt)⟩, from h,
  rw dif_neg h',
  rw sum.inr.inj_iff,
  rw from_edge_unfold,
  rw dif_pos,
  swap,
  simp,
  rw subtype.ext,
  simp,
  rw hh',
  refl,
end

def index_equiv : Q × α ⊕ unit ≃ Q ⊕ R
  := ⟨rhs_of_lhs, lhs_of_rhs, lhs_of_lhs, rhs_of_rhs⟩

end


meta mutual inductive holtype, holterm
with holtype : Type
| o : holtype -- Boolean (predefined TFF $o)
| i : holtype -- Individual (predefined TFF $i, default type)
| int : holtype -- Individual (predefined TFF $int, integer)
| rat : holtype -- Individual (predefined TFF $rat, rational numbers)
| real : holtype -- Individual (predefined TFF $real, real numbers)
| type : holtype -- Type (predefined TFF $tType)
| ltype : name → holtype -- Self-specified type
| functor : list holtype → holtype → holtype
-- binder !> in HOL (example: !>[A: $tType, B: $tType] : ((map@A@B) > A > B))  where map : $tType > $tType > $tType
| dep_binder : list (name × holtype) → holtype → holtype -- We only encode !>[A: $tType, B: $tType] by the first list. Afterwards, it can be any holtype
-- Should for example encode "map@A@B" as stated above
| partial_app : holterm → holtype

-- Problem: dependencies to each other...
with holterm : Type
| const : name → holterm -- Constant with given label
| lconst : name → holtype → holterm -- Second term should rather by holtype
| prf : holterm
| var : nat → holterm -- Variables just specified by counter: X1,X2,X3,...
| app : holterm → holterm → holterm -- @(t,s) is the same as t s => apply t on input s
-- Encode λ-expressions explicitly
| lambda : name → holtype → holterm → holterm
-- Pi expression should not be necessary/implemented in TH1?
-- | pi : nat → holtype → holterm → holterm
-- Boolean constant
| top : holterm
| bottom : holterm

meta inductive holform
| P : holterm → holform -- Provability of a term (used in e.g. hammer_f if expression does not fit to any other option)
| T : holterm → holtype → holform -- Encoding of term constraints
| eq : holterm → holterm → holform -- Equality. t == s
| bottom : holform -- Constant False
| top : holform -- Constant True
| neg : holform → holform -- Negation function. ¬A
| imp : holform → holform → holform -- Imply: A → B
| iff : holform → holform → holform -- Two-sided imply/iff: A ↔ B
| conj : holform → holform → holform -- Conjunction: A ∧ B
| disj : holform → holform → holform -- Disjunction: A ∨ B
| all : name → holtype → holform → holform -- For all: ∀ (a : α) t -- a is the name of the parameter/variable, α the type, t the formula
| exist : name → holtype → holform → holform -- Exists: ∃ (a : α) t -- Similar as above

meta structure introduced_constant := -- Structure representing a new constant introduced for translation
(n : name) (e : expr) -- name and type

meta structure axioma := -- Note: axiom is reserved word in Lean, thus the additional a
(n : name) (f : holform) -- Every axiom is specified by a name and its formula

meta structure type_def :=
(def_name : name) (type_name : name) (t : holtype)

meta inductive role -- Role of a formula. Can be either axiom, definition or conjecture
| axioma : role
| r_definition : role -- Keyword "definition" already used in Lean
| conjecture : role

meta def role.to_format : role → format
| role.axioma := to_fmt "axiom"
| role.r_definition := to_fmt "definition"
| role.conjecture := to_fmt "conjecture"

meta structure hammer_state := -- Structure representing the state of the hammer (list of axioms with corresponding list of newly introduced constants for translation)
(axiomas : list axioma)
(type_definitions : list type_def)
(introduced_constants : list introduced_constant)

meta def hammer_tactic :=
state_t hammer_state tactic

meta def holterm.abstract_locals_core : holterm → ℕ → list name → holterm
| e@(holterm.lconst n n1) d ln :=
  list.foldl
    (λ e' n', if n = n' then holterm.var $ d + ln.reverse.find_index (= n) else e')
    e
    ln
| (holterm.app t1 t2) d ln := holterm.app (t1.abstract_locals_core d ln) (t2.abstract_locals_core d ln)
-- | e@(holterm.lambda n t1 )
| e d ln := e

meta def holterm.abstract_locals : holterm → list name → holterm := λ f l, f.abstract_locals_core 0 l

meta def holform.abstract_locals_core : holform → nat → list name → holform
| e@(holform.P t) d ln := holform.P $ t.abstract_locals_core d ln
| e@(holform.T t u) d ln := e
| e@(holform.eq t u) d ln := holform.eq (t.abstract_locals_core d ln) (u.abstract_locals_core d ln)
| e@(holform.neg f) d ln := holform.neg (f.abstract_locals_core d ln)
| e@(holform.imp f1 f2) d ln := holform.imp (f1.abstract_locals_core d ln) (f2.abstract_locals_core d ln)
| e@(holform.iff f1 f2) d ln := holform.iff (f1.abstract_locals_core d ln) (f2.abstract_locals_core d ln)
| e@(holform.conj f1 f2) d ln := holform.conj (f1.abstract_locals_core d ln) (f2.abstract_locals_core d ln)
| e@(holform.disj f1 f2) d ln := holform.disj (f1.abstract_locals_core d ln) (f2.abstract_locals_core d ln)
| e@(holform.all n n1 f) d ln := holform.all n n1 (f.abstract_locals_core (d+1) ln)
| e@(holform.exist n n1 f) d ln := holform.exist n n1 (f.abstract_locals_core (d+1) ln)
| e d ln := e

meta def holform.abstract_locals : holform → list name → holform := λ f l, f.abstract_locals_core 0 l

meta mutual def holtype_list_to_repr, holtype_cross_list_to_repr, holtype.repr, holterm.repr
with  holtype_list_to_repr : list holtype → string
| (x :: xs) := x.repr ++ " " ++ (holtype_list_to_repr xs)
| [] := ""

with  holtype_cross_list_to_repr : list (name × holtype) → string
| ((n,x) :: xs) := name.to_string n ++ ":" ++ x.repr ++ " " ++ (holtype_cross_list_to_repr xs)
| [] := ""

with holtype.repr : holtype → string
| e@(holtype.o) := "(holtype.o)"
| e@(holtype.i) := "(holtype.i)"
| e@(holtype.int) := "(holtype.int)"
| e@(holtype.rat) := "(holtype.rat)"
| e@(holtype.real) := "(holtype.real)"
| e@(holtype.type) := "(holtype.type)"
| e@(holtype.ltype n) := "(holtype.ltype " ++ name.to_string n ++ ")"
| e@(holtype.functor ts t) := "(holtype.functor [" ++  holtype_list_to_repr ts ++ "] " ++ t.repr ++ ")"
| e@(holtype.dep_binder ts t) := "(holtype.dep_binder [" ++ holtype_cross_list_to_repr ts ++ "] " ++ t.repr ++ ")"
| e@(holtype.partial_app t) := "(holtype.partial_app " ++ t.repr ++ ")"

with holterm.repr : holterm → string
| e@(holterm.const n) := "(holterm.constant " ++ name.to_string n ++ ")"
| e@(holterm.lconst n t) := "(holterm.local_const " ++ name.to_string n ++ holtype.repr t ++ ")"
| e@(holterm.prf) := "(holterm.prf)"
| e@(holterm.var n) := "(holterm.var " ++ repr n ++ ")"
| e@(holterm.app t1 t2) := "(holterm.app " ++ holterm.repr t1 ++ " " ++ holterm.repr t2 ++ ")"
-- Encode λ-expressions explicitly
| e@(holterm.lambda n ty t) := "(holterm.lambda " ++ name.to_string n ++ " " ++ holtype.repr ty ++ " " ++ holterm.repr t ++ ")"
-- | e@(holterm.pi n ty t) := "(holterm.pi " ++ repr n ++ " " ++ holtype.repr ty ++ " " ++ holterm.repr t ++ ")"
-- Boolean constant
| e@(holterm.top) := "(holterm.top)"
| e@(holterm.bottom) := "(holterm.bottom)"

meta def holform.repr : holform → string
| e@(holform.P t) := "(holform.P " ++ t.repr ++ ")"
| e@(holform.T n t) := "(holform.T " ++ holterm.repr n ++ holtype.repr t ++ ")"
| e@(holform.eq t1 t2) := "(holform.eq " ++ t1.repr ++ t2.repr ++ ")"
-- Boolean constant
| e@(holform.bottom) := "(holform.bottom)"
| e@(holform.top) := "(holform.top)"
| e@(holform.neg f) := "(holform.neg " ++ f.repr ++ ")"
| e@(holform.imp f1 f2) := "(holform.imp " ++ f1.repr ++ " " ++ f2.repr ++ ")"
| e@(holform.iff f1 f2) := "(holform.iff " ++ f1.repr ++ " " ++ f2.repr ++ ")"
| e@(holform.conj f1 f2) := "(holform.conj " ++ f1.repr ++ " " ++ f2.repr ++ ")"
| e@(holform.disj f1 f2) := "(holform.disj " ++ f1.repr ++ " " ++ f2.repr ++ ")"
| e@(holform.all n t f) := "(holform.all " ++ name.to_string n ++ " " ++ t.repr  ++ " " ++ f.repr ++ ")"
| e@(holform.exist n t f) := "(holform.exist " ++ name.to_string n ++ " " ++ t.repr ++ " " ++ f.repr ++ ")"

meta mutual def holtype_list_to_format, holtype_cross_list_to_format, holtype.to_format_aux, holterm.to_format_aux
with  holtype_list_to_format : list holtype → ℕ → ℕ → string → format
| (x :: xs) depth n c := if n > 0
                   then " " ++ c ++ " " ++ x.to_format_aux depth ++ (holtype_list_to_format xs depth (n+1) c)
                   else x.to_format_aux depth ++ (holtype_list_to_format xs depth (n+1) c)
| [] depth n c := ""

with  holtype_cross_list_to_format : list (name × holtype) → ℕ → ℕ → string → format
| ((na,x) :: xs) depth n c := if n > 0
                   then " " ++ c ++ " " ++ to_fmt na ++ ": " ++ x.to_format_aux depth ++ (holtype_cross_list_to_format xs depth (n+1) c)
                   else to_fmt na ++ ": " ++ x.to_format_aux depth ++ (holtype_cross_list_to_format xs depth (n+1) c)
| [] depth n c := ""

with holtype.to_format_aux : holtype → ℕ → format
| e@(holtype.o) _ := "$o"
| e@(holtype.i) _ := "$i"
| e@(holtype.int) _ := "$int"
| e@(holtype.rat) _ := "$rat"
| e@(holtype.real) _ := "$real"
| e@(holtype.type) _ := "$tType"
| e@(holtype.ltype n) _ := to_fmt n
| e@(holtype.functor ts t) depth :=  (holtype_list_to_format ts depth 0 ">") ++ " > " ++ t.to_format_aux depth
| e@(holtype.dep_binder ts t) depth := "!>[" ++ holtype_cross_list_to_format ts depth 0 "," ++ "] : (" ++ t.to_format_aux depth ++ ")"
| e@(holtype.partial_app t) depth := "(" ++ t.to_format_aux depth ++ ")"

with holterm.to_format_aux : holterm → ℕ → format
| e@(holterm.const n) _ := to_fmt n
| e@(holterm.lconst n _) _ := to_fmt n
| e@(holterm.prf) _ := "prf"
| e@(holterm.var n) depth := "V" ++ to_fmt (depth - n)
| e@(holterm.app t1 t2) depth := "(" ++ t1.to_format_aux depth ++ "@" ++ t2.to_format_aux depth ++ ")"
| e@(holterm.lambda n ty t) depth := "( ^[" ++ to_fmt n ++ ":" ++ ty.to_format_aux depth ++ "] : " ++ t.to_format_aux (depth + 1) ++ " )"
-- Boolean constant
| e@(holterm.top) _ := "$true"
| e@(holterm.bottom) _ := "$false"

meta def holform.to_format_aux : holform → ℕ → format
| e@(holform.P t) depth := "p(" ++ t.to_format_aux depth ++ ")"
| e@(holform.T n t) depth := "t(" ++ n.to_format_aux depth ++ t.to_format_aux depth ++ ")"
| e@(holform.eq t1 t2) depth := "(" ++ t1.to_format_aux depth ++ "=" ++ t2.to_format_aux depth ++ ")"
-- Boolean constant
| e@(holform.bottom) _ := to_fmt "$false"
| e@(holform.top) _ := to_fmt "$true"
| e@(holform.neg f) depth := "~(" ++ f.to_format_aux depth ++ ")"
| e@(holform.imp f1 f2) depth := "(" ++ f1.to_format_aux depth ++ " => " ++ f2.to_format_aux depth ++ ")"
| e@(holform.iff f1 f2) depth := "(" ++ f1.to_format_aux depth ++ " <=> " ++ f2.to_format_aux depth ++ ")"
| e@(holform.conj f1 f2) depth := "(" ++ f1.to_format_aux depth ++ " & " ++ f2.to_format_aux depth ++ ")"
| e@(holform.disj f1 f2) depth := "(" ++ f1.to_format_aux depth ++ " | " ++ f2.to_format_aux depth ++ ")"
| e@(holform.all n t f) depth := "! [" ++ to_fmt n ++ ":" ++ t.to_format_aux depth ++ "] : " ++ f.to_format_aux (depth + 1)
| e@(holform.exist n t f) depth := "? [" ++ to_fmt n ++ ":" ++ t.to_format_aux depth ++ "] : " ++ f.to_format_aux (depth + 1)

meta def holtype.to_format (t : holtype) : format := t.to_format_aux 0
meta def holterm.to_format (t : holterm) : format := t.to_format_aux 0
meta def holform.to_format (f : holform) : format := f.to_format_aux 0

meta def holterm.to_name : holterm → name
| e := e.to_format.to_string

meta def holtype.to_name : holtype → name
| e := e.repr
-- Convert formula with name and role to output string
meta def axiom_to_thf (id : string) (r : role) (f : holform) : format :=
    to_fmt "thf(" ++ to_fmt id ++ "," ++ r.to_format ++ ",(" ++ f.to_format ++ "))."

-- Convert formula with name and role to output string
meta def typedef_to_thf (id : string) (type_name : name) (t : holtype) : format :=
    to_fmt "thf(" ++ to_fmt id ++ ",type,(" ++ to_fmt type_name ++ " : " ++ t.to_format ++ "))."

-- Combine list of axioma, type definitions and conjecture into single string
meta def export_formula : list type_def → list axioma → holform → format
| (⟨def_n, type_n, t⟩::tds) axiomas conjectures :=
  typedef_to_thf ("'" ++ to_string def_n ++ "'") type_n t
     ++ "\n\n"
     ++ export_formula tds axiomas conjectures
| [] (⟨n, f⟩::as) conjecture :=
  axiom_to_thf ("'" ++ to_string n ++ "'") role.axioma f
     ++ "\n\n"
     ++ export_formula [] as conjecture
| [] [] conjecture := axiom_to_thf "'problem_conjecture'" role.conjecture conjecture

---------------------
-- DEBUG FUNCTIONS --
---------------------
meta def example_formula : holform :=
holform.all `test (holtype.ltype `myType) $
    holform.eq
        (holterm.app (holterm.app (holterm.const `h1) (holterm.const `h2)) (holterm.const `test))
        (holterm.var 1)

meta def example_type : holtype :=
holtype.dep_binder [(`A, holtype.o), (`B, holtype.i)] $
    holtype.functor [holtype.partial_app (holterm.app (holterm.const `map) (holterm.const `A)), holtype.ltype `B] holtype.type

meta def example_axiom : axioma := ⟨`test_axiom, example_formula⟩
meta def example_type_def : type_def := ⟨`test_type_def, `myType, example_type⟩

run_cmd do tactic.trace example_formula.to_format
run_cmd do tactic.trace example_type.to_format
run_cmd do tactic.trace $ export_formula [example_type_def] [example_axiom] example_formula


import galois.tactic

universe variables u v

def bounded_list (α : Type u) (n : ℕ) := { l : list α // l.length ≤ n }

namespace bounded_list

/-- Two bounded_lists are equal if the underlying lists are equal. -/
theorem eq (α : Type u) (n : ℕ)
: ∀ {t₀ t₁ : bounded_list α n}, t₀^.val = t₁^.val → t₀ = t₁
| ⟨l, p₀⟩ ⟨.(l), p₁⟩ rfl := rfl

/-- Return tt if a bounded list is not empty. -/
@[reducible]
def empty {α : Type u} {n : ℕ} (l : bounded_list α n) : bool := l.val.empty

/-- Return singleton bounded_list -/
def single {α : Type u} (x : α) : bounded_list α 1 := ⟨[x], dec_trivial⟩

-- Empty bounded_list
def nil {α : Type u} : bounded_list α 0 := ⟨ [], dec_trivial ⟩

-- Prepend an element to a bounded list.
def cons {α : Type u} {n : ℕ} (x : α) :  bounded_list α n → bounded_list α (n+1)
| ⟨l, p⟩ :=
  let q : (l.cons x).length ≤ n+1 :=
      begin
        simp [nat.add_succ],
        apply nat.succ_le_succ,
        exact p,
      end in
  ⟨ l.cons x, q ⟩

-- A bounded_list of length n can be extended to a list of length n + k
def extend {α : Type u} {n : ℕ} : bounded_list α n → Π (k : ℕ), bounded_list α (n + k)
| ⟨l, p⟩ k := ⟨ l, le_trans p (nat.le_add_right n k) ⟩

-- Map over elements in a list.
def map {α β : Type u} {n : ℕ} (f : α → β) : bounded_list α n → bounded_list β n
| ⟨l, p⟩ := ⟨ l.map f, begin simp [list.length_map], exact p, end⟩

def append {A : Type u} {n m : ℕ} :
  bounded_list A n → bounded_list A m → bounded_list A (n + m)
 | ⟨ xs, pxs ⟩ ⟨ ys, pys ⟩ := ⟨ xs ++ ys,
   begin
   rw list.length_append, apply add_le_add; assumption
   end ⟩

inductive length_succ_cons_ind {A : Type u} (xs : list A) (n : ℕ) : Prop
  | smaller : xs.length ≤ n → length_succ_cons_ind
  | same : ∀ (x : A) (xs' : list A), xs = x :: xs' → xs'.length = n → length_succ_cons_ind

lemma list.length_le_zero_nil {A : Type u} {xs : list A}
  (H : xs.length ≤ 0) : xs = list.nil
:= begin
apply list.eq_nil_of_length_eq_zero,
apply nat.eq_zero_of_le_zero, assumption,
end

lemma length_succ_cons {A : Type u} {xs : list A}
  {n : ℕ} (H : xs.length ≤ n.succ)
  : length_succ_cons_ind xs n
:= begin
rw le_iff_lt_or_eq at H, induction H with H H,
{ apply_in H  nat.le_of_lt_succ,
  apply length_succ_cons_ind.smaller, assumption
},
{ cases xs, try { contradiction },
  apply length_succ_cons_ind.same, reflexivity,
  dsimp at H, injection H,
}
end

/-- Given a list and a bound this returns a bounded list if the length is small enough. œ-/
def of_list {α : Type u} (l : list α) (m : ℕ )
: option (bounded_list α m) :=
  if p : l.length ≤ m then
    option.some (⟨l, p⟩)
  else
    option.none

/-- Concatenate a bounded list of bounded lists all together. -/
lemma concat {A : Type u} {n m : ℕ}
  : bounded_list (bounded_list A m) n → bounded_list A (m * n)
| ⟨ xss, pxss ⟩ := ⟨ (xss.map subtype.val).join , begin
  clear concat,
  revert xss, induction n; intros,
  {
  apply_in pxss list.length_le_zero_nil,
  subst xss, simp [list.join],
  },
  { apply_in pxss length_succ_cons, induction pxss,
    { specialize (ih_1 _ a_1),
      apply le_trans, assumption,
      apply nat.mul_le_mul_left,
      apply nat.le_succ,
    },
    { subst xss, dsimp [list.map, list.join],
      rw list.length_append,
      rw nat.mul_succ, rw nat.add_comm,
      apply add_le_add, apply ih_1, subst a,
      apply x.property,
    }
  }
  end ⟩

end bounded_list