/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import representation_theory.Rep
import algebra.category.FinVect
import representation_theory.basic

/-!
# `fdRep k G` is the category of finite dimensional `k`-linear representations of `G`.

If `V : fdRep k G`, there is a coercion that allows you to treat `V` as a type,
and this type comes equipped with `module k V` and `finite_dimensional k V` instances.
Also `V.ρ` gives the homomorphism `G →* (V →ₗ[k] V)`.

Conversely, given a homomorphism `ρ : G →* (V →ₗ[k] V)`,
you can construct the bundled representation as `Rep.of ρ`.

We verify that `fdRep k G` is a rigid monoidal category.

## TODO
* `fdRep k G` has all finite (co)limits.
* `fdRep k G` is abelian.
* `fdRep k G ≌ FinVect (monoid_algebra k G)` (this will require generalising `FinVect` first).
* Upgrade the right rigid structure to a rigid structure.
-/

universes u

open category_theory
open category_theory.limits

/-- The category of finite dimensional `k`-linear representations of a monoid `G`. -/
@[derive [large_category, concrete_category/-, has_limits, has_colimits-/]]
abbreviation fdRep (k G : Type u) [field k] [monoid G] :=
Action (FinVect.{u} k) (Mon.of G)

namespace fdRep

variables {k G : Type u} [field k] [monoid G]

instance : has_coe_to_sort (fdRep k G) (Type u) := concrete_category.has_coe_to_sort _

instance (V : fdRep k G) : add_comm_group V :=
by { change add_comm_group ((forget₂ (fdRep k G) (FinVect k)).obj V), apply_instance, }

instance (V : fdRep k G) : module k V :=
by { change module k ((forget₂ (fdRep k G) (FinVect k)).obj V), apply_instance, }

instance (V : fdRep k G) : finite_dimensional k V :=
by { change finite_dimensional k ((forget₂ (fdRep k G) (FinVect k)).obj V), apply_instance, }

/-- The monoid homomorphism corresponding to the action of `G` onto `V : fdRep k G`. -/
def ρ (V : fdRep k G) : G →* (V →ₗ[k] V) := V.ρ

/-- The underlying `linear_equiv` of an isomorphism of representations. -/
def iso_to_linear_equiv {V W : fdRep k G} (i : V ≅ W) : V ≃ₗ[k] W :=
  FinVect.iso_to_linear_equiv ((Action.forget (FinVect k) (Mon.of G)).map_iso i)

lemma iso.conj_ρ {V W : fdRep k G} (i : V ≅ W) (g : G) :
   W.ρ g = (fdRep.iso_to_linear_equiv i).conj (V.ρ g) :=
begin
  rw [fdRep.iso_to_linear_equiv, ←FinVect.iso.conj_eq_conj, iso.conj_apply],
  rw [iso.eq_inv_comp ((Action.forget (FinVect k) (Mon.of G)).map_iso i)],
  exact (i.hom.comm g).symm,
end

-- This works well with the new design for representations:
example (V : fdRep k G) : G →* (V →ₗ[k] V) := V.ρ

/-- Lift an unbundled representation to `fdRep`. -/
@[simps ρ]
def of {V : Type u} [add_comm_group V] [module k V] [finite_dimensional k V]
  (ρ : representation k G V) : fdRep k G :=
⟨FinVect.of k V, ρ⟩

instance : has_forget₂ (fdRep k G) (Rep k G) :=
{ forget₂ := (forget₂ (FinVect k) (Module k)).map_Action (Mon.of G), }

-- Verify that the monoidal structure is available.
example : monoidal_category (fdRep k G) := by apply_instance

end fdRep

namespace fdRep
variables {k G : Type u} [field k] [group G]

-- Verify that the rigid structure is available when the monoid is a group.
noncomputable instance : right_rigid_category (fdRep k G) :=
by { change right_rigid_category (Action (FinVect k) (Group.of G)), apply_instance, }

end fdRep

namespace fdRep

open representation

variables {k G V W : Type u} [field k] [group G]
variables [add_comm_group V] [module k V] [add_comm_group W] [module k W]
variables [finite_dimensional k V] [finite_dimensional k W]
variables (ρV : representation k G V) (ρW : representation k G W)

/-- Auxiliary definition for `fdRep.dual_tensor_iso_lin_hom`. -/
noncomputable def dual_tensor_iso_lin_hom_aux :
  ((fdRep.of ρV.dual) ⊗ (fdRep.of ρW)).V ≅ (fdRep.of (lin_hom ρV ρW)).V :=
(dual_tensor_hom_equiv k V W).to_FinVect_iso

/-- When `V` and `W` are finite dimensional representations of a group `G`, the isomorphism
`dual_tensor_hom_equiv k V W` of vector spaces induces an isomorphism of representations. -/
noncomputable def dual_tensor_iso_lin_hom :
  (fdRep.of ρV.dual) ⊗ (fdRep.of ρW) ≅ fdRep.of (lin_hom ρV ρW) :=
begin
  apply Action.mk_iso (dual_tensor_iso_lin_hom_aux ρV ρW),
  convert (dual_tensor_hom_comm ρV ρW),
end

@[simp] lemma dual_tensor_iso_lin_hom_hom_hom :
  (dual_tensor_iso_lin_hom ρV ρW).hom.hom = dual_tensor_hom k V W := rfl

end fdRep


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang

! This file was ported from Lean 3 source module category_theory.sites.induced_topology
! leanprover-community/mathlib commit ba43124c37cfe0009bbfc57505f9503ae0e8c1af
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Sites.DenseSubsite

/-!
# Induced Topology

We say that a functor `G : C ⥤ (D, K)` is locally dense if for each covering sieve `T` in `D` of
some `X : C`, `T ∩ mor(C)` generates a covering sieve of `X` in `D`. A locally dense fully faithful
functor then induces a topology on `C` via `{ T ∩ mor(C) | T ∈ K }`. Note that this is equal to
the collection of sieves on `C` whose image generates a covering sieve. This construction would
make `C` both cover-lifting and cover-preserving.

Some typical examples are full and cover-dense functors (for example the functor from a basis of a
topological space `X` into `opens X`). The functor `over X ⥤ C` is also locally dense, and the
induced topology can then be used to construct the big sites associated to a scheme.

Given a fully faithful cover-dense functor `G : C ⥤ (D, K)` between small sites, we then have
`Sheaf (H.induced_topology) A ≌ Sheaf K A`. This is known as the comparison lemma.

## References

* [Elephant]: *Sketches of an Elephant*, P. T. Johnstone: C2.2.
* https://ncatlab.org/nlab/show/dense+sub-site
* https://ncatlab.org/nlab/show/comparison+lemma

-/

namespace CategoryTheory

universe v u

open Limits Opposite Presieve

section

variable {C : Type _} [Category C] {D : Type _} [Category D] {G : C ⥤ D}

variable {J : GrothendieckTopology C} {K : GrothendieckTopology D}

variable (A : Type v) [Category.{u} A]

-- variables (A) [full G] [faithful G]
/-- We say that a functor `C ⥤ D` into a site is "locally dense" if
for each covering sieve `T` in `D`, `T ∩ mor(C)` generates a covering sieve in `D`.
-/
def LocallyCoverDense (K : GrothendieckTopology D) (G : C ⥤ D) : Prop :=
  ∀ ⦃X⦄ (T : K (G.obj X)), (T.val.functorPullback G).functorPushforward G ∈ K (G.obj X)
#align category_theory.locally_cover_dense CategoryTheory.LocallyCoverDense

namespace LocallyCoverDense

variable [Full G] [Faithful G] (Hld : LocallyCoverDense K G)

include Hld

theorem pushforward_cover_iff_cover_pullback {X : C} (S : Sieve X) :
    K _ (S.functorPushforward G) ↔ ∃ T : K (G.obj X), T.val.functorPullback G = S :=
  by
  constructor
  · intro hS
    exact ⟨⟨_, hS⟩, (sieve.fully_faithful_functor_galois_coinsertion G X).u_l_eq S⟩
  · rintro ⟨T, rfl⟩
    exact Hld T
#align category_theory.locally_cover_dense.pushforward_cover_iff_cover_pullback CategoryTheory.LocallyCoverDense.pushforward_cover_iff_cover_pullback

/-- If a functor `G : C ⥤ (D, K)` is fully faithful and locally dense,
then the set `{ T ∩ mor(C) | T ∈ K }` is a grothendieck topology of `C`.
-/
@[simps]
def inducedTopology : GrothendieckTopology C
    where
  sieves X S := K _ (S.functorPushforward G)
  top_mem' X := by
    change K _ _
    rw [sieve.functor_pushforward_top]
    exact K.top_mem _
  pullback_stable' X Y S f hS :=
    by
    have : S.pullback f = ((S.functor_pushforward G).pullback (G.map f)).functorPullback G :=
      by
      conv_lhs => rw [← (sieve.fully_faithful_functor_galois_coinsertion G X).u_l_eq S]
      ext
      change (S.functor_pushforward G) _ ↔ (S.functor_pushforward G) _
      rw [G.map_comp]
    rw [this]
    change K _ _
    apply Hld ⟨_, K.pullback_stable (G.map f) hS⟩
  transitive' X S hS S' H' := by
    apply K.transitive hS
    rintro Y _ ⟨Z, g, i, hg, rfl⟩
    rw [sieve.pullback_comp]
    apply K.pullback_stable i
    refine' K.superset_covering _ (H' hg)
    rintro W _ ⟨Z', g', i', hg, rfl⟩
    use ⟨Z', g' ≫ g, i', hg, by simp⟩
#align category_theory.locally_cover_dense.induced_topology CategoryTheory.LocallyCoverDense.inducedTopology

/-- `G` is cover-lifting wrt the induced topology. -/
theorem inducedTopologyCoverLifting : CoverLifting Hld.inducedTopology K G :=
  ⟨fun _ S hS => Hld ⟨S, hS⟩⟩
#align category_theory.locally_cover_dense.induced_topology_cover_lifting CategoryTheory.LocallyCoverDense.inducedTopologyCoverLifting

/-- `G` is cover-preserving wrt the induced topology. -/
theorem inducedTopologyCoverPreserving : CoverPreserving Hld.inducedTopology K G :=
  ⟨fun _ S hS => hS⟩
#align category_theory.locally_cover_dense.induced_topology_cover_preserving CategoryTheory.LocallyCoverDense.inducedTopologyCoverPreserving

end LocallyCoverDense

theorem CoverDense.locallyCoverDense [Full G] (H : CoverDense K G) : LocallyCoverDense K G :=
  by
  intro X T
  refine' K.superset_covering _ (K.bind_covering T.property fun Y f Hf => H.is_cover Y)
  rintro Y _ ⟨Z, _, f, hf, ⟨W, g, f', rfl : _ = _⟩, rfl⟩
  use W; use G.preimage (f' ≫ f); use g
  constructor
  simpa using T.val.downward_closed hf f'
  simp
#align category_theory.cover_dense.locally_cover_dense CategoryTheory.CoverDense.locallyCoverDense

/-- Given a fully faithful cover-dense functor `G : C ⥤ (D, K)`, we may induce a topology on `C`.
-/
abbrev CoverDense.inducedTopology [Full G] [Faithful G] (H : CoverDense K G) :
    GrothendieckTopology C :=
  H.LocallyCoverDense.inducedTopology
#align category_theory.cover_dense.induced_topology CategoryTheory.CoverDense.inducedTopology

variable (J)

theorem over_forget_locallyCoverDense (X : C) : LocallyCoverDense J (Over.forget X) :=
  by
  intro Y T
  convert T.property
  ext (Z f)
  constructor
  · rintro ⟨_, _, g', hg, rfl⟩
    exact T.val.downward_closed hg g'
  · intro hf
    exact ⟨over.mk (f ≫ Y.hom), over.hom_mk f, 𝟙 _, hf, (category.id_comp _).symm⟩
#align category_theory.over_forget_locally_cover_dense CategoryTheory.over_forget_locallyCoverDense

end

section SmallSite

variable {C : Type v} [SmallCategory C] {D : Type v} [SmallCategory D] {G : C ⥤ D}

variable {J : GrothendieckTopology C} {K : GrothendieckTopology D}

variable (A : Type u) [Category.{v} A]

/-- Cover-dense functors induces an equivalence of categories of sheaves.

This is known as the comparison lemma. It requires that the sites are small and the value category
is complete.
-/
noncomputable def CoverDense.sheafEquiv [Full G] [Faithful G] (H : CoverDense K G) [HasLimits A] :
    Sheaf H.inducedTopology A ≌ Sheaf K A :=
  H.sheafEquivOfCoverPreservingCoverLifting H.LocallyCoverDense.inducedTopologyCoverPreserving
    H.LocallyCoverDense.inducedTopologyCoverLifting
#align category_theory.cover_dense.Sheaf_equiv CategoryTheory.CoverDense.sheafEquiv

end SmallSite

end CategoryTheory


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.products.bifunctor
import Mathlib.PostPort

universes u₁ u₂ u₃ v₁ v₂ v₃

namespace Mathlib

namespace category_theory

/--
The uncurrying functor, taking a functor `C ⥤ (D ⥤ E)` and producing a functor `(C × D) ⥤ E`.
-/
def uncurry {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] : (C ⥤ D ⥤ E) ⥤ C × D ⥤ E :=
  functor.mk
    (fun (F : C ⥤ D ⥤ E) =>
      functor.mk (fun (X : C × D) => functor.obj (functor.obj F (prod.fst X)) (prod.snd X))
        fun (X Y : C × D) (f : X ⟶ Y) =>
          nat_trans.app (functor.map F (prod.fst f)) (prod.snd X) ≫ functor.map (functor.obj F (prod.fst Y)) (prod.snd f))
    fun (F G : C ⥤ D ⥤ E) (T : F ⟶ G) =>
      nat_trans.mk fun (X : C × D) => nat_trans.app (nat_trans.app T (prod.fst X)) (prod.snd X)

/--
The object level part of the currying functor. (See `curry` for the functorial version.)
-/
def curry_obj {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C × D ⥤ E) : C ⥤ D ⥤ E :=
  functor.mk
    (fun (X : C) => functor.mk (fun (Y : D) => functor.obj F (X, Y)) fun (Y Y' : D) (g : Y ⟶ Y') => functor.map F (𝟙, g))
    fun (X X' : C) (f : X ⟶ X') => nat_trans.mk fun (Y : D) => functor.map F (f, 𝟙)

/--
The currying functor, taking a functor `(C × D) ⥤ E` and producing a functor `C ⥤ (D ⥤ E)`.
-/
def curry {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] : (C × D ⥤ E) ⥤ C ⥤ D ⥤ E :=
  functor.mk (fun (F : C × D ⥤ E) => curry_obj F)
    fun (F G : C × D ⥤ E) (T : F ⟶ G) => nat_trans.mk fun (X : C) => nat_trans.mk fun (Y : D) => nat_trans.app T (X, Y)

@[simp] theorem uncurry.obj_obj {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C ⥤ D ⥤ E} {X : C × D} : functor.obj (functor.obj uncurry F) X = functor.obj (functor.obj F (prod.fst X)) (prod.snd X) :=
  rfl

@[simp] theorem uncurry.obj_map {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C ⥤ D ⥤ E} {X : C × D} {Y : C × D} {f : X ⟶ Y} : functor.map (functor.obj uncurry F) f =
  nat_trans.app (functor.map F (prod.fst f)) (prod.snd X) ≫ functor.map (functor.obj F (prod.fst Y)) (prod.snd f) :=
  rfl

@[simp] theorem uncurry.map_app {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C ⥤ D ⥤ E} {G : C ⥤ D ⥤ E} {α : F ⟶ G} {X : C × D} : nat_trans.app (functor.map uncurry α) X = nat_trans.app (nat_trans.app α (prod.fst X)) (prod.snd X) :=
  rfl

@[simp] theorem curry.obj_obj_obj {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C × D ⥤ E} {X : C} {Y : D} : functor.obj (functor.obj (functor.obj curry F) X) Y = functor.obj F (X, Y) :=
  rfl

@[simp] theorem curry.obj_obj_map {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C × D ⥤ E} {X : C} {Y : D} {Y' : D} {g : Y ⟶ Y'} : functor.map (functor.obj (functor.obj curry F) X) g = functor.map F (𝟙, g) :=
  rfl

@[simp] theorem curry.obj_map_app {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C × D ⥤ E} {X : C} {X' : C} {f : X ⟶ X'} {Y : D} : nat_trans.app (functor.map (functor.obj curry F) f) Y = functor.map F (f, 𝟙) :=
  rfl

@[simp] theorem curry.map_app_app {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C × D ⥤ E} {G : C × D ⥤ E} {α : F ⟶ G} {X : C} {Y : D} : nat_trans.app (nat_trans.app (functor.map curry α) X) Y = nat_trans.app α (X, Y) :=
  rfl

/--
The equivalence of functor categories given by currying/uncurrying.
-/
@[simp] theorem currying_unit_iso_inv_app_app_app {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (X : C ⥤ D ⥤ E) : ∀ (X_1 : C) (X_2 : D),
  nat_trans.app (nat_trans.app (nat_trans.app (iso.inv (equivalence.unit_iso currying)) X) X_1) X_2 = 𝟙 := sorry


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl, Reid Barton
-/
import category_theory.category.preorder
import category_theory.adjunction.basic
import order.galois_connection

/-!

# Galois connections between preorders are adjunctions.

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

* `galois_connection.adjunction` is the adjunction associated to a galois connection.

-/

universes u v

section

variables {X : Type u} {Y : Type v} [preorder X] [preorder Y]

/--
A galois connection between preorders induces an adjunction between the associated categories.
-/
def galois_connection.adjunction {l : X → Y} {u : Y → X} (gc : galois_connection l u) :
  gc.monotone_l.functor ⊣ gc.monotone_u.functor :=
category_theory.adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, ⟨λ f, (gc.le_u f.le).hom, λ f, (gc.l_le f.le).hom, by tidy, by tidy⟩ }

end

namespace category_theory

variables {X : Type u} {Y : Type v} [preorder X] [preorder Y]

/--
An adjunction between preorder categories induces a galois connection.
-/
lemma adjunction.gc {L : X ⥤ Y} {R : Y ⥤ X} (adj : L ⊣ R) :
  galois_connection L.obj R.obj :=
λ x y, ⟨λ h, ((adj.hom_equiv x y).to_fun h.hom).le, λ h, ((adj.hom_equiv x y).inv_fun h.hom).le⟩

end category_theory


import Myint.Mul

namespace myint

-- Optional: Canonical representation of the integers
-- Satisfied by n ≈ (n'.x, n'.y) where n'.x = 0 or n'.y = 0

theorem arbitrary_representation : ∀ k : mynat, k ≤ n.x ∧ k ≤ n.y → ∃ m : myint, (m.x + k = n.x ∧ m.y + k = n.y) ∧ m ≈ n := by
  intro z
  induction z
  case zero =>
    rw [mynat.mynat_zero_eq_zero]
    intro _
    exists n
    repeat rw [mynat.add_zero]
    apply And.intro
    . apply And.intro
      . rfl
      . rfl
    . exact refl n
  case succ z' hz =>
    intro hgoal
    have := mynat.le_succ _ _ hgoal.left
    have hl := mynat.le_of_succ_le_succ _ _ this
    have := mynat.le_succ _ _ hgoal.right
    have hr := mynat.le_of_succ_le_succ _ _ this
    have hind := hz ⟨ hl, hr ⟩
    cases hind with
    | intro d hd =>
      have ⟨ dx, dy ⟩ := d
      cases dx
      case zero =>
        rw [mynat.mynat_zero_eq_zero] at hd
        rw [destruct_x, destruct_y] at hd
        have hd1 := hd.left
        have hd2 := hd.right
        rw [equiv_is_myequal, myequal] at hd2
        rw [destruct_x, destruct_y _ dy, mynat.zero_add] at hd2
        rw [mynat.zero_add] at hd1
        rw [hd2] at hd1
        have hdconc : z' = n.x := hd1.left
        apply False.elim
        have hfalse := hgoal.left
        rw [hdconc] at hfalse
        exact mynat.not_succ_le_self n.x hfalse
      case succ dx' =>
        cases dy
        case zero =>
          rw [mynat.mynat_zero_eq_zero] at hd
          rw [destruct_x, destruct_y] at hd
          have hd1 := hd.left
          have hd2 := hd.right
          rw [equiv_is_myequal, myequal] at hd2
          rw [destruct_x, destruct_y, destruct_y _ 0, mynat.zero_add] at hd2
          rw [mynat.zero_add] at hd1
          have hdconc : z' = n.y := hd1.right
          apply False.elim
          have hfalse := hgoal.right
          rw [hdconc] at hfalse
          exact mynat.not_succ_le_self n.y hfalse
        case succ dy' =>
          rw [destruct_x, destruct_y] at hd
          have hd1 := hd.left
          have hd2 := hd.right
          rw [equiv_is_myequal, myequal] at hd2
          rw [destruct_x, destruct_y _ (mynat.succ dy')] at hd2
          rw [mynat.succ_add, mynat.succ_add] at hd2
          have hd2conc := mynat.succ_inj hd2
          exists myint.mk dx' dy'
          rw [destruct_x, destruct_y]
          rw [mynat.add_succ, ← mynat.succ_add, mynat.add_succ, ← mynat.succ_add]
          rw [equiv_is_myequal, myequal, destruct_x dx' _, destruct_y _ dy']
          exact ⟨ hd1, hd2conc ⟩

theorem canon_neg (n : myint) : n.x ≤ n.y → ∃ n' : myint, n'.x = 0 ∧ n' ≈ n := by
  intro h
  have := arbitrary_representation n.x ⟨ mynat.le_refl n.x, h ⟩
  cases this with
  | intro c hc =>
    have hc1 := hc.left.left
    have hc3 := hc.right
    exists c
    apply And.intro
    . rw [mynat.add_comm] at hc1
      exact mynat.eq_zero_of_add_right_eq_self hc1
    . exact hc3

theorem canon_pos (n : myint) : n.y ≤ n.x → ∃ n' : myint, n'.y = 0 ∧ n' ≈ n := by
  intro h
  have := arbitrary_representation n.y ⟨ h, mynat.le_refl n.y ⟩
  cases this with
  | intro c hc =>
    have hc2 := hc.left.right
    have hc3 := hc.right
    exists c
    apply And.intro
    . rw [mynat.add_comm] at hc2
      exact mynat.eq_zero_of_add_right_eq_self hc2
    . exact hc3

theorem canon (n : myint) : ∃ n' : myint, (n'.x = 0 ∨ n'.y = 0) ∧ n' ≈ n := by
  let pn := n.x ≤ n.y
  cases Classical.em pn
  case inl h =>
    have : n.x ≤ n.y := h
    have := canon_neg n this
    cases this with
    | intro c hc =>
      exists c
      apply And.intro
      . apply Or.intro_left
        exact hc.left
      . exact hc.right
  case inr h =>
    have hf : ¬n.x ≤ n.y := h
    have : n.x ≤ n.y ∨ n.y ≤ n.x := mynat.le_total n.x n.y
    cases this
    case inl hh =>
      apply False.elim
      exact hf hh
    case inr hh =>
      have := arbitrary_representation n.y ⟨ hh, mynat.le_refl n.y ⟩
      cases this with
      | intro c hc =>
        have hc2 := hc.left.right
        have hc3 := hc.right
        exists c
        apply And.intro
        . apply Or.intro_right
          rw [mynat.add_comm] at hc2
          exact mynat.eq_zero_of_add_right_eq_self hc2
        . exact hc3

end myint


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.limits.yoneda
import category_theory.preadditive.opposite
import algebra.category.Module.basic
import algebra.category.Group.preadditive

/-!
# The Yoneda embedding for preadditive categories

The Yoneda embedding for preadditive categories sends an object `Y` to the presheaf sending an
object `X` to the group of morphisms `X ⟶ Y`. At each point, we get an additional `End Y`-module
structure.

We also show that this presheaf is additive and that it is compatible with the normal Yoneda
embedding in the expected way and deduce that the preadditive Yoneda embedding is fully faithful.

## TODO
* The Yoneda embedding is additive itself

-/

universes v u

open category_theory.preadditive opposite category_theory.limits

noncomputable theory

namespace category_theory

variables {C : Type u} [category.{v} C] [preadditive C]

/--
The Yoneda embedding for preadditive categories sends an object `Y` to the presheaf sending an
object `X` to the `End Y`-module of morphisms `X ⟶ Y`.
-/
@[simps]
def preadditive_yoneda_obj (Y : C) : Cᵒᵖ ⥤ Module.{v} (End Y) :=
{ obj := λ X, Module.of _ (X.unop ⟶ Y),
  map := λ X X' f,
  { to_fun := λ g, f.unop ≫ g,
    map_add' := λ g g', comp_add _ _ _ _ _ _,
    map_smul' := λ r g, eq.symm $ category.assoc _ _ _ } }

/--
The Yoneda embedding for preadditive categories sends an object `Y` to the presheaf sending an
object `X` to the group of morphisms `X ⟶ Y`. At each point, we get an additional `End Y`-module
structure, see `preadditive_yoneda_obj`.
-/
@[simps]
def preadditive_yoneda : C ⥤ (Cᵒᵖ ⥤ AddCommGroup.{v}) :=
{ obj := λ Y, preadditive_yoneda_obj Y ⋙ forget₂ _ _,
  map := λ Y Y' f,
  { app := λ X,
    { to_fun := λ g, g ≫ f,
      map_zero' := limits.zero_comp,
      map_add' := λ g g', add_comp _ _ _ _ _ _ },
    naturality' := λ X X' g, AddCommGroup.ext _ _ _ _ $ λ x, category.assoc _ _ _ },
  map_id' := λ X, by { ext, simp },
  map_comp' := λ X Y Z f g, by { ext, simp } }

/--
The Yoneda embedding for preadditive categories sends an object `X` to the copresheaf sending an
object `Y` to the `End X`-module of morphisms `X ⟶ Y`.
-/
@[simps]
def preadditive_coyoneda_obj (X : Cᵒᵖ) : C ⥤ Module.{v} (End X) :=
{ obj := λ Y, Module.of _ (unop X ⟶ Y),
  map := λ Y Y' f,
  { to_fun := λ g, g ≫ f,
    map_add' := λ g g', add_comp _ _ _ _ _ _,
    map_smul' := λ r g, category.assoc _ _ _ } }

/--
The Yoneda embedding for preadditive categories sends an object `X` to the copresheaf sending an
object `Y` to the group of morphisms `X ⟶ Y`. At each point, we get an additional `End X`-module
structure, see `preadditive_coyoneda_obj`.
-/
@[simps]
def preadditive_coyoneda : Cᵒᵖ ⥤ (C ⥤ AddCommGroup.{v}) :=
{ obj := λ X, preadditive_coyoneda_obj X ⋙ forget₂ _ _,
  map := λ X X' f,
  { app := λ Y,
    { to_fun := λ g, f.unop ≫ g,
      map_zero' := limits.comp_zero,
      map_add' := λ g g', comp_add _ _ _ _ _ _ },
    naturality' := λ Y Y' g, AddCommGroup.ext _ _ _ _ $ λ x, eq.symm $ category.assoc _ _ _ },
  map_id' := λ X, by { ext, simp },
  map_comp' := λ X Y Z f g, by { ext, simp } }

instance additive_yoneda_obj (X : C) : functor.additive (preadditive_yoneda_obj X) := {}
instance additive_yoneda_obj' (X : C) : functor.additive (preadditive_yoneda.obj X) := {}
instance additive_coyoneda_obj (X : Cᵒᵖ) : functor.additive (preadditive_coyoneda_obj X) := {}
instance additive_coyoneda_obj' (X : Cᵒᵖ) : functor.additive (preadditive_coyoneda.obj X) := {}

/--
Composing the preadditive yoneda embedding with the forgetful functor yields the regular
Yoneda embedding.
-/
@[simp]

/--
Composing the preadditive yoneda embedding with the forgetful functor yields the regular
Yoneda embedding.
-/
@[simp] lemma whiskering_preadditive_coyoneda : preadditive_coyoneda ⋙
  (whiskering_right C AddCommGroup (Type v)).obj (forget AddCommGroup) = coyoneda :=
rfl

instance preadditive_yoneda_full : full (preadditive_yoneda : C ⥤ Cᵒᵖ ⥤ AddCommGroup) :=
let yoneda_full : full (preadditive_yoneda ⋙
  (whiskering_right Cᵒᵖ AddCommGroup (Type v)).obj (forget AddCommGroup)) := yoneda.yoneda_full in
by exactI full.of_comp_faithful preadditive_yoneda
  ((whiskering_right Cᵒᵖ AddCommGroup (Type v)).obj (forget AddCommGroup))

instance preadditive_coyoneda_full : full (preadditive_coyoneda : Cᵒᵖ ⥤ C ⥤ AddCommGroup) :=
let coyoneda_full : full (preadditive_coyoneda ⋙
  (whiskering_right C AddCommGroup (Type v)).obj (forget AddCommGroup)) :=
    coyoneda.coyoneda_full in
by exactI full.of_comp_faithful preadditive_coyoneda
  ((whiskering_right C AddCommGroup (Type v)).obj (forget AddCommGroup))

instance preadditive_yoneda_faithful : faithful (preadditive_yoneda : C ⥤ Cᵒᵖ ⥤ AddCommGroup) :=
faithful.of_comp_eq whiskering_preadditive_yoneda

instance preadditive_coyoneda_faithful :
  faithful (preadditive_coyoneda : Cᵒᵖ ⥤ C ⥤ AddCommGroup) :=
faithful.of_comp_eq whiskering_preadditive_coyoneda

end category_theory


import topology.constructions
import topology.separation
import topology.category.Top.basic
import topology.homotopy.basic
import analysis.convex.star

lemma quotient_map_of_is_closed_map {α β} [topological_space α] [topological_space β]
  (f : α → β) : function.surjective f → is_closed_map f → continuous f → quotient_map f :=
begin
  intros hS hC hCont,
  rw quotient_map_iff,
  split, assumption,
  intro U,
  rw [← is_closed_compl_iff, ← is_closed_compl_iff, ← set.preimage_compl],
  generalize : Uᶜ = C, clear U,
  split,
  { apply is_closed.preimage, assumption },
  { intro h, rw (_ : C = f '' (f ⁻¹' C)),
    { apply hC, assumption },
    { symmetry, apply set.image_preimage_eq_of_subset,
      rw hS.range_eq, apply set.subset_univ } }
end

lemma surjection_of_compact_hausdorff_is_quot_map {α β} [topological_space α] [topological_space β]
  [compact_space α] [t2_space β]
  (f : α → β) : function.surjective f → continuous f → quotient_map f :=
λ hSurj hCont, quotient_map_of_is_closed_map f hSurj
                                             (λ C hC, (hC.is_compact.image hCont).is_closed)
                                             hCont

noncomputable
def lift_along_quot_map {α β γ : Top} (q : α ⟶ β) (f : α ⟶ γ) (Hquot : quotient_map q)
  (H : ∀ x y, q x = q y → f x = f y) : β ⟶ γ := {
    to_fun := λ b, f (classical.some (Hquot.left b)),
    continuous_to_fun := (quotient_map.continuous_iff Hquot).mpr
                          (continuous.congr f.continuous_to_fun
                            (λ x, H x _ (eq.symm (classical.some_spec (Hquot.left (q x))))))
  }

lemma lift_along_quot_map_spec {α β γ : Top} (q : α ⟶ β) (f : α ⟶ γ) (Hquot : quotient_map q)
  (H : ∀ x y, q x = q y → f x = f y) (b : β) (a : α) (h : q a = b)
  : lift_along_quot_map q f Hquot H b = f a :=
  H (classical.some (lift_along_quot_map._proof_1 q Hquot b)) a
    ((classical.some_spec (Hquot.left b)).trans h.symm)

lemma lift_along_quot_map_comm_square
  {α β γ δ : Top} (q : α ⟶ β)
  (f : α ⟶ γ) (g : γ ⟶ δ)
  (Hquot : quotient_map q)
  (H : ∀ x y, q x = q y → f x = f y)
  : lift_along_quot_map q f Hquot H ≫ g
  = lift_along_quot_map q (f ≫ g) Hquot (λ x y Hxy, (congr_arg g (H x y Hxy) : g (f x) = g (f y))) :=
begin
  ext b, obtain ⟨a, ha⟩ := Hquot.left b,
  symmetry,
  refine eq.trans (lift_along_quot_map_spec q (f ≫ g) Hquot _ b a ha) _,
  symmetry, exact congr_arg g (lift_along_quot_map_spec q f Hquot H b a ha)
end

universe u
noncomputable
def cylinder : Top.{u} ⥤ Top.{u} := {
  obj := λ X, Top.of (unit_interval × X),
  map := λ X Y f, continuous_map.mk (λ p : unit_interval × X, (p.fst, f p.snd))
                                    (continuous.prod_mk continuous_fst
                                      (continuous.comp f.continuous continuous_snd)),
  map_id' := by { intros, ext p, cases p, simp, refl },
  map_comp' := by { intros, ext p, cases p, simp, refl },
}

def homeomorph.Pi_to_subtype
  {α : Type*} {β : α → Type*} {P : Π (a : α), β a → Prop}
  [τ : Π (a : α), topological_space (β a)]
  : { f : Π (a : α), β a // ∀ a, P a (f a) } ≃ₜ (Π (a : α), { b // P a b }) :=
  equiv.subtype_pi_equiv_pi.to_homeomorph_of_inducing
    ⟨by { simp [subtype.topological_space, Pi.topological_space, induced_compose], refl }⟩

def homeomorph.subtype_prod_equiv_prod
  {α : Type*} {β : Type*} {p : α → Prop} {q : β → Prop}
  [tα : topological_space α] [tβ : topological_space β]
  : {c : α × β // p c.fst ∧ q c.snd} ≃ₜ {a // p a} × {b // q b} :=
  equiv.subtype_prod_equiv_prod.to_homeomorph_of_inducing
    ⟨by { simp [subtype.topological_space, prod.topological_space, induced_inf, induced_compose],
          refl }⟩

variables {E : Type*} [add_comm_group E] [module ℝ E] [topological_space E]
  [has_continuous_add E] [has_continuous_smul ℝ E] {s : set E} {x : E}

/-- A non-empty star convex set is a contractible space. -/
def star_convex.contraction (h : star_convex ℝ x s) (h' : s.nonempty) :
  (continuous_map.id s).homotopy
    (continuous_map.const s ⟨x, star_convex.mem h h'⟩) := {
    to_fun := λ p, ⟨p.1.1 • x + (1 - p.1.1) • p.2,
                    h p.2.2 p.1.2.1 (sub_nonneg.2 p.1.2.2) (add_sub_cancel'_right _ _)⟩,
    map_zero_left' := λ _, by simp,
    map_one_left' := λ _, by simp,
  }

/-- A non-empty convex set is a contractible space. -/
noncomputable
lemma convex.contraction (hs : convex ℝ s)
  : Π (x0 : s), (continuous_map.id s).homotopy (continuous_map.const s x0)
| ⟨x0, h⟩ := (hs.star_convex h).contraction ⟨x0, h⟩

noncomputable
def embedding.pullback {α β γ : Type*} [topological_space α] [topological_space β]
  [topological_space γ] {f : α → β} (hf : embedding f) (g : C(γ, β))
  (hg : set.range g ⊆ set.range f) : C(γ, α) := {
    to_fun := λ x, classical.some (hg (set.mem_range_self x)),
    continuous_to_fun := by {
      refine hf.continuous_iff.mpr _,
      apply continuous.congr g.continuous_to_fun,
      intro x, symmetry, exact classical.some_spec (hg (set.mem_range_self x))
    }
  }

lemma embedding.pullback_spec {α β γ : Type*} [topological_space α] [topological_space β]
  [topological_space γ] {f : α → β} (hf : embedding f) (g : C(γ, β))
  (hg : set.range g ⊆ set.range f) : ∀ x, f (hf.pullback g hg x) = g x :=
begin
  intro x, exact classical.some_spec (hg (set.mem_range_self x))
end

noncomputable
def embedding_restricts_to_homeomorph {X Y : Type*} [topological_space X] [topological_space Y]
  (s : set X) (f : X → Y) (hf : embedding f) : s ≃ₜ f '' s :=
begin
  refine homeomorph.trans (homeomorph.of_embedding _ (embedding.comp hf (@embedding_subtype_coe _ _ s)))
         ⟨equiv.set_congr _, _, _⟩,
  { rw [set.range_comp, subtype.range_coe] },
  { exact continuous_subtype_mk _ continuous_subtype_coe },
  { exact continuous_subtype_mk _ continuous_subtype_coe }
end

-- lemma embedding_restricts_to_homeomorph_spec
--   {X Y : Type*} [topological_space X] [topological_space Y]
--   (s : set X) (f : X → Y) (hf : embedding f) (x : s)
--   : embedding_restricts_to_homeomorph s f hf x = ⟨f x.val, set.mem_image_of_mem f x.property⟩ :=
-- begin
--   refl
-- end


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import topology.category.Profinite
import topology.locally_constant.basic
import topology.discrete_quotient

/-!
# Cofiltered limits of profinite sets.

This file contains some theorems about cofiltered limits of profinite sets.

## Main Results

- `exists_clopen_of_cofiltered` shows that any clopen set in a cofiltered limit of profinite
  sets is the pullback of a clopen set from one of the factors in the limit.
- `exists_locally_constant` shows that any locally constant function from a cofiltered limit
  of profinite sets factors through one of the components.
-/

namespace Profinite

open_locale classical
open category_theory
open category_theory.limits

universe u
variables {J : Type u} [small_category J] [is_cofiltered J]
  {F : J ⥤ Profinite.{u}} (C : cone F) (hC : is_limit C)

include hC

/--
If `X` is a cofiltered limit of profinite sets, then any clopen subset of `X` arises from
a clopen set in one of the terms in the limit.
-/
theorem exists_clopen_of_cofiltered {U : set C.X} (hU : is_clopen U) :
  ∃ (j : J) (V : set (F.obj j)) (hV : is_clopen V), U = C.π.app j ⁻¹' V :=
begin
  -- First, we have the topological basis of the cofiltered limit obtained by pulling back
  -- clopen sets from the factors in the limit. By continuity, all such sets are again clopen.
  have hB := Top.is_topological_basis_cofiltered_limit
    (F ⋙ Profinite.to_Top)
    (Profinite.to_Top.map_cone C)
    (is_limit_of_preserves _ hC)
    (λ j, {W | is_clopen W})
    _ (λ i, is_clopen_univ) (λ i U1 U2 hU1 hU2, hU1.inter hU2) _,
  rotate,
  { intros i,
    change topological_space.is_topological_basis
      {W : set (F.obj i) | is_clopen W},
    apply is_topological_basis_clopen },
  { rintros i j f V (hV : is_clopen _),
    refine ⟨hV.1.preimage _, hV.2.preimage _⟩;
    continuity },
  -- Using this, since `U` is open, we can write `U` as a union of clopen sets all of which
  -- are preimages of clopens from the factors in the limit.
  obtain ⟨S,hS,h⟩ := hB.open_eq_sUnion hU.1,
  clear hB,
  let j : S → J := λ s, (hS s.2).some,
  let V : Π (s : S), set (F.obj (j s)) := λ s, (hS s.2).some_spec.some,
  have hV : ∀ (s : S), is_clopen (V s) ∧ s.1 = C.π.app (j s) ⁻¹' (V s) :=
    λ s, (hS s.2).some_spec.some_spec,
  -- Since `U` is also closed, hence compact, it is covered by finitely many of the
  -- clopens constructed in the previous step.
  have := hU.2.is_compact.elim_finite_subcover (λ s : S, C.π.app (j s) ⁻¹' (V s)) _ _,
  rotate,
  { intros s,
    refine (hV s).1.1.preimage _,
    continuity },
  { dsimp only,
    rw h,
    rintro x ⟨T,hT,hx⟩,
    refine ⟨_,⟨⟨T,hT⟩,rfl⟩,_⟩,
    dsimp only,
    rwa ← (hV ⟨T,hT⟩).2 },
  -- We thus obtain a finite set `G : finset J` and a clopen set of `F.obj j` for each
  -- `j ∈ G` such that `U` is the union of the preimages of these clopen sets.
  obtain ⟨G,hG⟩ := this,
  -- Since `J` is cofiltered, we can find a single `j0` dominating all the `j ∈ G`.
  -- Pulling back all of the sets from the previous step to `F.obj j0` and taking a union,
  -- we obtain a clopen set in `F.obj j0` which works.
  obtain ⟨j0,hj0⟩ := is_cofiltered.inf_objs_exists (G.image j),
  let f : Π (s : S) (hs : s ∈ G), j0 ⟶ j s :=
    λ s hs, (hj0 (finset.mem_image.mpr ⟨s,hs,rfl⟩)).some,
  let W : S → set (F.obj j0) := λ s,
    if hs : s ∈ G then F.map (f s hs) ⁻¹' (V s) else set.univ,
  -- Conclude, using the `j0` and the clopen set of `F.obj j0` obtained above.
  refine ⟨j0, ⋃ (s : S) (hs : s ∈ G), W s, _, _⟩,
  { apply is_clopen_bUnion,
    intros s hs,
    dsimp only [W],
    rw dif_pos hs,
    refine ⟨(hV s).1.1.preimage _, (hV s).1.2.preimage _⟩;
    continuity },
  { ext x,
    split,
    { intro hx,
      simp_rw [set.preimage_Union, set.mem_Union],
      obtain ⟨_, ⟨s,rfl⟩, _, ⟨hs, rfl⟩, hh⟩ := hG hx,
      refine ⟨s, hs, _⟩,
      dsimp only [W] at hh ⊢,
      rwa [dif_pos hs, ← set.preimage_comp, ← Profinite.coe_comp, C.w] },
    { intro hx,
      simp_rw [set.preimage_Union, set.mem_Union] at hx,
      obtain ⟨s,hs,hx⟩ := hx,
      rw h,
      refine ⟨s.1,s.2,_⟩,
      rw (hV s).2,
      dsimp only [W] at hx,
      rwa [dif_pos hs, ← set.preimage_comp, ← Profinite.coe_comp, C.w] at hx } }
end

lemma exists_locally_constant_fin_two (f : locally_constant C.X (fin 2)) :
  ∃ (j : J) (g : locally_constant (F.obj j) (fin 2)), f = g.comap (C.π.app _) :=
begin
  let U := f ⁻¹' {0},
  have hU : is_clopen U := f.is_locally_constant.is_clopen_fiber _,
  obtain ⟨j,V,hV,h⟩ := exists_clopen_of_cofiltered C hC hU,
  use [j, locally_constant.of_clopen hV],
  apply locally_constant.locally_constant_eq_of_fiber_zero_eq,
  rw locally_constant.coe_comap _ _ (C.π.app j).continuous,
  conv_rhs { rw set.preimage_comp },
  rw [locally_constant.of_clopen_fiber_zero hV, ← h],
end

theorem exists_locally_constant_fintype_aux {α : Type*} [fintype α] (f : locally_constant C.X α) :
  ∃ (j : J) (g : locally_constant (F.obj j) (α → fin 2)),
    f.map (λ a b, if a = b then (0 : fin 2) else 1) = g.comap (C.π.app _) :=
begin
  let ι : α → α → fin 2 := λ x y, if x = y then 0 else 1,
  let ff := (f.map ι).flip,
  have hff := λ (a : α), exists_locally_constant_fin_two _ hC (ff a),
  choose j g h using hff,
  let G : finset J := finset.univ.image j,
  obtain ⟨j0,hj0⟩ := is_cofiltered.inf_objs_exists G,
  have hj : ∀ a, j a ∈ G,
  { intros a,
    simp [G] },
  let fs : Π (a : α), j0 ⟶ j a := λ a, (hj0 (hj a)).some,
  let gg : α → locally_constant (F.obj j0) (fin 2) := λ a, (g a).comap (F.map (fs _)),
  let ggg := locally_constant.unflip gg,
  refine ⟨j0, ggg, _⟩,
  have : f.map ι = locally_constant.unflip (f.map ι).flip, by simp,
  rw this, clear this,
  have : locally_constant.comap (C.π.app j0) ggg =
    locally_constant.unflip (locally_constant.comap (C.π.app j0) ggg).flip, by simp,
  rw this, clear this,
  congr' 1,
  ext1 a,
  change ff a = _,
  rw h,
  dsimp [ggg, gg],
  ext1,
  repeat
  { rw locally_constant.coe_comap,
    dsimp [locally_constant.flip, locally_constant.unflip] },
  { congr' 1,
    change _ = ((C.π.app j0) ≫ (F.map (fs a))) x,
    rw C.w },
  all_goals { continuity },
end

theorem exists_locally_constant_fintype_nonempty {α : Type*} [fintype α] [nonempty α]
  (f : locally_constant C.X α) :
  ∃ (j : J) (g : locally_constant (F.obj j) α), f = g.comap (C.π.app _) :=
begin
  inhabit α,
  obtain ⟨j,gg,h⟩ := exists_locally_constant_fintype_aux _ hC f,
  let ι : α → α → fin 2 := λ a b, if a = b then 0 else 1,
  let σ : (α → fin 2) → α := λ f, if h : ∃ (a : α), ι a = f then h.some else arbitrary _,
  refine ⟨j, gg.map σ, _⟩,
  ext,
  rw locally_constant.coe_comap _ _ (C.π.app j).continuous,
  dsimp [σ],
  have h1 : ι (f x) = gg (C.π.app j x),
  { change f.map (λ a b, if a = b then (0 : fin 2) else 1) x = _,
    rw [h, locally_constant.coe_comap _ _ (C.π.app j).continuous] },
  have h2 : ∃ a : α, ι a = gg (C.π.app j x) := ⟨f x, h1⟩,
  rw dif_pos h2,
  apply_fun ι,
  { rw h2.some_spec,
    exact h1 },
  { intros a b hh,
    apply_fun (λ e, e a) at hh,
    dsimp [ι] at hh,
    rw if_pos rfl at hh,
    split_ifs at hh with hh1 hh1,
    { exact hh1.symm },
    { exact false.elim (bot_ne_top hh) } }
end

/-- Any locally constant function from a cofiltered limit of profinite sets factors through
one of the components. -/
theorem exists_locally_constant {α : Type*} (f : locally_constant C.X α) :
  ∃ (j : J) (g : locally_constant (F.obj j) α), f = g.comap (C.π.app _) :=
begin
  let S := f.discrete_quotient,
  let ff : S → α := f.lift,
  casesI is_empty_or_nonempty S,
  { suffices : ∃ j, is_empty (F.obj j),
    { refine this.imp (λ j hj, _),
      refine ⟨⟨hj.elim, λ A, _⟩, _⟩,
      { convert is_open_empty,
        exact @set.eq_empty_of_is_empty _ hj _ },
      { ext x,
        exact hj.elim' (C.π.app j x) } },
    simp only [← not_nonempty_iff, ← not_forall],
    intros h,
    haveI : ∀ j : J, nonempty ((F ⋙ Profinite.to_Top).obj j) := h,
    haveI : ∀ j : J, t2_space ((F ⋙ Profinite.to_Top).obj j) := λ j,
      (infer_instance : t2_space (F.obj j)),
    haveI : ∀ j : J, compact_space ((F ⋙ Profinite.to_Top).obj j) := λ j,
      (infer_instance : compact_space (F.obj j)),
    have cond := Top.nonempty_limit_cone_of_compact_t2_cofiltered_system
      (F ⋙ Profinite.to_Top),
    suffices : nonempty C.X, from is_empty.false (S.proj this.some),
    let D := Profinite.to_Top.map_cone C,
    have hD : is_limit D := is_limit_of_preserves Profinite.to_Top hC,
    have CD := (hD.cone_point_unique_up_to_iso (Top.limit_cone_is_limit _)).inv,
    exact cond.map CD },
  { let f' : locally_constant C.X S := ⟨S.proj, S.proj_is_locally_constant⟩,
    obtain ⟨j, g', hj⟩ := exists_locally_constant_fintype_nonempty _ hC f',
    refine ⟨j, ⟨ff ∘ g', g'.is_locally_constant.comp _⟩,_⟩,
    ext1 t,
    apply_fun (λ e, e t) at hj,
    rw locally_constant.coe_comap _ _ (C.π.app j).continuous at hj ⊢,
    dsimp at hj ⊢,
    rw ← hj,
    refl },
end

end Profinite


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.num.basic
import data.bitvec.core

/-!
# Bitwise operations using binary representation of integers

## Definitions

* bitwise operations for `pos_num` and `num`,
* `snum`, a type that represents integers as a bit string with a sign bit at the end,
* arithmetic operations for `snum`.
-/

namespace pos_num

  /-- Bitwise "or" for `pos_num`. -/
  def lor : pos_num → pos_num → pos_num
  | 1        (bit0 q) := bit1 q
  | 1        q        := q
  | (bit0 p) 1        := bit1 p
  | p        1        := p
  | (bit0 p) (bit0 q) := bit0 (lor p q)
  | (bit0 p) (bit1 q) := bit1 (lor p q)
  | (bit1 p) (bit0 q) := bit1 (lor p q)
  | (bit1 p) (bit1 q) := bit1 (lor p q)

  /-- Bitwise "and" for `pos_num`. -/
  def land : pos_num → pos_num → num
  | 1        (bit0 q) := 0
  | 1        _        := 1
  | (bit0 p) 1        := 0
  | _        1        := 1
  | (bit0 p) (bit0 q) := num.bit0 (land p q)
  | (bit0 p) (bit1 q) := num.bit0 (land p q)
  | (bit1 p) (bit0 q) := num.bit0 (land p q)
  | (bit1 p) (bit1 q) := num.bit1 (land p q)

  /-- Bitwise `λ a b, a && !b` for `pos_num`. For example, `ldiff 5 9 = 4`:

     101
    1001
    ----
     100

  -/
  def ldiff : pos_num → pos_num → num
  | 1        (bit0 q) := 1
  | 1        _        := 0
  | (bit0 p) 1        := num.pos (bit0 p)
  | (bit1 p) 1        := num.pos (bit0 p)
  | (bit0 p) (bit0 q) := num.bit0 (ldiff p q)
  | (bit0 p) (bit1 q) := num.bit0 (ldiff p q)
  | (bit1 p) (bit0 q) := num.bit1 (ldiff p q)
  | (bit1 p) (bit1 q) := num.bit0 (ldiff p q)

  /-- Bitwise "xor" for `pos_num`. -/
  def lxor : pos_num → pos_num → num
  | 1        1        := 0
  | 1        (bit0 q) := num.pos (bit1 q)
  | 1        (bit1 q) := num.pos (bit0 q)
  | (bit0 p) 1        := num.pos (bit1 p)
  | (bit1 p) 1        := num.pos (bit0 p)
  | (bit0 p) (bit0 q) := num.bit0 (lxor p q)
  | (bit0 p) (bit1 q) := num.bit1 (lxor p q)
  | (bit1 p) (bit0 q) := num.bit1 (lxor p q)
  | (bit1 p) (bit1 q) := num.bit0 (lxor p q)

  /-- `a.test_bit n` is `tt` iff the `n`-th bit (starting from the LSB) in the binary representation
      of `a` is active. If the size of `a` is less than `n`, this evaluates to `ff`. -/
  def test_bit : pos_num → nat → bool
  | 1        0     := tt
  | 1        (n+1) := ff
  | (bit0 p) 0     := ff
  | (bit0 p) (n+1) := test_bit p n
  | (bit1 p) 0     := tt
  | (bit1 p) (n+1) := test_bit p n

  /-- `n.one_bits 0` is the list of indices of active bits in the binary representation of `n`. -/
  def one_bits : pos_num → nat → list nat
  | 1        d := [d]
  | (bit0 p) d := one_bits p (d+1)
  | (bit1 p) d := d :: one_bits p (d+1)

  /-- Left-shift the binary representation of a `pos_num`. -/
  def shiftl (p : pos_num) : nat → pos_num
  | 0     := p
  | (n+1) := bit0 (shiftl n)

  /-- Right-shift the binary representation of a `pos_num`. -/
  def shiftr : pos_num → nat → num
  | p        0     := num.pos p
  | 1        (n+1) := 0
  | (bit0 p) (n+1) := shiftr p n
  | (bit1 p) (n+1) := shiftr p n

end pos_num

namespace num

  /-- Bitwise "or" for `num`. -/
  def lor : num → num → num
  | 0       q       := q
  | p       0       := p
  | (pos p) (pos q) := pos (p.lor q)

  /-- Bitwise "and" for `num`. -/
  def land : num → num → num
  | 0       q       := 0
  | p       0       := 0
  | (pos p) (pos q) := p.land q

  /-- Bitwise `λ a b, a && !b` for `num`. For example, `ldiff 5 9 = 4`:

     101
    1001
    ----
     100

  -/
  def ldiff : num → num → num
  | 0       q       := 0
  | p       0       := p
  | (pos p) (pos q) := p.ldiff q

  /-- Bitwise "xor" for `num`. -/
  def lxor : num → num → num
  | 0       q       := q
  | p       0       := p
  | (pos p) (pos q) := p.lxor q

  /-- Left-shift the binary representation of a `num`. -/
  def shiftl : num → nat → num
  | 0       n := 0
  | (pos p) n := pos (p.shiftl n)

  /-- Right-shift the binary representation of a `pos_num`. -/
  def shiftr : num → nat → num
  | 0       n := 0
  | (pos p) n := p.shiftr n

  /-- `a.test_bit n` is `tt` iff the `n`-th bit (starting from the LSB) in the binary representation
      of `a` is active. If the size of `a` is less than `n`, this evaluates to `ff`. -/
  def test_bit : num → nat → bool
  | 0       n := ff
  | (pos p) n := p.test_bit n

  /-- `n.one_bits` is the list of indices of active bits in the binary representation of `n`. -/
  def one_bits : num → list nat
  | 0       := []
  | (pos p) := p.one_bits 0

end num

/-- This is a nonzero (and "non minus one") version of `snum`.
    See the documentation of `snum` for more details. -/
@[derive has_reflect, derive decidable_eq]
inductive nzsnum : Type
| msb : bool → nzsnum
| bit : bool → nzsnum → nzsnum

/-- Alternative representation of integers using a sign bit at the end.
  The convention on sign here is to have the argument to `msb` denote
  the sign of the MSB itself, with all higher bits set to the negation
  of this sign. The result is interpreted in two's complement.

     13  = ..0001101(base 2) = nz (bit1 (bit0 (bit1 (msb tt))))
     -13 = ..1110011(base 2) = nz (bit1 (bit1 (bit0 (msb ff))))

  As with `num`, a special case must be added for zero, which has no msb,
  but by two's complement symmetry there is a second special case for -1.
  Here the `bool` field indicates the sign of the number.

     0  = ..0000000(base 2) = zero ff
     -1 = ..1111111(base 2) = zero tt -/
@[derive has_reflect, derive decidable_eq]
inductive snum : Type
| zero : bool → snum
| nz : nzsnum → snum
instance : has_coe nzsnum snum := ⟨snum.nz⟩
instance : has_zero snum := ⟨snum.zero ff⟩
instance : has_one nzsnum := ⟨nzsnum.msb tt⟩
instance : has_one snum := ⟨snum.nz 1⟩
instance : inhabited nzsnum := ⟨1⟩
instance : inhabited snum := ⟨0⟩

/-!
The `snum` representation uses a bit string, essentially a list of 0 (`ff`) and 1 (`tt`) bits,
and the negation of the MSB is sign-extended to all higher bits.
-/
namespace nzsnum
  notation a :: b := bit a b

  /-- Sign of a `nzsnum`. -/
  def sign : nzsnum → bool
  | (msb b) := bnot b
  | (b :: p) := sign p

  /-- Bitwise `not` for `nzsnum`. -/
  @[pattern] def not : nzsnum → nzsnum
  | (msb b) := msb (bnot b)
  | (b :: p) := bnot b :: not p
  prefix ~ := not

  /-- Add an inactive bit at the end of a `nzsnum`. This mimics `pos_num.bit0`. -/
  def bit0 : nzsnum → nzsnum := bit ff

  /-- Add an active bit at the end of a `nzsnum`. This mimics `pos_num.bit1`. -/
  def bit1 : nzsnum → nzsnum := bit tt

  /-- The `head` of a `nzsnum` is the boolean value of its LSB. -/
  def head : nzsnum → bool
  | (msb b)  := b
  | (b :: p) := b

  /-- The `tail` of a `nzsnum` is the `snum` obtained by removing the LSB.
      Edge cases: `tail 1 = 0` and `tail (-2) = -1`. -/
  def tail : nzsnum → snum
  | (msb b)  := snum.zero (bnot b)
  | (b :: p) := p

end nzsnum

namespace snum
  open nzsnum

  /-- Sign of a `snum`. -/
  def sign : snum → bool
  | (zero z) := z
  | (nz p)   := p.sign

  /-- Bitwise `not` for `snum`. -/
  @[pattern] def not : snum → snum
  | (zero z) := zero (bnot z)
  | (nz p)   := ~p
  prefix ~ := not

  /-- Add a bit at the end of a `snum`. This mimics `nzsnum.bit`. -/
  @[pattern] def bit : bool → snum → snum
  | b (zero z) := if b = z then zero b else msb b
  | b (nz p)   := p.bit b

  notation a :: b := bit a b

  /-- Add an inactive bit at the end of a `snum`. This mimics `znum.bit0`. -/
  def bit0 : snum → snum := bit ff

  /-- Add an active bit at the end of a `snum`. This mimics `znum.bit1`. -/
  def bit1 : snum → snum := bit tt

  theorem bit_zero (b) : b :: zero b = zero b := by cases b; refl

  theorem bit_one (b) : b :: zero (bnot b) = msb b := by cases b; refl

end snum

namespace nzsnum
  open snum

  /-- A dependent induction principle for `nzsnum`, with base cases
      `0 : snum` and `(-1) : snum`. -/
  def drec' {C : snum → Sort*} (z : Π b, C (snum.zero b))
    (s : Π b p, C p → C (b :: p)) : Π p : nzsnum, C p
  | (msb b)  := by rw ←bit_one; exact s b (snum.zero (bnot b)) (z (bnot b))
  | (bit b p) := s b p (drec' p)
end nzsnum

namespace snum
  open nzsnum

  /-- The `head` of a `snum` is the boolean value of its LSB. -/
  def head : snum → bool
  | (zero z) := z
  | (nz p)   := p.head

  /-- The `tail` of a `snum` is obtained by removing the LSB.
      Edge cases: `tail 1 = 0`, `tail (-2) = -1`, `tail 0 = 0` and `tail (-1) = -1`. -/
  def tail : snum → snum
  | (zero z) := zero z
  | (nz p)   := p.tail

  /-- A dependent induction principle for `snum` which avoids relying on `nzsnum`. -/
  def drec' {C : snum → Sort*} (z : Π b, C (snum.zero b))
    (s : Π b p, C p → C (b :: p)) : Π p, C p
  | (zero b) := z b
  | (nz p)   := p.drec' z s

  /-- An induction principle for `snum` which avoids relying on `nzsnum`. -/
  def rec' {α} (z : bool → α) (s : bool → snum → α → α) : snum → α :=
  drec' z s

  /-- `snum.test_bit n a` is `tt` iff the `n`-th bit (starting from the LSB) of `a` is active.
      If the size of `a` is less than `n`, this evaluates to `ff`. -/
  def test_bit : nat → snum → bool
  | 0     p := head p
  | (n+1) p := test_bit n (tail p)

  /-- The successor of a `snum` (i.e. the operation adding one). -/
  def succ : snum → snum :=
  rec' (λ b, cond b 0 1) (λb p succp, cond b (ff :: succp) (tt :: p))

  /-- The predecessor of a `snum` (i.e. the operation of removing one). -/
  def pred : snum → snum :=
  rec' (λ b, cond b (~1) ~0) (λb p predp, cond b (ff :: p) (tt :: predp))

  /-- The opposite of a `snum`. -/
  protected def neg (n : snum) : snum := succ ~n

  instance : has_neg snum := ⟨snum.neg⟩

  /-- `snum.czadd a b n` is `n + a - b` (where `a` and `b` should be read as either 0 or 1).
      This is useful to implement the carry system in `cadd`. -/
  def czadd : bool → bool → snum → snum
  | ff ff p := p
  | ff tt p := pred p
  | tt ff p := succ p
  | tt tt p := p

end snum

namespace snum

/-- `a.bits n` is the vector of the `n` first bits of `a` (starting from the LSB). -/
def bits : snum → Π n, vector bool n
| p 0     := vector.nil
| p (n+1) := head p ::ᵥ bits (tail p) n

def cadd : snum → snum → bool → snum :=
rec' (λ a p c, czadd c a p) $ λa p IH,
rec' (λb c, czadd c b (a :: p)) $ λb q _ c,
bitvec.xor3 a b c :: IH q (bitvec.carry a b c)

/-- Add two `snum`s. -/
protected def add (a b : snum) : snum := cadd a b ff

instance : has_add snum := ⟨snum.add⟩

/-- Substract two `snum`s. -/
protected def sub (a b : snum) : snum := a + -b

instance : has_sub snum := ⟨snum.sub⟩

/-- Multiply two `snum`s. -/
protected def mul (a : snum) : snum → snum :=
rec' (λ b, cond b (-a) 0) $ λb q IH,
cond b (bit0 IH + a) (bit0 IH)

instance : has_mul snum := ⟨snum.mul⟩

end snum


-- Variant on orElse that's useful for de-option-ifying cell values
def Option.orDefault {α} [Inhabited α] : Option α → α
| some x => x
| none => default

-- List utilities
inductive List.All {α} (p : α → Prop) : List α → Prop
| vac      : All p []
| cons {x xs} : p x → All p xs → All p (x::xs)

inductive List.Sublist {α} : List α → List α → Prop
| nil : Sublist [] []
| cons (xs ys x) : Sublist xs ys → Sublist xs (x :: ys)
| cons2 (xs ys x) : Sublist xs ys → Sublist (x :: xs) (x :: ys)

-- TODO: could solve schema woes...
-- mutual
--   inductive UniqueList (α : Type _)
--   | nil : UniqueList α
--   | cons (x : α) (xs : UniqueList α) : ¬(UniqueList.Mem x xs) → UniqueList α

--   inductive UniqueList.Mem (α : Type _) : α → UniqueList α → Prop
--   | head (a : α) (as : UniqueList α) : Mem a (UniqueList.cons a as)
--   | tail (a : α) {b : α} {as : List α} : Mem b as → Mem b (UniqueList.cons a as)
-- end

-- Nifty, but hard to write proofs over
-- def List.prod {α β} (xs : List α) (ys : List β) : List (α × β) :=
-- List.foldl List.append [] (List.map (λ x => List.map (λ y => (x, y)) ys) xs)

-- This goes the wrong way -- keep it around just in case...
theorem Nat.lt_of_add_lt_add : ∀ (a m n : Nat), m + a < n + a → m < n
| 0, m, n, h => h
| 1, m, n, h => Nat.lt_of_succ_lt_succ h
| succ (succ a'), m, n, h =>
  -- Copied from `one_lt_succ_succ` in Lean 3's `basic.lean`
  have term_help : 1 < succ (succ a') := succ_lt_succ $ succ_pos a'
  have ih1 := lt_of_add_lt_add 1 (m + succ a') (n + succ a') h
  have ih := lt_of_add_lt_add (succ a') m n ih1
  ih

theorem Nat.add_lt_add_of_lt : ∀ (a m n : Nat), m < n → m + a < n + a :=
by intros a m n h
   induction a with
   | zero => exact h
   | succ n' ih =>
    rw [←Nat.add_one, ←Nat.add_assoc, ←Nat.add_assoc, Nat.add_one, Nat.add_one]
    apply Nat.succ_lt_succ
    exact ih

def List.prod {α β} : List α → List β → List (α × β)
| [], _ => []
| _, [] => []
| [x], y :: ys => (x, y) :: prod [x] ys
| x :: x' :: xs, ys =>
  have h₁ : Nat.succ 0 + length ys <
            Nat.succ (Nat.succ (length xs)) + length ys :=
    by apply Nat.add_lt_add_of_lt
       apply Nat.succ_lt_succ $ Nat.succ_pos (length xs)
  have h₂ : Nat.succ (length xs) + length ys <
            Nat.succ (Nat.succ (length xs)) + length ys :=
    by apply Nat.add_lt_add_of_lt
       apply Nat.succ_lt_succ
       apply Nat.lt.base
  prod [x] ys ++ prod (x' :: xs) ys
termination_by List.prod xs ys => xs.length + ys.length

-- TODO: So List.nth *does* still exist in the prelude -- they just changed
-- the name to `List.get`...
def List.nth {α} : (xs : List α) → (n : Nat) → (n < List.length xs) → α
| [], _, h => absurd h (by intro nh; cases nh)
| x::xs, 0, h => x
| x::xs, Nat.succ n, h => nth xs n (Nat.le_of_succ_le_succ h)

def List.nths {α}
              (xs : List α)
              (ns : List {n : Nat // n < List.length xs}) : List α :=
  List.map (λ n => List.nth xs n.val n.property) ns

def List.dropLastN {α} : Nat → List α → List α :=
  (λ n => reverse ∘ List.drop n ∘ reverse)

-- This is slick, but unfortunately, it breaks type inference
-- def List.sieve' {α} (bs : List Bool) (xs : List α) : List α :=
--   xs |> List.zip bs
--      |> List.filter Prod.fst
--      |> List.map Prod.snd

def List.sieve {α} : List Bool → List α → List α
| [], xs => xs
| _, [] => []
| true :: bs, x :: xs => x :: sieve bs xs
| false :: bs, _ :: xs => sieve bs xs

-- TODO: I don't think we even need this function after all...
def List.flatten {α} : List (List α) → List α
| [] => []
| [] :: ys => flatten ys
| (x :: xs) :: ys => x :: flatten (xs :: ys)

def List.flatMap {α β} (f : α → List β) : List α → List β
| [] => []
| x :: xs => f x ++ flatMap f xs

def List.toSingletons : List α → List (List α)
| [] => []
| x :: xs => [x] :: toSingletons xs

-- TODO: better name?
def List.somes : List (Option α) → List α
| [] => []
| none :: xs => somes xs
| some x :: xs => x :: somes xs

-- Based on `buffer.lt_aux_1` in Lean 3's `lib/lean/library/data/buffer.lean`
theorem Nat.lt_of_lt_add_left {a b c : Nat} (h : a + c < b) : a < b :=
Nat.lt_of_le_of_lt (Nat.le_add_right a c) h

def List.vEnumFrom (xs : List α) :
  (n : Nat) → (ys : List α) → (n + ys.length ≤ xs.length) →
  List (Fin xs.length × α)
| n, [], _ => []
| n, y :: ys, pf =>
  (⟨n, Nat.lt_of_lt_add_left pf⟩, y) ::
  vEnumFrom xs (n + 1) ys (Eq.subst (motive := (· ≤ length xs))
                  (Nat.add_right_comm n (length ys) 1) pf)

def List.verifiedEnum (xs : List α) : List (Fin xs.length × α) :=
  vEnumFrom xs 0 xs (Eq.subst (Nat.zero_add _) (Nat.le_refl _))

theorem List.length_vEnumFrom (xs : List α) :
  ∀ (ys : List α) (n : Nat) (pf : n + ys.length ≤ xs.length),
  (vEnumFrom xs n ys pf).length = ys.length
| [], _, _ => rfl
| y :: ys, n, pf => congrArg (·+1) (length_vEnumFrom xs ys (n + 1) _)

theorem List.length_verifiedEnum : ∀ (xs : List α),
  xs.verifiedEnum.length = xs.length
| [] => rfl
| x :: xs => congrArg (·+1) (length_vEnumFrom _ _ _ _)

theorem List.filter_length_aux {α} (g : α → Bool) (xs : List α) :
    ∀ rs : List α, List.length (List.filterAux g xs rs)
                   <= List.length xs + List.length rs :=
by
  induction xs with
  | nil =>
    intro rs
    simp only [filter, filterAux]
    rw [List.length_reverse]
    simp only [length, Nat.zero_add]
    apply Nat.le.refl
  | cons x xs ih =>
    intro rs
    simp only [filter, filterAux]
    cases (g x) with
    | true => simp only
              apply Nat.le_trans (ih (x::rs))
              simp only [length]
              rw [Nat.add_comm (length rs), Nat.add_assoc]
              apply Nat.le.refl
    | false => simp only [length]
               apply Nat.le_trans (ih rs)
               rw [Nat.add_comm (length xs) 1,
                   Nat.add_assoc 1,
                   Nat.add_comm 1,
                   Nat.add_one]
               apply Nat.le.step
               apply Nat.le.refl

theorem List.filter_length {α} (g : α → Bool) (xs : List α) :
    List.length (List.filter g xs) <= List.length xs :=
  List.filter_length_aux g xs []

-- Temporary merge sort algorithm until the full sorting library gets ported

def List.split {α} : List α → List α × List α
| [] => ([], [])
| [x] => ([x], [])
| x₁ :: x₂ :: xs =>
  let (ys, zs) := split xs;
  (x₁ :: ys, x₂ :: zs)

theorem List.split_length_fst' {α} :
    ∀ (xs : List α), (split xs).fst.length ≤ xs.length
| [] => by simp only [length]
| [x] => by simp only [length]
| x₁ :: x₂ :: xs =>
  have ih := split_length_fst' xs;
  by simp only [split, length]
     apply Nat.le.step
     apply Nat.succ_le_succ
     apply ih

theorem List.split_length_fst {α} :
    ∀ (xs : List α), xs.length ≤ 1 ∨ (split xs).fst.length < xs.length
| [] => by simp only [length]
| [x] => by simp only [length]
| [x, y] => by simp only [length]
| [x, y, z] => by simp only [length]
| x₁ :: x₂ :: x :: x' :: xs =>
  have ih := split_length_fst (x :: x' :: xs);
  by simp only [split, length]
     apply Or.intro_right
     apply Nat.succ_lt_succ
     simp [length, Nat.add] at ih
     apply Nat.lt.step
     cases ih with
     | inl _ => contradiction
     | inr h => apply h

theorem List.split_length_snd {α} :
    ∀ (xs : List α), xs = [] ∨ (split xs).snd.length < xs.length
| [] => by simp only [length]
| [x] => by simp only [length]
| [x, y] => by simp only [length]
| x₁ :: x₂ :: x :: xs =>
  have ih := split_length_snd (x :: xs);
  by simp only [split, length]
     apply Or.intro_right
     apply Nat.succ_lt_succ
     simp at ih
     apply Nat.lt.step
     apply ih

theorem List.split_length_snd' {α} :
    ∀ (xs : List α), (split xs).snd.length ≤ xs.length
| [] => by simp only [length]
| [x] => by simp only [length]
| x₁ :: x₂ :: xs =>
  have ih := split_length_snd' xs;
  by simp only [split, length]
     apply Nat.le.step
     apply Nat.succ_le_succ
     apply ih

def List.mergeWith {α} : (α → α → Ordering) → List α × List α → List α
| _, ([], ys) => ys
| _, (xs, []) => xs
| cmp, (x :: xs, y :: ys) =>
  have h1 : ys.length + (x :: xs).length <
            (x :: xs).length + (y :: ys).length :=
    by simp only [length]
       rw [Nat.add_comm]
       apply Nat.lt.base
  have h2 : (y :: ys).length + xs.length <
            (x :: xs).length + (y :: ys).length :=
    by simp only [length]
       rw [Nat.add_comm (length xs + 1)]
       apply Nat.lt.base
  match cmp x y with
  | Ordering.gt => y :: mergeWith cmp (ys, x :: xs)
  | _ => x :: mergeWith cmp (y :: ys, xs)
termination_by mergeWith cmp prd => prd.fst.length + prd.snd.length
decreasing_by assumption

def List.mergeSortWith {α} : (α → α → Ordering) → List α → List α
| _, [] => []
| _, [x] => [x]
| cmp, x₁ :: x₂ :: xs =>
  have _ : (split (x₁::x₂::xs)).fst.length < (x₁::x₂::xs).length :=
    match xs with
    | [] => by simp only [length]
    | [xs] => by simp only [length]
    | y :: y' :: ys =>
      match split_length_fst (y :: y' :: ys) with
      | Or.inl _ => by contradiction
      | Or.inr h =>
        by simp only [length] at *
           apply Nat.lt.step
           apply Nat.succ_lt_succ
           exact h

   have _ : (split (x₁::x₂::xs)).snd.length < (x₁::x₂::xs).length :=
    match xs with
    | [] => by simp only [length]
    | [xs] => by simp only [length]
    | y :: y' :: ys =>
      match split_length_snd (y :: y' :: ys) with
      | Or.inl _ => by contradiction
      | Or.inr h =>
        by simp only [length] at *
           apply Nat.lt.step
           apply Nat.succ_lt_succ
           exact h

  let xs_split := split (x₁ :: x₂ :: xs)
  mergeWith cmp (mergeSortWith cmp (xs_split.fst),
                  mergeSortWith cmp (xs_split.snd))
termination_by mergeSortWith cmp xs => xs.length
decreasing_by assumption

-- theorem List.length_map : ∀ (xs : List α) (f : α → β),
--     List.length (List.map f xs) = List.length xs
-- | [], _ => rfl
-- | (x :: xs), f => congrArg _ (length_map xs f)

theorem List.zip_length_eq_of_length_eq :
  ∀ (xs : List α) (ys : List β) (h : xs.length = ys.length),
    (List.zip xs ys).length = xs.length
| [], [], _ => rfl
| (x :: xs), (y :: ys), h =>
  have ih := zip_length_eq_of_length_eq xs ys (by
    simp only [List.length] at h
    apply Nat.succ.inj
    apply h
  )
  by
  simp only [List.zip, List.zipWith]
  -- TODO: how do you "refold" a definition in Lean 4?
  have aux : List.zipWith Prod.mk xs ys = List.zip xs ys := rfl
  rw [aux]
  simp only [List.length]
  apply congrArg (λ x => x + 1)
  apply ih

theorem List.length_prod : ∀ (xs : List α) (ys : List β),
  List.length (List.prod xs ys) = xs.length * ys.length
| [], _ => by simp [prod, length]
| x :: xs, [] => by simp [prod, length]
| [x], y :: ys =>
  have ih := length_prod [x] ys
  by simp only [prod]
     unfold length  -- `simp only [length]` does bad things
     simp only
     rw [ih]
     simp only [length]
     rw [Nat.one_mul, Nat.one_mul]
| x :: x' :: xs, y :: ys =>
  -- TODO: could probably consolidate these with the List.prod helper lemmas
  -- (there are some slight discrepancies due to specifying `y :: ys`)
  have h_term₁ : Nat.succ 0 + Nat.succ (length ys) <
                 Nat.succ (Nat.succ (length xs)) + Nat.succ (length ys) :=
    by apply Nat.add_lt_add_of_lt
       apply Nat.succ_lt_succ $ Nat.succ_pos (length xs)
  have h_term₂ : Nat.succ (length xs) + Nat.succ (length ys) <
                 Nat.succ (Nat.succ (length xs)) + Nat.succ (length ys) :=
    by apply Nat.add_lt_add_of_lt
       apply Nat.succ_lt_succ
       apply Nat.lt.base
  have ih₁ := length_prod [x] (y :: ys)
  have ih₂ := length_prod (x' :: xs) (y :: ys)
  by unfold prod
     simp only
     rw [List.length_append, ih₁, ih₂]
     simp only [length]
     rw [←Nat.add_mul, Nat.zero_add, Nat.add_comm 1]
termination_by List.length_prod xs ys => xs.length + ys.length

theorem List.length_drop : ∀ (n : Nat) (xs : List α),
  n < xs.length → length (drop n xs) = length xs - n
| 0, _, _ => by simp only [drop, Nat.sub_zero]
| n + 1, x :: xs, h =>
  have ih := length_drop n xs (Nat.lt_of_succ_lt_succ h)
  by simp only [drop, Nat.add, length]
     rw [Nat.succ_sub_succ_eq_sub]
     exact ih

theorem List.length_take :
  ∀ (n : Nat) (xs : List α) (h : n < xs.length),
    length (List.take n xs) = n
| _, [], h => by cases h
| 0, _, _ => by simp only [take, length]
| Nat.succ n, x :: xs, h =>
  have ih : length (take n xs) = n :=
    length_take n xs (Nat.lt_of_succ_lt_succ h)
  by simp only [take, length]
     apply congrArg Nat.succ ih

theorem List.reverse_singleton (x : α) : reverse [x] = [x] := rfl

theorem List.singleton_append (x : α) (xs : List α) : [x] ++ xs = x :: xs := rfl

theorem List.map_map {α β γ : Type _} :
  ∀ (g : β → γ) (f : α → β) (xs : List α) ,
  map g (map f xs) = map (g ∘ f) xs
| _, _, [] => rfl
| g, f, x :: xs => congrArg (g (f x) :: ·) (map_map g f xs)

theorem List.map_map_append {α β γ δ : Type _} :
  ∀ (xs : List α) (ys : List β) (f : γ → δ) (g : α → γ) (h : β → γ),
  map f (map g xs ++ map h ys) = map (f ∘ g) xs ++ map (f ∘ h) ys
| [], ys, f, g, h => map_map f h ys
| x :: xs, ys, f, g, h => congrArg (f (g x) :: ·) (map_map_append xs ys f g h)

theorem List.not_mem_nil {α} (x : α) : ¬ (x ∈ []) :=
λ h => nomatch h

theorem List.sublist_self : ∀ (xs : List α), Sublist xs xs
| [] => Sublist.nil
| x :: xs => Sublist.cons2 xs xs x (sublist_self xs)

theorem List.nil_sublist : ∀ (xs : List α), Sublist [] xs
| [] => Sublist.nil
| x :: xs => Sublist.cons [] xs x $ nil_sublist xs

theorem List.singleton_sublist_of_mem (y : α) :
  ∀ (xs : List α), y ∈ xs → Sublist [y] xs
| .(y) :: xs, List.Mem.head _ _ => Sublist.cons2 [] xs y (nil_sublist xs)
| x :: xs, List.Mem.tail .(x) h =>
  Sublist.cons _ xs x (singleton_sublist_of_mem y xs h)

-- Adapted from ll. 953-962 of `data/list/basic.lean` of Mathlib 3
theorem List.Sublist.trans {l₁ l₂ l₃ : List α}
  (h₁ : Sublist l₁ l₂) (h₂ : Sublist l₂ l₃) : Sublist l₁ l₃ :=
Sublist.recOn
  (motive := λ l₂ l₃ h₂ => (l₁ : List α) → (Sublist l₁ l₂) → Sublist l₁ l₃)
  h₂
  (λ _ s => s)
  (λ l₂ l₃ a h₂ IH l₁ h₁ => Sublist.cons _ _ _ (IH l₁ h₁))
  (λ l₂ l₃ a h₂ IH l₁ h₁ =>
    Sublist.casesOn
      (motive := λl₁ l₂' _ => l₂' = a :: l₂ → Sublist l₁ (a :: l₃))
      h₁
      (λ_ => nil_sublist _)
      (λl₁ l₂' a' h₁' e =>
        match a', l₂', e, h₁' with
          | _, _, rfl, h₁ => Sublist.cons _ _ _ (IH _ h₁))
      (λl₁ l₂' a' h₁' e => match a', l₂', e, h₁' with
        | _, _, rfl, h₁ => Sublist.cons2 _ _ _ (IH _ h₁)) rfl)
  l₁ h₁

-- This shouldn't need to be this verbose -- is something up with the defeqs for
-- `sieve`?
theorem List.sieve_sublist : (bs : List Bool) → (xs : List α) →
  Sublist (List.sieve bs xs) xs
| [], [] => Sublist.nil
| [], x :: xs => List.sublist_self (x :: xs)
| true :: bs, [] => Sublist.nil
| false :: bs, [] => Sublist.nil
| true :: bs, x :: xs => Sublist.cons2 (sieve bs xs) xs x (sieve_sublist bs xs)
| false :: bs, x :: xs => Sublist.cons (sieve bs xs) xs x (sieve_sublist bs xs)

theorem List.sublist_of_map_sublist :
  (xs : List α) → (ys : List α) → (f : α → β) → Sublist xs ys →
    Sublist (xs.map f) (ys.map f)
| [], ys, f, h => nil_sublist (map f ys)
| xs, x :: ys, f, Sublist.cons _ _ _ h =>
  have ih := sublist_of_map_sublist xs ys f h
  Sublist.cons (map f xs) (map f ys) (f x) ih
| x :: xs, _ :: ys, f, Sublist.cons2 _ _ _ h =>
  have ih := sublist_of_map_sublist xs ys f h
  Sublist.cons2 (map f xs) (map f ys) (f x) ih

theorem List.removeAll_singleton_hd_eq [DecidableEq α] :
  ∀ (x: α) (xs : List α), removeAll (x :: xs) [x] = removeAll xs [x] :=
by intros x xs
   simp [removeAll, filter, filterAux, notElem, elem]

theorem List.filterAux_spec : ∀ (p : α → Bool) (xs acc : List α),
  filterAux p xs acc = (reverse acc) ++ filter p xs := by
  intros p xs
  induction xs with
  | nil => intros acc; simp [filter, filterAux]
  | cons x xs ih =>
    intros acc
    simp only [filterAux]
    cases hp : p x
    . simp only
      rw [ih]
      conv =>
        rhs
        simp only [filter, filterAux, hp]
        rw [ih]
    . simp only
      apply (
        -- TODO: get this out of calc mode eventually
calc filterAux p xs (x :: acc)
      = reverse (x :: acc) ++ filter p xs := ih _
      _ = reverse acc ++ [x] ++ filter p xs := by simp
      _ = reverse acc ++ reverse [x] ++ filter p xs := by simp
      _ = reverse acc ++ filterAux p xs [x] := by rw [ih, append_assoc]
      _ = reverse acc ++ filterAux p (x :: xs) [] := by simp [filterAux, hp]
      )

def List.filterSpec (p : α → Bool) : List α → List α
| [] => []
| x :: xs => if p x then x :: filterSpec p xs else filterSpec p xs

theorem List.filter_eq_filterSpec : filter p xs = filterSpec p xs := by
  induction xs with
  | nil => simp only [filter, filterAux, filterSpec, reverse, reverseAux]
  | cons x xs ih =>
    simp only [filter, filterAux, filterSpec]
    cases p x with
    | true =>
      simp only [ite_true]
      rw [filterAux_spec, reverse_singleton, singleton_append, ih]
    | false => simp only [ite_false]; rw [←filter, ih]

theorem List.reverseAux_spec (xs acc : List α) :
  reverseAux xs acc = reverse xs ++ acc := by
  induction xs generalizing acc with
  | nil => simp [reverse, reverseAux]
  | cons x xs ih =>
    simp only [reverse, reverseAux]
    simp only [ih]
    rw [←singleton_append, append_assoc]

def List.reverseSpec : List α → List α
| [] => []
| x :: xs => reverseSpec xs ++ [x]

theorem List.reverse_eq_reverseSpec (xs : List α) :
  reverse xs = reverseSpec xs := by
  induction xs with
  | nil => simp [reverse, reverseAux, reverseSpec]
  | cons x xs ih =>
    simp only [reverse, reverseSpec, reverseAux]
    rw [reverseAux_spec]
    exact congrArg (· ++ [x]) ih

theorem List.filterAux_acc_eq_rev_append : ∀ (p : α → Bool) (xs as bs : List α),
  filterAux p xs (bs ++ as) = reverse as ++ filterAux p xs bs
| p, [], as, bs => by simp [filterAux]
| p, xs, [], bs => by simp [filterAux]
| p, x :: xs, a :: as, bs =>
  have ih_true := filterAux_acc_eq_rev_append p xs (a :: as) (x :: bs)
  have ih_false := filterAux_acc_eq_rev_append p xs (a :: as) bs
  by simp only [filterAux]
     cases p x with
     | true => simp only; apply ih_true
     | false => simp only; apply ih_false

theorem List.removeAll_singleton_hd_neq {α : Type _} [BEq α] :
  ∀ (x : α) (y : α) (xs : List α),
    ((x == y) = false) → removeAll (x :: xs) [y] = x :: removeAll xs [y] :=
by intros x y xs hneq
   simp only [removeAll, filter, filterAux, notElem, elem, hneq]
   exact filterAux_acc_eq_rev_append _ xs [x] []

theorem List.sieve_removeAll : (bs : List Bool) → (xs : List α) →
  length bs = length xs →
    length (sieve bs xs) = length (removeAll bs [false])
| [], [], h => rfl
| b :: bs, [], h => by cases h
| [], x :: xs, h => by cases h
| true :: bs, x :: xs, h =>
  have ih := sieve_removeAll bs xs (Nat.succ.inj h)
  by rw [removeAll_singleton_hd_neq]
     . simp only [length]
       apply congrArg (λ x => x + 1)
       exact ih
     . simp only
| false :: bs, x :: xs, h =>
  have ih := sieve_removeAll bs xs (Nat.succ.inj h)
  by rw [removeAll_singleton_hd_eq]
     . simp only [length, sieve]
       exact ih

theorem List.length_mergeWith : ∀ (cmp : α → α → Ordering)
                                   (xs ys : List α),
  length (mergeWith cmp (xs, ys)) = length xs + length ys
| cmp, [], ys => by simp only [mergeWith, length, Nat.zero_add]
| cmp, x :: xs, [] => rfl
| cmp, x :: xs, y :: ys =>
have ih₁ := length_mergeWith cmp (y :: ys) xs
have ih₂ := length_mergeWith cmp ys (x :: xs)
by simp only [mergeWith]
   cases cmp x y with
   | lt =>
     simp only
     have h₁ : length (x :: mergeWith cmp (y :: ys, xs)) =
               length (mergeWith cmp (y :: ys, xs)) + 1 := rfl
     have h₂ : length (x :: xs) = length xs + 1 := rfl
     rw [h₁, h₂, Nat.add_comm (length xs + 1), ←Nat.add_assoc]
     apply congrArg (λ x => x + 1)
     exact ih₁
   | eq =>
     simp only
     have h₁ : length (x :: mergeWith cmp (y :: ys, xs)) =
               length (mergeWith cmp (y :: ys, xs)) + 1 := rfl
     have h₂ : length (x :: xs) = length xs + 1 := rfl
     rw [h₁, h₂, Nat.add_comm (length xs + 1), ←Nat.add_assoc]
     apply congrArg (λ x => x + 1)
     exact ih₁
   | gt =>
     simp only [length]
     simp only [length] at ih₂
     rw [←Nat.add_assoc]
     apply congrArg (λ x => x + 1)
     rw [Nat.add_comm]
     exact ih₂
termination_by length_mergeWith xs ys => xs.length + ys.length

theorem List.length_split : ∀ (xs : List α),
  length ((split xs).1) + length ((split xs).2) = length xs
| [] => rfl
| [x] => rfl
| x :: y :: xs =>
  have ih := length_split xs
  by simp only [split, length]
     rw [Nat.add_assoc (length xs),
         Nat.add_assoc (length (split xs).1),
         Nat.add_comm 1,
         Nat.add_assoc (length (split xs).2),
         ←Nat.add_assoc (length (split xs).1)]
     apply congrArg (λ x => x + (1 + 1))
     exact ih

theorem List.length_mergeSortWith : ∀ (cmp : α → α → Ordering) (xs : List α),
  length (mergeSortWith cmp xs) = length xs
| _, [] => rfl
| _, [x] => rfl
| cmp, x :: y :: xs =>
  have term₁ : Nat.succ (length (split xs).fst) <
               Nat.succ (Nat.succ (length xs)) :=
    Nat.succ_le_succ (Nat.succ_le_succ $ split_length_fst' xs)
  have term₂ : Nat.succ (length (split xs).snd) <
               Nat.succ (Nat.succ (length xs)) :=
    Nat.succ_le_succ (Nat.succ_le_succ $ split_length_snd' xs)
  have ih₁ := length_mergeSortWith cmp (x :: (split xs).1)
  have ih₂ := length_mergeSortWith cmp (y :: (split xs).2)
  -- TODO: we shouldn't need to do a "step" of length_split again here
  by simp only [mergeSortWith, mergeWith, split, length_mergeWith, length]
     rw [ih₁, ih₂]
     simp only [length]
     rw [Nat.add_assoc (length (split xs).1),
         Nat.add_comm 1,
         Nat.add_assoc (length (split xs).2),
         ←Nat.add_assoc (length (split xs).1),
         Nat.add_assoc (length xs)]
     apply congrArg (λ x => x + (1 + 1))
     apply length_split
termination_by length_mergeSortWith cmp xs => xs.length

-- Slightly over-generalized "loop invariant" (we could make the preservation
-- portion more specific, e.g., by providing `x ∈ xs` as an extra hypothesis)
theorem List.foldr_invariant :
  ∀ (p : β → Prop) (f : α → β → β) (z : β) (xs : List α),
  p z → (∀ x a, p a → p (f x a)) → p (List.foldr f z xs)
| _, _, _, [], h_init, _ => h_init
| p, f, z, x :: xs, h_init, h_pres =>
  h_pres x (foldr f z xs) (foldr_invariant p f z xs h_init h_pres)

-- From a failed approach to `pivotTable` -- keeping around just in case
def List.depFoldr {κ : List α → Type _} :
  (xs : List α) →
  (∀ {xs : List α} (x : α), κ xs → κ (x :: xs)) →
  κ [] →
  κ xs
| [], f, z => z
| x :: xs, f, z => f x (depFoldr xs f z)

-- Reproducing `algebra/order/sub.lean` for Nats

-- Based on `tsub_le_iff_left` in `algebra/order/sub.lean` in Mathlib 3
theorem Nat.sub_le_iff_left {a b c : Nat} : a - b ≤ c ↔ a ≤ b + c :=
by apply Iff.intro
   . intros h
     rw [Nat.add_comm]
     apply Nat.le_add_of_sub_le
     exact h
   . intros h
     apply Nat.sub_le_of_le_add
     rw [Nat.add_comm]
     exact h

-- Based on `le_add_tsub`
theorem Nat.le_add_sub {a b : Nat} : a ≤ b + (a - b) :=
Nat.sub_le_iff_left.mp $ Nat.le_refl _

-- Based on `tsub_add_eq_tsub_tsub`
theorem Nat.sub_add_eq_sub_sub {a b c : Nat} : a - (b + c) = a - b - c :=
by apply Nat.le_antisymm (Nat.sub_le_iff_left.mpr _)
                         (Nat.sub_le_iff_left.mpr $ Nat.sub_le_iff_left.mpr _)
   . rw [Nat.add_assoc]
     apply Nat.le_trans Nat.le_add_sub (Nat.add_le_add_left Nat.le_add_sub _)
   . rw [←Nat.add_assoc]
     apply Nat.le_add_sub

theorem Nat.lt_of_sub_add : ∀ (m k n : Nat),
  k < m →
  n > 0 →
  m - (k + n) < m - k := by
  intros m k n hkm hn
  -- have h1 : m - (k + n) ≤ m - k - n :=
  apply Nat.lt_of_le_of_lt (m := m - k - n)
  . apply Nat.le_of_eq (@Nat.sub_add_eq_sub_sub m k n)
  . apply Nat.sub_lt
    . exact Nat.zero_lt_sub_of_lt hkm
    . exact hn

theorem Nat.lt_of_not_ge (x y : Nat) (h : ¬(x ≥ y)) : x < y :=
by unfold LT.lt
   unfold instLTNat
   unfold Nat.lt
   simp only
   have h' : Nat.le (Nat.succ x) y = ((x + 1) ≤ y) := rfl
   rw [h']
   rw [←Nat.not_le_eq]
   apply h

-- I suspect this is probably built in somewhere, but I'm not finding it
-- def Int.abs (z : Int) := if z < 0 then -z else z

def Int.abs : Int → Nat
| Int.ofNat n => n
| Int.negSucc n => n.succ

theorem Int.toNat_of_ofNat_inj : ∀ z : Int, z ≥ 0 → Int.ofNat (z.toNat) = z :=
by intros z h
   cases z with
   | ofNat n => simp [toNat, ofNat]
   | negSucc n => contradiction

theorem Int.abs_of_nonneg_eq_toNat : ∀ z : Int, z ≥ 0 → z.abs = z.toNat :=
by intros z h
   cases z with
   | ofNat n => simp [toNat, ofNat, abs]
   | negSucc n => contradiction

theorem Int.neg_succ_eq_neg_ofNat_succ (n : Nat) :
  Int.negSucc n = -(Int.ofNat n.succ) :=
by unfold Neg.neg
   unfold instNegInt
   unfold Int.neg
   simp only [negOfNat]

theorem Int.add_neg_eq_sub (m n : Int) : n < 0 → m + n = m - n.abs :=
by intros h
   simp only at h
   cases n with
   | ofNat n => contradiction
   | negSucc n =>
     simp only [abs]
     unfold HSub.hSub
     unfold instHSub
     unfold Sub.sub
     unfold Int.instSubInt
     unfold Int.sub
     simp only
     rw [neg_succ_eq_neg_ofNat_succ]

-- Is this really not in the library yet, or am I missing something?
theorem Int.add_comm : ∀ (x y : Int), x + y = y + x :=
by intros x y
   unfold HAdd.hAdd
   unfold instHAdd
   unfold Add.add
   unfold instAddInt
   unfold Int.add
   induction x with
   | ofNat n =>
     cases y with
     | ofNat m => simp [Nat.add_comm]
     | negSucc m => simp
   | negSucc n =>
     cases y with
     | ofNat m => simp
     | negSucc m => simp [Nat.add_comm]

-- BEGIN `groupByKey`
-- (Contains infrastructure for `groupBy`, as well as some extra proofs that
-- aren't used but might be useful in the future.)

-- TODO: figure out where De Morgan's laws are hiding in the library...
-- (There's `Decidable.not_and_iff_or_not`, but why should we require
-- decidability?)
theorem not_or_distrib : ¬ (a ∨ b) ↔ ¬a ∧ ¬b :=
Iff.intro
(λ h => And.intro (λ ha => h (Or.intro_left _ ha))
                  (λ hb => h (Or.intro_right _ hb)))
(λ h => λ hneg =>
  match hneg with
  | Or.inl ha => h.left ha
  | Or.inr hb => h.right hb)

-- Again, this must be in the library somewhere...
theorem And.comm : p ∧ q ↔ q ∧ p :=
  Iff.intro (λ h => And.intro h.right h.left) (λ h => And.intro h.right h.left)

theorem Iff.not_iff_not_of_iff : (p ↔ q) → (¬ p ↔ ¬ q) := λ hpq =>
  Iff.intro (λ hnp hq => hnp $ hpq.mpr hq) (λ hnq hp => hnq $ hpq.mp hp)

theorem Decidable.prop_eq_of_decide_eq (p q : Prop)
  [ip : Decidable p] [iq : Decidable q] :
  p = q → decide p = decide q := λ h =>
  by cases h
     apply congr
     . simp
     . apply eq_of_heq
       apply Subsingleton.helim
       rfl

def List.matchKey {κ ν} [DecidableEq κ]
    : List (κ × ν) → κ → List ν × List (κ × ν)
| [], _ => ([], [])
| (k, v) :: kvs, x =>
  let res := matchKey kvs x
  if k = x
  then (v :: res.1, res.2)
  else (res.1, (k, v) :: res.2)

theorem List.matchKey_snd_length {κ ν} [DecidableEq κ] :
    ∀ (xs : List (κ × ν)) (k : κ), (matchKey xs k).2.length ≤ xs.length :=
by intros xs k
   induction xs with
   | nil => exact Nat.le.refl
   | cons x xs ih =>
     simp only [matchKey]
     apply @Decidable.byCases (x.1=k) _
     . intros heq
       simp only [heq]
       rw [ite_true]
       simp only [Prod.snd]
       apply Nat.le_step
       exact ih
     . intros hneq
       simp only [hneq]
       rw [ite_false]
       simp only [Prod.fst]
       apply Nat.succ_le_succ
       exact ih

theorem List.matchKey_lengths_sum {κ ν} [inst : DecidableEq κ] :
  ∀ (xs : List (κ × ν)) (k : κ),
  (matchKey xs k).1.length + (matchKey xs k).2.length = xs.length :=
by intros xs k
   induction xs with
   | nil => rfl
   | cons x xs ih =>
     simp only [matchKey]
     cases inst x.1 k with
     | isFalse hfalse =>
       simp only [hfalse, ite_false, List.length]
       rw [←Nat.add_assoc]
       apply congrArg (·+1) ih
     | isTrue htrue =>
       simp only [htrue, ite_true, List.length]
       rw [Nat.add_assoc, Nat.add_comm 1, ←Nat.add_assoc]
       apply congrArg (·+1) ih

theorem List.matchKey_snd_keys_neq_k_map [DecidableEq κ] (xs : List (κ × ν)) :
  ∀ e, e ∈ (List.map Prod.fst (matchKey xs k).snd) → e ≠ k :=
by intros e hsnd
   induction xs with
   | nil => cases hsnd
   | cons x xs ih =>
     cases Decidable.em (x.1 = k) with
     | inl heq =>
       apply ih
       simp only [matchKey, heq, ite_true] at hsnd
       exact hsnd
     | inr hneq =>
       simp only [matchKey, hneq, ite_false] at hsnd
       cases hsnd with
       | head => exact hneq
       | tail _ hin => exact ih hin

theorem List.fst_mem_of_pair_mem : ∀ (x : α) (y : β) (ps : List (α × β)),
  (x, y) ∈ ps → x ∈ (map Prod.fst ps)
| x, y, [], hxy => by contradiction
| x, y, _ :: ps, List.Mem.head _ _ => List.Mem.head _ _
| x, y, _ :: ps, List.Mem.tail a h => Mem.tail _ $ fst_mem_of_pair_mem x y ps h

theorem List.matchKey_snd_keys_neq_k [DecidableEq κ] (xs : List (κ × ν)) :
  ∀ e, e ∈ (matchKey xs k).snd → e.fst ≠ k := λ e he =>
matchKey_snd_keys_neq_k_map xs e.fst
  (List.fst_mem_of_pair_mem e.1 e.2 (matchKey xs k).snd he)

-- TODO: should we use `List.eraseDups` instead? (Uses BEq instead of DEq.)
def List.uniqueAux {α} [DecidableEq α] : List α → List α → List α
| [], acc => acc.reverse
| x :: xs, acc => if x ∈ acc then uniqueAux xs acc else uniqueAux xs (x :: acc)

def List.unique {α} [inst : DecidableEq α] (xs : List α) := uniqueAux xs []

def List.no_duplicates [DecidableEq α] (xs : List α) := unique xs = xs

inductive List.NoDuplicates {α} : List α → Prop
| nil : NoDuplicates []
| cons x xs : x ∉ xs → NoDuplicates xs → NoDuplicates (x :: xs)

def List.uniqueFoldl [DecidableEq α] (xs : List α) :=
  xs.foldl (λ acc x => if x ∈ acc then acc else acc ++ [x]) []

theorem List.mem_append_singleton : ∀ (x : α) (xs : List α), x ∈ xs ++ [x]
| x, [] => List.Mem.head _ _
| x, y :: ys => List.Mem.tail _ (mem_append_singleton x ys)

theorem List.mem_append_front :
  ∀ (x : α) (xs ys : List α), x ∈ xs → x ∈ xs ++ ys
| x, _ :: xs, ys, List.Mem.head _ _ => List.Mem.head _ _
| x, x' :: xs, ys, List.Mem.tail _ h =>
  List.Mem.tail x' (mem_append_front x xs ys h)

theorem List.mem_reverse_iff (x : α) (xs : List α) :
  x ∈ xs ↔ x ∈ reverse xs := by
  rw [reverse_eq_reverseSpec]
  apply Iff.intro
  . intro hf
    induction hf with
    | head x xs =>
      simp only [reverseSpec]
      apply mem_append_singleton
    | @tail y x ys h_x_ys ih =>
      simp only [reverseSpec]
      apply mem_append_front _ _ _ ih
  . intro hb
    induction xs with
    | nil => contradiction
    | cons y ys ih =>
      simp only [reverseSpec] at hb
      admit

theorem List.unique_eq_uniqueFold_aux [DecidableEq α] :
  ∀ (xs : List α) (acc : List α),
  uniqueAux xs acc =
    foldl (λ acc x => if x ∈ acc then acc else acc ++ [x]) (reverse acc) xs := sorry
  --   by
  -- intros xs acc
  -- induction xs generalizing acc with
  -- | nil => simp [uniqueAux, foldl]
  -- | cons x xs ih =>
  --   simp only [uniqueAux, foldl]
  --   cases Decidable.em (x ∈ acc) with
  --   | inl h =>
  --     simp only [h, ite_true]
  --     conv =>
  --       rhs
  --       lhs
  --       have : (if x ∈ reverse acc then reverse acc else reverse acc ++ [x]) =
  --              if x ∈ acc then reverse acc else reverse acc ++ [x] := by rw [mem_reverse_iff]

theorem List.unique_eq_uniqueFold [DecidableEq α] :
  ∀ (xs : List α), unique xs = uniqueFoldl xs := by
  intros xs
  induction xs with
  | nil => simp [unique, uniqueFoldl, uniqueAux, foldl]
  | cons x xs ih =>
    simp only [unique, uniqueFoldl, uniqueAux]
    simp only [List.not_mem_nil, ite_false]
    rw [unique_eq_uniqueFold_aux]
    simp only [foldl]
    apply congrArg
    rfl

theorem List.all_pred {p : α → Prop} [DecidablePred p] {xs : List α} :
  xs.all (λ x => decide (p x)) ↔ ∀ x, x ∈ xs → p x := by
  simp only [all]
  apply Iff.intro
  . intros hforward x hx
    induction hx with
    | head a as =>
      simp [foldr] at hforward
      apply And.left hforward
    | tail a h ih =>
      apply ih
      simp [foldr] at hforward
      apply And.right hforward
  . intros hbackward
    induction xs with
    | nil => simp [foldr]
    | cons x xs ih =>
      simp [foldr]
      apply And.intro
      . apply hbackward x (List.Mem.head _ _)
      . apply ih
        intro x' hx'
        apply hbackward _ $ List.Mem.tail _ hx'

-- This didn't end up getting used for the `length_groupByKey` proof, but I'm
-- keeping it around just in case
@[instance] def List.forAllDecidable (xs : List α) (p : α → Prop)
  [DecidablePred p] : Decidable (∀x, x ∈ xs → p x) :=
if h : xs.all (λ x => decide (p x))
then Decidable.isTrue (List.all_pred.mp h)
else Decidable.isFalse (h ∘ List.all_pred.mpr)

def List.unique' {α} [DecidableEq α] : List α → List α
| [] => []
| x :: xs =>
  let ys := unique' xs
  if ∀ y, y ∈ ys → x ≠ y then x :: ys else ys

theorem List.mem_singleton_iff (x y : α) : x ∈ [y] ↔ x = y := by
  apply Iff.intro
  . intros hin
    cases hin
    . rfl
    . contradiction
  . intros heq
    rw [heq]
    apply Mem.head

theorem List.mem_cons_iff_mem_singleton_or_tail (y : α) (ys : List α) (x : α) :
  x ∈ y :: ys ↔ x ∈ [y] ∨ x ∈ ys := by
  apply Iff.intro
  . intro hf
    cases hf with
    | head => apply Or.intro_left _ (Mem.head _ _)
    | tail _ h => apply Or.intro_right _ h
  . intro hb
    cases hb with
    | inl h => rw [(mem_singleton_iff x y).mp h]; apply Mem.head
    | inr h => apply Mem.tail _ h

-- TODO: it would make more sense to use `&&` instead of `∧` since this is a
-- "data function." However, `∧` is better for the `length_groupByKey` proof, so
-- I'm leaving it, at least for now.
theorem List.filter_filter (p₁ p₂ : α → Bool) (xs : List α) :
  filter p₁ (filter p₂ xs) = filter (λ x => p₂ x ∧ p₁ x) xs := by
  -- filter p₁ (filter p₂ xs) = filter (λ x => p₂ x ∧ p₁ x) xs := by
  rw [filter_eq_filterSpec, filter_eq_filterSpec, filter_eq_filterSpec]
  induction xs with
  | nil => simp [filterSpec]
  | cons x xs ih =>
    cases h₂ : p₂ x with
    | false =>
      simp only [filterSpec, h₂, ite_false]
      exact ih
    | true =>
      simp only [filterSpec, h₂, ite_true]
      cases h₁ : p₁ x with
      | false =>
        simp only [filterSpec, h₁, h₂, ite_false]
        exact ih
      | true =>
        simp only [filterSpec, h₁, h₂, ite_true]
        exact congrArg _ ih

theorem List.uniqueAux_acc_append_filter {α} [DecidableEq α] :
  ∀ (xs acc : List α),
  uniqueAux xs acc = reverse acc ++ unique (xs.filter (· ∉ acc))
| [], acc => by simp [uniqueAux, reverse, reverseAux, unique]
| x :: xs, acc =>
  have hterm : length (filter (λ a => !decide (a ∈ acc)) xs)
                < Nat.succ (length xs) :=
    Nat.lt_of_le_of_lt (m := length xs) (filter_length _ _) (Nat.lt.base _)
  have ih₁ := uniqueAux_acc_append_filter xs acc
  have ih₂ := uniqueAux_acc_append_filter xs (x :: acc)
  have ih₃ :=
    uniqueAux_acc_append_filter (filter (λ a => decide ¬a ∈ acc) xs) [x]
  by
    simp only [uniqueAux, filter, filterAux]
    cases Decidable.em (x ∈ acc) with
    | inl hin =>
      simp only [hin, ite_true]
      -- TODO: this shouldn't be necessary
      have : decide False = false := rfl
      rw [this]
      simp only
      rw [ih₁]
      simp only [filter]
    | inr hout =>
      -- Case x is not already in the accumulator
      simp only [hout, ite_false]
      have : decide True = true := rfl
      rw [this]
      simp only [filterAux_spec, reverse_singleton, singleton_append, unique,
                 uniqueAux, List.not_mem_nil, ite_false]
      rw [ih₂]
      simp only [reverse_cons, append_assoc, singleton_append]
      apply congrArg
      simp only [unique]
      rw [ih₃]
      rw [reverse_singleton, singleton_append, filter_filter]
      have : (λ x_1 => decide (
              (decide ¬x_1 ∈ acc) = true ∧ (decide ¬x_1 ∈ [x]) = true)
             ) = (λ x_1 => decide (¬x_1 ∈ acc ∧ ¬x_1 ∈ [x])) :=
        by simp
      rw [this, ←unique]
      apply congrArg
      apply congrArg
      have h_mem_iff := mem_cons_iff_mem_singleton_or_tail x acc
      have h_mem_iff_neg := (λ x => Iff.not_iff_not_of_iff $ h_mem_iff x)
      apply congr _ rfl
      apply congr rfl
      apply funext
      intros a
      apply Decidable.prop_eq_of_decide_eq
      rw [h_mem_iff_neg, not_or_distrib, And.comm]
termination_by uniqueAux_acc_append_filter xs ac => xs.length

theorem List.uniqueAux_acc_append {α} [DecidableEq α] (xs : List α)
  (acc : List α) (h : ∀ x, x ∈ xs → ¬ (x ∈ acc)) :
  uniqueAux xs acc = reverse acc ++ unique xs := by
  have : filter (fun a => decide ¬a ∈ acc) xs = xs := by
    induction xs with
    | nil => simp [filter, filterAux]
    | cons x xs ih =>
      simp only [filter, filterAux]
      have : decide (¬x ∈ acc) = true := by simp [h x (Mem.head _ _)]
      rw [this]
      simp only
      rw [filterAux_spec, ih, reverse_singleton, singleton_append]
      . intros x hx
        apply h x (Mem.tail _ hx)
  rw [uniqueAux_acc_append_filter]
  cases xs with
  | nil => apply congrArg; simp [filter, filterAux]
  | cons x xs =>
    apply congrArg
    rw [this]

theorem List.length_uniqueAux {α} [DecidableEq α]
  (xs : List α) (acc : List α) (h : ∀ x, x ∈ xs → ¬ (x ∈ acc)) :
  length (uniqueAux xs acc) = length (unique xs) + length acc := by
  rw [uniqueAux_acc_append _ _ h, length_append, length_reverse, Nat.add_comm]

theorem List.matchKey_fst_eq_filter_k_map_snd {κ ν} [inst : DecidableEq κ] :
  ∀ (xs : List (κ × ν)) (k : κ),
    (matchKey xs k).1 = (xs.filter (λ x => x.1 = k)).map Prod.snd :=
by intros xs k
   simp only [List.filter]
   induction xs with
   | nil => rfl
   | cons x xs ih =>
     simp only [matchKey]
     cases inst x.1 k with
     | isFalse hfalse =>
       simp only [hfalse, ite_false, List.filterAux, ih]
       exact rfl
     | isTrue htrue =>
       simp only [htrue, ite_true, List.filterAux, ih]
       -- TODO: why won't Lean reduce `match decide True with...` to the
       -- `true` arm automatically? This workaround works but is ugly.
       have h :
        (x.2 :: List.map Prod.snd (List.filterAux
            (λ x => decide (x.fst = k)) xs []) =
          List.map Prod.snd
            (match decide True with
            | true => List.filterAux (fun x => decide (x.fst = k)) xs [x]
            | false => List.filterAux (fun x => decide (x.fst = k)) xs []))
        = (x.2 :: List.map Prod.snd (List.filterAux
            (λ x => decide (x.fst = k)) xs []) =
          List.map Prod.snd (List.filterAux
            (fun x => decide (x.fst = k)) xs [x])) := rfl
       simp only at h
       apply cast (Eq.symm h)
       have h_filterAux := List.filterAux_acc_eq_rev_append
                            (λ x => decide (x.fst = k)) xs [x] []
       rw [List.nil_append, List.reverse_singleton, List.singleton_append]
        at h_filterAux
       rw [h_filterAux]
       simp only [List.map]

def List.groupByKey {κ} [DecidableEq κ] {ν} : List (κ × ν) → List (κ × List ν)
| [] => []
| (k, v) :: kvs =>
  have h_help : (matchKey kvs k).2.length < kvs.length.succ :=
    Nat.lt_of_succ_le $ Nat.succ_le_succ $ matchKey_snd_length kvs k

  let fms := matchKey kvs k
  (k, v :: fms.1) :: groupByKey fms.2
termination_by groupByKey xs => xs.length
decreasing_by assumption

theorem List.groupByKey_matchKey_snd_length_cons [DecidableEq κ]
  (k : κ) (v : ν) (xs : List (κ × ν)) :
  1 + length (groupByKey (matchKey ((k, v) :: xs) k).snd)
    = (groupByKey ((k, v) :: xs)).length :=
calc
  1 + length (groupByKey (matchKey ((k, v) :: xs) k).2)
  = 1 + length (groupByKey (matchKey xs k).2) :=
    by simp only [matchKey, length, ite_true]
  _ = length (groupByKey (matchKey xs k).2) + 1 := Nat.add_comm _ _
  _ = length ((k, v :: (matchKey xs k).1) :: groupByKey (matchKey xs k).2) :=
    rfl
  _ = length (groupByKey ((k, v) :: xs)) := rfl

theorem List.length_uniqueAux_matchKey {κ ν} [DecidableEq κ]
  (xs : List (κ × ν)) (k : κ) :
  ∀ (acc : List κ) (hk : k ∈ acc),
  (uniqueAux (map Prod.fst xs) acc).length
  = (uniqueAux (map Prod.fst (matchKey xs k).snd) acc).length :=
by induction xs with
   | nil => intros; simp [uniqueAux]
   | cons x xs ih =>
     intros acc hk
     simp only [length, uniqueAux]
     cases Decidable.em (x.fst ∈ acc) with
     | inl hin =>
       simp only [hin, ite_true, matchKey]
       rw [ih _ hk]
       cases Decidable.em (x.1 = k) with
       | inl heq => simp only [heq, ite_true]
       | inr hneq => simp only [hneq, ite_false, map, uniqueAux, hin, ite_true]
     | inr hout =>
       simp only [hout, ite_false, matchKey]
       cases Decidable.em (x.1 = k) with
       | inl heq =>
         apply absurd hk
         rw [heq] at hout
         exact hout
       | inr hneq =>
         rw [ih _ (List.Mem.tail _ hk)]
         simp only [hneq, ite_false, uniqueAux, hout]

instance (y : Nat) : Decidable (∀ x : Nat, x - y = x) :=
if h : y = 0
then Decidable.isTrue (λ x => by rw [h]; simp)
else Decidable.isFalse (λ x => by
  have h1 : 1 - y = 1 := x 1
  have : y > 0 := Nat.zero_lt_of_ne_zero h
  have := Nat.sub_lt (Nat.lt.base 0) this
  apply absurd h1
  apply Nat.ne_of_lt this)

theorem List.length_groupByKey {κ} [DecidableEq κ] {ν} :
  ∀ (xs : List (κ × ν)),
  length (groupByKey xs) = (xs.map Prod.fst).unique.length
| [] => rfl
| (k, v) :: xs => by
  have hterm : length (matchKey xs k).snd < Nat.succ (length xs) :=
    Nat.lt_of_succ_le $ Nat.succ_le_succ $ matchKey_snd_length xs k
  have ih := length_groupByKey (matchKey xs k).2
  simp only [map, unique, uniqueAux, List.not_mem_nil, ite_false, groupByKey]
  -- This needs to be a separate `simp` to ensure proper ordering
  simp only [length]
  rw [length_uniqueAux_matchKey _ k _ $ List.Mem.head _ _]
  rw [ih]
  apply Eq.symm
  apply List.length_uniqueAux (acc := [k])
  intro x
  rw [mem_singleton_iff]
  apply matchKey_snd_keys_neq_k_map (k := k) xs
termination_by length_groupByKey xs => length xs
decreasing_by assumption
-- END `groupByKey`

-- `List.counts`, helper functions, and associated theorems
-- TODO: these proofs could probably be cleaned up a lot.
def List.incrCounts {α} [DecidableEq α] :
  List (α × Nat) → α → List (α × Nat)
| [], v => [(v, 1)]
| (t, n) :: rs, v =>
  if t = v then (t, n + 1) :: rs else (t, n) :: incrCounts rs v

def List.counts {α} [DecidableEq α] (xs : List α) : List (α × Nat) :=
  xs.foldl (λ acc v => incrCounts acc v) []

theorem List.map_fst_incrCounts_eq_map_fst [DecidableEq α] (x : α) :
  ∀ (as : List (α × Nat)) (h : x ∈ map Prod.fst as),
  map Prod.fst (incrCounts as x) = map Prod.fst as
| (.(x), _) :: as, List.Mem.head _ _ => by simp only [map, incrCounts]
| a :: as, List.Mem.tail _ h' =>
  have ih := map_fst_incrCounts_eq_map_fst x as h'
  match Decidable.em (a.1 = x) with
  | .inl heq => by simp only [map, incrCounts, heq, ite_true, map]
  | .inr hneq => by
      simp only [hneq, ite_false, map, incrCounts]
      exact congrArg _ ih

theorem not_not (p : Prop) : p → ¬¬p := λ hp hneg => hneg hp

theorem List.map_fst_incrCounts_eq_cons_fst [DecidableEq α] (x : α) :
  ∀ (as : List (α × Nat)) (h : x ∉ map Prod.fst as),
  map Prod.fst (incrCounts as x) = map Prod.fst as ++ [x] := by
  intros as h
  induction as with
  | nil =>
    simp only [incrCounts, map, HAppend.hAppend, Append.append, List.append]
  | cons a as ih =>
    simp only [map, incrCounts]
    cases Decidable.em (a.1 = x) with
    | inl heq =>
      apply absurd h
      apply not_not
      simp only [map, heq]
      apply List.Mem.head
    | inr hneq =>
      simp only [hneq, ite_false, map]
      apply congrArg
      apply ih
      . intros hneg
        apply h
        apply List.Mem.tail _ hneg

#check List.mem_append_singleton

theorem List.mem_append_back (x : α) : ∀ (xs ys : List α),
  x ∈ ys → x ∈ xs ++ ys
| [], ys, hin => hin
| z :: xs, ys, hin => List.Mem.tail _ (mem_append_back x xs ys hin)

theorem List.mem_append_iff {x : α} {xs ys : List α} :
  (x ∈ xs ∨ x ∈ ys) ↔ x ∈ xs ++ ys := by
  apply Iff.intro
  . intros hf
    cases hf with
    | inl hxs => apply mem_append_front _ _ _ hxs
    | inr hys => apply mem_append_back _ _ _ hys
  . intros hb
    induction xs with
    | nil => exact Or.intro_right _ hb
    | cons z xs ih =>
      cases hb with
      | head _ _ => apply Or.intro_left _ (List.Mem.head _ _)
      | tail _ h' =>
        cases ys with
        | nil =>
          apply Or.intro_left
          apply List.Mem.tail
          simp at h'
          exact h'
        | cons y ys =>
          simp at h'
          cases ih h' with
          | inl hxxs =>
            apply Or.intro_left
            exact List.Mem.tail _ hxxs
          | inr hxys =>
            exact Or.intro_right _ hxys

theorem List.length_uniqueAux_congr_append_cons_acc [DecidableEq α]
  (x y : α) (as xs : List α) (cs : List α) :
  length (uniqueAux xs (cs ++ x :: (as ++ [y]))) =
  length (uniqueAux xs (cs ++ y :: x :: as)) := by
  induction xs generalizing cs with
  | nil =>
    simp [uniqueAux]
    rw [←Nat.add_one,
        Nat.add_assoc,
        Nat.add_comm (length cs),
        ←Nat.add_assoc]
  | cons z zs ih =>
    have rearrange_mem :
      (z ∈ cs ++ x :: (as ++ [y])) ↔ (z ∈ cs ++ y :: x :: as) := by
      apply Iff.intro
      . intros h
        cases mem_append_iff.mpr h with
        | inl hcs => exact List.mem_append_front _ _ _ hcs
        | inr hcons =>
          apply List.mem_append_back
          rw [←cons_append] at hcons
          cases mem_append_iff.mpr hcons with
          | inl hxas => exact List.Mem.tail _ hxas
          | inr hy =>
            cases hy with
            | tail _ _ => contradiction
            | head _ _ => exact List.Mem.head _ _
      . intros h
        cases mem_append_iff.mpr h with
        | inl hcs => exact List.mem_append_front _ _ _ hcs
        | inr hcons =>
          apply List.mem_append_back
          cases hcons with
          | head _ _ =>
            apply List.Mem.tail
            apply List.mem_append_back
            apply (List.mem_singleton_iff y y).mpr rfl
          | tail _ hcons' =>
            rw [←cons_append]
            exact List.mem_append_front _ _ _ hcons'

    simp only [uniqueAux]
    cases Decidable.em (z ∈ cs ++ x :: (as ++ [y])) with
    | inl hin =>
      simp only [hin, rearrange_mem.mp hin, ite_true]
      apply ih
    | inr hout =>
      simp only [hout, rearrange_mem.not_iff_not_of_iff.mp hout, ite_false]
      have rw_help (stuff) : (z :: (cs ++ stuff)) = ((z :: cs) ++ stuff) := rfl
      rw [rw_help, rw_help]
      apply ih

theorem List.length_counts_aux [DecidableEq α]
  (xs : List α) (acc : List (α × Nat)) :
  List.length (foldl (λ acc v => incrCounts acc v) acc xs) =
  List.length (uniqueAux xs (acc.map Prod.fst)) := by
  induction xs generalizing acc with
  | nil => simp [foldl, uniqueAux]
  | cons x xs ih =>
    simp only [uniqueAux, foldl]
    cases acc with
    | nil =>
      simp only [incrCounts, map, List.not_mem_nil, ite_false]
      apply ih
    | cons a as =>
      simp only [incrCounts]
      cases Decidable.em (a.1 = x) with
      | inl htrue =>
        simp only [htrue, ite_true, incrCounts, map]
        rw [if_pos]
        . apply ih
        . exact List.Mem.head _ _
      | inr hfalse =>
        simp only [hfalse, ite_false, incrCounts, map]
        rw [ih]
        cases Decidable.em (x ∈ map Prod.fst as) with
        | inl hin =>
          have : x ∈ a.1 :: map Prod.fst as := List.Mem.tail _ hin
          simp only [this, ite_true, map, uniqueAux]
          apply congrArg
          apply congrArg
          apply congrArg
          exact map_fst_incrCounts_eq_map_fst x as hin
        | inr hout =>
          have : ¬ (x ∈ a.1 :: map Prod.fst as) := by
            intros hneg; cases hneg; repeat contradiction
          simp only [this, ite_false, map]
          rw [map_fst_incrCounts_eq_cons_fst _ _ hout]
          apply List.length_uniqueAux_congr_append_cons_acc _ _ _ _ []

theorem List.length_counts [DecidableEq α] (xs : List α) :
  xs.counts.length = xs.unique.length :=
  length_counts_aux xs []
-- End `counts` work