/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.equiv.list
import data.list.join
import logic.function.iterate

/-!
# The primitive recursive functions

The primitive recursive functions are the least collection of functions
`nat → nat` which are closed under projections (using the mkpair
pairing function), composition, zero, successor, and primitive recursion
(i.e. nat.rec where the motive is C n := nat).

We can extend this definition to a large class of basic types by
using canonical encodings of types as natural numbers (Gödel numbering),
which we implement through the type class `encodable`. (More precisely,
we need that the composition of encode with decode yields a
primitive recursive function, so we have the `primcodable` type class
for this.)

## References

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

open denumerable encodable function

namespace nat

def elim {C : Sort*} : C → (ℕ → C → C) → ℕ → C := @nat.rec (λ _, C)

@[simp] theorem elim_zero {C} (a f) : @nat.elim C a f 0 = a := rfl
@[simp] theorem elim_succ {C} (a f n) :
  @nat.elim C a f (succ n) = f n (nat.elim a f n) := rfl

def cases {C : Sort*} (a : C) (f : ℕ → C) : ℕ → C := nat.elim a (λ n _, f n)

@[simp] theorem cases_zero {C} (a f) : @nat.cases C a f 0 = a := rfl
@[simp] theorem cases_succ {C} (a f n) : @nat.cases C a f (succ n) = f n := rfl

@[simp, reducible] def unpaired {α} (f : ℕ → ℕ → α) (n : ℕ) : α :=
f n.unpair.1 n.unpair.2

/-- The primitive recursive functions `ℕ → ℕ`. -/
inductive primrec : (ℕ → ℕ) → Prop
| zero : primrec (λ n, 0)
| succ : primrec succ
| left : primrec (λ n, n.unpair.1)
| right : primrec (λ n, n.unpair.2)
| pair {f g} : primrec f → primrec g → primrec (λ n, mkpair (f n) (g n))
| comp {f g} : primrec f → primrec g → primrec (λ n, f (g n))
| prec {f g} : primrec f → primrec g → primrec (unpaired (λ z n,
   n.elim (f z) (λ y IH, g $ mkpair z $ mkpair y IH)))

namespace primrec

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

theorem const : ∀ (n : ℕ), primrec (λ _, n)
| 0 := zero
| (n+1) := succ.comp (const n)

protected theorem id : primrec id :=
(left.pair right).of_eq $ λ n, by simp

theorem prec1 {f} (m : ℕ) (hf : primrec f) : primrec (λ n,
   n.elim m (λ y IH, f $ mkpair y IH)) :=
((prec (const m) (hf.comp right)).comp
  (zero.pair primrec.id)).of_eq $
λ n, by simp; dsimp; rw [unpair_mkpair]

theorem cases1 {f} (m : ℕ) (hf : primrec f) : primrec (nat.cases m f) :=
(prec1 m (hf.comp left)).of_eq $ by simp [cases]

theorem cases {f g} (hf : primrec f) (hg : primrec g) :
  primrec (unpaired (λ z n, n.cases (f z) (λ y, g $ mkpair z y))) :=
(prec hf (hg.comp (pair left (left.comp right)))).of_eq $ by simp [cases]

protected theorem swap : primrec (unpaired (swap mkpair)) :=
(pair right left).of_eq $ λ n, by simp

theorem swap' {f} (hf : primrec (unpaired f)) : primrec (unpaired (swap f)) :=
(hf.comp primrec.swap).of_eq $ λ n, by simp

theorem pred : primrec pred :=
(cases1 0 primrec.id).of_eq $ λ n, by cases n; simp *

theorem add : primrec (unpaired (+)) :=
(prec primrec.id ((succ.comp right).comp right)).of_eq $
λ p, by simp; induction p.unpair.2; simp [*, -add_comm, add_succ]

theorem sub : primrec (unpaired has_sub.sub) :=
(prec primrec.id ((pred.comp right).comp right)).of_eq $
λ p, by simp; induction p.unpair.2; simp [*, -add_comm, sub_succ]

theorem mul : primrec (unpaired (*)) :=
(prec zero (add.comp (pair left (right.comp right)))).of_eq $
λ p, by simp; induction p.unpair.2; simp [*, mul_succ, add_comm]

theorem pow : primrec (unpaired (^)) :=
(prec (const 1) (mul.comp (pair (right.comp right) left))).of_eq $
λ p, by simp; induction p.unpair.2; simp [*, pow_succ']

end primrec

end nat

/-- A `primcodable` type is an `encodable` type for which
  the encode/decode functions are primitive recursive. -/
class primcodable (α : Type*) extends encodable α :=
(prim [] : nat.primrec (λ n, encodable.encode (decode n)))

namespace primcodable
open nat.primrec

@[priority 10] instance of_denumerable (α) [denumerable α] : primcodable α :=
⟨succ.of_eq $ by simp⟩

def of_equiv (α) {β} [primcodable α] (e : β ≃ α) : primcodable β :=
{ prim := (primcodable.prim α).of_eq $ λ n,
    show encode (decode α n) =
      (option.cases_on (option.map e.symm (decode α n))
        0 (λ a, nat.succ (encode (e a))) : ℕ),
    by cases decode α n; dsimp; simp,
  ..encodable.of_equiv α e }

instance empty : primcodable empty :=
⟨zero⟩

instance unit : primcodable punit :=
⟨(cases1 1 zero).of_eq $ λ n, by cases n; simp⟩

instance option {α : Type*} [h : primcodable α] : primcodable (option α) :=
⟨(cases1 1 ((cases1 0 (succ.comp succ)).comp (primcodable.prim α))).of_eq $
  λ n, by cases n; simp; cases decode α n; refl⟩

instance bool : primcodable bool :=
⟨(cases1 1 (cases1 2 zero)).of_eq $
λ n, begin
  cases n, {refl}, cases n, {refl},
  rw decode_ge_two, {refl},
  exact dec_trivial
end⟩

end primcodable

/-- `primrec f` means `f` is primitive recursive (after
  encoding its input and output as natural numbers). -/
def primrec {α β} [primcodable α] [primcodable β] (f : α → β) : Prop :=
nat.primrec (λ n, encode ((decode α n).map f))

namespace primrec
variables {α : Type*} {β : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable σ]
open nat.primrec

protected theorem encode : primrec (@encode α _) :=
(primcodable.prim α).of_eq $ λ n, by cases decode α n; refl

protected theorem decode : primrec (decode α) :=
succ.comp (primcodable.prim α)

theorem dom_denumerable {α β} [denumerable α] [primcodable β]
  {f : α → β} : primrec f ↔ nat.primrec (λ n, encode (f (of_nat α n))) :=
⟨λ h, (pred.comp h).of_eq $ λ n, by simp; refl,
 λ h, (succ.comp h).of_eq $ λ n, by simp; refl⟩

theorem nat_iff {f : ℕ → ℕ} : primrec f ↔ nat.primrec f :=
dom_denumerable

theorem encdec : primrec (λ n, encode (decode α n)) :=
nat_iff.2 (primcodable.prim α)

theorem option_some : primrec (@some α) :=
((cases1 0 (succ.comp succ)).comp (primcodable.prim α)).of_eq $
λ n, by cases decode α n; simp

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

theorem const (x : σ) : primrec (λ a : α, x) :=
((cases1 0 (const (encode x).succ)).comp (primcodable.prim α)).of_eq $
λ n, by cases decode α n; refl

protected theorem id : primrec (@id α) :=
(primcodable.prim α).of_eq $ by simp

theorem comp {f : β → σ} {g : α → β}
  (hf : primrec f) (hg : primrec g) : primrec (λ a, f (g a)) :=
((cases1 0 (hf.comp $ pred.comp hg)).comp (primcodable.prim α)).of_eq $
λ n, begin
  cases decode α n, {refl},
  simp [encodek]
end

theorem succ : primrec nat.succ := nat_iff.2 nat.primrec.succ

theorem pred : primrec nat.pred := nat_iff.2 nat.primrec.pred

theorem encode_iff {f : α → σ} : primrec (λ a, encode (f a)) ↔ primrec f :=
⟨λ h, nat.primrec.of_eq h $ λ n, by cases decode α n; refl,
 primrec.encode.comp⟩

theorem of_nat_iff {α β} [denumerable α] [primcodable β]
  {f : α → β} : primrec f ↔ primrec (λ n, f (of_nat α n)) :=
dom_denumerable.trans $ nat_iff.symm.trans encode_iff

protected theorem of_nat (α) [denumerable α] : primrec (of_nat α) :=
of_nat_iff.1 primrec.id

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

theorem of_equiv {β} {e : β ≃ α} :
  by haveI := primcodable.of_equiv α e; exact
  primrec e :=
by letI : primcodable β := primcodable.of_equiv α e; exact encode_iff.1 primrec.encode

theorem of_equiv_symm {β} {e : β ≃ α} :
  by haveI := primcodable.of_equiv α e; exact
  primrec e.symm :=
by letI := primcodable.of_equiv α e; exact
encode_iff.1
  (show primrec (λ a, encode (e (e.symm a))), by simp [primrec.encode])

theorem of_equiv_iff {β} (e : β ≃ α)
  {f : σ → β} :
  by haveI := primcodable.of_equiv α e; exact
  primrec (λ a, e (f a)) ↔ primrec f :=
by letI := primcodable.of_equiv α e; exact
⟨λ h, (of_equiv_symm.comp h).of_eq (λ a, by simp), of_equiv.comp⟩

theorem of_equiv_symm_iff {β} (e : β ≃ α)
  {f : σ → α} :
  by haveI := primcodable.of_equiv α e; exact
  primrec (λ a, e.symm (f a)) ↔ primrec f :=
by letI := primcodable.of_equiv α e; exact
⟨λ h, (of_equiv.comp h).of_eq (λ a, by simp), of_equiv_symm.comp⟩

end primrec

namespace primcodable
open nat.primrec

instance prod {α β} [primcodable α] [primcodable β] : primcodable (α × β) :=
⟨((cases zero ((cases zero succ).comp
  (pair right ((primcodable.prim β).comp left)))).comp
  (pair right ((primcodable.prim α).comp left))).of_eq $
λ n, begin
  simp [nat.unpaired],
  cases decode α n.unpair.1, { simp },
  cases decode β n.unpair.2; simp
end⟩

end primcodable

namespace primrec
variables {α : Type*} {σ : Type*} [primcodable α] [primcodable σ]
open nat.primrec

theorem fst {α β} [primcodable α] [primcodable β] :
  primrec (@prod.fst α β) :=
((cases zero ((cases zero (nat.primrec.succ.comp left)).comp
  (pair right ((primcodable.prim β).comp left)))).comp
  (pair right ((primcodable.prim α).comp left))).of_eq $
λ n, begin
  simp,
  cases decode α n.unpair.1; simp,
  cases decode β n.unpair.2; simp
end

theorem snd {α β} [primcodable α] [primcodable β] :
  primrec (@prod.snd α β) :=
((cases zero ((cases zero (nat.primrec.succ.comp right)).comp
  (pair right ((primcodable.prim β).comp left)))).comp
  (pair right ((primcodable.prim α).comp left))).of_eq $
λ n, begin
  simp,
  cases decode α n.unpair.1; simp,
  cases decode β n.unpair.2; simp
end

theorem pair {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {f : α → β} {g : α → γ} (hf : primrec f) (hg : primrec g) :
  primrec (λ a, (f a, g a)) :=
((cases1 0 (nat.primrec.succ.comp $
  pair (nat.primrec.pred.comp hf) (nat.primrec.pred.comp hg))).comp
  (primcodable.prim α)).of_eq $
λ n, by cases decode α n; simp [encodek]; refl

theorem unpair : primrec nat.unpair :=
(pair (nat_iff.2 nat.primrec.left) (nat_iff.2 nat.primrec.right)).of_eq $
λ n, by simp

theorem list_nth₁ : ∀ (l : list α), primrec l.nth
| []     := dom_denumerable.2 zero
| (a::l) := dom_denumerable.2 $
  (cases1 (encode a).succ $ dom_denumerable.1 $ list_nth₁ l).of_eq $
  λ n, by cases n; simp

end primrec

/-- `primrec₂ f` means `f` is a binary primitive recursive function.
  This is technically unnecessary since we can always curry all
  the arguments together, but there are enough natural two-arg
  functions that it is convenient to express this directly. -/
def primrec₂ {α β σ} [primcodable α] [primcodable β] [primcodable σ] (f : α → β → σ) :=
primrec (λ p : α × β, f p.1 p.2)

/-- `primrec_pred p` means `p : α → Prop` is a (decidable)
  primitive recursive predicate, which is to say that
  `to_bool ∘ p : α → bool` is primitive recursive. -/
def primrec_pred {α} [primcodable α] (p : α → Prop)
  [decidable_pred p] := primrec (λ a, to_bool (p a))

/-- `primrec_rel p` means `p : α → β → Prop` is a (decidable)
  primitive recursive relation, which is to say that
  `to_bool ∘ p : α → β → bool` is primitive recursive. -/
def primrec_rel {α β} [primcodable α] [primcodable β]
  (s : α → β → Prop) [∀ a b, decidable (s a b)] :=
primrec₂ (λ a b, to_bool (s a b))

namespace primrec₂
variables {α : Type*} {β : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable σ]

theorem of_eq {f g : α → β → σ} (hg : primrec₂ f) (H : ∀ a b, f a b = g a b) : primrec₂ g :=
(by funext a b; apply H : f = g) ▸ hg

theorem const (x : σ) : primrec₂ (λ (a : α) (b : β), x) := primrec.const _

protected theorem pair : primrec₂ (@prod.mk α β) :=
primrec.pair primrec.fst primrec.snd

theorem left : primrec₂ (λ (a : α) (b : β), a) := primrec.fst

theorem right : primrec₂ (λ (a : α) (b : β), b) := primrec.snd

theorem mkpair : primrec₂ nat.mkpair :=
by simp [primrec₂, primrec]; constructor

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

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

theorem encode_iff {f : α → β → σ} : primrec₂ (λ a b, encode (f a b)) ↔ primrec₂ f :=
primrec.encode_iff

theorem option_some_iff {f : α → β → σ} : primrec₂ (λ a b, some (f a b)) ↔ primrec₂ f :=
primrec.option_some_iff

theorem of_nat_iff {α β σ}
  [denumerable α] [denumerable β] [primcodable σ]
  {f : α → β → σ} : primrec₂ f ↔ primrec₂ (λ m n : ℕ,
    f (of_nat α m) (of_nat β n)) :=
(primrec.of_nat_iff.trans $ by simp).trans unpaired

theorem uncurry {f : α → β → σ} : primrec (function.uncurry f) ↔ primrec₂ f :=
by rw [show function.uncurry f = λ (p : α × β), f p.1 p.2,
       from funext $ λ ⟨a, b⟩, rfl]; refl

theorem curry {f : α × β → σ} : primrec₂ (function.curry f) ↔ primrec f :=
by rw [← uncurry, function.uncurry_curry]

end primrec₂

section comp
variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable δ] [primcodable σ]

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

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

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

theorem primrec_pred.comp
  {p : β → Prop} [decidable_pred p] {f : α → β} :
  primrec_pred p → primrec f →
  primrec_pred (λ a, p (f a)) := primrec.comp

theorem primrec_rel.comp
  {R : β → γ → Prop} [∀ a b, decidable (R a b)] {f : α → β} {g : α → γ} :
  primrec_rel R → primrec f → primrec g →
  primrec_pred (λ a, R (f a) (g a)) := primrec₂.comp

theorem primrec_rel.comp₂
  {R : γ → δ → Prop} [∀ a b, decidable (R a b)] {f : α → β → γ} {g : α → β → δ} :
  primrec_rel R → primrec₂ f → primrec₂ g →
  primrec_rel (λ a b, R (f a b) (g a b)) := primrec_rel.comp

end comp

theorem primrec_pred.of_eq {α} [primcodable α]
  {p q : α → Prop} [decidable_pred p] [decidable_pred q]
  (hp : primrec_pred p) (H : ∀ a, p a ↔ q a) : primrec_pred q :=
primrec.of_eq hp (λ a, to_bool_congr (H a))

theorem primrec_rel.of_eq {α β} [primcodable α] [primcodable β]
  {r s : α → β → Prop} [∀ a b, decidable (r a b)] [∀ a b, decidable (s a b)]
  (hr : primrec_rel r) (H : ∀ a b, r a b ↔ s a b) : primrec_rel s :=
primrec₂.of_eq hr (λ a b, to_bool_congr (H a b))

namespace primrec₂
variables {α : Type*} {β : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable σ]
open nat.primrec

theorem swap {f : α → β → σ} (h : primrec₂ f) : primrec₂ (swap f) :=
h.comp₂ primrec₂.right primrec₂.left

theorem nat_iff {f : α → β → σ} : primrec₂ f ↔
  nat.primrec (nat.unpaired $ λ m n : ℕ,
    encode $ (decode α m).bind $ λ a, (decode β n).map (f a)) :=
have ∀ (a : option α) (b : option β),
  option.map (λ (p : α × β), f p.1 p.2)
    (option.bind a (λ (a : α), option.map (prod.mk a) b)) =
  option.bind a (λ a, option.map (f a) b),
by intros; cases a; [refl, {cases b; refl}],
by simp [primrec₂, primrec, this]

theorem nat_iff' {f : α → β → σ} : primrec₂ f ↔ primrec₂ (λ m n : ℕ,
  option.bind (decode α m) (λ a, option.map (f a) (decode β n))) :=
nat_iff.trans $ unpaired'.trans encode_iff

end primrec₂

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

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

theorem nat_elim {f : α → β} {g : α → ℕ × β → β}
  (hf : primrec f) (hg : primrec₂ g) :
  primrec₂ (λ a (n : ℕ), n.elim (f a) (λ n IH, g a (n, IH))) :=
primrec₂.nat_iff.2 $ ((nat.primrec.cases nat.primrec.zero $
    (nat.primrec.prec hf $ nat.primrec.comp hg $ nat.primrec.left.pair $
      (nat.primrec.left.comp nat.primrec.right).pair $
      nat.primrec.pred.comp $ nat.primrec.right.comp nat.primrec.right).comp $
    nat.primrec.right.pair $
      nat.primrec.right.comp nat.primrec.left).comp $
  nat.primrec.id.pair $ (primcodable.prim α).comp nat.primrec.left).of_eq $
λ n, begin
  simp,
  cases decode α n.unpair.1 with a, {refl},
  simp [encodek],
  induction n.unpair.2 with m; simp [encodek],
  simp [ih, encodek]
end

theorem nat_elim' {f : α → ℕ} {g : α → β} {h : α → ℕ × β → β}
  (hf : primrec f) (hg : primrec g) (hh : primrec₂ h) :
  primrec (λ a, (f a).elim (g a) (λ n IH, h a (n, IH))) :=
(nat_elim hg hh).comp primrec.id hf

theorem nat_elim₁ {f : ℕ → α → α} (a : α) (hf : primrec₂ f) :
  primrec (nat.elim a f) :=
nat_elim' primrec.id (const a) $ comp₂ hf primrec₂.right

theorem nat_cases' {f : α → β} {g : α → ℕ → β}
  (hf : primrec f) (hg : primrec₂ g) :
  primrec₂ (λ a, nat.cases (f a) (g a)) :=
nat_elim hf $ hg.comp₂ primrec₂.left $
  comp₂ fst primrec₂.right

theorem nat_cases {f : α → ℕ} {g : α → β} {h : α → ℕ → β}
  (hf : primrec f) (hg : primrec g) (hh : primrec₂ h) :
  primrec (λ a, (f a).cases (g a) (h a)) :=
(nat_cases' hg hh).comp primrec.id hf

theorem nat_cases₁ {f : ℕ → α} (a : α) (hf : primrec f) :
  primrec (nat.cases a f) :=
nat_cases primrec.id (const a) (comp₂ hf primrec₂.right)

theorem nat_iterate {f : α → ℕ} {g : α → β} {h : α → β → β}
  (hf : primrec f) (hg : primrec g) (hh : primrec₂ h) :
  primrec (λ a, (h a)^[f a] (g a)) :=
(nat_elim' hf hg (hh.comp₂ primrec₂.left $ snd.comp₂ primrec₂.right)).of_eq $
λ a, by induction f a; simp [*, function.iterate_succ']

theorem option_cases {o : α → option β} {f : α → σ} {g : α → β → σ}
  (ho : primrec o) (hf : primrec f) (hg : primrec₂ g) :
  @primrec _ σ _ _ (λ a, option.cases_on (o a) (f a) (g a)) :=
encode_iff.1 $
(nat_cases (encode_iff.2 ho) (encode_iff.2 hf) $
  pred.comp₂ $ primrec₂.encode_iff.2 $
  (primrec₂.nat_iff'.1 hg).comp₂
    ((@primrec.encode α _).comp fst).to₂
    primrec₂.right).of_eq $
λ a, by cases o a with b; simp [encodek]; refl

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

theorem option_bind₁ {f : α → option σ} (hf : primrec f) :
  primrec (λ o, option.bind o f) :=
option_bind primrec.id (hf.comp snd).to₂

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

theorem option_map₁ {f : α → σ} (hf : primrec f) : primrec (option.map f) :=
option_map primrec.id (hf.comp snd).to₂

theorem option_iget [inhabited α] : primrec (@option.iget α _) :=
(option_cases primrec.id (const $ default α) primrec₂.right).of_eq $
λ o, by cases o; refl

theorem option_is_some : primrec (@option.is_some α) :=
(option_cases primrec.id (const ff) (const tt).to₂).of_eq $
λ o, by cases o; refl

theorem option_get_or_else : primrec₂ (@option.get_or_else α) :=
primrec.of_eq (option_cases primrec₂.left primrec₂.right primrec₂.right) $
λ ⟨o, a⟩, by cases o; refl

theorem bind_decode_iff {f : α → β → option σ} : primrec₂ (λ a n,
  (decode β n).bind (f a)) ↔ primrec₂ f :=
⟨λ h, by simpa [encodek] using
   h.comp fst ((@primrec.encode β _).comp snd),
 λ h, option_bind (primrec.decode.comp snd) $
   h.comp (fst.comp fst) snd⟩

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

theorem nat_add : primrec₂ ((+) : ℕ → ℕ → ℕ) :=
primrec₂.unpaired'.1 nat.primrec.add

theorem nat_sub : primrec₂ (has_sub.sub : ℕ → ℕ → ℕ) :=
primrec₂.unpaired'.1 nat.primrec.sub

theorem nat_mul : primrec₂ ((*) : ℕ → ℕ → ℕ) :=
primrec₂.unpaired'.1 nat.primrec.mul

theorem cond {c : α → bool} {f : α → σ} {g : α → σ}
  (hc : primrec c) (hf : primrec f) (hg : primrec g) :
  primrec (λ 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 ite {c : α → Prop} [decidable_pred c] {f : α → σ} {g : α → σ}
  (hc : primrec_pred c) (hf : primrec f) (hg : primrec g) :
  primrec (λ a, if c a then f a else g a) :=
by simpa using cond hc hf hg

theorem nat_le : primrec_rel ((≤) : ℕ → ℕ → Prop) :=
(nat_cases nat_sub (const tt) (const ff).to₂).of_eq $
λ p, begin
  dsimp [swap],
  cases e : p.1 - p.2 with n,
  { simp [tsub_eq_zero_iff_le.1 e] },
  { simp [not_le.2 (nat.lt_of_sub_eq_succ e)] }
end

theorem nat_min : primrec₂ (@min ℕ _) := ite nat_le fst snd
theorem nat_max : primrec₂ (@max ℕ _) := ite (nat_le.comp primrec.snd primrec.fst) fst snd

theorem dom_bool (f : bool → α) : primrec f :=
(cond primrec.id (const (f tt)) (const (f ff))).of_eq $
λ b, by cases b; refl

theorem dom_bool₂ (f : bool → bool → α) : primrec₂ f :=
(cond fst
  ((dom_bool (f tt)).comp snd)
  ((dom_bool (f ff)).comp snd)).of_eq $
λ ⟨a, b⟩, by cases a; refl

protected theorem bnot : primrec bnot := dom_bool _
protected theorem band : primrec₂ band := dom_bool₂ _
protected theorem bor : primrec₂ bor := dom_bool₂ _

protected theorem not {p : α → Prop} [decidable_pred p]
  (hp : primrec_pred p) : primrec_pred (λ a, ¬ p a) :=
(primrec.bnot.comp hp).of_eq $ λ n, by simp

protected theorem and {p q : α → Prop}
  [decidable_pred p] [decidable_pred q]
  (hp : primrec_pred p) (hq : primrec_pred q) :
  primrec_pred (λ a, p a ∧ q a) :=
(primrec.band.comp hp hq).of_eq $ λ n, by simp

protected theorem or {p q : α → Prop}
  [decidable_pred p] [decidable_pred q]
  (hp : primrec_pred p) (hq : primrec_pred q) :
  primrec_pred (λ a, p a ∨ q a) :=
(primrec.bor.comp hp hq).of_eq $ λ n, by simp

protected theorem eq [decidable_eq α] : primrec_rel (@eq α) :=
have primrec_rel (λ a b : ℕ, a = b), from
  (primrec.and nat_le nat_le.swap).of_eq $
  λ a, by simp [le_antisymm_iff],
(this.comp₂
  (primrec.encode.comp₂ primrec₂.left)
  (primrec.encode.comp₂ primrec₂.right)).of_eq $
λ a b, encode_injective.eq_iff

theorem nat_lt : primrec_rel ((<) : ℕ → ℕ → Prop) :=
(nat_le.comp snd fst).not.of_eq $ λ p, by simp

theorem option_guard {p : α → β → Prop}
  [∀ a b, decidable (p a b)] (hp : primrec_rel p)
  {f : α → β} (hf : primrec f) :
  primrec (λ a, option.guard (p a) (f a)) :=
ite (hp.comp primrec.id hf) (option_some_iff.2 hf) (const none)

theorem option_orelse :
  primrec₂ ((<|>) : option α → option α → option α) :=
(option_cases fst snd (fst.comp fst).to₂).of_eq $
λ ⟨o₁, o₂⟩, by cases o₁; cases o₂; refl

protected theorem decode₂ : primrec (decode₂ α) :=
option_bind primrec.decode $
option_guard ((@primrec.eq _ _ nat.decidable_eq).comp
  (encode_iff.2 snd) (fst.comp fst)) snd

theorem list_find_index₁ {p : α → β → Prop}
  [∀ a b, decidable (p a b)] (hp : primrec_rel p) :
  ∀ (l : list β), primrec (λ a, l.find_index (p a))
| [] := const 0
| (a::l) := ite (hp.comp primrec.id (const a)) (const 0)
  (succ.comp (list_find_index₁ l))

theorem list_index_of₁ [decidable_eq α] (l : list α) :
  primrec (λ a, l.index_of a) := list_find_index₁ primrec.eq l

theorem dom_fintype [fintype α] (f : α → σ) : primrec f :=
let ⟨l, nd, m⟩ := fintype.exists_univ_list α in
option_some_iff.1 $ begin
  haveI := decidable_eq_of_encodable α,
  refine ((list_nth₁ (l.map f)).comp (list_index_of₁ l)).of_eq (λ a, _),
  rw [list.nth_map, list.nth_le_nth (list.index_of_lt_length.2 (m _)),
      list.index_of_nth_le]; refl
end

theorem nat_bodd_div2 : primrec nat.bodd_div2 :=
(nat_elim' primrec.id (const (ff, 0))
  (((cond fst
      (pair (const ff) (succ.comp snd))
      (pair (const tt) snd)).comp snd).comp snd).to₂).of_eq $
λ n, begin
  simp [-nat.bodd_div2_eq],
  induction n with n IH, {refl},
  simp [-nat.bodd_div2_eq, nat.bodd_div2, *],
  rcases nat.bodd_div2 n with ⟨_|_, m⟩; simp [nat.bodd_div2]
end

theorem nat_bodd : primrec nat.bodd := fst.comp nat_bodd_div2
theorem nat_div2 : primrec nat.div2 := snd.comp nat_bodd_div2

theorem nat_bit0 : primrec (@bit0 ℕ _) :=
nat_add.comp primrec.id primrec.id

theorem nat_bit1 : primrec (@bit1 ℕ _ _) :=
nat_add.comp nat_bit0 (const 1)

theorem nat_bit : primrec₂ nat.bit :=
(cond primrec.fst
  (nat_bit1.comp primrec.snd)
  (nat_bit0.comp primrec.snd)).of_eq $
λ n, by cases n.1; refl

theorem nat_div_mod : primrec₂ (λ n k : ℕ, (n / k, n % k)) :=
let f (a : ℕ × ℕ) : ℕ × ℕ := a.1.elim (0, 0) (λ _ IH,
  if nat.succ IH.2 = a.2
  then (nat.succ IH.1, 0)
  else (IH.1, nat.succ IH.2)) in
have hf : primrec f, from
nat_elim' fst (const (0, 0)) $
  ((ite ((@primrec.eq ℕ _ _).comp (succ.comp $ snd.comp snd) fst)
      (pair (succ.comp $ fst.comp snd) (const 0))
      (pair (fst.comp snd) (succ.comp $ snd.comp snd)))
    .comp (pair (snd.comp fst) (snd.comp snd))).to₂,
suffices ∀ k n, (n / k, n % k) = f (n, k),
from hf.of_eq $ λ ⟨m, n⟩, by simp [this],
λ k n, begin
  have : (f (n, k)).2 + k * (f (n, k)).1 = n
    ∧ (0 < k → (f (n, k)).2 < k)
    ∧ (k = 0 → (f (n, k)).1 = 0),
  { induction n with n IH, {exact ⟨rfl, id, λ _, rfl⟩},
    rw [λ n:ℕ, show f (n.succ, k) =
      _root_.ite ((f (n, k)).2.succ = k)
      (nat.succ (f (n, k)).1, 0)
      ((f (n, k)).1, (f (n, k)).2.succ), from rfl],
    by_cases h : (f (n, k)).2.succ = k; simp [h],
    { have := congr_arg nat.succ IH.1,
      refine ⟨_, λ k0, nat.no_confusion (h.trans k0)⟩,
      rwa [← nat.succ_add, h, add_comm, ← nat.mul_succ] at this },
    { exact ⟨by rw [nat.succ_add, IH.1],
        λ k0, lt_of_le_of_ne (IH.2.1 k0) h, IH.2.2⟩ } },
  revert this, cases f (n, k) with D M,
  simp, intros h₁ h₂ h₃,
  cases nat.eq_zero_or_pos k,
  { simp [h, h₃ h] at h₁ ⊢, simp [h₁] },
  { exact (nat.div_mod_unique h).2 ⟨h₁, h₂ h⟩ }
end

theorem nat_div : primrec₂ ((/) : ℕ → ℕ → ℕ) := fst.comp₂ nat_div_mod
theorem nat_mod : primrec₂ ((%) : ℕ → ℕ → ℕ) := snd.comp₂ nat_div_mod

end primrec

section
variables {α : Type*} {β : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable σ]

variable (H : nat.primrec (λ n, encodable.encode (decode (list β) n)))
include H
open primrec

private def prim : primcodable (list β) := ⟨H⟩

private lemma list_cases'
  {f : α → list β} {g : α → σ} {h : α → β × list β → σ}
  (hf : by haveI := prim H; exact primrec f) (hg : primrec g)
  (hh : by haveI := prim H; exact primrec₂ h) :
  @primrec _ σ _ _ (λ a, list.cases_on (f a) (g a) (λ b l, h a (b, l))) :=
by letI := prim H; exact
have @primrec _ (option σ) _ _ (λ a,
  (decode (option (β × list β)) (encode (f a))).map
  (λ o, option.cases_on o (g a) (h a))), from
((@map_decode_iff _ (option (β × list β)) _ _ _ _ _).2 $
    to₂ $ option_cases snd (hg.comp fst)
  (hh.comp₂ (fst.comp₂ primrec₂.left) primrec₂.right))
    .comp primrec.id (encode_iff.2 hf),
option_some_iff.1 $ this.of_eq $
λ a, by cases f a with b l; simp [encodek]; refl

private lemma list_foldl'
  {f : α → list β} {g : α → σ} {h : α → σ × β → σ}
  (hf : by haveI := prim H; exact primrec f) (hg : primrec g)
  (hh : by haveI := prim H; exact primrec₂ h) :
  primrec (λ a, (f a).foldl (λ s b, h a (s, b)) (g a)) :=
by letI := prim H; exact
let G (a : α) (IH : σ × list β) : σ × list β :=
  list.cases_on IH.2 IH (λ b l, (h a (IH.1, b), l)) in
let F (a : α) (n : ℕ) := (G a)^[n] (g a, f a) in
have primrec (λ a, (F a (encode (f a))).1), from
fst.comp $ nat_iterate (encode_iff.2 hf) (pair hg hf) $
  list_cases' H (snd.comp snd) snd $ to₂ $ pair
    (hh.comp (fst.comp fst) $
      pair ((fst.comp snd).comp fst) (fst.comp snd))
    (snd.comp snd),
this.of_eq $ λ a, begin
  have : ∀ n, F a n =
    ((list.take n (f a)).foldl (λ s b, h a (s, b)) (g a),
      list.drop n (f a)),
  { intro, simp [F],
    generalize : f a = l, generalize : g a = x,
    induction n with n IH generalizing l x, {refl},
    simp, cases l with b l; simp [IH] },
  rw [this, list.take_all_of_le (length_le_encode _)]
end

private lemma list_cons' : by haveI := prim H; exact primrec₂ (@list.cons β) :=
by letI := prim H; exact
encode_iff.1 (succ.comp $
primrec₂.mkpair.comp (encode_iff.2 fst) (encode_iff.2 snd))

private lemma list_reverse' : by haveI := prim H; exact
  primrec (@list.reverse β) :=
by letI := prim H; exact
(list_foldl' H primrec.id (const []) $ to₂ $
   ((list_cons' H).comp snd fst).comp snd).of_eq
(suffices ∀ l r, list.foldl (λ (s : list β) (b : β), b :: s) r l = list.reverse_core l r,
from λ l, this l [],
λ l, by induction l; simp [*, list.reverse_core])

end

namespace primcodable
variables {α : Type*} {β : Type*}
variables [primcodable α] [primcodable β]
open primrec

instance sum : primcodable (α ⊕ β) :=
⟨primrec.nat_iff.1 $
(encode_iff.2 (cond nat_bodd
  (((@primrec.decode β _).comp nat_div2).option_map $ to₂ $
     nat_bit.comp (const tt) (primrec.encode.comp snd))
  (((@primrec.decode α _).comp nat_div2).option_map $ to₂ $
     nat_bit.comp (const ff) (primrec.encode.comp snd)))).of_eq $
λ n, show _ = encode (decode_sum n), begin
  simp [decode_sum],
  cases nat.bodd n; simp [decode_sum],
  { cases decode α n.div2; refl },
  { cases decode β n.div2; refl }
end⟩

instance list : primcodable (list α) := ⟨
by letI H := primcodable.prim (list ℕ); exact
have primrec₂ (λ (a : α) (o : option (list ℕ)),
  o.map (list.cons (encode a))), from
option_map snd $
  (list_cons' H).comp ((@primrec.encode α _).comp (fst.comp fst)) snd,
have primrec (λ n, (of_nat (list ℕ) n).reverse.foldl
  (λ o m, (decode α m).bind (λ a, o.map (list.cons (encode a))))
   (some [])), from
list_foldl' H
  ((list_reverse' H).comp (primrec.of_nat (list ℕ)))
  (const (some []))
  (primrec.comp₂ (bind_decode_iff.2 $ primrec₂.swap this) primrec₂.right),
nat_iff.1 $ (encode_iff.2 this).of_eq $ λ n, begin
  rw list.foldl_reverse,
  apply nat.case_strong_induction_on n, { simp },
  intros n IH, simp,
  cases decode α n.unpair.1 with a, {refl},
  simp,
  suffices : ∀ (o : option (list ℕ)) p (_ : encode o = encode p),
    encode (option.map (list.cons (encode a)) o) =
    encode (option.map (list.cons a) p),
  from this _ _ (IH _ (nat.unpair_right_le n)),
  intros o p IH,
  cases o; cases p; injection IH with h,
  exact congr_arg (λ k, (nat.mkpair (encode a) k).succ.succ) h
end⟩

end primcodable

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

theorem sum_inl : primrec (@sum.inl α β) :=
encode_iff.1 $ nat_bit0.comp primrec.encode

theorem sum_inr : primrec (@sum.inr α β) :=
encode_iff.1 $ nat_bit1.comp primrec.encode

theorem sum_cases
  {f : α → β ⊕ γ} {g : α → β → σ} {h : α → γ → σ}
  (hf : primrec f) (hg : primrec₂ g) (hh : primrec₂ h) :
  @primrec _ σ _ _ (λ a, sum.cases_on (f a) (g a) (h a)) :=
option_some_iff.1 $
(cond (nat_bodd.comp $ encode_iff.2 hf)
  (option_map (primrec.decode.comp $ nat_div2.comp $ encode_iff.2 hf) hh)
  (option_map (primrec.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 list_cons : primrec₂ (@list.cons α) :=
list_cons' (primcodable.prim _)

theorem list_cases
  {f : α → list β} {g : α → σ} {h : α → β × list β → σ} :
  primrec f → primrec g → primrec₂ h →
  @primrec _ σ _ _ (λ a, list.cases_on (f a) (g a) (λ b l, h a (b, l))) :=
list_cases' (primcodable.prim _)

theorem list_foldl
  {f : α → list β} {g : α → σ} {h : α → σ × β → σ} :
  primrec f → primrec g → primrec₂ h →
  primrec (λ a, (f a).foldl (λ s b, h a (s, b)) (g a)) :=
list_foldl' (primcodable.prim _)

theorem list_reverse : primrec (@list.reverse α) :=
list_reverse' (primcodable.prim _)

theorem list_foldr
  {f : α → list β} {g : α → σ} {h : α → β × σ → σ}
  (hf : primrec f) (hg : primrec g) (hh : primrec₂ h) :
  primrec (λ a, (f a).foldr (λ b s, h a (b, s)) (g a)) :=
(list_foldl (list_reverse.comp hf) hg $ to₂ $
  hh.comp fst $ (pair snd fst).comp snd).of_eq $
λ a, by simp [list.foldl_reverse]

theorem list_head' : primrec (@list.head' α) :=
(list_cases primrec.id (const none)
  (option_some_iff.2 $ (fst.comp snd)).to₂).of_eq $
λ l, by cases l; refl

theorem list_head [inhabited α] : primrec (@list.head α _) :=
(option_iget.comp list_head').of_eq $
λ l, l.head_eq_head'.symm

theorem list_tail : primrec (@list.tail α) :=
(list_cases primrec.id (const []) (snd.comp snd).to₂).of_eq $
λ l, by cases l; refl

theorem list_rec
  {f : α → list β} {g : α → σ} {h : α → β × list β × σ → σ}
  (hf : primrec f) (hg : primrec g) (hh : primrec₂ h) :
  @primrec _ σ _ _ (λ a,
    list.rec_on (f a) (g a) (λ b l IH, h a (b, l, IH))) :=
let F (a : α) := (f a).foldr
  (λ (b : β) (s : list β × σ), (b :: s.1, h a (b, s))) ([], g a) in
have primrec F, from
list_foldr hf (pair (const []) hg) $ to₂ $
  pair ((list_cons.comp fst (fst.comp snd)).comp snd) hh,
(snd.comp this).of_eq $ λ a, begin
  suffices : F a = (f a,
    list.rec_on (f a) (g a) (λ b l IH, h a (b, l, IH))), {rw this},
  simp [F], induction f a with b l IH; simp *
end

theorem list_nth : primrec₂ (@list.nth α) :=
let F (l : list α) (n : ℕ) :=
l.foldl (λ (s : ℕ ⊕ α) (a : α),
  sum.cases_on s
    (@nat.cases (ℕ ⊕ α) (sum.inr a) sum.inl) sum.inr)
  (sum.inl n) in
have hF : primrec₂ F, from
list_foldl fst (sum_inl.comp snd) ((sum_cases fst
  (nat_cases snd
    (sum_inr.comp $ snd.comp fst)
    (sum_inl.comp snd).to₂).to₂
  (sum_inr.comp snd).to₂).comp snd).to₂,
have @primrec _ (option α) _ _ (λ p : list α × ℕ,
  sum.cases_on (F p.1 p.2) (λ _, none) some), from
sum_cases hF (const none).to₂ (option_some.comp snd).to₂,
this.to₂.of_eq $ λ l n, begin
  dsimp, symmetry,
  induction l with a l IH generalizing n, {refl},
  cases n with n,
  { rw [(_ : F (a :: l) 0 = sum.inr a)], {refl},
    clear IH, dsimp [F],
    induction l with b l IH; simp * },
  { apply IH }
end

theorem list_inth [inhabited α] : primrec₂ (@list.inth α _) :=
option_iget.comp₂ list_nth

theorem list_append : primrec₂ ((++) : list α → list α → list α) :=
(list_foldr fst snd $ to₂ $ comp (@list_cons α _) snd).to₂.of_eq $
λ l₁ l₂, by induction l₁; simp *

theorem list_concat : primrec₂ (λ l (a:α), l ++ [a]) :=
list_append.comp fst (list_cons.comp snd (const []))

theorem list_map
  {f : α → list β} {g : α → β → σ}
  (hf : primrec f) (hg : primrec₂ g) :
  primrec (λ a, (f a).map (g a)) :=
(list_foldr hf (const []) $ to₂ $ list_cons.comp
  (hg.comp fst (fst.comp snd)) (snd.comp snd)).of_eq $
λ a, by induction f a; simp *

theorem list_range : primrec list.range :=
(nat_elim' primrec.id (const [])
  ((list_concat.comp snd fst).comp snd).to₂).of_eq $
λ n, by simp; induction n; simp [*, list.range_succ]; refl

theorem list_join : primrec (@list.join α) :=
(list_foldr primrec.id (const []) $ to₂ $
  comp (@list_append α _) snd).of_eq $
λ l, by dsimp; induction l; simp *

theorem list_length : primrec (@list.length α) :=
(list_foldr (@primrec.id (list α) _) (const 0) $ to₂ $
  (succ.comp $ snd.comp snd).to₂).of_eq $
λ l, by dsimp; induction l; simp [*, -add_comm]

theorem list_find_index {f : α → list β} {p : α → β → Prop}
  [∀ a b, decidable (p a b)]
  (hf : primrec f) (hp : primrec_rel p) :
  primrec (λ a, (f a).find_index (p a)) :=
(list_foldr hf (const 0) $ to₂ $
  ite (hp.comp fst $ fst.comp snd) (const 0)
    (succ.comp $ snd.comp snd)).of_eq $
λ a, eq.symm $ by dsimp; induction f a with b l;
  [refl, simp [*, list.find_index]]

theorem list_index_of [decidable_eq α] : primrec₂ (@list.index_of α _) :=
to₂ $ list_find_index snd $ primrec.eq.comp₂ (fst.comp fst).to₂ snd.to₂

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

end primrec

namespace primcodable
variables {α : Type*} {β : Type*}
variables [primcodable α] [primcodable β]
open primrec

def subtype {p : α → Prop} [decidable_pred p]
  (hp : primrec_pred p) : primcodable (subtype p) :=
⟨have primrec (λ n, (decode α n).bind (λ a, option.guard p a)),
 from option_bind primrec.decode (option_guard (hp.comp snd) snd),
 nat_iff.1 $ (encode_iff.2 this).of_eq $ λ n,
 show _ = encode ((decode α n).bind (λ a, _)), begin
   cases decode α n with a, {refl},
   dsimp [option.guard],
   by_cases h : p a; simp [h]; refl
 end⟩

instance fin {n} : primcodable (fin n) :=
@of_equiv _ _
  (subtype $ nat_lt.comp primrec.id (const n))
  (equiv.fin_equiv_subtype _)

instance vector {n} : primcodable (vector α n) :=
subtype ((@primrec.eq _ _ nat.decidable_eq).comp list_length (const _))

instance fin_arrow {n} : primcodable (fin n → α) :=
of_equiv _ (equiv.vector_equiv_fin _ _).symm

instance array {n} : primcodable (array n α) :=
of_equiv _ (equiv.array_equiv_fin _ _)

section ulower
local attribute [instance, priority 100]
  encodable.decidable_range_encode encodable.decidable_eq_of_encodable

instance ulower : primcodable (ulower α) :=
have primrec_pred (λ n, encodable.decode₂ α n ≠ none),
from primrec.not (primrec.eq.comp (primrec.option_bind primrec.decode
  (primrec.ite (primrec.eq.comp (primrec.encode.comp primrec.snd) primrec.fst)
    (primrec.option_some.comp primrec.snd) (primrec.const _))) (primrec.const _)),
primcodable.subtype $
  primrec_pred.of_eq this (λ n, decode₂_ne_none_iff)

end ulower

end primcodable

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

theorem subtype_val {p : α → Prop} [decidable_pred p]
  {hp : primrec_pred p} :
  by haveI := primcodable.subtype hp; exact
  primrec (@subtype.val α p) :=
begin
  letI := primcodable.subtype hp,
  refine (primcodable.prim (subtype p)).of_eq (λ n, _),
  rcases decode (subtype p) n with _|⟨a,h⟩; refl
end

theorem subtype_val_iff {p : β → Prop} [decidable_pred p]
  {hp : primrec_pred p} {f : α → subtype p} :
  by haveI := primcodable.subtype hp; exact
  primrec (λ a, (f a).1) ↔ primrec f :=
begin
  letI := primcodable.subtype hp,
  refine ⟨λ h, _, λ hf, subtype_val.comp hf⟩,
  refine nat.primrec.of_eq h (λ n, _),
  cases decode α n with a, {refl},
  simp, cases f a; refl
end

theorem subtype_mk {p : β → Prop} [decidable_pred p] {hp : primrec_pred p}
  {f : α → β} {h : ∀ a, p (f a)} (hf : primrec f) :
  by haveI := primcodable.subtype hp; exact
  primrec (λ a, @subtype.mk β p (f a) (h a)) :=
subtype_val_iff.1 hf

theorem option_get {f : α → option β} {h : ∀ a, (f a).is_some} :
  primrec f → primrec (λ a, option.get (h a)) :=
begin
  intro hf,
  refine (nat.primrec.pred.comp hf).of_eq (λ n, _),
  generalize hx : decode α n = x,
  cases x; simp
end

theorem ulower_down : primrec (ulower.down : α → ulower α) :=
by letI : ∀ a, decidable (a ∈ set.range (encode : α → ℕ)) := decidable_range_encode _; exact
subtype_mk primrec.encode

theorem ulower_up : primrec (ulower.up : ulower α → α) :=
by letI : ∀ a, decidable (a ∈ set.range (encode : α → ℕ)) := decidable_range_encode _; exact
option_get (primrec.decode₂.comp subtype_val)

theorem fin_val_iff {n} {f : α → fin n} :
  primrec (λ a, (f a).1) ↔ primrec f :=
begin
  let : primcodable {a//id a<n}, swap,
  exactI (iff.trans (by refl) subtype_val_iff).trans (of_equiv_iff _)
end

theorem fin_val {n} : primrec (coe : fin n → ℕ) := fin_val_iff.2 primrec.id

theorem fin_succ {n} : primrec (@fin.succ n) :=
fin_val_iff.1 $ by simp [succ.comp fin_val]

theorem vector_to_list {n} : primrec (@vector.to_list α n) := subtype_val

theorem vector_to_list_iff {n} {f : α → vector β n} :
  primrec (λ a, (f a).to_list) ↔ primrec f := subtype_val_iff

theorem vector_cons {n} : primrec₂ (@vector.cons α n) :=
vector_to_list_iff.1 $ by simp; exact
list_cons.comp fst (vector_to_list_iff.2 snd)

theorem vector_length {n} : primrec (@vector.length α n) := const _

theorem vector_head {n} : primrec (@vector.head α n) :=
option_some_iff.1 $
(list_head'.comp vector_to_list).of_eq $ λ ⟨a::l, h⟩, rfl

theorem vector_tail {n} : primrec (@vector.tail α n) :=
vector_to_list_iff.1 $ (list_tail.comp vector_to_list).of_eq $
λ ⟨l, h⟩, by cases l; refl

theorem vector_nth {n} : primrec₂ (@vector.nth α n) :=
option_some_iff.1 $
(list_nth.comp (vector_to_list.comp fst) (fin_val.comp snd)).of_eq $
λ a, by simp [vector.nth_eq_nth_le]; rw [← list.nth_le_nth]

theorem list_of_fn : ∀ {n} {f : fin n → α → σ},
  (∀ i, primrec (f i)) → primrec (λ 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, primrec (f i)) : primrec (λ a, vector.of_fn (λ i, f i a)) :=
vector_to_list_iff.1 $ by simp [list_of_fn hf]

theorem vector_nth' {n} : primrec (@vector.nth α n) := of_equiv_symm

theorem vector_of_fn' {n} : primrec (@vector.of_fn α n) := of_equiv

theorem fin_app {n} : primrec₂ (@id (fin n → σ)) :=
(vector_nth.comp (vector_of_fn'.comp fst) snd).of_eq $
λ ⟨v, i⟩, by simp

theorem fin_curry₁ {n} {f : fin n → α → σ} : primrec₂ f ↔ ∀ i, primrec (f i) :=
⟨λ h i, h.comp (const i) primrec.id,
 λ h, (vector_nth.comp ((vector_of_fn h).comp snd) fst).of_eq $ λ a, by simp⟩

theorem fin_curry {n} {f : α → fin n → σ} : primrec f ↔ primrec₂ f :=
⟨λ h, fin_app.comp (h.comp fst) snd,
 λ h, (vector_nth'.comp (vector_of_fn (λ i,
    show primrec (λ a, f a i), from
    h.comp primrec.id (const i)))).of_eq $
  λ a, by funext i; simp⟩

end primrec

namespace nat
open vector

/-- An alternative inductive definition of `primrec` which
  does not use the pairing function on ℕ, and so has to
  work with n-ary functions on ℕ instead of unary functions.
  We prove that this is equivalent to the regular notion
  in `to_prim` and `of_prim`. -/
inductive primrec' : ∀ {n}, (vector ℕ n → ℕ) → Prop
| zero : @primrec' 0 (λ _, 0)
| succ : @primrec' 1 (λ v, succ v.head)
| nth {n} (i : fin n) : primrec' (λ v, v.nth i)
| comp {m n f} (g : fin n → vector ℕ m → ℕ) :
  primrec' f → (∀ i, primrec' (g i)) →
  primrec' (λ a, f (of_fn (λ i, g i a)))
| prec {n f g} : @primrec' n f → @primrec' (n+2) g →
  primrec' (λ v : vector ℕ (n+1),
    v.head.elim (f v.tail) (λ y IH, g (y ::ᵥ IH ::ᵥ v.tail)))

end nat

namespace nat.primrec'
open vector primrec nat (primrec') nat.primrec'
hide ite

theorem to_prim {n f} (pf : @primrec' n f) : primrec f :=
begin
  induction pf,
  case nat.primrec'.zero { exact const 0 },
  case nat.primrec'.succ { exact primrec.succ.comp vector_head },
  case nat.primrec'.nth : n i
  { exact vector_nth.comp primrec.id (const i) },
  case nat.primrec'.comp : m n f g _ _ hf hg
  { exact hf.comp (vector_of_fn (λ i, hg i)) },
  case nat.primrec'.prec : n f g _ _ hf hg
  { exact nat_elim' vector_head (hf.comp vector_tail) (hg.comp $
      vector_cons.comp (fst.comp snd) $
      vector_cons.comp (snd.comp snd) $
      (@vector_tail _ _ (n+1)).comp fst).to₂ },
end

theorem of_eq {n} {f g : vector ℕ n → ℕ}
  (hf : primrec' f) (H : ∀ i, f i = g i) : primrec' g :=
(funext H : f = g) ▸ hf

theorem const {n} : ∀ m, @primrec' n (λ v, m)
| 0     := zero.comp fin.elim0 (λ i, i.elim0)
| (m+1) := succ.comp _ (λ i, const m)

theorem head {n : ℕ} : @primrec' n.succ head :=
(nth 0).of_eq $ λ v, by simp [nth_zero]

theorem tail {n f} (hf : @primrec' n f) : @primrec' n.succ (λ v, f v.tail) :=
(hf.comp _ (λ i, @nth _ i.succ)).of_eq $
λ v, by rw [← of_fn_nth v.tail]; congr; funext i; simp

def vec {n m} (f : vector ℕ n → vector ℕ m) :=
∀ i, primrec' (λ v, (f v).nth i)

protected theorem nil {n} : @vec n 0 (λ _, nil) := λ i, i.elim0

protected theorem cons {n m f g}
  (hf : @primrec' n f) (hg : @vec n m g) :
  vec (λ v, (f v ::ᵥ g v)) :=
λ i, fin.cases (by simp *) (λ i, by simp [hg i]) i

theorem idv {n} : @vec n n id := nth

theorem comp' {n m f g}
  (hf : @primrec' m f) (hg : @vec n m g) :
  primrec' (λ v, f (g v)) :=
(hf.comp _ hg).of_eq $ λ v, by simp

theorem comp₁ (f : ℕ → ℕ) (hf : @primrec' 1 (λ v, f v.head))
  {n g} (hg : @primrec' n g) : primrec' (λ v, f (g v)) :=
hf.comp _ (λ i, hg)

theorem comp₂ (f : ℕ → ℕ → ℕ)
  (hf : @primrec' 2 (λ v, f v.head v.tail.head))
  {n g h} (hg : @primrec' n g) (hh : @primrec' n h) :
  primrec' (λ v, f (g v) (h v)) :=
by simpa using hf.comp' (hg.cons $ hh.cons primrec'.nil)

theorem prec' {n f g h}
  (hf : @primrec' n f) (hg : @primrec' n g) (hh : @primrec' (n+2) h) :
  @primrec' n (λ v, (f v).elim (g v)
    (λ (y IH : ℕ), h (y ::ᵥ IH ::ᵥ v))) :=
by simpa using comp' (prec hg hh) (hf.cons idv)

theorem pred : @primrec' 1 (λ v, v.head.pred) :=
(prec' head (const 0) head).of_eq $
λ v, by simp; cases v.head; refl

theorem add : @primrec' 2 (λ v, v.head + v.tail.head) :=
(prec head (succ.comp₁ _ (tail head))).of_eq $
λ v, by simp; induction v.head; simp [*, nat.succ_add]

theorem sub : @primrec' 2 (λ v, v.head - v.tail.head) :=
begin
  suffices, simpa using comp₂ (λ a b, b - a) this (tail head) head,
  refine (prec head (pred.comp₁ _ (tail head))).of_eq (λ v, _),
  simp, induction v.head; simp [*, nat.sub_succ]
end

theorem mul : @primrec' 2 (λ v, v.head * v.tail.head) :=
(prec (const 0) (tail (add.comp₂ _ (tail head) (head)))).of_eq $
λ v, by simp; induction v.head; simp [*, nat.succ_mul]; rw add_comm

theorem if_lt {n a b f g}
  (ha : @primrec' n a) (hb : @primrec' n b)
  (hf : @primrec' n f) (hg : @primrec' n g) :
  @primrec' n (λ v, if a v < b v then f v else g v) :=
(prec' (sub.comp₂ _ hb ha) hg (tail $ tail hf)).of_eq $
λ v, begin
  cases e : b v - a v,
  { simp [not_lt.2 (tsub_eq_zero_iff_le.mp e)] },
  { simp [nat.lt_of_sub_eq_succ e] }
end

theorem mkpair : @primrec' 2 (λ v, v.head.mkpair v.tail.head) :=
if_lt head (tail head)
  (add.comp₂ _ (tail $ mul.comp₂ _ head head) head)
  (add.comp₂ _ (add.comp₂ _
    (mul.comp₂ _ head head) head) (tail head))

protected theorem encode : ∀ {n}, @primrec' n encode
| 0     := (const 0).of_eq (λ v, by rw v.eq_nil; refl)
| (n+1) := (succ.comp₁ _ (mkpair.comp₂ _ head (tail encode)))
  .of_eq $ λ ⟨a::l, e⟩, rfl

theorem sqrt : @primrec' 1 (λ v, v.head.sqrt) :=
begin
  suffices H : ∀ n : ℕ, n.sqrt = n.elim 0 (λ x y,
    if x.succ < y.succ*y.succ then y else y.succ),
  { simp [H],
    have := @prec' 1 _ _ (λ v,
      by have x := v.head; have y := v.tail.head; from
      if x.succ < y.succ*y.succ then y else y.succ) head (const 0) _,
    { convert this, funext, congr, funext x y, congr; simp },
    have x1 := succ.comp₁ _ head,
    have y1 := succ.comp₁ _ (tail head),
    exact if_lt x1 (mul.comp₂ _ y1 y1) (tail head) y1 },
  intro, symmetry,
  induction n with n IH, {simp},
  dsimp, rw IH, split_ifs,
  { exact le_antisymm (nat.sqrt_le_sqrt (nat.le_succ _))
      (nat.lt_succ_iff.1 $ nat.sqrt_lt.2 h) },
  { exact nat.eq_sqrt.2 ⟨not_lt.1 h, nat.sqrt_lt.1 $
      nat.lt_succ_iff.2 $ nat.sqrt_succ_le_succ_sqrt _⟩ },
end

theorem unpair₁ {n f} (hf : @primrec' n f) :
  @primrec' n (λ v, (f v).unpair.1) :=
begin
  have s := sqrt.comp₁ _ hf,
  have fss := sub.comp₂ _ hf (mul.comp₂ _ s s),
  refine (if_lt fss s fss s).of_eq (λ v, _),
  simp [nat.unpair], split_ifs; refl
end

theorem unpair₂ {n f} (hf : @primrec' n f) :
  @primrec' n (λ v, (f v).unpair.2) :=
begin
  have s := sqrt.comp₁ _ hf,
  have fss := sub.comp₂ _ hf (mul.comp₂ _ s s),
  refine (if_lt fss s s (sub.comp₂ _ fss s)).of_eq (λ v, _),
  simp [nat.unpair], split_ifs; refl
end

theorem of_prim : ∀ {n f}, primrec f → @primrec' n f :=
suffices ∀ f, nat.primrec f → @primrec' 1 (λ v, f v.head), from
λ n f hf, (pred.comp₁ _ $ (this _ hf).comp₁
  (λ m, encodable.encode $ (decode (vector ℕ n) m).map f)
    primrec'.encode).of_eq (λ i, by simp [encodek]),
λ f hf, begin
  induction hf,
  case nat.primrec.zero { exact const 0 },
  case nat.primrec.succ { exact succ },
  case nat.primrec.left { exact unpair₁ head },
  case nat.primrec.right { exact unpair₂ head },
  case nat.primrec.pair : f g _ _ hf hg
  { exact mkpair.comp₂ _ hf hg },
  case nat.primrec.comp : f g _ _ hf hg
  { exact hf.comp₁ _ hg },
  case nat.primrec.prec : f g _ _ hf hg
  { simpa using prec' (unpair₂ head)
      (hf.comp₁ _ (unpair₁ head))
      (hg.comp₁ _ $ mkpair.comp₂ _ (unpair₁ $ tail $ tail head)
        (mkpair.comp₂ _ head (tail head))) },
end

theorem prim_iff {n f} : @primrec' n f ↔ primrec f := ⟨to_prim, of_prim⟩

theorem prim_iff₁ {f : ℕ → ℕ} :
  @primrec' 1 (λ v, f v.head) ↔ primrec f :=
prim_iff.trans ⟨
  λ h, (h.comp $ vector_of_fn $ λ i, primrec.id).of_eq (λ v, by simp),
  λ h, h.comp vector_head⟩

theorem prim_iff₂ {f : ℕ → ℕ → ℕ} :
  @primrec' 2 (λ v, f v.head v.tail.head) ↔ primrec₂ f :=
prim_iff.trans ⟨
  λ h, (h.comp $ vector_cons.comp fst $
    vector_cons.comp snd (primrec.const nil)).of_eq (λ v, by simp),
  λ h, h.comp vector_head (vector_head.comp vector_tail)⟩

theorem vec_iff {m n f} :
  @vec m n f ↔ primrec f :=
⟨λ h, by simpa using vector_of_fn (λ i, to_prim (h i)),
 λ h i, of_prim $ vector_nth.comp h (primrec.const i)⟩

end nat.primrec'

theorem primrec.nat_sqrt : primrec nat.sqrt :=
nat.primrec'.prim_iff₁.1 nat.primrec'.sqrt


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

/-!
# Injectivity of `int.cast` into characteristic zero rings and fields.

-/

variables {α : Type*}

open nat

namespace int

@[simp]
theorem cast_eq_zero [add_group_with_one α] [char_zero α] {n : ℤ} : (n : α) = 0 ↔ n = 0 :=
⟨λ h, begin cases n,
  { rw [int.cast_of_nat] at h, exact congr_arg coe (nat.cast_eq_zero.1 h) },
  { rw [cast_neg_succ_of_nat, neg_eq_zero, nat.cast_eq_zero] at h,
    contradiction }
end, λ h, by rw [h, cast_zero]⟩

@[simp, norm_cast] theorem cast_inj [add_group_with_one α] [char_zero α] {m n : ℤ} :
  (m : α) = n ↔ m = n :=
by rw [← sub_eq_zero, ← cast_sub, cast_eq_zero, sub_eq_zero]

theorem cast_injective [add_group_with_one α] [char_zero α] : function.injective (coe : ℤ → α)
| m n := cast_inj.1

theorem cast_ne_zero [add_group_with_one α] [char_zero α] {n : ℤ} : (n : α) ≠ 0 ↔ n ≠ 0 :=
not_congr cast_eq_zero

@[simp, norm_cast]
theorem cast_div_char_zero {k : Type*} [field k] [char_zero k] {m n : ℤ}
  (n_dvd : n ∣ m) : ((m / n : ℤ) : k) = m / n :=
begin
  rcases eq_or_ne n 0 with rfl | hn,
  { simp [int.div_zero] },
  { exact cast_div n_dvd (cast_ne_zero.mpr hn), },
end

end int

lemma ring_hom.injective_int {α : Type*} [non_assoc_ring α] (f : ℤ →+* α) [char_zero α] :
  function.injective f :=
subsingleton.elim (int.cast_ring_hom _) f ▸ int.cast_injective


import analysis.real tactic.ring tactic.interactive
import seq naturally background

open set

namespace hw2

namespace problem1

-- (1) Give an example (with proof) of a countable bounded subset A ⊂ ℝ
--     whose inf and sup are both in ℝ \ A.

-- I'm going to start with the harmonic sequence, bounded between 0 and 1
-- (but never reaching a value of 0).
def harmonic := {x : ℝ | ∃ n:ℕ+, x = 1/n}

def harmonic_inf : ℝ := 0
def harmonic_sup : ℝ := 1

lemma harmonic_inf_proof : is_glb harmonic harmonic_inf :=
  begin
  unfold is_glb is_greatest lower_bounds upper_bounds,
  constructor,
  show ∀ (a : ℝ), a ∈ harmonic → harmonic_inf ≤ a,
  simp [harmonic],
  suffices : ∀ (x : ℕ+), (0 : ℝ) ≤ (↑↑x)⁻¹,
    intro a, intro x, intro a_x, rw a_x, exact this x,
  intro x, apply le_of_lt, apply inv_pos,
  cases x, simp, exact x_property,
  simp [harmonic, harmonic_inf],
  intro a, intro a_lb,
  apply le_of_not_lt, intro a_pos,
  let := exists_nat_gt (a⁻¹),
  apply exists.elim this, intros n h,
  have : (n : ℝ) > 0, transitivity, exact h, exact inv_pos a_pos,
  have : n > 0, rw [← nat.cast_zero] at this, exact nat.cast_lt.1 this,
  have h' := (inv_lt_inv _ _).2 h, rw @inv_inv' _ _ a at h',
  have := a_lb _ ⟨n, _⟩ rfl, simp at this,
  have := lt_of_le_of_lt this h',
  exact lt_irrefl a this, cc,
  show ↑n > (0 : ℝ), cc,
  apply inv_pos a_pos,
  end

lemma harmonic_sup_proof : is_lub harmonic harmonic_sup :=
  begin
  unfold is_lub is_least upper_bounds lower_bounds,
  constructor,
  show ∀ (a : ℝ), a ∈ harmonic → a ≤ 1,
  unfold harmonic, simp,
  suffices : ∀ (x : ℕ+), (↑↑x)⁻¹ ≤ (1 : ℝ),
    intro a, intro x, intro a_x, rw a_x, exact this x,
  intro x, cases x, simp,
  cases x_val, exfalso, exact ne_of_lt x_property rfl,
  induction x_val with n ih, exact le_of_eq inv_one,
  transitivity,
  refine (inv_le_inv _ _).2 _,
  exact ↑(nat.succ n),
  suffices : 0 < n + 2,
    rw [← nat.cast_zero],
    exact nat.cast_lt.2 this,
  exact nat.zero_lt_succ _,
  suffices : 0 < n + 1,
    rw [← nat.cast_zero],
    exact nat.cast_lt.2 this,
  exact nat.zero_lt_succ _,
  rw nat.cast_le, exact nat.le_succ _,
  exact ih (nat.zero_lt_succ _),
  simp [harmonic, harmonic_sup],
  intro a, intro a_ub,
  have a_ub_1 := a_ub _ 1 rfl, simp at a_ub_1,
  exact a_ub_1,
  end

-- And if we make it alternate sign, then it will approach ±1, but
-- never reach those
def A := {x:ℝ | ∃ n:ℕ+, x = signed n * (1 - 1/n)}

def A_inf : ℝ := -1
def A_sup : ℝ := 1

lemma A_inf_proof : is_glb A A_inf :=
  begin
  unfold is_glb is_greatest lower_bounds upper_bounds,
  constructor,
  show ∀ (a : ℝ), a ∈ A → -1 ≤ a,
  unfold A, simp,
  suffices : ∀ (n : ℕ+), (-1 : ℝ) ≤ signed n * (1 - (n : ℝ)⁻¹),
    intro a, intro x, intro a_x, rw a_x, exact this x,
  intro n,
  have n_mod_2 := nat.mod_two_eq_zero_or_one n,
  cases n_mod_2,
  have := nat.dvd_of_mod_eq_zero n_mod_2,
  cases this with n', rw this_h, rw signed_even,
  suffices : (↑(2 * n') : ℝ)⁻¹ ≤ 1,
    simp, simp at this,
    apply le_add_of_neg_add_le, ring, apply neg_le_neg,
    simp [this_h],
    transitivity, exact this, exact le_of_lt one_lt_two,
  apply harmonic_sup_proof.1, simp [harmonic],
  existsi n, simp [this_h],
  rw [← nat.mod_add_div n 2, n_mod_2],
  rw [add_comm 1 _, signed_odd], simp,
  apply harmonic_inf_proof.1,
  existsi n, simp,
  simp [A_inf], intro a, simp [A], intro a_lb,
  have := harmonic_inf_proof.2 (a+1)
    begin
    intros v v_h,
    apply exists.elim v_h, intros n n_h, rw n_h,
    have n_mod_2 := nat.mod_two_eq_zero_or_one n,
    cases n_mod_2,
    {
      have := nat.dvd_of_mod_eq_zero n_mod_2,
      cases this with n',
      apply add_le_of_le_sub_right,
      transitivity,
      apply a_lb _ (2*n'+1).to_pnat' rfl,
      rw [(@pnat.to_pnat'_coe (2*n'+1) dec_trivial)],
      rw [signed_odd, int.cast_neg, int.cast_one, ← this_h],
      simp, rw inv_le_inv,
      apply le_add_of_sub_right_le, simp, exact zero_le_one,
      rw [← nat.cast_zero, ← nat.cast_one, ← nat.cast_add, nat.cast_lt, add_comm],
      exact nat.zero_lt_succ _,
      rw [← nat.cast_zero, nat.cast_lt],
      exact pnat.pos n,
    }, {
      have : (n : ℕ) = 2*(n/2)+1,
        begin
        transitivity,
        symmetry,
        exact nat.mod_add_div n 2,
        rw [add_comm, n_mod_2],
        end,
      apply add_le_of_le_sub_right,
      transitivity,
      apply a_lb _ (2*(↑n/2)+1 : ℕ).to_pnat' rfl,
      rw [(@pnat.to_pnat'_coe (2*(↑n/2)+1 : ℕ) dec_trivial)],
      rw [signed_odd, ← this, int.cast_neg, int.cast_one],
      simp,
    }
    end,
  transitivity,
  apply le_add_of_sub_left_le,
  rw [← neg_neg (1 : ℝ)] at this,
  exact this,
  simp [harmonic_inf],
  end

end problem1

namespace problem2

-- (2) If A is a nonempty bounded subset of ℝ, and B is the set of all
--     upper bounds for A, prove: inf B = sup A

open lattice

-- this is kind of ugly, mixing variables and constants
-- I think it forces me to annotate the types of the sets
-- (so it knows what the variable α should be),
-- but I think that's better than parameterizing B over A.
variable {α : Type}
variable [_inst_1 : conditionally_complete_lattice α]
constant A : set α
constant A_nonempty : (A : set α) ≠ ∅
constant A_bdd_above : bdd_above (A : set α)
constant A_bdd_below : bdd_below (A : set α)
def B : set α := upper_bounds A

-- The implementation of is_lub is instructive
#print is_lub
#print is_least
-- That is, a least upper bound is an upper bound which is
-- a lower bounds on the upper bounds.
-- So it makes sense that Inf B and Sup A both represent the
-- exact boundary between these sets, informally speaking,
-- so they will be equal.

-- This already exists
#check exists_mem_of_ne_empty
#check cInf_lower_bounds_eq_cSup
-- Here's another proof of it
lemma proof : Inf (B : set α) = Sup (A : set α) :=
  begin
  -- B is bounded below by Sup A, since B consists of upper bounds
  -- and Sup A is the _least_ upper bound.
  have B_bdd_below : bdd_below (B : set α),
    begin
    unfold B upper_bounds,
    existsi (Sup (A : set α)), intros y y_upper_bound,
    simp at y_upper_bound,
    apply cSup_le A_nonempty y_upper_bound,
    end,
  -- B is nonempty, from the proof that A is bounded above.
  have B_nonempty : (B : set α) ≠ ∅ :=
    set.ne_empty_iff_exists_mem.2 A_bdd_above,
  apply le_antisymm,
  {
    -- Inf B ≤ Sup A since Sup A ∈ B and Inf is a lower bound
    apply cInf_le B_bdd_below,
    simp [B, upper_bounds],
    intros a a_mem_A,
    exact le_cSup A_bdd_above a_mem_A,
  }, {
    -- Sup A ≤ Inf B since Inf is the greatest lower bound of B and
    -- Sup A is a lower bound of B (aka the upper bounds of A)
    apply le_cInf B_nonempty,
    intros b b_mem_B,
    apply cSup_le A_nonempty,
    intros a a_mem_A,
    exact b_mem_B a a_mem_A,
  },
  end

end problem2

namespace problem3

-- Helper lemma
lemma eq_singleton_of_nonempty_of_subset_singleton
  {α : Type} {A : set α} {a : α} : A ≠ ∅ → A ⊆ {a} → A = {a} :=
  begin
  intro A_nonempty, intro A_subset_singleton,
  rw subset_def at A_subset_singleton,
  have := exists_mem_of_ne_empty A_nonempty,
  apply exists.elim this, intros b b_mem,
  apply set.ext,
  intro x,
  constructor,
  exact A_subset_singleton x,
  intro x_mem, rw mem_singleton_iff at x_mem, rw x_mem,
  have : b = a := eq_of_mem_singleton (A_subset_singleton _ b_mem),
  rw this at b_mem, exact b_mem,
  end

-- (3) If A is a nonempty bounded subset of R and inf A = sup A, what can you say about A? Give proof.

open lattice

variable {α : Type}
variable [_inst_1 : conditionally_complete_lattice α]
constant A : set α
constant A_nonempty : (A : set α) ≠ ∅
constant A_bdd_above : bdd_above (A : set α)
constant A_bdd_below : bdd_below (A : set α)

-- A must be a singleton set {a}, thus a = Inf A = Sup A
lemma proof (a : α) (a_Inf : a = Inf A) (a_Sup : a = Sup A) : (A : set α) = {a} :=
  begin
  -- a must be the least upper bound
  have a_lub : is_lub A a,
    rw a_Sup, constructor,
    simp [upper_bounds],
    intro a, exact le_cSup A_bdd_above,
    simp [lower_bounds, upper_bounds],
    intro a, exact cSup_le A_nonempty,
  -- and the greatest lower bound
  have a_glb : is_glb A a,
    rw a_Inf, constructor,
    simp [lower_bounds],
    intro a, exact cInf_le A_bdd_below,
    simp [upper_bounds, lower_bounds],
    intro a, exact le_cInf A_nonempty,
  apply eq_singleton_of_nonempty_of_subset_singleton A_nonempty,
  rw subset_def, simp only [mem_singleton_iff],
  -- we need to show that any element x in the set is just a
  intro x,
  intro x_in_A,
  -- so we show it is ≤ a and ≥ a, since a is sup and inf
  apply le_antisymm,
  exact a_lub.1 _ x_in_A,
  exact a_glb.1 _ x_in_A,
  end

end problem3

namespace problem4

-- (4) Prove that the sequence {n − 1/n}∞n=1 does not have a limit.
noncomputable def s : seq ℝ := λ n, n - n⁻¹

lemma s_pos : ∀ n, s (n+2) > 0 :=
  begin
  intro n, unfold s,
  rw [← sub_self (2 : ℝ)],
  apply sub_lt_sub_of_le_of_lt,
  natureally,
  apply lt_of_le_of_lt,
  apply problem1.harmonic_sup_proof.1,
  simp [problem1.harmonic],
  existsi (⟨n+2, nat.succ_pos _⟩ : ℕ+),
  simp,
  simp only [problem1.harmonic_sup], natureally,
  end

-- It suffices to show that the sequence is not bounded, so,
-- given a real number, illustrate an index where the sequence
-- is actually larger than it.
lemma proof : ¬converges s :=
  begin
  intro c, exfalso,
  suffices : ¬∃ M, ∀ n, M > norm (s n),
    exact this (bounded_of_converges c),
  intro ex, apply exists.elim ex, intros M bound,
  simp [s, real.norm_eq_abs] at bound,
  cases h : ceil M,
    -- if the ceiling is a positive value a, use a+2 as the index.
    have : M ≤ abs (↑(a+2) + -(↑(a+2))⁻¹),
      begin
      rw abs_of_pos,
      transitivity,
      exact le_ceil M, rw h,
      simp,
      apply le_of_sub_nonneg, simp,
      rw [← sub_self (1 : ℝ), ← sub_eq_add_neg],
      apply sub_le_sub, exact le_of_lt one_lt_two,
      apply problem1.harmonic_sup_proof.1,
      simp [problem1.harmonic],
      existsi (⟨a+2, nat.succ_pos _⟩ : ℕ+),
      simp,
      apply s_pos,
      end,
      exact not_le_of_gt (bound (a+2)) this,
    -- otherwise, if it is negative, use the index 0
    have : M < 0,
      begin
      apply lt_of_le_of_lt,
      exact le_ceil M, rw h,
      rw [int.cast_lt_zero],
      unfold has_lt.lt int.lt,
      rw [int.neg_succ_of_nat_eq'],
      simp,
      end,
      exact not_lt_of_gt this (lt_of_le_of_lt (abs_nonneg _) (bound 0)),
  end

end problem4

local infix `⟶`:50 := converges_to

lemma converges_of_bdd_not_decr (s : seq ℝ) :
  bdd_above {x : ℝ | ∃ n, x = s n} → (∀ n, s n ≤ s (n+1)) → converges s := sorry

lemma converges_to_cSup (s : seq ℝ) : (∀ n, s n ≤ s (n+1)) → s ⟶ lattice.Sup {x : ℝ | ∃ n, x = s n} := sorry

namespace problem5

-- (5) Prove that if {|sn|}∞n=1 converges to 0 then {sn}∞n=1 converges to 0 also.

-- This can actually be a biconditional; it is true almost by definition.
lemma proof (s : seq ℝ) : abs ∘ s ⟶ 0 ↔ s ⟶ 0 :=
  begin
  simp [converges_to.def],
  suffices : ∀ n, norm (abs (s n)) = norm (s n), simp only [this],
  intro n, rw real.norm_eq_abs, rw real.norm_eq_abs,
  exact abs_abs _,
  end

end problem5

noncomputable def alternating (s : seq ℝ) : seq ℝ := λ n, signed n * s n

namespace problem6

-- (6) Suppose {sn}∞n=1 converges to 0. Prove that {(−1)^n*sn}∞n=1 converges to 0 also.

-- This again is a biconditional along the same lines.
lemma proof (s : seq ℝ) : s ⟶ 0 ↔ alternating s ⟶ 0 :=
  begin
  simp only [converges_to.def],
  suffices : ∀ n, dist (s n) 0 = dist (alternating s n) 0, simp only [this],
  intro n, rw real.dist_0_eq_abs, rw real.dist_0_eq_abs,
  simp [alternating],
  cases signed_cases n; simp [h]
  end

end problem6

namespace problem7

-- (7) Suppose {sn}∞n=1 is a sequence of positive numbers with the property that sn+1 < (1/2)sn for all n ∈ N. Prove that limn→∞ sn = 0. How would you change your proof if 1/2 was replaced by a fixed number x ∈ (0, 1)?

-- So it's actually easier if I do the more abstract version ...
variable r : ℝ
variable r_in_0_1 : r ∈ (Ioo 0 1 : set ℝ)

-- whoops, we don't have these functions ...
def powℝ (b : ℝ) (p : ℝ) : ℝ := sorry
def log_base (b : ℝ) (x : ℝ) : ℝ := sorry
lemma log_pow (b p : ℝ) : log_base b (powℝ b p) = p := sorry
lemma pow_log (b p : ℝ) : powℝ b (log_base b p) = p := sorry

include r_in_0_1
lemma proof (s : seq ℝ) : (∀ n, abs (s (n+1)) < r*abs (s n)) → s ⟶ 0 :=
  begin
  simp only [converges_to.def],
  intro prop,
  -- This uses transitivity to compare it with a geometric sequence
  have : ∀ n, abs (s n) ≤ r^n * abs (s 0),
    intro n,
    cases n with n, simp,
    induction n with n ih,
    { have := prop 0, apply le_of_lt, simpa },
    transitivity,
    apply le_of_lt,
    apply prop,
    rw pow_succ r,
    rw mul_assoc,
    apply (mul_le_mul_left r_in_0_1.1).2,
    exact ih,
  -- now we just need to ensure it is less than ε
  -- solve: (r^n * s 0 < ε) ← (n > log_base r (ε / s 0)), with 0 < r < 1
  intros ε ε_pos,
  have get_N := exists_nat_gt (log_base r (ε / abs (s 0))),
  apply exists_imp_exists _ get_N,
  intro N, intro N_gt, intro n, intro n_ge,
  rw real.dist_0_eq_abs,
  apply lt_of_le_of_lt,
  exact this n,
  have : (N : ℝ) ≤ (n : ℝ), rw nat.cast_le, exact n_ge,
  have := lt_of_lt_of_le N_gt this,
  suffices finishing : log_base r (ε / abs (s 0)) < n → r ^ n * abs (s 0) < ε,
    exact finishing this,
  -- can't prove this in Lean
  admit,
  end

end problem7

namespace problem8

noncomputable theory

-- (8) Suppose limn→∞ (s n − 1)/(s n + 1) = 0. Prove that limn→∞ s n = 1.
variable (s : seq ℝ)
def ratio : seq ℝ := λ n, (s n - 1)/(s n + 1)

open classical
local attribute [instance] prop_decidable

-- I don't know how to show that it converges ...
-- but assuming it converges, and is never equal to -1,
-- and does not approach -1, it would be easy enough
-- to appeal to the algebraic limit theorems to say that
--   lim (s n - 1) = 0 * lim (s n + 1) = 0
--   lim s n = 0 + 1 = 1
lemma proof : (ratio s ⟶ 0) → (s ⟶ 1) := sorry

end problem8

namespace problem9

-- sorry constructivism ... I tried
noncomputable theory
open real

-- (9) Let s1 = √2 and let sn+1 = √2 ·√sn for n ≥ 1.
--     (a) Prove, by induction, that sn ≤ 2 for all n.
--     (b) Prove that sn+1 ≥ sn for all n.
--     (c) Prove that {sn}∞n=1 is convergent.
--     (d) Prove that limn→∞ sn = 2.

noncomputable def s : seq ℝ
| 0 := 1
| (n+1) := sqrt 2 * sqrt (s n)
@[simp] lemma s_0 : s 0 = 1 := rfl
@[simp] lemma s_1 : s 1 = sqrt 2 := by simp [s]
@[simp] lemma s_succ_n : ∀ n, s (n+1) = sqrt 2*sqrt (s n) :=
  by intro n; unfold s

lemma s_pos : ∀ n, 0 < s n :=
  begin
  intro n, induction n with n ih,
  exact zero_lt_one, simp,
  have : 0 < sqrt (s n),
    rw sqrt_pos, exact ih,
  apply mul_pos _ this,
  show 0 < sqrt 2, rw sqrt_pos, exact two_pos,
  end

-- The base case reduces to this ... not fun.
lemma ugh : sqrt (2 * sqrt 2) ≥ 3/2 :=
  begin
  rw [← @sqrt_sqr (3/2)],
  apply (sqrt_le _ _).2,
  unfold pow monoid.pow, simp, rw [div_mul_div, mul_comm _ (sqrt 2)],
  apply le_mul_of_div_le two_pos, ring,
  rw [← @sqrt_sqr (9/8)],
  apply (sqrt_le _ _).2,
  unfold pow monoid.pow, ring,
  apply div_le_of_le_mul,
  show (81 : ℝ) ≤ 64 * 2,
  transitivity,
  { show (81 : ℝ) ≤ 128, norm_num, natureally },
  { apply le_of_eq, ring },
  show 0 ≤ 2 * sqrt 2,
  {
    apply mul_nonneg, tactic.swap, apply sqrt_nonneg, repeat { exact le_of_lt two_pos },
  },
  any_goals { unfold pow monoid.pow, rw [mul_one, div_mul_div] },
  all_goals { norm_num },
  end

-- Trust me, this looks a lot easier since I created natureally.
lemma sigh : ∀ (n : ℕ), @has_le.le ℝ _ ((n+2)+2*(n+3)^2) (4*(n+2)*(n+3)) :=
    begin
    intro n,
    ring, rw [right_distrib, right_distrib],
    apply le_of_sub_nonneg,
    ring, natureally
    end

-- This is the main lemma for proving that s converges to 2
-- by comparing it to the easy harmonic sequence.
-- 2 - s n < ε ... n > 1/ε
lemma s_sup : ∀ n : {n : ℕ // n > 1}, s n ≥ 2 - 1/n :=
  begin
  intro n,
  cases n with n n_pos,
  cases n, exfalso, exact not_lt_of_ge (nat.zero_le 1) n_pos,
  cases n, exfalso, exact lt_irrefl 1 n_pos,
  induction n with n ih,
  simp, rw [← sqrt_mul (le_of_lt two_pos), one_add_one_eq_two],
  have : @eq ℝ (2 + -2⁻¹) (3/2),
  {
    apply eq_div_of_mul_eq _ _ two_ne_zero,
    rw [right_distrib, neg_mul_eq_neg_mul_symm, inv_mul_cancel two_ne_zero],
    refl,
  },
  rw this,
  exact ugh,
  simp,
  have n_1_1 : @eq ℝ (1 + (1 + ↑n)) ↑(n+2),
  {
    natureally, simp,
  },
  rw n_1_1,
  have m_1 : ∀ (m : ℕ), @eq ℝ (1 + ↑m) ↑(m+1),
  {
    intro m,
    natureally, simp,
  },
  have n_2 : @eq ℝ (2 + ↑n) ↑(n+2),
  {
    natureally, simp,
  },
  rw m_1 (n+2),
  show (2 : ℝ) + -(↑(n + 3))⁻¹ ≤ sqrt 2 * sqrt (sqrt 2 * sqrt (sqrt 2 * sqrt (s n))),
  have ih' := mul_le_mul (le_refl (sqrt 2)) ((sqrt_le _ _).2 (ih dec_trivial)) _ _,
  simp at ih',
  rw n_1_1 at ih',
  refine le_trans _ ih',
  rw ← sqrt_mul, transitivity, apply le_of_eq, symmetry,
  apply sqrt_sqr _, tactic.swap,
  rw sqrt_le,
  unfold pow monoid.pow, simp,
  rw [left_distrib, right_distrib],
  ring, apply add_le_add_right,
  rw [← neg_sub, neg_mul_eq_neg_mul_symm],
  apply neg_le_neg,
  rw [sub_mul], apply le_sub_left_of_add_le,
  ring,
  rw [← @div_eq_mul_inv ℝ _ 4],
  apply le_div_of_mul_le _,
  rw [right_distrib],
  unfold pow monoid.pow, simp,
  rw [mul_assoc (3 + ↑n : ℝ)⁻¹, inv_mul_cancel, mul_one],
  rw [mul_assoc, mul_comm _⁻¹, ← mul_assoc],
  apply add_le_of_le_sub_right,
  rw [← div_eq_mul_inv],
  apply div_le_of_le_mul _,
  simp, rw [left_distrib (2 + ↑n : ℝ), ← neg_mul_eq_mul_neg, ← sub_eq_add_neg],
  apply le_sub_left_of_add_le,
  apply add_le_of_le_sub_right,
  rw [← div_eq_mul_inv],
  apply div_le_of_le_mul _,
  simp, rw [left_distrib (3 + ↑n : ℝ), ← neg_mul_eq_mul_neg, ← sub_eq_add_neg],
  apply le_sub_left_of_add_le,
  refine eq.mp _ (sigh n),
  { unfold pow monoid.pow, simp, ring, },
  -- ugly tactics to kill off the remaining goals en masse
  any_goals {
    try { unfold pow monoid.pow },
    simp,
  },
  any_goals { unfold gt },
  any_goals { iterate { apply sqrt_nonneg <|> apply mul_nonneg } },
  any_goals { unfold ge },
  any_goals {
    try { rw [add_comm _ (n : ℕ)] <|> rw [add_comm _ (n : ℝ)] },
    natureally,
  },
  all_goals {
    have : ∀ m : ℕ, ((2 : ℕ) : ℝ) + -(nat.succ m : ℝ)⁻¹ ≥ ↑0,
    {
      intro m,
      rw [← sub_eq_add_neg],
      apply le_sub_left_of_add_le,
      rw [nat.cast_zero, add_zero],
      transitivity,
      show (nat.succ m : ℝ)⁻¹ ≤ 1,
      rw [← @inv_inv' ℝ _ 1, inv_le_inv, inv_one, ← nat.cast_one, nat.cast_le],
      exact nat.zero_lt_succ m,
      rw [← nat.cast_zero, nat.cast_lt],
      exact nat.zero_lt_succ m,
      rw [inv_one],
      exact zero_lt_one,
      exact le_of_lt two_gt_one,
    },
    exact this _,
  }
  end

-- Easy enough to show that is is bounded above by 2.
lemma part_a : ∀ n, s n ≤ 2 :=
  begin
  intro n, induction n with n ih,
  simp, exact le_of_lt one_lt_two,
  simp,
  have : sqrt (s n) ≤ sqrt 2,
    rw sqrt_le, exact ih,
    apply le_of_lt, exact s_pos n,
    apply le_of_lt, exact two_pos,
  transitivity,
  have sqrt_two_pos : 0 < sqrt 2, rw sqrt_pos, exact two_pos,
  apply (mul_le_mul_left sqrt_two_pos).2, exact this,
  rw mul_self_sqrt, apply le_of_lt, exact two_pos,
  end

-- And always increasing (strictly!).
lemma part_b : ∀ n, s n < s (n+1) :=
  begin
  intro n, induction n with n ih,
  simp, apply lt_of_le_of_lt, exact le_of_eq (eq.symm sqrt_one),
  rw sqrt_lt, exact two_gt_one,
  apply le_of_lt, exact zero_lt_one,
  apply le_of_lt, exact two_pos,
  simp,
  have sqrt_two_pos : 0 < sqrt 2, rw sqrt_pos, exact two_pos,
  apply (mul_lt_mul_left sqrt_two_pos).2, rw sqrt_lt,
  simp at ih,
  exact ih,
  exact le_of_lt (s_pos n),
  have := le_of_lt (s_pos (n+1)), simpa
  end

-- So it must converge!
lemma part_c : converges s :=
  begin
  apply converges_of_bdd_not_decr,
  existsi (2 : ℝ), simp, intros y x y_x, rw y_x, exact part_a x,
  intro n, exact le_of_lt (part_b n),
  end

lemma blah {a b c : ℝ} : c - a < c - b → a > b := le_imp_le_iff_lt_imp_lt.1 (λ h, sub_le_sub_left h _)

-- And we use the stuff above to show that it converges to 2.
lemma part_d : s ⟶ 2 :=
  begin
  suffices : Sup {x : ℝ | ∃ (n : ℕ), x = s n} = 2,
    rw ← this, apply converges_to_cSup,
    intro n, exact le_of_lt (part_b n),
  apply lattice.cSup_intro,
  apply ne_empty_of_mem, apply exists.intro 0, refl,
  intros a a_mem, apply exists.elim a_mem, intros n a_n, rw a_n,
  exact part_a n,
  intros w w_lt_2, simp,
  suffices : ∀ ε, ε > 0 → ∃ n, (2 - s n) < ε,
    apply exists.elim (this (2 - w) (sub_pos.2 w_lt_2)), intros n c,
    existsi s n, constructor, existsi n, refl,
    apply blah c,
  intros ε ε_pos,
  apply exists.elim (exists_nat_gt (1/ε)),
  intro n, intro n_gt,
  existsi max n 2,
  have nmax_gt : ↑(max n 2) > 1/ε,
    apply lt_of_lt_of_le, exact n_gt, rw nat.cast_le, apply le_max_left,
  apply lt_of_le_of_lt,
  apply sub_le_of_sub_le,
  apply s_sup ⟨max n 2, _⟩,
  apply lt_of_lt_of_le,
  show 1 < 2, exact nat.le_refl 2,
  exact le_max_right n 2,
  simp at *, rw [← @inv_inv' _ _ ε, inv_lt_inv],
  exact nmax_gt,
  apply lt_of_lt_of_le,
  show (0 : ℝ) < 2, natureally,
  exact le_max_right n 2,
  exact inv_pos ε_pos,
  end

end problem9

end hw2


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.metric_space.emetric_space

/-!
# Metric separated pairs of sets

In this file we define the predicate `is_metric_separated`. We say that two sets in an (extended)
metric space are *metric separated* if the (extended) distance between `x ∈ s` and `y ∈ t` is
bounded from below by a positive constant.

This notion is useful, e.g., to define metric outer measures.
-/

open emetric set
noncomputable theory

/-- Two sets in an (extended) metric space are called *metric separated* if the (extended) distance
between `x ∈ s` and `y ∈ t` is bounded from below by a positive constant. -/
def is_metric_separated {X : Type*} [emetric_space X] (s t : set X) :=
∃ r ≠ 0, ∀ (x ∈ s) (y ∈ t), r ≤ edist x y

namespace is_metric_separated

variables {X : Type*} [emetric_space X] {s t : set X} {x y : X}

@[symm] lemma symm (h : is_metric_separated s t) : is_metric_separated t s :=
let ⟨r, r0, hr⟩ := h in ⟨r, r0, λ y hy x hx, edist_comm x y ▸ hr x hx y hy⟩

lemma comm : is_metric_separated s t ↔ is_metric_separated t s := ⟨symm, symm⟩

@[simp] lemma empty_left (s : set X) : is_metric_separated ∅ s :=
⟨1, ennreal.zero_lt_one.ne', λ x, false.elim⟩

@[simp] lemma empty_right (s : set X) : is_metric_separated s ∅ :=
(empty_left s).symm

protected lemma disjoint (h : is_metric_separated s t) : disjoint s t :=
let ⟨r, r0, hr⟩ := h in λ x hx, r0 $ by simpa using hr x hx.1 x hx.2

lemma subset_compl_right (h : is_metric_separated s t) : s ⊆ tᶜ :=
λ x hs ht, h.disjoint ⟨hs, ht⟩

@[mono] lemma mono {s' t'} (hs : s ⊆ s') (ht : t ⊆ t') :
  is_metric_separated s' t' → is_metric_separated s t :=
λ ⟨r, r0, hr⟩, ⟨r, r0, λ x hx y hy, hr x (hs hx) y (ht hy)⟩

lemma mono_left {s'} (h' : is_metric_separated s' t) (hs : s ⊆ s') :
  is_metric_separated s t :=
h'.mono hs subset.rfl

lemma mono_right {t'} (h' : is_metric_separated s t') (ht : t ⊆ t') :
  is_metric_separated s t :=
h'.mono subset.rfl ht

lemma union_left {s'} (h : is_metric_separated s t) (h' : is_metric_separated s' t) :
  is_metric_separated (s ∪ s') t :=
begin
  rcases ⟨h, h'⟩ with ⟨⟨r, r0, hr⟩, ⟨r', r0', hr'⟩⟩,
  refine ⟨min r r', _, λ x hx y hy, hx.elim _ _⟩,
  { rw [← pos_iff_ne_zero] at r0 r0' ⊢,
    exact lt_min r0 r0' },
  { exact λ hx, (min_le_left _ _).trans (hr _ hx _ hy) },
  { exact λ hx, (min_le_right _ _).trans (hr' _ hx _ hy) }
end

@[simp] lemma union_left_iff {s'} :
  is_metric_separated (s ∪ s') t ↔ is_metric_separated s t ∧ is_metric_separated s' t :=
⟨λ h, ⟨h.mono_left (subset_union_left _ _), h.mono_left (subset_union_right _ _)⟩,
  λ h, h.1.union_left h.2⟩

lemma union_right {t'} (h : is_metric_separated s t) (h' : is_metric_separated s t') :
  is_metric_separated s (t ∪ t') :=
(h.symm.union_left h'.symm).symm

@[simp] lemma union_right_iff {t'} :
  is_metric_separated s (t ∪ t') ↔ is_metric_separated s t ∧ is_metric_separated s t' :=
comm.trans $ union_left_iff.trans $ and_congr comm comm

lemma finite_Union_left_iff {ι : Type*} {I : set ι} (hI : finite I) {s : ι → set X} {t : set X} :
  is_metric_separated (⋃ i ∈ I, s i) t ↔ ∀ i ∈ I, is_metric_separated (s i) t :=
begin
  refine finite.induction_on hI (by simp) (λ i I hi _ hI, _),
  rw [bUnion_insert, ball_insert_iff, union_left_iff, hI]
end

alias finite_Union_left_iff ↔ _ is_metric_separated.finite_Union_left

lemma finite_Union_right_iff {ι : Type*} {I : set ι} (hI : finite I) {s : set X} {t : ι → set X} :
  is_metric_separated s (⋃ i ∈ I, t i) ↔ ∀ i ∈ I, is_metric_separated s (t i) :=
by simpa only [@comm _ _ s] using finite_Union_left_iff hI

@[simp] lemma finset_Union_left_iff {ι : Type*} {I : finset ι} {s : ι → set X} {t : set X} :
  is_metric_separated (⋃ i ∈ I, s i) t ↔ ∀ i ∈ I, is_metric_separated (s i) t :=
finite_Union_left_iff I.finite_to_set

alias finset_Union_left_iff ↔ _ is_metric_separated.finset_Union_left

@[simp] lemma finset_Union_right_iff {ι : Type*} {I : finset ι} {s : set X} {t : ι → set X} :
  is_metric_separated s (⋃ i ∈ I, t i) ↔ ∀ i ∈ I, is_metric_separated s (t i) :=
finite_Union_right_iff I.finite_to_set

alias finset_Union_right_iff ↔ _ is_metric_separated.finset_Union_right

end is_metric_separated


import analysis.calculus.lhopital
import order.filter.at_top_bot

/-!
# Langmuir adsorption model
This section defines Langmuir adsorption model from kinetics for a single adsorbate on a single site:

$$
θ = \frac{K Pₐ}{1  +  K Pₐ}
$$
where:
- `θ` is the fractional occupancy of the adsorption sites
- `K` is the adsorption constant describing the adsorption/desorption rates in equilibrium
- `Pₐ` is the partial pressure of the adsorbate

### Assumption
The model assumes the rate of adsorption `r_ad = k_ad * Pₐ * S` and

the rate of desorption `r_d = k_d * A` are equal at equilibrium conditions where:
- `k_ad` is the adsorption constant
- `k_d` is the desorption constant
-  `S` is the concentartion of all sites
- `A` is the concentartion of occupied sites

### Constraints generated by Lean
- `S ≠ 0`
- `k_d ≠ 0`

### To-Do
- Proof statistical mechanical derivation of the model
- Generalize proof from properties of system
-/

theorem Langmuir_single_site_old
(Pₐ k_ad k_d A S : ℝ)
(hreaction : let r_ad := k_ad*Pₐ*S, r_d := k_d*A in r_ad = r_d)
(hS : S ≠ 0)
(hk_d : k_d ≠ 0)
:
let θ := A/(S+A),
    K := k_ad/k_d in
θ = K*Pₐ/(1+K*Pₐ) :=
begin
  simp at hreaction,
  rw [mul_comm k_d A, ← div_eq_div_iff hk_d hS] at hreaction,
  field_simp [hreaction],
end

noncomputable
def langmuir_single_site_model (equilibrium_constant : ℝ) : ℝ → ℝ := λ P : ℝ, equilibrium_constant*P/(1+equilibrium_constant*P)
def hernys_law_model (equilibrium_constant : ℝ) : ℝ → ℝ := λ P, equilibrium_constant*P

theorem langmuir_single_site_kinetic_derivation
{Pₐ k_ad k_d A S : ℝ}
(hreaction : let r_ad := k_ad*Pₐ*S, r_d := k_d*A in r_ad = r_d)
(hS : S ≠ 0)
(hk_d : k_d ≠ 0)
:
let θ := A/(S+A),
    K := k_ad/k_d in
θ = langmuir_single_site_model K Pₐ :=
begin
  simp [langmuir_single_site_model] at *,
  rw [mul_comm k_d A, ← div_eq_div_iff hk_d hS] at hreaction,
  field_simp [hreaction],
end

lemma lhopital_at_top_div_at_top_transformation
(f g : ℝ → ℝ)
(l : filter ℝ)
: filter.tendsto (λ x, f x / g x) l = filter.tendsto ((λ x, (1 / g x) / (1 / f x))) l := by simp

theorem langmuir_approx_henry_law_at_low_pressure
{k_ad k_d : ℝ}
(hk_ad : 0 < k_ad)
(hk_d : 0 < k_d)
: filter.tendsto ((langmuir_single_site_model (k_ad/k_d))/(hernys_law_model (k_ad/k_d))) (nhds_within 0 (set.Ioi 0)) (nhds 1) :=
begin
  simp [langmuir_single_site_model, hernys_law_model],
  apply deriv.lhopital_zero_nhds_right,
  { rw filter.eventually_iff_exists_mem,
    use (set.Ioi (0 : ℝ)),
    split,
    exact self_mem_nhds_within,
    intros,
    simp,
    apply differentiable_at.div,
    any_goals {simp},
    simp at H,
    apply ne_of_gt,
    apply add_pos,
    exact zero_lt_one,
    apply mul_pos (div_pos hk_ad hk_d) H,},
  { rw filter.eventually_iff_exists_mem,
    use (set.Ioi (0 : ℝ)),
    split,
    exact self_mem_nhds_within,
    intros,
    simp,
    apply not_or (ne_of_gt hk_ad) (ne_of_gt hk_d),},
  { simp,
    rw nhds_within,
    apply filter.tendsto_inf_left,
    rw [show (0 : ℝ) = 0/1, by norm_num, show (λ (x : ℝ), k_ad / k_d * x / (1 + k_ad / k_d * x)) = (λ (x : ℝ), k_ad / k_d * x) /  (λ x, (1 + k_ad / k_d * x)), by finish],
    apply filter.tendsto.div,
    rw show 0 = (k_ad/k_d * 0), by simp,
    apply filter.tendsto.const_mul,
    finish,
    rw show nhds (1 : ℝ) = nhds (1 + 0), by simp,
    apply filter.tendsto.const_add,
    rw show 0 = (k_ad/k_d * 0), by simp,
    apply filter.tendsto.const_mul,
    finish,
    exact zero_ne_one.symm,},
  { rw nhds_within,
    apply filter.tendsto_inf_left,
    rw show 0 = (k_ad/k_d * 0), by simp,
    apply filter.tendsto.const_mul,
    finish,},
  simp,

end

theorem langmuir_zero_loading_at_zero_pressure
{k_ad k_d : ℝ}
: langmuir_single_site_model (k_ad/k_d) 0 = 0 :=
begin
  field_simp [langmuir_single_site_model],
end

theorem langmuir_single_site_finite_loading
{k_ad k_d : ℝ}
(hk_ad : 0 < k_ad)
(hk_d : 0 < k_d)
: filter.tendsto (langmuir_single_site_model (k_ad/k_d)) filter.at_top (nhds (1 : ℝ)):=
begin
  simp [langmuir_single_site_model],
  have hk_ad1 : k_ad ≠ 0 := ne_of_gt hk_ad,
  have hk_d1 : k_d ≠ 0 := ne_of_gt hk_d,

  -- rw lhopital_at_top_div_at_top_transformation,
  -- apply deriv.lhopital_zero_at_top,
  -- { rw filter.eventually_iff_exists_mem,
  --   use ({-k_d/k_ad}ᶜ),
  --   rw filter.mem_at_top_sets,
  --   split,
  --   use (-k_d/k_ad + 1),
  --   intros,
  --   apply ne_of_gt,
  --   have h : -k_d/k_ad < -k_d/k_ad + 1 := by simp,
  --   exact lt_of_lt_of_le h H,
  --   intros,
  --   apply differentiable_at.div (differentiable_at_const (1 : ℝ)),
  --   simp [differentiable_at.const_add],
  --   simp at H,
  --   field_simp,
  --   field_simp at H,
  --   rw [add_comm, add_eq_zero_iff_eq_neg],
  --   ring,
  --   exact H,},
  -- { rw filter.eventually_iff_exists_mem,
  --   use (set.Ioi (0)),
  --   rw filter.mem_at_top_sets,
  --   split,
  --   use (k_d/k_ad),
  --   intros,
  --   simp,
  --   apply lt_of_lt_of_le _ H,
  --   rw lt_div_iff hk_ad,
  --   simpa using hk_d,
  --   intros,
  --   simp,
  --   push_neg,
  --   have h : y ≠ 0,
  --   { simp at H,
  --     apply ne_of_gt, exact H,
  --     },
  --   exact ⟨h, hk_d1, hk_ad1⟩,
  --   },
  --   { apply filter.tendsto.div_at_top tendsto_const_nhds,
  --     apply filter.tendsto_at_top_add_const_left,
  --     apply filter.tendsto.const_mul_at_top,
  --     rw lt_div_iff hk_d,
  --     simpa using hk_ad,
  --     finish,
  --     exact real.order_topology,
  --     exact real.topological_ring.to_topological_semiring.to_has_continuous_mul,},
  --   { apply filter.tendsto.div_at_top tendsto_const_nhds,
  --     apply filter.tendsto.const_mul_at_top,
  --     rw lt_div_iff hk_d,
  --     simpa using hk_ad,
  --     finish,
  --     exact real.order_topology,
  --     exact real.topological_ring.to_topological_semiring.to_has_continuous_mul,},
  --   { have hderiv1 : λ (x : ℝ), deriv (λ (x : ℝ), 1 / (1 + k_ad / k_d * x)) x
  --     },
end


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import topology.algebra.mul_action
import group_theory.group_action.basic

/-!
# Minimal action of a group

In this file we define an action of a monoid `M` on a topological space `α` to be *minimal* if the
`M`-orbit of every point `x : α` is dense. We also provide an additive version of this definition
and prove some basic facts about minimal actions.

## TODO

* Define a minimal set of an action.

## Tags

group action, minimal
-/

open_locale pointwise

/-- An action of an additive monoid `M` on a topological space is called *minimal* if the `M`-orbit
of every point `x : α` is dense. -/
class add_action.is_minimal (M α : Type*) [add_monoid M] [topological_space α] [add_action M α] :
  Prop :=
(dense_orbit : ∀ x : α, dense (add_action.orbit M x))

/-- An action of a monoid `M` on a topological space is called *minimal* if the `M`-orbit of every
point `x : α` is dense. -/
@[to_additive]
class mul_action.is_minimal (M α : Type*) [monoid M] [topological_space α] [mul_action M α] :
  Prop :=
(dense_orbit : ∀ x : α, dense (mul_action.orbit M x))

open mul_action set

variables (M G : Type*) {α : Type*} [monoid M] [group G] [topological_space α] [mul_action M α]
  [mul_action G α]

@[to_additive] lemma mul_action.dense_orbit [is_minimal M α] (x : α) : dense (orbit M x) :=
mul_action.is_minimal.dense_orbit x

@[to_additive] lemma dense_range_smul [is_minimal M α] (x : α) :
  dense_range (λ c : M, c • x) :=
mul_action.dense_orbit M x

@[priority 100, to_additive]
instance mul_action.is_minimal_of_pretransitive [is_pretransitive M α] : is_minimal M α :=
⟨λ x, (surjective_smul M x).dense_range⟩

@[to_additive] lemma is_open.exists_smul_mem [is_minimal M α] (x : α) {U : set α} (hUo : is_open U)
  (hne : U.nonempty) : ∃ c : M, c • x ∈ U :=
(dense_range_smul M x).exists_mem_open hUo hne

@[to_additive] lemma is_open.Union_preimage_smul [is_minimal M α] {U : set α} (hUo : is_open U)
  (hne : U.nonempty) : (⋃ c : M, (•) c ⁻¹' U) = univ :=
Union_eq_univ_iff.2 $ λ x, hUo.exists_smul_mem M x hne

@[to_additive] lemma is_open.Union_smul [is_minimal G α] {U : set α} (hUo : is_open U)
  (hne : U.nonempty) : (⋃ g : G, g • U) = univ :=
Union_eq_univ_iff.2 $ λ x, let ⟨g, hg⟩ := hUo.exists_smul_mem G x hne
in ⟨g⁻¹, _, hg, inv_smul_smul _ _⟩

@[to_additive]
lemma is_compact.exists_finite_cover_smul [topological_space G] [is_minimal G α]
  [has_continuous_smul G α] {K U : set α} (hK : is_compact K) (hUo : is_open U)
  (hne : U.nonempty) :
  ∃ I : finset G, K ⊆ ⋃ g ∈ I, g • U :=
hK.elim_finite_subcover (λ g : G, g • U) (λ g, hUo.smul _) $
  calc K ⊆ univ : subset_univ K
  ... = ⋃ g : G, g • U : (hUo.Union_smul G hne).symm

@[to_additive]
lemma dense_of_nonempty_smul_invariant [is_minimal M α] {s : set α} (hne : s.nonempty)
  (hsmul : ∀ c : M, c • s ⊆ s) : dense s :=
let ⟨x, hx⟩ := hne in (mul_action.dense_orbit M x).mono
  (range_subset_iff.2 $ λ c, hsmul c $ ⟨x, hx, rfl⟩)

@[to_additive]
lemma eq_empty_or_univ_of_smul_invariant_closed [is_minimal M α] {s : set α} (hs : is_closed s)
  (hsmul : ∀ c : M, c • s ⊆ s) : s = ∅ ∨ s = univ :=
s.eq_empty_or_nonempty.imp_right $ λ hne, hs.closure_eq ▸
  (dense_of_nonempty_smul_invariant M hne hsmul).closure_eq

@[to_additive] lemma is_minimal_iff_closed_smul_invariant [topological_space M]
  [has_continuous_smul M α] :
  is_minimal M α ↔ ∀ s : set α, is_closed s → (∀ c : M, c • s ⊆ s) → s = ∅ ∨ s = univ :=
begin
  split, { introsI h s, exact eq_empty_or_univ_of_smul_invariant_closed M },
  refine λ H, ⟨λ x, dense_iff_closure_eq.2 $ (H _ _ _).resolve_left _⟩,
  exacts [is_closed_closure, λ c, smul_closure_orbit_subset _ _,
    (orbit_nonempty _).closure.ne_empty]
end