/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Floris van Doorn
-/

import data.finsupp.multiset
import order.bounded
import set_theory.ordinal.principal
import tactic.linarith

/-!
# Cardinals and ordinals

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

Relationships between cardinals and ordinals, properties of cardinals that are proved
using ordinals.

## Main definitions

* The function `cardinal.aleph'` gives the cardinals listed by their ordinal
  index, and is the inverse of `cardinal.aleph_idx`.
  `aleph' n = n`, `aleph' ω = ℵ₀`, `aleph' (ω + 1) = succ ℵ₀`, etc.
  It is an order isomorphism between ordinals and cardinals.
* The function `cardinal.aleph` gives the infinite cardinals listed by their
  ordinal index. `aleph 0 = ℵ₀`, `aleph 1 = succ ℵ₀` is the first
  uncountable cardinal, and so on.
* The function `cardinal.beth` enumerates the Beth cardinals. `beth 0 = ℵ₀`,
  `beth (succ o) = 2 ^ beth o`, and for a limit ordinal `o`, `beth o` is the supremum of `beth a`
  for `a < o`.

## Main Statements

* `cardinal.mul_eq_max` and `cardinal.add_eq_max` state that the product (resp. sum) of two infinite
  cardinals is just their maximum. Several variations around this fact are also given.
* `cardinal.mk_list_eq_mk` : when `α` is infinite, `α` and `list α` have the same cardinality.
* simp lemmas for inequalities between `bit0 a` and `bit1 b` are registered, making `simp`
  able to prove inequalities about numeral cardinals.

## Tags

cardinal arithmetic (for infinite cardinals)
-/

noncomputable theory

open function cardinal set equiv order
open_locale classical cardinal ordinal

universes u v w

namespace cardinal
section using_ordinals
open ordinal

theorem ord_is_limit {c} (co : ℵ₀ ≤ c) : (ord c).is_limit :=
begin
  refine ⟨λ h, aleph_0_ne_zero _, λ a, lt_imp_lt_of_le_imp_le (λ h, _)⟩,
  { rw [←ordinal.le_zero, ord_le] at h,
    simpa only [card_zero, nonpos_iff_eq_zero] using co.trans h },
  { rw ord_le at h ⊢,
    rwa [←@add_one_of_aleph_0_le (card a), ←card_succ],
    rw [←ord_le, ←le_succ_of_is_limit, ord_le],
    { exact co.trans h },
    { rw ord_aleph_0, exact omega_is_limit } }
end

/-! ### Aleph cardinals -/

/-- The `aleph'` index function, which gives the ordinal index of a cardinal.
  (The `aleph'` part is because unlike `aleph` this counts also the
  finite stages. So `aleph_idx n = n`, `aleph_idx ω = ω`,
  `aleph_idx ℵ₁ = ω + 1` and so on.)
  In this definition, we register additionally that this function is an initial segment,
  i.e., it is order preserving and its range is an initial segment of the ordinals.
  For the basic function version, see `aleph_idx`.
  For an upgraded version stating that the range is everything, see `aleph_idx.rel_iso`. -/
def aleph_idx.initial_seg : @initial_seg cardinal ordinal (<) (<) :=
@rel_embedding.collapse cardinal ordinal (<) (<) _ cardinal.ord.order_embedding.lt_embedding

/-- The `aleph'` index function, which gives the ordinal index of a cardinal.
  (The `aleph'` part is because unlike `aleph` this counts also the
  finite stages. So `aleph_idx n = n`, `aleph_idx ω = ω`,
  `aleph_idx ℵ₁ = ω + 1` and so on.)
  For an upgraded version stating that the range is everything, see `aleph_idx.rel_iso`. -/
def aleph_idx : cardinal → ordinal := aleph_idx.initial_seg

@[simp] theorem aleph_idx.initial_seg_coe :
  (aleph_idx.initial_seg : cardinal → ordinal) = aleph_idx := rfl

@[simp] theorem aleph_idx_lt {a b} : aleph_idx a < aleph_idx b ↔ a < b :=
aleph_idx.initial_seg.to_rel_embedding.map_rel_iff

@[simp] theorem aleph_idx_le {a b} : aleph_idx a ≤ aleph_idx b ↔ a ≤ b :=
by rw [← not_lt, ← not_lt, aleph_idx_lt]

theorem aleph_idx.init {a b} : b < aleph_idx a → ∃ c, aleph_idx c = b :=
aleph_idx.initial_seg.init

/-- The `aleph'` index function, which gives the ordinal index of a cardinal.
  (The `aleph'` part is because unlike `aleph` this counts also the
  finite stages. So `aleph_idx n = n`, `aleph_idx ℵ₀ = ω`,
  `aleph_idx ℵ₁ = ω + 1` and so on.)
  In this version, we register additionally that this function is an order isomorphism
  between cardinals and ordinals.
  For the basic function version, see `aleph_idx`. -/
def aleph_idx.rel_iso : @rel_iso cardinal.{u} ordinal.{u} (<) (<) :=
@rel_iso.of_surjective cardinal.{u} ordinal.{u} (<) (<) aleph_idx.initial_seg.{u} $
(initial_seg.eq_or_principal aleph_idx.initial_seg.{u}).resolve_right $
λ ⟨o, e⟩, begin
  have : ∀ c, aleph_idx c < o := λ c, (e _).2 ⟨_, rfl⟩,
  refine ordinal.induction_on o _ this, introsI α r _ h,
  let s := ⨆ a, inv_fun aleph_idx (ordinal.typein r a),
  apply (lt_succ s).not_le,
  have I : injective aleph_idx := aleph_idx.initial_seg.to_embedding.injective,
  simpa only [typein_enum, left_inverse_inv_fun I (succ s)] using le_csupr
    (cardinal.bdd_above_range.{u u} (λ a : α, inv_fun aleph_idx (ordinal.typein r a)))
    (ordinal.enum r _ (h (succ s)))
end

@[simp] theorem aleph_idx.rel_iso_coe :
  (aleph_idx.rel_iso : cardinal → ordinal) = aleph_idx := rfl

@[simp] theorem type_cardinal : @type cardinal (<) _ = ordinal.univ.{u (u+1)} :=
by rw ordinal.univ_id; exact quotient.sound ⟨aleph_idx.rel_iso⟩

@[simp] theorem mk_cardinal : #cardinal = univ.{u (u+1)} :=
by simpa only [card_type, card_univ] using congr_arg card type_cardinal

/-- The `aleph'` function gives the cardinals listed by their ordinal
  index, and is the inverse of `aleph_idx`.
  `aleph' n = n`, `aleph' ω = ω`, `aleph' (ω + 1) = succ ℵ₀`, etc.
  In this version, we register additionally that this function is an order isomorphism
  between ordinals and cardinals.
  For the basic function version, see `aleph'`. -/
def aleph'.rel_iso := cardinal.aleph_idx.rel_iso.symm

/-- The `aleph'` function gives the cardinals listed by their ordinal
  index, and is the inverse of `aleph_idx`.
  `aleph' n = n`, `aleph' ω = ω`, `aleph' (ω + 1) = succ ℵ₀`, etc. -/
def aleph' : ordinal → cardinal := aleph'.rel_iso

@[simp] theorem aleph'.rel_iso_coe :
  (aleph'.rel_iso : ordinal → cardinal) = aleph' := rfl

@[simp] theorem aleph'_lt {o₁ o₂ : ordinal} : aleph' o₁ < aleph' o₂ ↔ o₁ < o₂ :=
aleph'.rel_iso.map_rel_iff

@[simp] theorem aleph'_le {o₁ o₂ : ordinal} : aleph' o₁ ≤ aleph' o₂ ↔ o₁ ≤ o₂ :=
le_iff_le_iff_lt_iff_lt.2 aleph'_lt

@[simp] theorem aleph'_aleph_idx (c : cardinal) : aleph' c.aleph_idx = c :=
cardinal.aleph_idx.rel_iso.to_equiv.symm_apply_apply c

@[simp] theorem aleph_idx_aleph' (o : ordinal) : (aleph' o).aleph_idx = o :=
cardinal.aleph_idx.rel_iso.to_equiv.apply_symm_apply o

@[simp] theorem aleph'_zero : aleph' 0 = 0 :=
by { rw [← nonpos_iff_eq_zero, ← aleph'_aleph_idx 0, aleph'_le], apply ordinal.zero_le }

@[simp] theorem aleph'_succ {o : ordinal} : aleph' (succ o) = succ (aleph' o) :=
begin
  apply (succ_le_of_lt $ aleph'_lt.2 $ lt_succ o).antisymm' (cardinal.aleph_idx_le.1 $ _),
  rw [aleph_idx_aleph', succ_le_iff, ← aleph'_lt, aleph'_aleph_idx],
  apply lt_succ
end

@[simp] theorem aleph'_nat : ∀ n : ℕ, aleph' n = n
| 0     := aleph'_zero
| (n+1) := show aleph' (succ n) = n.succ,
           by rw [aleph'_succ, aleph'_nat, nat_succ]

theorem aleph'_le_of_limit {o : ordinal} (l : o.is_limit) {c} :
  aleph' o ≤ c ↔ ∀ o' < o, aleph' o' ≤ c :=
⟨λ h o' h', (aleph'_le.2 $ h'.le).trans h,
 λ h, begin
  rw [←aleph'_aleph_idx c, aleph'_le, limit_le l],
  intros x h',
  rw [←aleph'_le, aleph'_aleph_idx],
  exact h _ h'
end⟩

theorem aleph'_limit {o : ordinal} (ho : is_limit o) : aleph' o = ⨆ a : Iio o, aleph' a :=
begin
  refine le_antisymm _ (csupr_le' (λ i, aleph'_le.2 (le_of_lt i.2))),
  rw aleph'_le_of_limit ho,
  exact λ a ha, le_csupr (bdd_above_of_small _) (⟨a, ha⟩ : Iio o)
end

@[simp] theorem aleph'_omega : aleph' ω = ℵ₀ :=
eq_of_forall_ge_iff $ λ c, begin
  simp only [aleph'_le_of_limit omega_is_limit, lt_omega, exists_imp_distrib, aleph_0_le],
  exact forall_swap.trans (forall_congr $ λ n, by simp only [forall_eq, aleph'_nat]),
end

/-- `aleph'` and `aleph_idx` form an equivalence between `ordinal` and `cardinal` -/
@[simp] def aleph'_equiv : ordinal ≃ cardinal :=
⟨aleph', aleph_idx, aleph_idx_aleph', aleph'_aleph_idx⟩

/-- The `aleph` function gives the infinite cardinals listed by their
  ordinal index. `aleph 0 = ℵ₀`, `aleph 1 = succ ℵ₀` is the first
  uncountable cardinal, and so on. -/
def aleph (o : ordinal) : cardinal := aleph' (ω + o)

@[simp] theorem aleph_lt {o₁ o₂ : ordinal} : aleph o₁ < aleph o₂ ↔ o₁ < o₂ :=
aleph'_lt.trans (add_lt_add_iff_left _)

@[simp] theorem aleph_le {o₁ o₂ : ordinal} : aleph o₁ ≤ aleph o₂ ↔ o₁ ≤ o₂ :=
le_iff_le_iff_lt_iff_lt.2 aleph_lt

@[simp] theorem max_aleph_eq (o₁ o₂ : ordinal) : max (aleph o₁) (aleph o₂) = aleph (max o₁ o₂) :=
begin
  cases le_total (aleph o₁) (aleph o₂) with h h,
  { rw [max_eq_right h, max_eq_right (aleph_le.1 h)] },
  { rw [max_eq_left h, max_eq_left (aleph_le.1 h)] }
end

@[simp] theorem aleph_succ {o : ordinal} : aleph (succ o) = succ (aleph o) :=
by rw [aleph, add_succ, aleph'_succ, aleph]

@[simp] theorem aleph_zero : aleph 0 = ℵ₀ :=
by rw [aleph, add_zero, aleph'_omega]

theorem aleph_limit {o : ordinal} (ho : is_limit o) : aleph o = ⨆ a : Iio o, aleph a :=
begin
  apply le_antisymm _ (csupr_le' _),
  { rw [aleph, aleph'_limit (ho.add _)],
    refine csupr_mono' (bdd_above_of_small _) _,
    rintro ⟨i, hi⟩,
    cases lt_or_le i ω,
    { rcases lt_omega.1 h with ⟨n, rfl⟩,
      use ⟨0, ho.pos⟩,
      simpa using (nat_lt_aleph_0 n).le },
    { exact ⟨⟨_, (sub_lt_of_le h).2 hi⟩, aleph'_le.2 (le_add_sub _ _)⟩ } },
  { exact λ i, aleph_le.2 (le_of_lt i.2) }
end

theorem aleph_0_le_aleph' {o : ordinal} : ℵ₀ ≤ aleph' o ↔ ω ≤ o :=
by rw [← aleph'_omega, aleph'_le]

theorem aleph_0_le_aleph (o : ordinal) : ℵ₀ ≤ aleph o :=
by { rw [aleph, aleph_0_le_aleph'], apply ordinal.le_add_right }

theorem aleph'_pos {o : ordinal} (ho : 0 < o) : 0 < aleph' o :=
by rwa [←aleph'_zero, aleph'_lt]

theorem aleph_pos (o : ordinal) : 0 < aleph o :=
aleph_0_pos.trans_le (aleph_0_le_aleph o)

@[simp] theorem aleph_to_nat (o : ordinal) : (aleph o).to_nat = 0 :=
to_nat_apply_of_aleph_0_le $ aleph_0_le_aleph o

@[simp] theorem aleph_to_part_enat (o : ordinal) : (aleph o).to_part_enat = ⊤ :=
to_part_enat_apply_of_aleph_0_le $ aleph_0_le_aleph o

instance nonempty_out_aleph (o : ordinal) : nonempty (aleph o).ord.out.α :=
begin
  rw [out_nonempty_iff_ne_zero, ←ord_zero],
  exact λ h, (ord_injective h).not_gt (aleph_pos o)
end

theorem ord_aleph_is_limit (o : ordinal) : is_limit (aleph o).ord :=
ord_is_limit $ aleph_0_le_aleph _

instance (o : ordinal) : no_max_order (aleph o).ord.out.α :=
out_no_max_of_succ_lt (ord_aleph_is_limit o).2

theorem exists_aleph {c : cardinal} : ℵ₀ ≤ c ↔ ∃ o, c = aleph o :=
⟨λ h, ⟨aleph_idx c - ω,
  by { rw [aleph, ordinal.add_sub_cancel_of_le, aleph'_aleph_idx],
       rwa [← aleph_0_le_aleph', aleph'_aleph_idx] }⟩,
 λ ⟨o, e⟩, e.symm ▸ aleph_0_le_aleph _⟩

theorem aleph'_is_normal : is_normal (ord ∘ aleph') :=
⟨λ o, ord_lt_ord.2 $ aleph'_lt.2 $ lt_succ o,
 λ o l a, by simp only [ord_le, aleph'_le_of_limit l]⟩

theorem aleph_is_normal : is_normal (ord ∘ aleph) :=
aleph'_is_normal.trans $ add_is_normal ω

theorem succ_aleph_0 : succ ℵ₀ = aleph 1 :=
by rw [←aleph_zero, ←aleph_succ, ordinal.succ_zero]

lemma aleph_0_lt_aleph_one : ℵ₀ < aleph 1 :=
by { rw ←succ_aleph_0, apply lt_succ }

lemma countable_iff_lt_aleph_one {α : Type*} (s : set α) : s.countable ↔ #s < aleph 1 :=
by rw [←succ_aleph_0, lt_succ_iff, le_aleph_0_iff_set_countable]

/-- Ordinals that are cardinals are unbounded. -/
theorem ord_card_unbounded : unbounded (<) {b : ordinal | b.card.ord = b} :=
unbounded_lt_iff.2 $ λ a, ⟨_, ⟨(by { dsimp, rw card_ord }), (lt_ord_succ_card a).le⟩⟩

theorem eq_aleph'_of_eq_card_ord {o : ordinal} (ho : o.card.ord = o) : ∃ a, (aleph' a).ord = o :=
⟨cardinal.aleph_idx.rel_iso o.card, by simpa using ho⟩

/-- `ord ∘ aleph'` enumerates the ordinals that are cardinals. -/
theorem ord_aleph'_eq_enum_card : ord ∘ aleph' = enum_ord {b : ordinal | b.card.ord = b} :=
begin
  rw [←eq_enum_ord _ ord_card_unbounded, range_eq_iff],
  exact ⟨aleph'_is_normal.strict_mono, ⟨(λ a, (by { dsimp, rw card_ord })),
    λ b hb, eq_aleph'_of_eq_card_ord hb⟩⟩
end

/-- Infinite ordinals that are cardinals are unbounded. -/
theorem ord_card_unbounded' : unbounded (<) {b : ordinal | b.card.ord = b ∧ ω ≤ b} :=
(unbounded_lt_inter_le ω).2 ord_card_unbounded

theorem eq_aleph_of_eq_card_ord {o : ordinal} (ho : o.card.ord = o) (ho' : ω ≤ o) :
  ∃ a, (aleph a).ord = o :=
begin
  cases eq_aleph'_of_eq_card_ord ho with a ha,
  use a - ω,
  unfold aleph,
  rwa ordinal.add_sub_cancel_of_le,
  rwa [←aleph_0_le_aleph', ←ord_le_ord, ha, ord_aleph_0]
end

/-- `ord ∘ aleph` enumerates the infinite ordinals that are cardinals. -/
theorem ord_aleph_eq_enum_card :
  ord ∘ aleph = enum_ord {b : ordinal | b.card.ord = b ∧ ω ≤ b} :=
begin
  rw ←eq_enum_ord _ ord_card_unbounded',
  use aleph_is_normal.strict_mono,
  rw range_eq_iff,
  refine ⟨(λ a, ⟨_, _⟩), λ b hb, eq_aleph_of_eq_card_ord hb.1 hb.2⟩,
  { rw card_ord },
  { rw [←ord_aleph_0, ord_le_ord],
    exact aleph_0_le_aleph _ }
end

/-! ### Beth cardinals -/

/-- Beth numbers are defined so that `beth 0 = ℵ₀`, `beth (succ o) = 2 ^ (beth o)`, and when `o` is
a limit ordinal, `beth o` is the supremum of `beth o'` for `o' < o`.

Assuming the generalized continuum hypothesis, which is undecidable in ZFC, `beth o = aleph o` for
every `o`. -/
def beth (o : ordinal.{u}) : cardinal.{u} :=
limit_rec_on o aleph_0 (λ _ x, 2 ^ x) (λ a ha IH, ⨆ b : Iio a, IH b.1 b.2)

@[simp] theorem beth_zero : beth 0 = aleph_0 :=
limit_rec_on_zero _ _ _

@[simp] theorem beth_succ (o : ordinal) : beth (succ o) = 2 ^ beth o :=
limit_rec_on_succ _ _ _ _

theorem beth_limit {o : ordinal} : is_limit o → beth o = ⨆ a : Iio o, beth a :=
limit_rec_on_limit _ _ _ _

theorem beth_strict_mono : strict_mono beth :=
begin
  intros a b,
  induction b using ordinal.induction with b IH generalizing a,
  intro h,
  rcases zero_or_succ_or_limit b with rfl | ⟨c, rfl⟩ | hb,
  { exact (ordinal.not_lt_zero a h).elim },
  { rw lt_succ_iff at h,
    rw beth_succ,
    apply lt_of_le_of_lt _ (cantor _),
    rcases eq_or_lt_of_le h with rfl | h, { refl },
    exact (IH c (lt_succ c) h).le },
  { apply (cantor _).trans_le,
    rw [beth_limit hb, ←beth_succ],
    exact le_csupr (bdd_above_of_small _) (⟨_, hb.succ_lt h⟩ : Iio b) }
end

@[simp] theorem beth_lt {o₁ o₂ : ordinal} : beth o₁ < beth o₂ ↔ o₁ < o₂ :=
beth_strict_mono.lt_iff_lt

@[simp] theorem beth_le {o₁ o₂ : ordinal} : beth o₁ ≤ beth o₂ ↔ o₁ ≤ o₂ :=
beth_strict_mono.le_iff_le

theorem aleph_le_beth (o : ordinal) : aleph o ≤ beth o :=
begin
  apply limit_rec_on o,
  { simp },
  { intros o h,
    rw [aleph_succ, beth_succ, succ_le_iff],
    exact (cantor _).trans_le (power_le_power_left two_ne_zero h) },
  { intros o ho IH,
    rw [aleph_limit ho, beth_limit ho],
    exact csupr_mono (bdd_above_of_small _) (λ x, IH x.1 x.2) }
end

theorem aleph_0_le_beth (o : ordinal) : ℵ₀ ≤ beth o :=
(aleph_0_le_aleph o).trans $ aleph_le_beth o

theorem beth_pos (o : ordinal) : 0 < beth o :=
aleph_0_pos.trans_le $ aleph_0_le_beth o

theorem beth_ne_zero (o : ordinal) : beth o ≠ 0 :=
(beth_pos o).ne'

lemma beth_normal : is_normal.{u} (λ o, (beth o).ord) :=
(is_normal_iff_strict_mono_limit _).2 ⟨ord_strict_mono.comp beth_strict_mono, λ o ho a ha,
  by { rw [beth_limit ho, ord_le], exact csupr_le' (λ b, ord_le.1 (ha _ b.2)) }⟩

/-! ### Properties of `mul` -/

/-- If `α` is an infinite type, then `α × α` and `α` have the same cardinality. -/
theorem mul_eq_self {c : cardinal} (h : ℵ₀ ≤ c) : c * c = c :=
begin
  refine le_antisymm _
    (by simpa only [mul_one] using
      mul_le_mul_left' (one_le_aleph_0.trans h) c),
  -- the only nontrivial part is `c * c ≤ c`. We prove it inductively.
  refine acc.rec_on (cardinal.lt_wf.apply c) (λ c _,
    quotient.induction_on c $ λ α IH ol, _) h,
  -- consider the minimal well-order `r` on `α` (a type with cardinality `c`).
  rcases ord_eq α with ⟨r, wo, e⟩, resetI,
  letI := linear_order_of_STO r,
  haveI : is_well_order α (<) := wo,
  -- Define an order `s` on `α × α` by writing `(a, b) < (c, d)` if `max a b < max c d`, or
  -- the max are equal and `a < c`, or the max are equal and `a = c` and `b < d`.
  let g : α × α → α := λ p, max p.1 p.2,
  let f : α × α ↪ ordinal × (α × α) :=
    ⟨λ p:α×α, (typein (<) (g p), p), λ p q, congr_arg prod.snd⟩,
  let s := f ⁻¹'o (prod.lex (<) (prod.lex (<) (<))),
  -- this is a well order on `α × α`.
  haveI : is_well_order _ s := (rel_embedding.preimage _ _).is_well_order,
  /- it suffices to show that this well order is smaller than `r`
     if it were larger, then `r` would be a strict prefix of `s`. It would be contained in
    `β × β` for some `β` of cardinality `< c`. By the inductive assumption, this set has the
    same cardinality as `β` (or it is finite if `β` is finite), so it is `< c`, which is a
    contradiction. -/
  suffices : type s ≤ type r, {exact card_le_card this},
  refine le_of_forall_lt (λ o h, _),
  rcases typein_surj s h with ⟨p, rfl⟩,
  rw [← e, lt_ord],
  refine lt_of_le_of_lt
    (_ : _ ≤ card (succ (typein (<) (g p))) * card (succ (typein (<) (g p)))) _,
  { have : {q | s q p} ⊆ insert (g p) {x | x < g p} ×ˢ insert (g p) {x | x < g p},
    { intros q h,
      simp only [s, embedding.coe_fn_mk, order.preimage, typein_lt_typein, prod.lex_def, typein_inj]
        at h,
      exact max_le_iff.1 (le_iff_lt_or_eq.2 $ h.imp_right and.left) },
    suffices H : (insert (g p) {x | r x (g p)} : set α) ≃ ({x | r x (g p)} ⊕ punit),
    { exact ⟨(set.embedding_of_subset _ _ this).trans
        ((equiv.set.prod _ _).trans (H.prod_congr H)).to_embedding⟩ },
    refine (equiv.set.insert _).trans
      ((equiv.refl _).sum_congr punit_equiv_punit),
    apply @irrefl _ r },
  cases lt_or_le (card (succ (typein (<) (g p)))) ℵ₀ with qo qo,
  { exact (mul_lt_aleph_0 qo qo).trans_le ol },
  { suffices, {exact (IH _ this qo).trans_lt this},
    rw ← lt_ord, apply (ord_is_limit ol).2,
    rw [mk_def, e], apply typein_lt_type }
end

end using_ordinals

/-- If `α` and `β` are infinite types, then the cardinality of `α × β` is the maximum
of the cardinalities of `α` and `β`. -/
theorem mul_eq_max {a b : cardinal} (ha : ℵ₀ ≤ a) (hb : ℵ₀ ≤ b) : a * b = max a b :=
le_antisymm
  (mul_eq_self (ha.trans (le_max_left a b)) ▸
    mul_le_mul' (le_max_left _ _) (le_max_right _ _)) $
max_le
  (by simpa only [mul_one] using
    mul_le_mul_left' (one_le_aleph_0.trans hb) a)
  (by simpa only [one_mul] using
    mul_le_mul_right' (one_le_aleph_0.trans ha) b)

@[simp] theorem mul_mk_eq_max {α β : Type*} [infinite α] [infinite β] : #α * #β = max (#α) (#β) :=
mul_eq_max (aleph_0_le_mk α) (aleph_0_le_mk β)

@[simp] theorem aleph_mul_aleph (o₁ o₂ : ordinal) : aleph o₁ * aleph o₂ = aleph (max o₁ o₂) :=
by rw [cardinal.mul_eq_max (aleph_0_le_aleph o₁) (aleph_0_le_aleph o₂), max_aleph_eq]

@[simp] theorem aleph_0_mul_eq {a : cardinal} (ha : ℵ₀ ≤ a) : ℵ₀ * a = a :=
(mul_eq_max le_rfl ha).trans (max_eq_right ha)

@[simp] theorem mul_aleph_0_eq {a : cardinal} (ha : ℵ₀ ≤ a) : a * ℵ₀ = a :=
(mul_eq_max ha le_rfl).trans (max_eq_left ha)

@[simp] theorem aleph_0_mul_mk_eq {α : Type*} [infinite α] : ℵ₀ * #α = #α :=
aleph_0_mul_eq (aleph_0_le_mk α)

@[simp] theorem mk_mul_aleph_0_eq {α : Type*} [infinite α] : #α * ℵ₀ = #α :=
mul_aleph_0_eq (aleph_0_le_mk α)

@[simp] theorem aleph_0_mul_aleph (o : ordinal) : ℵ₀ * aleph o = aleph o :=
aleph_0_mul_eq (aleph_0_le_aleph o)

@[simp] theorem aleph_mul_aleph_0 (o : ordinal) : aleph o * ℵ₀ = aleph o :=
mul_aleph_0_eq (aleph_0_le_aleph o)

theorem mul_lt_of_lt {a b c : cardinal} (hc : ℵ₀ ≤ c) (h1 : a < c) (h2 : b < c) : a * b < c :=
(mul_le_mul' (le_max_left a b) (le_max_right a b)).trans_lt $
(lt_or_le (max a b) ℵ₀).elim
  (λ h, (mul_lt_aleph_0 h h).trans_le hc)
  (λ h, by { rw mul_eq_self h, exact max_lt h1 h2 })

lemma mul_le_max_of_aleph_0_le_left {a b : cardinal} (h : ℵ₀ ≤ a) : a * b ≤ max a b :=
begin
  convert mul_le_mul' (le_max_left a b) (le_max_right a b),
  rw mul_eq_self,
  refine h.trans (le_max_left a b)
end

lemma mul_eq_max_of_aleph_0_le_left {a b : cardinal} (h : ℵ₀ ≤ a) (h' : b ≠ 0) : a * b = max a b :=
begin
  cases le_or_lt ℵ₀ b with hb hb, { exact mul_eq_max h hb },
  refine (mul_le_max_of_aleph_0_le_left h).antisymm _,
  have : b ≤ a, from hb.le.trans h,
  rw [max_eq_left this],
  convert mul_le_mul_left' (one_le_iff_ne_zero.mpr h') _, rw [mul_one],
end

lemma mul_le_max_of_aleph_0_le_right {a b : cardinal} (h : ℵ₀ ≤ b) : a * b ≤ max a b :=
by simpa only [mul_comm, max_comm] using mul_le_max_of_aleph_0_le_left h

lemma mul_eq_max_of_aleph_0_le_right {a b : cardinal} (h' : a ≠ 0) (h : ℵ₀ ≤ b) : a * b = max a b :=
begin
  rw [mul_comm, max_comm],
  exact mul_eq_max_of_aleph_0_le_left h h'
end

lemma mul_eq_max' {a b : cardinal} (h : ℵ₀ ≤ a * b) : a * b = max a b :=
begin
  rcases aleph_0_le_mul_iff.mp h with ⟨ha, hb, ha' | hb'⟩,
  { exact mul_eq_max_of_aleph_0_le_left ha' hb },
  { exact mul_eq_max_of_aleph_0_le_right ha hb' }
end

theorem mul_le_max (a b : cardinal) : a * b ≤ max (max a b) ℵ₀ :=
begin
  rcases eq_or_ne a 0 with rfl | ha0, { simp },
  rcases eq_or_ne b 0 with rfl | hb0, { simp },
  cases le_or_lt ℵ₀ a with ha ha,
  { rw [mul_eq_max_of_aleph_0_le_left ha hb0],
    exact le_max_left _ _ },
  { cases le_or_lt ℵ₀ b with hb hb,
    { rw [mul_comm, mul_eq_max_of_aleph_0_le_left hb ha0, max_comm],
      exact le_max_left _ _ },
    { exact le_max_of_le_right (mul_lt_aleph_0 ha hb).le } }
end

lemma mul_eq_left {a b : cardinal} (ha : ℵ₀ ≤ a) (hb : b ≤ a) (hb' : b ≠ 0) : a * b = a :=
by { rw [mul_eq_max_of_aleph_0_le_left ha hb', max_eq_left hb] }

lemma mul_eq_right {a b : cardinal} (hb : ℵ₀ ≤ b) (ha : a ≤ b) (ha' : a ≠ 0) : a * b = b :=
by { rw [mul_comm, mul_eq_left hb ha ha'] }

lemma le_mul_left {a b : cardinal} (h : b ≠ 0) : a ≤ b * a :=
by { convert mul_le_mul_right' (one_le_iff_ne_zero.mpr h) _,
  rw [one_mul] }

lemma le_mul_right {a b : cardinal} (h : b ≠ 0) : a ≤ a * b :=
by { rw [mul_comm], exact le_mul_left h }

lemma mul_eq_left_iff {a b : cardinal} : a * b = a ↔ ((max ℵ₀ b ≤ a ∧ b ≠ 0) ∨ b = 1 ∨ a = 0) :=
begin
  rw max_le_iff,
  refine ⟨λ h, _, _⟩,
  { cases le_or_lt ℵ₀ a with ha ha,
    { have : a ≠ 0, { rintro rfl, exact ha.not_lt aleph_0_pos },
      left, use ha,
      { rw ←not_lt, exact λ hb, ne_of_gt (hb.trans_le (le_mul_left this)) h },
      { rintro rfl, apply this, rw mul_zero at h, exact h.symm }},
    right, by_cases h2a : a = 0, { exact or.inr h2a },
    have hb : b ≠ 0, { rintro rfl, apply h2a, rw mul_zero at h, exact h.symm },
    left, rw [←h, mul_lt_aleph_0_iff, lt_aleph_0, lt_aleph_0] at ha,
    rcases ha with rfl|rfl|⟨⟨n, rfl⟩, ⟨m, rfl⟩⟩, contradiction, contradiction,
    rw ←ne at h2a, rw ←one_le_iff_ne_zero at h2a hb, norm_cast at h2a hb h ⊢,
    apply le_antisymm _ hb, rw ←not_lt,
    apply λ h2b, ne_of_gt _ h, conv_lhs { rw ←mul_one n },
    rwa mul_lt_mul_left, apply nat.lt_of_succ_le h2a },
  { rintro (⟨⟨ha, hab⟩, hb⟩|rfl|rfl),
    { rw [mul_eq_max_of_aleph_0_le_left ha hb, max_eq_left hab] },
    all_goals { simp }}
end

/-! ### Properties of `add` -/

/-- If `α` is an infinite type, then `α ⊕ α` and `α` have the same cardinality. -/
theorem add_eq_self {c : cardinal} (h : ℵ₀ ≤ c) : c + c = c :=
le_antisymm
  (by simpa only [nat.cast_bit0, nat.cast_one, mul_eq_self h, two_mul] using
     mul_le_mul_right' ((nat_lt_aleph_0 2).le.trans h) c)
  (self_le_add_left c c)

/-- If `α` is an infinite type, then the cardinality of `α ⊕ β` is the maximum
of the cardinalities of `α` and `β`. -/
theorem add_eq_max {a b : cardinal} (ha : ℵ₀ ≤ a) : a + b = max a b :=
le_antisymm
  (add_eq_self (ha.trans (le_max_left a b)) ▸
    add_le_add (le_max_left _ _) (le_max_right _ _)) $
max_le (self_le_add_right _ _) (self_le_add_left _ _)

theorem add_eq_max' {a b : cardinal} (ha : ℵ₀ ≤ b) : a + b = max a b :=
by rw [add_comm, max_comm, add_eq_max ha]

@[simp] theorem add_mk_eq_max {α β : Type*} [infinite α] : #α + #β = max (#α) (#β) :=
add_eq_max (aleph_0_le_mk α)

@[simp] theorem add_mk_eq_max' {α β : Type*} [infinite β] : #α + #β = max (#α) (#β) :=
add_eq_max' (aleph_0_le_mk β)

theorem add_le_max (a b : cardinal) : a + b ≤ max (max a b) ℵ₀ :=
begin
  cases le_or_lt ℵ₀ a with ha ha,
  { rw [add_eq_max ha],
    exact le_max_left _ _ },
  { cases le_or_lt ℵ₀ b with hb hb,
    { rw [add_comm, add_eq_max hb, max_comm],
      exact le_max_left _ _ },
    { exact le_max_of_le_right (add_lt_aleph_0 ha hb).le } }
end

theorem add_le_of_le {a b c : cardinal} (hc : ℵ₀ ≤ c) (h1 : a ≤ c) (h2 : b ≤ c) : a + b ≤ c :=
(add_le_add h1 h2).trans $ le_of_eq $ add_eq_self hc

theorem add_lt_of_lt {a b c : cardinal} (hc : ℵ₀ ≤ c) (h1 : a < c) (h2 : b < c) : a + b < c :=
(add_le_add (le_max_left a b) (le_max_right a b)).trans_lt $
(lt_or_le (max a b) ℵ₀).elim
  (λ h, (add_lt_aleph_0 h h).trans_le hc)
  (λ h, by rw add_eq_self h; exact max_lt h1 h2)

lemma eq_of_add_eq_of_aleph_0_le {a b c : cardinal} (h : a + b = c) (ha : a < c) (hc : ℵ₀ ≤ c) :
  b = c :=
begin
  apply le_antisymm,
  { rw [← h], apply self_le_add_left },
  rw[← not_lt], intro hb,
  have : a + b < c := add_lt_of_lt hc ha hb,
  simpa [h, lt_irrefl] using this
end

lemma add_eq_left {a b : cardinal} (ha : ℵ₀ ≤ a) (hb : b ≤ a) : a + b = a :=
by { rw [add_eq_max ha, max_eq_left hb] }

lemma add_eq_right {a b : cardinal} (hb : ℵ₀ ≤ b) (ha : a ≤ b) : a + b = b :=
by { rw [add_comm, add_eq_left hb ha] }

lemma add_eq_left_iff {a b : cardinal} : a + b = a ↔ (max ℵ₀ b ≤ a ∨ b = 0) :=
begin
  rw max_le_iff,
  refine ⟨λ h, _, _⟩,
  { cases (le_or_lt ℵ₀ a) with ha ha,
    { left, use ha, rw ←not_lt, apply λ hb, ne_of_gt _ h,
      exact hb.trans_le (self_le_add_left b a) },
    right, rw [←h, add_lt_aleph_0_iff, lt_aleph_0, lt_aleph_0] at ha,
    rcases ha with ⟨⟨n, rfl⟩, ⟨m, rfl⟩⟩, norm_cast at h ⊢,
    rw [←add_right_inj, h, add_zero] },
  { rintro (⟨h1, h2⟩|h3),
    { rw [add_eq_max h1, max_eq_left h2] },
    { rw [h3, add_zero] } }
end

lemma add_eq_right_iff {a b : cardinal} : a + b = b ↔ (max ℵ₀ a ≤ b ∨ a = 0) :=
by { rw [add_comm, add_eq_left_iff] }

lemma add_nat_eq {a : cardinal} (n : ℕ) (ha : ℵ₀ ≤ a) : a + n = a :=
add_eq_left ha ((nat_lt_aleph_0 _).le.trans ha)

lemma add_one_eq {a : cardinal} (ha : ℵ₀ ≤ a) : a + 1 = a :=
add_eq_left ha (one_le_aleph_0.trans ha)

@[simp] lemma mk_add_one_eq {α : Type*} [infinite α] : #α + 1 = #α :=
add_one_eq (aleph_0_le_mk α)

protected lemma eq_of_add_eq_add_left {a b c : cardinal} (h : a + b = a + c) (ha : a < ℵ₀) :
  b = c :=
begin
  cases le_or_lt ℵ₀ b with hb hb,
  { have : a < b := ha.trans_le hb,
    rw [add_eq_right hb this.le, eq_comm] at h,
    rw [eq_of_add_eq_of_aleph_0_le h this hb] },
  { have hc : c < ℵ₀,
    { rw ←not_le, intro hc,
      apply lt_irrefl ℵ₀, apply (hc.trans (self_le_add_left _ a)).trans_lt,
      rw ←h, apply add_lt_aleph_0 ha hb },
    rw lt_aleph_0 at *,
    rcases ha with ⟨n, rfl⟩, rcases hb with ⟨m, rfl⟩, rcases hc with ⟨k, rfl⟩,
    norm_cast at h ⊢, apply add_left_cancel h }
end

protected lemma eq_of_add_eq_add_right {a b c : cardinal} (h : a + b = c + b) (hb : b < ℵ₀) :
  a = c :=
by { rw [add_comm a b, add_comm c b] at h, exact cardinal.eq_of_add_eq_add_left h hb }

@[simp] theorem aleph_add_aleph (o₁ o₂ : ordinal) : aleph o₁ + aleph o₂ = aleph (max o₁ o₂) :=
by rw [cardinal.add_eq_max (aleph_0_le_aleph o₁), max_aleph_eq]

theorem principal_add_ord {c : cardinal} (hc : ℵ₀ ≤ c) : ordinal.principal (+) c.ord :=
λ a b ha hb, by { rw [lt_ord, ordinal.card_add] at *, exact add_lt_of_lt hc ha hb }

theorem principal_add_aleph (o : ordinal) : ordinal.principal (+) (aleph o).ord :=
principal_add_ord $ aleph_0_le_aleph o

lemma add_right_inj_of_lt_aleph_0 {α β γ : cardinal} (γ₀ : γ < aleph_0) :
  α + γ = β + γ ↔ α = β :=
⟨λ h, cardinal.eq_of_add_eq_add_right h γ₀, λ h, congr_fun (congr_arg (+) h) γ⟩

@[simp] lemma add_nat_inj {α β : cardinal} (n : ℕ) :
  α + n = β + n ↔ α = β :=
add_right_inj_of_lt_aleph_0 (nat_lt_aleph_0 _)

@[simp] lemma add_one_inj {α β : cardinal} :
  α + 1 = β + 1 ↔ α = β :=
add_right_inj_of_lt_aleph_0 one_lt_aleph_0

lemma add_le_add_iff_of_lt_aleph_0 {α β γ : cardinal} (γ₀ : γ < cardinal.aleph_0) :
  α + γ ≤ β + γ ↔ α ≤ β :=
begin
  refine ⟨λ h, _, λ h, add_le_add_right h γ⟩,
  contrapose h,
  rw [not_le, lt_iff_le_and_ne, ne] at h ⊢,
  exact ⟨add_le_add_right h.1 γ, mt (add_right_inj_of_lt_aleph_0 γ₀).1 h.2⟩,
end

@[simp] lemma add_nat_le_add_nat_iff_of_lt_aleph_0 {α β : cardinal} (n : ℕ) :
  α + n ≤ β + n ↔ α ≤ β :=
add_le_add_iff_of_lt_aleph_0 (nat_lt_aleph_0 n)

@[simp] lemma add_one_le_add_one_iff_of_lt_aleph_0 {α β : cardinal} :
  α + 1 ≤ β + 1 ↔ α ≤ β :=
add_le_add_iff_of_lt_aleph_0 one_lt_aleph_0

/-! ### Properties about power -/

theorem pow_le {κ μ : cardinal.{u}} (H1 : ℵ₀ ≤ κ) (H2 : μ < ℵ₀) : κ ^ μ ≤ κ :=
let ⟨n, H3⟩ := lt_aleph_0.1 H2 in
H3.symm ▸ (quotient.induction_on κ (λ α H1, nat.rec_on n
  (lt_of_lt_of_le (by { rw [nat.cast_zero, power_zero], exact one_lt_aleph_0 }) H1).le
  (λ n ih, trans_rel_left _
    (by { rw [nat.cast_succ, power_add, power_one], exact mul_le_mul_right' ih _ })
    (mul_eq_self H1))) H1)

theorem pow_eq {κ μ : cardinal.{u}} (H1 : ℵ₀ ≤ κ) (H2 : 1 ≤ μ) (H3 : μ < ℵ₀) : κ ^ μ = κ :=
(pow_le H1 H3).antisymm $ self_le_power κ H2

lemma power_self_eq {c : cardinal} (h : ℵ₀ ≤ c) : c ^ c = 2 ^ c :=
begin
  apply ((power_le_power_right $ (cantor c).le).trans _).antisymm,
  { convert power_le_power_right ((nat_lt_aleph_0 2).le.trans h), apply nat.cast_two.symm },
  { rw [←power_mul, mul_eq_self h] }
end

lemma prod_eq_two_power {ι : Type u} [infinite ι] {c : ι → cardinal.{v}} (h₁ : ∀ i, 2 ≤ c i)
  (h₂ : ∀ i, lift.{u} (c i) ≤ lift.{v} (#ι)) :
  prod c = 2 ^ lift.{v} (#ι) :=
begin
  rw [← lift_id' (prod c), lift_prod, ← lift_two_power],
  apply le_antisymm,
  { refine (prod_le_prod _ _ h₂).trans_eq _,
    rw [prod_const, lift_lift, ← lift_power, power_self_eq (aleph_0_le_mk ι), lift_umax.{u v}] },
  { rw [← prod_const', lift_prod],
    refine prod_le_prod _ _ (λ i, _),
    rw [lift_two, ← lift_two.{u v}, lift_le],
    exact h₁ i }
end

lemma power_eq_two_power {c₁ c₂ : cardinal} (h₁ : ℵ₀ ≤ c₁) (h₂ : 2 ≤ c₂) (h₂' : c₂ ≤ c₁) :
  c₂ ^ c₁ = 2 ^ c₁ :=
le_antisymm (power_self_eq h₁ ▸ power_le_power_right h₂') (power_le_power_right h₂)

lemma nat_power_eq {c : cardinal.{u}} (h : ℵ₀ ≤ c) {n : ℕ} (hn : 2 ≤ n) :
  (n : cardinal.{u}) ^ c = 2 ^ c :=
power_eq_two_power h (by assumption_mod_cast) ((nat_lt_aleph_0 n).le.trans h)

lemma power_nat_le {c : cardinal.{u}} {n : ℕ} (h : ℵ₀ ≤ c) : c ^ n ≤ c :=
pow_le h (nat_lt_aleph_0 n)

lemma power_nat_eq {c : cardinal.{u}} {n : ℕ} (h1 : ℵ₀ ≤ c) (h2 : 1 ≤ n) : c ^ n = c :=
pow_eq h1 (by exact_mod_cast h2) (nat_lt_aleph_0 n)

lemma power_nat_le_max {c : cardinal.{u}} {n : ℕ} : c ^ (n : cardinal.{u}) ≤ max c ℵ₀ :=
begin
  cases le_or_lt ℵ₀ c with hc hc,
  { exact le_max_of_le_left (power_nat_le hc) },
  { exact le_max_of_le_right ((power_lt_aleph_0 hc (nat_lt_aleph_0 _)).le) }
end

lemma powerlt_aleph_0 {c : cardinal} (h : ℵ₀ ≤ c) : c ^< ℵ₀ = c :=
begin
  apply le_antisymm,
  { rw powerlt_le, intro c', rw lt_aleph_0, rintro ⟨n, rfl⟩, apply power_nat_le h },
  convert le_powerlt c one_lt_aleph_0, rw power_one
end

lemma powerlt_aleph_0_le (c : cardinal) : c ^< ℵ₀ ≤ max c ℵ₀ :=
begin
  cases le_or_lt ℵ₀ c,
  { rw powerlt_aleph_0 h, apply le_max_left },
  rw powerlt_le,
  exact λ c' hc', (power_lt_aleph_0 h hc').le.trans (le_max_right _ _)
end

/-! ### Computing cardinality of various types -/

@[simp] theorem mk_list_eq_mk (α : Type u) [infinite α] : #(list α) = #α :=
have H1 : ℵ₀ ≤ #α := aleph_0_le_mk α,
eq.symm $ le_antisymm ⟨⟨λ x, [x], λ x y H, (list.cons.inj H).1⟩⟩ $
calc  #(list α)
    = sum (λ n : ℕ, #α ^ (n : cardinal.{u})) : mk_list_eq_sum_pow α
... ≤ sum (λ n : ℕ, #α) : sum_le_sum _ _ $ λ n, pow_le H1 $ nat_lt_aleph_0 n
... = #α : by simp [H1]

theorem mk_list_eq_aleph_0 (α : Type u) [countable α] [nonempty α] : #(list α) = ℵ₀ :=
mk_le_aleph_0.antisymm (aleph_0_le_mk _)

theorem mk_list_eq_max_mk_aleph_0 (α : Type u) [nonempty α] : #(list α) = max (#α) ℵ₀ :=
begin
  casesI finite_or_infinite α,
  { rw [mk_list_eq_aleph_0, eq_comm, max_eq_right],
    exact mk_le_aleph_0 },
  { rw [mk_list_eq_mk, eq_comm, max_eq_left],
    exact aleph_0_le_mk α }
end

theorem mk_list_le_max (α : Type u) : #(list α) ≤ max ℵ₀ (#α) :=
begin
  casesI finite_or_infinite α,
  { exact mk_le_aleph_0.trans (le_max_left _ _) },
  { rw mk_list_eq_mk,
    apply le_max_right }
end

@[simp] theorem mk_finset_of_infinite (α : Type u) [infinite α] : #(finset α) = #α :=
eq.symm $ le_antisymm (mk_le_of_injective (λ x y, finset.singleton_inj.1)) $
calc #(finset α) ≤ #(list α) : mk_le_of_surjective list.to_finset_surjective
... = #α : mk_list_eq_mk α

@[simp] lemma mk_finsupp_lift_of_infinite (α : Type u) (β : Type v) [infinite α] [has_zero β]
  [nontrivial β] : #(α →₀ β) = max (lift.{v} (#α)) (lift.{u} (#β)) :=
begin
  apply le_antisymm,
  { calc #(α →₀ β) ≤ # (finset (α × β)) : mk_le_of_injective (finsupp.graph_injective α β)
    ... = #(α × β) : mk_finset_of_infinite _
    ... = max (lift.{v} (#α)) (lift.{u} (#β)) :
      by rw [mk_prod, mul_eq_max_of_aleph_0_le_left]; simp },
  { apply max_le;
    rw [←lift_id (# (α →₀ β)), ←lift_umax],
    { cases exists_ne (0 : β) with b hb,
      exact lift_mk_le.{u (max u v) v}.2 ⟨⟨_, finsupp.single_left_injective hb⟩⟩ },
    { inhabit α,
      exact lift_mk_le.{v (max u v) u}.2 ⟨⟨_, finsupp.single_injective default⟩⟩ } }
end

lemma mk_finsupp_of_infinite (α β : Type u) [infinite α] [has_zero β]
  [nontrivial β] : #(α →₀ β) = max (#α) (#β) :=
by simp

@[simp] lemma mk_finsupp_lift_of_infinite' (α : Type u) (β : Type v) [nonempty α]
  [has_zero β] [infinite β] : #(α →₀ β) = max (lift.{v} (#α)) (lift.{u} (#β)) :=
begin
  casesI fintype_or_infinite α,
  { rw mk_finsupp_lift_of_fintype,
    have : ℵ₀ ≤ (#β).lift := aleph_0_le_lift.2 (aleph_0_le_mk β),
    rw [max_eq_right (le_trans _ this), power_nat_eq this],
    exacts [fintype.card_pos, lift_le_aleph_0.2 (lt_aleph_0_of_finite _).le] },
  { apply mk_finsupp_lift_of_infinite },
end

lemma mk_finsupp_of_infinite' (α β : Type u) [nonempty α] [has_zero β] [infinite β] :
  #(α →₀ β) = max (#α) (#β) := by simp

lemma mk_finsupp_nat (α : Type u) [nonempty α] : #(α →₀ ℕ) = max (#α) ℵ₀ := by simp

@[simp] lemma mk_multiset_of_nonempty (α : Type u) [nonempty α] : #(multiset α) = max (#α) ℵ₀ :=
multiset.to_finsupp.to_equiv.cardinal_eq.trans (mk_finsupp_nat α)

lemma mk_multiset_of_infinite (α : Type u) [infinite α] : #(multiset α) = #α := by simp

@[simp] lemma mk_multiset_of_is_empty (α : Type u) [is_empty α] : #(multiset α) = 1 :=
multiset.to_finsupp.to_equiv.cardinal_eq.trans (by simp)

lemma mk_multiset_of_countable (α : Type u) [countable α] [nonempty α] : #(multiset α) = ℵ₀ :=
multiset.to_finsupp.to_equiv.cardinal_eq.trans (by simp)

lemma mk_bounded_set_le_of_infinite (α : Type u) [infinite α] (c : cardinal) :
  #{t : set α // #t ≤ c} ≤ #α ^ c :=
begin
  refine le_trans _ (by rw [←add_one_eq (aleph_0_le_mk α)]),
  induction c using cardinal.induction_on with β,
  fapply mk_le_of_surjective,
  { intro f, use sum.inl ⁻¹' range f,
    refine le_trans (mk_preimage_of_injective _ _ (λ x y, sum.inl.inj)) _,
    apply mk_range_le },
  rintro ⟨s, ⟨g⟩⟩,
  use λ y, if h : ∃(x : s), g x = y then sum.inl (classical.some h).val else sum.inr ⟨⟩,
  apply subtype.eq, ext,
  split,
  { rintro ⟨y, h⟩, dsimp only at h, by_cases h' : ∃ (z : s), g z = y,
    { rw [dif_pos h'] at h, cases sum.inl.inj h, exact (classical.some h').2 },
    { rw [dif_neg h'] at h, cases h }},
  { intro h, have : ∃(z : s), g z = g ⟨x, h⟩, exact ⟨⟨x, h⟩, rfl⟩,
    use g ⟨x, h⟩, dsimp only, rw [dif_pos this], congr',
    suffices : classical.some this = ⟨x, h⟩, exact congr_arg subtype.val this,
    apply g.2, exact classical.some_spec this }
end

lemma mk_bounded_set_le (α : Type u) (c : cardinal) :
  #{t : set α // #t ≤ c} ≤ max (#α) ℵ₀ ^ c :=
begin
  transitivity #{t : set (ulift.{u} ℕ ⊕ α) // #t ≤ c},
  { refine ⟨embedding.subtype_map _ _⟩, apply embedding.image,
    use sum.inr, apply sum.inr.inj, intros s hs, exact mk_image_le.trans hs },
  apply (mk_bounded_set_le_of_infinite (ulift.{u} ℕ ⊕ α) c).trans,
  rw [max_comm, ←add_eq_max]; refl
end

lemma mk_bounded_subset_le {α : Type u} (s : set α) (c : cardinal.{u}) :
  #{t : set α // t ⊆ s ∧ #t ≤ c} ≤ max (#s) ℵ₀ ^ c :=
begin
  refine le_trans _ (mk_bounded_set_le s c),
  refine ⟨embedding.cod_restrict _ _ _⟩,
  use λ t, coe ⁻¹' t.1,
  { rintros ⟨t, ht1, ht2⟩ ⟨t', h1t', h2t'⟩ h, apply subtype.eq, dsimp only at h ⊢,
    refine (preimage_eq_preimage' _ _).1 h; rw [subtype.range_coe]; assumption },
  rintro ⟨t, h1t, h2t⟩, exact (mk_preimage_of_injective _ _ subtype.val_injective).trans h2t
end

/-! ### Properties of `compl` -/

lemma mk_compl_of_infinite {α : Type*} [infinite α] (s : set α) (h2 : #s < #α) :
  #(sᶜ : set α) = #α :=
by { refine eq_of_add_eq_of_aleph_0_le _ h2 (aleph_0_le_mk α), exact mk_sum_compl s }

lemma mk_compl_finset_of_infinite {α : Type*} [infinite α] (s : finset α) :
  #((↑s)ᶜ : set α) = #α :=
by { apply mk_compl_of_infinite, exact (finset_card_lt_aleph_0 s).trans_le (aleph_0_le_mk α) }

lemma mk_compl_eq_mk_compl_infinite {α : Type*} [infinite α] {s t : set α} (hs : #s < #α)
  (ht : #t < #α) : #(sᶜ : set α) = #(tᶜ : set α) :=
by { rw [mk_compl_of_infinite s hs, mk_compl_of_infinite t ht] }

lemma mk_compl_eq_mk_compl_finite_lift {α : Type u} {β : Type v} [finite α]
  {s : set α} {t : set β} (h1 : lift.{max v w} (#α) = lift.{max u w} (#β))
  (h2 : lift.{max v w} (#s) = lift.{max u w} (#t)) :
  lift.{max v w} (#(sᶜ : set α)) = lift.{max u w} (#(tᶜ : set β)) :=
begin
  casesI nonempty_fintype α,
  rcases lift_mk_eq.1 h1 with ⟨e⟩, letI : fintype β := fintype.of_equiv α e,
  replace h1 : fintype.card α = fintype.card β := (fintype.of_equiv_card _).symm,
  classical,
  lift s to finset α using s.to_finite,
  lift t to finset β using t.to_finite,
  simp only [finset.coe_sort_coe, mk_coe_finset, lift_nat_cast, nat.cast_inj] at h2,
  simp only [← finset.coe_compl, finset.coe_sort_coe, mk_coe_finset, finset.card_compl,
    lift_nat_cast, nat.cast_inj, h1, h2]
end

lemma mk_compl_eq_mk_compl_finite {α β : Type u} [finite α] {s : set α} {t : set β}
  (h1 : #α = #β) (h : #s = #t) : #(sᶜ : set α) = #(tᶜ : set β) :=
by { rw ← lift_inj, apply mk_compl_eq_mk_compl_finite_lift; rwa [lift_inj] }

lemma mk_compl_eq_mk_compl_finite_same {α : Type*} [finite α] {s t : set α}
  (h : #s = #t) : #(sᶜ : set α) = #(tᶜ : set α) :=
mk_compl_eq_mk_compl_finite rfl h

/-! ### Extending an injection to an equiv -/

theorem extend_function {α β : Type*} {s : set α} (f : s ↪ β)
  (h : nonempty ((sᶜ : set α) ≃ ((range f)ᶜ : set β))) :
  ∃ (g : α ≃ β), ∀ x : s, g x = f x :=
begin
  intros, have := h, cases this with g,
  let h : α ≃ β := (set.sum_compl (s : set α)).symm.trans
    ((sum_congr (equiv.of_injective f f.2) g).trans
    (set.sum_compl (range f))),
  refine ⟨h, _⟩, rintro ⟨x, hx⟩, simp [set.sum_compl_symm_apply_of_mem, hx]
end

theorem extend_function_finite {α β : Type*} [finite α] {s : set α} (f : s ↪ β)
  (h : nonempty (α ≃ β)) : ∃ (g : α ≃ β), ∀ x : s, g x = f x :=
begin
  apply extend_function f,
  cases id h with g,
  rw [← lift_mk_eq] at h,
  rw [←lift_mk_eq, mk_compl_eq_mk_compl_finite_lift h],
  rw [mk_range_eq_lift], exact f.2
end

theorem extend_function_of_lt {α β : Type*} {s : set α} (f : s ↪ β) (hs : #s < #α)
  (h : nonempty (α ≃ β)) : ∃ (g : α ≃ β), ∀ x : s, g x = f x :=
begin
  casesI fintype_or_infinite α,
  { exact extend_function_finite f h },
  { apply extend_function f, cases id h with g, haveI := infinite.of_injective _ g.injective,
    rw [← lift_mk_eq'] at h ⊢,
    rwa [mk_compl_of_infinite s hs, mk_compl_of_infinite],
    rwa [← lift_lt, mk_range_eq_of_injective f.injective, ← h, lift_lt] },
end

section bit
/-!
This section proves inequalities for `bit0` and `bit1`, enabling `simp` to solve inequalities
for numeral cardinals. The complexity of the resulting algorithm is not good, as in some cases
`simp` reduces an inequality to a disjunction of two situations, depending on whether a cardinal
is finite or infinite. Since the evaluation of the branches is not lazy, this is bad. It is good
enough for practical situations, though.

For specific numbers, these inequalities could also be deduced from the corresponding
inequalities of natural numbers using `norm_cast`:
```
example : (37 : cardinal) < 42 :=
by { norm_cast, norm_num }
```
-/

lemma bit0_ne_zero (a : cardinal) : ¬bit0 a = 0 ↔ ¬a = 0 :=
by simp [bit0]

@[simp] lemma bit1_ne_zero (a : cardinal) : ¬bit1 a = 0 :=
by simp [bit1]

@[simp] lemma zero_lt_bit0 (a : cardinal) : 0 < bit0 a ↔ 0 < a :=
by { rw ←not_iff_not, simp [bit0], }

@[simp] lemma zero_lt_bit1 (a : cardinal) : 0 < bit1 a :=
zero_lt_one.trans_le (self_le_add_left _ _)

@[simp] lemma one_le_bit0 (a : cardinal) : 1 ≤ bit0 a ↔ 0 < a :=
⟨λ h, (zero_lt_bit0 a).mp (zero_lt_one.trans_le h),
 λ h, (one_le_iff_pos.mpr h).trans (self_le_add_left a a)⟩

@[simp] lemma one_le_bit1 (a : cardinal) : 1 ≤ bit1 a :=
self_le_add_left _ _

theorem bit0_eq_self {c : cardinal} (h : ℵ₀ ≤ c) : bit0 c = c :=
add_eq_self h

@[simp] theorem bit0_lt_aleph_0 {c : cardinal} : bit0 c < ℵ₀ ↔ c < ℵ₀ :=
by simp [bit0, add_lt_aleph_0_iff]

@[simp] theorem aleph_0_le_bit0 {c : cardinal} : ℵ₀ ≤ bit0 c ↔ ℵ₀ ≤ c :=
by { rw ←not_iff_not, simp }

@[simp] theorem bit1_eq_self_iff {c : cardinal} : bit1 c = c ↔ ℵ₀ ≤ c :=
begin
  by_cases h : ℵ₀ ≤ c,
  { simp only [bit1, bit0_eq_self h, h, eq_self_iff_true, add_one_of_aleph_0_le] },
  { refine iff_of_false (ne_of_gt _) h,
    rcases lt_aleph_0.1 (not_le.1 h) with ⟨n, rfl⟩,
    norm_cast,
    dsimp [bit1, bit0],
    linarith }
end

@[simp] theorem bit1_lt_aleph_0 {c : cardinal} : bit1 c < ℵ₀ ↔ c < ℵ₀ :=
by simp [bit1, bit0, add_lt_aleph_0_iff, one_lt_aleph_0]

@[simp] theorem aleph_0_le_bit1 {c : cardinal} : ℵ₀ ≤ bit1 c ↔ ℵ₀ ≤ c :=
by { rw ←not_iff_not, simp }

@[simp] lemma bit0_le_bit0 {a b : cardinal} : bit0 a ≤ bit0 b ↔ a ≤ b :=
begin
  cases le_or_lt ℵ₀ a with ha ha; cases le_or_lt ℵ₀ b with hb hb,
  { rw [bit0_eq_self ha, bit0_eq_self hb] },
  { rw bit0_eq_self ha,
    refine iff_of_false (λ h, _) (hb.trans_le ha).not_le,
    have A : bit0 b < ℵ₀, by simpa using hb,
    exact lt_irrefl _ ((A.trans_le ha).trans_le h) },
  { rw bit0_eq_self hb,
    exact iff_of_true ((bit0_lt_aleph_0.2 ha).le.trans hb) (ha.le.trans hb) },
  { rcases lt_aleph_0.1 ha with ⟨m, rfl⟩,
    rcases lt_aleph_0.1 hb with ⟨n, rfl⟩,
    norm_cast,
    exact bit0_le_bit0 }
end

@[simp] lemma bit0_le_bit1 {a b : cardinal} : bit0 a ≤ bit1 b ↔ a ≤ b :=
begin
  cases le_or_lt ℵ₀ a with ha ha; cases le_or_lt ℵ₀ b with hb hb,
  { rw [bit0_eq_self ha, bit1_eq_self_iff.2 hb] },
  { rw bit0_eq_self ha,
    refine iff_of_false (λ h, _) (hb.trans_le ha).not_le,
    have A : bit1 b < ℵ₀, by simpa using hb,
    exact lt_irrefl _ ((A.trans_le ha).trans_le h) },
  { rw bit1_eq_self_iff.2 hb,
    exact iff_of_true ((bit0_lt_aleph_0.2 ha).le.trans hb) (ha.le.trans hb) },
  { rcases lt_aleph_0.1 ha with ⟨m, rfl⟩,
    rcases lt_aleph_0.1 hb with ⟨n, rfl⟩,
    norm_cast,
    exact nat.bit0_le_bit1_iff }
end

@[simp] lemma bit1_le_bit1 {a b : cardinal} : bit1 a ≤ bit1 b ↔ a ≤ b :=
⟨λ h, bit0_le_bit1.1 ((self_le_add_right (bit0 a) 1).trans h), λ h,
  (add_le_add_right (add_le_add_left h a) 1).trans (add_le_add_right (add_le_add_right h b) 1)⟩

@[simp] lemma bit1_le_bit0 {a b : cardinal} : bit1 a ≤ bit0 b ↔ (a < b ∨ (a ≤ b ∧ ℵ₀ ≤ a)) :=
begin
  cases le_or_lt ℵ₀ a with ha ha; cases le_or_lt ℵ₀ b with hb hb,
  { simp only [bit1_eq_self_iff.mpr ha, bit0_eq_self hb, ha, and_true],
    refine ⟨λ h, or.inr h, λ h, _⟩,
    cases h,
    { exact le_of_lt h },
    { exact h } },
  { rw bit1_eq_self_iff.2 ha,
    refine iff_of_false (λ h, _) (λ h, _),
    { have A : bit0 b < ℵ₀, by simpa using hb,
      exact lt_irrefl _ ((A.trans_le ha).trans_le h) },
    { exact not_le_of_lt (hb.trans_le ha) (h.elim le_of_lt and.left) } },
  { rw bit0_eq_self hb,
    exact iff_of_true ((bit1_lt_aleph_0.2 ha).le.trans hb) (or.inl $ ha.trans_le hb) },
  { rcases lt_aleph_0.1 ha with ⟨m, rfl⟩,
    rcases lt_aleph_0.1 hb with ⟨n, rfl⟩,
    norm_cast,
    simp [not_le.mpr ha] }
end

@[simp] lemma bit0_lt_bit0 {a b : cardinal} : bit0 a < bit0 b ↔ a < b :=
begin
  cases le_or_lt ℵ₀ a with ha ha; cases le_or_lt ℵ₀ b with hb hb,
  { rw [bit0_eq_self ha, bit0_eq_self hb] },
  { rw bit0_eq_self ha,
    refine iff_of_false (λ h, _) (hb.le.trans ha).not_lt,
    have A : bit0 b < ℵ₀, by simpa using hb,
    exact lt_irrefl _ ((A.trans_le ha).trans h) },
  { rw bit0_eq_self hb,
    exact iff_of_true ((bit0_lt_aleph_0.2 ha).trans_le hb) (ha.trans_le hb) },
  { rcases lt_aleph_0.1 ha with ⟨m, rfl⟩,
    rcases lt_aleph_0.1 hb with ⟨n, rfl⟩,
    norm_cast,
    exact bit0_lt_bit0 }
end

@[simp] lemma bit1_lt_bit0 {a b : cardinal} : bit1 a < bit0 b ↔ a < b :=
begin
  cases le_or_lt ℵ₀ a with ha ha; cases le_or_lt ℵ₀ b with hb hb,
  { rw [bit1_eq_self_iff.2 ha, bit0_eq_self hb] },
  { rw bit1_eq_self_iff.2 ha,
    refine iff_of_false (λ h, _) (hb.le.trans ha).not_lt,
    have A : bit0 b < ℵ₀, by simpa using hb,
    exact lt_irrefl _ ((A.trans_le ha).trans h) },
  { rw bit0_eq_self hb,
    exact iff_of_true ((bit1_lt_aleph_0.2 ha).trans_le hb) (ha.trans_le hb) },
  { rcases lt_aleph_0.1 ha with ⟨m, rfl⟩,
    rcases lt_aleph_0.1 hb with ⟨n, rfl⟩,
    norm_cast,
    exact nat.bit1_lt_bit0_iff }
end

@[simp] lemma bit1_lt_bit1 {a b : cardinal} : bit1 a < bit1 b ↔ a < b :=
begin
  cases le_or_lt ℵ₀ a with ha ha; cases le_or_lt ℵ₀ b with hb hb,
  { rw [bit1_eq_self_iff.2 ha, bit1_eq_self_iff.2 hb] },
  { rw bit1_eq_self_iff.2 ha,
    refine iff_of_false (λ h, _) (hb.le.trans ha).not_lt,
    have A : bit1 b < ℵ₀, by simpa using hb,
    exact lt_irrefl _ ((A.trans_le ha).trans h) },
  { rw bit1_eq_self_iff.2 hb,
    exact iff_of_true ((bit1_lt_aleph_0.2 ha).trans_le hb) (ha.trans_le hb) },
  { rcases lt_aleph_0.1 ha with ⟨m, rfl⟩,
    rcases lt_aleph_0.1 hb with ⟨n, rfl⟩,
    norm_cast,
    exact bit1_lt_bit1 }
end

@[simp] lemma bit0_lt_bit1 {a b : cardinal} : bit0 a < bit1 b ↔ (a < b ∨ (a ≤ b ∧ a < ℵ₀)) :=
begin
  cases le_or_lt ℵ₀ a with ha ha; cases le_or_lt ℵ₀ b with hb hb,
  { simp [bit0_eq_self ha, bit1_eq_self_iff.2 hb, not_lt.mpr ha] },
  { rw bit0_eq_self ha,
    refine iff_of_false (λ h, _) (λ h, _),
    { have A : bit1 b < ℵ₀, by simpa using hb,
      exact lt_irrefl _ ((A.trans_le ha).trans h) },
    { exact (hb.trans_le ha).not_le (h.elim le_of_lt and.left) } },
  { rw [bit1_eq_self_iff.2 hb],
    exact iff_of_true ((bit0_lt_aleph_0.2 ha).trans_le hb) (or.inl $ ha.trans_le hb) },
  { rcases lt_aleph_0.1 ha with ⟨m, rfl⟩,
    rcases lt_aleph_0.1 hb with ⟨n, rfl⟩,
    norm_cast,
    simp only [ha, and_true, nat.bit0_lt_bit1_iff, or_iff_right_of_imp le_of_lt] }
end

lemma one_lt_two : (1 : cardinal) < 2 :=
-- This strategy works generally to prove inequalities between numerals in `cardinality`.
by { norm_cast, norm_num }

@[simp] lemma one_lt_bit0 {a : cardinal} : 1 < bit0 a ↔ 0 < a :=
by simp [←bit1_zero]

@[simp] lemma one_lt_bit1 (a : cardinal) : 1 < bit1 a ↔ 0 < a :=
by simp [←bit1_zero]

end bit

end cardinal


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import computability.primrec
import data.nat.psub
import data.pfun

/-!
# The partial recursive functions

The partial recursive functions are defined similarly to the primitive
recursive functions, but now all functions are partial, implemented
using the `part` monad, and there is an additional operation, called
μ-recursion, which performs unbounded minimization.

## References

* [Mario Carneiro, *Formalizing computability theory via partial recursive functions*][carneiro2019]
-/

open encodable denumerable part

local attribute [-simp] not_forall

namespace nat

section rfind
parameter (p : ℕ →. bool)

private def lbp (m n : ℕ) : Prop := m = n + 1 ∧ ∀ k ≤ n, ff ∈ p k

parameter (H : ∃ n, tt ∈ p n ∧ ∀ k < n, (p k).dom)

private def wf_lbp : well_founded lbp :=
⟨let ⟨n, pn⟩ := H in begin
  suffices : ∀m k, n ≤ k + m → acc (lbp p) k,
  { from λ a, this _ _ (nat.le_add_left _ _) },
  intros m k kn,
  induction m with m IH generalizing k;
    refine ⟨_, λ y r, _⟩; rcases r with ⟨rfl, a⟩,
  { injection mem_unique pn.1 (a _ kn) },
  { exact IH _ (by rw nat.add_right_comm; exact kn) }
end⟩

def rfind_x : {n // tt ∈ p n ∧ ∀m < n, ff ∈ p m} :=
suffices ∀ k, (∀n < k, ff ∈ p n) → {n // tt ∈ p n ∧ ∀m < n, ff ∈ p m},
from this 0 (λ n, (nat.not_lt_zero _).elim),
@well_founded.fix _ _ lbp wf_lbp begin
  intros m IH al,
  have pm : (p m).dom,
  { rcases H with ⟨n, h₁, h₂⟩,
    rcases lt_trichotomy m n with h₃|h₃|h₃,
    { exact h₂ _ h₃ },
    { rw h₃, exact h₁.fst },
    { injection mem_unique h₁ (al _ h₃) } },
  cases e : (p m).get pm,
  { suffices,
    exact IH _ ⟨rfl, this⟩ (λ n h, this _ (le_of_lt_succ h)),
    intros n h, cases h.lt_or_eq_dec with h h,
    { exact al _ h },
    { rw h, exact ⟨_, e⟩ } },
  { exact ⟨m, ⟨_, e⟩, al⟩ }
end

end rfind

def rfind (p : ℕ →. bool) : part ℕ :=
⟨_, λ h, (rfind_x p h).1⟩

theorem rfind_spec {p : ℕ →. bool} {n : ℕ} (h : n ∈ rfind p) : tt ∈ p n :=
h.snd ▸ (rfind_x p h.fst).2.1

theorem rfind_min {p : ℕ →. bool} {n : ℕ} (h : n ∈ rfind p) :
  ∀ {m : ℕ}, m < n → ff ∈ p m :=
h.snd ▸ (rfind_x p h.fst).2.2

@[simp] theorem rfind_dom {p : ℕ →. bool} :
  (rfind p).dom ↔ ∃ n, tt ∈ p n ∧ ∀ {m : ℕ}, m < n → (p m).dom :=
iff.rfl

theorem rfind_dom' {p : ℕ →. bool} :
  (rfind p).dom ↔ ∃ n, tt ∈ p n ∧ ∀ {m : ℕ}, m ≤ n → (p m).dom :=
exists_congr $ λ n, and_congr_right $ λ pn,
⟨λ H m h, (decidable.eq_or_lt_of_le h).elim (λ e, e.symm ▸ pn.fst) (H _),
 λ H m h, H (le_of_lt h)⟩

@[simp] theorem mem_rfind {p : ℕ →. bool} {n : ℕ} :
  n ∈ rfind p ↔ tt ∈ p n ∧ ∀ {m : ℕ}, m < n → ff ∈ p m :=
⟨λ h, ⟨rfind_spec h, @rfind_min _ _ h⟩,
  λ ⟨h₁, h₂⟩, let ⟨m, hm⟩ := dom_iff_mem.1 $
    (@rfind_dom p).2 ⟨_, h₁, λ m mn, (h₂ mn).fst⟩ in
  begin
    rcases lt_trichotomy m n with h|h|h,
    { injection mem_unique (h₂ h) (rfind_spec hm) },
    { rwa ← h },
    { injection mem_unique h₁ (rfind_min hm h) },
  end⟩

theorem rfind_min' {p : ℕ → bool} {m : ℕ} (pm : p m) :
  ∃ n ∈ rfind p, n ≤ m :=
have tt ∈ (p : ℕ →. bool) m, from ⟨trivial, pm⟩,
let ⟨n, hn⟩ := dom_iff_mem.1 $
  (@rfind_dom p).2 ⟨m, this, λ k h, ⟨⟩⟩ in
⟨n, hn, not_lt.1 $ λ h,
  by injection mem_unique this (rfind_min hn h)⟩

theorem rfind_zero_none
  (p : ℕ →. bool) (p0 : p 0 = none) : rfind p = none :=
eq_none_iff.2 $ λ a h,
let ⟨n, h₁, h₂⟩ := rfind_dom'.1 h.fst in
(p0 ▸ h₂ (zero_le _) : (@part.none bool).dom)

def rfind_opt {α} (f : ℕ → option α) : part α :=
(rfind (λ n, (f n).is_some)).bind (λ n, f n)

theorem rfind_opt_spec {α} {f : ℕ → option α} {a}
 (h : a ∈ rfind_opt f) : ∃ n, a ∈ f n :=
let ⟨n, h₁, h₂⟩ := mem_bind_iff.1 h in ⟨n, mem_coe.1 h₂⟩

theorem rfind_opt_dom {α} {f : ℕ → option α} :
  (rfind_opt f).dom ↔ ∃ n a, a ∈ f n :=
⟨λ h, (rfind_opt_spec ⟨h, rfl⟩).imp (λ n h, ⟨_, h⟩),
 λ h, begin
  have h' : ∃ n, (f n).is_some :=
    h.imp (λ n, option.is_some_iff_exists.2),
  have s := nat.find_spec h',
  have fd : (rfind (λ n, (f n).is_some)).dom :=
    ⟨nat.find h', by simpa using s.symm, λ _ _, trivial⟩,
  refine ⟨fd, _⟩,
  have := rfind_spec (get_mem fd),
  simp at this ⊢,
  cases option.is_some_iff_exists.1 this.symm with a e,
  rw e, trivial
end⟩

theorem rfind_opt_mono {α} {f : ℕ → option α}
  (H : ∀ {a m n}, m ≤ n → a ∈ f m → a ∈ f n)
  {a} : a ∈ rfind_opt f ↔ ∃ n, a ∈ f n :=
⟨rfind_opt_spec, λ ⟨n, h⟩, begin
  have h' := rfind_opt_dom.2 ⟨_, _, h⟩,
  cases rfind_opt_spec ⟨h', rfl⟩ with k hk,
  have := (H (le_max_left _ _) h).symm.trans
          (H (le_max_right _ _) hk),
  simp at this, simp [this, get_mem]
end⟩

inductive partrec : (ℕ →. ℕ) → Prop
| zero : partrec (pure 0)
| succ : partrec succ
| left : partrec ↑(λ n : ℕ, n.unpair.1)
| right : partrec ↑(λ n : ℕ, n.unpair.2)
| pair {f g} : partrec f → partrec g → partrec (λ n, mkpair <$> f n <*> g n)
| comp {f g} : partrec f → partrec g → partrec (λ n, g n >>= f)
| prec {f g} : partrec f → partrec g → partrec (unpaired (λ a n,
    n.elim (f a) (λ y IH, do i ← IH, g (mkpair a (mkpair y i)))))
| rfind {f} : partrec f → partrec (λ a,
    rfind (λ n, (λ m, m = 0) <$> f (mkpair a n)))

namespace partrec

theorem of_eq {f g : ℕ →. ℕ} (hf : partrec f) (H : ∀ n, f n = g n) : partrec g :=
(funext H : f = g) ▸ hf

theorem of_eq_tot {f : ℕ →. ℕ} {g : ℕ → ℕ}
  (hf : partrec f) (H : ∀ n, g n ∈ f n) : partrec g :=
hf.of_eq (λ n, eq_some_iff.2 (H n))

theorem of_primrec {f : ℕ → ℕ} (hf : primrec f) : partrec f :=
begin
  induction hf,
  case nat.primrec.zero { exact zero },
  case nat.primrec.succ { exact succ },
  case nat.primrec.left { exact left },
  case nat.primrec.right { exact right },
  case nat.primrec.pair : f g hf hg pf pg
  { refine (pf.pair pg).of_eq_tot (λ n, _),
    simp [has_seq.seq] },
  case nat.primrec.comp : f g hf hg pf pg
  { refine (pf.comp pg).of_eq_tot (λ n, _),
    simp },
  case nat.primrec.prec : f g hf hg pf pg
  { refine (pf.prec pg).of_eq_tot (λ n, _),
    simp,
    induction n.unpair.2 with m IH, {simp},
    simp, exact ⟨_, IH, rfl⟩ },
end

protected theorem some : partrec some := of_primrec primrec.id

theorem none : partrec (λ n, none) :=
(of_primrec (nat.primrec.const 1)).rfind.of_eq $
λ n, eq_none_iff.2 $ λ a ⟨h, e⟩, by simpa using h

theorem prec' {f g h}
  (hf : partrec f) (hg : partrec g) (hh : partrec h) :
  partrec (λ a, (f a).bind (λ n, n.elim (g a)
    (λ y IH, do i ← IH, h (mkpair a (mkpair y i))))) :=
((prec hg hh).comp (pair partrec.some hf)).of_eq $
λ a, ext $ λ s, by simp [(<*>)]; exact
⟨λ ⟨n, h₁, h₂⟩, ⟨_, ⟨_, h₁, rfl⟩, by simpa using h₂⟩,
 λ ⟨_, ⟨n, h₁, rfl⟩, h₂⟩, ⟨_, h₁, by simpa using h₂⟩⟩

theorem ppred : partrec (λ n, ppred n) :=
have primrec₂ (λ n m, if n = nat.succ m then 0 else 1),
from (primrec.ite
  (@@primrec_rel.comp _ _ _ _ _ _ _ primrec.eq
    primrec.fst
    (_root_.primrec.succ.comp primrec.snd))
  (_root_.primrec.const 0) (_root_.primrec.const 1)).to₂,
(of_primrec (primrec₂.unpaired'.2 this)).rfind.of_eq $
λ n, begin
  cases n; simp,
  { exact eq_none_iff.2 (λ a ⟨⟨m, h, _⟩, _⟩,
      by simpa [show 0 ≠ m.succ, by intro h; injection h] using h) },
  { refine eq_some_iff.2 _,
    simp, intros m h, simp [ne_of_gt h] }
end

end partrec

end nat

def partrec {α σ} [primcodable α] [primcodable σ]
  (f : α →. σ) := nat.partrec (λ n,
  part.bind (decode α n) (λ a, (f a).map encode))

def partrec₂ {α β σ} [primcodable α] [primcodable β] [primcodable σ]
  (f : α → β →. σ) := partrec (λ p : α × β, f p.1 p.2)

def computable {α σ} [primcodable α] [primcodable σ] (f : α → σ) := partrec (f : α →. σ)

def computable₂ {α β σ} [primcodable α] [primcodable β] [primcodable σ]
  (f : α → β → σ) := computable (λ p : α × β, f p.1 p.2)

theorem primrec.to_comp {α σ} [primcodable α] [primcodable σ]
  {f : α → σ} (hf : primrec f) : computable f :=
(nat.partrec.ppred.comp (nat.partrec.of_primrec hf)).of_eq $
λ n, by simp; cases decode α n; simp

theorem primrec₂.to_comp {α β σ} [primcodable α] [primcodable β] [primcodable σ]
  {f : α → β → σ} (hf : primrec₂ f) : computable₂ f := hf.to_comp

protected theorem computable.partrec {α σ} [primcodable α] [primcodable σ]
  {f : α → σ} (hf : computable f) : partrec (f : α →. σ) := hf

protected theorem computable₂.partrec₂ {α β σ} [primcodable α] [primcodable β] [primcodable σ]
  {f : α → β → σ} (hf : computable₂ f) : partrec₂ (λ a, (f a : β →. σ)) := hf

namespace computable
variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable σ]

theorem of_eq {f g : α → σ} (hf : computable f) (H : ∀ n, f n = g n) : computable g :=
(funext H : f = g) ▸ hf

theorem const (s : σ) : computable (λ a : α, s) :=
(primrec.const _).to_comp

theorem of_option {f : α → option β} (hf : computable f) :
  partrec (λ a, (f a : part β)) :=
(nat.partrec.ppred.comp hf).of_eq $ λ n, begin
  cases decode α n with a; simp,
  cases f a with b; simp
end

theorem to₂ {f : α × β → σ} (hf : computable f) : computable₂ (λ a b, f (a, b)) :=
hf.of_eq $ λ ⟨a, b⟩, rfl

protected theorem id : computable (@id α) := primrec.id.to_comp

theorem fst : computable (@prod.fst α β) := primrec.fst.to_comp

theorem snd : computable (@prod.snd α β) := primrec.snd.to_comp

theorem pair {f : α → β} {g : α → γ}
  (hf : computable f) (hg : computable g) : computable (λ a, (f a, g a)) :=
(hf.pair hg).of_eq $
λ n, by cases decode α n; simp [(<*>)]

theorem unpair : computable nat.unpair := primrec.unpair.to_comp

theorem succ : computable nat.succ := primrec.succ.to_comp
theorem pred : computable nat.pred := primrec.pred.to_comp
theorem nat_bodd : computable nat.bodd := primrec.nat_bodd.to_comp
theorem nat_div2 : computable nat.div2 := primrec.nat_div2.to_comp

theorem sum_inl : computable (@sum.inl α β) := primrec.sum_inl.to_comp
theorem sum_inr : computable (@sum.inr α β) := primrec.sum_inr.to_comp

theorem list_cons : computable₂ (@list.cons α) := primrec.list_cons.to_comp
theorem list_reverse : computable (@list.reverse α) := primrec.list_reverse.to_comp
theorem list_nth : computable₂ (@list.nth α) := primrec.list_nth.to_comp
theorem list_append : computable₂ ((++) : list α → list α → list α) := primrec.list_append.to_comp
theorem list_concat : computable₂ (λ l (a:α), l ++ [a]) := primrec.list_concat.to_comp
theorem list_length : computable (@list.length α) := primrec.list_length.to_comp

theorem vector_cons {n} : computable₂ (@vector.cons α n) := primrec.vector_cons.to_comp
theorem vector_to_list {n} : computable (@vector.to_list α n) := primrec.vector_to_list.to_comp
theorem vector_length {n} : computable (@vector.length α n) := primrec.vector_length.to_comp
theorem vector_head {n} : computable (@vector.head α n) := primrec.vector_head.to_comp
theorem vector_tail {n} : computable (@vector.tail α n) := primrec.vector_tail.to_comp
theorem vector_nth {n} : computable₂ (@vector.nth α n) := primrec.vector_nth.to_comp
theorem vector_nth' {n} : computable (@vector.nth α n) := primrec.vector_nth'.to_comp
theorem vector_of_fn' {n} : computable (@vector.of_fn α n) := primrec.vector_of_fn'.to_comp

theorem fin_app {n} : computable₂ (@id (fin n → σ)) := primrec.fin_app.to_comp

protected theorem encode : computable (@encode α _) :=
primrec.encode.to_comp

protected theorem decode : computable (decode α) :=
primrec.decode.to_comp

protected theorem of_nat (α) [denumerable α] : computable (of_nat α) :=
(primrec.of_nat _).to_comp

theorem encode_iff {f : α → σ} : computable (λ a, encode (f a)) ↔ computable f :=
iff.rfl

theorem option_some : computable (@option.some α) :=
primrec.option_some.to_comp

end computable

namespace partrec
variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable σ]

open computable

theorem of_eq {f g : α →. σ} (hf : partrec f) (H : ∀ n, f n = g n) : partrec g :=
(funext H : f = g) ▸ hf

theorem of_eq_tot {f : α →. σ} {g : α → σ}
  (hf : partrec f) (H : ∀ n, g n ∈ f n) : computable g :=
hf.of_eq (λ a, eq_some_iff.2 (H a))

theorem none : partrec (λ a : α, @part.none σ) :=
nat.partrec.none.of_eq $ λ n, by cases decode α n; simp

protected theorem some : partrec (@part.some α) := computable.id

theorem _root_.decidable.partrec.const' (s : part σ) [decidable s.dom] : partrec (λ a : α, s) :=
(of_option (const (to_option s))).of_eq (λ a, of_to_option s)

theorem const' (s : part σ) : partrec (λ a : α, s) :=
by haveI := classical.dec s.dom; exact decidable.partrec.const' s

protected

theorem map {f : α →. β} {g : α → β → σ}
  (hf : partrec f) (hg : computable₂ g) : partrec (λ a, (f a).map (g a)) :=
by simpa [bind_some_eq_map] using
   @@partrec.bind _ _ _ (λ a b, part.some (g a b)) hf hg

theorem to₂ {f : α × β →. σ} (hf : partrec f) : partrec₂ (λ a b, f (a, b)) :=
hf.of_eq $ λ ⟨a, b⟩, rfl

theorem nat_elim
  {f : α → ℕ} {g : α →. σ} {h : α → ℕ × σ →. σ}
  (hf : computable f) (hg : partrec g) (hh : partrec₂ h) :
  partrec (λ a, (f a).elim (g a) (λ y IH, IH.bind (λ i, h a (y, i)))) :=
(nat.partrec.prec' hf hg hh).of_eq $ λ n, begin
  cases e : decode α n with a; simp [e],
  induction f a with m IH; simp,
  rw [IH, bind_map],
  congr, funext s,
  simp [encodek]
end

theorem comp {f : β →. σ} {g : α → β}
  (hf : partrec f) (hg : computable g) : partrec (λ a, f (g a)) :=
(hf.comp hg).of_eq $
λ n, by simp; cases e : decode α n with a;
  simp [e, encodek]

theorem nat_iff {f : ℕ →. ℕ} : partrec f ↔ nat.partrec f :=
by simp [partrec, map_id']

theorem map_encode_iff {f : α →. σ} : partrec (λ a, (f a).map encode) ↔ partrec f :=
iff.rfl

end partrec

namespace partrec₂
variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable δ] [primcodable σ]

theorem unpaired {f : ℕ → ℕ →. α} : partrec (nat.unpaired f) ↔ partrec₂ f :=
⟨λ h, by simpa using h.comp primrec₂.mkpair.to_comp,
 λ h, h.comp primrec.unpair.to_comp⟩

theorem unpaired' {f : ℕ → ℕ →. ℕ} : nat.partrec (nat.unpaired f) ↔ partrec₂ f :=
partrec.nat_iff.symm.trans unpaired

theorem comp
  {f : β → γ →. σ} {g : α → β} {h : α → γ}
  (hf : partrec₂ f) (hg : computable g) (hh : computable h) :
  partrec (λ a, f (g a) (h a)) := hf.comp (hg.pair hh)

theorem comp₂
  {f : γ → δ →. σ} {g : α → β → γ} {h : α → β → δ}
  (hf : partrec₂ f) (hg : computable₂ g) (hh : computable₂ h) :
  partrec₂ (λ a b, f (g a b) (h a b)) := hf.comp hg hh

end partrec₂

namespace computable
variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable σ]

theorem comp {f : β → σ} {g : α → β}
  (hf : computable f) (hg : computable g) :
  computable (λ a, f (g a)) := hf.comp hg

theorem comp₂ {f : γ → σ} {g : α → β → γ}
  (hf : computable f) (hg : computable₂ g) :
  computable₂ (λ a b, f (g a b)) := hf.comp hg

end computable

namespace computable₂
variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable δ] [primcodable σ]

theorem comp
  {f : β → γ → σ} {g : α → β} {h : α → γ}
  (hf : computable₂ f) (hg : computable g) (hh : computable h) :
  computable (λ a, f (g a) (h a)) := hf.comp (hg.pair hh)

theorem comp₂
  {f : γ → δ → σ} {g : α → β → γ} {h : α → β → δ}
  (hf : computable₂ f) (hg : computable₂ g) (hh : computable₂ h) :
  computable₂ (λ a b, f (g a b) (h a b)) := hf.comp hg hh

end computable₂

namespace partrec
variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable σ]

open computable

theorem rfind {p : α → ℕ →. bool} (hp : partrec₂ p) :
  partrec (λ a, nat.rfind (p a)) :=
(nat.partrec.rfind $ hp.map
  ((primrec.dom_bool (λ b, cond b 0 1))
    .comp primrec.snd).to₂.to_comp).of_eq $
λ n, begin
  cases e : decode α n with a;
    simp [e, nat.rfind_zero_none, map_id'],
  congr, funext n,
  simp [part.map_map, (∘)],
  apply map_id' (λ b, _),
  cases b; refl
end

theorem rfind_opt {f : α → ℕ → option σ} (hf : computable₂ f) :
  partrec (λ a, nat.rfind_opt (f a)) :=
(rfind (primrec.option_is_some.to_comp.comp hf).partrec.to₂).bind
  (of_option hf)

theorem nat_cases_right
  {f : α → ℕ} {g : α → σ} {h : α → ℕ →. σ}
  (hf : computable f) (hg : computable g) (hh : partrec₂ h) :
  partrec (λ a, (f a).cases (some (g a)) (h a)) :=
(nat_elim hf hg (hh.comp fst (pred.comp $ hf.comp fst)).to₂).of_eq $
λ a, begin
  simp, cases f a; simp,
  refine ext (λ b, ⟨λ H, _, λ H, _⟩),
  { rcases mem_bind_iff.1 H with ⟨c, h₁, h₂⟩, exact h₂ },
  { have : ∀ m, (nat.elim (part.some (g a))
      (λ y IH, IH.bind (λ _, h a n)) m).dom,
    { intro, induction m; simp [*, H.fst] },
    exact ⟨⟨this n, H.fst⟩, H.snd⟩ }
end

theorem bind_decode₂_iff {f : α →. σ} : partrec f ↔
  nat.partrec (λ n, part.bind (decode₂ α n) (λ a, (f a).map encode)) :=
⟨λ hf, nat_iff.1 $ (of_option primrec.decode₂.to_comp).bind $
  (map hf (computable.encode.comp snd).to₂).comp snd,
λ h, map_encode_iff.1 $ by simpa [encodek₂]
  using (nat_iff.2 h).comp (@computable.encode α _)⟩

theorem vector_m_of_fn : ∀ {n} {f : fin n → α →. σ}, (∀ i, partrec (f i)) →
  partrec (λ (a : α), vector.m_of_fn (λ i, f i a))
| 0     f hf := const _
| (n+1) f hf := by simp [vector.m_of_fn]; exact
  (hf 0).bind (partrec.bind ((vector_m_of_fn (λ i, hf i.succ)).comp fst)
    (primrec.vector_cons.to_comp.comp (snd.comp fst) snd))

end partrec

@[simp] theorem vector.m_of_fn_part_some {α n} : ∀ (f : fin n → α),
  vector.m_of_fn (λ i, part.some (f i)) = part.some (vector.of_fn f) :=
vector.m_of_fn_pure

namespace computable
variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable σ]

theorem option_some_iff {f : α → σ} : computable (λ a, some (f a)) ↔ computable f :=
⟨λ h, encode_iff.1 $ primrec.pred.to_comp.comp $ encode_iff.2 h,
 option_some.comp⟩

theorem bind_decode_iff {f : α → β → option σ} : computable₂ (λ a n,
  (decode β n).bind (f a)) ↔ computable₂ f :=
⟨λ hf, nat.partrec.of_eq
    (((partrec.nat_iff.2 (nat.partrec.ppred.comp $
        nat.partrec.of_primrec $ primcodable.prim β)).comp snd).bind
      (computable.comp hf fst).to₂.partrec₂) $
  λ n, by simp;
    cases decode α n.unpair.1; simp;
    cases decode β n.unpair.2; simp,
λ hf, begin
  have : partrec (λ a : α × ℕ, (encode (decode β a.2)).cases
    (some option.none) (λ n, part.map (f a.1) (decode β n))) :=
  partrec.nat_cases_right (primrec.encdec.to_comp.comp snd)
    (const none) ((of_option (computable.decode.comp snd)).map
      (hf.comp (fst.comp $ fst.comp fst) snd).to₂),
  refine this.of_eq (λ a, _),
  simp, cases decode β a.2; simp [encodek]
end⟩

theorem map_decode_iff {f : α → β → σ} : computable₂ (λ a n,
  (decode β n).map (f a)) ↔ computable₂ f :=
bind_decode_iff.trans option_some_iff

theorem nat_elim
  {f : α → ℕ} {g : α → σ} {h : α → ℕ × σ → σ}
  (hf : computable f) (hg : computable g) (hh : computable₂ h) :
  computable (λ a, (f a).elim (g a) (λ y IH, h a (y, IH))) :=
(partrec.nat_elim hf hg hh.partrec₂).of_eq $
λ a, by simp; induction f a; simp *

theorem nat_cases {f : α → ℕ} {g : α → σ} {h : α → ℕ → σ}
  (hf : computable f) (hg : computable g) (hh : computable₂ h) :
  computable (λ a, (f a).cases (g a) (h a)) :=
nat_elim hf hg (hh.comp fst $ fst.comp snd).to₂

theorem cond {c : α → bool} {f : α → σ} {g : α → σ}
  (hc : computable c) (hf : computable f) (hg : computable g) :
  computable (λ a, cond (c a) (f a) (g a)) :=
(nat_cases (encode_iff.2 hc) hg (hf.comp fst).to₂).of_eq $
λ a, by cases c a; refl

theorem option_cases {o : α → option β} {f : α → σ} {g : α → β → σ}
  (ho : computable o) (hf : computable f) (hg : computable₂ g) :
  @computable _ σ _ _ (λ a, option.cases_on (o a) (f a) (g a)) :=
option_some_iff.1 $
(nat_cases (encode_iff.2 ho) (option_some_iff.2 hf)
    (map_decode_iff.2 hg)).of_eq $
λ a, by cases o a; simp [encodek]; refl

theorem option_bind {f : α → option β} {g : α → β → option σ}
  (hf : computable f) (hg : computable₂ g) :
  computable (λ a, (f a).bind (g a)) :=
(option_cases hf (const option.none) hg).of_eq $
λ a, by cases f a; refl

theorem option_map {f : α → option β} {g : α → β → σ}
  (hf : computable f) (hg : computable₂ g) : computable (λ a, (f a).map (g a)) :=
option_bind hf (option_some.comp₂ hg)

theorem option_get_or_else {f : α → option β} {g : α → β}
  (hf : computable f) (hg : computable g) :
  computable (λ a, (f a).get_or_else (g a)) :=
(computable.option_cases hf hg (show computable₂ (λ a b, b), from computable.snd)).of_eq $
λ a, by cases f a; refl

theorem subtype_mk {f : α → β} {p : β → Prop} [decidable_pred p] {h : ∀ a, p (f a)}
    (hp : primrec_pred p) (hf : computable f) :
  @computable _ _ _ (primcodable.subtype hp) (λ a, (⟨f a, h a⟩ : subtype p)) :=
hf

theorem sum_cases
  {f : α → β ⊕ γ} {g : α → β → σ} {h : α → γ → σ}
  (hf : computable f) (hg : computable₂ g) (hh : computable₂ h) :
  @computable _ σ _ _ (λ a, sum.cases_on (f a) (g a) (h a)) :=
option_some_iff.1 $
(cond (nat_bodd.comp $ encode_iff.2 hf)
  (option_map (computable.decode.comp $ nat_div2.comp $ encode_iff.2 hf) hh)
  (option_map (computable.decode.comp $ nat_div2.comp $ encode_iff.2 hf) hg)).of_eq $
λ a, by cases f a with b c;
  simp [nat.div2_bit, nat.bodd_bit, encodek]; refl

theorem nat_strong_rec
  (f : α → ℕ → σ) {g : α → list σ → option σ} (hg : computable₂ g)
  (H : ∀ a n, g a ((list.range n).map (f a)) = some (f a n)) : computable₂ f :=
suffices computable₂ (λ a n, (list.range n).map (f a)), from
  option_some_iff.1 $
  (list_nth.comp (this.comp fst (succ.comp snd)) snd).to₂.of_eq $
  λ a, by simp [list.nth_range (nat.lt_succ_self a.2)]; refl,
option_some_iff.1 $
(nat_elim snd (const (option.some [])) (to₂ $
  option_bind (snd.comp snd) $ to₂ $
  option_map
    (hg.comp (fst.comp $ fst.comp fst) snd)
    (to₂ $ list_concat.comp (snd.comp fst) snd))).of_eq $
λ a, begin
  simp, induction a.2 with n IH, {refl},
  simp [IH, H, list.range_succ]
end

theorem list_of_fn : ∀ {n} {f : fin n → α → σ},
  (∀ i, computable (f i)) → computable (λ a, list.of_fn (λ i, f i a))
| 0     f hf := const []
| (n+1) f hf := by simp [list.of_fn_succ]; exact
  list_cons.comp (hf 0) (list_of_fn (λ i, hf i.succ))

theorem vector_of_fn {n} {f : fin n → α → σ}
  (hf : ∀ i, computable (f i)) : computable (λ a, vector.of_fn (λ i, f i a)) :=
(partrec.vector_m_of_fn hf).of_eq $ λ a, by simp

end computable

namespace partrec
variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable σ]

open computable

theorem option_some_iff {f : α →. σ} :
  partrec (λ a, (f a).map option.some) ↔ partrec f :=
⟨λ h, (nat.partrec.ppred.comp h).of_eq $
   λ n, by simp [part.bind_assoc, bind_some_eq_map],
 λ hf, hf.map (option_some.comp snd).to₂⟩

theorem option_cases_right {o : α → option β} {f : α → σ} {g : α → β →. σ}
  (ho : computable o) (hf : computable f) (hg : partrec₂ g) :
  @partrec _ σ _ _ (λ a, option.cases_on (o a) (some (f a)) (g a)) :=
have partrec (λ (a : α), nat.cases (part.some (f a))
  (λ n, part.bind (decode β n) (g a)) (encode (o a))) :=
nat_cases_right (encode_iff.2 ho) hf.partrec $
  ((@computable.decode β _).comp snd).of_option.bind
    (hg.comp (fst.comp fst) snd).to₂,
this.of_eq $ λ a, by cases o a with b; simp [encodek]

theorem sum_cases_right {f : α → β ⊕ γ} {g : α → β → σ} {h : α → γ →. σ}
  (hf : computable f) (hg : computable₂ g) (hh : partrec₂ h) :
  @partrec _ σ _ _ (λ a, sum.cases_on (f a) (λ b, some (g a b)) (h a)) :=
have partrec (λ a, (option.cases_on
  (sum.cases_on (f a) (λ b, option.none) option.some : option γ)
  (some (sum.cases_on (f a) (λ b, some (g a b))
     (λ c, option.none)))
  (λ c, (h a c).map option.some) : part (option σ))) :=
option_cases_right
  (sum_cases hf (const option.none).to₂ (option_some.comp snd).to₂)
  (sum_cases hf (option_some.comp hg) (const option.none).to₂)
  (option_some_iff.2 hh),
option_some_iff.1 $ this.of_eq $ λ a, by cases f a; simp

theorem sum_cases_left {f : α → β ⊕ γ} {g : α → β →. σ} {h : α → γ → σ}
  (hf : computable f) (hg : partrec₂ g) (hh : computable₂ h) :
  @partrec _ σ _ _ (λ a, sum.cases_on (f a) (g a) (λ c, some (h a c))) :=
(sum_cases_right (sum_cases hf
  (sum_inr.comp snd).to₂ (sum_inl.comp snd).to₂) hh hg).of_eq $
λ a, by cases f a; simp

lemma fix_aux {α σ} (f : α →. σ ⊕ α) (a : α) (b : σ) :
  let F : α → ℕ →. σ ⊕ α := λ a n,
    n.elim (some (sum.inr a)) $ λ y IH, IH.bind $ λ s,
    sum.cases_on s (λ _, part.some s) f in
  (∃ (n : ℕ), ((∃ (b' : σ), sum.inl b' ∈ F a n) ∧
        ∀ {m : ℕ}, m < n → (∃ (b : α), sum.inr b ∈ F a m)) ∧
      sum.inl b ∈ F a n) ↔ b ∈ pfun.fix f a :=
begin
  intro, refine ⟨λ h, _, λ h, _⟩,
  { rcases h with ⟨n, ⟨_x, h₁⟩, h₂⟩,
    have : ∀ m a' (_: sum.inr a' ∈ F a m)
      (_: b ∈ pfun.fix f a'), b ∈ pfun.fix f a,
    { intros m a' am ba,
      induction m with m IH generalizing a'; simp [F] at am,
      { rwa ← am },
      rcases am with ⟨a₂, am₂, fa₂⟩,
      exact IH _ am₂ (pfun.mem_fix_iff.2 (or.inr ⟨_, fa₂, ba⟩)) },
    cases n; simp [F] at h₂, {cases h₂},
    rcases h₂ with h₂ | ⟨a', am', fa'⟩,
    { cases h₁ (nat.lt_succ_self _) with a' h,
      injection mem_unique h h₂ },
    { exact this _ _ am' (pfun.mem_fix_iff.2 (or.inl fa')) } },
  { suffices : ∀ a' (_: b ∈ pfun.fix f a') k (_: sum.inr a' ∈ F a k),
       ∃ n, sum.inl b ∈ F a n ∧
         ∀ (m < n) (_ : k ≤ m), ∃ a₂, sum.inr a₂ ∈ F a m,
    { rcases this _ h 0 (by simp [F]) with ⟨n, hn₁, hn₂⟩,
      exact ⟨_, ⟨⟨_, hn₁⟩, λ m mn, hn₂ m mn (nat.zero_le _)⟩, hn₁⟩ },
    intros a₁ h₁,
    apply pfun.fix_induction h₁, intros a₂ h₂ IH k hk,
    rcases pfun.mem_fix_iff.1 h₂ with h₂ | ⟨a₃, am₃, fa₃⟩,
    { refine ⟨k.succ, _, λ m mk km, ⟨a₂, _⟩⟩,
      { simp [F], exact or.inr ⟨_, hk, h₂⟩ },
      { rwa le_antisymm (nat.le_of_lt_succ mk) km } },
    { rcases IH _ am₃ k.succ _ with ⟨n, hn₁, hn₂⟩,
      { refine ⟨n, hn₁, λ m mn km, _⟩,
        cases km.lt_or_eq_dec with km km,
        { exact hn₂ _ mn km },
        { exact km ▸ ⟨_, hk⟩ } },
      { simp [F], exact ⟨_, hk, am₃⟩ } } }
end

theorem fix {f : α →. σ ⊕ α} (hf : partrec f) : partrec (pfun.fix f) :=
let F : α → ℕ →. σ ⊕ α := λ a n,
  n.elim (some (sum.inr a)) $ λ y IH, IH.bind $ λ s,
  sum.cases_on s (λ _, part.some s) f in
have hF : partrec₂ F :=
partrec.nat_elim snd (sum_inr.comp fst).partrec
  (sum_cases_right (snd.comp snd)
    (snd.comp $ snd.comp fst).to₂
    (hf.comp snd).to₂).to₂,
let p := λ a n, @part.map _ bool
  (λ s, sum.cases_on s (λ_, tt) (λ _, ff)) (F a n) in
have hp : partrec₂ p := hF.map ((sum_cases computable.id
  (const tt).to₂ (const ff).to₂).comp snd).to₂,
(hp.rfind.bind (hF.bind
  (sum_cases_right snd snd.to₂ none.to₂).to₂).to₂).of_eq $
λ a, ext $ λ b, by simp; apply fix_aux f

end partrec


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison

! This file was ported from Lean 3 source module topology.sheaves.sheafify
! leanprover-community/mathlib commit bb103f356534a9a7d3596a672097e375290a4c3a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Sheaves.LocalPredicate
import Mathbin.Topology.Sheaves.Stalks

/-!
# Sheafification of `Type` valued presheaves

We construct the sheafification of a `Type` valued presheaf,
as the subsheaf of dependent functions into the stalks
consisting of functions which are locally germs.

We show that the stalks of the sheafification are isomorphic to the original stalks,
via `stalk_to_fiber` which evaluates a germ of a dependent function at a point.

We construct a morphism `to_sheafify` from a presheaf to (the underlying presheaf of)
its sheafification, given by sending a section to its collection of germs.

## Future work
Show that the map induced on stalks by `to_sheafify` is the inverse of `stalk_to_fiber`.

Show sheafification is a functor from presheaves to sheaves,
and that it is the left adjoint of the forgetful functor,
following <https://stacks.math.columbia.edu/tag/007X>.
-/

universe v

noncomputable section

open TopCat

open Opposite

open TopologicalSpace

variable {X : TopCat.{v}} (F : Presheaf (Type v) X)

namespace TopCat.Presheaf

namespace Sheafify

/--
The prelocal predicate on functions into the stalks, asserting that the function is equal to a germ.
-/
def isGerm : PrelocalPredicate fun x => F.stalk x
    where
  pred U f := ∃ g : F.obj (op U), ∀ x : U, f x = F.germ x g
  res := fun V U i f ⟨g, p⟩ =>
    ⟨F.map i.op g, fun x => (p (i x)).trans (F.germ_res_apply _ _ _).symm⟩
#align Top.presheaf.sheafify.is_germ TopCat.Presheaf.Sheafify.isGerm

/-- The local predicate on functions into the stalks,
asserting that the function is locally equal to a germ.
-/
def isLocallyGerm : LocalPredicate fun x => F.stalk x :=
  (isGerm F).sheafify
#align Top.presheaf.sheafify.is_locally_germ TopCat.Presheaf.Sheafify.isLocallyGerm

end Sheafify

/-- The sheafification of a `Type` valued presheaf, defined as the functions into the stalks which
are locally equal to germs.
-/
def sheafify : Sheaf (Type v) X :=
  subsheafToTypes (Sheafify.isLocallyGerm F)
#align Top.presheaf.sheafify TopCat.Presheaf.sheafify

/-- The morphism from a presheaf to its sheafification,
sending each section to its germs.
(This forms the unit of the adjunction.)
-/
def toSheafify : F ⟶ F.sheafify.1
    where
  app U f := ⟨fun x => F.germ x f, PrelocalPredicate.sheafify_of ⟨f, fun x => rfl⟩⟩
  naturality' U U' f := by
    ext (x⟨u, m⟩)
    exact germ_res_apply F f.unop ⟨u, m⟩ x
#align Top.presheaf.to_sheafify TopCat.Presheaf.toSheafify

/-- The natural morphism from the stalk of the sheafification to the original stalk.
In `sheafify_stalk_iso` we show this is an isomorphism.
-/
def stalkToFiber (x : X) : F.sheafify.Presheaf.stalk x ⟶ F.stalk x :=
  stalkToFiber (Sheafify.isLocallyGerm F) x
#align Top.presheaf.stalk_to_fiber TopCat.Presheaf.stalkToFiber

theorem stalkToFiber_surjective (x : X) : Function.Surjective (F.stalkToFiber x) :=
  by
  apply stalk_to_fiber_surjective
  intro t
  obtain ⟨U, m, s, rfl⟩ := F.germ_exist _ t
  · use ⟨U, m⟩
    fconstructor
    · exact fun y => F.germ y s
    · exact ⟨prelocal_predicate.sheafify_of ⟨s, fun _ => rfl⟩, rfl⟩
#align Top.presheaf.stalk_to_fiber_surjective TopCat.Presheaf.stalkToFiber_surjective

theorem stalkToFiber_injective (x : X) : Function.Injective (F.stalkToFiber x) :=
  by
  apply stalk_to_fiber_injective
  intros
  rcases hU ⟨x, U.2⟩ with ⟨U', mU, iU, gU, wU⟩
  rcases hV ⟨x, V.2⟩ with ⟨V', mV, iV, gV, wV⟩
  have wUx := wU ⟨x, mU⟩
  dsimp at wUx; erw [wUx] at e; clear wUx
  have wVx := wV ⟨x, mV⟩
  dsimp at wVx; erw [wVx] at e; clear wVx
  rcases F.germ_eq x mU mV gU gV e with ⟨W, mW, iU', iV', e'⟩
  dsimp at e'
  use ⟨W ⊓ (U' ⊓ V'), ⟨mW, mU, mV⟩⟩
  refine' ⟨_, _, _⟩
  · change W ⊓ (U' ⊓ V') ⟶ U.obj
    exact opens.inf_le_right _ _ ≫ opens.inf_le_left _ _ ≫ iU
  · change W ⊓ (U' ⊓ V') ⟶ V.obj
    exact opens.inf_le_right _ _ ≫ opens.inf_le_right _ _ ≫ iV
  · intro w
    dsimp
    specialize wU ⟨w.1, w.2.2.1⟩
    dsimp at wU
    specialize wV ⟨w.1, w.2.2.2⟩
    dsimp at wV
    erw [wU, ← F.germ_res iU' ⟨w, w.2.1⟩, wV, ← F.germ_res iV' ⟨w, w.2.1⟩,
      CategoryTheory.types_comp_apply, CategoryTheory.types_comp_apply, e']
#align Top.presheaf.stalk_to_fiber_injective TopCat.Presheaf.stalkToFiber_injective

/-- The isomorphism betweeen a stalk of the sheafification and the original stalk.
-/
def sheafifyStalkIso (x : X) : F.sheafify.Presheaf.stalk x ≅ F.stalk x :=
  (Equiv.ofBijective _ ⟨stalkToFiber_injective _ _, stalkToFiber_surjective _ _⟩).toIso
#align Top.presheaf.sheafify_stalk_iso TopCat.Presheaf.sheafifyStalkIso

-- PROJECT functoriality, and that sheafification is the left adjoint of the forgetful functor.
end TopCat.Presheaf


import algebra.comm_rings.basic

namespace comm_ring

universes u v

structure mul_closed_set (R : Type u) [comm_ring R] : Type u :=
  (body : set R)
  (contains_one : (1:R) ∈ body)
  (mul_closed : ∀ s₁ s₂, s₁ ∈ body → s₂ ∈ body → (s₁ * s₂) ∈ body)

instance mul_closed_set_coe (R : Type u) [comm_ring R] : has_coe (mul_closed_set R) (set R)
  := ⟨λ S, S.body⟩

structure mcs_type {R: Type u} [comm_ring R] (S : mul_closed_set R) : Type u :=
  (val : R)
  (property : val ∈ S.body)

instance mcs_as_type {R: Type u} [comm_ring R]
  : has_coe_to_sort (mul_closed_set R) (Type u) := ⟨mcs_type⟩

instance mcs_val {R: Type u} [comm_ring R] {S: mul_closed_set R} : has_coe S R := ⟨λ s : S, s.val⟩

def mcs_mul {R: Type u} [comm_ring R] {S: mul_closed_set R} : S → S → S :=
begin
  intros s₁ s₂,
  split,
  apply S.mul_closed,
  exact s₁.property,
  exact s₂.property,
end

instance mcs_has_mul {R: Type u} [comm_ring R] {S: mul_closed_set R} : has_mul S := ⟨mcs_mul⟩

@[simp]
lemma mcs_mul_coe {R: Type u} [comm_ring R] {S: mul_closed_set R} : ∀ s₁ s₂ : S, ↑(s₁ * s₂) = (↑s₁) * (↑s₂ :R) := λ _ _,rfl

def equal_as_fractions {R: Type u} [comm_ring R] (S: mul_closed_set R) : R × S → R × S → Prop :=
  λ  p₁ p₂,  ∃ (s : S), ↑s * (p₁.1 * p₂.2 + -(p₂.1 * p₁.2)) = 0

lemma equal_as_fractions_refl {R: Type u} [comm_ring R] (S: mul_closed_set R) : ∀ f : R × S, equal_as_fractions S f f :=
begin
  intro f,
  existsi (⟨(1:R),S.contains_one⟩ : S),
  rw [minus_inverse,mul_zero],
end

lemma equal_as_fractions_symm {R: Type u} [comm_ring R] (S : mul_closed_set R)
  : ∀ f g : R × S, equal_as_fractions S f g → equal_as_fractions S g f :=
begin
  intros f g hfg,
  cases hfg with s hs,
  existsi s,
  rw [← minus_minus (g.fst * ↑f.snd),← minus_dis,add_comm],
  rw [mul_comm,← minus_mul,mul_comm,hs,minus_zero_zero],
end

lemma equal_as_fractions_trans {R: Type u} [comm_ring R] (S : mul_closed_set R)
  : ∀ f₁ f₂ f₃ : R × S, equal_as_fractions S f₁ f₂ → equal_as_fractions S f₂ f₃ → equal_as_fractions S f₁ f₃ :=
begin
  intros f₁ f₂ f₃ hf₁f₂ hf₂f₃,
  cases f₁ with r₁ s₁,
  cases f₂ with r₂ s₂,
  cases f₃ with r₃ s₃,
  cases hf₁f₂ with s₁₂ hs₁₂,
  simp at hs₁₂,
  cases hf₂f₃ with s₂₃ hs₂₃,
  simp at hs₂₃,
  existsi s₁₂ * s₂₃ * s₂,
  simp,
  have hrw : ↑((s₁₂ * s₂₃) * s₃) * (r₁ * s₂ + - r₂ * s₁) + ↑ ((s₁₂ * s₂₃) * s₁) * (r₂ * s₃ + - r₃ * s₂) =
      ↑s₁₂ * ↑s₂₃ * ↑s₂ * (r₁ * ↑s₃ + - (r₃ * ↑s₁)),
    simp,
    let α : R := ↑s₁₂ * ↑s₂₃,
    have trv : ↑s₁₂ * ↑s₂₃ = α := rfl,
    rw trv,
    have hrw₁ : α * ↑s₃ * (r₁ * ↑s₂ + - r₂ * ↑s₁) = (α * ↑s₂) * (r₁ * ↑s₃) + -r₂ * (α * s₃ * s₁),
      rw mul_comm (-r₂) (α * ↑s₃ * ↑s₁),
      rw [← mul_assoc α,← mul_assoc α,← mul_assoc α,← mul_assoc α],
      rw ← mul_dis α ,
      rw [mul_assoc ↑s₂, mul_comm (↑s₂ * r₁)],
      rw [← mul_assoc ↑s₃ ↑s₁,← mul_dis ↑s₃],
      simp [mul_comm],
    have hrw₂ : α * ↑s₁ * (r₂ * ↑s₃ + - r₃ * ↑s₂) = r₂ * (α * s₃ * s₁) + - (α * ↑s₂) * (r₃ * ↑s₁),
      rw mul_comm r₂ (α * s₃ * s₁),
      rw [mul_comm α s₂,minus_mul,mul_comm (-↑s₂) α],
      rw [← mul_assoc α,← mul_assoc α,← mul_assoc α,← mul_assoc α],
      rw ← mul_dis α,
      rw [mul_assoc (-↑s₂), mul_comm ((-↑s₂) * r₃)],
      rw [mul_comm ↑s₃ ↑s₁, ← mul_assoc ↑s₁,← mul_dis ↑s₁],
      rw [← minus_mul,← minus_mul],
      simp [mul_comm],
    rw [hrw₁,hrw₂],
    rw [← minus_mul,← minus_mul],
    let β₁: R := α * ↑s₂ * (r₁ * ↑s₃),
    have hβ₁ : α * ↑s₂ * (r₁ * ↑s₃) = β₁ := rfl,
    let β₂ : R := r₂ * (α * ↑s₃ * ↑s₁),
    have hβ₂ : r₂ * (α * ↑s₃ * ↑s₁) = β₂ := rfl,
    let β₃ : R := α * ↑s₂ * (r₃ * ↑s₁),
    have hβ₃ : α * ↑s₂ * (r₃ * ↑s₁) = β₃ := rfl,
    rw [hβ₁,hβ₂,hβ₃],
    have hrw₃ : β₁ + -β₂ + (β₂ + -β₃) = β₁ + (-β₂ + β₂) + -β₃,
      simp [add_assoc],
    rw hrw₃,
    rw [add_comm (-β₂),minus_inverse, add_zero],
    rw mul_dis,
    rw [hβ₁, mul_comm (α * ↑s₂), ← minus_mul, mul_comm (r₃ * ↑s₁)],
  rw ← hrw,
  rw [← minus_mul, ← minus_mul],
  let δ₁₂ := r₁ * ↑s₂ + -(r₂ * ↑s₁),
  have hδ₁₂ : r₁ * ↑s₂ + -(r₂ * ↑s₁) = δ₁₂ := rfl,
  let δ₂₃ := r₂ * ↑s₃ + - (r₃ * ↑s₂),
  have hδ₂₃ : r₂ * ↑s₃ + - (r₃ * ↑s₂) = δ₂₃ := rfl,
  rw [hδ₁₂,hδ₂₃],
  rw hδ₁₂ at hs₁₂,
  rw hδ₂₃ at hs₂₃,
  simp,
  clear hrw hδ₁₂ hδ₂₃,
  have hz₁ : ↑s₁₂ * ↑s₂₃ * ↑s₁ * δ₂₃ = 0,
    rw mul_comm ↑s₁₂,
    rw mul_comm,
    rw mul_assoc,
    rw mul_assoc,
    rw mul_comm δ₂₃,
    rw hs₂₃,
    repeat {
      rw mul_comm (0:R),
      rw mul_zero,
    },
  have hz₂ : ↑s₁₂ * ↑s₂₃ * ↑s₃ * δ₁₂ = 0,
    rw ←mul_assoc,
    rw ← mul_assoc,
    rw mul_comm ↑s₁₂,
    rw ← mul_assoc,
    rw ← mul_assoc,
    rw mul_comm δ₁₂,
    rw hs₁₂,
    simp [mul_zero],
  rw [hz₁,hz₂,add_zero],
end

instance fraction_setoid (R : Type u) [comm_ring R] (S : mul_closed_set R) : setoid (R × S)
  := ⟨equal_as_fractions S, equal_as_fractions_refl S, equal_as_fractions_symm S, equal_as_fractions_trans S⟩

def localisation (R : Type u) [comm_ring R] (S : mul_closed_set R) := quotient (comm_ring.fraction_setoid R S)

notation R `[`S `⁻¹]` := localisation R S

def localisation_pre_add {R : Type u} [comm_ring R] (S : mul_closed_set R) : R × S → R × S → R[S⁻¹]
  | (x₁,s₁) (x₂,s₂) := ⟦(x₁ * s₂ + x₂ * s₁, s₁ * s₂)⟧

theorem localisation_pre_add_lifts {R : Type u} [comm_ring R] (S : mul_closed_set R)
  : ∀ a₁ a₂ b₁ b₂ : R × S, a₁ ≈ b₁ → a₂ ≈ b₂ → localisation_pre_add S a₁ a₂ = localisation_pre_add S b₁ b₂ :=
begin
  intros a₁ a₂ b₁ b₂ h₁ h₂,
  cases a₁ with ax₁ as₁,
  cases a₂ with ax₂ as₂,
  cases b₁ with bx₁ bs₁,
  cases b₂ with bx₂ bs₂,
  simp [localisation_pre_add],
  apply quotient.sound,
  cases h₁ with s₁ hs₁,
  cases h₂ with s₂ hs₂,
  simp at hs₁,
  simp at hs₂,
  let s := s₁ * s₂,
  have hs : ↑s = ↑s₁ * ↑s₂,
    simp[s],
    rw mcs_mul_coe,
  let as := as₁ * as₂,
  have has : ↑as = ↑as₁ * ↑as₂,
    simp[as],
  let bs := bs₁ * bs₂,
  have hbs : ↑bs = ↑bs₁ * ↑bs₂,
    simp[bs],
  have v₁ : ↑s * (ax₁ * bs₁ + -(bx₁ * as₁)) = 0,
    simp [s],
    rw mul_comm (↑s₁ : R) s₂,
    rw [← mul_assoc, hs₁, mul_zero],
  have v₂ : ↑s * (ax₂ * bs₂ + -(bx₂ * as₂)) = 0,
    simp [s],
    rw [← mul_assoc, hs₂, mul_zero],
  existsi s,
  simp,
  rw ← hs,
  have sub₁ : (ax₁ * as₂ + ax₂ * as₁) * (↑bs₁ * ↑bs₂) = (ax₁ * bs₁) * bs +

end

end comm_ring


import temporal_logic.basic

universe variables u u₀ u₁ u₂

namespace temporal
open predicate

section pair

variables {α : Type u} {β : Type u₀} {γ : Type u₁} {ω : Type u₂}
variables (x : tvar α) (y : tvar β) (z : tvar γ)

@[tl_simp, simp]
lemma pair_model (i : ℕ) :
i ⊨ ⦃x,y⦄ = (i ⊨ x,i ⊨ y) :=
by { cases x, cases y, refl }

@[reducible]
def pair.fst : var (α × β) α :=
⟨ @prod.fst α β ⟩

@[reducible]
def pair.snd : var (α × β) β :=
⟨ @prod.snd α β ⟩

abbreviation tvar.fst (p : var γ (α × β)) : var γ α :=
pair.fst!p

abbreviation tvar.snd (p : var γ (α × β)) : var γ β :=
pair.snd!p

@[tl_simp, simp]
def pair.fst_mk (x : tvar α) (y : tvar β)
: pair.fst ! ⦃x,y⦄ = x :=
by lifted_pred

@[tl_simp, simp]
def pair.fst_mk' (x : tvar α) (y : tvar β)
: ⟨ @prod.fst α β ⟩ ! ⦃x,y⦄ = x :=
pair.fst_mk _ _

@[tl_simp, simp]
def pair.snd_mk (x : tvar α) (y : tvar β)
: pair.snd ! ⦃x,y⦄ = y :=
by lifted_pred

@[tl_simp, simp]
def pair.snd_mk' (x : tvar α) (y : tvar β)
: ⟨ @prod.snd α β ⟩ ! ⦃x,y⦄ = y :=
by lifted_pred

@[tl_simp, simp]
def prod.map_left {α β γ} (f : α → β) : α × γ → β × γ
 | (x,y) := (f x, y)

@[tl_simp, simp]
def prod.map_right {α β γ} (f : β → γ) : α × β → α × γ
 | (x,y) := (x,f y)
open temporal.prod

@[tl_simp, simp]
lemma map_right_proj_pair (f : β → γ)
: ⟨map_right f⟩ ! ⦃x,y⦄ = ⦃x, ⟨f⟩ ! y⦄ :=
by ext i ; simp [map_right] with tl_simp

@[tl_simp, simp]
lemma map_left_proj_pair (f : α → γ)
: ⟨map_left f⟩ ! ⦃x,y⦄ = ⦃⟨f⟩ ! x, y⦄ :=
by ext i ; simp [map_left] with tl_simp

@[tl_simp, simp]
lemma map_proj_pair (f : α → γ) (g : β → ω)
: ⟨prod.map f g⟩ ! ⦃x,y⦄ = ⦃⟨f⟩ ! x,⟨g⟩ ! y⦄ :=
by ext i ; simp [prod.map] with tl_simp

@[tl_simp, simp]
lemma eta_pair (w : tvar (α × β))
: ⦃w.fst, w.snd⦄ = w :=
by ext i ; simp [prod.map] with tl_simp

@[tl_simp, simp]
lemma next_pair (v₀ : tvar α) (v₁ : tvar β)
: ⊙⦃v₀,v₁⦄ = ⦃⊙v₀,⊙v₁⦄ :=
by lifted_pred [next]

@[tl_simp, simp, predicate]
lemma to_fun_var_pair (f : tvar α → tvar β) (g : tvar α → tvar γ) (w : tvar α)
: to_fun_var (λ w : tvar α, ⦃f w,g w⦄) w = ⦃to_fun_var f w,to_fun_var g w⦄ :=
by { lifted_pred, simp! }

end pair

end temporal


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.limits.preserves.basic

/-!
# Isomorphisms about functors which preserve (co)limits

If `G` preserves limits, and `C` and `D` have limits, then for any diagram `F : J ⥤ C` we have a
canonical isomorphism `preserves_limit_iso : G.obj (limit F) ≅ limit (F ⋙ G)`.
We also show that we can commute `is_limit.lift` of a preserved limit with `functor.map_cone`:
`(preserves_limit.preserves t).lift (G.map_cone c₂) = G.map (t.lift c₂)`.

The duals of these are also given. For functors which preserve (co)limits of specific shapes, see
`preserves/shapes.lean`.
-/

universes v u₁ u₂

noncomputable theory

namespace category_theory

open category limits

variables {C : Type u₁} [category.{v} C]
variables {D : Type u₂} [category.{v} D]
variables (G : C ⥤ D)
variables {J : Type v} [small_category J]
variables (F : J ⥤ C)

section
variables [preserves_limit F G]

@[simp]
lemma preserves_lift_map_cone (c₁ c₂ : cone F) (t : is_limit c₁) :
  (preserves_limit.preserves t).lift (G.map_cone c₂) = G.map (t.lift c₂) :=
((preserves_limit.preserves t).uniq (G.map_cone c₂) _ (by simp [← G.map_comp])).symm

variables [has_limit F] [has_limit (F ⋙ G)]
/--
If `G` preserves limits, we have an isomorphism from the image of the limit of a functor `F`
to the limit of the functor `F ⋙ G`.
-/
def preserves_limit_iso : G.obj (limit F) ≅ limit (F ⋙ G) :=
(preserves_limit.preserves (limit.is_limit _)).cone_point_unique_up_to_iso (limit.is_limit _)

@[simp, reassoc]
lemma preserves_limits_iso_hom_π (j) :
  (preserves_limit_iso G F).hom ≫ limit.π _ j = G.map (limit.π F j) :=
is_limit.cone_point_unique_up_to_iso_hom_comp _ _ j

@[simp, reassoc]
lemma preserves_limits_iso_inv_π (j) :
  (preserves_limit_iso G F).inv ≫ G.map (limit.π F j) = limit.π _ j :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ j

@[simp, reassoc]
lemma lift_comp_preserves_limits_iso_hom (t : cone F) :
  G.map (limit.lift _ t) ≫ (preserves_limit_iso G F).hom = limit.lift (F ⋙ G) (G.map_cone _) :=
by { ext, simp [← G.map_comp] }
end

section
variables [preserves_colimit F G]

@[simp]
lemma preserves_desc_map_cocone (c₁ c₂ : cocone F) (t : is_colimit c₁) :
  (preserves_colimit.preserves t).desc (G.map_cocone _) = G.map (t.desc c₂) :=
((preserves_colimit.preserves t).uniq (G.map_cocone _) _ (by simp [← G.map_comp])).symm

variables [has_colimit F] [has_colimit (F ⋙ G)]
/--
If `G` preserves colimits, we have an isomorphism from the image of the colimit of a functor `F`
to the colimit of the functor `F ⋙ G`.
-/
-- TODO: think about swapping the order here
def preserves_colimit_iso : G.obj (colimit F) ≅ colimit (F ⋙ G) :=
(preserves_colimit.preserves (colimit.is_colimit _)).cocone_point_unique_up_to_iso
  (colimit.is_colimit _)

@[simp, reassoc]
lemma ι_preserves_colimits_iso_inv (j : J) :
  colimit.ι _ j ≫ (preserves_colimit_iso G F).inv = G.map (colimit.ι F j) :=
is_colimit.comp_cocone_point_unique_up_to_iso_inv _ (colimit.is_colimit (F ⋙ G)) j

@[simp, reassoc]
lemma ι_preserves_colimits_iso_hom (j : J) :
  G.map (colimit.ι F j) ≫ (preserves_colimit_iso G F).hom = colimit.ι (F ⋙ G) j :=
(preserves_colimit.preserves (colimit.is_colimit _)).comp_cocone_point_unique_up_to_iso_hom _ j

@[simp, reassoc]
lemma preserves_colimits_iso_inv_comp_desc (t : cocone F) :
  (preserves_colimit_iso G F).inv ≫ G.map (colimit.desc _ t) = colimit.desc _ (G.map_cocone t) :=
by { ext, simp [← G.map_comp] }
end

end category_theory


import data.fintype.basic
import data.finset
import tactic
import finset_extra

noncomputable theory
open_locale classical
open set

universes u v

def size {γ : Type u} (X: set γ) := (sorry : ℤ) -- need to fix this to actually be the size

lemma finsize {γ : Type u} {hfin: fintype γ} (X: set γ) : size X = (fintype.card ↥X : ℤ) := sorry

structure matroid_on (γ : Type u)[fintype γ]  :=

(r : set γ → ℤ)
(R1l : ∀ (X : set γ), 0 ≤ r X)
(R1u : ∀ (X:  set γ), r X ≤ size X)
(R2 : ∀ {X Y : set γ}, X ⊆ Y → r X ≤ r Y)
(R3 : ∀ (X Y : set γ), r (X ∪ Y) + r (X ∩ Y) ≤ r X + r Y)

class matroids (α : Type v)  :=
(type_map : α → Σ (γ : Type u), fintype γ)
(to_matroid : Π (M : α), @matroid_on (type_map M).1 (type_map M).2)
-- M is the name of the matroid and has type α.
-- (γ M) is the 'ground type' of the matroid M;
--the function to_matroid maps the name M to the structure of -- matroid M (i.e. a rank function and proofs of axioms).

instance matroid_on.matroids (γ  : Type u)[h: fintype γ]  : matroids (matroid_on γ) :=
{ type_map := λ (M: matroid_on γ), ⟨γ, h⟩,
  to_matroid := id }

namespace matroid

local attribute [simp] image_union image_inter

variables {α : Type v} [matroids α]
-- Accessor functions for terms that have a matroid representation

def γ (M : α) := (matroids.type_map M).1 -- matroid elements have type γ
def E (M: α) : (set (γ M)) := set.univ  -- E is the ground set viewed as a set, not a type.
def r (M : α) (X : set (γ M) ) : ℤ := (matroids.to_matroid M).r X
def R1l (M : α) (X : set (γ M)) : 0 ≤ r M X := (matroids.to_matroid M).R1l X
def R1u (M:  α) (X: set (γ M))  : r M X ≤ size X := (matroids.to_matroid M).R1u X
def R2 (M : α) {X Y : set (γ M)} (h : X ⊆ Y) : r M X ≤ r M Y := (matroids.to_matroid M).R2 h
def R3 (M : α) (X Y : set (γ M)) : r M (X ∪ Y) + r M (X ∩ Y) ≤ r M X + r M Y := (matroids.to_matroid M).R3 X Y

@[simp] lemma r_empty_eq_zero (M : α) : r M (∅ : set (γ M)) = 0 :=
begin
    have := R1u M ∅,
    have := R1l M ∅,
    have := finsize (∅ : set (γ M)),
    sorry,
    --simp only [card_empty, int.coe_nat_zero] at this,
    --linarith,
end
--by { have h := R1 M ∅, rwa [card_empty, le_zero_iff_eq] at h }

lemma rank_subadditive (M : α) (X Y : set (γ M)) : r M (X ∪ Y) ≤ r M X + r M Y := by linarith [R3 M X Y, (R1 M (X ∩ Y)).1]

lemma r_le_union (M : α) (X Y : set (γ M)) : r M X ≤ r M (X ∪ Y) :=
by { apply R2 M, apply subset_union_left }

lemma r_le_union_right (M : α) (X Y : set (γ M)) : r M Y ≤ r M (X ∪ Y) :=
by { rw union_comm, apply r_le_union }

instance coe_subtype_set {α : Type*} {Y: set α} :
    has_coe (set Y) (set α) := ⟨λ X, X.image subtype.val⟩

@[simp] lemma coe_subtype_size {α : Type*} {Y: set α} (X: set Y) :
    size X = size (X: set α) := sorry

@[simp] lemma coe_subtype_union {α: Type*} {Y: set α} (X₁ X₂ : set Y) :
    (((X₁ ∪ X₂ : set Y)) :set α ) = X₁ ∪ X₂ := by apply image_union

@[simp] lemma coe_subtype_inter {α: Type*} {Y: set α} (X₁ X₂ : set Y) :
    (((X₁ ∩ X₂ : set Y)) :set α) = X₁ ∩ X₂ :=
begin
    sorry,
end

structure submatroid (M : α) :=
(F : set (γ M))

--set_option pp.beta true
--set_option pp.universes true
instance submatroid.matroid (M : α) : matroids (submatroid M) :=
{ γ := λ (M' : submatroid M), ↥(M'.F),
  to_matroid := λ (M' : submatroid M),
  { r := λ X, r M X,
    R1 := λ X,
    begin
        split,
        apply (R1 M X).1,
        simp only [coe_subtype_size],
        exact (R1 M X).2,
    end,
    R2 := λ X₁ X₂ h, R2 M (image_subset _ h),
    R3 := λ X₁ X₂,
    begin
        convert (R3 M X₁ X₂),
        simp,
        simp,
    end, }}

def delete (M : α) (F : set (γ M)) : submatroid M :=
submatroid.mk F

structure matroid_contraction (M : α) :=
(C : set (γ M))

--def contract (M : α) (C : set (γ M)) : matroid_contraction M :=
--matroid_contraction.mk C

instance matroid_contraction.matroid (M : α) : matroids (matroid_contraction M) :=
{ γ := λ M', ↥((M'.C : set (γ M))ᶜ),
  to_matroid := λ M',
  { r := λ X, r M (X ∪ M'.C) - r M M'.C,
    R1 := λ X,
    begin

      split,
      linarith [R2 M (subset_union_right ↑X M'.C)],

      have h1 := rank_subadditive M X M'.C,
      have := (R1 M X).2,
      rw coe_subtype_size X,
      --unfold size,
      linarith,
    end,
    R2 := λ X,
    begin
        intros Y hXY,
        have hXYC: (X ∪ M'.C: set (γ M)) ⊆ (Y ∪ M'.C: set (γ M)),
        {
            apply union_subset_union_left,
            apply image_subset,
            exact hXY,
        },
        linarith [R2 M hXYC],
    end,
    R3 :=
    begin
        intros X Y,
        --rw ← coe_subtype_union,
        suffices : r M (↑(X ∪ Y) ∪ M'.C) + r M (↑(X ∩ Y) ∪ M'.C) ≤ r M (↑X ∪ M'.C) + r M (↑Y ∪ M'.C), by linarith,

        --calc r M (↑(X ∪ Y) ∪ M'.C) - r M M'.C + (r M (↑(X ∩ Y) ∪ M'.C) - r M M'.C) ≤ r M (↑(X ∪ Y) ∪ M'.C) + (r M (↑(X ∩ Y) ∪ M'.C) - 2*(r M M'.C) : by linarith
        --... = r M (↑X ∪ M'.C) - r M M'.C + (r M (↑Y ∪ M'.C) - r M M'.C) : sorry,
        --... =

        --sorry,
        --exact this,

        --{linarith,},
        --rw @image_union (finset (↑(M'.C))ᶜ) () _ _ _ X Y ,
        --sorry,

        /-intros X Y,
        let X' := X.image subtype.val,
        let Y' := Y.image subtype.val,
        rw [image_union, image_inter],
        have := R3 M (X' ∪ M'.C) (Y' ∪ M'.C),
        simp only [@union_unions _ _ X' Y' _, inter_unions]  at this,

        linarith,
        intros x y,
        exact subtype.eq,-/
    end,
    }
 }

def dual (M : α) [fintype (γ M)] : matroid_on (γ M) :=
{ r := λ X, size X - r M (E M) + r M (Xᶜ),
  R1 :=
  begin
    sorry,
    /-intros X,
    split,
    have h1 : r X ≤ size X := (R1 M X).2,
    have h2 := rank_subadditive M X (Xᶜ),
    have h3 := lambda_conn_nonegative M X,
    --unfold lambda_conn at h3,

    calc size X - r (E M) + r Xᶜ = size X - r X + (r X + r Xᶜ - r (E M)) : by linarith
                        ...      ≥ size X - r X                          : by linarith [lambda_conn_nonegative M X]
                        ...      ≥ 0                                     : by linarith [(R1 M X).2],

    linarith[ R2 M ((by simp) :(Xᶜ ⊆ E M))], -/
  end,
  R2 := sorry,
  R3 := sorry }

end matroid