/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import morphisms.basic
import topology.spectral.hom
import algebraic_geometry.limits

/-!
# Quasi-compact morphisms

A morphism of schemes is quasi-compact if the preimages of quasi-compact open sets are
quasi-compact.

It suffices to check that preimages of affine open sets are compact
(`quasi_compact_iff_forall_affine`).

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

open_locale algebraic_geometry

namespace algebraic_geometry

variables {X Y : Scheme.{u}} (f : X ⟶ Y)

/--
A morphism is `quasi-compact` if the underlying map of topological spaces is, i.e. if the preimages
of quasi-compact open sets are quasi-compact.
-/
@[mk_iff]
class quasi_compact (f : X ⟶ Y) : Prop :=
(is_compact_preimage [] : ∀ U : set Y.carrier,
  is_open U → is_compact U → is_compact (f.1.base ⁻¹' U))

lemma quasi_compact_iff_spectral : quasi_compact f ↔ is_spectral_map f.1.base :=
⟨λ ⟨h⟩, ⟨by continuity, h⟩, λ h, ⟨h.2⟩⟩

/-- The `affine_target_morphism_property` corresponding to `quasi_compact`, asserting that the
domain is a quasi-compact scheme. -/
def quasi_compact.affine_property : affine_target_morphism_property :=
λ X Y f hf, compact_space X.carrier

@[priority 900]
instance quasi_compact_of_is_iso {X Y : Scheme} (f : X ⟶ Y) [is_iso f] : quasi_compact f :=
begin
  constructor,
  intros U hU hU',
  convert hU'.image (inv f.1.base).continuous_to_fun using 1,
  rw set.image_eq_preimage_of_inverse,
  delta function.left_inverse,
  exacts [is_iso.inv_hom_id_apply f.1.base, is_iso.hom_inv_id_apply f.1.base]
end

instance quasi_compact_comp {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z)
  [quasi_compact f] [quasi_compact g] : quasi_compact (f ≫ g) :=
begin
  constructor,
  intros U hU hU',
  rw [Scheme.comp_val_base, coe_comp, set.preimage_comp],
  apply quasi_compact.is_compact_preimage,
  { exact continuous.is_open_preimage (by continuity) _ hU },
  apply quasi_compact.is_compact_preimage; assumption
end

lemma is_compact_open_iff_eq_finset_affine_union {X : Scheme} (U : set X.carrier) :
  is_compact U ∧ is_open U ↔
    ∃ (s : set X.affine_opens), s.finite ∧ U = ⋃ (i : X.affine_opens) (h : i ∈ s), i :=
begin
  apply opens.is_compact_open_iff_eq_finite_Union_of_is_basis
    (coe : X.affine_opens → opens X.carrier),
  { rw subtype.range_coe, exact is_basis_affine_open X },
  { intro i, exact i.2.is_compact }
end

lemma is_compact_open_iff_eq_basic_open_union {X : Scheme} [is_affine X] (U : set X.carrier) :
  is_compact U ∧ is_open U ↔
    ∃ (s : set (X.presheaf.obj (op ⊤))), s.finite ∧
      U = ⋃ (i : X.presheaf.obj (op ⊤)) (h : i ∈ s), X.basic_open i :=
begin
  apply opens.is_compact_open_iff_eq_finite_Union_of_is_basis,
  { exact is_basis_basic_open X },
  { intro i, exact ((top_is_affine_open _).basic_open_is_affine _).is_compact }
end

lemma quasi_compact_iff_forall_affine : quasi_compact f ↔
  ∀ U : opens Y.carrier, is_affine_open U → is_compact (f.1.base ⁻¹' (U : set Y.carrier)) :=
begin
  rw quasi_compact_iff,
  refine ⟨λ H U hU, H U U.prop hU.is_compact, _⟩,
  intros H U hU hU',
  obtain ⟨S, hS, rfl⟩ := (is_compact_open_iff_eq_finset_affine_union U).mp ⟨hU', hU⟩,
  simp only [set.preimage_Union, subtype.val_eq_coe],
  exact hS.is_compact_bUnion (λ i _, H i i.prop)
end

@[simp] lemma quasi_compact.affine_property_to_property {X Y : Scheme} (f : X ⟶ Y) :
  (quasi_compact.affine_property : _).to_property f ↔
    is_affine Y ∧ compact_space X.carrier :=
by { delta affine_target_morphism_property.to_property quasi_compact.affine_property, simp }

lemma quasi_compact_iff_affine_property :
  quasi_compact f ↔ target_affine_locally quasi_compact.affine_property f :=
begin
  rw quasi_compact_iff_forall_affine,
  transitivity (∀ U : Y.affine_opens, is_compact (f.1.base ⁻¹' (U : set Y.carrier))),
  { exact ⟨λ h U, h U U.prop, λ h U hU, h ⟨U, hU⟩⟩ },
  apply forall_congr,
  exact λ _, is_compact_iff_compact_space,
end

lemma quasi_compact_eq_affine_property :
  @quasi_compact = target_affine_locally quasi_compact.affine_property :=
by { ext, exact quasi_compact_iff_affine_property _ }

lemma is_compact_basic_open (X : Scheme) {U : opens X.carrier} (hU : is_compact (U : set X.carrier))
   (f : X.presheaf.obj (op U)) : is_compact (X.basic_open f : set X.carrier) :=
begin
  classical,
  refine ((is_compact_open_iff_eq_finset_affine_union _).mpr _).1,
  obtain ⟨s, hs, e⟩ := (is_compact_open_iff_eq_finset_affine_union _).mp ⟨hU, U.prop⟩,
  let g : s → X.affine_opens,
  { intro V,
    use V.1 ⊓ X.basic_open f,
    have : V.1.1 ⟶ U,
    { apply hom_of_le, change _ ⊆ (U : set X.carrier), rw e,
      convert @set.subset_Union₂ _ _ _ (λ (U : X.affine_opens) (h : U ∈ s), ↑U) V V.prop using 1,
      refl },
    erw ← X.to_LocallyRingedSpace.to_RingedSpace.basic_open_res this.op,
    exact is_affine_open.basic_open_is_affine V.1.prop _ },
  haveI : finite s := hs.to_subtype,
  refine ⟨set.range g, set.finite_range g, _⟩,
  refine (set.inter_eq_right_iff_subset.mpr (RingedSpace.basic_open_le _ _)).symm.trans _,
  rw [e, set.Union₂_inter],
  apply le_antisymm; apply set.Union₂_subset,
  { intros i hi,
    refine set.subset.trans _ (set.subset_Union₂ _ (set.mem_range_self ⟨i, hi⟩)),
    exact set.subset.rfl },
  { rintro ⟨i, hi⟩ ⟨⟨j, hj⟩, hj'⟩,
    rw ← hj',
    refine set.subset.trans _ (set.subset_Union₂ j hj),
    exact set.subset.rfl }
end

lemma quasi_compact.affine_property_is_local :
  (quasi_compact.affine_property : _).is_local :=
begin
  split,
  { apply affine_target_morphism_property.respects_iso_mk; rintros X Y Z _ _ _ H,
    exacts [@@homeomorph.compact_space _ _ H (Top.homeo_of_iso (as_iso e.inv.1.base)), H] },
  { introv H,
    delta quasi_compact.affine_property at H ⊢,
    change compact_space ((opens.map f.val.base).obj (Y.basic_open r)),
    rw Scheme.preimage_basic_open f r,
    erw ← is_compact_iff_compact_space,
    rw ← is_compact_univ_iff at H,
    exact is_compact_basic_open X H _ },
  { rintros X Y H f S hS hS',
    resetI,
    rw ← is_affine_open.basic_open_union_eq_self_iff at hS,
    delta quasi_compact.affine_property,
    rw ← is_compact_univ_iff,
    change is_compact ((opens.map f.val.base).obj ⊤).1,
    rw ← hS,
    dsimp [opens.map],
    simp only [opens.coe_supr, set.preimage_Union, subtype.val_eq_coe],
    exacts [is_compact_Union (λ i, is_compact_iff_compact_space.mpr (hS' i)),
      top_is_affine_open _] }
end

lemma quasi_compact.affine_open_cover_tfae {X Y : Scheme.{u}} (f : X ⟶ Y) :
  tfae [quasi_compact f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)],
      ∀ (i : 𝒰.J), compact_space (pullback f (𝒰.map i)).carrier,
    ∀ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)] (i : 𝒰.J),
      compact_space (pullback f (𝒰.map i)).carrier,
    ∀ {U : Scheme} (g : U ⟶ Y) [is_affine U] [is_open_immersion g],
      compact_space (pullback f g).carrier,
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤) (hU' : ∀ i, is_affine_open (U i)),
      ∀ i, compact_space (f.1.base ⁻¹' (U i).1)] :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.affine_open_cover_tfae f

lemma quasi_compact.is_local_at_target :
  property_is_local_at_target @quasi_compact :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.target_affine_locally_is_local

lemma quasi_compact.open_cover_tfae {X Y : Scheme.{u}} (f : X ⟶ Y) :
  tfae [quasi_compact f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y), ∀ (i : 𝒰.J),
      quasi_compact (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (𝒰 : Scheme.open_cover.{u} Y) (i : 𝒰.J),
      quasi_compact (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (U : opens Y.carrier), quasi_compact (f ∣_ U),
    ∀ {U : Scheme} (g : U ⟶ Y) [is_open_immersion g],
      quasi_compact (pullback.snd : pullback f g ⟶ _),
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤), ∀ i, quasi_compact (f ∣_ (U i))] :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.target_affine_locally_is_local.open_cover_tfae f

lemma quasi_compact_over_affine_iff {X Y : Scheme} (f : X ⟶ Y) [is_affine Y] :
  quasi_compact f ↔ compact_space X.carrier :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.affine_target_iff f

lemma compact_space_iff_quasi_compact (X : Scheme) :
  compact_space X.carrier ↔ quasi_compact (terminal.from X) :=
(quasi_compact_over_affine_iff _).symm

lemma quasi_compact.affine_open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y)
  [∀ i, is_affine (𝒰.obj i)] (f : X ⟶ Y) :
  quasi_compact f ↔ ∀ i, compact_space (pullback f (𝒰.map i)).carrier :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.affine_open_cover_iff f 𝒰

lemma quasi_compact.open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y) (f : X ⟶ Y) :
  quasi_compact f ↔ ∀ i, quasi_compact (pullback.snd : pullback f (𝒰.map i) ⟶ _) :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.target_affine_locally_is_local.open_cover_iff f 𝒰

lemma quasi_compact_respects_iso : morphism_property.respects_iso @quasi_compact :=
quasi_compact_eq_affine_property.symm ▸
  target_affine_locally_respects_iso quasi_compact.affine_property_is_local.1

lemma quasi_compact_stable_under_composition :
  morphism_property.stable_under_composition @quasi_compact :=
λ _ _ _ _ _ _ _, by exactI infer_instance

local attribute [-simp] PresheafedSpace.as_coe SheafedSpace.as_coe

lemma quasi_compact.affine_property_stable_under_base_change :
  quasi_compact.affine_property.stable_under_base_change :=
begin
  intros X Y S _ _ f g h,
  rw quasi_compact.affine_property at h ⊢,
  resetI,
  let 𝒰 := Scheme.pullback.open_cover_of_right Y.affine_cover.finite_subcover f g,
  haveI : finite 𝒰.J,
  { dsimp [𝒰], apply_instance },
  haveI : ∀ i, compact_space (𝒰.obj i).carrier,
  { intro i, dsimp, apply_instance },
  exact 𝒰.compact_space,
end

lemma quasi_compact_stable_under_base_change :
  morphism_property.stable_under_base_change @quasi_compact :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.stable_under_base_change
    quasi_compact.affine_property_stable_under_base_change

variables {Z : Scheme.{u}}

instance (f : X ⟶ Z) (g : Y ⟶ Z) [quasi_compact g] :
  quasi_compact (pullback.fst : pullback f g ⟶ X) :=
quasi_compact_stable_under_base_change.fst f g infer_instance

instance (f : X ⟶ Z) (g : Y ⟶ Z) [quasi_compact f] :
  quasi_compact (pullback.snd : pullback f g ⟶ Y) :=
quasi_compact_stable_under_base_change.snd f g infer_instance

@[elab_as_eliminator]
lemma compact_open_induction_on {P : opens X.carrier → Prop} (S : opens X.carrier)
  (hS : is_compact S.1)
  (h₁ : P ⊥)
  (h₂ : ∀ (S : opens X.carrier) (hS : is_compact S.1) (U : X.affine_opens), P S → P (S ⊔ U)) :
    P S :=
begin
  classical,
  obtain ⟨s, hs, hs'⟩ := (is_compact_open_iff_eq_finset_affine_union S.1).mp ⟨hS, S.2⟩,
  replace hs' : S = supr (λ i : s, (i : opens X.carrier)) := by { ext1, simpa using hs' },
  subst hs',
  apply hs.induction_on,
  { convert h₁, rw supr_eq_bot, rintro ⟨_, h⟩, exact h.elim },
  { intros x s h₃ hs h₄,
    have : is_compact (⨆ i : s, (i : opens X.carrier)).1,
    { refine ((is_compact_open_iff_eq_finset_affine_union _).mpr _).1, exact ⟨s, hs, by simp⟩ },
    convert h₂ _ this x h₄,
    simp only [coe_coe],
    rw [supr_subtype, sup_comm],
    conv_rhs { rw supr_subtype },
    exact supr_insert }
end

lemma exists_pow_mul_eq_zero_of_res_basic_open_eq_zero_of_is_affine_open (X : Scheme)
  {U : opens X.carrier} (hU : is_affine_open U) (x f : X.presheaf.obj (op U))
  (H : x |_ X.basic_open f = 0) :
  ∃ n : ℕ, f ^ n * x = 0 :=
begin
  rw ← map_zero (X.presheaf.map (hom_of_le $ X.basic_open_le f : X.basic_open f ⟶ U).op) at H,
  have := (is_localization_basic_open hU f).3,
  obtain ⟨⟨_, n, rfl⟩, e⟩ := this.mp H,
  exact ⟨n, by simpa [mul_comm x] using e⟩,
end

/-- If `x : Γ(X, U)` is zero on `D(f)` for some `f : Γ(X, U)`, and `U` is quasi-compact, then
`f ^ n * x = 0` for some `n`. -/
lemma exists_pow_mul_eq_zero_of_res_basic_open_eq_zero_of_is_compact (X : Scheme)
  {U : opens X.carrier} (hU : is_compact U.1) (x f : X.presheaf.obj (op U))
  (H : x |_ X.basic_open f = 0) :
  ∃ n : ℕ, f ^ n * x = 0 :=
begin
  obtain ⟨s, hs, e⟩ := (is_compact_open_iff_eq_finset_affine_union U.1).mp ⟨hU, U.2⟩,
  replace e : U = supr (λ i : s, (i : opens X.carrier)),
  { ext1, simpa using e },
  have h₁ : ∀ i : s, i.1.1 ≤ U,
  { intro i, change (i : opens X.carrier) ≤ U, rw e, exact le_supr _ _ },
  have H' := λ (i : s), exists_pow_mul_eq_zero_of_res_basic_open_eq_zero_of_is_affine_open X i.1.2
    (X.presheaf.map (hom_of_le (h₁ i)).op x) (X.presheaf.map (hom_of_le (h₁ i)).op f) _,
  swap,
  { delta Top.presheaf.restrict_open Top.presheaf.restrict at H ⊢,
    convert congr_arg (X.presheaf.map (hom_of_le _).op) H,
    { simp only [← comp_apply, ← functor.map_comp], congr },
    { rw map_zero },
    { rw X.basic_open_res, exact set.inter_subset_right _ _ } },
  choose n hn using H',
  haveI := hs.to_subtype,
  casesI nonempty_fintype s,
  use finset.univ.sup n,
  suffices : ∀ (i : s), X.presheaf.map (hom_of_le (h₁ i)).op (f ^ (finset.univ.sup n) * x) = 0,
  { subst e,
    apply X.sheaf.eq_of_locally_eq (λ (i : s), (i : opens X.carrier)),
    intro i,
    rw map_zero,
    apply this },
  intro i,
  replace hn := congr_arg
    (λ x, X.presheaf.map (hom_of_le (h₁ i)).op (f ^ (finset.univ.sup n - n i)) * x) (hn i),
  dsimp at hn,
  simp only [← map_mul, ← map_pow] at hn,
  rwa [mul_zero, ← mul_assoc, ← pow_add, tsub_add_cancel_of_le] at hn,
  apply finset.le_sup (finset.mem_univ i)
end

end algebraic_geometry


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.category.Lattice

/-!
# The category of distributive lattices

This file defines `DistribLattice`, the category of distributive lattices.

Note that [`DistLat`](https://ncatlab.org/nlab/show/DistLat) in the literature doesn't always
correspond to `DistribLattice` as we don't require bottom or top elements. Instead, this `DistLat`
corresponds to `BoundedDistribLattice`.
-/

universes u

open category_theory

/-- The category of distributive lattices. -/
def DistribLattice := bundled distrib_lattice

namespace DistribLattice

instance : has_coe_to_sort DistribLattice Type* := bundled.has_coe_to_sort
instance (X : DistribLattice) : distrib_lattice X := X.str

/-- Construct a bundled `DistribLattice` from a `distrib_lattice` underlying type and typeclass. -/
def of (α : Type*) [distrib_lattice α] : DistribLattice := bundled.of α

@[simp] lemma coe_of (α : Type*) [distrib_lattice α] : ↥(of α) = α := rfl

instance : inhabited DistribLattice := ⟨of punit⟩

instance : bundled_hom.parent_projection @distrib_lattice.to_lattice := ⟨⟩

attribute [derive [large_category, concrete_category]] DistribLattice

instance has_forget_to_Lattice : has_forget₂ DistribLattice Lattice := bundled_hom.forget₂ _ _

/-- Constructs an equivalence between distributive lattices from an order isomorphism between them.
-/
@[simps] def iso.mk {α β : DistribLattice.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : DistribLattice ⥤ DistribLattice :=
{ obj := λ X, of (order_dual X), map := λ X Y, lattice_hom.dual }

/-- The equivalence between `DistribLattice` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : DistribLattice ≌ DistribLattice :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end DistribLattice

lemma DistribLattice_dual_comp_forget_to_Lattice :
  DistribLattice.dual ⋙ forget₂ DistribLattice Lattice =
    forget₂ DistribLattice Lattice ⋙ Lattice.dual := rfl


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

! This file was ported from Lean 3 source module data.hash_map
! leanprover-community/mathlib commit 4fcbc82dc2257986c03e113f87bc5ce021243a44
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Array.Lemmas
import Mathbin.Data.List.Join
import Mathbin.Data.List.Range
import Mathbin.Data.Pnat.Defs

/-!
# Hash maps

Defines a hash map data structure, representing a finite key-value map
with a value type that may depend on the key type.  The structure
requires a `nat`-valued hash function to associate keys to buckets.

## Main definitions

* `hash_map`: constructed with `mk_hash_map`.

## Implementation details

A hash map with key type `α` and (dependent) value type `β : α → Type*`
consists of an array of *buckets*, which are lists containing
key/value pairs for that bucket.  The hash function is taken modulo `n`
to assign keys to their respective bucket.  Because of this, some care
should be put into the hash function to ensure it evenly distributes
keys.

The bucket array is an `array`.  These have special VM support for
in-place modification if there is only ever one reference to them.  If
one takes special care to never keep references to old versions of a
hash map alive after updating it, then the hash map will be modified
in-place.  In this documentation, when we say a hash map is modified
in-place, we are assuming the API is being used in this manner.

When inserting (`hash_map.insert`), if the number of stored pairs (the
*size*) is going to exceed the number of buckets, then a new hash map
is first created with double the number of buckets and everything in
the old hash map is reinserted along with the new key/value pair.
Otherwise, the bucket array is modified in-place.  The amortized
running time of inserting $$n$$ elements into a hash map is $$O(n)$$.

When removing (`hash_map.erase`), the hash map is modified in-place.
The implementation does not reduce the number of buckets in the hash
map if the size gets too low.

## Tags

hash map

-/

universe u v w

/-- `bucket_array α β` is the underlying data type for `hash_map α β`,
  an array of linked lists of key-value pairs. -/
def BucketArray (α : Type u) (β : α → Type v) (n : ℕ+) :=
  Array' n (List (Σa, β a))
#align bucket_array BucketArray

/-- Make a hash_map index from a `nat` hash value and a (positive) buffer size -/
def HashMap.mkIdx (n : ℕ+) (i : Nat) : Fin n :=
  ⟨i % n, Nat.mod_lt _ n.2⟩
#align hash_map.mk_idx HashMap.mkIdx

namespace BucketArray

section

parameter {α : Type u}{β : α → Type v}(hash_fn : α → Nat)

variable {n : ℕ+} (data : BucketArray α β n)

instance : Inhabited (BucketArray α β n) :=
  ⟨mkArray' _ []⟩

/-- Read the bucket corresponding to an element -/
def read (a : α) : List (Σa, β a) :=
  let bidx := HashMap.mkIdx n (hash_fn a)
  data.read bidx
#align bucket_array.read BucketArray.read

/-- Write the bucket corresponding to an element -/
def write (a : α) (l : List (Σa, β a)) : BucketArray α β n :=
  let bidx := HashMap.mkIdx n (hash_fn a)
  data.write bidx l
#align bucket_array.write BucketArray.write

/-- Modify (read, apply `f`, and write) the bucket corresponding to an element -/
def modify (a : α) (f : List (Σa, β a) → List (Σa, β a)) : BucketArray α β n :=
  let bidx := HashMap.mkIdx n (hash_fn a)
  Array'.write data bidx (f (Array'.read data bidx))
#align bucket_array.modify BucketArray.modify

/-- The list of all key-value pairs in the bucket list -/
def asList : List (Σa, β a) :=
  data.toList.join
#align bucket_array.as_list BucketArray.asList

theorem mem_asList {a : Σa, β a} : a ∈ data.asList ↔ ∃ i, a ∈ Array'.read data i :=
  by
  have :
    (∃ (l : List (Σa : α, β a))(i : Fin n.val), a ∈ l ∧ Array'.read data i = l) ↔
      ∃ i : Fin n.val, a ∈ Array'.read data i :=
    by rw [exists_swap] <;> exact exists_congr fun i => by simp
  simp [as_list] <;> simpa [Array'.Mem.def, and_comm']
#align bucket_array.mem_as_list BucketArray.mem_asList

/-- Fold a function `f` over the key-value pairs in the bucket list -/
def foldl {δ : Type w} (d : δ) (f : δ → ∀ a, β a → δ) : δ :=
  data.foldl d fun b d => b.foldl (fun r a => f r a.1 a.2) d
#align bucket_array.foldl BucketArray.foldl

theorem foldl_eq {δ : Type w} (d : δ) (f : δ → ∀ a, β a → δ) :
    data.foldl d f = data.asList.foldl (fun r a => f r a.1 a.2) d := by
  rw [foldl, as_list, List.foldl_join, ← Array'.toList_foldl]
#align bucket_array.foldl_eq BucketArray.foldl_eq

end

end BucketArray

namespace HashMap

section

parameter {α : Type u}{β : α → Type v}(hash_fn : α → Nat)

/-- Insert the pair `⟨a, b⟩` into the correct location in the bucket array
  (without checking for duplication) -/
def reinsertAux {n} (data : BucketArray α β n) (a : α) (b : β a) : BucketArray α β n :=
  data.modify hash_fn a fun l => ⟨a, b⟩ :: l
#align hash_map.reinsert_aux HashMap.reinsertAux

theorem mk_asList (n : ℕ+) : BucketArray.asList (mkArray' n [] : BucketArray α β n) = [] :=
  List.eq_nil_iff_forall_not_mem.mpr fun x m =>
    let ⟨i, h⟩ := (BucketArray.mem_asList _).1 m
    h
#align hash_map.mk_as_list HashMap.mk_asList

parameter [DecidableEq α]

/-- Search a bucket for a key `a` and return the value -/
def findAux (a : α) : List (Σa, β a) → Option (β a)
  | [] => none
  | ⟨a', b⟩ :: t => if h : a' = a then some (Eq.recOn h b) else find_aux t
#align hash_map.find_aux HashMap.findAux

theorem findAux_iff {a : α} {b : β a} :
    ∀ {l : List (Σa, β a)}, (l.map Sigma.fst).Nodup → (find_aux a l = some b ↔ Sigma.mk a b ∈ l)
  | [], nd => ⟨fun n => by injection n, False.elim⟩
  | ⟨a', b'⟩ :: t, nd => by
    by_cases a' = a
    · clear find_aux_iff
      subst h
      suffices b' = b ↔ b' = b ∨ Sigma.mk a' b ∈ t by simpa [find_aux, eq_comm]
      refine' (or_iff_left_of_imp fun m => _).symm
      have : a' ∉ t.map Sigma.fst := nd.not_mem
      exact this.elim (List.mem_map_of_mem Sigma.fst m)
    · have : Sigma.mk a b ≠ ⟨a', b'⟩ := by
        intro e
        injection e with e
        exact h e.symm
      simp at nd
      simp [find_aux, h, Ne.symm h, find_aux_iff, nd]
#align hash_map.find_aux_iff HashMap.findAux_iff

/-- Returns `tt` if the bucket `l` contains the key `a` -/
def containsAux (a : α) (l : List (Σa, β a)) : Bool :=
  (find_aux a l).isSome
#align hash_map.contains_aux HashMap.containsAux

theorem containsAux_iff {a : α} {l : List (Σa, β a)} (nd : (l.map Sigma.fst).Nodup) :
    contains_aux a l ↔ a ∈ l.map Sigma.fst :=
  by
  unfold contains_aux
  cases' h : find_aux a l with b <;> simp
  · intro (b : β a)(m : Sigma.mk a b ∈ l)
    rw [(find_aux_iff nd).2 m] at h
    contradiction
  · show ∃ b : β a, Sigma.mk a b ∈ l
    exact ⟨_, (find_aux_iff nd).1 h⟩
#align hash_map.contains_aux_iff HashMap.containsAux_iff

/-- Modify a bucket to replace a value in the list. Leaves the list
 unchanged if the key is not found. -/
def replaceAux (a : α) (b : β a) : List (Σa, β a) → List (Σa, β a)
  | [] => []
  | ⟨a', b'⟩ :: t => if a' = a then ⟨a, b⟩ :: t else ⟨a', b'⟩ :: replace_aux t
#align hash_map.replace_aux HashMap.replaceAux

/-- Modify a bucket to remove a key, if it exists. -/
def eraseAux (a : α) : List (Σa, β a) → List (Σa, β a)
  | [] => []
  | ⟨a', b'⟩ :: t => if a' = a then t else ⟨a', b'⟩ :: erase_aux t
#align hash_map.erase_aux HashMap.eraseAux

/-- The predicate `valid bkts sz` means that `bkts` satisfies the `hash_map`
  invariants: There are exactly `sz` elements in it, every pair is in the
  bucket determined by its key and the hash function, and no key appears
  multiple times in the list. -/
structure Valid {n} (bkts : BucketArray α β n) (sz : Nat) : Prop where
  len : bkts.asList.length = sz
  idx : ∀ {i} {a : Σa, β a}, a ∈ Array'.read bkts i → mkIdx n (hash_fn a.1) = i
  Nodup : ∀ i, ((Array'.read bkts i).map Sigma.fst).Nodup
#align hash_map.valid HashMap.Valid

theorem Valid.idx_enum {n} {bkts : BucketArray α β n} {sz : Nat} (v : valid bkts sz) {i l}
    (he : (i, l) ∈ bkts.toList.enum) {a} {b : β a} (hl : Sigma.mk a b ∈ l) :
    ∃ h, mkIdx n (hash_fn a) = ⟨i, h⟩ :=
  (Array'.mem_toList_enum.mp he).imp fun h e => by subst e <;> exact v.idx hl
#align hash_map.valid.idx_enum HashMap.Valid.idx_enum

theorem Valid.idx_enum_1 {n} {bkts : BucketArray α β n} {sz : Nat} (v : valid bkts sz) {i l}
    (he : (i, l) ∈ bkts.toList.enum) {a} {b : β a} (hl : Sigma.mk a b ∈ l) :
    (mkIdx n (hash_fn a)).1 = i :=
  by
  let ⟨h, e⟩ := v.idx_enum _ he hl
  rw [e] <;> rfl
#align hash_map.valid.idx_enum_1 HashMap.Valid.idx_enum_1

theorem Valid.asList_nodup {n} {bkts : BucketArray α β n} {sz : Nat} (v : valid bkts sz) :
    (bkts.asList.map Sigma.fst).Nodup :=
  by
  suffices (bkts.to_list.map (List.map Sigma.fst)).Pairwise List.Disjoint
    by
    suffices ∀ l, Array'.Mem l bkts → (l.map Sigma.fst).Nodup by
      simpa [BucketArray.asList, List.nodup_join, *]
    rintro l ⟨i, rfl⟩
    apply v.nodup
  rw [← List.enum_map_snd bkts.to_list, List.pairwise_map', List.pairwise_map']
  have : (bkts.to_list.enum.map Prod.fst).Nodup := by simp [List.nodup_range]
  refine' List.Pairwise.imp_of_mem _ ((List.pairwise_map' _).1 this)
  rw [Prod.forall]
  intro i l₁
  rw [Prod.forall]
  intro j l₂ me₁ me₂ ij
  simp [List.Disjoint]
  intro a b ml₁ b' ml₂
  apply ij
  rwa [← v.idx_enum_1 _ me₁ ml₁, ← v.idx_enum_1 _ me₂ ml₂]
#align hash_map.valid.as_list_nodup HashMap.Valid.asList_nodup

theorem mk_valid (n : ℕ+) : @valid n (mkArray' n []) 0 :=
  ⟨by simp [mk_as_list], fun i a h => by cases h, fun i => List.nodup_nil⟩
#align hash_map.mk_valid HashMap.mk_valid

theorem Valid.findAux_iff {n} {bkts : BucketArray α β n} {sz : Nat} (v : valid bkts sz) {a : α}
    {b : β a} : find_aux a (bkts.read hash_fn a) = some b ↔ Sigma.mk a b ∈ bkts.asList :=
  (find_aux_iff (v.Nodup _)).trans <| by
    rw [bkts.mem_as_list] <;> exact ⟨fun h => ⟨_, h⟩, fun ⟨i, h⟩ => (v.idx h).symm ▸ h⟩
#align hash_map.valid.find_aux_iff HashMap.Valid.findAux_iff

theorem Valid.containsAux_iff {n} {bkts : BucketArray α β n} {sz : Nat} (v : valid bkts sz)
    (a : α) : contains_aux a (bkts.read hash_fn a) ↔ a ∈ bkts.asList.map Sigma.fst := by
  simp [contains_aux, Option.isSome_iff_exists, v.find_aux_iff hash_fn]
#align hash_map.valid.contains_aux_iff HashMap.Valid.containsAux_iff

section

parameter
  {n :
    ℕ+}{bkts :
    BucketArray α β
      n}{bidx : Fin n}{f : List (Σa, β a) → List (Σa, β a)}(u v1 v2 w : List (Σa, β a))

-- mathport name: exprL
local notation "L" => Array'.read bkts bidx

private def bkts' : BucketArray α β n :=
  Array'.write bkts bidx (f L)
#align hash_map.bkts' hash_map.bkts'

variable (hl : L = u ++ v1 ++ w) (hfl : f L = u ++ v2 ++ w)

include hl hfl

theorem append_of_modify : ∃ u' w', bkts.asList = u' ++ v1 ++ w' ∧ bkts'.asList = u' ++ v2 ++ w' :=
  by
  unfold BucketArray.asList
  have h : (bidx : ℕ) < bkts.to_list.length := by simp only [bidx.is_lt, Array'.toList_length]
  refine' ⟨(bkts.to_list.take bidx).join ++ u, w ++ (bkts.to_list.drop (bidx + 1)).join, _, _⟩
  · conv =>
      lhs
      rw [← List.take_append_drop bidx bkts.to_list, List.drop_eq_get_cons h]
      simp [hl]
    simp
  · conv =>
      lhs
      rw [bkts', Array'.write_toList, List.set_eq_take_cons_drop _ h]
      simp [hfl]
    simp
#align hash_map.append_of_modify HashMap.append_of_modify

variable (hvnd : (v2.map Sigma.fst).Nodup)
  (hal : ∀ a : Σa, β a, a ∈ v2 → mkIdx n (hash_fn a.1) = bidx)
  (djuv : (u.map Sigma.fst).Disjoint (v2.map Sigma.fst))
  (djwv : (w.map Sigma.fst).Disjoint (v2.map Sigma.fst))

include hvnd hal djuv djwv

theorem Valid.modify {sz : ℕ} (v : valid bkts sz) :
    v1.length ≤ sz + v2.length ∧ valid bkts' (sz + v2.length - v1.length) :=
  by
  rcases append_of_modify u v1 v2 w hl hfl with ⟨u', w', e₁, e₂⟩
  rw [← v.len, e₁]
  suffices valid bkts' (u' ++ v2 ++ w').length by
    simpa [GE.ge, add_comm, add_left_comm, Nat.le_add_right, add_tsub_cancel_left]
  refine' ⟨congr_arg _ e₂, fun i a => _, fun i => _⟩
  · by_cases bidx = i
    · subst i
      rw [bkts', Array'.read_write, hfl]
      have := @valid.idx _ _ _ v bidx a
      simp only [hl, List.mem_append, or_imp] at this⊢
      exact ⟨⟨this.1.1, hal _⟩, this.2⟩
    · rw [bkts', Array'.read_write_of_ne _ _ h]
      apply v.idx
  · by_cases bidx = i
    · subst i
      rw [bkts', Array'.read_write, hfl]
      have := @valid.nodup _ _ _ v bidx
      simp [hl, List.nodup_append] at this
      simp [List.nodup_append, this, hvnd, djuv, djwv.symm]
    · rw [bkts', Array'.read_write_of_ne _ _ h]
      apply v.nodup
#align hash_map.valid.modify HashMap.Valid.modify

end

theorem Valid.replaceAux (a : α) (b : β a) :
    ∀ l : List (Σa, β a),
      a ∈ l.map Sigma.fst →
        ∃ (u w : List (Σa, β a))(b' : _),
          l = u ++ [⟨a, b'⟩] ++ w ∧ replace_aux a b l = u ++ [⟨a, b⟩] ++ w
  | [] => False.elim
  | ⟨a', b'⟩ :: t => by
    by_cases e : a' = a
    · subst a'
      suffices
        ∃ (u w : List (Σa, β a))(b'' : β a),
          Sigma.mk a b' :: t = u ++ ⟨a, b''⟩ :: w ∧
            replace_aux a b (⟨a, b'⟩ :: t) = u ++ ⟨a, b⟩ :: w
        by simpa
      refine' ⟨[], t, b', _⟩
      simp [replace_aux]
    · suffices
        ∀ (x : β a) (_ : Sigma.mk a x ∈ t),
          ∃ (u w : _)(b'' : β a),
            Sigma.mk a' b' :: t = u ++ ⟨a, b''⟩ :: w ∧
              Sigma.mk a' b' :: replace_aux a b t = u ++ ⟨a, b⟩ :: w
        by simpa [replace_aux, Ne.symm e, e]
      intro x m
      have IH :
        ∀ (x : β a) (_ : Sigma.mk a x ∈ t),
          ∃ (u w : _)(b'' : β a), t = u ++ ⟨a, b''⟩ :: w ∧ replace_aux a b t = u ++ ⟨a, b⟩ :: w :=
        by simpa using valid.replace_aux t
      rcases IH x m with ⟨u, w, b'', hl, hfl⟩
      exact ⟨⟨a', b'⟩ :: u, w, b'', by simp [hl, hfl.symm, Ne.symm e]⟩
#align hash_map.valid.replace_aux HashMap.Valid.replaceAux

theorem Valid.replace {n : ℕ+} {bkts : BucketArray α β n} {sz : ℕ} (a : α) (b : β a)
    (Hc : contains_aux a (bkts.read hash_fn a)) (v : valid bkts sz) :
    valid (bkts.modify hash_fn a (replace_aux a b)) sz :=
  by
  have nd := v.nodup (mk_idx n (hash_fn a))
  rcases HashMap.Valid.replaceAux a b (Array'.read bkts (mk_idx n (hash_fn a)))
      ((contains_aux_iff nd).1 Hc) with
    ⟨u, w, b', hl, hfl⟩
  simp [hl, List.nodup_append] at nd
  refine'
      (v.modify hash_fn u [⟨a, b'⟩] [⟨a, b⟩] w hl hfl (List.nodup_singleton _)
          (fun a' e => by simp at e <;> rw [e]) (fun a' e1 e2 => _) fun a' e1 e2 => _).2 <;>
    · revert e1
      simp [-Sigma.exists] at e2
      subst a'
      simp [nd]
#align hash_map.valid.replace HashMap.Valid.replace

theorem Valid.insert {n : ℕ+} {bkts : BucketArray α β n} {sz : ℕ} (a : α) (b : β a)
    (Hnc : ¬contains_aux a (bkts.read hash_fn a)) (v : valid bkts sz) :
    valid (reinsert_aux bkts a b) (sz + 1) :=
  by
  have nd := v.nodup (mk_idx n (hash_fn a))
  refine'
    (v.modify hash_fn [] [] [⟨a, b⟩] (bkts.read hash_fn a) rfl rfl (List.nodup_singleton _)
        (fun a' e => by simp at e <;> rw [e]) (fun a' => False.elim) fun a' e1 e2 => _).2
  simp [-Sigma.exists] at e2; subst a'
  exact Hnc ((contains_aux_iff nd).2 e1)
#align hash_map.valid.insert HashMap.Valid.insert

theorem Valid.eraseAux (a : α) :
    ∀ l : List (Σa, β a),
      a ∈ l.map Sigma.fst →
        ∃ (u w : List (Σa, β a))(b : _), l = u ++ [⟨a, b⟩] ++ w ∧ erase_aux a l = u ++ [] ++ w
  | [] => False.elim
  | ⟨a', b'⟩ :: t => by
    by_cases e : a' = a
    · subst a'
      simpa [erase_aux, and_comm'] using
        show ∃ (u w : _)(x : β a), t = u ++ w ∧ Sigma.mk a b' :: t = u ++ ⟨a, x⟩ :: w from
          ⟨[], t, b', by simp⟩
    · simp [erase_aux, e, Ne.symm e]
      suffices
        ∀ (b : β a) (_ : Sigma.mk a b ∈ t),
          ∃ (u w : _)(x : β a),
            Sigma.mk a' b' :: t = u ++ ⟨a, x⟩ :: w ∧ Sigma.mk a' b' :: erase_aux a t = u ++ w
        by simpa [replace_aux, Ne.symm e, e]
      intro b m
      have IH :
        ∀ (x : β a) (_ : Sigma.mk a x ∈ t),
          ∃ (u w : _)(x : β a), t = u ++ ⟨a, x⟩ :: w ∧ erase_aux a t = u ++ w :=
        by simpa using valid.erase_aux t
      rcases IH b m with ⟨u, w, b'', hl, hfl⟩
      exact ⟨⟨a', b'⟩ :: u, w, b'', by simp [hl, hfl.symm]⟩
#align hash_map.valid.erase_aux HashMap.Valid.eraseAux

theorem Valid.erase {n} {bkts : BucketArray α β n} {sz} (a : α)
    (Hc : contains_aux a (bkts.read hash_fn a)) (v : valid bkts sz) :
    valid (bkts.modify hash_fn a (erase_aux a)) (sz - 1) :=
  by
  have nd := v.nodup (mk_idx n (hash_fn a))
  rcases HashMap.Valid.eraseAux a (Array'.read bkts (mk_idx n (hash_fn a)))
      ((contains_aux_iff nd).1 Hc) with
    ⟨u, w, b, hl, hfl⟩
  refine' (v.modify hash_fn u [⟨a, b⟩] [] w hl hfl List.nodup_nil _ _ _).2 <;> simp
#align hash_map.valid.erase HashMap.Valid.erase

end

end HashMap

/-- A hash map data structure, representing a finite key-value map
  with key type `α` and value type `β` (which may depend on `α`). -/
structure HashMap (α : Type u) [DecidableEq α] (β : α → Type v) where
  hashFn : α → Nat
  size : ℕ
  nbuckets : ℕ+
  buckets : BucketArray α β nbuckets
  is_valid : HashMap.Valid hash_fn buckets size
#align hash_map HashMap

/-- Construct an empty hash map with buffer size `nbuckets` (default 8). -/
def mkHashMap {α : Type u} [DecidableEq α] {β : α → Type v} (hash_fn : α → Nat) (nbuckets := 8) :
    HashMap α β :=
  let n := if nbuckets = 0 then 8 else nbuckets
  let nz : n > 0 := by abstract cases nbuckets <;> simp [if_pos, Nat.succ_ne_zero]
  { hashFn
    size := 0
    nbuckets := ⟨n, nz⟩
    buckets := mkArray' n []
    is_valid := HashMap.mk_valid _ _ }
#align mk_hash_map mkHashMap

namespace HashMap

variable {α : Type u} {β : α → Type v} [DecidableEq α]

/-- Return the value corresponding to a key, or `none` if not found -/
def find (m : HashMap α β) (a : α) : Option (β a) :=
  findAux a (m.buckets.read m.hashFn a)
#align hash_map.find HashMap.find

/-- Return `tt` if the key exists in the map -/
def contains (m : HashMap α β) (a : α) : Bool :=
  (m.find a).isSome
#align hash_map.contains HashMap.contains

instance : Membership α (HashMap α β) :=
  ⟨fun a m => m.contains a⟩

/-- Fold a function over the key-value pairs in the map -/
def fold {δ : Type w} (m : HashMap α β) (d : δ) (f : δ → ∀ a, β a → δ) : δ :=
  m.buckets.foldl d f
#align hash_map.fold HashMap.fold

/-- The list of key-value pairs in the map -/
def entries (m : HashMap α β) : List (Σa, β a) :=
  m.buckets.asList
#align hash_map.entries HashMap.entries

/-- The list of keys in the map -/
def keys (m : HashMap α β) : List α :=
  m.entries.map Sigma.fst
#align hash_map.keys HashMap.keys

theorem find_iff (m : HashMap α β) (a : α) (b : β a) :
    m.find a = some b ↔ Sigma.mk a b ∈ m.entries :=
  m.is_valid.findAux_iff _
#align hash_map.find_iff HashMap.find_iff

theorem contains_iff (m : HashMap α β) (a : α) : m.contains a ↔ a ∈ m.keys :=
  m.is_valid.containsAux_iff _ _
#align hash_map.contains_iff HashMap.contains_iff

theorem entries_empty (hash_fn : α → Nat) (n) : (@mkHashMap α _ β hash_fn n).entries = [] :=
  mk_asList _
#align hash_map.entries_empty HashMap.entries_empty

theorem keys_empty (hash_fn : α → Nat) (n) : (@mkHashMap α _ β hash_fn n).keys = [] := by
  dsimp [keys] <;> rw [entries_empty] <;> rfl
#align hash_map.keys_empty HashMap.keys_empty

theorem find_empty (hash_fn : α → Nat) (n a) : (@mkHashMap α _ β hash_fn n).find a = none := by
  induction' h : (@mkHashMap α _ β hash_fn n).find a with <;> [rfl,
    · have := (find_iff _ _ _).1 h
      rw [entries_empty] at this
      contradiction]
#align hash_map.find_empty HashMap.find_empty

theorem not_contains_empty (hash_fn : α → Nat) (n a) : ¬(@mkHashMap α _ β hash_fn n).contains a :=
  by apply Bool.bool_iff_false.2 <;> dsimp [contains] <;> rw [find_empty] <;> rfl
#align hash_map.not_contains_empty HashMap.not_contains_empty

theorem insert_lemma (hash_fn : α → Nat) {n n'} {bkts : BucketArray α β n} {sz}
    (v : Valid hash_fn bkts sz) :
    Valid hash_fn (bkts.foldl (mkArray' _ [] : BucketArray α β n') (reinsertAux hash_fn)) sz :=
  by
  suffices
    ∀ (l : List (Σa, β a)) (t : BucketArray α β n') (sz),
      valid hash_fn t sz →
        ((l ++ t.asList).map Sigma.fst).Nodup →
          valid hash_fn (l.foldl (fun r (a : Σa, β a) => reinsert_aux hash_fn r a.1 a.2) t)
            (sz + l.length)
    by
    have p := this bkts.as_list _ _ (mk_valid _ _)
    rw [mk_as_list, List.append_nil, zero_add, v.len] at p
    rw [BucketArray.foldl_eq]
    exact p (v.as_list_nodup _)
  intro l
  induction' l with c l IH <;> intro t sz v nd
  · exact v
  rw [show sz + (c :: l).length = sz + 1 + l.length by simp [add_comm, add_assoc]]
  rcases show
      (l.map Sigma.fst).Nodup ∧
        ((BucketArray.asList t).map Sigma.fst).Nodup ∧
          c.fst ∉ l.map Sigma.fst ∧
            c.fst ∉ (BucketArray.asList t).map Sigma.fst ∧
              (l.map Sigma.fst).Disjoint ((BucketArray.asList t).map Sigma.fst)
      by simpa [List.nodup_append, not_or, and_comm', and_left_comm] using nd with
    ⟨nd1, nd2, nm1, nm2, dj⟩
  have v' := v.insert _ _ c.2 fun Hc => nm2 <| (v.contains_aux_iff _ c.1).1 Hc
  apply IH _ _ v'
  suffices
    ∀ ⦃a : α⦄ (b : β a),
      Sigma.mk a b ∈ l → ∀ b' : β a, Sigma.mk a b' ∈ (reinsert_aux hash_fn t c.1 c.2).asList → False
    by simpa [List.nodup_append, nd1, v'.as_list_nodup _, List.Disjoint]
  intro a b m1 b' m2
  rcases(reinsert_aux hash_fn t c.1 c.2).mem_asList.1 m2 with ⟨i, im⟩
  have : Sigma.mk a b' ∉ Array'.read t i := by
    intro m3
    have : a ∈ List.map Sigma.fst t.as_list :=
      List.mem_map_of_mem Sigma.fst (t.mem_as_list.2 ⟨_, m3⟩)
    exact dj (List.mem_map_of_mem Sigma.fst m1) this
  by_cases h : mk_idx n' (hash_fn c.1) = i
  · subst h
    have e : Sigma.mk a b' = ⟨c.1, c.2⟩ := by
      simpa [reinsert_aux, BucketArray.modify, Array'.read_write, this] using im
    injection e with e
    subst a
    exact nm1.elim (@List.mem_map_of_mem _ _ Sigma.fst _ _ m1)
  · apply this
    simpa [reinsert_aux, BucketArray.modify, Array'.read_write_of_ne _ _ h] using im
#align hash_map.insert_lemma HashMap.insert_lemma

/-- Insert a key-value pair into the map. (Modifies `m` in-place when applicable) -/
def insert : ∀ (m : HashMap α β) (a : α) (b : β a), HashMap α β
  | ⟨hash_fn, size, n, buckets, v⟩, a, b =>
    let bkt := buckets.read hash_fn a
    if hc : containsAux a bkt then
      { hashFn
        size
        nbuckets := n
        buckets := buckets.modify hash_fn a (replaceAux a b)
        is_valid := v.replace _ a b hc }
    else
      let size' := size + 1
      let buckets' := buckets.modify hash_fn a fun l => ⟨a, b⟩ :: l
      let valid' := v.insert _ a b hc
      if size' ≤ n then
        { hashFn
          size := size'
          nbuckets := n
          buckets := buckets'
          is_valid := valid' }
      else
        let n' : ℕ+ := ⟨n * 2, mul_pos n.2 (by decide)⟩
        let buckets'' : BucketArray α β n' := buckets'.foldl (mkArray' _ []) (reinsertAux hash_fn)
        { hashFn
          size := size'
          nbuckets := n'
          buckets := buckets''
          is_valid := insert_lemma _ valid' }
#align hash_map.insert HashMap.insert

theorem mem_insert :
    ∀ (m : HashMap α β) (a b a' b'),
      (Sigma.mk a' b' : Sigma β) ∈ (m.insert a b).entries ↔
        if a = a' then HEq b b' else Sigma.mk a' b' ∈ m.entries
  | ⟨hash_fn, size, n, bkts, v⟩, a, b, a', b' =>
    by
    let bkt := bkts.read hash_fn a
    have nd : (bkt.map Sigma.fst).Nodup := v.nodup (mk_idx n (hash_fn a))
    have lem :
      ∀ (bkts' : BucketArray α β n) (v1 u w) (hl : BucketArray.asList bkts = u ++ v1 ++ w)
        (hfl : BucketArray.asList bkts' = u ++ [⟨a, b⟩] ++ w)
        (veq : v1 = [] ∧ ¬contains_aux a bkt ∨ ∃ b'', v1 = [⟨a, b''⟩]),
        Sigma.mk a' b' ∈ bkts'.asList ↔
          if a = a' then HEq b b' else Sigma.mk a' b' ∈ bkts.as_list :=
      by
      intro bkts' v1 u w hl hfl veq
      rw [hl, hfl]
      by_cases h : a = a'
      · subst a'
        suffices b = b' ∨ Sigma.mk a b' ∈ u ∨ Sigma.mk a b' ∈ w ↔ b = b' by
          simpa [eq_comm, or_left_comm]
        refine' or_iff_left_of_imp (Not.elim <| not_or.2 _)
        rcases veq with (⟨rfl, Hnc⟩ | ⟨b'', rfl⟩)
        · have na := (not_congr <| v.contains_aux_iff _ _).1 Hnc
          simp [hl, not_or] at na
          simp [na]
        · have nd' := v.as_list_nodup _
          simp [hl, List.nodup_append] at nd'
          simp [nd']
      · suffices Sigma.mk a' b' ∉ v1 by simp [h, Ne.symm h, this]
        rcases veq with (⟨rfl, Hnc⟩ | ⟨b'', rfl⟩) <;> simp [Ne.symm h]
    by_cases Hc : (contains_aux a bkt : Prop)
    · rcases HashMap.Valid.replaceAux a b (Array'.read bkts (mk_idx n (hash_fn a)))
          ((contains_aux_iff nd).1 Hc) with ⟨u', w', b'', hl', hfl'⟩
      rcases append_of_modify u' [⟨a, b''⟩] [⟨a, b⟩] w' hl' hfl' with ⟨u, w, hl, hfl⟩
      simpa [insert, @dif_pos (contains_aux a bkt) _ Hc] using
        lem _ _ u w hl hfl (Or.inr ⟨b'', rfl⟩)
    · let size' := size + 1
      let bkts' := bkts.modify hash_fn a fun l => ⟨a, b⟩ :: l
      have mi :
        Sigma.mk a' b' ∈ bkts'.as_list ↔
          if a = a' then HEq b b' else Sigma.mk a' b' ∈ bkts.as_list :=
        let ⟨u, w, hl, hfl⟩ := append_of_modify [] [] [⟨a, b⟩] _ rfl rfl
        lem bkts' _ u w hl hfl <| Or.inl ⟨rfl, Hc⟩
      simp [insert, @dif_neg (contains_aux a bkt) _ Hc]
      by_cases h : size' ≤ n
      · simpa [show size' ≤ n from h] using mi
      · let n' : ℕ+ := ⟨n * 2, mul_pos n.2 (by decide)⟩
        let bkts'' : BucketArray α β n' := bkts'.foldl (mkArray' _ []) (reinsert_aux hash_fn)
        suffices Sigma.mk a' b' ∈ bkts''.as_list ↔ Sigma.mk a' b' ∈ bkts'.as_list.reverse by
          simpa [show ¬size' ≤ n from h, mi]
        rw [show bkts'' = bkts'.as_list.foldl _ _ from bkts'.foldl_eq _ _, ← List.foldr_reverse]
        induction' bkts'.as_list.reverse with a l IH
        · simp [mk_as_list]
        · cases' a with a'' b''
          let B :=
            l.foldr (fun (y : Sigma β) (x : BucketArray α β n') => reinsert_aux hash_fn x y.1 y.2)
              (mkArray' n' [])
          rcases append_of_modify [] [] [⟨a'', b''⟩] _ rfl rfl with ⟨u, w, hl, hfl⟩
          simp [IH.symm, or_left_comm, show B.as_list = _ from hl,
            show (reinsert_aux hash_fn B a'' b'').asList = _ from hfl]
#align hash_map.mem_insert HashMap.mem_insert

theorem find_insert_eq (m : HashMap α β) (a : α) (b : β a) : (m.insert a b).find a = some b :=
  (find_iff (m.insert a b) a b).2 <| (mem_insert m a b a b).2 <| by rw [if_pos rfl]
#align hash_map.find_insert_eq HashMap.find_insert_eq

theorem find_insert_ne (m : HashMap α β) (a a' : α) (b : β a) (h : a ≠ a') :
    (m.insert a b).find a' = m.find a' :=
  Option.eq_of_eq_some fun b' =>
    let t := mem_insert m a b a' b'
    (find_iff _ _ _).trans <| Iff.trans (by rwa [if_neg h] at t) (find_iff _ _ _).symm
#align hash_map.find_insert_ne HashMap.find_insert_ne

theorem find_insert (m : HashMap α β) (a' a : α) (b : β a) :
    (m.insert a b).find a' = if h : a = a' then some (Eq.recOn h b) else m.find a' :=
  if h : a = a' then by
    rw [dif_pos h] <;>
      exact
        match a', h with
        | _, rfl => find_insert_eq m a b
  else by rw [dif_neg h] <;> exact find_insert_ne m a a' b h
#align hash_map.find_insert HashMap.find_insert

/-- Insert a list of key-value pairs into the map. (Modifies `m` in-place when applicable) -/
def insertAll (l : List (Σa, β a)) (m : HashMap α β) : HashMap α β :=
  l.foldl (fun m ⟨a, b⟩ => insert m a b) m
#align hash_map.insert_all HashMap.insertAll

/-- Construct a hash map from a list of key-value pairs. -/
def ofList (l : List (Σa, β a)) (hash_fn) : HashMap α β :=
  insertAll l (mkHashMap hash_fn (2 * l.length))
#align hash_map.of_list HashMap.ofList

/-- Remove a key from the map. (Modifies `m` in-place when applicable) -/
def erase (m : HashMap α β) (a : α) : HashMap α β :=
  match m with
  | ⟨hash_fn, size, n, buckets, v⟩ =>
    if hc : containsAux a (buckets.read hash_fn a) then
      { hashFn
        size := size - 1
        nbuckets := n
        buckets := buckets.modify hash_fn a (eraseAux a)
        is_valid := v.eraseₓ _ a hc }
    else m
#align hash_map.erase HashMap.erase

theorem mem_erase :
    ∀ (m : HashMap α β) (a a' b'),
      (Sigma.mk a' b' : Sigma β) ∈ (m.eraseₓ a).entries ↔ a ≠ a' ∧ Sigma.mk a' b' ∈ m.entries
  | ⟨hash_fn, size, n, bkts, v⟩, a, a', b' =>
    by
    let bkt := bkts.read hash_fn a
    by_cases Hc : (contains_aux a bkt : Prop)
    · let bkts' := bkts.modify hash_fn a (erase_aux a)
      suffices Sigma.mk a' b' ∈ bkts'.as_list ↔ a ≠ a' ∧ Sigma.mk a' b' ∈ bkts.as_list by
        simpa [erase, @dif_pos (contains_aux a bkt) _ Hc]
      have nd := v.nodup (mk_idx n (hash_fn a))
      rcases valid.erase_aux a bkt ((contains_aux_iff nd).1 Hc) with ⟨u', w', b, hl', hfl'⟩
      rcases append_of_modify u' [⟨a, b⟩] [] _ hl' hfl' with ⟨u, w, hl, hfl⟩
      suffices ∀ _ : Sigma.mk a' b' ∈ u ∨ Sigma.mk a' b' ∈ w, a ≠ a'
        by
        have :
          Sigma.mk a' b' ∈ u ∨ Sigma.mk a' b' ∈ w ↔
            (¬a = a' ∧ a' = a) ∧ HEq b' b ∨ ¬a = a' ∧ (Sigma.mk a' b' ∈ u ∨ Sigma.mk a' b' ∈ w) :=
          by simp [eq_comm, not_and_self_iff, and_iff_right_of_imp this]
        simpa [hl, show bkts'.as_list = _ from hfl, and_or_left, and_comm', and_left_comm,
          or_left_comm]
      rintro m rfl
      revert m
      apply not_or.2
      have nd' := v.as_list_nodup _
      simp [hl, List.nodup_append] at nd'
      simp [nd']
    · suffices ∀ _ : Sigma.mk a' b' ∈ BucketArray.asList bkts, a ≠ a' by
        simp [erase, @dif_neg (contains_aux a bkt) _ Hc, entries, and_iff_right_of_imp this]
      rintro m rfl
      exact Hc ((v.contains_aux_iff _ _).2 (List.mem_map_of_mem Sigma.fst m))
#align hash_map.mem_erase HashMap.mem_erase

theorem find_erase_eq (m : HashMap α β) (a : α) : (m.eraseₓ a).find a = none :=
  by
  cases' h : (m.erase a).find a with b; · rfl
  exact absurd rfl ((mem_erase m a a b).1 ((find_iff (m.erase a) a b).1 h)).left
#align hash_map.find_erase_eq HashMap.find_erase_eq

theorem find_erase_ne (m : HashMap α β) (a a' : α) (h : a ≠ a') :
    (m.eraseₓ a).find a' = m.find a' :=
  Option.eq_of_eq_some fun b' =>
    (find_iff _ _ _).trans <|
      (mem_erase m a a' b').trans <| (and_iff_right h).trans (find_iff _ _ _).symm
#align hash_map.find_erase_ne HashMap.find_erase_ne

theorem find_erase (m : HashMap α β) (a' a : α) :
    (m.eraseₓ a).find a' = if a = a' then none else m.find a' :=
  if h : a = a' then by subst a' <;> simp [find_erase_eq m a]
  else by rw [if_neg h] <;> exact find_erase_ne m a a' h
#align hash_map.find_erase HashMap.find_erase

section String

variable [ToString α] [∀ a, ToString (β a)]

open Prod

private def key_data_to_string (a : α) (b : β a) (first : Bool) : String :=
  (if first then "" else ", ") ++ s! "{a } ← {b}"
#align hash_map.key_data_to_string hash_map.key_data_to_string

private def to_string (m : HashMap α β) : String :=
  "⟨" ++ fst (fold m ("", true) fun p a b => (fst p ++ keyDataToString a b (snd p), false)) ++ "⟩"
#align hash_map.to_string hash_map.to_string

instance : ToString (HashMap α β) :=
  ⟨toString⟩

end String

section Format

open Format Prod

variable [has_to_format α] [∀ a, has_to_format (β a)]

private unsafe def format_key_data (a : α) (b : β a) (first : Bool) : format :=
  (if first then to_fmt "" else to_fmt "," ++ line) ++ to_fmt a ++ space ++ to_fmt "←" ++ space ++
    to_fmt b
#align hash_map.format_key_data hash_map.format_key_data

private unsafe def to_format (m : HashMap α β) : format :=
  Group <|
    to_fmt "⟨" ++
        nest 1
          (fst
            (fold m (to_fmt "", true) fun p a b =>
              (fst p ++ format_key_data a b (snd p), false))) ++
      to_fmt "⟩"
#align hash_map.to_format hash_map.to_format

unsafe instance : has_to_format (HashMap α β) :=
  ⟨to_format⟩

end Format

/-- `hash_map` with key type `nat` and value type that may vary. -/
instance {β : ℕ → Type _} : Inhabited (HashMap ℕ β) :=
  ⟨mkHashMap id⟩

end HashMap


/-
-- Copyright (c) 2020 Bhavik Mehta. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Bhavik Mehta, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.equalizers
import Mathlib.category_theory.limits.shapes.finite_products
import Mathlib.category_theory.limits.preserves.shapes.products
import Mathlib.category_theory.limits.preserves.shapes.equalizers
import Mathlib.PostPort

universes u v u₂

namespace Mathlib

/-!
# Constructing limits from products and equalizers.

If a category has all products, and all equalizers, then it has all limits.
Similarly, if it has all finite products, and all equalizers, then it has all finite limits.

If a functor preserves all products and equalizers, then it preserves all limits.
Similarly, if it preserves all finite products and equalizers, then it preserves all finite limits.

# TODO

Provide the dual results.
Show the analogous results for functors which reflect or create (co)limits.
-/

namespace category_theory.limits

-- We hide the "implementation details" inside a namespace

namespace has_limit_of_has_products_of_has_equalizers

/--
(Implementation) Given the appropriate product and equalizer cones, build the cone for `F` which is
limiting if the given cones are also.
-/
def build_limit {C : Type u} [category C] {J : Type v} [small_category J] {F : J ⥤ C} {c₁ : fan (functor.obj F)} {c₂ : fan fun (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p) => functor.obj F (prod.snd (sigma.fst f))} (s : cone.X c₁ ⟶ cone.X c₂) (t : cone.X c₁ ⟶ cone.X c₂) (hs : ∀ (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p),
  s ≫ nat_trans.app (cone.π c₂) f = nat_trans.app (cone.π c₁) (prod.fst (sigma.fst f)) ≫ functor.map F (sigma.snd f)) (ht : ∀ (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p),
  t ≫ nat_trans.app (cone.π c₂) f = nat_trans.app (cone.π c₁) (prod.snd (sigma.fst f))) (i : fork s t) : cone F :=
  cone.mk (cone.X i) (nat_trans.mk fun (j : J) => fork.ι i ≫ nat_trans.app (cone.π c₁) j)

/--
(Implementation) Show the cone constructed in `build_limit` is limiting, provided the cones used in
its construction are.
-/
def build_is_limit {C : Type u} [category C] {J : Type v} [small_category J] {F : J ⥤ C} {c₁ : fan (functor.obj F)} {c₂ : fan fun (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p) => functor.obj F (prod.snd (sigma.fst f))} (s : cone.X c₁ ⟶ cone.X c₂) (t : cone.X c₁ ⟶ cone.X c₂) (hs : ∀ (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p),
  s ≫ nat_trans.app (cone.π c₂) f = nat_trans.app (cone.π c₁) (prod.fst (sigma.fst f)) ≫ functor.map F (sigma.snd f)) (ht : ∀ (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p),
  t ≫ nat_trans.app (cone.π c₂) f = nat_trans.app (cone.π c₁) (prod.snd (sigma.fst f))) {i : fork s t} (t₁ : is_limit c₁) (t₂ : is_limit c₂) (hi : is_limit i) : is_limit (build_limit s t hs ht i) :=
  is_limit.mk
    fun (q : cone F) =>
      is_limit.lift hi (fork.of_ι (is_limit.lift t₁ (fan.mk (cone.X q) fun (j : J) => nat_trans.app (cone.π q) j)) sorry)

end has_limit_of_has_products_of_has_equalizers

/--
Given the existence of the appropriate (possibly finite) products and equalizers, we know a limit of
`F` exists.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
theorem has_limit_of_equalizer_and_product {C : Type u} [category C] {J : Type v} [small_category J] (F : J ⥤ C) [has_limit (discrete.functor (functor.obj F))] [has_limit
  (discrete.functor
    fun (f : sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p) => functor.obj F (prod.snd (sigma.fst f)))] [has_equalizers C] : has_limit F := sorry

/--
Any category with products and equalizers has all limits.

See https://stacks.math.columbia.edu/tag/002N.
-/
theorem limits_from_equalizers_and_products {C : Type u} [category C] [has_products C] [has_equalizers C] : has_limits C :=
  has_limits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      has_limits_of_shape.mk fun (F : J ⥤ C) => has_limit_of_equalizer_and_product F

/--
Any category with finite products and equalizers has all finite limits.

See https://stacks.math.columbia.edu/tag/002O.
-/
theorem finite_limits_from_equalizers_and_finite_products {C : Type u} [category C] [has_finite_products C] [has_equalizers C] : has_finite_limits C :=
  fun (J : Type v) (_x : small_category J) (_x_1 : fin_category J) =>
    has_limits_of_shape.mk fun (F : J ⥤ C) => has_limit_of_equalizer_and_product F

/-- If a functor preserves equalizers and the appropriate products, it preserves limits. -/
def preserves_limit_of_preserves_equalizers_and_product {C : Type u} [category C] {J : Type v} [small_category J] {D : Type u₂} [category D] [has_limits_of_shape (discrete J) C] [has_limits_of_shape (discrete (sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p)) C] [has_equalizers C] (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair G] [preserves_limits_of_shape (discrete J) G] [preserves_limits_of_shape (discrete (sigma fun (p : J × J) => prod.fst p ⟶ prod.snd p)) G] : preserves_limits_of_shape J G := sorry

/-- If G preserves equalizers and finite products, it preserves finite limits. -/
def preserves_finite_limits_of_preserves_equalizers_and_finite_products {C : Type u} [category C] {D : Type u₂} [category D] [has_equalizers C] [has_finite_products C] (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair G] [(J : Type v) → [_inst_8 : fintype J] → preserves_limits_of_shape (discrete J) G] (J : Type v) [small_category J] [fin_category J] : preserves_limits_of_shape J G :=
  preserves_limit_of_preserves_equalizers_and_product G

/-- If G preserves equalizers and products, it preserves all limits. -/
def preserves_limits_of_preserves_equalizers_and_products {C : Type u} [category C] {D : Type u₂} [category D] [has_equalizers C] [has_products C] (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair G] [(J : Type v) → preserves_limits_of_shape (discrete J) G] : preserves_limits G :=
  preserves_limits.mk fun (J : Type v) (𝒥 : small_category J) => preserves_limit_of_preserves_equalizers_and_product G


/-
Copyright (c) 2022 James Gallicchio.

Authors: James Gallicchio
-/

import LeanColls.Classes
import LeanColls.Range
import LeanColls.View
import LeanColls.List

namespace LeanColls

namespace IndexedOps

instance [Indexed C τ] : Membership τ C where
  mem x c := ∃ i, x = Indexed.nth c i

instance [Indexed C τ] : Iterable C τ where
  ρ := Σ' (c : C), Iterable'.ρ Nat (Range.mk <| Size.size c)
  toIterator c := ⟨c, Iterable'.toIterator (Range.mk <| Size.size c)⟩
  step := λ ⟨c,r⟩ => Iterable'.step r
                    |>.map (fun (⟨i,h⟩,r) => (Indexed.nth c ⟨i,h⟩, ⟨c,r⟩))

theorem size_pos_iff_mem [Indexed C τ] {c : C}
  : Size.size c > 0 ↔ ∃ x, x ∈ c
  := by
  constructor
  case mp =>
    intro h
    apply Exists.intro (Indexed.nth c ⟨0,h⟩)
    simp [Membership.mem]
    apply Exists.intro ⟨0,h⟩
    rfl
  case mpr =>
    intro h
    cases h; case intro x h =>
    cases h; case intro i _ =>
    exact i.size_positive

instance [Indexed C τ] : Foldable'.Correct C τ inferInstance where
  fold c f init :=
    Foldable'.Correct.fold' (Range.mk <| Size.size c) (λ acc i h =>
      f acc (Indexed.nth c ⟨i,h⟩)
    ) init
  fold' c f init :=
    Foldable'.Correct.fold' (Range.mk <| Size.size c) (λ acc i h =>
      f acc (Indexed.nth c ⟨i,h⟩) ⟨⟨i,h⟩, rfl⟩
    ) init
  foldCorrect := by
    intro β c f acc
    simp [Foldable.fold]
    rw [Foldable'.fold_canonicalToList_fold'_eq_fold']
  memCorrect x c := by
    simp [Foldable.fold, canonicalToList]
    constructor
    case mp =>
      intro h; simp at h; cases h; case intro i h =>
      have := Foldable'.fold'_append_singleton_eq_map
        (⟨Size.size c⟩ : Range)
        (fun i h => Indexed.nth c ⟨i,h⟩)
      simp [Membership.mem] at this ⊢
      simp [this, Foldable.fold]
      rw [List.map'_rw _ (Range.toList_eq_canonicalToList ⟨Size.size c⟩).symm]
      rw [List.map']
      apply (List.mem_of_map_iff _ _ _).mpr
      simp
      cases i; case mk i h_i =>
      have : i ∈ Range.toList ⟨Size.size c⟩ := by
          rw [Range.toList_eq_canonicalToList]
          apply (Range.memCorrect _ _).mp
          assumption
      apply Exists.intro i
      apply Exists.intro this
      simp
      constructor
      case left =>
        simp [List.mem_of_subtypeByMem _ i this]
      case right =>
        exact h.symm
    case mpr =>
      intro h
      rw [Foldable'.Correct.fold'Correct] at h
      rw [List.foldl'_eq_subtypeByMem_foldl] at h
      rw [List.foldl_eq_map] at h
      rw [(List.mem_of_map_iff _ _ _)] at h
      cases h; case intro x h =>
      cases x; case mk i h_i =>
      simp [Membership.mem]
      have h_i' : i < Size.size c := by
        simp [Foldable.fold] at h_i
        rw [←Range.memCorrect] at h_i
        exact h_i
      apply Exists.intro ⟨i, h_i'⟩
      exact h.2.symm
  fold'Correct := by
    intro β c f acc
    simp
    conv => rhs; simp [Foldable'.Correct.fold', Foldable.fold]
    have := Foldable'.canonicalToList_fold'_eq_map'
      (⟨Size.size c⟩ : Range)
      (fun x h => Indexed.nth c ⟨x,h⟩)
    simp [Foldable'.Correct.fold'] at this
    rw [List.foldl'_rw _ _ _ _ this]
    simp [Foldable'.Correct.fold'Correct, List.foldl'_eq_subtypeByMem_foldl]
    sorry

structure Slice (C) (τ : outParam (Type u)) [Indexed C τ] where
  c : C
  off : Nat
  len : Nat
  h_range : off + len ≤ Size.size c

instance [Indexed C τ] : Indexed (Slice C τ) τ where
  size S := S.len
  nth S (i : Fin S.len) := Indexed.nth S.c ⟨S.off + i, Nat.le_trans (Nat.add_lt_add_left i.isLt _) (Slice.h_range S)⟩

def IndexedEq [DecidableEq τ] [Indexed C₁ τ] [Indexed C₂ τ] (c₁ : C₁) (c₂ : C₂)
  {h : Size.size c₁ = Size.size c₂} : Prop :=
  ∀ i, Indexed.nth c₁ i = Indexed.nth c₂ ⟨i.val, by rw [←h]; exact i.isLt⟩

end IndexedOps

class IndexedOps (C) (τ : Type u) [Indexed C τ] where
  slice (c : C) (off len : Nat)
    {h : off + len ≤ Size.size c} : IndexedOps.Slice C τ
  map (c : C) {τ' : Type u} (f : τ → τ') [Initable C' (Size.size c) τ'] : C'
  findi (c : C) (f : τ → Bool) : Option (Fin (Size.size c) × τ)
  findMapi (c : C) {τ' : Type u} (f : τ → Option τ') : Option (Fin (Size.size c) × τ')

namespace IndexedOps

instance [Indexed C τ] : Inhabited (IndexedOps C τ) where
  default := {
    slice := λ c off len h => ⟨c,off,len,h⟩
    map := λ c _ f => Initable.init (fun i => f (Indexed.nth c i))
    findi := λ c f =>
      View.view' (Range.mk (Size.size c))
      |>.map (fun ⟨i,h⟩ => (⟨i,h⟩ : Fin (Size.size c)))
      |> FoldableOps.find (f := fun i => f (Indexed.nth c i))
      |> Option.map (fun i => (i, Indexed.nth c i))
    findMapi := λ c _ f =>
      View.view' (Range.mk (Size.size c))
      |>.map (fun ⟨i,h⟩ => (⟨i,h⟩ : Fin (Size.size c)))
      |> FoldableOps.findMap (f := fun i =>
        f (Indexed.nth c i) |>.map (fun x => (i, x))
        )
  }

instance [Indexed C τ] [Foldable C τ] : FoldableOps C τ
  := { (default : FoldableOps C τ) with
  toList := λ c =>
    let n := Size.size c
    Foldable'.Correct.fold' (Range.mk n) (λ acc i h =>
      Indexed.nth c ⟨n-i-1, by
        simp
        simp [Membership.mem] at h
        rw [Nat.sub_sub]
        apply Nat.sub_lt_of_pos_le
        simp [Nat.add_one, Nat.zero_lt_succ]
        exact h
      ⟩ :: acc
      ) []
  }

theorem toList_eq_range_toList_map [Indexed C τ] (c : C)
  (hL : ∀ {x}, x ∈ canonicalToList (Foldable.fold (Range.mk (Size.size c))) → x < Size.size c)
  : FoldableOps.toList c = (
      canonicalToList ((⟨Size.size c⟩ : Range).foldl)
      |>.map' (fun x h => Indexed.nth c ⟨x, hL h⟩))
  := by
  simp [FoldableOps.toList]
  rw [Foldable'.Correct.fold'Correct]
  -- Get RHS to Range.foldr'
  suffices ∀ L (h : L = canonicalToList (⟨Size.size c⟩ : Range).foldl) f'
    (h_f' : ∃ (h' : ∀ {x}, x ∈ L → _), ∀ x (h : x ∈ L), f' x h = Indexed.nth c ⟨x, h' h⟩),
    _ = List.map' L f'
    from this _ rfl _ (by
      apply Exists.intro _
      intro x h
      simp
      intro x h
      apply (Range.memCorrect _ _).mpr h
      )
  intro L h f' h_f'
  rw [←Range.toList_eq_canonicalToList] at h
  cases h
  conv =>
    rhs
    rw [←List.foldr'_eq_map']
    rw [←Range.foldr'_correct _ (Range.toList_eq_canonicalToList _)
      (f := fun x h acc =>
        f' x (by
          rw [Range.toList_eq_canonicalToList]
          apply (Range.memCorrect _ _).mp h
        ) :: acc)]
    simp
  -- Get LHS to Range.foldl'
  suffices ∀ L (h : L = canonicalToList fun {β} => Foldable.fold (⟨Size.size c⟩ : Range)),
    List.foldl' L (fun acc x h' =>
      Indexed.nth c ⟨Size.size c - x - 1, by
        have : Size.size c > 0 := by
          rw [h] at h'
          rw [←Foldable'.Correct.memCorrect] at h'
          simp [Membership.mem] at h'
          apply Nat.lt_of_le_of_lt (Nat.zero_le x)
          assumption
        rw [Nat.sub_sub]
        apply Nat.sub_lt
        assumption
        apply Nat.zero_lt_succ
      ⟩ :: acc) []
    = _
    from this _ rfl
  intro L h
  simp [Foldable.fold] at h
  rw [←Range.toList_eq_canonicalToList] at h
  cases h
  conv =>
    lhs
    rw [←Range.foldl'_correct _ (Range.toList_eq_canonicalToList _)
      (f := fun acc x h =>
        Indexed.nth c ⟨Size.size c - x - 1, by rw [Nat.sub_sub]; apply Nat.sub_lt; exact Range.size_pos_of_mem h; apply Nat.zero_lt_succ⟩ :: acc)]
  -- Use range lemma
  rw [Range.foldr'_eq_foldl'_mapped]
  congr
  funext acc x h
  rw [h_f'.2]

theorem toList_eq_default_toList [Indexed C τ] (c : C)
  : FoldableOps.toList c = (FoldableOps.defaultImpl C τ).toList c
  := by
  conv =>
    rhs
    rw [FoldableOps.default_toList_eq_canonicalToList]
    simp [canonicalToList]
    unfold Foldable.fold
    simp [Foldable.Correct.toFoldable, Foldable'.Correct.toCorrect,
      instCorrectInferInstanceMembershipInstMembership]
    rw [Foldable'.fold'_append_singleton_eq_map]
  rw [toList_eq_range_toList_map]
  case hL =>
    intro i h
    rw [←Foldable'.Correct.memCorrect] at h
    simp [Membership.mem] at h
    assumption
  rfl

@[simp]
theorem length_toList_eq_size {C τ : Type} [Indexed C τ] (c : C)
  : List.length (FoldableOps.toList c) = Size.size c
  := by
  rw [toList_eq_default_toList]
  simp [FoldableOps.toList, FoldableOps.defaultImpl, Foldable.fold]
  rw [Foldable'.canonicalToList_fold'_eq_map']
  simp [Foldable.fold]
  rw [←Range.toList_eq_canonicalToList]
  simp

theorem get_toList_eq_get [Indexed C τ] (c : C) (i : Nat) (h : i < _)
  : List.get (FoldableOps.toList c) ⟨i, h⟩ = Indexed.nth c ⟨i, by simp at h; exact h⟩
  := by
  suffices ∀ L (hL : L = FoldableOps.toList c),
    List.get L ⟨i, by rw [hL]; exact h⟩ = _
    from this _ rfl
  intro L hL
  simp at h
  rw [toList_eq_default_toList] at hL
  simp [FoldableOps.defaultImpl, canonicalToList, Foldable.fold, Foldable'.Correct.fold'] at hL
  rw [Range.foldl'_correct _ (Range.toList_eq_canonicalToList _)] at hL
  rw [List.foldl'_eq_map'] at hL
  rw [List.map'] at hL
  cases hL
  simp

structure Map (C) [Indexed C τ] where
  val : C

namespace Map

instance [Indexed C τ] : MapLike (Map C) Nat τ where
  fold c f acc :=
    Range.foldl' ⟨Size.size c.val⟩ (λ acc i h_i =>
      f acc (i, Indexed.nth c.val ⟨i,h_i⟩)
    ) acc
  get? i c :=
    if h : i < Size.size c.val then
      some (Indexed.nth c.val ⟨i, h⟩)
    else none


/-
Copyright (c) 2020 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jannis Limperg
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.core
import Mathlib.PostPort

namespace Mathlib

/-!
# Better `clear` tactics

We define two variants of the standard `clear` tactic:

* `clear'` works like `clear` but the hypotheses that should be cleared can be
  given in any order. In contrast, `clear` can fail if hypotheses that depend on
  each other are given in the wrong order, even if all of them could be cleared.

* `clear_dependent` works like `clear'` but also clears any hypotheses that
  depend on the given hypotheses.

## Implementation notes

The implementation (ab)uses the native `revert_lst`, which can figure out
dependencies between hypotheses. This implementation strategy was suggested by
Simon Hudon.
-/

/-- Clears all the hypotheses in `hyps`. The tactic fails if any of the `hyps`
is not a local or if the target depends on any of the `hyps`. It also fails if
`hyps` contains duplicates.

If there are local hypotheses or definitions, say `H`, which are not in `hyps`
but depend on one of the `hyps`, what we do depends on `clear_dependent`. If it
is true, `H` is implicitly also cleared. If it is false, `clear'` fails. -/
-- Check if the target depends on any of the hyps. Doing this (instead of

-- letting one of the later tactics fail) lets us give a much more informative

-- error message.

-- If revert_lst reverted more hypotheses than we wanted to clear, there must

-- have been other hypotheses dependent on some of the hyps.

namespace tactic.interactive

/--
An improved version of the standard `clear` tactic. `clear` is sensitive to the
order of its arguments: `clear x y` may fail even though both `x` and `y` could
be cleared (if the type of `y` depends on `x`). `clear'` lifts this limitation.

```lean
example {α} {β : α → Type} (a : α) (b : β a) : unit :=
begin
  try { clear a b }, -- fails since `b` depends on `a`
  clear' a b,        -- succeeds
  exact ()
end
```
-/
/--
A variant of `clear'` which clears not only the given hypotheses, but also any
other hypotheses depending on them.

```lean
example {α} {β : α → Type} (a : α) (b : β a) : unit :=
begin
  try { clear' a },  -- fails since `b` depends on `a`
  clear_dependent a, -- succeeds, clearing `a` and `b`
  exact ()
end
```
 -/