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

! This file was ported from Lean 3 source module data.analysis.topology
! leanprover-community/mathlib commit 55d771df074d0dd020139ee1cd4b95521422df9f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Analysis.Filter
import Mathlib.Topology.Bases
import Mathlib.Topology.LocallyFinite

/-!
# Computational realization of topological spaces (experimental)

This file provides infrastructure to compute with topological spaces.

## Main declarations

* `Ctop`: Realization of a topology basis.
* `Ctop.Realizer`: Realization of a topological space. `Ctop` that generates the given topology.
* `LocallyFinite.Realizer`: Realization of the local finiteness of an indexed family of sets.
* `Compact.Realizer`: Realization of the compactness of a set.
-/

open Set

open Filter hiding Realizer

open Topology

/-- A `Ctop α σ` is a realization of a topology (basis) on `α`,
  represented by a type `σ` together with operations for the top element and
  the intersection operation. -/
structure Ctop (α σ : Type _) where
  f : σ → Set α
  top : α → σ
  top_mem : ∀ x : α, x ∈ f (top x)
  inter : ∀ (a b) (x : α), x ∈ f a ∩ f b → σ
  inter_mem : ∀ a b x h, x ∈ f (inter a b x h)
  inter_sub : ∀ a b x h, f (inter a b x h) ⊆ f a ∩ f b
#align ctop Ctop

variable {α : Type _} {β : Type _} {σ : Type _} {τ : Type _}

instance : Inhabited (Ctop α (Set α)) :=
  ⟨{  f := id
      top := singleton
      top_mem := mem_singleton
      inter := fun s t _ _ ↦ s ∩ t
      inter_mem := fun _s _t _a ↦ id
      inter_sub := fun _s _t _a _ha ↦ Subset.rfl }⟩

namespace Ctop

section

variable (F : Ctop α σ)

instance : CoeFun (Ctop α σ) fun _ ↦ σ → Set α :=
  ⟨Ctop.f⟩

-- @[simp] -- Porting note: dsimp can prove this
theorem coe_mk (f T h₁ I h₂ h₃ a) : (@Ctop.mk α σ f T h₁ I h₂ h₃) a = f a := rfl
#align ctop.coe_mk Ctop.coe_mk

/-- Map a Ctop to an equivalent representation type. -/
def ofEquiv (E : σ ≃ τ) : Ctop α σ → Ctop α τ
  | ⟨f, T, h₁, I, h₂, h₃⟩ =>
    { f := fun a ↦ f (E.symm a)
      top := fun x ↦ E (T x)
      top_mem := fun x ↦ by simpa using h₁ x
      inter := fun a b x h ↦ E (I (E.symm a) (E.symm b) x h)
      inter_mem := fun a b x h ↦ by simpa using h₂ (E.symm a) (E.symm b) x h
      inter_sub := fun a b x h ↦ by simpa using h₃ (E.symm a) (E.symm b) x h }
#align ctop.of_equiv Ctop.ofEquiv

@[simp]
theorem ofEquiv_val (E : σ ≃ τ) (F : Ctop α σ) (a : τ) : F.ofEquiv E a = F (E.symm a) := by
  cases F ; rfl
#align ctop.of_equiv_val Ctop.ofEquiv_val

end

/-- Every `Ctop` is a topological space. -/
def toTopsp (F : Ctop α σ) : TopologicalSpace α := TopologicalSpace.generateFrom (Set.range F.f)
#align ctop.to_topsp Ctop.toTopsp

theorem toTopsp_isTopologicalBasis (F : Ctop α σ) :
    @TopologicalSpace.IsTopologicalBasis _ F.toTopsp (Set.range F.f) :=
  letI := F.toTopsp
  ⟨fun _u ⟨a, e₁⟩ _v ⟨b, e₂⟩ ↦
    e₁ ▸ e₂ ▸ fun x h ↦ ⟨_, ⟨_, rfl⟩, F.inter_mem a b x h, F.inter_sub a b x h⟩,
    eq_univ_iff_forall.2 fun x ↦ ⟨_, ⟨_, rfl⟩, F.top_mem x⟩, rfl⟩
#align ctop.to_topsp_is_topological_basis Ctop.toTopsp_isTopologicalBasis

@[simp]

end Ctop

/-- A `Ctop` realizer for the topological space `T` is a `Ctop`
  which generates `T`. -/
structure Ctop.Realizer (α) [T : TopologicalSpace α] where
  σ : Type _
  F : Ctop α σ
  eq : F.toTopsp = T
#align ctop.realizer Ctop.Realizer

open Ctop

/-- A `Ctop` realizes the topological space it generates. -/
protected def Ctop.toRealizer (F : Ctop α σ) : @Ctop.Realizer _ F.toTopsp :=
  @Ctop.Realizer.mk _ F.toTopsp σ F rfl
#align ctop.to_realizer Ctop.toRealizer

instance (F : Ctop α σ) : Inhabited (@Ctop.Realizer _ F.toTopsp) :=
  ⟨F.toRealizer⟩

namespace Ctop.Realizer

protected theorem is_basis [T : TopologicalSpace α] (F : Realizer α) :
    TopologicalSpace.IsTopologicalBasis (Set.range F.F.f) := by
  have := toTopsp_isTopologicalBasis F.F ; rwa [F.eq] at this
#align ctop.realizer.is_basis Ctop.Realizer.is_basis

protected theorem mem_nhds [T : TopologicalSpace α] (F : Realizer α) {s : Set α} {a : α} :
  s ∈ 𝓝 a ↔ ∃ b, a ∈ F.F b ∧ F.F b ⊆ s := by
  have := @mem_nhds_toTopsp _ _ F.F s a ; rwa [F.eq] at this
#align ctop.realizer.mem_nhds Ctop.Realizer.mem_nhds

theorem isOpen_iff [TopologicalSpace α] (F : Realizer α) {s : Set α} :
    IsOpen s ↔ ∀ a ∈ s, ∃ b, a ∈ F.F b ∧ F.F b ⊆ s :=
  isOpen_iff_mem_nhds.trans <| ball_congr fun _a _h ↦ F.mem_nhds
#align ctop.realizer.is_open_iff Ctop.Realizer.isOpen_iff

theorem isClosed_iff [TopologicalSpace α] (F : Realizer α) {s : Set α} :
    IsClosed s ↔ ∀ a, (∀ b, a ∈ F.F b → ∃ z, z ∈ F.F b ∩ s) → a ∈ s :=
  isOpen_compl_iff.symm.trans <|
    F.isOpen_iff.trans <|
      forall_congr' fun a ↦
        show (a ∉ s → ∃ b : F.σ, a ∈ F.F b ∧ ∀ z ∈ F.F b, z ∉ s) ↔ _ by
          haveI := Classical.propDecidable ; rw [not_imp_comm] ;
            simp [not_exists, not_and, not_forall, and_comm]; trivial
#align ctop.realizer.is_closed_iff Ctop.Realizer.isClosed_iff

theorem mem_interior_iff [TopologicalSpace α] (F : Realizer α) {s : Set α} {a : α} :
    a ∈ interior s ↔ ∃ b, a ∈ F.F b ∧ F.F b ⊆ s :=
  mem_interior_iff_mem_nhds.trans F.mem_nhds
#align ctop.realizer.mem_interior_iff Ctop.Realizer.mem_interior_iff

protected theorem isOpen [TopologicalSpace α] (F : Realizer α) (s : F.σ) : IsOpen (F.F s) :=
  isOpen_iff_nhds.2 fun a m ↦ by simpa using F.mem_nhds.2 ⟨s, m, Subset.refl _⟩
#align ctop.realizer.is_open Ctop.Realizer.isOpen

theorem ext' [T : TopologicalSpace α] {σ : Type _} {F : Ctop α σ}
    (H : ∀ a s, s ∈ 𝓝 a ↔ ∃ b, a ∈ F b ∧ F b ⊆ s) : F.toTopsp = T := by
  refine' eq_of_nhds_eq_nhds fun x ↦ _
  ext s
  rw [mem_nhds_toTopsp, H]
#align ctop.realizer.ext' Ctop.Realizer.ext'

theorem ext [T : TopologicalSpace α] {σ : Type _} {F : Ctop α σ} (H₁ : ∀ a, IsOpen (F a))
    (H₂ : ∀ a s, s ∈ 𝓝 a → ∃ b, a ∈ F b ∧ F b ⊆ s) : F.toTopsp = T :=
  ext' fun a s ↦ ⟨H₂ a s, fun ⟨_b, h₁, h₂⟩ ↦ mem_nhds_iff.2 ⟨_, h₂, H₁ _, h₁⟩⟩
#align ctop.realizer.ext Ctop.Realizer.ext

variable [TopologicalSpace α]

-- Porting note: add non-computable : because
-- > ... it depends on `Inter.inter`, and it does not have executable code.
/-- The topological space realizer made of the open sets. -/
protected noncomputable def id : Realizer α :=
  ⟨{ x : Set α // IsOpen x },
    { f := Subtype.val
      top := fun _ ↦ ⟨univ, isOpen_univ⟩
      top_mem := mem_univ
      inter := fun ⟨_x, h₁⟩ ⟨_y, h₂⟩ _a _h₃ ↦ ⟨_, h₁.inter h₂⟩
      inter_mem := fun ⟨_x, _h₁⟩ ⟨_y, _h₂⟩ _a ↦ id
      inter_sub := fun ⟨_x, _h₁⟩ ⟨_y, _h₂⟩ _a _h₃ ↦ Subset.refl _ },
    ext Subtype.property fun _x _s h ↦
      let ⟨t, h, o, m⟩ := mem_nhds_iff.1 h
      ⟨⟨t, o⟩, m, h⟩⟩
#align ctop.realizer.id Ctop.Realizer.id

/-- Replace the representation type of a `Ctop` realizer. -/
def ofEquiv (F : Realizer α) (E : F.σ ≃ τ) : Realizer α :=
  ⟨τ, F.F.ofEquiv E,
    ext' fun a s ↦
      F.mem_nhds.trans <|
        ⟨fun ⟨s, h⟩ ↦ ⟨E s, by simpa using h⟩, fun ⟨t, h⟩ ↦ ⟨E.symm t, by simpa using h⟩⟩⟩
#align ctop.realizer.of_equiv Ctop.Realizer.ofEquiv

@[simp]
theorem ofEquiv_σ (F : Realizer α) (E : F.σ ≃ τ) : (F.ofEquiv E).σ = τ := rfl
#align ctop.realizer.of_equiv_σ Ctop.Realizer.ofEquiv_σ

@[simp]
theorem ofEquiv_F (F : Realizer α) (E : F.σ ≃ τ) (s : τ) : (F.ofEquiv E).F s = F.F (E.symm s) := by
  delta ofEquiv ; simp
set_option linter.uppercaseLean3 false in
#align ctop.realizer.of_equiv_F Ctop.Realizer.ofEquiv_F

/-- A realizer of the neighborhood of a point. -/
protected def nhds (F : Realizer α) (a : α) : (𝓝 a).Realizer :=
  ⟨{ s : F.σ // a ∈ F.F s },
    { f := fun s ↦ F.F s.1
      pt := ⟨_, F.F.top_mem a⟩
      inf := fun ⟨x, h₁⟩ ⟨y, h₂⟩ ↦ ⟨_, F.F.inter_mem x y a ⟨h₁, h₂⟩⟩
      inf_le_left := fun ⟨x, h₁⟩ ⟨y, h₂⟩ _z h ↦ (F.F.inter_sub x y a ⟨h₁, h₂⟩ h).1
      inf_le_right := fun ⟨x, h₁⟩ ⟨y, h₂⟩ _z h ↦ (F.F.inter_sub x y a ⟨h₁, h₂⟩ h).2 },
    filter_eq <|
      Set.ext fun _x ↦
        ⟨fun ⟨⟨_s, as⟩, h⟩ ↦ mem_nhds_iff.2 ⟨_, h, F.isOpen _, as⟩, fun h ↦
          let ⟨s, h, as⟩ := F.mem_nhds.1 h
          ⟨⟨s, h⟩, as⟩⟩⟩
#align ctop.realizer.nhds Ctop.Realizer.nhds

@[simp]
theorem nhds_σ (F : Realizer α) (a : α) : (F.nhds a).σ = { s : F.σ // a ∈ F.F s } := rfl
#align ctop.realizer.nhds_σ Ctop.Realizer.nhds_σ

@[simp]
theorem nhds_F (F : Realizer α) (a : α) (s) : (F.nhds a).F s = F.F s.1 := rfl
set_option linter.uppercaseLean3 false in
#align ctop.realizer.nhds_F Ctop.Realizer.nhds_F

theorem tendsto_nhds_iff {m : β → α} {f : Filter β} (F : f.Realizer) (R : Realizer α) {a : α} :
    Tendsto m f (𝓝 a) ↔ ∀ t, a ∈ R.F t → ∃ s, ∀ x ∈ F.F s, m x ∈ R.F t :=
  (F.tendsto_iff _ (R.nhds a)).trans Subtype.forall
#align ctop.realizer.tendsto_nhds_iff Ctop.Realizer.tendsto_nhds_iff

end Ctop.Realizer

/-- A `locally_finite.realizer F f` is a realization that `f` is locally finite, namely it is a
choice of open sets from the basis of `F` such that they intersect only finitely many of the values
of `f`.  -/
structure LocallyFinite.Realizer [TopologicalSpace α] (F : Ctop.Realizer α) (f : β → Set α) where
  bas : ∀ a, { s // a ∈ F.F s }
  sets : ∀ x : α, Fintype { i | (f i ∩ F.F (bas x)).Nonempty }
#align locally_finite.realizer LocallyFinite.Realizer

theorem LocallyFinite.Realizer.to_locallyFinite [TopologicalSpace α] {F : Ctop.Realizer α}
  {f : β → Set α} (R : LocallyFinite.Realizer F f) : LocallyFinite f := fun a ↦
  ⟨_, F.mem_nhds.2 ⟨(R.bas a).1, (R.bas a).2, Subset.refl _⟩, ⟨R.sets a⟩⟩
#align locally_finite.realizer.to_locally_finite LocallyFinite.Realizer.to_locallyFinite

theorem locallyFinite_iff_exists_realizer [TopologicalSpace α]
  (F : Ctop.Realizer α) {f : β → Set α} : LocallyFinite f ↔ Nonempty (LocallyFinite.Realizer F f) :=
  ⟨fun h ↦
    let ⟨g, h₁⟩ := Classical.axiom_of_choice h
    let ⟨g₂, h₂⟩ :=
      Classical.axiom_of_choice fun x ↦
        show ∃ b : F.σ, x ∈ F.F b ∧ F.F b ⊆ g x from
          let ⟨h, _h'⟩ := h₁ x
          F.mem_nhds.1 h
    ⟨⟨fun x ↦ ⟨g₂ x, (h₂ x).1⟩, fun x ↦
        Finite.fintype <|
          let ⟨_h, h'⟩ := h₁ x
          h'.subset fun _i hi ↦ hi.mono (inter_subset_inter_right _ (h₂ x).2)⟩⟩,
    fun ⟨R⟩ ↦ R.to_locallyFinite⟩
#align locally_finite_iff_exists_realizer locallyFinite_iff_exists_realizer

instance [TopologicalSpace α] [Finite β] (F : Ctop.Realizer α) (f : β → Set α) :
    Nonempty (LocallyFinite.Realizer F f) :=
  (locallyFinite_iff_exists_realizer _).1 <| locallyFinite_of_finite _

/-- A `Compact.Realizer s` is a realization that `s` is compact, namely it is a
choice of finite open covers for each set family covering `s`.  -/
def Compact.Realizer [TopologicalSpace α] (s : Set α) :=
  ∀ {f : Filter α} (F : f.Realizer) (x : F.σ), f ≠ ⊥ → F.F x ⊆ s → { a // a ∈ s ∧ 𝓝 a ⊓ f ≠ ⊥ }
#align compact.realizer Compact.Realizer

instance [TopologicalSpace α] : Inhabited (Compact.Realizer (∅ : Set α)) :=
  ⟨fun {f} F x h hF ↦ by
    suffices : f = ⊥ ; exact absurd this h
    rw [← F.eq, eq_bot_iff]
    exact λ s _ ↦ ⟨x, hF.trans s.empty_subset⟩⟩


/-
Copyright (c) 2021 Henry Swanson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henry Swanson
-/
import data.equiv.basic
import data.equiv.option
import dynamics.fixed_points.basic
import group_theory.perm.option

/-!
# Derangements on types

In this file we define `derangements α`, the set of derangements on a type `α`.

We also define some equivalences involving various subtypes of `perm α` and `derangements α`:
* `derangements_option_equiv_sigma_at_most_one_fixed_point`: An equivalence between
  `derangements (option α)` and the sigma-type `Σ a : α, {f : perm α // fixed_points f ⊆ a}`.
* `derangements_recursion_equiv`: An equivalence between `derangements (option α)` and the
  sigma-type `Σ a : α, (derangements (({a}ᶜ : set α) : Type _) ⊕ derangements α)` which is later
  used to inductively count the number of derangements.

In order to prove the above, we also prove some results about the effect of `equiv.remove_none`
on derangements: `remove_none.fiber_none` and `remove_none.fiber_some`.
-/

open equiv function

/-- A permutation is a derangement if it has no fixed points. -/
def derangements (α : Type*) : set (perm α) := {f : perm α | ∀ x : α, f x ≠ x}

variables {α β : Type*}

lemma mem_derangements_iff_fixed_points_eq_empty {f : perm α} :
  f ∈ derangements α ↔ fixed_points f = ∅ :=
set.eq_empty_iff_forall_not_mem.symm

/-- If `α` is equivalent to `β`, then `derangements α` is equivalent to `derangements β`. -/
def equiv.derangements_congr (e : α ≃ β) : (derangements α ≃ derangements β) :=
e.perm_congr.subtype_equiv $ λ f, e.forall_congr $ by simp

namespace derangements

/-- Derangements on a subtype are equivalent to permutations on the original type where points are
fixed iff they are not in the subtype. -/
protected def subtype_equiv (p : α → Prop) [decidable_pred p] :
  derangements (subtype p) ≃ {f : perm α // ∀ a, ¬p a ↔ a ∈ fixed_points f} :=
calc
  derangements (subtype p)
      ≃ {f : {f : perm α // ∀ a, ¬p a → a ∈ fixed_points f} // ∀ a, a ∈ fixed_points f → ¬p a}
      : begin
        refine (perm.subtype_equiv_subtype_perm p).subtype_equiv (λ f, ⟨λ hf a hfa ha, _, _⟩),
        { refine hf ⟨a, ha⟩ (subtype.ext _),
          rwa [mem_fixed_points, is_fixed_pt, perm.subtype_equiv_subtype_perm, @coe_fn_coe_base',
               equiv.coe_fn_mk, subtype.coe_mk, equiv.perm.of_subtype_apply_of_mem]
            at hfa },
        rintro hf ⟨a, ha⟩ hfa,
        refine hf _ _ ha,
        change perm.subtype_equiv_subtype_perm p f a = a,
        rw [perm.subtype_equiv_subtype_perm_apply_of_mem f ha, hfa, subtype.coe_mk],
      end
  ... ≃ {f : perm α // ∃ (h : ∀ a, ¬p a → a ∈ fixed_points f), ∀ a, a ∈ fixed_points f → ¬p a}
      : subtype_subtype_equiv_subtype_exists _ _
  ... ≃ {f : perm α // ∀ a, ¬p a ↔ a ∈ fixed_points f}
      : subtype_equiv_right (λ f, by simp_rw [exists_prop, ←forall_and_distrib,
        ←iff_iff_implies_and_implies])

/-- The set of permutations that fix either `a` or nothing is equivalent to the sum of:
    - derangements on `α`
    - derangements on `α` minus `a`. -/
def at_most_one_fixed_point_equiv_sum_derangements [decidable_eq α] (a : α) :
  {f : perm α // fixed_points f ⊆ {a}} ≃ (derangements ({a}ᶜ : set α)) ⊕ derangements α :=
calc
  {f : perm α // fixed_points f ⊆ {a}}
      ≃ {f : {f : perm α // fixed_points f ⊆ {a}} // a ∈ fixed_points f}
        ⊕ {f : {f : perm α // fixed_points f ⊆ {a}} // a ∉ fixed_points f}
      : (equiv.sum_compl _).symm
  ... ≃ {f : perm α // fixed_points f ⊆ {a} ∧ a ∈ fixed_points f}
        ⊕ {f : perm α // fixed_points f ⊆ {a} ∧ a ∉ fixed_points f}
      : begin
        refine equiv.sum_congr _ _;
        { convert subtype_subtype_equiv_subtype_inter _ _, ext f, refl }
      end
  ... ≃ {f : perm α // fixed_points f = {a}} ⊕ {f : perm α // fixed_points f = ∅}
      : begin
        refine equiv.sum_congr (subtype_equiv_right $ λ f, _) (subtype_equiv_right $ λ f, _),
        { rw [set.eq_singleton_iff_unique_mem, and_comm],
          refl },
        { rw set.eq_empty_iff_forall_not_mem,
          refine ⟨λ h x hx, h.2 (h.1 hx ▸ hx), λ h, ⟨λ x hx, (h _ hx).elim, h _⟩⟩ }
      end
  ... ≃ (derangements ({a}ᶜ : set α)) ⊕ derangements α
      : begin
        refine equiv.sum_congr ((derangements.subtype_equiv _).trans $ subtype_equiv_right $ λ x,
          _).symm (subtype_equiv_right $ λ f, mem_derangements_iff_fixed_points_eq_empty.symm),
        rw [eq_comm, set.ext_iff],
        simp_rw [set.mem_compl_iff, not_not],
      end

namespace equiv
variables [decidable_eq α]

/-- The set of permutations `f` such that the preimage of `(a, f)` under
    `equiv.perm.decompose_option` is a derangement. -/
def remove_none.fiber (a : option α) : set (perm α) :=
  {f : perm α | (a, f) ∈ equiv.perm.decompose_option '' derangements (option α)}

lemma remove_none.mem_fiber (a : option α) (f : perm α) :
  f ∈ remove_none.fiber a ↔
  ∃ F : perm (option α), F ∈ derangements (option α) ∧ F none = a ∧ remove_none F = f :=
by simp [remove_none.fiber, derangements]

lemma remove_none.fiber_none : remove_none.fiber (@none α) = ∅ :=
begin
  rw set.eq_empty_iff_forall_not_mem,
  intros f hyp,
  rw remove_none.mem_fiber at hyp,
  rcases hyp with ⟨F, F_derangement, F_none, _⟩,
  exact F_derangement none F_none
end

/-- For any `a : α`, the fiber over `some a` is the set of permutations
    where `a` is the only possible fixed point. -/
lemma remove_none.fiber_some (a : α) :
  (remove_none.fiber (some a)) = {f : perm α | fixed_points f ⊆ {a}} :=
begin
  ext f,
  split,
  { rw remove_none.mem_fiber,
    rintro ⟨F, F_derangement, F_none, rfl⟩ x x_fixed,
    rw mem_fixed_points_iff at x_fixed,
    apply_fun some at x_fixed,
    cases Fx : F (some x) with y,
    { rwa [remove_none_none F Fx, F_none, option.some_inj, eq_comm] at x_fixed },
    { exfalso, rw remove_none_some F ⟨y, Fx⟩ at x_fixed, exact F_derangement _ x_fixed } },
  { intro h_opfp,
    use equiv.perm.decompose_option.symm (some a, f),
    split,
    { intro x,
      apply_fun (swap none (some a)),
      simp only [perm.decompose_option_symm_apply, swap_apply_self, perm.coe_mul],
      cases x,
      { simp },
      simp only [equiv_functor.map_equiv_apply, equiv_functor.map,
                  option.map_eq_map, option.map_some'],
      by_cases x_vs_a : x = a,
      { rw [x_vs_a, swap_apply_right], apply option.some_ne_none },
      have ne_1 : some x ≠ none := option.some_ne_none _,
      have ne_2 : some x ≠ some a := (option.some_injective α).ne_iff.mpr x_vs_a,
      rw [swap_apply_of_ne_of_ne ne_1 ne_2, (option.some_injective α).ne_iff],
      intro contra,
      exact x_vs_a (h_opfp contra) },
    { rw apply_symm_apply } }
end

end equiv

section option
variables [decidable_eq α]

/-- The set of derangements on `option α` is equivalent to the union over `a : α`
    of "permutations with `a` the only possible fixed point". -/
def derangements_option_equiv_sigma_at_most_one_fixed_point :
  derangements (option α) ≃ Σ a : α, {f : perm α | fixed_points f ⊆ {a}} :=
begin
  have fiber_none_is_false : (equiv.remove_none.fiber (@none α)) -> false,
  { rw equiv.remove_none.fiber_none, exact is_empty.false },

  calc derangements (option α)
      ≃ equiv.perm.decompose_option '' derangements (option α) : equiv.image _ _
  ... ≃ Σ (a : option α), ↥(equiv.remove_none.fiber a)         : set_prod_equiv_sigma _
  ... ≃ Σ (a : α), ↥(equiv.remove_none.fiber (some a))
          : sigma_option_equiv_of_some _ fiber_none_is_false
  ... ≃ Σ (a : α), {f : perm α | fixed_points f ⊆ {a}}
          : by simp_rw equiv.remove_none.fiber_some,
end

/-- The set of derangements on `option α` is equivalent to the union over all `a : α` of
    "derangements on `α` ⊕ derangements on `{a}ᶜ`". -/
def derangements_recursion_equiv :
  derangements (option α) ≃ Σ a : α, (derangements (({a}ᶜ : set α) : Type _) ⊕ derangements α) :=
derangements_option_equiv_sigma_at_most_one_fixed_point.trans (sigma_congr_right
  at_most_one_fixed_point_equiv_sum_derangements)

end option

end derangements


import tactic
import data.set
import order.conditionally_complete_lattice

import .sequences
import .si_sequence
import .topology
import .sups

noncomputable theory
open_locale classical

section bw
variables {X: Type} [espace_metrique X] [conditionally_complete_linear_order X]

open espace_metrique
open set

/-- FIXME: À déplacer -/
-- le merveilleux.
-- niveau: magnifique.

lemma principe_des_tiroirs {A: Type} {B: Type} {f: A → B} (Hinfinite: infinite A) (Hfinite: (range f).finite):
  ∃ x ∈ (range f), (preimage f {x}).infinite := sorry

lemma strictly_increasing_sequence_has_no_max (S: set X)
  (x: ℕ → X): bdd_above (range x) → strictement_croissante x → Sup (range x) ∉ (range x) := begin
  intro H,
  by_contra Hbdd,
  sorry
end

lemma smallest_element (S: set ℕ): S.nonempty → ∃ n : ℕ, ∀ m < n, m ∉ S := begin
  intro H,
  use (nat.find H),
  intro m,
  apply nat.find_min H,
end

lemma infinite_diff_finite_is_infinite {T: Type} {A: set T} {B: set T}:
  set.infinite A → set.finite B → set.infinite (A \ B) := sorry

lemma infinite_set_is_not_empty {T: Type} {S: set T}: set.infinite S → S.nonempty :=
begin
intro h,
by_contra,
rw set.not_nonempty_iff_eq_empty at a,
apply h,
rw a,
exact set.finite_empty,
end

/-- Fin du FIXME
-- Il faut comprendre ce lemme comme:
-- Dès lors que toutes parties de S ont des max et des min, alors S est finie.
-- Ce lemme est fondamental dans la mesure où il entraîne directement l'existence des points limites
-- dans le cas de parties infinies.
--/

lemma lemme_fondateur_de_bw (S: set X):
  (∀ U ⊆ S, U.nonempty → is_greatest U (Sup U) ∧ is_least U (Inf U)) → set.finite S :=
begin
  by_cases S.nonempty,
  by_contra H,
  push_neg at H,
  rw ← set.infinite at H,
  obtain ⟨ Hsupinf, Hinfinite ⟩ := H,
  have Hinf: ∀ U ⊆ S, U.nonempty → is_least U (Inf U) := λ U hU hN, (Hsupinf U hU hN).2,
  have HSup: ∀ U ⊆ S, U.nonempty → is_greatest U (Sup U) := λ U hU hN, (Hsupinf U hU hN).1,
  have Hbdd: bdd_above S := is_greatest.bdd_above (HSup S (by refl) h),
  obtain ⟨ x, hsc, hrange ⟩ := suite_st_croissante_props S Hinfinite Hinf,
  apply strictly_increasing_sequence_has_no_max S x (bdd_above.mono hrange Hbdd) hsc,
  apply (HSup (range x) hrange (set.range_nonempty _)).1,
  intro _,
  rw not_nonempty_iff_eq_empty at h,
  rw h,
  exact set.finite_empty,
end

-- TODO: À réparer
lemma bolzano_weierstrass_v2 (S: set ℝ): (set.infinite S) → bdd_below S ∧ bdd_above S → ∃ l : ℝ, point_limite S l :=
begin
intros hs hbdd,
by_contra,
push_neg at a,
apply hs,
apply lemme_fondateur_de_bw,
intros U subU hU,
split,
-- TODO: c'est la même preuve pour sup ou inf à sup/inf près. Autant utiliser l'automatisation.
by_contra,
apply a (Sup U),
rw is_greatest at a_1,
push_neg at a_1,
have := is_lub_cSup hU (bdd_above.mono subU hbdd.2),
cases a_1 with hsup hub,
exact real.Sup_is_a_limit_point U hsup (bdd_above.mono subU hbdd.2),
obtain ⟨ x, hx, hc ⟩ := this,
use x,
split,
intro n,
apply mem_of_subset_of_mem,
transitivity,
exact hx,
apply diff_subset_diff_left,
exact subU,
exact hc,
rw is_lub at this,
rw is_least at this,
exfalso,
exact hub this.1,
by_contra,
apply a (Inf U),
rw is_least at a_1,
push_neg at a_1,
cases a_1 with hinf hlb,
have: point_limite U (Inf U) := real.Inf_is_a_limit_point U hinf (bdd_below.mono subU hbdd.1),
obtain ⟨ x, hx, hc ⟩ := this,
use x,
split,
intro n,
apply mem_of_subset_of_mem,
transitivity,
exact hx,
apply diff_subset_diff_left,
exact subU,
exact hc,
have := is_glb_cInf hU (bdd_below.mono subU hbdd.1),
rw is_glb at this,
rw is_greatest at this,
exfalso,
exact hlb this.1,
end

lemma bolzano_weierstrass {x: ℕ → ℝ}: bornee x → ∃ l : ℝ, adhere x l :=
begin
intro Hb,
have bdd_above_and_below_of_image: bdd_below (range x) ∧ bdd_above (range x) := sorry,
by_cases (set.finite (range x)),
{
  -- par principe des tiroirs, il existe x_0 dans S tel que x^-1{x_0} est infini.
  obtain ⟨ l, hl, hpreimage ⟩  := principe_des_tiroirs nat.infinite h,
  use l,
  intros ε hε N,
  have: ((preimage x {l}) \ { n : ℕ | n < N}).nonempty := begin
  apply infinite_set_is_not_empty,
  apply infinite_diff_finite_is_infinite,
  exact hpreimage,
  exact set.finite_lt_nat N,
  end,
  obtain ⟨ n, hn ⟩ := this,
  use n,
  obtain ⟨ hn_preimage, hn_gt_N ⟩ := ((set.mem_diff n).1 hn),
  split,
  simp at hn_gt_N,
  exact hn_gt_N,
  simp at hn_preimage,
  rw hn_preimage,
  rw presep,
  exact hε,
  refl, -- l = l
},
{
  -- C'est un peu moche, on peut directement utiliser y et prouver que c'est une sous-suite
  -- Donc, en tirer qu'on a bien une VA.
  obtain ⟨ l ⟩ := bolzano_weierstrass_v2 (range x) h bdd_above_and_below_of_image,
  use l,
  rw point_limite at h_1,
  rw adhere_ens at h_1,
  apply adhere_of_seq_adhere,
  obtain ⟨ x, hrange, hcv ⟩ := h_1,
  sorry,
}
end

end bw


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot

! This file was ported from Lean 3 source module algebra.ring.pi
! leanprover-community/mathlib commit ba2245edf0c8bb155f1569fd9b9492a9b384cde6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Group.Pi
import Mathlib.Algebra.Hom.Ring

/-!
# Pi instances for ring

This file defines instances for ring, semiring and related structures on Pi Types
-/

-- Porting notes: used to import `tactic.pi_instances`

namespace Pi

universe u v w

variable {I : Type u}

-- The indexing type
variable {f : I → Type v}

-- The family of types already equipped with instances
variable (x y : ∀ i, f i) (i : I)

-- Porting note: All these instances used `refine_struct` and `pi_instance_derive_field`

instance distrib [∀ i, Distrib <| f i] : Distrib (∀ i : I, f i) :=
  { add := (· + ·)
    mul := (· * ·)
    left_distrib := by intros; ext; exact mul_add _ _ _
    right_distrib := by intros; ext; exact add_mul _ _ _}
#align pi.distrib Pi.distrib

instance nonUnitalNonAssocSemiring [∀ i, NonUnitalNonAssocSemiring <| f i] :
    NonUnitalNonAssocSemiring (∀ i : I, f i) :=
  { Pi.distrib, Pi.addCommMonoid, Pi.mulZeroClass with }
#align pi.non_unital_non_assoc_semiring Pi.nonUnitalNonAssocSemiring

instance nonUnitalSemiring [∀ i, NonUnitalSemiring <| f i] : NonUnitalSemiring (∀ i : I, f i) :=
  { Pi.nonUnitalNonAssocSemiring, Pi.semigroupWithZero with }
#align pi.non_unital_semiring Pi.nonUnitalSemiring

instance nonAssocSemiring [∀ i, NonAssocSemiring <| f i] : NonAssocSemiring (∀ i : I, f i) :=
  { Pi.nonUnitalNonAssocSemiring, Pi.mulZeroOneClass, Pi.addMonoidWithOne with }
#align pi.non_assoc_semiring Pi.nonAssocSemiring

instance semiring [∀ i, Semiring <| f i] : Semiring (∀ i : I, f i) :=
  { Pi.nonUnitalSemiring, Pi.nonAssocSemiring, Pi.monoidWithZero with }
#align pi.semiring Pi.semiring

instance nonUnitalCommSemiring [∀ i, NonUnitalCommSemiring <| f i] :
    NonUnitalCommSemiring (∀ i : I, f i) :=
  { Pi.nonUnitalSemiring, Pi.commSemigroup with }
#align pi.non_unital_comm_semiring Pi.nonUnitalCommSemiring

instance commSemiring [∀ i, CommSemiring <| f i] : CommSemiring (∀ i : I, f i) :=
  { Pi.semiring, Pi.commMonoid with }
#align pi.comm_semiring Pi.commSemiring

instance nonUnitalNonAssocRing [∀ i, NonUnitalNonAssocRing <| f i] :
    NonUnitalNonAssocRing (∀ i : I, f i) :=
  { Pi.addCommGroup, Pi.nonUnitalNonAssocSemiring with }
#align pi.non_unital_non_assoc_ring Pi.nonUnitalNonAssocRing

instance nonUnitalRing [∀ i, NonUnitalRing <| f i] : NonUnitalRing (∀ i : I, f i) :=
  { Pi.nonUnitalNonAssocRing, Pi.nonUnitalSemiring with }
#align pi.non_unital_ring Pi.nonUnitalRing

instance nonAssocRing [∀ i, NonAssocRing <| f i] : NonAssocRing (∀ i : I, f i) :=
  { Pi.nonUnitalNonAssocRing, Pi.nonAssocSemiring, Pi.addGroupWithOne with }
#align pi.non_assoc_ring Pi.nonAssocRing

instance ring [∀ i, Ring <| f i] : Ring (∀ i : I, f i) :=
  { Pi.semiring, Pi.addCommGroup, Pi.addGroupWithOne with }
#align pi.ring Pi.ring

instance nonUnitalCommRing [∀ i, NonUnitalCommRing <| f i] : NonUnitalCommRing (∀ i : I, f i) :=
  { Pi.nonUnitalRing, Pi.commSemigroup with }
#align pi.non_unital_comm_ring Pi.nonUnitalCommRing

instance commRing [∀ i, CommRing <| f i] : CommRing (∀ i : I, f i) :=
  { Pi.ring, Pi.commSemiring with }
#align pi.comm_ring Pi.commRing

/-- A family of non-unital ring homomorphisms `f a : γ →ₙ+* β a` defines a non-unital ring
homomorphism `Pi.nonUnitalRingHom f : γ →+* Π a, β a` given by
`Pi.nonUnitalRingHom f x b = f b x`. -/
@[simps]
protected def nonUnitalRingHom {γ : Type w} [∀ i, NonUnitalNonAssocSemiring (f i)]
    [NonUnitalNonAssocSemiring γ] (g : ∀ i, γ →ₙ+* f i) : γ →ₙ+* ∀ i, f i :=
  { Pi.mulHom fun i => (g i).toMulHom, Pi.addMonoidHom fun i => (g i).toAddMonoidHom with
    toFun := fun x b => g b x }
#align pi.non_unital_ring_hom Pi.nonUnitalRingHom

theorem nonUnitalRingHom_injective {γ : Type w} [Nonempty I]
    [∀ i, NonUnitalNonAssocSemiring (f i)] [NonUnitalNonAssocSemiring γ] (g : ∀ i, γ →ₙ+* f i)
    (hg : ∀ i, Function.Injective (g i)) : Function.Injective (Pi.nonUnitalRingHom g) :=
  mulHom_injective (fun i => (g i).toMulHom) hg
#align pi.non_unital_ring_hom_injective Pi.nonUnitalRingHom_injective

/-- A family of ring homomorphisms `f a : γ →+* β a` defines a ring homomorphism
`Pi.ringHom f : γ →+* Π a, β a` given by `Pi.ringHom f x b = f b x`. -/
@[simps]
protected def ringHom {γ : Type w} [∀ i, NonAssocSemiring (f i)] [NonAssocSemiring γ]
    (g : ∀ i, γ →+* f i) : γ →+* ∀ i, f i :=
  { Pi.monoidHom fun i => (g i).toMonoidHom, Pi.addMonoidHom fun i => (g i).toAddMonoidHom with
    toFun := fun x b => g b x }
#align pi.ring_hom Pi.ringHom
#align pi.ring_hom_apply Pi.ringHom_apply

theorem ringHom_injective {γ : Type w} [Nonempty I] [∀ i, NonAssocSemiring (f i)]
    [NonAssocSemiring γ] (g : ∀ i, γ →+* f i) (hg : ∀ i, Function.Injective (g i)) :
    Function.Injective (Pi.ringHom g) :=
  monoidHom_injective (fun i => (g i).toMonoidHom) hg
#align pi.ring_hom_injective Pi.ringHom_injective

end Pi

section NonUnitalRingHom

universe u v

variable {I : Type u}

/-- Evaluation of functions into an indexed collection of non-unital rings at a point is a
non-unital ring homomorphism. This is `Function.eval` as a `NonUnitalRingHom`. -/
@[simps]
def Pi.evalNonUnitalRingHom (f : I → Type v) [∀ i, NonUnitalNonAssocSemiring (f i)] (i : I) :
    (∀ i, f i) →ₙ+* f i :=
  { Pi.evalMulHom f i, Pi.evalAddMonoidHom f i with }
#align pi.eval_non_unital_ring_hom Pi.evalNonUnitalRingHom

/-- `Function.const` as a `NonUnitalRingHom`. -/
@[simps]
def Pi.constNonUnitalRingHom (α β : Type _) [NonUnitalNonAssocSemiring β] : β →ₙ+* α → β :=
  { Pi.nonUnitalRingHom fun _ => NonUnitalRingHom.id β with toFun := Function.const _ }
#align pi.const_non_unital_ring_hom Pi.constNonUnitalRingHom

/-- Non-unital ring homomorphism between the function spaces `I → α` and `I → β`, induced by a
non-unital ring homomorphism `f` between `α` and `β`. -/
@[simps]
protected def NonUnitalRingHom.compLeft {α β : Type _} [NonUnitalNonAssocSemiring α]
    [NonUnitalNonAssocSemiring β] (f : α →ₙ+* β) (I : Type _) : (I → α) →ₙ+* I → β :=
  { f.toMulHom.compLeft I, f.toAddMonoidHom.compLeft I with toFun := fun h => f ∘ h }
#align non_unital_ring_hom.comp_left NonUnitalRingHom.compLeft

end NonUnitalRingHom

section RingHom

universe u v

variable {I : Type u}

/-- Evaluation of functions into an indexed collection of rings at a point is a ring
homomorphism. This is `Function.eval` as a `RingHom`. -/
@[simps!]
def Pi.evalRingHom (f : I → Type v) [∀ i, NonAssocSemiring (f i)] (i : I) : (∀ i, f i) →+* f i :=
  { Pi.evalMonoidHom f i, Pi.evalAddMonoidHom f i with }
#align pi.eval_ring_hom Pi.evalRingHom
#align pi.eval_ring_hom_apply Pi.evalRingHom_apply

/-- `Function.const` as a `RingHom`. -/
@[simps]
def Pi.constRingHom (α β : Type _) [NonAssocSemiring β] : β →+* α → β :=
  { Pi.ringHom fun _ => RingHom.id β with toFun := Function.const _ }
#align pi.const_ring_hom Pi.constRingHom
#align pi.const_ring_hom_apply Pi.constRingHom_apply

/-- Ring homomorphism between the function spaces `I → α` and `I → β`, induced by a ring
homomorphism `f` between `α` and `β`. -/
@[simps]
protected def RingHom.compLeft {α β : Type _} [NonAssocSemiring α] [NonAssocSemiring β]
    (f : α →+* β) (I : Type _) : (I → α) →+* I → β :=
  { f.toMonoidHom.compLeft I, f.toAddMonoidHom.compLeft I with toFun := fun h => f ∘ h }
#align ring_hom.comp_left RingHom.compLeft
#align ring_hom.comp_left_apply RingHom.compLeft_apply

end RingHom


/-
Copyright (c) 2022 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández
-/
import ring_theory.dedekind_domain.ideal

/-!
# Adic valuations on Dedekind domains
Given a Dedekind domain `R` of Krull dimension 1 and a maximal ideal `v` of `R`, we define the
`v`-adic valuation on `R`.
We prove several properties of this valuation, including the existence of uniformizers.
TODO: extend the valuation to the field of fractions `K` of `R`.

## Main definitions
 - `is_dedekind_domain.height_one_spectrum.int_valuation v` is the `v`-adic valuation on `R`.

## Main results
- `is_dedekind_domain.height_one_spectrum.int_valuation_le_one` : The `v`-adic valuation on `R` is
  bounded above by 1.
- `is_dedekind_domain.height_one_spectrum.int_valuation_lt_one_iff_dvd` : The `v`-adic valuation of
  `r ∈ R` is less than 1 if and only if `v` divides the ideal `(r)`.
- `is_dedekind_domain.height_one_spectrum.int_valuation_le_pow_iff_dvd` : The `v`-adic valuation of
  `r ∈ R` is less than or equal to `multiplicative.of_add (-n)` if and only if `vⁿ` divides the
  ideal `(r)`.
- `is_dedekind_domain.height_one_spectrum.int_valuation_exists_uniformizer` : There exists `π ∈ R`
  with `v`-adic valuation `multiplicative.of_add (-1)`.

## Implementation notes
We are only interested in Dedekind domains with Krull dimension 1.

## References
* [G. J. Janusz, *Algebraic Number Fields*][janusz1996]
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]
* [J. Neukirch, *Algebraic Number Theory*][Neukirch1992]

## Tags
dedekind domain, dedekind ring, adic valuation
-/

noncomputable theory
open_locale classical

open multiplicative is_dedekind_domain

variables {R : Type*} [comm_ring R] [is_domain R] [is_dedekind_domain R] {K : Type*} [field K]
  [algebra R K] [is_fraction_ring R K] (v : height_one_spectrum R)

namespace is_dedekind_domain.height_one_spectrum
/-! ### Adic valuations on the Dedekind domain R -/

/-- The additive `v`-adic valuation of `r ∈ R` is the exponent of `v` in the factorization of the
ideal `(r)`, if `r` is nonzero, or infinity, if `r = 0`. `int_valuation_def` is the corresponding
multiplicative valuation. -/
def int_valuation_def (r : R) : with_zero (multiplicative ℤ) :=
if r = 0 then 0 else multiplicative.of_add
  (-(associates.mk v.as_ideal).count (associates.mk (ideal.span {r} : ideal R)).factors : ℤ)

lemma int_valuation_def_if_pos {r : R} (hr : r = 0) : v.int_valuation_def r = 0 := if_pos hr

lemma int_valuation_def_if_neg {r : R} (hr : r ≠ 0) : v.int_valuation_def r = (multiplicative.of_add
  (-(associates.mk v.as_ideal).count (associates.mk (ideal.span {r} : ideal R)).factors : ℤ)) :=
if_neg hr

/-- Nonzero elements have nonzero adic valuation. -/
lemma int_valuation_ne_zero (x : R) (hx : x ≠ 0) : v.int_valuation_def x ≠ 0 :=
begin
  rw [int_valuation_def, if_neg hx],
  exact with_zero.coe_ne_zero,
end

/-- Nonzero divisors have nonzero valuation. -/
lemma int_valuation_ne_zero' (x : non_zero_divisors R) : v.int_valuation_def x ≠ 0 :=
v.int_valuation_ne_zero x (non_zero_divisors.coe_ne_zero x)

/-- Nonzero divisors have valuation greater than zero. -/
lemma int_valuation_zero_le (x : non_zero_divisors R) : 0 < v.int_valuation_def x :=
begin
  rw [v.int_valuation_def_if_neg (non_zero_divisors.coe_ne_zero x)],
  exact with_zero.zero_lt_coe _,
end

/-- The `v`-adic valuation on `R` is bounded above by 1. -/
lemma int_valuation_le_one (x : R) : v.int_valuation_def x ≤ 1 :=
begin
  rw int_valuation_def,
  by_cases hx : x = 0,
  { rw if_pos hx, exact with_zero.zero_le 1 },
  { rw [if_neg hx, ← with_zero.coe_one, ← of_add_zero, with_zero.coe_le_coe, of_add_le,
      right.neg_nonpos_iff],
    exact int.coe_nat_nonneg _ }
end

/-- The `v`-adic valuation of `r ∈ R` is less than 1 if and only if `v` divides the ideal `(r)`. -/
lemma int_valuation_lt_one_iff_dvd (r : R) :
  v.int_valuation_def r < 1 ↔ v.as_ideal ∣ ideal.span {r} :=
begin
  rw int_valuation_def,
  split_ifs with hr,
  { simpa [hr] using (with_zero.zero_lt_coe _) },
  { rw [← with_zero.coe_one, ← of_add_zero, with_zero.coe_lt_coe, of_add_lt, neg_lt_zero,
      ← int.coe_nat_zero, int.coe_nat_lt, zero_lt_iff],
    have h : (ideal.span {r} : ideal R) ≠ 0,
    { rw [ne.def, ideal.zero_eq_bot, ideal.span_singleton_eq_bot],
      exact hr },
    apply associates.count_ne_zero_iff_dvd h (by apply v.irreducible) }
end

/-- The `v`-adic valuation of `r ∈ R` is less than `multiplicative.of_add (-n)` if and only if
`vⁿ` divides the ideal `(r)`. -/
lemma int_valuation_le_pow_iff_dvd (r : R) (n : ℕ) :
  v.int_valuation_def r ≤ multiplicative.of_add (-(n : ℤ)) ↔ v.as_ideal^n ∣ ideal.span {r} :=
begin
  rw int_valuation_def,
  split_ifs with hr,
  { simp_rw [hr, ideal.dvd_span_singleton, zero_le', submodule.zero_mem], },
  { rw [with_zero.coe_le_coe, of_add_le, neg_le_neg_iff, int.coe_nat_le, ideal.dvd_span_singleton,
      ← associates.le_singleton_iff, associates.prime_pow_dvd_iff_le (associates.mk_ne_zero'.mpr hr)
      (by apply v.associates_irreducible)] }
end

/-- The `v`-adic valuation of `0 : R` equals 0. -/
lemma int_valuation.map_zero' : v.int_valuation_def 0 = 0 := v.int_valuation_def_if_pos (eq.refl 0)

/-- The `v`-adic valuation of `1 : R` equals 1. -/
lemma int_valuation.map_one' : v.int_valuation_def 1 = 1 :=
by rw [v.int_valuation_def_if_neg (zero_ne_one.symm : (1 : R) ≠ 0), ideal.span_singleton_one,
  ← ideal.one_eq_top, associates.mk_one, associates.factors_one, associates.count_zero
  (by apply v.associates_irreducible), int.coe_nat_zero, neg_zero, of_add_zero, with_zero.coe_one]

/-- The `v`-adic valuation of a product equals the product of the valuations. -/
lemma int_valuation.map_mul' (x y : R) :
  v.int_valuation_def (x * y) = v.int_valuation_def x * v.int_valuation_def y :=
begin
  simp only [int_valuation_def],
  by_cases hx : x = 0,
  { rw [hx, zero_mul, if_pos (eq.refl _), zero_mul] },
  { by_cases hy : y = 0,
    { rw [hy, mul_zero, if_pos (eq.refl _), mul_zero] },
    { rw [if_neg hx, if_neg hy, if_neg (mul_ne_zero hx hy), ← with_zero.coe_mul, with_zero.coe_inj,
        ← of_add_add, ← ideal.span_singleton_mul_span_singleton, ← associates.mk_mul_mk, ← neg_add,
        associates.count_mul (by apply associates.mk_ne_zero'.mpr hx)
        (by apply associates.mk_ne_zero'.mpr hy) (by apply v.associates_irreducible)],
      refl }}
end

lemma int_valuation.le_max_iff_min_le {a b c : ℕ} :  multiplicative.of_add(-c : ℤ) ≤
  max (multiplicative.of_add(-a : ℤ)) (multiplicative.of_add(-b : ℤ)) ↔ min a b ≤ c :=
by rw [le_max_iff, of_add_le, of_add_le, neg_le_neg_iff, neg_le_neg_iff, int.coe_nat_le,
    int.coe_nat_le, ← min_le_iff]

/-- The `v`-adic valuation of a sum is bounded above by the maximum of the valuations. -/
lemma int_valuation.map_add_le_max' (x y : R) : v.int_valuation_def (x + y) ≤
  max (v.int_valuation_def x) (v.int_valuation_def y) :=
begin
  by_cases hx : x = 0,
  { rw [hx, zero_add],
    conv_rhs {rw [int_valuation_def, if_pos (eq.refl _)]},
    rw max_eq_right (with_zero.zero_le (v.int_valuation_def y)),
    exact le_refl _, },
  { by_cases hy : y = 0,
    { rw [hy, add_zero],
      conv_rhs {rw [max_comm, int_valuation_def, if_pos (eq.refl _)]},
      rw max_eq_right (with_zero.zero_le (v.int_valuation_def x)),
      exact le_refl _ },
    { by_cases hxy : x + y = 0,
      { rw [int_valuation_def, if_pos hxy], exact zero_le',},
      { rw [v.int_valuation_def_if_neg hxy, v.int_valuation_def_if_neg hx,
          v.int_valuation_def_if_neg hy, with_zero.le_max_iff, int_valuation.le_max_iff_min_le],
      set nmin := min
        ((associates.mk v.as_ideal).count (associates.mk (ideal.span {x})).factors)
        ((associates.mk v.as_ideal).count (associates.mk (ideal.span {y})).factors),
      have h_dvd_x : x ∈ v.as_ideal ^ (nmin),
      { rw [← associates.le_singleton_iff x nmin _,
          associates.prime_pow_dvd_iff_le (associates.mk_ne_zero'.mpr hx) _],
        exact min_le_left _ _,
        apply v.associates_irreducible },
      have h_dvd_y : y ∈ v.as_ideal ^ nmin,
      { rw [← associates.le_singleton_iff y nmin _,
          associates.prime_pow_dvd_iff_le (associates.mk_ne_zero'.mpr hy) _],
        exact min_le_right _ _,
        apply v.associates_irreducible },
      have h_dvd_xy : associates.mk v.as_ideal^nmin ≤ associates.mk (ideal.span {x + y}),
      { rw associates.le_singleton_iff,
        exact ideal.add_mem (v.as_ideal^nmin) h_dvd_x h_dvd_y, },
      rw (associates.prime_pow_dvd_iff_le (associates.mk_ne_zero'.mpr hxy) _) at h_dvd_xy,
      exact h_dvd_xy,
      apply v.associates_irreducible, }}}
end

/-- The `v`-adic valuation on `R`. -/
def int_valuation : valuation R (with_zero (multiplicative ℤ)) :=
{ to_fun          := v.int_valuation_def,
  map_zero'       := int_valuation.map_zero' v,
  map_one'        := int_valuation.map_one' v,
  map_mul'        := int_valuation.map_mul' v,
  map_add_le_max' := int_valuation.map_add_le_max' v }

/-- There exists `π ∈ R` with `v`-adic valuation `multiplicative.of_add (-1)`. -/
lemma int_valuation_exists_uniformizer :
  ∃ (π : R), v.int_valuation_def π = multiplicative.of_add (-1 : ℤ) :=
begin
  have hv : _root_.irreducible (associates.mk v.as_ideal) := v.associates_irreducible,
  have hlt : v.as_ideal^2 < v.as_ideal,
  { rw ← ideal.dvd_not_unit_iff_lt,
    exact ⟨v.ne_bot, v.as_ideal,
     (not_congr ideal.is_unit_iff).mpr (ideal.is_prime.ne_top v.is_prime), sq v.as_ideal⟩ } ,
  obtain ⟨π, mem, nmem⟩ := set_like.exists_of_lt hlt,
  have hπ : associates.mk (ideal.span {π}) ≠ 0,
  { rw associates.mk_ne_zero',
    intro h,
    rw h at nmem,
    exact nmem (submodule.zero_mem (v.as_ideal^2)), },
  use π,
  rw [int_valuation_def, if_neg (associates.mk_ne_zero'.mp hπ), with_zero.coe_inj],
  apply congr_arg,
  rw [neg_inj, ← int.coe_nat_one, int.coe_nat_inj'],
  rw [← ideal.dvd_span_singleton, ← associates.mk_le_mk_iff_dvd_iff] at mem nmem,
  rw [← pow_one ( associates.mk v.as_ideal),
    associates.prime_pow_dvd_iff_le hπ hv]  at mem,
  rw [associates.mk_pow, associates.prime_pow_dvd_iff_le hπ hv, not_le] at nmem,
  exact nat.eq_of_le_of_lt_succ mem nmem,
end

end is_dedekind_domain.height_one_spectrum


/-
Copyright (c) 2022 James Gallicchio.

Authors: James Gallicchio
-/

import LeanColls.AuxLemmas
import LeanColls.Array
import LeanColls.IndexedOps

/-!
# Radix Balanced Finger Trees

An implementation of persistent vectors which has fast random
access, fast cons/snoc, and reasonable performance on most other
vector operations.

The implementation is an N-dimensional hypercube where all sides
are `WIDTH` wide. The first and last slice of the highest
dimension can be just partially filled, and are implemented as
"fingers" that provide O(1) access to the first/last elements.

The interior layers of the hypercube are completely full.
This allows for rapid index calculations, like a radix trie.
We also store incremental sizes at each joint of the fingers
to allow faster indexing calculations within the fingers.

## References

See the [Scala issue on GitHub](https://github.com/scala/scala/pull/8534)
introducing this collection. There are no formal references.
-/

namespace LeanColls.RadixBalancedFT

@[inline] constant WIDTH_PREV : Nat := 31
@[inline] def WIDTH : Nat := WIDTH_PREV.succ
@[simp] theorem WIDTH_pos : 0 < WIDTH := Nat.zero_lt_succ _

/- A hypercube array thing with `n` dimensions, each
  `WIDTH` wide, e.g. a total capacity of `WIDTH ^ n`
-/
def HyperArray (α : Type u) : Nat → Type u
| 0   => α
| n+1 => COWArray (HyperArray α n) WIDTH

namespace HyperArray

@[inline, simp]
def size (_ : HyperArray α n) : Nat := WIDTH ^ n

def get : {n : Nat} → HyperArray α n → (i : Fin (WIDTH ^ n)) → α
| 0,   a, ⟨0,_⟩   => a
| n+1, A, ⟨i,h_i⟩ =>
  let q := i / WIDTH^n
  let r := i % WIDTH^n
  have h_q : q < WIDTH := by
    apply Nat.lt_of_mul_lt $ Nat.pos_pow_of_pos _ (by simp)
    rw [Nat.pow_succ, Nat.mul_comm] at h_i
    assumption
  have h_r : r < WIDTH^n :=
    Nat.mod_lt _ (Nat.pos_pow_of_pos _ (by simp))
  COWArray.get A ⟨q, h_q⟩
  |>.get ⟨r, h_r⟩

def set : {n : Nat} → HyperArray α n → (i : Fin (WIDTH ^ n)) → α → HyperArray α n
| 0,   _, ⟨0,_⟩  , a => a
| n+1, A, ⟨i,h_i⟩, a =>
  let q := i / WIDTH^n
  let r := i % WIDTH^n
  have h_q : q < WIDTH := by
    apply Nat.lt_of_mul_lt $ Nat.pos_pow_of_pos _ (by simp)
    rw [Nat.pow_succ, Nat.mul_comm] at h_i
    assumption
  have h_r : r < WIDTH^n :=
    Nat.mod_lt _ (Nat.pos_pow_of_pos _ (by simp))
  COWArray.update A ⟨q, h_q⟩
  <| λ A' => set A' ⟨r, h_r⟩ a

theorem get_of_set (A : HyperArray α n) (i j : Fin (WIDTH ^ n)) (x : α)
  : (A.set i x |>.get j) = if i = j then x else A.get j
  := by
  induction n with
  | zero =>
    simp [HyperArray, Nat.pow_zero] at A i j
    cases i; case mk i h_i =>
    cases j; case mk j h_j =>
    have : i = 0 := Nat.eq_zero_of_le_zero <| Nat.le_of_succ_le_succ h_i
    cases this
    have : j = 0 := Nat.eq_zero_of_le_zero <| Nat.le_of_succ_le_succ h_j
    cases this
    simp [set, get]
  | succ n ih =>
    simp [HyperArray, Nat.pow_zero] at A i j
    cases i; case mk i h_i =>
    cases j; case mk j h_j =>
    by_cases i = j
    case inl h =>
      simp [h, set, get, COWArray.update, COWArray.get, COWArray.set, ih]
    case inr h =>
      simp [h]
      by_cases i / WIDTH ^ n = j / WIDTH ^ n
      case inl h' =>
        simp [h', set, get, COWArray.update, COWArray.get, COWArray.set, ih]
        have : i % WIDTH ^ n ≠ j % WIDTH ^ n := by
          clear A x ih
          rw [←Nat.div_add_mod i (WIDTH ^ n), ←Nat.div_add_mod j (WIDTH ^ n)] at h
          rw [h'] at h
          clear h'
          exact h ∘ (congrArg _)
        simp [this]
      case inr h' =>
        simp [h', set, get, COWArray.update, COWArray.get, COWArray.set]
        simp [Array.copy, Array.init_eq_mk, Array.get, Array.set]

def repr [R : Repr α] : {n : Nat} → Repr (HyperArray α n)
| 0 => R
| n+1 => @COWArray.instReprCOWArray _ _ (repr)

instance [Repr α] : Repr (HyperArray α n) := repr

end HyperArray

structure HyperRect (α : Type u) (n : Nat) : Type u where
  (w : Nat)
  (backing : COWArray (HyperArray α n) w)
  (size : Cached (w * WIDTH ^ n))
deriving Repr

namespace HyperRect

def ofArray {w} (backing : COWArray (HyperArray α n) w) : HyperRect α n :=
  ⟨w, backing, cached _⟩

def empty : HyperRect α n := ofArray (COWArray.empty)

def singleton (A : HyperArray α n) : HyperRect α n :=
  ⟨1, COWArray.singleton A, cached _⟩

def fullToHyperArray : (r : HyperRect α n) → r.w = WIDTH → HyperArray α n.succ
| ⟨_, backing, _⟩, h =>
  backing |> cast (by simp at h; simp [HyperArray, h])

theorem size_eq_sum_sizes (F : HyperRect α n)
  : Foldable.fold (λ x (acc : Nat) => x.size + acc) 0 F.backing = F.size
  := by
  match F with
  | ⟨w, ⟨backing⟩, _⟩ =>
  simp
  unfold Foldable.fold
  simp [COWArray.instFoldableCOWArray]
  unfold Foldable.fold
  simp [instFoldable]
  simp [Indexed.size, Indexed.nth]
  apply Range.fold_ind (motive := λ w res => res = w * WIDTH ^ n)
  case init => simp
  case step =>
  intro i acc h_i h_acc
  simp [h_acc, Nat.succ_mul, Nat.add_comm]

def get : (A : HyperRect α n) → Fin A.size → α
| ⟨w,A,_⟩, ⟨i,h_i⟩ =>
  let q := i / WIDTH^n
  let r := i % WIDTH^n
  have h_q := by
    simp at h_i
    apply Nat.lt_of_mul_lt $ Nat.pos_pow_of_pos _ (by simp)
    assumption
  have h_r := Nat.mod_lt _ (Nat.pos_pow_of_pos _ $ by simp)
  COWArray.get A ⟨q, h_q⟩
  |>.get ⟨r, h_r⟩

def set : (A : HyperRect α n) → Fin A.size → α → HyperRect α n
| ⟨w,A,size⟩, ⟨i,h_i⟩, a =>
  let q := i / WIDTH^n
  let r := i % WIDTH^n
  have h_q := by
    simp at h_i
    apply Nat.lt_of_mul_lt $ Nat.pos_pow_of_pos _ (by simp)
    assumption
  have h_r := Nat.mod_lt _ (Nat.pos_pow_of_pos _ $ by simp)
  ⟨w,
    COWArray.update A ⟨q, h_q⟩ <| λ A' => A'.set ⟨r, h_r⟩ a,
    size⟩

def cons : HyperArray α n → HyperRect α n → HyperRect α n
| x, ⟨w,A,size⟩ =>
  ⟨w.succ, A.cons x,
    cached' (size.val + WIDTH ^ n) (by simp [Nat.succ_mul])⟩

def snoc : HyperRect α n → HyperArray α n → HyperRect α n
| ⟨w,A,size⟩, x =>
  ⟨w.succ, A.snoc x,
    cached' (size.val + WIDTH ^ n) (by simp [Nat.succ_mul])⟩

def front? : HyperRect α n → Option (HyperArray α n × HyperRect α n)
| ⟨0,_,_⟩ => none
| ⟨w+1, A, size⟩ =>
  match A.front with
  | (x, A') =>
  some (x, ⟨w, A',
      cached' (size.val - WIDTH ^ n) (by
        simp [Nat.succ_mul, Nat.add_sub_cancel])⟩
  )

theorem size_front?_none : (r : HyperRect τ n) → front? r = none → r.size.val = 0
| ⟨w, A, _⟩, h => by
  simp [front?] at *
  split at h
  case h_1 h_r =>
    simp at h_r
    simp [h_r.left]
  case h_2 =>
    contradiction

def back? : HyperRect α n → Option (HyperRect α n × HyperArray α n)
| ⟨0,_,_⟩ => none
| ⟨w+1, A, size⟩ =>
  match A.back with
  | (A', x) =>
  some (
    ⟨w, A',
      cached' (size.val - WIDTH ^ n) (by
        simp [Nat.succ_mul, Nat.add_sub_cancel])⟩,
    x
  )

end HyperRect

/-!
## FingerList

A linked-list-like representation of the prefix/suffix fingers.
A `FingerList τ n m` is a list of `HyperRect τ i`s for `m ≤ i < n`.
-/
inductive FingerList (τ : Type u) (n : Nat) : Nat → Type u
| base  : FingerList τ n n
| joint : (hd : HyperRect τ m) → (tl : FingerList τ n m.succ)
          → FingerList τ n m
deriving Repr

namespace FingerList

theorem upperBound (L : FingerList τ n m) : m ≤ n := by
  induction L
  apply Nat.le_refl
  apply Nat.le_of_lt
  assumption

theorem upperBound_zero_base (L : FingerList τ 0 0) : L = base := by
  match L with
  | base => rfl
  | joint hd tl =>
    have := upperBound tl
    contradiction

def size : FingerList τ n m → Nat
| base => 0
| joint hd tl => hd.size + tl.size

def validList : FingerList τ n m → Bool
| base => true
| joint hd tl =>
  hd.w ≤ WIDTH && validList tl

def isFull : FingerList τ n m → Bool
| base => true
| joint hd tl =>
  hd.w = WIDTH && isFull tl

def extend (new : HyperRect τ n) : FingerList τ n m → FingerList τ n.succ m
| base => joint new base
| joint hd tl => joint hd (extend new tl)

def unextend : {n m : Nat} → m ≤ n → FingerList τ n.succ m → HyperRect τ n × FingerList τ n m
| _, _, h, base => False.elim (Nat.ne_of_lt h rfl)
| _, _, h, joint hd base => (hd, base)
| n, m, h, joint hd (joint hd' tl') =>
  have : m.succ ≤ n := Nat.le_of_succ_le_succ (upperBound tl')
  let (x, tl) := unextend this (joint hd' tl')
  (x, joint hd tl)

/-!
getL
Indexes into L from the left; e.g. 0 is the top-left
element, and `L.size - 1` is the bottom right's last element.
-/
def getL : (L : FingerList τ n m) → (h_L : L.validList)
          → (i : Nat) → (h_i : i < L.size)
          → τ
| base, _, _, h_i =>
  False.elim <| by
    simp [size] at h_i
    exact Nat.not_lt_zero _ h_i
| joint hd tl, h_L, i, h_i =>
  if h : i < hd.size then
    hd.get ⟨i, h⟩
  else
    getL tl
      (by simp [validList] at h_L; exact h_L.right)
      (i - hd.size)
      (by
        simp [size] at h_i ⊢
        apply Nat.sub_lt_of_lt_add
        rw [Nat.add_comm]
        simp [h_i]
        simp at h
        exact Nat.ge_of_not_lt h)

/-! See `getL` -/
def setL : (L : FingerList τ n m) → (h_L : L.validList)
          → (i : Nat) → (h_i : i < L.size)
          → τ → FingerList τ n m
| base, _, _, h_i, a =>
  False.elim <| by
    simp [size] at h_i
    exact Nat.not_lt_zero _ h_i
| joint hd tl, h_L, i, h_i, a =>
  if h : i < hd.size then
    joint (hd.set ⟨i, h⟩ a) tl
  else
    joint hd <|
      setL tl (by
        simp [validList] at h_L
        exact h_L.right)
        (i - hd.size)
        (by
          simp [size] at h_i ⊢
          apply Nat.sub_lt_of_lt_add
          rw [Nat.add_comm]
          simp [h_i]
          simp at h
          exact Nat.ge_of_not_lt h)
        a

theorem valid_setL_of_valid (L : FingerList τ n m) (h_L : L.validList)
          (i : Nat) (h_i : i < L.size) (x : τ)
  : validList (setL L h_L i h_i x)
  := by
  induction L generalizing i with
  | base =>
    apply False.elim
    simp [size] at h_i
    exact Nat.not_lt_zero _ h_i
  | joint hd tl ih =>
    simp [setL]
    split <;> (
      simp [validList, HyperRect.set] at h_L ⊢
      simp [h_L, ih]
    )

def size_setL (L : FingerList τ n m) (h_L : L.validList)
          (i : Nat) (h_i : i < L.size) (x : τ)
  : size (setL L h_L i h_i x) = size L
  := by
  induction L generalizing i with
  | base =>
    apply False.elim
    simp [size] at h_i
    exact Nat.not_lt_zero _ h_i
  | joint hd tl ih =>
    simp [setL]
    split <;> (
      simp [set, HyperRect.set] at h_L ⊢
      simp [size, ih]
    )

/-! getR
Indexes into `L` from the right, e.g. 0 is the top-right
element and `L.size-1` is the bottom-left's first element.
-/
def getR : (L : FingerList τ n m) → (h_L : L.validList)
          → (i : Nat) → (h_i : i < L.size)
          → τ
| base, _, _, h_i =>
  False.elim <| by
    simp [size] at h_i
    exact Nat.not_lt_zero _ h_i
| joint hd tl, h_L, i, h_i =>
  if h : i < hd.size then
    hd.get ⟨hd.size - i.succ,
      Nat.sub_lt_of_lt_add (Nat.add_lt_add_left (Nat.zero_lt_succ _) _) h⟩
  else
    getR tl
      (by simp [validList] at h_L; exact h_L.right)
      (i - hd.size)
      (by
        simp [size] at h_i ⊢
        apply Nat.sub_lt_of_lt_add
        rw [Nat.add_comm]
        simp [h_i]
        simp at h
        exact Nat.ge_of_not_lt h)

/-! See `getR` -/
def setR : (L : FingerList τ n m) → (h_L : L.validList)
          → (i : Nat) → (h_i : i < L.size)
          → τ → FingerList τ n m
| base, _, _, h_i, a =>
  False.elim <| by
    simp [size] at h_i
    exact Nat.not_lt_zero _ h_i
| joint hd tl, h_L, i, h_i, a =>
  if h : i < hd.size then
    let hd' := hd.set ⟨hd.size - i.succ,
      Nat.sub_lt_of_lt_add (Nat.add_lt_add_left (Nat.zero_lt_succ _) _) h⟩
      a
    joint hd' tl
  else
    joint hd <|
      setR tl (by
        simp [validList] at h_L
        exact h_L.right)
        (i - hd.size)
        (by
          simp [size] at h_i ⊢
          apply Nat.sub_lt_of_lt_add
          rw [Nat.add_comm]
          simp [h_i]
          simp at h
          exact Nat.ge_of_not_lt h)
        a

theorem valid_setR_of_valid (L : FingerList τ n m) (h_L : L.validList)
          (i : Nat) (h_i : i < L.size) (x : τ)
  : validList (setR L h_L i h_i x)
  := by
  induction L generalizing i with
  | base =>
    apply False.elim
    simp [size] at h_i
    exact Nat.not_lt_zero _ h_i
  | joint hd tl ih =>
    simp [setR]
    split <;> (
      simp [validList, HyperRect.set] at h_L ⊢
      simp [h_L, ih]
    )

def size_setR (L : FingerList τ n m) (h_L : L.validList)
          (i : Nat) (h_i : i < L.size) (x : τ)
  : size (setR L h_L i h_i x) = size L
  := by
  induction L generalizing i with
  | base =>
    apply False.elim
    simp [size] at h_i
    exact Nat.not_lt_zero _ h_i
  | joint hd tl ih =>
    simp [setR]
    split <;> (
      simp [set, HyperRect.set] at h_L ⊢
      simp [size, ih]
    )

/- Pushes `x` onto `L` from the left at the top joint (small element).
If `L` is full, returns the (full) bottom joint as a `HyperArray τ n`
and shifts everything else up to accommodate `x`.
-/
def consL (x : HyperArray τ m) : (L : FingerList τ n m) → L.validList →
    FingerList τ n m × Option (HyperArray τ n)
| base, _ => (base, some x)
| joint hd tl, h_L =>
    if h : hd.w < WIDTH then
      (joint (hd.cons x) tl, none)
    else
      have ⟨h_w, h_tl⟩ : hd.w ≤ WIDTH ∧ tl.validList := by
        simp [validList] at h_L
        simp at h_L
        simp [h_L]
      have h_w : hd.w = WIDTH := by
        apply Nat.le_antisymm
        exact h_w
        exact Nat.ge_of_not_lt h
      let newSlice : HyperArray τ (m + 1) :=
        hd.backing
        |> cast (by simp [h_w, HyperArray, WIDTH])
      let (fl, excess) := consL newSlice tl h_tl
      (joint ⟨1, COWArray.singleton x, cached' (WIDTH ^ m) (by simp)⟩ fl,
        excess)

theorem valid_consL (x : HyperArray τ m) (L : FingerList τ n m) (h_L : L.validList)
  : let ⟨L',_⟩ := L.consL x h_L
    L'.validList
  := by
  induction L with
  | base =>
    simp [consL, h_L]
  | joint hd tl ih =>
    simp [consL]
    simp [validList] at h_L
    split
    case inl m' h =>
      simp [validList]
      simp [HyperRect.cons, h_L]
      exact h
    case inr m' h =>
      split
      case _ _ h_w h_tl _ =>
      simp [validList]
      constructor
      case left  => exact WIDTH_pos
      case right =>
      apply ih

theorem size_consL (x : HyperArray τ m) (L : FingerList τ n m) (h_L : L.validList)
  {L' excess} (h_L' : L.consL x h_L = (L', excess))
  : L'.size + (match excess with
      | none => 0
      | some e => HyperArray.size e
    ) = L.size + x.size
  := by
  simp [Option.getD, Option.map, Option.bind]
  induction L generalizing excess with
  | base =>
    split
    case h_1 h_L' =>
      simp [size, consL] at h_L'
    case h_2 h_L' =>
      simp [size, consL] at h_L'
      simp [h_L']
  | joint hd tl ih =>
    rename Nat => m'
    clear m
    simp [validList] at h_L
    have : hd.w < WIDTH ∨ hd.w = WIDTH := by
      match h : Nat.beq hd.w WIDTH with
      | false =>
        apply Or.inl (Nat.lt_of_le_and_ne (And.left h_L) _)
        apply Nat.ne_of_beq_eq_false h
      | true =>
        apply Or.inr
        apply Nat.eq_of_beq_eq_true h
    match this with
    | .inl h_w =>
      split
      case h_1 h_L' =>
        simp [consL, h_w, HyperRect.cons] at h_L'
        simp [←h_L', size]
        rw [Nat.succ_mul, Nat.add_assoc, Nat.add_comm _ (size tl), ←Nat.add_assoc]
      case h_2 h_L' =>
        simp [consL, h_w, HyperRect.cons] at h_L'
    | .inr h_w =>
      clear this
      cases hd; case mk m w backing hd_size h_L'' =>
      simp at h_w
      simp [size]
      rw [Nat.add_comm _ (size tl), Nat.add_assoc, h_w]
      unfold consL at h_L'
      simp [h_w] at h_L'
      split at h_L'
      rename validList tl = true => h_tl
      simp [h_w, size] at h_L'
      subst h_w
      simp [cast] at h_L'
      split
      case h_1 =>
        simp [consL, HyperRect.cons] at h_L'
        simp [←h_L'.1, size]
        cases consL backing tl h_tl; case mk fst snd =>
        have : size fst + _ = _ := ih backing h_tl ( := snd)
        rw [Nat.add_comm, ih, Nat.add_assoc, Nat.add_comm _ (size tl), ←Nat.add_assoc]
      case h_2 h_L' =>
        simp [consL, h_w, HyperRect.cons] at h_L'
      rw [Nat.add_assoc, ih, Nat.pow_succ, Nat.mul_comm]
      simp_arith

/- Pushes `x` onto `L` from the right at the top joint (small elements).
If `L` is full, returns the (full) bottom joint as a `HyperArray τ n`
and shifts everything else up to accommodate `x`.
-/
def consR (x : HyperArray τ m) : (L : FingerList τ n m) → L.validList →
    FingerList τ n m × Option (HyperArray τ n)
| base, _ => (base, some x)
| joint hd tl, h_L =>
    if h : hd.w < WIDTH then
      (joint (hd.cons x) tl, none)
    else
      have ⟨h_w, h_tl⟩ : hd.w ≤ WIDTH ∧ tl.validList := by
        simp [validList] at h_L
        simp at h_L
        simp [h_L]
      have h_w : hd.w = WIDTH := by
        apply Nat.le_antisymm
        exact h_w
        exact Nat.ge_of_not_lt h
      let newSlice : HyperArray τ (m + 1) :=
        hd.backing
        |> cast (by simp [h_w, HyperArray, WIDTH])
      match consR newSlice tl h_tl with
      | (fl, excess) =>
      (joint ⟨1, COWArray.singleton x, cached' (WIDTH ^ m) (by simp)⟩ fl, excess)

theorem valid_consR (x : HyperArray τ m) (L : FingerList τ n m) (h_R : L.validList)
  : let ⟨L',_⟩ := L.consR x h_R
    L'.validList
  := by
  induction L with
  | base =>
    simp [consR, h_R]
  | joint hd tl ih =>
    simp [consR]
    simp [validList] at h_R
    split
    case inl m' h =>
      simp [validList]
      simp [HyperRect.cons, h_R]
      exact h
    case inr m' h =>
      split
      case _ _ h_w h_tl _ =>
      simp [validList]
      constructor
      case left  => exact WIDTH_pos
      case right =>
      apply ih

theorem size_consR (x : HyperArray τ m) (L : FingerList τ n m) (h_L : L.validList)
  : let ⟨L', excess⟩ := L.consR x h_L
    L'.size + (match excess with
      | none => 0
      | some e => HyperArray.size e
    ) = L.size + x.size
  := by
  simp [Option.getD, Option.map, Option.bind]
  induction L with
  | base =>
    simp [size, consR]
  | joint hd tl ih =>
    clear m
    simp [validList] at h_L
    have : hd.w < WIDTH ∨ hd.w = WIDTH := by
      match h : Nat.beq hd.w WIDTH with
      | false =>
        apply Or.inl (Nat.lt_of_le_and_ne (And.left h_L) _)
        apply Nat.ne_of_beq_eq_false h
      | true =>
        apply Or.inr
        apply Nat.eq_of_beq_eq_true h
    match this with
    | .inl h_w =>
      simp [size, consR, h_w, HyperRect.cons]
      rw [Nat.succ_mul, Nat.add_assoc, Nat.add_comm _ (size tl), ←Nat.add_assoc]
    | .inr h_w =>
      cases hd; case mk m w backing hd_size h_L' =>
      simp at h_w
      unfold consR
      simp [h_w]
      split
      simp [h_w, size]
      subst h_w
      simp [cast]
      rw [Nat.add_assoc, ih, Nat.pow_succ, Nat.mul_comm]
      simp_arith

/- Pops a single element from the left at the top joint (small elements).
  If `L` is empty, returns none.
-/
def frontL? : FingerList τ n m → Option (HyperArray τ m × FingerList τ n m)
| base => none
| joint hd tl =>
  match hd.front? with
  | some (A, hd') => some (A, joint hd' tl)
  | none =>
  match tl.frontL? with
  | none => none
  | some (A, tl') =>
    match A.front with
    | (A', hd') =>
      some (A', joint (.ofArray hd') tl')

theorem size_frontL?_none (L : FingerList τ n m)
  : frontL? L = none → size L = 0
  := by
    intro h
    induction L with
    | base => simp [size]
    | joint hd tl ih =>
      simp [frontL?] at h
      split at h
      simp [size]; contradiction
      case h_2 h_hd =>
      split at h
      case h_1 h_tl =>
        simp [size, ih h_tl]
        simp [HyperRect.front?] at h_hd
        split at h_hd <;> simp
        contradiction
      case h_2 h_tl =>
        contradiction

/- Pops a single element from the right at the top joint (small elements).
  If `L` is empty, returns none.
-/
def frontR? : FingerList τ n m → Option (FingerList τ n m × HyperArray τ m)
| base => none
| joint hd tl =>
  match hd.back? with
  | some (hd', A) => some (joint hd' tl, A)
  | none =>
  match tl.frontR? with
  | none => none
  | some (tl', A) =>
    match A.back with
    | (hd', A') =>
      some (joint (.ofArray hd') tl', A')

def splitHyperArrayL : {m : Nat} → HyperArray τ m → FingerList τ n m → τ × FingerList τ n 0
| 0, x, L => (x, L)
| m+1, A, L =>
  match A.front with
  | (hd, tl) =>
  let tl := joint
    ⟨WIDTH-1, tl, cached _⟩
    L
  splitHyperArrayL hd tl

def splitHyperArrayR : {m : Nat} → HyperArray τ m → FingerList τ n m → τ × FingerList τ n 0
| 0, x, L => (x, L)
| m+1, A, L =>
  match A.back with
  | (tl, hd) =>
  let tl := joint
    ⟨WIDTH-1, tl, cached _⟩
    L
  splitHyperArrayR hd tl

end RadixBalancedFT.FingerList

open RadixBalancedFT

structure RadixBalancedFT (τ : Type u) : Type u where
  depth : Nat
  pre : FingerList τ depth 0 -- "L" fingerlist
  mid : HyperRect τ depth
  suf : FingerList τ depth 0 -- "R" fingerlist
  mid_idx : Cached pre.size
  suf_idx : Cached (pre.size + mid.size)
  size : Cached (pre.size + mid.size + suf.size)
  h_pre : pre.validList
  h_mid : mid.w ≤ WIDTH
  h_suf : suf.validList
deriving Repr

namespace RadixBalancedFT

abbrev RBFT := RadixBalancedFT

def empty : RBFT τ := {
  depth := 0
  pre := .base
  mid := ⟨0, COWArray.empty, cached' 0 (by simp)⟩
  suf := .base
  mid_idx := cached' 0 (by simp [FingerList.size])
  suf_idx := cached' 0 (by simp [FingerList.size])
  size := cached' 0 (by simp [FingerList.size])
  h_pre := by simp [FingerList.validList]
  h_mid := by simp
  h_suf := by simp [FingerList.validList]
}

def get : (A : RBFT τ) → Fin A.size → τ
| ⟨_, pre, mid, suf, mid_idx, suf_idx, size, h_pre, h_mid, h_suf⟩, ⟨i,h_i⟩ =>
  if h : i < mid_idx then
    pre.getL h_pre i (by simp at h; assumption)
  else if h' : i < suf_idx then
    have h_i := by
      rw [Cached.cached_val] at h h' ⊢
      apply Nat.le_of_add_le_add_right
      rw [Nat.succ_add, Nat.sub_add_cancel (Nat.ge_of_not_lt h)]
      rw [Nat.add_comm] at h'
      assumption
    mid.get ⟨i - mid_idx, h_i⟩
  else
    have h := by
      apply Nat.sub_lt_of_lt_add
      rw [←Nat.add_assoc, Nat.add_one]
      apply Nat.succ_le_succ
      have h := Nat.ge_of_not_lt h'
      simp at h ⊢
      rw [Nat.add_comm]
      apply Nat.add_le_add
      apply Nat.le_refl
      assumption
      simp at h_i ⊢
      assumption
    suf.getR h_suf (size - (i+1)) h

def set : (A : RBFT τ) → Fin A.size → τ → RBFT τ
| A, ⟨i,h_i⟩, a =>
  if h : i < A.mid_idx then
    {A with
      pre := A.pre.setL A.h_pre i (by simp at h; assumption) a
      h_pre := by simp [FingerList.valid_setL_of_valid]
      mid_idx := cast (by rw [FingerList.size_setL]) A.mid_idx
      suf_idx := cast (by rw [FingerList.size_setL]) A.suf_idx
      h_suf := by simp [FingerList.valid_setL_of_valid, FingerList.size_setL]; exact A.h_suf
      size := cast (by rw [FingerList.size_setL]) A.size
      }
  else if h' : i < A.suf_idx then
    have h_i := by
      rw [Cached.cached_val] at h h' ⊢
      simp at h h' ⊢
      apply Nat.sub_lt_of_lt_add
      rw [Nat.add_comm]
      assumption
      exact Nat.ge_of_not_lt h
    {A with
      mid := A.mid.set ⟨i - A.mid_idx, h_i⟩ a
      }
  else
    have h := by
      apply Nat.sub_lt_of_lt_add _ (Nat.ge_of_not_lt h')
      simp at h_i ⊢
      rw [Nat.add_comm]
      exact h_i
    {A with
      suf := A.suf.setR A.h_suf (i - A.suf_idx) h a
      h_suf := by simp [FingerList.valid_setR_of_valid]
      size := cast (by rw [FingerList.size_setR]) A.size
      }

def cons (x : τ) (A : RBFT τ) : RBFT τ :=
  -- Try putting x in the prefix finger
  match h_preCons : A.pre.consL x A.h_pre with
  | (pre, none) =>
    have h_pre := by
      have := FingerList.valid_consL x A.pre A.h_pre
      rw [h_preCons] at this
      exact this
    have size_pre : pre.size = A.pre.size + 1 := by
      have := A.pre.size_consL x
      rw [h_preCons]
      sorry
    {A with
      pre := pre
      h_pre := h_pre
      mid_idx := cached' (A.mid_idx.val + 1) (by sorry)
      suf_idx := cached' (A.suf_idx.val + 1) (by sorry)
      size := cached' (A.size.val + 1) (by sorry)
    }
  | (pre, some excess) =>
    /- The finger was full! Now we have a new (full) slice
      to put somewhere -/
    if h : A.mid.w < WIDTH then
    -- We can put the slice here!
    { pre := pre
      mid := A.mid.cons excess
      suf := A.suf
      h_pre := by sorry
      h_mid := by sorry
      h_suf := A.h_suf
      mid_idx := cached' 1 (by sorry)
      suf_idx := cached' (A.suf_idx.val + 1) (by sorry)
      size := cached' (A.size.val + 1) (by sorry)
      }
    else
    have h : A.mid.w = WIDTH := by
      apply Nat.le_antisymm
      exact A.h_mid
      exact Nat.ge_of_not_lt h
    -- We need a new level!
    { depth := A.depth.succ,
      pre := pre.extend (.singleton excess)
      mid := .singleton (A.mid.fullToHyperArray h)
      suf := A.suf.extend .empty
      h_pre := by sorry
      h_mid := by simp [HyperRect.singleton]; exact WIDTH_pos
      h_suf := by sorry
      mid_idx := cached' (A.mid_idx.val + 1) (by sorry)
      suf_idx := cached' (A.mid_idx.val + 1) (by sorry)
      size := cached' (A.size.val + 1) (by sorry)
      }

def front? : RBFT τ → Option (τ × RBFT τ)
| ⟨depth, pre, mid, suf, mid_idx, suf_idx, size, h_pre, h_mid, h_suf⟩ =>
  if h : size.val = 0 then none else (
    match h_preFront : pre.frontL? with
    | some (x, pre') => some (x, {
      pre := pre', mid, suf,
      mid_idx := cached' (mid_idx - 1) (by sorry)
      suf_idx := cached' (suf_idx - 1) (by sorry)
      size := cached' (size - 1) (by sorry)
      h_pre := by sorry, h_mid, h_suf
      })
    | none =>
    match h_midFront : mid.front? with
    | some (slice, mid') =>
      match FingerList.splitHyperArrayL slice .base with
      | (x, pre') => some (x, {
        pre := pre',
        mid := mid',
        suf,
        mid_idx := cached' (mid_idx - 1) (by sorry)
        suf_idx := cached' (suf_idx - 1) (by sorry)
        size := cached' (size - 1) (by sorry)
        h_pre := by sorry
        h_mid := by sorry,
        h_suf
      })
    | none =>
    -- Time to yeet a level
    match h_depth : depth with
    | 0 => by
      simp at h_depth; cases h_depth
      simp at *
      cases pre.upperBound_zero_base
      cases suf.upperBound_zero_base
      have := HyperRect.size_front?_none _ h_midFront
      simp at this
      simp [FingerList.size] at h
      contradiction
    | depth+1 =>
    match suf.unextend (Nat.zero_le _) with
    | (x, suf') =>
    front? {
      depth,
      pre := pre.unextend (Nat.zero_le _) |>.snd,
      mid := x,
      suf := suf',
      mid_idx := cached' 0 (by sorry),
      suf_idx := cached' x.size (by sorry),
      size := cached' size (by sorry),
      h_pre := by sorry
      h_mid := by sorry
      h_suf := by sorry
    }
  )
termination_by _ r => r.depth

instance : Enumerable (RBFT α) α where
  ρ := RBFT α
  fromEnumerator := id
  insert := λ
    | none => empty
    | some (x, y) => cons x y

instance : Iterable (RBFT α) α where
  ρ := RBFT α
  toIterator := id
  step := front?

def test := @Range.mk 1237
  |> View.of
  |>.map (Fin.val)
  |>.fold cons empty