/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import data.equiv.basic
import control.equiv_functor

/-!
# Equivalences for `option α`

We define `remove_none` which acts to provide a `e : α ≃ β` if given a `f : option α ≃ option β`.

To construct an `f : option α ≃ option β` from `e : α ≃ β` such that
`f none = none` and `f (some x) = some (e x)`, use
`f = equiv_functor.map_equiv option e`.
-/

namespace equiv

variables {α β : Type*} (e : option α ≃ option β)

private def remove_none_aux (x : α) : β :=
if h : (e (some x)).is_some
  then option.get h
  else option.get $ show (e none).is_some, from
  begin
    rw ←option.ne_none_iff_is_some,
    intro hn,
    rw [option.not_is_some_iff_eq_none, ←hn] at h,
    simpa only using e.injective h,
  end

private lemma remove_none_aux_some {x : α} (h : ∃ x', e (some x) = some x') :
  some (remove_none_aux e x) = e (some x) :=
by simp [remove_none_aux, option.is_some_iff_exists.mpr h]

private lemma remove_none_aux_none {x : α} (h : e (some x) = none) :
  some (remove_none_aux e x) = e none :=
by simp [remove_none_aux, option.not_is_some_iff_eq_none.mpr h]

private lemma remove_none_aux_inv (x : α) : remove_none_aux e.symm (remove_none_aux e x) = x :=
option.some_injective _ begin
  cases h1 : e.symm (some (remove_none_aux e x)); cases h2 : (e (some x)),
  { rw remove_none_aux_none _ h1,
    exact (e.eq_symm_apply.mpr h2).symm },
  { rw remove_none_aux_some _ ⟨_, h2⟩ at h1,
    simpa using h1, },
  { rw remove_none_aux_none _ h2 at h1,
    simpa using h1, },
  { rw remove_none_aux_some _ ⟨_, h1⟩,
    rw remove_none_aux_some _ ⟨_, h2⟩,
    simp },
end

/-- Given an equivalence between two `option` types, eliminate `none` from that equivalence by
mapping `e.symm none` to `e none`. -/
def remove_none : α ≃ β :=
{ to_fun := remove_none_aux e,
  inv_fun := remove_none_aux e.symm,
  left_inv := remove_none_aux_inv e,
  right_inv := remove_none_aux_inv e.symm, }

@[simp]
lemma remove_none_symm : (remove_none e).symm = remove_none e.symm := rfl

lemma remove_none_some {x : α} (h : ∃ x', e (some x) = some x') :
  some (remove_none e x) = e (some x) := remove_none_aux_some e h

lemma remove_none_none {x : α} (h : e (some x) = none) :
  some (remove_none e x) = e none := remove_none_aux_none e h

@[simp] lemma option_symm_apply_none_iff : e.symm none = none ↔ e none = none :=
⟨λ h, by simpa using (congr_arg e h).symm, λ h, by simpa using (congr_arg e.symm h).symm⟩

lemma some_remove_none_iff {x : α} :
  some (remove_none e x) = e none ↔ e.symm none = some x :=
begin
  cases h : e (some x) with a,
  { rw remove_none_none _ h,
    simpa using (congr_arg e.symm h).symm },
  { rw remove_none_some _ ⟨a, h⟩,
    have := (congr_arg e.symm h),
    rw [symm_apply_apply] at this,
    simp only [false_iff, apply_eq_iff_eq],
    simp [this] }
end

@[simp]
lemma remove_none_map_equiv {α β : Type*} (e : α ≃ β) :
  remove_none (equiv_functor.map_equiv option e) = e :=
equiv.ext $ λ x, option.some_injective _ $ remove_none_some _ ⟨e x, by simp [equiv_functor.map]⟩

end equiv


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

universes v₁ u₁

namespace Mathlib

/-!
# Special coequalizers associated to a monad

Associated to a monad `T : C ⥤ C` we have important coequalizer constructions:
Any algebra is a coequalizer (in the category of algebras) of free algebras. Furthermore, this
coequalizer is reflexive.
In `C`, this cofork diagram is a split coequalizer (in particular, it is still a coequalizer).
This split coequalizer is known as the Beck coequalizer (as it features heavily in Beck's
monadicity theorem).
-/

namespace category_theory

namespace monad

/-!
Show that any algebra is a coequalizer of free algebras.
-/

/-- The top map in the coequalizer diagram we will construct. -/
@[simp] theorem free_coequalizer.top_map_f {C : Type u₁} [category C] {T : C ⥤ C} [monad T]
    (X : algebra T) : algebra.hom.f (free_coequalizer.top_map X) = functor.map T (algebra.a X) :=
  Eq.refl (functor.map T (algebra.a X))

/-- The bottom map in the coequalizer diagram we will construct. -/
def free_coequalizer.bottom_map {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) :
    functor.obj (free T) (functor.obj T (algebra.A X)) ⟶ functor.obj (free T) (algebra.A X) :=
  algebra.hom.mk (nat_trans.app μ_ (algebra.A X))

/-- The cofork map in the coequalizer diagram we will construct. -/
def free_coequalizer.π {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) :
    functor.obj (free T) (algebra.A X) ⟶ X :=
  algebra.hom.mk (algebra.a X)

theorem free_coequalizer.condition {C : Type u₁} [category C] {T : C ⥤ C} [monad T]
    (X : algebra T) :
    free_coequalizer.top_map X ≫ free_coequalizer.π X =
        free_coequalizer.bottom_map X ≫ free_coequalizer.π X :=
  algebra.hom.ext (free_coequalizer.top_map X ≫ free_coequalizer.π X)
    (free_coequalizer.bottom_map X ≫ free_coequalizer.π X) (Eq.symm (algebra.assoc X))

protected instance free_coequalizer.bottom_map.category_theory.is_reflexive_pair {C : Type u₁}
    [category C] {T : C ⥤ C} [monad T] (X : algebra T) :
    is_reflexive_pair (free_coequalizer.top_map X) (free_coequalizer.bottom_map X) :=
  is_reflexive_pair.mk' (functor.map (free T) (nat_trans.app η_ (algebra.A X)))
    (algebra.hom.ext
      (functor.map (free T) (nat_trans.app η_ (algebra.A X)) ≫ free_coequalizer.top_map X) 𝟙
      (id
        (eq.mpr
          (id
            (Eq._oldrec
              (Eq.refl
                (functor.map T (nat_trans.app η_ (algebra.A X)) ≫ functor.map T (algebra.a X) = 𝟙))
              (Eq.symm (functor.map_comp T (nat_trans.app η_ (algebra.A X)) (algebra.a X)))))
          (eq.mpr
            (id
              (Eq._oldrec
                (Eq.refl (functor.map T (nat_trans.app η_ (algebra.A X) ≫ algebra.a X) = 𝟙))
                (algebra.unit X)))
            (eq.mpr
              (id (Eq._oldrec (Eq.refl (functor.map T 𝟙 = 𝟙)) (functor.map_id T (algebra.A X))))
              (Eq.refl 𝟙))))))
    (algebra.hom.ext
      (functor.map (free T) (nat_trans.app η_ (algebra.A X)) ≫ free_coequalizer.bottom_map X) 𝟙
      (right_unit (functor.obj 𝟭 (algebra.A X))))

/--
Construct the Beck cofork in the category of algebras. This cofork is reflexive as well as a
coequalizer.
-/
@[simp] theorem beck_algebra_cofork_X {C : Type u₁} [category C] {T : C ⥤ C} [monad T]
    (X : algebra T) : limits.cocone.X (beck_algebra_cofork X) = X :=
  Eq.refl X

/--
The cofork constructed is a colimit. This shows that any algebra is a (reflexive) coequalizer of
free algebras.
-/
def beck_algebra_coequalizer {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) :
    limits.is_colimit (beck_algebra_cofork X) :=
  limits.cofork.is_colimit.mk' (beck_algebra_cofork X)
    fun (s : limits.cofork (free_coequalizer.top_map X) (free_coequalizer.bottom_map X)) =>
      { val :=
          algebra.hom.mk
            (nat_trans.app η_ (algebra.A (limits.cocone.X (beck_algebra_cofork X))) ≫
              algebra.hom.f (limits.cofork.π s)),
        property := sorry }

/-- The Beck cofork is a split coequalizer. -/
def beck_split_coequalizer {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) :
    is_split_coequalizer (functor.map T (algebra.a X)) (nat_trans.app μ_ (algebra.A X))
        (algebra.a X) :=
  is_split_coequalizer.mk (nat_trans.app η_ (algebra.A X))
    (nat_trans.app η_ (functor.obj T (algebra.A X))) sorry (algebra.unit X) sorry sorry

/-- This is the Beck cofork. It is a split coequalizer, in particular a coequalizer. -/
@[simp] theorem beck_cofork_X {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) :
    limits.cocone.X (beck_cofork X) = algebra.A X :=
  Eq.refl (algebra.A X)

/-- The Beck cofork is a coequalizer. -/
def beck_coequalizer {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) :
    limits.is_colimit (beck_cofork X) :=
  is_split_coequalizer.is_coequalizer (beck_split_coequalizer X)

end Mathlib


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Robert Y. Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.mv_polynomial.counit
import Mathlib.data.mv_polynomial.invertible
import Mathlib.ring_theory.witt_vector.defs
import Mathlib.PostPort

universes u_4 u_5 u_1 u_2

namespace Mathlib

/-!
# Witt vectors

This file verifies that the ring operations on `witt_vector p R`
satisfy the axioms of a commutative ring.

## Main definitions

* `witt_vector.map`: lifts a ring homomorphism `R →+* S` to a ring homomorphism `𝕎 R →+* 𝕎 S`.
* `witt_vector.ghost_component n x`: evaluates the `n`th Witt polynomial
  on the first `n` coefficients of `x`, producing a value in `R`.
  This is a ring homomorphism.
* `witt_vector.ghost_map`: a ring homomorphism `𝕎 R →+* (ℕ → R)`, obtained by packaging
  all the ghost components together.
  If `p` is invertible in `R`, then the ghost map is an equivalence,
  which we use to define the ring operations on `𝕎 R`.
* `witt_vector.comm_ring`: the ring structure induced by the ghost components.

## Notation

We use notation `𝕎 R`, entered `\bbW`, for the Witt vectors over `R`.

## Implementation details

As we prove that the ghost components respect the ring operations, we face a number of repetitive
proofs. To avoid duplicating code we factor these proofs into a custom tactic, only slightly more
powerful than a tactic macro. This tactic is not particularly useful outside of its applications
in this file.
-/

namespace witt_vector

/-- `f : α → β` induces a map from `𝕎 α` to `𝕎 β` by applying `f` componentwise.
If `f` is a ring homomorphism, then so is `f`, see `witt_vector.map f`. -/
def map_fun {p : ℕ} {α : Type u_4} {β : Type u_5} (f : α → β) : witt_vector p α → witt_vector p β :=
  fun (x : witt_vector p α) => f ∘ x

namespace map_fun

theorem injective {p : ℕ} {α : Type u_4} {β : Type u_5} (f : α → β) (hf : function.injective f) :
    function.injective (map_fun f) :=
  fun (x y : witt_vector p α) (h : map_fun f x = map_fun f y) =>
    funext fun (n : ℕ) => hf (congr_fun h n)

theorem surjective {p : ℕ} {α : Type u_4} {β : Type u_5} (f : α → β) (hf : function.surjective f) :
    function.surjective (map_fun f) :=
  sorry

/-- Auxiliary tactic for showing that `map_fun` respects the ring operations. -/
/- We do not tag these lemmas as `@[simp]` because they will be bundled in `map` later on. -/

theorem zero {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R]
    [comm_ring S] (f : R →+* S) : map_fun (⇑f) 0 = 0 :=
  sorry

theorem one {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R]
    [comm_ring S] (f : R →+* S) : map_fun (⇑f) 1 = 1 :=
  sorry

theorem add {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R]
    [comm_ring S] (f : R →+* S) (x : witt_vector p R) (y : witt_vector p R) :
    map_fun (⇑f) (x + y) = map_fun (⇑f) x + map_fun (⇑f) y :=
  sorry

theorem sub {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R]
    [comm_ring S] (f : R →+* S) (x : witt_vector p R) (y : witt_vector p R) :
    map_fun (⇑f) (x - y) = map_fun (⇑f) x - map_fun (⇑f) y :=
  sorry

theorem mul {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R]
    [comm_ring S] (f : R →+* S) (x : witt_vector p R) (y : witt_vector p R) :
    map_fun (⇑f) (x * y) = map_fun (⇑f) x * map_fun (⇑f) y :=
  sorry

theorem neg {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R]
    [comm_ring S] (f : R →+* S) (x : witt_vector p R) : map_fun (⇑f) (-x) = -map_fun (⇑f) x :=
  sorry

end map_fun

end witt_vector

/-- An auxiliary tactic for proving that `ghost_fun` respects the ring operations. -/
namespace witt_vector

/-- Evaluates the `n`th Witt polynomial on the first `n` coefficients of `x`,
producing a value in `R`.
This function will be bundled as the ring homomorphism `witt_vector.ghost_map`
once the ring structure is available,
but we rely on it to set up the ring structure in the first place. -/
/- The following lemmas are not `@[simp]` because they will be bundled in `ghost_map` later on. -/

/-- The bijection between `𝕎 R` and `ℕ → R`, under the assumption that `p` is invertible in `R`.
In `witt_vector.ghost_equiv` we upgrade this to an isomorphism of rings. -/
/-- The commutative ring structure on `𝕎 R`. -/
protected instance comm_ring (p : ℕ) (R : Type u_1) [hp : fact (nat.prime p)] [comm_ring R] :
    comm_ring (witt_vector p R) :=
  function.surjective.comm_ring_sub (map_fun ⇑(mv_polynomial.counit R)) sorry sorry sorry sorry
    sorry sorry sorry

/-- `witt_vector.map f` is the ring homomorphism `𝕎 R →+* 𝕎 S` naturally induced
by a ring homomorphism `f : R →+* S`. It acts coefficientwise. -/
def map {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R] [comm_ring S]
    (f : R →+* S) : witt_vector p R →+* witt_vector p S :=
  ring_hom.mk (map_fun ⇑f) (map_fun.one f) (map_fun.mul f) (map_fun.zero f) (map_fun.add f)

theorem map_injective {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R]
    [comm_ring S] (f : R →+* S) (hf : function.injective ⇑f) : function.injective ⇑(map f) :=
  map_fun.injective (⇑f) hf

theorem map_surjective {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R]
    [comm_ring S] (f : R →+* S) (hf : function.surjective ⇑f) : function.surjective ⇑(map f) :=
  map_fun.surjective (⇑f) hf

@[simp] theorem map_coeff {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)]
    [comm_ring R] [comm_ring S] (f : R →+* S) (x : witt_vector p R) (n : ℕ) :
    coeff (coe_fn (map f) x) n = coe_fn f (coeff x n) :=
  rfl

/-- `witt_vector.ghost_map` is a ring homomorphism that maps each Witt vector
to the sequence of its ghost components. -/
def ghost_map {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] :
    witt_vector p R →+* ℕ → R :=
  ring_hom.mk ghost_fun ghost_fun_one ghost_fun_mul ghost_fun_zero ghost_fun_add

/-- Evaluates the `n`th Witt polynomial on the first `n` coefficients of `x`,
producing a value in `R`. -/
def ghost_component {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (n : ℕ) :
    witt_vector p R →+* R :=
  ring_hom.comp (ring_hom.apply (fun (i : ℕ) => R) n) ghost_map

theorem ghost_component_apply {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (n : ℕ)
    (x : witt_vector p R) :
    coe_fn (ghost_component n) x = coe_fn (mv_polynomial.aeval (coeff x)) (witt_polynomial p ℤ n) :=
  rfl

@[simp] theorem ghost_map_apply {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R]
    (x : witt_vector p R) (n : ℕ) : coe_fn ghost_map x n = coe_fn (ghost_component n) x :=
  rfl

/-- `witt_vector.ghost_map` is a ring isomorphism when `p` is invertible in `R`. -/
def ghost_equiv (p : ℕ) (R : Type u_1) [hp : fact (nat.prime p)] [comm_ring R] [invertible ↑p] :
    witt_vector p R ≃+* (ℕ → R) :=
  ring_equiv.mk (ring_hom.to_fun ghost_map) (equiv.inv_fun (ghost_equiv' p R)) sorry sorry sorry
    sorry

@[simp] theorem ghost_equiv_coe (p : ℕ) (R : Type u_1) [hp : fact (nat.prime p)] [comm_ring R]
    [invertible ↑p] : ↑(ghost_equiv p R) = ghost_map :=
  rfl

theorem ghost_map.bijective_of_invertible (p : ℕ) (R : Type u_1) [hp : fact (nat.prime p)]
    [comm_ring R] [invertible ↑p] : function.bijective ⇑ghost_map :=
  ring_equiv.bijective (ghost_equiv p R)

end Mathlib


/-!

# Probability theory in Lean

## About me

Hi, I am Jason and I've just graduated from Imperial College this summer and
I will be starting part III at Cambridge this fall. I've worked with Lean for
the past 3 years learning lean from Kevin and the experts on the Lean Zulip
chat. I mostly formalize probability theory nowadays with my most recent project
being the formalization of martingales. I also formalized a some linear algebra
(mostly stuff from the 2nd year linear algebra course at Imperial).

## About the project

In this project we will work with probability theory in Lean. I have a few
projects prepared but feel free to suggest something if theres something you
want to work with.

### Project outline

Heres the outline of what I intend to do:

- **Intro to measure theory**: Measure theory is fundamental to doing
probability theory rigorously so I will quickly go over the maths (if you
haven't seen it before) and also give a brief overview of the measure theory
that is in mathlib

- **Working with measure-theoretic probability theory**: You probably have used
notions such as random variable, expectation, conditional expectation in your
first year probability course. But really, what *is* a random variable? I will
quickly go through the maths here.

- **State of probability theory**: If you know a lot of probability theory
already you might be disappointed/exicted that probability theory is relatively
new for mathlib. I will go over what's there and what's not.

- **Projects**: Finally, we can start discussing the projects and get our hands
dirty by doing some Lean.

### The projects

Originally I had four projects in mind though it turns our one of them:
Doob's decomposition theorem was formalized by Rémy Degenne just two weeks ago.
Furthermore, one of the other project I had in mind - Kolmogorov's 0-1 law is
probably too easy (at least the martingale proof). As a result I
will offer two pre-planned projects (feel free to suggest others).

**The weak law of large numbers**
The weak law of large numbers (WLLN) is one of the famous limit theorems in
probability theory along side the strong law of large numbers (SLLN) and the
central limit theorem (CLT). Informally, the WLLN states that if I do a random
measurement multiple times, the average of the measurements should converge
(in some specific sense) to the true measurement.

The SLLN has been formalized in Lean by Sébastien Gouëzel while the CLT is not
doable at the moment (we don't have a theory of characteristic functions but
there are discussions on formalizing the Fourier transform which will get us
quite far). The WLLN, in contrast to what the name suggests, is not a direct
corrolary of the SLLN (though a more restrictive version of the WLLN is).
Luckily, the WLLN is much easier than the other two limit theorems and have a
chance of being formalized in a workshop. Even luckier, the WLLN is not yet
formalized in mathlib so if we manage to formalize it, we can PR it to the
library for others to use.

**The second Borel-Cantelli lemma**
The second Borel-Cantelli lemma is a fun result in probability theory which
tells you, under certain conditions, the probability of a sequence of events
happening infinitely often is certain.

Here's a fun application of the second Borel-Cantelli lemma.
Suppose we have a long jump event at every year where we record the longest
jumper of that year by `Xₙ`. Furthermore, suppose `Xₙ` is iid. following the law
`μ` where `μ(Xₙ ≤ r) < 1` for all `r ≥ 0` (e.g. χ² distribution). Then what is
the probability the record will be crushed infinitely many times?

I know two proofs of this theorem, a classical proof and a martingale proof.
The classical proof is what everyone is taught in a typical probability theory
course involving bounding a finite product. I personally don't like the
classical proof that much and I would prefer if we do the martingale proof.
The martingale proof involves a more general theorem known as Lévy's generalized
Borel-Cantelli. I formalized Lévy's generalized Borel-Cantelli quite recently so
we can directly use it. As the name suggests, this theorem generalizes the
Borel-cantelli lemmas though this implication is not trivial and will involve us
fiddling around with independence.

-/


import .archi .lib .word

namespace integers
open word

/- * Specialization to integers of size 8, 32, and 64 bits -/

def W8 : ℕ+ := ⟨8, dec_trivial⟩
def W16 : ℕ+ := ⟨16, dec_trivial⟩
def W32 : ℕ+ := ⟨32, dec_trivial⟩
def W64 : ℕ+ := ⟨64, dec_trivial⟩
def ptrofs.wordsize : ℕ+ := if archi.ptr64 then W64 else W32

def byte := word W8
def int32 := word W32
def int64 := word W64
def ptrofs := word ptrofs.wordsize

theorem byte.wordsize_dvd_modulus : wordsize W8 ∣ modulus W8 :=
wordsize_dvd_modulus 3 rfl

theorem int32.wordsize_dvd_modulus : wordsize W32 ∣ modulus W32 :=
wordsize_dvd_modulus 5 rfl

theorem int64.wordsize_dvd_modulus : wordsize W64 ∣ modulus W64 :=
wordsize_dvd_modulus 6 rfl

theorem ptrofs.wordsize_dvd_modulus :
  wordsize ptrofs.wordsize ∣ modulus ptrofs.wordsize :=
wordsize_dvd_modulus (if archi.ptr64 then 6 else 5)
  (by delta wordsize ptrofs.wordsize; cases archi.ptr64; refl)

instance byte.comm_ring   : comm_ring byte   := word.comm_ring
instance int32.comm_ring  : comm_ring int32  := word.comm_ring
instance int64.comm_ring  : comm_ring int64  := word.comm_ring
instance ptrofs.comm_ring : comm_ring ptrofs := word.comm_ring
instance byte.decidable_linear_order   : decidable_linear_order byte   := word.decidable_linear_order
instance int32.decidable_linear_order  : decidable_linear_order int32  := word.decidable_linear_order
instance int64.decidable_linear_order  : decidable_linear_order int64  := word.decidable_linear_order
instance ptrofs.decidable_linear_order : decidable_linear_order ptrofs := word.decidable_linear_order

namespace int64

def is_power2 (x : int64) : option int32 :=
ucoe <$> is_power2 x

lemma is_power2_rng (n logn) : is_power2 n = some logn → unsigned logn < 64 := sorry'

theorem is_power2_range (n logn) : is_power2 n = some logn → ltu logn 32 := sorry'

lemma is_power2_correct (n logn) : is_power2 n = some logn →
  unsigned n = 2^unsigned logn := sorry'

theorem mul_pow2 (x n logn) : is_power2 n = some logn →
  x * n = shl x (ucoe logn) := sorry'

theorem divu_pow2 (x n logn) : is_power2 n = some logn →
  divu x n = shru x (ucoe logn) := sorry'

/- Decomposing 64-bit ints as pairs of 32-bit ints -/

def loword (n : int64) : int32 := ucoe n

def hiword (n : int64) : int32 := ucoe (shru n 32)

def ofwords (hi lo : int32) : int64 := word.or (shl (ucoe hi) 32) (ucoe lo)

lemma bits_loword (n i) : i < 32 → test_bit (loword n) i = test_bit n i := sorry'

lemma bits_hiword (n i) : i < 32 → test_bit (hiword n) i = test_bit n (i + 32) := sorry'

lemma bits_ofwords (hi lo i) :
  test_bit (ofwords hi lo) i = if i < 32 then test_bit lo i else test_bit hi (i - 32) := sorry'

lemma lo_ofwords (hi lo) : loword (ofwords hi lo) = lo := sorry'

lemma hi_ofwords (hi lo) : hiword (ofwords hi lo) = hi := sorry'

lemma ofwords_recompose (n) : ofwords (hiword n) (loword n) = n := sorry'

lemma ofwords_add (lo hi) : ofwords hi lo = repr (unsigned hi * 2^32 + unsigned lo) := sorry'

lemma ofwords_add' (lo hi) : unsigned (ofwords hi lo) = unsigned hi * 2^32 + unsigned lo := sorry'

lemma ofwords_add'' (lo hi) : signed (ofwords hi lo) = signed hi * 2^32 + unsigned lo := sorry'

/- Expressing 64-bit operations in terms of 32-bit operations -/

lemma decompose_bitwise_binop {f : ∀ {w}, word w → word w → word w} {f' : bool → bool → bool} :
  (∀ {w} (x y : word w) (i : ℕ), i < wordsize w → test_bit (f x y) i = f' (test_bit x i) (test_bit y i)) →
  ∀ xh xl yh yl, f (ofwords xh xl) (ofwords yh yl) = ofwords (f xh yh) (f xl yl) := sorry'

lemma decompose_and : ∀ xh xl yh yl,
  word.and (ofwords xh xl) (ofwords yh yl) = ofwords (word.and xh yh) (word.and xl yl) :=
decompose_bitwise_binop @bits_and

lemma decompose_or : ∀ xh xl yh yl,
  word.or (ofwords xh xl) (ofwords yh yl) = ofwords (word.or xh yh) (word.or xl yl) :=
decompose_bitwise_binop @bits_or

lemma decompose_xor : ∀ xh xl yh yl,
  word.xor (ofwords xh xl) (ofwords yh yl) = ofwords (word.xor xh yh) (word.xor xl yl) :=
decompose_bitwise_binop @bits_xor

lemma decompose_not (xh xl) : word.not (ofwords xh xl) = ofwords (word.not xh) (word.not xl) := sorry'

lemma decompose_shl_1 (xh xl y) : unsigned y < 32 → shl (ofwords xh xl) (ucoe y) =
  ofwords (word.or (shl xh y) (shru xl (32 - y))) (shl xl y) := sorry'

lemma decompose_shl_2 (xh xl y) : 32 ≤ unsigned y → unsigned y < 64 →
  shl (ofwords xh xl) (ucoe y) = ofwords (shl xl (y - 32)) 0 := sorry'

lemma decompose_shru_1 (xh xl y) : unsigned y < 32 → shru (ofwords xh xl) (ucoe y) =
  ofwords (shru xh y) (word.or (shru xl y) (shl xh (32 - y))) := sorry'

lemma decompose_shru_2 (xh xl y) : 32 ≤ unsigned y → unsigned y < 64 →
  shru (ofwords xh xl) (ucoe y) = ofwords 0 (shru xh (y - 32)) := sorry'

lemma decompose_shr_1 (xh xl y) : unsigned y < 32 → shr (ofwords xh xl) (ucoe y) =
  ofwords (shr xh y) (word.or (shru xl y) (shl xh (32 - y))) := sorry'

lemma decompose_shr_2 (xh xl y) : 32 ≤ unsigned y → unsigned y < 64 →
  shr (ofwords xh xl) (ucoe y) = ofwords (shr xh (32 - 1)) (shr xh (y - 32)) := sorry'

lemma decompose_add (xh xl yh yl) : ofwords xh xl + ofwords yh yl =
  ofwords (xh + yh + (add_carry xl yl 0)) (xl + yl) := sorry'

lemma decompose_sub (xh xl yh yl) : ofwords xh xl - ofwords yh yl =
  ofwords (xh - yh - sub_borrow xl yl 0) (xl - yl) := sorry'

lemma decompose_sub' (xh xl yh yl) : ofwords xh xl - ofwords yh yl =
  ofwords (xh + word.not yh + add_carry xl (word.not yl) 1) (xl - yl) := sorry'

lemma mul_mulhu (x y) : ucoe x * ucoe y = ofwords (mulhu x y) (x * y) := sorry'

lemma decompose_mul (xh xl yh yl) : ofwords xh xl * ofwords yh yl =
  ofwords (mulhu xl yl + xl * yh + xh * yl) (xl * yl) := sorry'

lemma decompose_ltu (xh xl yh yl) :
  ltu (ofwords xh xl) (ofwords yh yl) ↔ if xh = yh then ltu xl yl else ltu xh yh := sorry'

lemma decompose_leu (xh xl yh yl) : ¬ltu (ofwords yh yl) (ofwords xh xl) ↔
  if xh = yh then ¬ltu yl xl else ltu xh yh := sorry'

lemma decompose_lt (xh xl yh yl) :
  ofwords xh xl < ofwords yh yl ↔ if xh = yh then xl < yl else xh < yh := sorry'

lemma decompose_le (xh xl yh yl) : ofwords xh xl ≤ ofwords yh yl ↔
  if xh = yh then xl ≤ yl else xh < yh := sorry'

lemma bytes_of_int64 (i) :
  (words_of_int 8 (unsigned i) : list byte) =
  words_of_int 4 (unsigned (loword i)) ++ words_of_int 4 (unsigned (hiword i)) := sorry'

end int64

/- * Specialization to offsets in pointer values -/

namespace ptrofs

def to_int (x : ptrofs) : int32 := ucoe x

def to_int64 (x : ptrofs) : int64 := ucoe x

def of_int (x : int32) : ptrofs := ucoe x

def of_intu := of_int

def of_ints (x : int32) : ptrofs := scoe x

def of_int64 (x : int64) : ptrofs := ucoe x

def of_int64u := of_int64

def of_int64s (x : int64) : ptrofs := scoe x

end ptrofs

end integers


import analysis.special_functions.pow
import analysis.special_functions.log.basic
import analysis.specific_limits.basic
import category_theory.Fintype
import analysis.normed_space.basic

import pseudo_normed_group.basic
import pseudo_normed_group.category

import laurent_measures.basic

import for_mathlib.tsum
import for_mathlib.nnreal

universe u

noncomputable theory
open_locale big_operators nnreal classical

/-- `invpoly r S`, with notation `ℤ[T⁻¹] S`, is the functions `S → ℤ[T⁻¹]`. -/
@[derive add_comm_group]
def invpoly (r : ℝ≥0) (S : Fintype) := S → polynomial ℤ

variables {r : ℝ≥0} {S S' : Fintype.{u}}

local notation `ℤ[T⁻¹]` := invpoly r

namespace invpoly

@[simp] lemma add_apply (F G : ℤ[T⁻¹] S) (s : S) : (F + G) s = F s + G s := rfl
@[simp] lemma sub_apply (F G : ℤ[T⁻¹] S) (s : S) : (F - G) s = F s - G s := rfl
@[simp] lemma neg_apply (F : ℤ[T⁻¹] S) (s : S) : (-F) s = -(F s) := rfl
@[simp] lemma zero_apply (s : S) : (0 : ℤ[T⁻¹] S) s = 0 := rfl
@[simp] lemma nsmul_apply (k : ℕ) (F : ℤ[T⁻¹] S) (s : S) : (k • F) s = k • (F s) := rfl
@[simp] lemma zsmul_apply (k : ℤ) (F : ℤ[T⁻¹] S) (s : S) : (k • F) s = k • (F s) := rfl

-- @[ext]
-- lemma ext (F G : ℤ[T⁻¹] S) : (F : S → ) = G → F = G :=
-- by { intros h, funext s, ext, exact congr_fun (congr_fun h s) n }

protected lemma nnreal_summable (F : ℤ[T⁻¹] S) (s : S) :
  summable (λ n, ∥(F s).coeff n∥₊ * r ^ (-n:ℤ)) :=
begin
  apply @summable_of_ne_finset_zero _ _ _ _ _ (F s).support,
  intros n hn,
  simp only [polynomial.mem_support_iff, not_not] at hn,
  simp only [hn, nnnorm_zero, zero_mul],
end

protected lemma summable (F : ℤ[T⁻¹] S) (s : S) :
  summable (λ n, ∥(F s).coeff n∥ * r ^ (-n : ℤ)) :=
begin
  simpa only [← nnreal.summable_coe, nnreal.coe_mul, coe_nnnorm, nnreal.coe_zpow]
    using F.nnreal_summable s
end

-- Move me
lemma nonneg_of_norm_mul_zpow (k n : ℤ) (r : ℝ≥0) : 0 ≤ ∥ k ∥ * (r : ℝ)^n :=
mul_nonneg (norm_nonneg _) (zpow_nonneg (nnreal.coe_nonneg _) _)

def map (f : S ⟶ S') : ℤ[T⁻¹] S → ℤ[T⁻¹] S' := λ F,
λ s', ∑ s in finset.univ.filter (λ t, f t = s'), F s

@[simp] lemma map_apply (f : S ⟶ S') (F : ℤ[T⁻¹] S) (s' : S') (k : ℕ) :
  (map f F s').coeff k = ∑ s in finset.univ.filter (λ t, f t = s'), (F s).coeff k :=
by simp only [map, ← polynomial.finset_sum_coeff]

@[simp] lemma map_id : (map (𝟙 S) : ℤ[T⁻¹] S → ℤ[T⁻¹] S) = id :=
begin
  ext F s k,
  simp only [map_apply, Fintype.id_apply, id.def, finset.sum_filter,
    finset.sum_ite_eq', finset.mem_univ, if_true],
end

@[simp] lemma map_comp {S'' : Fintype.{u}} (f : S ⟶ S') (g : S' ⟶ S'') :
  (map (f ≫ g) : ℤ[T⁻¹] S → ℤ[T⁻¹] S'') = map g ∘ map f :=
begin
  ext F s k,
  simp only [function.comp_app, map_apply, finset.sum_congr],
  rw ← finset.sum_bUnion,
  { apply finset.sum_congr,
    { change finset.univ.filter (λ t, g (f t) = s) = _,
      ext i,
      split;
      { intro hi, simpa only [finset.mem_bUnion, finset.mem_filter, finset.mem_univ, true_and,
          exists_prop, exists_eq_right'] using hi } },
    { intros, refl } },
  { intros i hi j hj h k hk,
    simp only [finset.inf_eq_inter, finset.mem_inter, finset.mem_filter, finset.mem_univ, true_and,
      finset.coe_filter, finset.coe_univ, set.sep_univ, set.mem_set_of_eq] at hi hj hk,
    refine h _,
    rw [← hk.1, ← hk.2] }
end

instance : has_norm (ℤ[T⁻¹] S) :=
⟨λ F, ∑ s, ∑' n, ∥(F s).coeff n∥ * (r : ℝ) ^ (-n:ℤ)⟩

lemma norm_def (F : ℤ[T⁻¹] S) : ∥F∥ = ∑ s, ∑' n, ∥(F s).coeff n∥ * (r : ℝ)^(-n:ℤ) := rfl

/-- The norm on `ℤ[T⁻¹](S)` sending `s ↦ ∑ aₙ(s) T⁻ⁿ` to `∑_{s,n} ∥aₙ(s)∥₊r^⁻ⁿ`. -/
instance : has_nnnorm (ℤ[T⁻¹] S) :=
⟨λ F, ∑ s, ∑' n, ∥(F s).coeff n∥₊ * r ^ (-n : ℤ)⟩

lemma nnnorm_def (F : ℤ[T⁻¹] S) : ∥F∥₊ = ∑ s, ∑' n, ∥(F s).coeff n∥₊ * r^(-n:ℤ) := rfl

@[simp] lemma coe_nnnorm (F : ℤ[T⁻¹] S) : (∥F∥₊ : ℝ) = ∥F∥ :=
by simp only [nnnorm_def, norm_def, nnreal.coe_sum, nnreal.coe_tsum,
  nonneg.coe_mul, coe_nnnorm, nnreal.coe_zpow]

@[simp] lemma invpoly.norm_nonneg (F : ℤ[T⁻¹] S) : 0 ≤ ∥F∥ :=
by rw [← coe_nnnorm]; exact ∥F∥₊.coe_nonneg

@[simp] lemma nnnorm_neg (F : ℤ[T⁻¹] S) : ∥-F∥₊ = ∥F∥₊ :=
by simp only [nnnorm_def, nnnorm_neg, neg_apply, polynomial.coeff_neg]

lemma nnnorm_add (F G : ℤ[T⁻¹] S) : ∥F + G∥₊ ≤ ∥F∥₊ + ∥G∥₊ :=
begin
  simp only [nnnorm_def, ← finset.sum_add_distrib],
  apply finset.sum_le_sum,
  rintro s -,
  rw ← tsum_add (F.nnreal_summable _) (G.nnreal_summable _),
  refine tsum_le_tsum _ ((F + G).nnreal_summable _)
    ((F.nnreal_summable s).add (G.nnreal_summable s)),
  intro b,
  simp [← add_mul],
  refine mul_le_mul' (nnnorm_add_le _ _) le_rfl
end

lemma norm_add (F G : ℤ[T⁻¹] S) : ∥F + G∥ ≤ ∥F∥ + ∥G∥ :=
by simpa only [← coe_nnnorm, ← nnreal.coe_add, nnreal.coe_le_coe] using nnnorm_add F G

instance : pseudo_normed_group (ℤ[T⁻¹] S) :=
{ filtration := λ c, { F | ∥F∥₊ ≤ c },
  filtration_mono := λ c₁ c₂ h F hF, by {dsimp at *, exact le_trans hF h},
  zero_mem_filtration := λ c, by simp [nnnorm_def],
  neg_mem_filtration := λ c F h, (nnnorm_neg F).le.trans h,
  add_mem_filtration := λ c₁ c₂ F₁ F₂ h₁ h₂, (nnnorm_add _ _).trans (add_le_add h₁ h₂) }

@[simp] lemma mem_filtration_iff (F : ℤ[T⁻¹] S) (c : ℝ≥0) :
  F ∈ pseudo_normed_group.filtration (ℤ[T⁻¹] S) c ↔ ∥F∥₊ ≤ c := iff.rfl

section
open finset

lemma map_bound (f : S ⟶ S') (F : ℤ[T⁻¹] S) : ∥map f F∥₊ ≤ ∥F∥₊ := calc
∥map f F∥₊ = ∑ s', ∑' n, ∥∑ s in univ.filter (λ t, f t = s'), (F s).coeff n∥₊ * (r^(-n:ℤ)) :
  (by simp only [map, ← polynomial.finset_sum_coeff]; refl)
... ≤ ∑ s', ∑' n, ∑ s in univ.filter (λ t, f t = s'), ∥(F s).coeff n∥₊ * r^(-n:ℤ) : begin
  apply sum_le_sum,
  rintros s' -,
  have h1 : summable (λ n : ℕ, ∑ (s : S.α) in univ.filter (λ t, f t = s'), ∥(F s).coeff n∥₊ * r^(-n:ℤ)) :=
    summable_sum (λ s _, F.nnreal_summable s),
  have h2 : ∀ b : ℕ,
    ∥∑ (s : S.α) in univ.filter (λ t, f t = s'), (F s).coeff b∥₊ * r ^ (-b:ℤ) ≤
      ∑ (s : S.α) in univ.filter (λ t, f t = s'), ∥(F s).coeff b∥₊ * r ^ (-b:ℤ),
  { intros b, rw ← sum_mul, exact mul_le_mul' (nnnorm_sum_le _ _) le_rfl },
  apply tsum_le_tsum h2 (nnreal.summable_of_le h2 h1) h1,
end
... = ∑ s', ∑ s in univ.filter (λ t, f t = s'), ∑' n, ∥(F s).coeff n∥₊ * r^(-n:ℤ) :
  sum_congr rfl (λ s' _, tsum_sum $ λ s _, F.nnreal_summable _)
... = _ : begin
  rw [← sum_bUnion],
  refine sum_congr _ _,
  { ext s, simp only [mem_bUnion, mem_univ, mem_filter, true_and, exists_true_left, exists_eq'] },
  { intros, refl },
  { rintro x - y - h i hi,
    apply h,
    simp only [inf_eq_inter, mem_inter, mem_filter, mem_univ, true_and] at hi,
    rw [← hi.1, ← hi.2] }
end

end

lemma map_bound' (f : S ⟶ S') (F : ℤ[T⁻¹] S) : ∥map f F∥ ≤ ∥F∥ :=
by simpa only [← coe_nnnorm, ← nnreal.coe_add, nnreal.coe_le_coe] using map_bound f F

lemma bounded_of_filtration (F : ℤ[T⁻¹] S) (c : ℝ≥0) [hr : fact (0 < r)] :
  ∥F∥₊ ≤ c → ∀ (s : S) (n : ℕ), ∥(F s).coeff n∥₊ ≤ c * r^n :=
begin
  intros hF s n,
  have : ∥(F s).coeff n∥₊ * r ^ (-n : ℤ) ≤ ∑' k, ∥(F s).coeff k∥₊ * r ^ (-k:ℤ),
  { exact le_tsum (F.nnreal_summable s) _ (λ k _, zero_le'), },
  rw [mul_comm, nnreal.mul_le_iff_le_inv (zpow_ne_zero_of_ne_zero (hr.elim.ne).symm _)] at this,
  simp only [zpow_neg, zpow_coe_nat, inv_inv, mul_comm (r^n)] at this,
  refine le_trans this _,
  rw mul_le_mul_right (pow_pos hr.elim n),
  refine le_trans _ hF,
  unfold nnnorm,
  simp only [zpow_neg, zpow_coe_nat],
  apply @finset.single_le_sum S ℝ≥0 _ (λ s, ∑' n, ∥(F s).coeff n∥₊ * (r^n)⁻¹),
    { rintros s -, exact zero_le', },
    { exact finset.mem_univ _ }
end

lemma bounded_of_filtration' (F : ℤ[T⁻¹] S) (c : ℝ≥0) [fact (0 < r)] [hr : fact (r < 1)] :
  ∥F∥₊ ≤ c → ∀ (s : S) (n : ℕ), |(F s).coeff n| ≤ ⌊c⌋₊ :=
begin
  intros hF s n,
  rw int.abs_le_floor_nnreal_iff,
  refine le_trans (bounded_of_filtration F c hF s n) _,
  exact mul_le_of_le_of_le_one (le_refl c) (pow_le_one' hr.elim.le n),
end

-- rather annoyingly, can't use `bounded_of_filtration` to prove this
-- more easily because it's true even if r=0 :-)
/-- This lemma puts bounds on where `(F s).coeff n` can be nonzero. -/
lemma eq_zero_of_filtration (F : ℤ[T⁻¹] S) (c : ℝ≥0) :
  ∥F∥₊ ≤ c → ∀ (s : S) (n : ℕ), c < r^(-n:ℤ) → (F s).coeff n = 0 :=
begin
  intros hF s n h,
  suffices : ∥(F s).coeff n∥₊ < 1,
  { change abs ((F s).coeff n : ℝ) < 1 at this,
    norm_cast at this,
    rwa ← int.abs_lt_one_iff },
  have : ∥(F s).coeff n∥₊ * r ^ (-n : ℤ) ≤ ∑' k, ∥(F s).coeff k∥₊ * r ^ (-k:ℤ),
  { exact le_tsum (F.nnreal_summable s) _ (λ k _, zero_le'), },
  replace this := lt_of_le_of_lt (this.trans _) h,
  { have hr₁ : 0 < r^(-n:ℤ) := lt_of_le_of_lt zero_le' h,
    have hr₂ : r^(-n:ℤ) ≠ 0 := hr₁.ne',
    convert mul_lt_mul this (le_refl (r ^ (-n : ℤ))⁻¹) _ hr₁.le,
    { exact (mul_inv_cancel_right₀ hr₂ _).symm },
    { exact (mul_inv_cancel hr₂).symm },
    { rwa nnreal.inv_pos }, },
  { refine le_trans _ hF,
    apply @finset.single_le_sum S ℝ≥0 _ (λ s, ∑' n, ∥(F s).coeff n∥₊ * r^(-n:ℤ)),
    { rintros s -, exact zero_le', },
    { exact finset.mem_univ _ } }
end

lemma log_div_log_lt {r : ℝ≥0} (c : ℝ≥0) (n : ℕ)
  (hr0 : 0 < r)
  (hr1 : r < 1)
  (h : -real.log ↑c / real.log ↑r < ↑n) :
  c < r ^ -(n : ℤ) :=
begin
  rcases (eq_zero_or_pos : c = 0 ∨ 0 < c) with (rfl | hc),
  { apply nnreal.zpow_pos hr0.ne.symm, },
  { rw [div_lt_iff_of_neg (real.log_neg hr0 hr1), lt_neg, ← neg_mul] at h,
    rw [(by norm_cast :  -(n : ℝ) = (-(n : ℤ) : ℤ)), ← real.log_zpow] at h,
    rw real.log_lt_log_iff hc at h,
    { exact_mod_cast h },
    { norm_cast, apply nnreal.zpow_pos hr0.ne.symm } },
end

lemma eq_zero_of_filtration' {F : ℤ[T⁻¹] S} {c : ℝ≥0} [hr0 : fact (0 < r)] [hr1 : fact (r < 1)] :
  ∥F∥₊ ≤ c → ∀ (s : S) (n : ℕ), -real.log(c)/real.log(r) < n → (F s).coeff n = 0 :=
begin
  intros hF s n h,
  refine eq_zero_of_filtration F c hF s n (log_div_log_lt c n hr0.elim hr1.elim h),
end

-- move me
lemma zpow_strict_anti {K : Type} [linear_ordered_field K] {x : K} (hx₀ : 0 < x) (hx₁ : x < 1) :
  strict_anti (λ n:ℤ, x ^ n) :=
begin
  intros n m H,
  rw [← inv_inv x],
  simp only [inv_zpow x⁻¹, inv_lt_inv (zpow_pos_of_pos (inv_pos.mpr hx₀) _)
    (zpow_pos_of_pos (inv_pos.mpr hx₀) _)],
  exact zpow_strict_mono (one_lt_inv hx₀ hx₁) H,
end

section profinite_structure

variables [fact (0 < r)] (c : ℝ≥0)

instance [fact (r < 1)] : fintype { F : ℤ[T⁻¹] S | ∥F∥₊ ≤ c} :=
let i : { F : ℤ[T⁻¹] S | ∥F∥₊ ≤ c} →
  (S → fin (⌊-real.log ↑c / real.log ↑r⌋₊ + 1) → set.Icc (-⌊c⌋₊ : ℤ) ⌊c⌋₊ ) :=
λ F s j, ⟨(F.1 s).coeff j, abs_le.1 (bounded_of_filtration' _ _ F.2 _ _)⟩ in
fintype.of_injective i begin
  intros F₁ F₂ h,
  ext s n,
  cases le_or_lt (n : ℝ) (-real.log(c)/real.log(r)) with hn hn,
  { replace hn := nat.le_floor hn,
    rw ← nat.lt_add_one_iff at hn,
    replace h := congr_fun (congr_fun h s) ⟨n, hn⟩,
    exact congr_arg subtype.val h },
  { convert (rfl : (0 : ℤ) = 0),
    { apply eq_zero_of_filtration' F₁.2 _ _ hn, },
    { apply eq_zero_of_filtration' F₂.2 _ _ hn, }
  },
end

instance : topological_space { F : ℤ[T⁻¹] S | ∥F∥₊ ≤ c} := ⊥

instance [fact (0 < r)] [fact (r < 1)] : profinitely_filtered_pseudo_normed_group (ℤ[T⁻¹] S) :=
{ continuous_add' := λ _ _, continuous_of_discrete_topology,
  continuous_neg' := λ _, continuous_of_discrete_topology,
  continuous_cast_le := λ _ _ _, continuous_of_discrete_topology,
  ..(infer_instance : (pseudo_normed_group (ℤ[T⁻¹] S))) }
.

end profinite_structure

/--
The `T⁻¹` action on `ℤ[T⁻¹] S`.
This is defined, essentially, as a shift in `ℕ` (accounting for the restriction at 0).
This is an additive group homomorphism.
-/
def Tinv_aux {S : Fintype.{u}} :
  ℤ[T⁻¹] S →+ ℤ[T⁻¹] S :=
add_monoid_hom.mk' (λ F s, add_monoid_hom.mul_left polynomial.X (F s))
  (by { intros F G, funext s, exact map_add _ _ _ })

lemma Tinv_aux_coeff (F : ℤ[T⁻¹] S) (s : S) (n : ℕ) :
  (Tinv_aux F s).coeff n = (polynomial.X * F s).coeff n := rfl

@[simp] lemma Tinv_aux_zero (F : ℤ[T⁻¹] S) (s : S) : (Tinv_aux F s).coeff 0 = 0 :=
by simp only [Tinv_aux_coeff, polynomial.mul_coeff_zero, polynomial.coeff_X_zero, zero_mul]

@[simp] lemma Tinv_aux_succ (F : ℤ[T⁻¹] S) (s : S) (i : ℕ) :
  (Tinv_aux F s).coeff (i + 1) = (F s).coeff i :=
by simp only [Tinv_aux_coeff, polynomial.coeff_X_mul]

lemma Tinv_aux_summable [hr : fact (0 < r)] (F : ℤ[T⁻¹] S) (s : S) :
  summable (λ n, (∥(Tinv_aux F s).coeff n∥₊ * r ^ (-n:ℤ))) :=
begin
  rw ← nnreal.summable_nat_add_iff 1,
  simp only [Tinv_aux_succ, int.coe_nat_succ, neg_add, zpow_add₀ hr.out.ne', ← mul_assoc],
  apply summable.mul_right,
  exact F.nnreal_summable s,
end

@[simps]
def Tinv_hom [hr : fact (0 < r)] [fact (r < 1)] :
  comphaus_filtered_pseudo_normed_group_hom (ℤ[T⁻¹] S) (ℤ[T⁻¹] S) :=
comphaus_filtered_pseudo_normed_group_hom.mk_of_bound Tinv_aux r⁻¹
begin
  abstract Tinv_spec {
  intro c,
  refine ⟨_, continuous_of_discrete_topology⟩,
  intros F hF,
  rw mul_comm,
  refine le_trans _ (mul_le_mul' hF le_rfl),
  simp only [nnnorm_def, finset.sum_mul],
  refine finset.sum_le_sum (λ s _, _),
  transitivity ∑' n, ∥(F s).coeff n∥₊ * r^(-n:ℤ) * r⁻¹,
  { rw ← sum_add_tsum_nat_add' 1,
    swap, { apply Tinv_aux_summable },
    simp only [finset.range_one, zpow_neg, zpow_coe_nat, finset.sum_singleton,
      pow_zero, inv_one, mul_one, int.coe_nat_succ, neg_add, zpow_add₀ hr.out.ne',
      zpow_one, mul_assoc, Tinv_aux_zero, nnnorm_zero, Tinv_aux_succ, zero_add], },
  refine le_of_eq _, ext,
  simp only [nonneg.coe_mul, nnreal.coe_tsum, coe_nnnorm, nnreal.coe_zpow, tsum_mul_right], }
end
.

instance [fact (0 < r)] [fact (r < 1)] :
  profinitely_filtered_pseudo_normed_group_with_Tinv r (ℤ[T⁻¹] S) :=
{ Tinv := Tinv_hom,
  Tinv_mem_filtration := λ c F hF,
    comphaus_filtered_pseudo_normed_group_hom.mk_of_bound_bound_by _ _ _ hF,
  .. (_: profinitely_filtered_pseudo_normed_group (ℤ[T⁻¹] S))}

open comphaus_filtered_pseudo_normed_group_with_Tinv

lemma Tinv_coeff [fact (0 < r)] [fact (r < 1)] (F : ℤ[T⁻¹] S) (s : S) (n : ℕ) :
  (Tinv F s).coeff n = (polynomial.X * F s).coeff n := rfl

@[simp] lemma Tinv_zero [fact (0 < r)] [fact (r < 1)] (F : ℤ[T⁻¹] S) (s : S) : (Tinv F s).coeff 0 = 0 :=
Tinv_aux_zero F s

@[simp] lemma Tinv_succ [fact (0 < r)] [fact (r < 1)] (F : ℤ[T⁻¹] S) (s : S) (i : ℕ) :
  (Tinv F s).coeff (i + 1) = (F s).coeff i :=
Tinv_aux_succ F s i

variable {α : Type*}

open pseudo_normed_group profinitely_filtered_pseudo_normed_group
  comphaus_filtered_pseudo_normed_group

@[simps]
def map_hom [fact (0 < r)] [fact (r < 1)] (f : S ⟶ S') :
  comphaus_filtered_pseudo_normed_group_with_Tinv_hom r (ℤ[T⁻¹] S) (ℤ[T⁻¹] S') :=
{ to_fun := map f,
  map_zero' := by { ext s n,
    simp only [map_apply, zero_apply, polynomial.coeff_zero, finset.sum_const_zero], },
  map_add' := λ F G, by { ext s n,
    simp only [map_apply, add_apply, polynomial.coeff_add, finset.sum_add_distrib], },
  map_Tinv' := λ F, by { ext s (_|n),
    { simp only [map_apply, Tinv_zero, finset.sum_const_zero], },
    { simp only [map_apply, Tinv_succ], } },
  strict' := λ c F (hF : ∥F∥₊ ≤ c), (map_bound _ _).trans hF,
  continuous' := λ c, continuous_of_discrete_topology }

end invpoly


import data.nat.enat data.set.countable
import logic.small
import order.conditionally_complete_lattice order.succ_pred.basic
import set_theory.cardinal.schroeder_bernstein

universes u v w

variables {α β : Type u}

instance cardinal.is_equivalent : setoid (Type u) :=
{ r := λ α β, nonempty (α ≃ β),
  iseqv := ⟨
    λ α, ⟨equiv.refl α⟩,
    λ α β ⟨e⟩, ⟨e.symm⟩,
    λ α β γ ⟨e₁⟩ ⟨e₂⟩, ⟨e₁.trans e₂⟩⟩ }

def cardinal : Type (u+1) := quotient cardinal.is_equivalent

namespace cardinal

def mk (α : Type u) : cardinal := quotient.mk α

prefix `#` := cardinal.mk

instance can_lift_cardinal_Type : can_lift cardinal.{u} (Type u) :=
⟨mk, λ c, true, λ c h, quotient.induction_on c (λ α, ⟨α, rfl⟩)⟩

@[elab_as_eliminator]
lemma induction_on {p : cardinal → Prop} (c : cardinal) : (∀ α, p #α) → p c :=
λ h, quotient.induction_on c h

@[elab_as_eliminator]
lemma induction_on₂ {p : cardinal → cardinal → Prop}
  (c₁ : cardinal.{u}) (c₂ : cardinal.{v}) : (∀ α β, p #α #β) → p c₁ c₂ :=
λ h, quotient.induction_on₂ c₁ c₂ h

@[elab_as_eliminator]
lemma induction_on₃ {p : cardinal → cardinal → cardinal → Prop}
  (c₁ : cardinal.{u}) (c₂ : cardinal.{v}) (c₃ : cardinal.{w}) :
  (∀ α β γ, p #α #β #γ) → p c₁ c₂ c₃ :=
λ h, quotient.induction_on₃ c₁ c₂ c₃ h

protected lemma eq : #α = #β ↔ nonempty (α ≃ β) := quotient.eq

@[simp] theorem mk_def (α : Type u) : @eq cardinal ⟦α⟧ #α := rfl

@[simp] theorem mk_out (c : cardinal) : #c.out = c := quotient.out_eq c

noncomputable def out_mk_equiv : (#α).out ≃ α :=
nonempty.some (cardinal.eq.mp (mk_out #α))

lemma mk_congr (e : α ≃ β) : #α = #β := quotient.sound ⟨e⟩

alias mk_congr ← _root_.equiv.cardinal_eq

def map (f : Type u → Type v) (hf : ∀ α β, α ≃ β → f α ≃ f β) :
  cardinal.{u} → cardinal.{v} :=
quotient.map f (λ α β ⟨e⟩, ⟨hf α β e⟩)

@[simp] lemma map_mk (f : Type u → Type v) (hf : ∀ α β, α ≃ β → f α ≃ f β) (α : Type u) :
  map f hf #α = #(f α) := rfl

def map₂ (f : Type u → Type v → Type w) (hf : ∀ α₁ β₁ α₂ β₂, α₁ ≃ β₁ → α₂ ≃ β₂ → f α₁ α₂ ≃ f β₁ β₂) :
  cardinal.{u} → cardinal.{v} → cardinal.{w} :=
quotient.map₂ f (λ α β ⟨e₁⟩ γ δ ⟨e₂⟩, ⟨hf α β γ δ e₁ e₂⟩)

def lift (c : cardinal.{v}) : cardinal.{max v u} :=
map ulift (λ α β e, equiv.ulift.trans (e.trans equiv.ulift.symm)) c

@[simp] theorem mk_ulift (α : Type u) : #(ulift α) = lift #α := rfl

@[simp] theorem lift_umax : lift.{(max u v) u} = lift.{v u} :=
funext (λ c, induction_on c (λ α, mk_congr (equiv.ulift.trans equiv.ulift.symm)))

@[simp] theorem lift_umax' : lift.{(max v u) u} = lift.{v u} := lift_umax

@[simp] theorem lift_id' (c : cardinal.{max u v}) : lift.{u} c = c :=
induction_on c (λ α, mk_congr equiv.ulift)

@[simp] theorem lift_id (c : cardinal.{u}) : lift.{u u} c = c := lift_id'.{u u} c

@[simp] theorem lift_uzero (c : cardinal.{u}) : lift.{0} c = c := lift_id'.{0 u} c

@[simp] theorem lift_lift (c : cardinal.{u}) :
  lift.{w} (lift.{v} c) = lift.{max v w} c :=
induction_on c (λ α, mk_congr (equiv.ulift.trans (equiv.ulift.trans equiv.ulift.symm)))

instance : has_le cardinal.{u} :=
⟨λ c₁ c₂, quotient.lift_on₂ c₁ c₂ (λ α β, nonempty (α ↪ β))
  (λ α₁ β₁ α₂ β₂ ⟨e₁⟩ ⟨e₂⟩, propext ⟨λ ⟨e⟩, ⟨e.congr e₁ e₂⟩, λ ⟨e⟩, ⟨e.congr e₁.symm e₂.symm⟩⟩)⟩

instance : partial_order cardinal.{u} :=
{ le          := (≤),
  le_refl     := by { rintros ⟨α⟩, exact ⟨function.embedding.refl α⟩ },
  le_trans    := by { rintros ⟨α⟩ ⟨β⟩ ⟨γ⟩ ⟨e₁⟩ ⟨e₂⟩, exact ⟨e₁.trans e₂⟩ },
  le_antisymm := by { rintros ⟨α⟩ ⟨β⟩ ⟨e₁⟩ ⟨e₂⟩, exact quotient.sound (e₁.antisymm e₂) } }

theorem le_def (α β : Type u) : #α ≤ #β ↔ nonempty (α ↪ β) :=
iff.rfl

theorem mk_le_of_injective {f : α → β} (hf : function.injective f) :
  #α ≤ #β :=
⟨⟨f, hf⟩⟩

theorem _root_.function.embedding.cardinal_le (f : α ↪ β) : #α ≤ #β := ⟨f⟩

theorem mk_le_of_surjective {f : α → β} (hf : function.surjective f) : #β ≤ #α :=
⟨function.embedding.of_surjective f hf⟩

theorem le_mk_iff_exists_set {c : cardinal} {α : Type u} :
  c ≤ #α ↔ ∃ s : set α, #s = c :=
⟨induction_on c (λ β ⟨⟨f, hf⟩⟩, ⟨set.range f, mk_congr (equiv.of_injective f hf).symm⟩),
 λ ⟨s, hs⟩, hs ▸ ⟨⟨subtype.val, λ a₁ a₂, subtype.eq⟩⟩⟩

theorem mk_subtype_le {α : Type u} (p : α → Prop) : #(subtype p) ≤ #α :=
⟨function.embedding.subtype p⟩

theorem mk_set_le (s : set α) : #s ≤ #α :=
mk_subtype_le s

theorem out_embedding {c₁ c₂ : cardinal} : c₁ ≤ c₂ ↔ nonempty (c₁.out ↪ c₂.out) :=
begin
  transitivity #c₁.out ≤ #c₂.out,
  { conv { to_lhs, rw [←mk_out c₁, ←mk_out c₂] } },
  { refl }
end

theorem lift_mk_le {α : Type u} {β : Type v} :
  lift.{max v w} #α ≤ lift.{max u w} #β ↔ nonempty (α ↪ β) :=
⟨λ ⟨f⟩, ⟨function.embedding.congr equiv.ulift equiv.ulift f⟩,
 λ ⟨f⟩, ⟨function.embedding.congr equiv.ulift.symm equiv.ulift.symm f⟩⟩

theorem lift_mk_le' {α : Type u} {β : Type v} :
  lift.{v} #α ≤ lift.{u} #β ↔ nonempty (α ↪ β) :=
lift_mk_le.{u v 0}

theorem lift_mk_eq {α : Type u} {β : Type v} :
  lift.{max v w} #α = lift.{max u w} #β ↔ nonempty (α ≃ β) :=
quotient.eq.trans
⟨λ ⟨f⟩, ⟨equiv.ulift.symm.trans (f.trans equiv.ulift)⟩,
 λ ⟨f⟩, ⟨equiv.ulift.trans (f.trans equiv.ulift.symm)⟩⟩

theorem lift_mk_eq' {α : Type u} {β : Type v} :
  lift.{v} #α = lift.{u} #β ↔ nonempty (α ≃ β) :=
lift_mk_eq.{u v 0}

@[simp] theorem lift_le {c₁ c₂ : cardinal} : lift c₁ ≤ lift c₂ ↔ c₁ ≤ c₂ :=
induction_on₂ c₁ c₂ (λ α β, lift_umax ▸ lift_mk_le)

@[simps { fully_applied := ff }] def lift_order_embedding :
  cardinal.{v} ↪o cardinal.{max v u} :=
order_embedding.of_map_le_iff lift (λ c₁ c₂, lift_le)

theorem lift_injective : function.injective lift.{u v} :=
lift_order_embedding.injective

@[simp] theorem lift_inj {c₁ c₂ : cardinal} : lift c₁ = lift c₂ ↔ c₁ = c₂ :=
lift_injective.eq_iff

@[simp] theorem lift_lt {c₁ c₂ : cardinal} : lift c₁ < lift c₂ ↔ c₁ < c₂ :=
lift_order_embedding.lt_iff_lt

theorem lift_strict_mono : strict_mono lift :=
λ c₁ c₂, lift_lt.mpr

theorem lift_monotone : monotone lift :=
lift_strict_mono.monotone

instance : has_zero cardinal := ⟨#pempty⟩

instance : inhabited cardinal := ⟨0⟩

lemma mk_eq_zero (α : Type u) [is_empty α] : #α = 0 :=
mk_congr (equiv.equiv_pempty α)

@[simp] theorem lift_zero : lift 0 = 0 := mk_congr (equiv.equiv_pempty (ulift pempty))

@[simp] theorem lift_eq_zero {c : cardinal} : lift c = 0 ↔ c = 0 :=
lift_injective.eq_iff' lift_zero

lemma mk_eq_zero_iff {α : Type u} : #α = 0 ↔ is_empty α :=
⟨λ h, let ⟨e⟩ := quotient.exact h in equiv.is_empty e, @mk_eq_zero α⟩

theorem mk_ne_zero_iff {α : Type u} : #α ≠ 0 ↔ nonempty α :=
(not_iff_not.mpr mk_eq_zero_iff).trans not_is_empty_iff

@[simp] lemma mk_ne_zero (α : Type u) [nonempty α] : #α ≠ 0 :=
mk_ne_zero_iff.mpr infer_instance

instance : has_one cardinal := ⟨#punit⟩

instance : nontrivial cardinal := ⟨⟨1, 0, mk_ne_zero punit⟩⟩

lemma mk_eq_one (α : Type u) [unique α] : #α = 1 :=
mk_congr (equiv.equiv_punit α)

theorem le_one_iff_subsingleton {α : Type u} : #α ≤ 1 ↔ subsingleton α :=
⟨λ ⟨f⟩, ⟨λ a₁ a₂, f.injective (subsingleton.elim (f a₁) (f a₂))⟩,
 λ ⟨h⟩, ⟨⟨λ a, punit.star, λ a₁ a₂ h', h a₁ a₂⟩⟩⟩

instance : has_add cardinal := ⟨map₂ sum (λ α₁ β₁ α₂ β₂, equiv.sum_congr)⟩

theorem add_def (α β : Type u) : #α + #β = #(α ⊕ β) := rfl

instance : has_nat_cast cardinal := ⟨nat.unary_cast⟩

@[simp] lemma mk_sum (α : Type u) (β : Type v) :
  #(α ⊕ β) = lift #α + lift.{u} #β :=
mk_congr (equiv.ulift.symm.sum_congr equiv.ulift.symm)

@[simp] theorem mk_option {α : Type u} : #(option α) = #α + 1 :=
mk_congr (equiv.option_equiv_sum_punit α)

@[simp] lemma mk_psum (α : Type u) (β : Type v) :
  #(psum α β) = lift #α + lift.{u} #β :=
(mk_congr (equiv.psum_equiv_sum α β)).trans (mk_sum α β)

@[simp] lemma mk_fintype (α : Type u) [hα : fintype α] : #α = fintype.card α :=
begin
  refine fintype.induction_empty_option' _ _ _ α,
  { intros α β hβ e h,
    let hα := @fintype.of_equiv α β hβ e.symm,
    rwa [mk_congr e, @fintype.card_congr α β hα hβ e] at h },
  { refl },
  { intros α hα h,
    simp only [h, mk_option, @fintype.card_option α hα],
    refl }
end

instance : has_mul cardinal := ⟨map₂ prod (λ α₁ β₁ α₂ β₂, equiv.prod_congr)⟩

theorem mul_def (α β : Type u) : #α * #β = #(α × β) := rfl

@[simp] lemma mk_prod (α : Type u) (β : Type v) :
  #(α × β) = lift #α * lift.{u} #β :=
mk_congr (equiv.ulift.symm.prod_congr equiv.ulift.symm)

private theorem mul_comm' (c₁ c₂ : cardinal.{u}) : c₁ * c₂ = c₂ * c₁ :=
induction_on₂ c₁ c₂ (λ α β, mk_congr (equiv.prod_comm α β))

instance : has_pow cardinal.{u} cardinal.{u} :=
⟨map₂ (λ α β, β → α) (λ α₁ β₁ α₂ β₂, flip equiv.arrow_congr)⟩

local infixr ` ^ ` := @has_pow.pow cardinal cardinal cardinal.has_pow
local infixr ` ^ℕ `:80 := @has_pow.pow cardinal ℕ monoid.has_pow

theorem power_def (α β : Type u) : #α ^ #β = #(β → α) := rfl

theorem mk_arrow (α : Type u) (β : Type v) : #(α → β) = lift.{u} #β ^ lift.{v} #α :=
mk_congr (equiv.ulift.symm.arrow_congr equiv.ulift.symm)

@[simp] theorem lift_power (c₁ c₂ : cardinal) : lift (c₁ ^ c₂) = lift c₁ ^ lift c₂ :=
induction_on₂ c₁ c₂ (λ α β, mk_congr (equiv.ulift.trans (equiv.ulift.arrow_congr equiv.ulift).symm))

@[simp] theorem power_zero {c : cardinal} : c ^ 0 = 1 :=
induction_on c (λ α, mk_congr (equiv.pempty_arrow_equiv_punit α))

@[simp] theorem power_one {c : cardinal} : c ^ 1 = c :=
induction_on c (λ α, mk_congr (equiv.punit_arrow_equiv α))

theorem power_add {c₁ c₂ c₃ : cardinal} : c₁ ^ (c₂ + c₃) = c₁ ^ c₂ * c₁ ^ c₃ :=
induction_on₃ c₁ c₂ c₃ (λ α β γ, mk_congr (equiv.sum_arrow_equiv_prod_arrow β γ α))

instance : comm_semiring cardinal.{u} :=
{ zero          := 0,
  one           := 1,
  add           := (+),
  mul           := (*),
  zero_add      := λ c, induction_on c (λ α, mk_congr (equiv.empty_sum pempty α)),
  add_zero      := λ c, induction_on c (λ α, mk_congr (equiv.sum_empty α pempty)),
  add_assoc     := λ c₁ c₂ c₃, induction_on₃ c₁ c₂ c₃ (λ α β γ, mk_congr (equiv.sum_assoc α β γ)),
  add_comm      := λ c₁ c₂, induction_on₂ c₁ c₂ (λ α β, mk_congr (equiv.sum_comm α β)),
  zero_mul      := λ c, induction_on c (λ α, mk_congr (equiv.pempty_prod α)),
  mul_zero      := λ c, induction_on c (λ α, mk_congr (equiv.prod_pempty α)),
  one_mul       := λ c, induction_on c (λ α, mk_congr (equiv.punit_prod α)),
  mul_one       := λ c, induction_on c (λ α, mk_congr (equiv.prod_punit α)),
  mul_assoc     := λ c₁ c₂ c₃, induction_on₃ c₁ c₂ c₃ (λ α β γ, mk_congr (equiv.prod_assoc α β γ)),
  mul_comm      := mul_comm',
  left_distrib  := λ c₁ c₂ c₃, induction_on₃ c₁ c₂ c₃ (λ α β γ, mk_congr (equiv.prod_sum_distrib α β γ)),
  right_distrib := λ c₁ c₂ c₃, induction_on₃ c₁ c₂ c₃ (λ α β γ, mk_congr (equiv.sum_prod_distrib α β γ)),
  npow          := λ n c, c ^ n,
  npow_zero'    := @power_zero,
  npow_succ'    := λ n c, show c ^ (n + 1) = c * c ^ n, by rw [power_add, power_one, mul_comm'] }

theorem power_bit0 (c₁ c₂ : cardinal) : c₁ ^ (bit0 c₂) = c₁ ^ c₂ * c₁ ^ c₂ :=
power_add

theorem power_bit1 (c₁ c₂ : cardinal) : c₁ ^ (bit1 c₂) = c₁ ^ c₂ * c₁ ^ c₂ * c₁ :=
by rw [bit1, ←power_bit0, power_add, power_one]

@[simp] theorem one_power {c : cardinal} : 1 ^ c = 1 :=
induction_on c (λ α, mk_congr (equiv.arrow_punit_equiv_punit α))

@[simp] theorem mk_bool : #bool = 2 := by simp

@[simp] theorem mk_Prop : #Prop = 2 := by simp

@[simp] theorem zero_power {c : cardinal} : c ≠ 0 → 0 ^ c = 0 :=
induction_on c (λ α h, mk_eq_zero_iff.mpr
  (is_empty_pi.mpr ⟨classical.choice (mk_ne_zero_iff.mp h), pempty.is_empty⟩))

theorem power_ne_zero {c₁ : cardinal.{u}} (c₂ : cardinal.{u}) : c₁ ≠ 0 → c₁ ^ c₂ ≠ 0 :=
induction_on₂ c₁ c₂
  (λ α β h, mk_ne_zero_iff.mpr ⟨λ b, classical.choice (mk_ne_zero_iff.mp h)⟩)

theorem mul_power {c₁ c₂ c₃ : cardinal} : (c₁ * c₂) ^ c₃ = c₁ ^ c₃ * c₂ ^ c₃ :=
induction_on₃ c₁ c₂ c₃ (λ α β γ, mk_congr (equiv.arrow_prod_equiv_prod_arrow α β γ))

theorem power_mul {c₁ c₂ c₃ : cardinal} : c₁ ^ (c₂ * c₃) = (c₁ ^ c₂) ^ c₃ :=
begin
  rw [mul_comm c₂ c₃],
  exact induction_on₃ c₁ c₂ c₃ (λ α β γ, mk_congr (equiv.curry γ β α))
end

@[simp] lemma pow_cast_right (c : cardinal) (n : ℕ) : c ^ n = c ^ℕ n :=
rfl

@[simp] theorem lift_one : lift 1 = 1 :=
mk_congr (equiv.ulift.trans equiv.punit_equiv_punit)

@[simp] theorem lift_add (c₁ c₂) : lift (c₁ + c₂) = lift c₁ + lift c₂ :=
induction_on₂ c₁ c₂
  (λ α β, mk_congr (equiv.ulift.trans (equiv.sum_congr equiv.ulift equiv.ulift).symm))

@[simp] theorem lift_mul (c₁ c₂) : lift (c₁ * c₂) = lift c₁ * lift c₂ :=
induction_on₂ c₁ c₂
  (λ α β, mk_congr (equiv.ulift.trans (equiv.prod_congr equiv.ulift equiv.ulift).symm))

@[simp] theorem lift_bit0 (c : cardinal) : lift (bit0 c) = bit0 (lift c) :=
lift_add c c

@[simp] theorem lift_bit1 (c : cardinal) : lift (bit1 c) = bit1 (lift c) :=
by simp [bit1]

theorem lift_two : lift 2 = 2 := by simp

@[simp] theorem mk_set {α : Type u} : #(set α) = 2 ^ #α := by simp [set, mk_arrow]

@[simp] theorem mk_powerset {α : Type u} (s : set α) : #(set.powerset s) = 2 ^ #s :=
(mk_congr (equiv.set.powerset s)).trans mk_set

theorem lift_two_power (c : cardinal) : lift (2 ^ c) = 2 ^ lift c := by simp

protected theorem zero_le (c : cardinal) : 0 ≤ c :=
induction_on c (λ α, ⟨function.embedding.of_is_empty⟩)

private theorem add_le_add' : ∀ {c₁ c₂ c₃ c₄ : cardinal}, c₁ ≤ c₂ → c₃ ≤ c₄ → c₁ + c₃ ≤ c₂ + c₄ :=
by { rintros ⟨α⟩ ⟨β⟩ ⟨γ⟩ ⟨δ⟩ ⟨e₁⟩ ⟨e₂⟩, exact ⟨function.embedding.sum_map e₁ e₂⟩ }

instance add_covariant_class : covariant_class cardinal cardinal (+) (≤) :=
⟨λ c₁ c₂ c₃, add_le_add' le_rfl⟩

instance add_swap_covariant_class :
  covariant_class cardinal cardinal (function.swap (+)) (≤) :=
⟨λ c₁ c₂ c₃ h, add_le_add' h le_rfl⟩

theorem exists_add_of_le {c₁ c₂ : cardinal} : c₁ ≤ c₂ → ∃ c₃, c₂ = c₁ + c₃ :=
begin
  classical,
  refine induction_on₂ c₁ c₂ _,
  rintros α β ⟨⟨f, hf⟩⟩,
  have h : α ⊕ ↥(set.range f)ᶜ ≃ β,
  { transitivity ↥(set.range f) ⊕ ↥(set.range f)ᶜ,
    { exact equiv.sum_congr (equiv.of_injective f hf) (equiv.refl ↥(set.range f)ᶜ) },
    { exact equiv.set.sum_compl (set.range f) } },
  exact ⟨#↥(set.range f)ᶜ, mk_congr h.symm⟩
end

theorem le_self_add {c₁ c₂ : cardinal} : c₁ ≤ c₁ + c₂ :=
begin
  transitivity c₁ + 0,
  { exact eq.ge (add_zero c₁) },
  { exact add_le_add_left (cardinal.zero_le c₂) c₁ }
end

theorem eq_zero_or_eq_zero_of_mul_eq_zero (c₁ c₂ : cardinal) :
  c₁ * c₂ = 0 → c₁ = 0 ∨ c₂ = 0 :=
begin
  refine induction_on₂ c₁ c₂ (λ α β, _),
  simpa only [mul_def, mk_eq_zero_iff, is_empty_prod] using id
end

instance : canonically_ordered_comm_semiring cardinal.{u} :=
{ bot                               := 0,
  bot_le                            := cardinal.zero_le,
  add_le_add_left                   := λ c₁ c₂, add_le_add_left,
  exists_add_of_le                  := @exists_add_of_le,
  le_self_add                       := @le_self_add,
  eq_zero_or_eq_zero_of_mul_eq_zero := eq_zero_or_eq_zero_of_mul_eq_zero,
  ..cardinal.comm_semiring, ..cardinal.partial_order }

@[simp] theorem zero_lt_one : (0 : cardinal) < 1 :=
lt_of_le_of_ne (zero_le 1) zero_ne_one

lemma zero_power_le (c : cardinal.{u}) : (0 : cardinal.{u}) ^ c ≤ 1 :=
begin
  by_cases h : c = 0,
  { rw [h, power_zero] },
  { rw [zero_power h],
    exact zero_le 1 }
end

theorem power_le_power_left {c₁ c₂ c₃ : cardinal} :
  c₁ ≠ 0 → c₂ ≤ c₃ → c₁ ^ c₂ ≤ c₁ ^ c₃ :=
begin
  refine induction_on₃ c₁ c₂ c₃ _,
  rintros α β γ h ⟨e⟩,
  haveI hα := classical.inhabited_of_nonempty (mk_ne_zero_iff.mp h),
  exact ⟨function.embedding.arrow_congr_left e⟩
end

theorem self_le_power (c₁ : cardinal) {c₂ : cardinal} (h₂ : 1 ≤ c₂) : c₁ ≤ c₁ ^ c₂ :=
begin
  by_cases h₁ : c₁ = 0,
  { exact h₁.symm ▸ zero_le (0 ^ c₂) },
  { convert power_le_power_left h₁ h₂,
    rw power_one }
end

theorem cantor (c : cardinal) : c < 2 ^ c :=
begin
  refine induction_on c (λ α, _),
  rw ←mk_set,
  refine ⟨⟨⟨singleton, λ a₁ a₂, set.singleton_eq_singleton_iff.mp⟩⟩, _⟩,
  rintro ⟨⟨f, hf⟩⟩,
  exact function.cantor_injective f hf
end

instance : no_max_order cardinal :=
{ exists_gt := λ c, ⟨2 ^ c, cantor c⟩ }

noncomputable instance : canonically_linear_ordered_add_monoid cardinal :=
{ le_total     := λ c₁ c₂, induction_on₂ c₁ c₂ (λ α β, function.embedding.total α β),
  decidable_le := classical.dec_rel (≤),
  ..cardinal.canonically_ordered_comm_semiring, ..cardinal.partial_order }

noncomputable instance : distrib_lattice cardinal := infer_instance

theorem one_lt_iff_nontrivial {α : Type u} : 1 < #α ↔ nontrivial α :=
by rw [←not_le, le_one_iff_subsingleton, ←not_nontrivial_iff_subsingleton, not_not]

theorem power_le_max_power_one {c₁ c₂ c₃ : cardinal} (h : c₂ ≤ c₃) :
  c₁ ^ c₂ ≤ max (c₁ ^ c₃) 1 :=
begin
  by_cases h₁ : c₁ = 0,
  { rw [h₁, max_eq_right (zero_power_le c₃)],
    exact zero_power_le c₂ },
  { transitivity c₁ ^ c₃,
    { exact power_le_power_left h₁ h },
    { exact le_max_left (c₁ ^ c₃) 1 } }
end

theorem power_le_power_right {c₁ c₂ c₃ : cardinal} : c₁ ≤ c₂ → c₁ ^ c₃ ≤ c₂ ^ c₃ :=
induction_on₃ c₁ c₂ c₃ (λ α β γ ⟨e⟩, ⟨function.embedding.arrow_congr_right e⟩)

protected theorem lt_wf : @well_founded cardinal (<) :=
begin
  refine ⟨λ c, _⟩,
  by_contra hc,
  let α := {c : cardinal // ¬ acc (<) c},
  haveI hα : nonempty α := ⟨⟨c, hc⟩⟩,
  obtain ⟨⟨c, hc⟩, ⟨h⟩⟩ := function.embedding.min_injective (λ a : α, a.val.out),
  refine hc ⟨c, _⟩,
  rintros c' ⟨h₁, h₂⟩,
  by_contra hc',
  refine h₂ _,
  replace h : #c.out ≤ #c'.out := ⟨h ⟨c', hc'⟩⟩,
  simpa using h
end

instance : has_well_founded cardinal := ⟨(<), cardinal.lt_wf⟩

instance wo : @is_well_order cardinal (<) := ⟨cardinal.lt_wf⟩

noncomputable instance : conditionally_complete_linear_order_bot cardinal :=
is_well_order.conditionally_complete_linear_order_bot cardinal

@[simp] theorem Inf_empty : Inf (∅ : set cardinal) = 0 :=
begin
  classical,
  exact dif_neg set.not_nonempty_empty
end

noncomputable instance : succ_order cardinal :=
begin
  refine succ_order.of_succ_le_iff (λ c, Inf {c' | c < c'}) _,
  intros c₁ c₂,
  refine ⟨_, _⟩,
  { let s : set cardinal := {c | c₁ < c},
    have h : set.nonempty s := exists_gt c₁,
    replace h : Inf s ∈ s := Inf_mem h,
    exact lt_of_lt_of_le h },
  { exact cInf_le' }
end

theorem succ_def (c : cardinal) : order.succ c = Inf {c' | c < c'} := rfl

theorem add_one_le_succ (c : cardinal) : c + 1 ≤ order.succ c :=
begin
  refine induction_on c (λ α, _),
  let s : set cardinal := {c | #α < c},
  have h : set.nonempty s := exists_gt #α,
  rw [succ_def, le_cInf_iff'' h],
  intro c,
  refine induction_on c (λ β h', _),
  change #α < #β at h',
  cases le_of_lt h' with f,
  have hf : ¬ function.surjective f,
  { exact λ hf, not_le_of_lt h' (mk_le_of_surjective hf) },
  simp only [function.surjective, not_forall] at hf,
  cases hf with b hb,
  rw ←mk_option,
  exact ⟨function.embedding.option_elim f b hb⟩
end

lemma succ_pos (c : cardinal) : 0 < order.succ c := order.bot_lt_succ c

lemma succ_ne_zero (c : cardinal) : order.succ c ≠ 0 := ne.symm (ne_of_lt (succ_pos c))

def sum {ι : Type u} (f : ι → cardinal.{v}) : cardinal.{max u v} := #(Σ i, (f i).out)

theorem le_sum {ι : Type u} (f : ι → cardinal.{max u v}) (i : ι) : f i ≤ sum f :=
mk_out (f i) ▸ ⟨⟨λ x, ⟨i, x⟩, λ x₁ x₂ h, eq_of_heq (by injection h)⟩⟩

@[simp] theorem mk_sigma {ι : Type u} (f : ι → Type v) :
  #(Σ i, f i) = sum (λ i, #(f i)) :=
mk_congr (equiv.sigma_congr_right (λ i, out_mk_equiv.symm))

@[simp] theorem sum_const (ι : Type u) (c : cardinal.{v}) :
  sum (λ i : ι, c) = lift #ι * lift.{u} c :=
begin
  refine induction_on c (λ α, mk_congr _),
  transitivity ι × (#α).out,
  { exact equiv.sigma_equiv_prod ι (#α).out },
  { exact equiv.ulift.symm.prod_congr (out_mk_equiv.trans equiv.ulift.symm) }
end

theorem sum_const' (ι : Type u) (c : cardinal.{u}) : sum (λ i : ι, c) = #ι * c :=
by simp

@[simp] theorem sum_add_distrib {ι : Type u} (f g : ι → cardinal.{v}) :
  sum (f + g) = sum f + sum g :=
begin
  have h := mk_congr (equiv.sigma_sum_distrib (quotient.out ∘ f) (quotient.out ∘ g)),
  simpa [mk_sigma, mk_sum, mk_out, lift_id] using h
end

@[simp] theorem sum_add_distrib' {ι : Type u} (f g : ι → cardinal.{v}) :
  sum (λ i, f i + g i) = sum f + sum g :=
sum_add_distrib f g

@[simp] theorem lift_sum {ι : Type u} (f : ι → cardinal.{v}) :
  lift.{w} (sum f) = sum (λ i, lift.{w} (f i)) :=
begin
  refine mk_congr _,
  transitivity Σ i, (f i).out,
  { exact equiv.ulift },
  { refine equiv.sigma_congr_right (λ i, classical.choice _),
    rw [←lift_mk_eq, mk_out, mk_out, lift_lift] }
end

theorem sum_le_sum {ι : Type u} (f g : ι → cardinal.{v}) (h : ∀ i, f i ≤ g i) :
  sum f ≤ sum g :=
begin
  refine ⟨function.embedding.sigma_map _ (λ i, classical.choice _)⟩,
  { exact function.embedding.refl ι },
  { specialize h i,
    rwa [←mk_out (f i), ←mk_out (g i)] at h }
end

lemma mk_le_mk_mul_of_mk_preimage_le {c : cardinal} (f : α → β) :
  (∀ b, #(f ⁻¹' {b}) ≤ c) → #α ≤ #β * c :=
begin
  simp only [←mk_congr (@equiv.sigma_fiber_equiv α β f), mk_sigma, ←sum_const'],
  exact sum_le_sum (λ b, #(f ⁻¹' {b})) (λ b, c)
end

theorem bdd_above_range {ι : Type u} (f : ι → cardinal.{max u v}) :
  bdd_above (set.range f) :=
⟨sum f, by { rintros c ⟨i, rfl⟩, exact le_sum f i }⟩

instance (c : cardinal.{u}) : small.{u} (set.Iic c) :=
begin
  rw ←mk_out c,
  let f : set c.out → set.Iic #c.out := λ s, ⟨#s, mk_set_le s⟩,
  refine @small_of_surjective (set c.out) (set.Iic #c.out) infer_instance f _,
  rintro ⟨c', h⟩,
  change c' ≤ #c.out at h,
  simp only [subtype.mk_eq_mk],
  rwa le_mk_iff_exists_set at h
end

theorem bdd_above_iff_small {s : set cardinal.{u}} : bdd_above s ↔ small.{u} s :=
begin
  split,
  { rintro ⟨c, hc⟩,
    change ∀ c', c' ∈ s → c' ≤ c at hc,
    exact @small_subset cardinal (set.Iic c) s hc infer_instance },
  { rintro ⟨ι, ⟨e⟩⟩,
    let f : ι → cardinal := λ i : ι, subtype.val (e.symm i),
    suffices h : set.range f = s,
    { exact h ▸ bdd_above_range.{u u} f },
    ext c,
    split,
    { rintro ⟨i, rfl⟩,
      exact subtype.prop (e.symm i) },
    { intro hc,
      use e ⟨c, hc⟩,
      dsimp only [f],
      rw [equiv.symm_apply_apply] } }
end

theorem bdd_above_image (f : cardinal.{u} → cardinal.{max u v}) {s : set cardinal.{u}}
  (hs : bdd_above s) : bdd_above (f '' s) :=
begin
  rw bdd_above_iff_small at ⊢ hs,
  exactI small_lift ↥(f '' s)
end

theorem bdd_above_range_comp {ι : Type u} {f : ι → cardinal.{v}}
  (hf : bdd_above (set.range f)) (g : cardinal.{v} → cardinal.{max v w}) :
  bdd_above (set.range (g ∘ f)) :=
by { rw set.range_comp, exact bdd_above_image g hf }

theorem supr_le_sum {ι : Type u} (f : ι → cardinal.{max u v}) : supr f ≤ sum f :=
csupr_le' (le_sum f)

theorem sum_le_supr_lift {ι : Type u} (f : ι → cardinal.{max u v}) :
  sum f ≤ lift #ι * supr f :=
begin
  rw [←lift_id (supr f), ←lift_umax, lift_umax.{(max u v) u}, ←sum_const],
  exact sum_le_sum f (λ i, supr f) (le_csupr (bdd_above_range f))
end

theorem sum_le_supr {ι : Type u} (f : ι → cardinal.{u}) : sum f ≤ #ι * supr f :=
lift_id #ι ▸ sum_le_supr_lift f

theorem sum_nat_eq_add_sum_succ (f : ℕ → cardinal.{u}) :
  sum f = f 0 + sum (λ i, f (i + 1)) :=
begin
  transitivity #((f 0).out ⊕ Σ i, (f (i + 1)).out),
  { exact mk_congr (equiv.sigma_nat_succ (λ i, (f i).out)) },
  { simp only [mk_sum, mk_out, mk_sigma, lift_id] }
end

@[simp] protected theorem supr_of_empty {ι : Type u} (f : ι → cardinal.{v}) [is_empty ι] :
  supr f = 0 :=
csupr_of_empty f

@[simp] lemma lift_mk_shrink (α : Type u) [small.{v} α] :
  lift.{max u w} #(shrink α) = lift.{max v w} #α :=
lift_mk_eq.mpr ⟨(equiv_shrink α).symm⟩

@[simp] lemma lift_mk_shrink' (α : Type u) [small.{v} α] :
  lift.{u} #(shrink α) = lift.{v} #α :=
lift_mk_shrink.{u v 0} α

@[simp] lemma lift_mk_shrink'' (α : Type (max u v)) [small.{v} α] :
  lift.{u} #(shrink α) = #α :=
by rw [←lift_umax', lift_mk_shrink'.{(max u v) v} α, ←lift_umax, lift_id]

def prod {ι : Type u} (f : ι → cardinal.{v}) : cardinal.{max u v} := #(Π i, (f i).out)

@[simp] theorem mk_pi {ι : Type u} (f : ι → Type v) :
  #(Π i, f i) = prod (λ i, #(f i)) :=
mk_congr (equiv.Pi_congr_right (λ i, out_mk_equiv.symm))

@[simp] theorem prod_const (ι : Type u) (c : cardinal.{v}) :
  prod (λ i : ι, c) = lift.{u} c ^ lift.{v} #ι :=
begin
  refine induction_on c (λ α, mk_congr (equiv.Pi_congr _ _)),
  { exact equiv.ulift.symm },
  { intro i,
    transitivity α,
    { exact out_mk_equiv },
    { exact equiv.ulift.symm } }
end

theorem prod_const' (ι : Type u) (c : cardinal.{u}) : prod (λ i : ι, c) = c ^ #ι :=
by simp

theorem prod_le_prod {ι : Type u} (f g : ι → cardinal.{v}) (h : ∀ i, f i ≤ g i) :
  prod f ≤ prod g :=
begin
  refine ⟨function.embedding.Pi_congr_right (λ i, classical.choice _)⟩,
  specialize h i,
  rwa [←mk_out (f i), ←mk_out (g i)] at h
end

@[simp] theorem prod_eq_zero {ι : Type u} (f : ι → cardinal.{v}) :
  prod f = 0 ↔ ∃ i, f i = 0 :=
begin
  lift f to ι → Type v using λ i, trivial,
  simp only [mk_eq_zero_iff, ←mk_pi, is_empty_pi]
end

theorem prod_ne_zero {ι : Type u} (f : ι → cardinal.{v}) : prod f ≠ 0 ↔ ∀ i, f i ≠ 0 :=
by simp [prod_eq_zero]

@[simp] theorem lift_prod {ι : Type u} (f : ι → cardinal.{v}) :
  lift.{w} (prod f) = prod (λ i, lift.{w} (f i)) :=
begin
  lift f to ι → Type v using λ i, trivial,
  simp only [←mk_pi, ←mk_ulift],
  refine mk_congr _,
  transitivity Π i, f i,
  { exact equiv.ulift },
  { exact equiv.Pi_congr_right (λ i, equiv.ulift.symm) }
end

@[simp] theorem lift_Inf (s : set cardinal) : lift (Inf s) = Inf (lift '' s) :=
begin
  cases set.eq_empty_or_nonempty s with hs hs,
  { rw [hs, Inf_empty, lift_zero, set.image_empty, Inf_empty] },
  { exact lift_monotone.map_Inf hs }
end

@[simp] theorem lift_infi {ι : Type u} (f : ι → cardinal.{v}) :
  lift (infi f) = infi (λ i, lift (f i)) :=
begin
  unfold infi,
  convert lift_Inf (set.range f),
  rw set.range_comp
end

theorem lift_down {c₁ : cardinal.{u}} {c₂ : cardinal.{max u v}} :
  c₂ ≤ lift c₁ → ∃ c₃, lift c₃ = c₂ :=
begin
  refine induction_on₂ c₁ c₂ (λ α β, _),
  rw [←lift_id #β, ←lift_umax, ←lift_umax.{u}, lift_mk_le],
  rintro ⟨f⟩,
  use #(set.range f),
  rw [eq_comm, lift_mk_eq],
  refine ⟨function.embedding.equiv_of_surjective _ _⟩,
  { exact function.embedding.cod_restrict (set.range f) f set.mem_range_self },
  { rintro ⟨a, ⟨b, h⟩⟩,
    simp only [function.embedding.cod_restrict_apply, subtype.mk_eq_mk],
    exact ⟨b, h⟩ }
end

theorem le_lift_iff {c₁ : cardinal.{u}} {c₂ : cardinal.{max u v}} :
  c₂ ≤ lift c₁ ↔ ∃ c₃, lift c₃ = c₂ ∧ c₃ ≤ c₁ :=
begin
  split,
  { intro h,
    rcases lift_down h with ⟨c₃, rfl⟩,
    rw lift_le at h,
    exact ⟨c₃, rfl, h⟩ },
  { rintro ⟨c₃, rfl, h⟩,
    rwa lift_le }
end

theorem lt_lift_iff {c₁ : cardinal.{u}} {c₂ : cardinal.{max u v}} :
  c₂ < lift c₁ ↔ ∃ c₃, lift c₃ = c₂ ∧ c₃ < c₁ :=
begin
  split,
  { intro h,
    rcases lift_down (le_of_lt h) with ⟨c₃, rfl⟩,
    rw lift_lt at h,
    exact ⟨c₃, rfl, h⟩ },
  { rintro ⟨c₃, rfl, h⟩,
    rwa lift_lt }
end

@[simp] theorem lift_succ (c : cardinal) : lift (order.succ c) = order.succ (lift c) :=
begin
  refine le_antisymm (le_of_not_gt _) _,
  { intro h,
    rcases lt_lift_iff.mp h with ⟨c', h₁, h₂⟩,
    rw [order.lt_succ_iff, ←lift_le, h₁, ←not_lt] at h₂,
    exact h₂ (order.lt_succ c.lift) },
  { refine order.succ_le_of_lt _,
    rw lift_lt,
    exact order.lt_succ c }
end

@[simp] theorem lift_umax_eq {c₁ : cardinal.{u}} {c₂ : cardinal.{v}} :
  lift.{max v w} c₁ = lift.{max u w} c₂ ↔ lift.{v} c₁ = lift.{u} c₂ :=
by rw [←lift_lift, ←lift_lift, lift_inj]

@[simp] theorem lift_min {c₁ c₂ : cardinal} :
  lift (min c₁ c₂) = min (lift c₁) (lift c₂) :=
lift_monotone.map_min

@[simp] theorem lift_max {c₁ c₂ : cardinal} :
  lift (max c₁ c₂) = max (lift c₁) (lift c₂) :=
lift_monotone.map_max

lemma lift_Sup {s : set cardinal} (hs : bdd_above s) :
  lift (Sup s) = Sup (lift '' s) :=
begin
  refine le_antisymm _ _,
  { rw le_cSup_iff' (bdd_above_image lift hs),
    intros c hc,
    by_contra h,
    obtain ⟨c, rfl⟩ := lift_down (le_of_not_le h),
    rw [lift_le, cSup_le_iff' hs] at h,
    refine h _,
    intros c' hc',
    change ∀ c', c' ∈ lift '' s → c' ≤ c.lift at hc,
    specialize hc (lift c') (set.mem_image_of_mem lift hc'),
    rwa lift_le at hc },
  { refine cSup_le' _,
    rintros c ⟨c, hc, rfl⟩,
    rw lift_le,
    exact le_cSup hs hc }
end

lemma lift_supr {ι : Type u} {f : ι → cardinal.{v}} (hf : bdd_above (set.range f)) :
  lift (supr f) = supr (λ i, lift (f i)) :=
by rw [supr, supr, lift_Sup hf, set.range_comp lift]

@[simp] lemma lift_supr_le_iff {ι : Type u} {f : ι → cardinal.{v}} {t : cardinal.{max v w}} :
  bdd_above (set.range f) → (lift (supr f) ≤ t ↔ ∀ i, lift (f i) ≤ t) :=
begin
  intro hf,
  rw lift_supr hf,
  exact csupr_le_iff' (bdd_above_range_comp hf lift)
end

lemma lift_supr_le {ι : Type u} {f : ι → cardinal.{v}} {t : cardinal.{max v w}} :
  bdd_above (set.range f) → (∀ i, lift (f i) ≤ t) → lift (supr f) ≤ t :=
by { intro hf, simp [hf] }

lemma {u' v'} lift_supr_le_lift_supr
  {ι : Type u} {ι' : Type u'} {f : ι → cardinal.{v}} {f' : ι' → cardinal.{v'}}
  (hf : bdd_above (set.range f)) (hf' : bdd_above (set.range f'))
  {g : ι → ι'} (h : ∀ i, lift.{v'} (f i) ≤ lift.{v} (f' (g i))) :
  lift.{v'} (supr f) ≤ lift.{v} (supr f') :=
begin
  rw [lift_supr hf, lift_supr hf'],
  refine csupr_mono' (bdd_above_range_comp hf' lift) _,
  intro i,
  use g i,
  exact h i
end

lemma lift_supr_le_lift_supr'
  {ι : Type u} {ι' : Type v} {f : ι → cardinal.{u}} {f' : ι' → cardinal.{v}}
  (hf : bdd_above (set.range f)) (hf' : bdd_above (set.range f'))
  {g : ι → ι'} (h : ∀ i, lift.{v} (f i) ≤ lift.{u} (f' (g i))) :
  lift.{v} (supr f) ≤ lift.{u} (supr f') :=
lift_supr_le_lift_supr hf hf' h

def aleph_0 : cardinal.{u} := lift #ℕ

notation `ℵ₀` := cardinal.aleph_0

lemma mk_nat : #ℕ = ℵ₀ := eq.symm (lift_id #ℕ)

theorem aleph_0_ne_zero : ℵ₀ ≠ 0 := mk_ne_zero (ulift ℕ)

theorem aleph_0_pos : 0 < ℵ₀ := pos_iff_ne_zero.mpr aleph_0_ne_zero

@[simp] theorem lift_aleph_0 : lift ℵ₀ = ℵ₀ := lift_lift #ℕ

@[simp] theorem aleph_0_le_lift {c : cardinal} : ℵ₀ ≤ lift c ↔ ℵ₀ ≤ c :=
by rw [←lift_aleph_0, lift_le]

@[simp] theorem lift_le_aleph_0 {c : cardinal} : lift c ≤ ℵ₀ ↔ c ≤ ℵ₀ :=
by rw [←lift_aleph_0, lift_le]

@[simp] theorem mk_fin (n : ℕ) : #(fin n) = n := by simp

@[simp] theorem lift_nat_cast (n : ℕ) : lift.{v} (n : cardinal.{u}) = n :=
begin
  induction n with n ih,
  { rw [nat.cast_zero, nat.cast_zero, lift_zero] },
  { rw [nat.cast_succ, nat.cast_succ, lift_add, lift_one, ih] }
end

@[simp] lemma lift_eq_nat_iff {c : cardinal.{u}} {n : ℕ} : lift.{v} c = n ↔ c = n :=
by rw [←lift_nat_cast.{u} n, lift_inj]

@[simp] lemma nat_eq_lift_iff {n : ℕ} {c : cardinal.{u}} : ↑n = lift.{v} c ↔ ↑n = c :=
by rw [←lift_nat_cast.{u} n, lift_inj]

theorem lift_mk_fin (n : ℕ) : lift #(fin n) = n := by simp

lemma mk_coe_finset {s : finset α} : #s = finset.card s := by simp

lemma mk_finset_of_fintype [fintype α] : #(finset α) = 2 ^ℕ fintype.card α := by simp

theorem card_le_of_finset (s : finset α) : ↑s.card ≤ #α :=
begin
  rw [show ↑s.card = #s, by rw [cardinal.mk_fintype, fintype.card_coe]],
  exact ⟨function.embedding.subtype (λ a, a ∈ s)⟩
end

@[simp, norm_cast] theorem nat_cast_pow {n m : ℕ} : ↑(pow n m) = n ^ m :=
begin
  induction m with m ih,
  { rw [pow_zero, nat.cast_one, nat.cast_zero, power_zero] },
  { rw [pow_succ', nat.cast_mul, ih, nat.cast_succ, power_add, power_one] }
end

@[simp, norm_cast] theorem nat_cast_le {n m : ℕ} : (n : cardinal) ≤ m ↔ n ≤ m :=
begin
  rw [←lift_mk_fin, ←lift_mk_fin, lift_le],
  split,
  { rintro ⟨⟨f, hf⟩⟩,
    have h : fintype.card (fin n) ≤ fintype.card (fin m),
    { exact fintype.card_le_of_injective f hf },
    rwa [fintype.card_fin n, fintype.card_fin m] at h },
  { intro h,
    obtain ⟨f, hf⟩ : fin n ↪o fin m := fin.cast_le h,
    exact ⟨f⟩ }
end

@[simp, norm_cast] theorem nat_cast_lt {n m : ℕ} : (n : cardinal) < m ↔ n < m :=
by { rw [←not_le, ←not_le, not_iff_not], exact nat_cast_le }

instance : char_zero cardinal := ⟨strict_mono.injective (λ m n, nat_cast_lt.mpr)⟩

theorem nat_cast_inj {n m : ℕ} : (n : cardinal) = m ↔ n = m := nat.cast_inj

lemma nat_cast_injective : function.injective (coe : ℕ → cardinal) :=
nat.cast_injective

@[simp, norm_cast, priority 900] theorem nat_succ (n : ℕ) :
  (n.succ : cardinal) = order.succ n :=
begin
  refine le_antisymm _ _,
  { exact add_one_le_succ n },
  { refine order.succ_le_of_lt _,
    rw nat_cast_lt,
    exact nat.lt_succ_self n }
end

@[simp] theorem succ_zero : order.succ (0 : cardinal) = 1 := by norm_cast

@[simp] theorem succ_one : order.succ (1 : cardinal) = 2 := by norm_cast

theorem card_le_of {n : ℕ} (h : ∀ s : finset α, s.card ≤ n) : #α ≤ n :=
begin
  refine order.le_of_lt_succ (lt_of_not_ge _),
  intro h',
  rw [←nat_succ, ←lift_mk_fin n.succ] at h',
  cases h' with f,
  specialize h (finset.map f finset.univ),
  refine not_lt_of_le h _,
  rw [finset.card_map, ←fintype.card, fintype.card_ulift, fintype.card_fin],
  exact nat.lt_succ_self n
end

theorem cantor' (c₁ : cardinal) {c₂ : cardinal} (hb : 1 < c₂) : c₁ < c₂ ^ c₁ :=
begin
  rw [←order.succ_le_iff, succ_one] at hb,
  calc c₁ < 2 ^ c₁  : cantor c₁
      ... ≤ c₂ ^ c₁ : power_le_power_right hb
end

theorem one_le_iff_pos {c : cardinal} : 1 ≤ c ↔ 0 < c :=
succ_zero ▸ order.succ_le_iff

theorem one_le_iff_ne_zero {c : cardinal} : 1 ≤ c ↔ c ≠ 0 :=
by rw [one_le_iff_pos, pos_iff_ne_zero]

theorem nat_lt_aleph_0 (n : ℕ) : ↑n < ℵ₀ :=
begin
  rw [←order.succ_le_iff, ←nat_succ, ←lift_mk_fin, aleph_0, lift_mk_le.{0 0}],
  exact ⟨⟨coe, λ n m, fin.ext⟩⟩
end

@[simp] theorem one_lt_aleph_0 : 1 < ℵ₀ :=
@nat.cast_one cardinal infer_instance ▸ nat_lt_aleph_0 1

theorem one_le_aleph_0 : 1 ≤ ℵ₀ := le_of_lt one_lt_aleph_0

theorem lt_aleph_0 {c : cardinal} : c < ℵ₀ ↔ ∃ n : ℕ, c = n :=
begin
  split,
  { intro h,
    change c < lift #ℕ at h,
    rw lt_lift_iff at h,
    rcases h with ⟨c, rfl, h, h'⟩,
    rw le_mk_iff_exists_set at h,
    rcases h with ⟨s, rfl⟩,
    suffices h : set.finite s,
    { lift s to finset ℕ using h, simp },
    contrapose! h' with h,
    replace h : infinite s := set.infinite.to_subtype h,
    exactI ⟨infinite.nat_embedding s⟩ },
  { rintro ⟨n, rfl⟩,
    exact nat_lt_aleph_0 n }
end

theorem aleph_0_le {c : cardinal} : ℵ₀ ≤ c ↔ ∀ n : ℕ, ↑n ≤ c :=
begin
  refine ⟨λ h n, _, λ h, le_of_not_lt (λ h', _)⟩,
  { transitivity ℵ₀,
    { exact le_of_lt (nat_lt_aleph_0 n) },
    { exact h } },
  { rw lt_aleph_0 at h',
    rcases h' with ⟨n, rfl⟩,
    specialize h n.succ,
    rw nat_cast_le at h,
    exact not_le_of_lt (nat.lt_succ_self n) h }
end

theorem lt_aleph_0_iff_fintype : #α < ℵ₀ ↔ nonempty (fintype α) :=
begin
  transitivity ∃ n, #α = ↑n,
  { exact lt_aleph_0 },
  { split,
    { rintro ⟨n, h⟩,
      rw ←lift_mk_fin n at h,
      cases quotient.exact h with e,
      exact ⟨fintype.of_equiv (ulift (fin n)) e.symm⟩ },
    { rintro ⟨h⟩,
      exactI ⟨fintype.card α, mk_fintype α⟩ } }
end

theorem lt_aleph_0_of_fintype (α : Type u) [fintype α] : #α < ℵ₀ :=
lt_aleph_0_iff_fintype.mpr ⟨infer_instance⟩

theorem lt_aleph_0_iff_finite {s : set α} : #s < ℵ₀ ↔ s.finite :=
begin
  transitivity nonempty (fintype s),
  { exact lt_aleph_0_iff_fintype },
  { rw set.finite_def }
end

instance can_lift_cardinal_nat : can_lift cardinal ℕ :=
⟨coe, λ c, c < ℵ₀, λ c h, let ⟨n, h⟩ := lt_aleph_0.mp h in ⟨n, h.symm⟩⟩

theorem add_lt_aleph_0 {c₁ c₂ : cardinal} (h₁ : c₁ < ℵ₀) (h₂ : c₂ < ℵ₀) :
  c₁ + c₂ < ℵ₀ :=
begin
  rw lt_aleph_0 at h₁ h₂,
  rcases h₁ with ⟨n, rfl⟩,
  rcases h₂ with ⟨m, rfl⟩,
  rw ←nat.cast_add,
  exact nat_lt_aleph_0 (n + m)
end

lemma add_lt_aleph_0_iff {c₁ c₂ : cardinal} : c₁ + c₂ < ℵ₀ ↔ c₁ < ℵ₀ ∧ c₂ < ℵ₀ :=
begin
  split,
  { refine λ h, ⟨lt_of_le_of_lt _ h, lt_of_le_of_lt _ h⟩,
    { exact self_le_add_right c₁ c₂ },
    { exact self_le_add_left c₂ c₁ } },
  { rintros ⟨h₁, h₂⟩,
    exact add_lt_aleph_0 h₁ h₂ }
end

lemma aleph_0_le_add_iff {c₁ c₂ : cardinal} : ℵ₀ ≤ c₁ + c₂ ↔ ℵ₀ ≤ c₁ ∨ ℵ₀ ≤ c₂ :=
by rw [←not_lt, ←not_lt, ←not_lt, add_lt_aleph_0_iff, not_and_distrib]

lemma nsmul_lt_aleph_0_iff {n : ℕ} {c : cardinal} : n • c < ℵ₀ ↔ n = 0 ∨ c < ℵ₀ :=
begin
  cases n with n,
  { rw [zero_smul, eq_self_iff_true, true_or, iff_true],
    exact nat_lt_aleph_0 0 },
  { simp only [nat.succ_ne_zero, false_or],
    induction n with n ih,
    { rw [nsmul_eq_mul, nat.cast_one, one_mul] },
    { rw [succ_nsmul, add_lt_aleph_0_iff, ih, and_self] } }
end

lemma nsmul_lt_aleph_0_iff_of_ne_zero {n : ℕ} {c : cardinal} (h : n ≠ 0) :
  n • c < ℵ₀ ↔ c < ℵ₀ :=
begin
  transitivity n = 0 ∨ c < ℵ₀,
  { exact nsmul_lt_aleph_0_iff },
  { exact or_iff_right h }
end

theorem mul_lt_aleph_0 {c₁ c₂ : cardinal} (h₁ : c₁ < ℵ₀) (h₂ : c₂ < ℵ₀) :
  c₁ * c₂ < ℵ₀ :=
begin
  rw lt_aleph_0 at h₁ h₂,
  rcases h₁ with ⟨n, rfl⟩,
  rcases h₂ with ⟨m, rfl⟩,
  rw ←nat.cast_mul,
  exact nat_lt_aleph_0 (n * m)
end

lemma mul_lt_aleph_0_iff {c₁ c₂ : cardinal} :
  c₁ * c₂ < ℵ₀ ↔ c₁ = 0 ∨ c₂ = 0 ∨ (c₁ < ℵ₀ ∧ c₂ < ℵ₀) :=
begin
  split,
  { intro h,
    by_cases h₁ : c₁ = 0, exact or.inl h₁, right,
    by_cases h₂ : c₂ = 0, exact or.inl h₂, right,
    rw [←ne, ←one_le_iff_ne_zero] at h₁ h₂,
    split,
    { rw ←mul_one c₁,
      exact lt_of_le_of_lt (mul_le_mul' le_rfl h₂) h },
    { rw ←one_mul c₂,
      exact lt_of_le_of_lt (mul_le_mul' h₁ le_rfl) h } },
  { rintro (rfl | rfl | ⟨h₁, h₂⟩),
    { rw [zero_mul], exact aleph_0_pos },
    { rw [mul_zero], exact aleph_0_pos },
    { exact mul_lt_aleph_0 h₁ h₂ } }
end

lemma aleph_0_le_mul_iff {c₁ c₂ : cardinal} :
  ℵ₀ ≤ c₁ * c₂ ↔ c₁ ≠ 0 ∧ c₂ ≠ 0 ∧ (ℵ₀ ≤ c₁ ∨ ℵ₀ ≤ c₂) :=
begin
  have h := not_congr (@mul_lt_aleph_0_iff c₁ c₂),
  rwa [not_lt, not_or_distrib, not_or_distrib, not_and_distrib, not_lt, not_lt] at h
end

lemma aleph_0_le_mul_iff' {c₁ c₂ : cardinal.{u}} :
  ℵ₀ ≤ c₁ * c₂ ↔ (c₁ ≠ 0 ∧ ℵ₀ ≤ c₂) ∨ (ℵ₀ ≤ c₁ ∧ c₂ ≠ 0) :=
begin
  transitivity c₁ ≠ 0 ∧ c₂ ≠ 0 ∧ (ℵ₀ ≤ c₁ ∨ ℵ₀ ≤ c₂),
  { exact aleph_0_le_mul_iff },
  { have h₁ : ℵ₀ ≤ c₁ → c₁ ≠ 0 := ne_bot_of_le_ne_bot aleph_0_ne_zero,
    have h₂ : ℵ₀ ≤ c₂ → c₂ ≠ 0 := ne_bot_of_le_ne_bot aleph_0_ne_zero,
    tauto }
end

lemma mul_lt_aleph_0_iff_of_ne_zero {c₁ c₂ : cardinal} (h₁ : c₁ ≠ 0) (h₂ : c₂ ≠ 0) :
  c₁ * c₂ < ℵ₀ ↔ c₁ < ℵ₀ ∧ c₂ < ℵ₀ :=
by simp only [mul_lt_aleph_0_iff, h₁, h₂, false_or]

theorem power_lt_aleph_0 {c₁ c₂ : cardinal} (h₁ : c₁ < ℵ₀) (h₂ : c₂ < ℵ₀) :
  c₁ ^ c₂ < ℵ₀ :=
begin
  rw lt_aleph_0 at h₁ h₂,
  rcases h₁ with ⟨n, rfl⟩,
  rcases h₂ with ⟨m, rfl⟩,
  rw ←nat_cast_pow,
  exact nat_lt_aleph_0 (pow n m)
end

lemma eq_one_iff_unique : #α = 1 ↔ subsingleton α ∧ nonempty α :=
begin
  transitivity #α ≤ 1 ∧ 1 ≤ #α,
  { exact le_antisymm_iff },
  { refine and_congr le_one_iff_subsingleton _,
    transitivity #α ≠ 0,
    { exact one_le_iff_ne_zero },
    { exact mk_ne_zero_iff } }
end

lemma eq_one_iff_unique' : #α = 1 ↔ nonempty (unique α) :=
begin
  transitivity subsingleton α ∧ nonempty α,
  { exact eq_one_iff_unique },
  { exact iff.symm (unique_iff_subsingleton_and_nonempty α) }
end

theorem infinite_iff : infinite α ↔ ℵ₀ ≤ #α :=
by rw [←not_lt, lt_aleph_0_iff_fintype, not_nonempty_iff, is_empty_fintype]

@[simp] lemma aleph_0_le_mk (α : Type u) [infinite α] : ℵ₀ ≤ #α :=
infinite_iff.mp infer_instance

lemma encodable_iff : nonempty (encodable α) ↔ #α ≤ ℵ₀ :=
begin
  split,
  { rintro ⟨h⟩,
    refine ⟨_⟩,
    transitivity ℕ,
    { exact @encodable.encode' α h },
    { exact equiv.ulift.symm.to_embedding } },
  { rintro ⟨f⟩,
    replace f : α ↪ ℕ := function.embedding.trans f equiv.ulift.to_embedding,
    exact ⟨encodable.of_inj f (function.embedding.injective f)⟩ }
end

@[simp] lemma mk_le_aleph_0 (α : Type u) [encodable α] : #α ≤ ℵ₀ :=
encodable_iff.mp ⟨infer_instance⟩

lemma denumerable_iff : nonempty (denumerable α) ↔ #α = ℵ₀ :=
begin
  split,
  { rintro ⟨h⟩,
    refine mk_congr _,
    transitivity ℕ,
    { exact @denumerable.eqv α h },
    { exact equiv.ulift.symm } },
  { intro h,
    cases quotient.exact h with e,
    refine ⟨denumerable.mk' _⟩,
    transitivity ulift ℕ,
    { exact e },
    { exact equiv.ulift } }
end

@[simp] lemma mk_denumerable (α : Type u) [denumerable α] : #α = ℵ₀ :=
denumerable_iff.mp ⟨infer_instance⟩

@[simp] lemma mk_set_le_aleph_0 (s : set α) : #s ≤ ℵ₀ ↔ set.countable s :=
begin
  rw [set.countable_iff_exists_injective],
  split,
  { rintro ⟨f⟩,
    obtain ⟨f, hf⟩ : s ↪ ℕ := function.embedding.trans f equiv.ulift.to_embedding,
    exact ⟨f, hf⟩ },
  { rintro ⟨f, hf⟩,
    have f : s ↪ ulift ℕ := function.embedding.trans ⟨f, hf⟩ equiv.ulift.symm.to_embedding,
    exact ⟨f⟩ }
end

@[simp] lemma mk_subtype_le_aleph_0 (p : α → Prop) :
  #{a // p a} ≤ ℵ₀ ↔ set.countable {a | p a} :=
mk_set_le_aleph_0 (set_of p)

@[simp] lemma aleph_0_add_aleph_0 : (ℵ₀ + ℵ₀ : cardinal.{u}) = ℵ₀ :=
mk_denumerable (ulift.{u} ℕ ⊕ ulift.{u} ℕ)

lemma aleph_0_mul_aleph_0 : (ℵ₀ * ℵ₀ : cardinal.{u}) = ℵ₀ :=
mk_denumerable (ulift.{u} ℕ × ulift.{u} ℕ)

@[simp] lemma add_le_aleph_0 {c₁ c₂ : cardinal} : c₁ + c₂ ≤ ℵ₀ ↔ c₁ ≤ ℵ₀ ∧ c₂ ≤ ℵ₀ :=
begin
  split,
  { intro h,
    split,
    { exact le_trans le_self_add h },
    { exact le_trans le_add_self h } },
  { rintro ⟨h₁, h₂⟩,
    exact aleph_0_add_aleph_0 ▸ add_le_add h₁ h₂ }
end

noncomputable def to_nat.to_fun : cardinal → ℕ :=
λ c, if h : c < ℵ₀ then classical.some (lt_aleph_0.mp h) else 0

theorem to_nat.map_zero' : to_nat.to_fun 0 = 0 :=
begin
  unfold to_nat.to_fun,
  have h : 0 < ℵ₀ := nat_lt_aleph_0 0,
  rw [dif_pos h, ←nat_cast_inj, ←classical.some_spec (lt_aleph_0.mp h), nat.cast_zero]
end

noncomputable def to_nat : zero_hom cardinal ℕ :=
{ to_fun := to_nat.to_fun, map_zero' := to_nat.map_zero' }

lemma to_nat_apply_of_lt_aleph_0 {c : cardinal} (h : c < ℵ₀) :
  to_nat c = classical.some (lt_aleph_0.mp h) :=
dif_pos h

lemma to_nat_apply_of_aleph_0_le {c : cardinal} (h : ℵ₀ ≤ c) : to_nat c = 0 :=
dif_neg (not_lt_of_le h)

lemma cast_to_nat_of_lt_aleph_0 {c : cardinal} (h : c < ℵ₀) : ↑(to_nat c) = c :=
by rw [to_nat_apply_of_lt_aleph_0 h, ←classical.some_spec (lt_aleph_0.mp h)]

lemma cast_to_nat_of_aleph_0_le {c : cardinal} (h : ℵ₀ ≤ c) :
  (to_nat c : cardinal) = 0 :=
by rw [to_nat_apply_of_aleph_0_le h, nat.cast_zero]

lemma to_nat_le_iff_le_of_lt_aleph_0 {c₁ c₂ : cardinal} (h₁ : c₁ < ℵ₀) (h₂ : c₂ < ℵ₀) :
  to_nat c₁ ≤ to_nat c₂ ↔ c₁ ≤ c₂ :=
by rw [←nat_cast_le, cast_to_nat_of_lt_aleph_0 h₁, cast_to_nat_of_lt_aleph_0 h₂]

lemma to_nat_lt_iff_lt_of_lt_aleph_0 {c₁ c₂ : cardinal} (h₁ : c₁ < ℵ₀) (h₂ : c₂ < ℵ₀) :
  to_nat c₁ < to_nat c₂ ↔ c₁ < c₂ :=
by rw [←nat_cast_lt, cast_to_nat_of_lt_aleph_0 h₁, cast_to_nat_of_lt_aleph_0 h₂]

lemma to_nat_le_of_le_of_lt_aleph_0 {c₁ c₂ : cardinal} (h₁ : c₂ < ℵ₀) (h₂ : c₁ ≤ c₂) :
  to_nat c₁ ≤ to_nat c₂ :=
by rwa [to_nat_le_iff_le_of_lt_aleph_0 (lt_of_le_of_lt h₂ h₁) h₁]

lemma to_nat_lt_of_lt_of_lt_aleph_0 {c₁ c₂ : cardinal} (h₁ : c₂ < ℵ₀) (h₂ : c₁ < c₂) :
  to_nat c₁ < to_nat c₂ :=
by rwa [to_nat_lt_iff_lt_of_lt_aleph_0 (lt_trans h₂ h₁) h₁]

@[simp] lemma to_nat_cast (n : ℕ) : to_nat n = n :=
begin
  have h : ↑n < ℵ₀ := nat_lt_aleph_0 n,
  rw [to_nat_apply_of_lt_aleph_0 h, ←nat_cast_inj, ←classical.some_spec (lt_aleph_0.mp h)]
end

lemma to_nat_right_inverse : function.right_inverse coe to_nat :=
to_nat_cast

lemma to_nat_surjective : function.surjective to_nat :=
to_nat_right_inverse.surjective

@[simp] lemma mk_to_nat_of_infinite [infinite α] : to_nat #α = 0 :=
dif_neg (not_lt_of_le (infinite_iff.mp infer_instance))

@[simp] theorem aleph_0_to_nat : to_nat ℵ₀ = 0 :=
to_nat_apply_of_aleph_0_le le_rfl

lemma mk_to_nat_eq_card [fintype α] : to_nat #α = fintype.card α := by simp

@[simp] lemma zero_to_nat : to_nat 0 = 0 :=
by rw [←to_nat_cast 0, nat.cast_zero]

@[simp] lemma one_to_nat : to_nat 1 = 1 :=
by rw [←to_nat_cast 1, nat.cast_one]

@[simp] lemma to_nat_eq_one {c : cardinal} : to_nat c = 1 ↔ c = 1 :=
begin
  split,
  { intro h,
    transitivity ↑(to_nat c),
    { replace h : ¬ ℵ₀ ≤ c := one_ne_zero ∘ h.symm.trans ∘ to_nat_apply_of_aleph_0_le,
      rw cast_to_nat_of_lt_aleph_0 (lt_of_not_ge h) },
    { replace h : (to_nat c : cardinal) = ↑1 := congr_arg coe h,
      rwa nat.cast_one at h } },
  { rintro rfl, exact one_to_nat }
end

lemma to_nat_eq_one_iff_unique : to_nat #α = 1 ↔ subsingleton α ∧ nonempty α :=
begin
  transitivity #α = 1,
  { exact to_nat_eq_one },
  { exact eq_one_iff_unique }
end

@[simp] lemma to_nat_lift (c : cardinal) : to_nat (lift c) = to_nat c :=
begin
  refine nat_cast_injective _,
  cases lt_or_ge c ℵ₀ with h₁ h₁,
  { have h₂ : lift c < ℵ₀ := lift_aleph_0 ▸ lift_lt.mpr h₁,
    rw [cast_to_nat_of_lt_aleph_0 h₂, ←lift_nat_cast, cast_to_nat_of_lt_aleph_0 h₁] },
  { have h₂ : ℵ₀ ≤ lift c := lift_aleph_0 ▸ lift_le.mpr h₁,
    rw [cast_to_nat_of_aleph_0_le h₂, cast_to_nat_of_aleph_0_le h₁] }
end

lemma to_nat_congr (e : α ≃ β) : to_nat #α = to_nat #β :=
by rw [←to_nat_lift, lift_mk_eq.mpr ⟨e⟩, to_nat_lift]

@[simp] lemma to_nat_mul (c₁ c₂ : cardinal) :
  to_nat (c₁ * c₂) = to_nat c₁ * to_nat c₂ :=
begin
  rcases eq_or_ne c₁ 0 with rfl | h₁₁,
  { rw [zero_mul, zero_to_nat, zero_mul] },
  rcases eq_or_ne c₂ 0 with rfl | h₂₁,
  { rw [mul_zero, zero_to_nat, mul_zero] },
  cases lt_or_le c₁ ℵ₀ with h₁₂ h₁₂,
  { cases lt_or_le c₂ ℵ₀ with h₂₂ h₂₂,
    { lift c₁ to ℕ using h₁₂,
      lift c₂ to ℕ using h₂₂,
      rw [←nat.cast_mul, to_nat_cast, to_nat_cast, to_nat_cast] },
    { have h : ℵ₀ ≤ c₁ * c₂ := aleph_0_le_mul_iff'.mpr (or.inl ⟨h₁₁, h₂₂⟩),
      rw [to_nat_apply_of_aleph_0_le h₂₂, mul_zero, to_nat_apply_of_aleph_0_le h] } },
  { have h : ℵ₀ ≤ c₁ * c₂ := aleph_0_le_mul_iff'.mpr (or.inr ⟨h₁₂, h₂₁⟩),
    rw [to_nat_apply_of_aleph_0_le h₁₂, zero_mul, to_nat_apply_of_aleph_0_le h] },
end

@[simp] lemma to_nat_add_of_lt_aleph_0 {c₁ : cardinal.{u}} {c₂ : cardinal.{v}} :
  c₁ < ℵ₀ → c₂ < ℵ₀ → to_nat (lift.{v} c₁ + lift.{u} c₂) = to_nat c₁ + to_nat c₂ :=
begin
  intros h₁ h₂,
  refine cardinal.nat_cast_injective _,
  replace h₁ : lift.{v} c₁ < ℵ₀ := lift_aleph_0 ▸ lift_lt.mpr h₁,
  replace h₂ : lift.{u} c₂ < ℵ₀ := lift_aleph_0 ▸ lift_lt.mpr h₂,
  rw [nat.cast_add, ←to_nat_lift c₁, ←to_nat_lift c₂, cast_to_nat_of_lt_aleph_0 h₁, cast_to_nat_of_lt_aleph_0 h₂],
  exact cast_to_nat_of_lt_aleph_0 (add_lt_aleph_0 h₁ h₂)
end

noncomputable def to_enat.to_fun : cardinal → enat :=
λ c, if c < ℵ₀ then to_nat c else ⊤

theorem to_enat.map_zero' : to_enat.to_fun 0 = 0 :=
begin
  unfold to_enat.to_fun,
  have h : 0 < ℵ₀ := nat_lt_aleph_0 0,
  rw [if_pos h, zero_to_nat, nat.cast_zero]
end

theorem to_enat.map_add' (c₁ c₂ : cardinal) :
  to_enat.to_fun (c₁ + c₂) = to_enat.to_fun c₁ + to_enat.to_fun c₂ :=
begin
  unfold to_enat.to_fun,
  by_cases h₁ : c₁ < ℵ₀,
  { by_cases h₂ : c₂ < ℵ₀,
    { obtain ⟨n, rfl⟩ := lt_aleph_0.mp h₁,
      obtain ⟨m, rfl⟩ := lt_aleph_0.mp h₂,
      rw [if_pos (add_lt_aleph_0 h₁ h₂), if_pos h₁, if_pos h₂],
      rw [←nat.cast_add, to_nat_cast, to_nat_cast, to_nat_cast, nat.cast_add] },
    { have h : ¬ c₁ + c₂ < ℵ₀,
      { contrapose! h₂,
        exact lt_of_le_of_lt le_add_self h₂ },
      rw [if_neg h₂, if_neg h, enat.add_top] } },
  { have h : ¬ c₁ + c₂ < ℵ₀,
    { contrapose! h₁,
      exact lt_of_le_of_lt le_self_add h₁ },
    rw [if_neg h₁, if_neg h, enat.top_add] }
end

noncomputable def to_enat : cardinal →+ enat :=
{ to_fun    := to_enat.to_fun,
  map_zero' := to_enat.map_zero',
  map_add'  := to_enat.map_add' }

lemma to_enat_apply_of_lt_aleph_0 {c : cardinal} (h : c < ℵ₀) : to_enat c = to_nat c :=
if_pos h

lemma to_enat_apply_of_aleph_0_le {c : cardinal} (h : ℵ₀ ≤ c) : c.to_enat = ⊤ :=
if_neg (not_lt_of_le h)

@[simp] lemma to_enat_cast (n : ℕ) : to_enat n = n :=
by rw [to_enat_apply_of_lt_aleph_0 (nat_lt_aleph_0 n), to_nat_cast]

@[simp] lemma mk_to_enat_of_infinite [infinite α] : to_enat #α = ⊤ :=
to_enat_apply_of_aleph_0_le (infinite_iff.mp infer_instance)

@[simp] theorem aleph_0_to_enat : to_enat ℵ₀ = ⊤ :=
to_enat_apply_of_aleph_0_le le_rfl

lemma to_enat_surjective : function.surjective to_enat :=
begin
  refine λ n, enat.cases_on n _ (λ n, _),
  { exact ⟨ℵ₀, to_enat_apply_of_aleph_0_le le_rfl⟩ },
  { exact ⟨n, to_enat_cast n⟩ }
end

lemma mk_to_enat_eq_coe_card [fintype α] : to_enat #α = fintype.card α := by simp

lemma mk_int : #ℤ = ℵ₀ := mk_denumerable ℤ

lemma mk_pnat : #ℕ+ = ℵ₀ := mk_denumerable ℕ+

theorem sum_lt_prod {ι : Type u} (f g : ι → cardinal.{v}) (h : ∀ i, f i < g i) :
  sum f < prod g :=
begin
  refine lt_of_not_ge _,
  rintro ⟨F⟩,
  haveI I : nonempty (Π i, (g i).out),
  { refine ⟨λ i, classical.choice (mk_ne_zero_iff.mp _)⟩,
    rw mk_out,
    exact ne_bot_of_gt (h i) },
  let G : (Σ i, (f i).out) → Π i, (g i).out := function.inv_fun F,
  have hG : function.surjective G,
  { exact function.inv_fun_surjective (function.embedding.injective F) },
  have hC : ∀ i, ∃ y, ∀ x, G ⟨i, x⟩ i ≠ y,
  { simp only [←not_exists, ←not_forall],
    change ¬ ∃ i, ∀ y, ∃ x, G ⟨i, x⟩ i = y,
    rintro ⟨i, hi⟩,
    refine not_le_of_lt (h i) _,
    rw [←mk_out (f i), ←mk_out (g i)],
    exact ⟨function.embedding.of_surjective (λ x, G ⟨i, x⟩ i) hi⟩ },
  choose C hC using hC,
  obtain ⟨⟨i, x⟩, h⟩ := hG C,
  exact hC i x (congr_fun h i),
end

namespace choice

def lt (α β : Type u) : Type u :=
pprod (α ↪ β) ((β ↪ α) → false)

noncomputable def lt.of_cardinal_lt : #α < #β → lt α β :=
λ ⟨f, h⟩, ⟨classical.choice f, λ f, h ⟨f⟩⟩

def lt.to_cardinal_lt : lt α β → #α < #β :=
λ ⟨f, h⟩, ⟨⟨f⟩, λ f, nonempty.rec h f⟩

axiom sum_lt_prod {α : Type u} (β₁ : α → Type v) (β₂ : α → Type v) :
  (Π a, lt (β₁ a) (β₂ a)) → lt (Σ a, β₁ a) (Π a, β₂ a)

noncomputable example {α : Type u} (β₁ : α → Type v) (β₂ : α → Type v) :
  (Π a, lt (β₁ a) (β₂ a)) → lt (Σ a, β₁ a) (Π a, β₂ a) :=
begin
  intro h,
  replace h := λ a, lt.to_cardinal_lt (h a),
  replace h := cardinal.sum_lt_prod (λ a, #(β₁ a)) (λ a, #(β₂ a)) h,
  replace h := lt.of_cardinal_lt h,
  dsimp only at h,
  rcases h with ⟨⟨f, hf⟩, h⟩,
  refine ⟨⟨_, _⟩, _⟩,
  { rintros ⟨a₁, b₁⟩ a₂,
    have e := classical.choice (quotient.mk_out (β₁ a₁)),
    exact classical.choice (quotient.mk_out (β₂ a₂)) (f ⟨a₁, e.symm b₁⟩ a₂) },
  { clear h,
    rintros ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h,
    replace h : f ⟨a₁, (classical.choice (quotient.mk_out (β₁ a₁))).symm b₁⟩ = f ⟨a₂, (classical.choice (quotient.mk_out (β₁ a₂))).symm b₂⟩,
    { exact funext (λ a, (classical.choice (quotient.mk_out (β₂ a))).injective (congr_fun h a)) },
    specialize hf h, clear h,
    simp only at hf,
    rcases hf with ⟨rfl, h⟩,
    rw (classical.choice (quotient.mk_out (β₁ a₁))).symm.injective (eq_of_heq h) },
  { clear hf f,
    refine λ h', h _, clear h,
    cases h' with f hf,
    refine ⟨_, _⟩,
    { intro g,
      cases f (λ a, classical.choice (quotient.mk_out (β₂ a)) (g a)) with a b,
      exact ⟨a, (classical.choice (quotient.mk_out (β₁ a))).symm b⟩ },
    { intros g₁ g₂ h,
      dsimp only at h,
      let F : (Σ a, β₁ a) → Σ a, (#(β₁ a)).out := @sigma.rec α β₁ (λ x, Σ a, (#(β₁ a)).out) (λ a b, ⟨a, (classical.choice (quotient.mk_out (β₁ a))).symm b⟩),
      suffices h' : function.injective F,
      { exact funext (λ a, (classical.choice (quotient.mk_out (β₂ a))).injective (congr_fun (hf (h' h)) a)) },
      rintros ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h,
      simp only [F] at h,
      rcases h with ⟨rfl, h⟩,
      rw (classical.choice (quotient.mk_out (β₁ a₁))).symm.injective (eq_of_heq h) } }
end

axiom not_not {p : Prop} : ¬¬p → p

theorem choice {α : Type u} {β : α → Type v} :
  (∀ a, nonempty (β a)) → nonempty (Π a, β a) :=
begin
  intro h,
  suffices : Π a, lt pempty (β a),
  { cases sum_lt_prod (λ a, pempty) β this with f h,
    exact not_not (λ h', h ⟨λ f, false.elim (h' ⟨f⟩), λ f, false.elim (h' ⟨f⟩)⟩) },
  intro a,
  specialize h a,
  refine ⟨⟨pempty.elim, λ x, pempty.elim x⟩, _⟩,
  rintro ⟨f, hf⟩,
  cases h with b,
  exact pempty.elim (f b)
end

theorem choice' {α : Sort u} {β : α → Sort v} :
  (∀ a, nonempty (β a)) → nonempty (Π a, β a) :=
begin
  intro h,
  suffices : ∀ a, nonempty (plift (β (plift.down a))),
  { cases choice this with h,
    exact ⟨λ a, (h ⟨a⟩).down⟩ },
  rintro ⟨a⟩,
  cases h a with h,
  exact ⟨⟨h⟩⟩
end

end choice

end cardinal