/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

! This file was ported from Lean 3 source module computability.partrec_code
! leanprover-community/mathlib commit 6155d4351090a6fad236e3d2e4e0e4e7342668e8
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Computability.Partrec

/-!
# Gödel Numbering for Partial Recursive Functions.

This file defines `nat.partrec.code`, an inductive datatype describing code for partial
recursive functions on ℕ. It defines an encoding for these codes, and proves that the constructors
are primitive recursive with respect to the encoding.

It also defines the evalution of these codes as partial functions using `pfun`, and proves that a
function is partially recursive (as defined by `nat.partrec`) if and only if it is the evaluation
of some code.

## Main Definitions

* `nat.partrec.code`: Inductive datatype for partial recursive codes.
* `nat.partrec.code.encode_code`: A (computable) encoding of codes as natural numbers.
* `nat.partrec.code.of_nat_code`: The inverse of this encoding.
* `nat.partrec.code.eval`: The interpretation of a `nat.partrec.code` as a partial function.

## Main Results

* `nat.partrec.code.rec_prim`: Recursion on `nat.partrec.code` is primitive recursive.
* `nat.partrec.code.rec_computable`: Recursion on `nat.partrec.code` is computable.
* `nat.partrec.code.smn`: The $S_n^m$ theorem.
* `nat.partrec.code.exists_code`: Partial recursiveness is equivalent to being the eval of a code.
* `nat.partrec.code.evaln_prim`: `evaln` is primitive recursive.
* `nat.partrec.code.fixed_point`: Roger's fixed point theorem.

## References

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

-/

open Encodable Denumerable

namespace Nat.Partrec

open Nat (pair)

theorem rfind' {f} (hf : Nat.Partrec f) :
    Nat.Partrec
      (Nat.unpaired fun a m =>
        (Nat.rfind fun n => (fun m => m = 0) <$> f (pair a (n + m))).map (· + m)) :=
  Partrec₂.unpaired'.2 <|
    by
    refine'
      Partrec.map
        ((@Partrec₂.unpaired' fun a b : ℕ =>
              Nat.rfind fun n => (fun m => m = 0) <$> f (mkpair a (n + b))).1
          _)
        (primrec.nat_add.comp Primrec.snd <| primrec.snd.comp Primrec.fst).to_comp.to₂
    have :=
      rfind
        (Partrec₂.unpaired'.2
          ((Partrec.nat_iff.2 hf).comp
              (primrec₂.mkpair.comp (primrec.fst.comp <| primrec.unpair.comp Primrec.fst)
                  (primrec.nat_add.comp Primrec.snd
                    (primrec.snd.comp <| primrec.unpair.comp Primrec.fst))).to_comp).to₂)
    simp at this; exact this
#align nat.partrec.rfind' Nat.Partrec.rfind'

/-- Code for partial recursive functions from ℕ to ℕ.
See `nat.partrec.code.eval` for the interpretation of these constructors.
-/
inductive Code : Type
  | zero : code
  | succ : code
  | left : code
  | right : code
  | pair : code → code → code
  | comp : code → code → code
  | prec : code → code → code
  | rfind' : code → code
#align nat.partrec.code Nat.Partrec.Code

end Nat.Partrec

namespace Nat.Partrec.Code

open Nat (pair unpair)

open Nat.Partrec (code)

instance : Inhabited Code :=
  ⟨zero⟩

/-- Returns a code for the constant function outputting a particular natural. -/
protected def const : ℕ → Code
  | 0 => zero
  | n + 1 => comp succ (const n)
#align nat.partrec.code.const Nat.Partrec.Code.const

theorem const_inj : ∀ {n₁ n₂}, Nat.Partrec.Code.const n₁ = Nat.Partrec.Code.const n₂ → n₁ = n₂
  | 0, 0, h => by simp
  | n₁ + 1, n₂ + 1, h => by
    dsimp [Nat.Partrec.Code.const] at h
    injection h with h₁ h₂
    simp only [const_inj h₂]
#align nat.partrec.code.const_inj Nat.Partrec.Code.const_inj

/-- A code for the identity function. -/
protected def id : Code :=
  pair left right
#align nat.partrec.code.id Nat.Partrec.Code.id

/-- Given a code `c` taking a pair as input, returns a code using `n` as the first argument to `c`.
-/
def curry (c : Code) (n : ℕ) : Code :=
  comp c (pair (Code.const n) Code.id)
#align nat.partrec.code.curry Nat.Partrec.Code.curry

/-- An encoding of a `nat.partrec.code` as a ℕ. -/
def encodeCode : Code → ℕ
  | zero => 0
  | succ => 1
  | left => 2
  | right => 3
  | pair cf cg => bit0 (bit0 <| pair (encode_code cf) (encode_code cg)) + 4
  | comp cf cg => bit0 (bit1 <| pair (encode_code cf) (encode_code cg)) + 4
  | prec cf cg => bit1 (bit0 <| pair (encode_code cf) (encode_code cg)) + 4
  | rfind' cf => bit1 (bit1 <| encode_code cf) + 4
#align nat.partrec.code.encode_code Nat.Partrec.Code.encodeCode

/--
A decoder for `nat.partrec.code.encode_code`, taking any ℕ to the `nat.partrec.code` it represents.
-/
def ofNatCode : ℕ → Code
  | 0 => zero
  | 1 => succ
  | 2 => left
  | 3 => right
  | n + 4 =>
    let m := n.div2.div2
    have hm : m < n + 4 := by
      simp [m, Nat.div2_val] <;>
        exact
          lt_of_le_of_lt (le_trans (Nat.div_le_self _ _) (Nat.div_le_self _ _))
            (Nat.succ_le_succ (Nat.le_add_right _ _))
    have m1 : m.unpair.1 < n + 4 := lt_of_le_of_lt m.unpair_left_le hm
    have m2 : m.unpair.2 < n + 4 := lt_of_le_of_lt m.unpair_right_le hm
    match n.bodd, n.div2.bodd with
    | ff, ff => pair (of_nat_code m.unpair.1) (of_nat_code m.unpair.2)
    | ff, tt => comp (of_nat_code m.unpair.1) (of_nat_code m.unpair.2)
    | tt, ff => prec (of_nat_code m.unpair.1) (of_nat_code m.unpair.2)
    | tt, tt => rfind' (of_nat_code m)
#align nat.partrec.code.of_nat_code Nat.Partrec.Code.ofNatCode

/-- Proof that `nat.partrec.code.of_nat_code` is the inverse of `nat.partrec.code.encode_code`-/
private theorem encode_of_nat_code : ∀ n, encodeCode (ofNatCode n) = n
  | 0 => by simp [of_nat_code, encode_code]
  | 1 => by simp [of_nat_code, encode_code]
  | 2 => by simp [of_nat_code, encode_code]
  | 3 => by simp [of_nat_code, encode_code]
  | n + 4 => by
    let m := n.div2.div2
    have hm : m < n + 4 := by
      simp [m, Nat.div2_val] <;>
        exact
          lt_of_le_of_lt (le_trans (Nat.div_le_self _ _) (Nat.div_le_self _ _))
            (Nat.succ_le_succ (Nat.le_add_right _ _))
    have m1 : m.unpair.1 < n + 4 := lt_of_le_of_lt m.unpair_left_le hm
    have m2 : m.unpair.2 < n + 4 := lt_of_le_of_lt m.unpair_right_le hm
    have IH := encode_of_nat_code m
    have IH1 := encode_of_nat_code m.unpair.1
    have IH2 := encode_of_nat_code m.unpair.2
    trans
    swap
    rw [← Nat.bit_decomp n, ← Nat.bit_decomp n.div2]
    simp [encode_code, of_nat_code, -add_comm]
    cases n.bodd <;> cases n.div2.bodd <;>
      simp [encode_code, of_nat_code, -add_comm, IH, IH1, IH2, m, Nat.bit]
#align nat.partrec.code.encode_of_nat_code nat.partrec.code.encode_of_nat_code

instance : Denumerable Code :=
  mk'
    ⟨encodeCode, ofNatCode, fun c => by
      induction c <;> try rfl <;> simp [encode_code, of_nat_code, -add_comm, *], encode_ofNatCode⟩

theorem encodeCode_eq : encode = encodeCode :=
  rfl
#align nat.partrec.code.encode_code_eq Nat.Partrec.Code.encodeCode_eq

theorem ofNatCode_eq : ofNat Code = ofNatCode :=
  rfl
#align nat.partrec.code.of_nat_code_eq Nat.Partrec.Code.ofNatCode_eq

theorem encode_lt_pair (cf cg) :
    encode cf < encode (pair cf cg) ∧ encode cg < encode (pair cf cg) :=
  by
  simp [encode_code_eq, encode_code, -add_comm]
  have := Nat.mul_le_mul_right _ (by decide : 1 ≤ 2 * 2)
  rw [one_mul, mul_assoc, ← bit0_eq_two_mul, ← bit0_eq_two_mul] at this
  have := lt_of_le_of_lt this (lt_add_of_pos_right _ (by decide : 0 < 4))
  exact ⟨lt_of_le_of_lt (Nat.left_le_pair _ _) this, lt_of_le_of_lt (Nat.right_le_pair _ _) this⟩
#align nat.partrec.code.encode_lt_pair Nat.Partrec.Code.encode_lt_pair

theorem encode_lt_comp (cf cg) :
    encode cf < encode (comp cf cg) ∧ encode cg < encode (comp cf cg) :=
  by
  suffices; exact (encode_lt_pair cf cg).imp (fun h => lt_trans h this) fun h => lt_trans h this
  change _; simp [encode_code_eq, encode_code]
#align nat.partrec.code.encode_lt_comp Nat.Partrec.Code.encode_lt_comp

theorem encode_lt_prec (cf cg) :
    encode cf < encode (prec cf cg) ∧ encode cg < encode (prec cf cg) :=
  by
  suffices; exact (encode_lt_pair cf cg).imp (fun h => lt_trans h this) fun h => lt_trans h this
  change _; simp [encode_code_eq, encode_code]
#align nat.partrec.code.encode_lt_prec Nat.Partrec.Code.encode_lt_prec

theorem encode_lt_rfind' (cf) : encode cf < encode (rfind' cf) :=
  by
  simp [encode_code_eq, encode_code, -add_comm]
  have := Nat.mul_le_mul_right _ (by decide : 1 ≤ 2 * 2)
  rw [one_mul, mul_assoc, ← bit0_eq_two_mul, ← bit0_eq_two_mul] at this
  refine' lt_of_le_of_lt (le_trans this _) (lt_add_of_pos_right _ (by decide : 0 < 4))
  exact le_of_lt (Nat.bit0_lt_bit1 <| le_of_lt <| Nat.bit0_lt_bit1 <| le_rfl)
#align nat.partrec.code.encode_lt_rfind' Nat.Partrec.Code.encode_lt_rfind'

section

open Primrec

theorem pair_prim : Primrec₂ pair :=
  Primrec₂.ofNat_iff.2 <|
    Primrec₂.encode_iff.1 <|
      nat_add.comp
        (nat_double.comp <|
          nat_double.comp <|
            Primrec₂.natPair.comp (encode_iff.2 <| (Primrec.ofNat Code).comp fst)
              (encode_iff.2 <| (Primrec.ofNat Code).comp snd))
        (Primrec₂.const 4)
#align nat.partrec.code.pair_prim Nat.Partrec.Code.pair_prim

theorem comp_prim : Primrec₂ comp :=
  Primrec₂.ofNat_iff.2 <|
    Primrec₂.encode_iff.1 <|
      nat_add.comp
        (nat_double.comp <|
          nat_double_succ.comp <|
            Primrec₂.natPair.comp (encode_iff.2 <| (Primrec.ofNat Code).comp fst)
              (encode_iff.2 <| (Primrec.ofNat Code).comp snd))
        (Primrec₂.const 4)
#align nat.partrec.code.comp_prim Nat.Partrec.Code.comp_prim

theorem prec_prim : Primrec₂ prec :=
  Primrec₂.ofNat_iff.2 <|
    Primrec₂.encode_iff.1 <|
      nat_add.comp
        (nat_double_succ.comp <|
          nat_double.comp <|
            Primrec₂.natPair.comp (encode_iff.2 <| (Primrec.ofNat Code).comp fst)
              (encode_iff.2 <| (Primrec.ofNat Code).comp snd))
        (Primrec₂.const 4)
#align nat.partrec.code.prec_prim Nat.Partrec.Code.prec_prim

theorem rfind_prim : Primrec rfind' :=
  ofNat_iff.2 <|
    encode_iff.1 <|
      nat_add.comp
        (nat_double_succ.comp <| nat_double_succ.comp <| encode_iff.2 <| Primrec.ofNat Code)
        (const 4)
#align nat.partrec.code.rfind_prim Nat.Partrec.Code.rfind_prim

theorem rec_prim' {α σ} [Primcodable α] [Primcodable σ] {c : α → Code} (hc : Primrec c) {z : α → σ}
    (hz : Primrec z) {s : α → σ} (hs : Primrec s) {l : α → σ} (hl : Primrec l) {r : α → σ}
    (hr : Primrec r) {pr : α → Code × Code × σ × σ → σ} (hpr : Primrec₂ pr)
    {co : α → Code × Code × σ × σ → σ} (hco : Primrec₂ co) {pc : α → Code × Code × σ × σ → σ}
    (hpc : Primrec₂ pc) {rf : α → Code × σ → σ} (hrf : Primrec₂ rf) :
    let PR (a) cf cg hf hg := pr a (cf, cg, hf, hg)
    let CO (a) cf cg hf hg := co a (cf, cg, hf, hg)
    let PC (a) cf cg hf hg := pc a (cf, cg, hf, hg)
    let RF (a) cf hf := rf a (cf, hf)
    let F (a : α) (c : Code) : σ :=
      Nat.Partrec.Code.recOn c (z a) (s a) (l a) (r a) (PR a) (CO a) (PC a) (RF a)
    Primrec (fun a => F a (c a) : α → σ) :=
  by
  intros
  let G₁ : (α × List σ) × ℕ × ℕ → Option σ := fun p =>
    let a := p.1.1
    let IH := p.1.2
    let n := p.2.1
    let m := p.2.2
    (IH.get? m).bind fun s =>
      (IH.get? m.unpair.1).bind fun s₁ =>
        (IH.get? m.unpair.2).map fun s₂ =>
          cond n.bodd
            (cond n.div2.bodd (rf a (of_nat code m, s))
              (pc a (of_nat code m.unpair.1, of_nat code m.unpair.2, s₁, s₂)))
            (cond n.div2.bodd (co a (of_nat code m.unpair.1, of_nat code m.unpair.2, s₁, s₂))
              (pr a (of_nat code m.unpair.1, of_nat code m.unpair.2, s₁, s₂)))
  have : Primrec G₁ :=
    by
    refine' option_bind (list_nth.comp (snd.comp fst) (snd.comp snd)) _
    refine'
      option_bind
        ((list_nth.comp (snd.comp fst) (fst.comp <| primrec.unpair.comp (snd.comp snd))).comp fst) _
    refine'
      option_map
        ((list_nth.comp (snd.comp fst) (snd.comp <| primrec.unpair.comp (snd.comp snd))).comp <|
          fst.comp fst)
        _
    have a := fst.comp (fst.comp <| fst.comp <| fst.comp fst)
    have n := fst.comp (snd.comp <| fst.comp <| fst.comp fst)
    have m := snd.comp (snd.comp <| fst.comp <| fst.comp fst)
    have m₁ := fst.comp (primrec.unpair.comp m)
    have m₂ := snd.comp (primrec.unpair.comp m)
    have s := snd.comp (fst.comp fst)
    have s₁ := snd.comp fst
    have s₂ := snd
    exact
      (nat_bodd.comp n).cond
        ((nat_bodd.comp <| nat_div2.comp n).cond (hrf.comp a (((Primrec.ofNat code).comp m).pair s))
          (hpc.comp a
            (((Primrec.ofNat code).comp m₁).pair <|
              ((Primrec.ofNat code).comp m₂).pair <| s₁.pair s₂)))
        (Primrec.cond (nat_bodd.comp <| nat_div2.comp n)
          (hco.comp a
            (((Primrec.ofNat code).comp m₁).pair <|
              ((Primrec.ofNat code).comp m₂).pair <| s₁.pair s₂))
          (hpr.comp a
            (((Primrec.ofNat code).comp m₁).pair <|
              ((Primrec.ofNat code).comp m₂).pair <| s₁.pair s₂)))
  let G : α → List σ → Option σ := fun a IH =>
    IH.length.cases (some (z a)) fun n =>
      n.cases (some (s a)) fun n =>
        n.cases (some (l a)) fun n => n.cases (some (r a)) fun n => G₁ ((a, IH), n, n.div2.div2)
  have : Primrec₂ G :=
    nat_cases (list_length.comp snd) (option_some_iff.2 (hz.comp fst)) <|
      nat_cases snd (option_some_iff.2 (hs.comp (fst.comp fst))) <|
        nat_cases snd (option_some_iff.2 (hl.comp (fst.comp <| fst.comp fst))) <|
          nat_cases snd (option_some_iff.2 (hr.comp (fst.comp <| fst.comp <| fst.comp fst)))
            (this.comp <|
              ((fst.pair snd).comp <| fst.comp <| fst.comp <| fst.comp <| fst).pair <|
                snd.pair <| nat_div2.comp <| nat_div2.comp snd)
  refine'
    ((nat_strong_rec (fun a n => F a (of_nat code n)) this.to₂ fun a n => _).comp Primrec.id <|
          encode_iff.2 hc).of_eq
      fun a => by simp
  simp
  iterate 4 cases' n with n; · simp [of_nat_code_eq, of_nat_code] <;> rfl
  simp [G]
  rw [List.length_map, List.length_range]
  let m := n.div2.div2
  show
    G₁ ((a, (List.range (n + 4)).map fun n => F a (of_nat code n)), n, m) =
      some (F a (of_nat code (n + 4)))
  have hm : m < n + 4 := by
    simp [Nat.div2_val, m] <;>
      exact
        lt_of_le_of_lt (le_trans (Nat.div_le_self _ _) (Nat.div_le_self _ _))
          (Nat.succ_le_succ (Nat.le_add_right _ _))
  have m1 : m.unpair.1 < n + 4 := lt_of_le_of_lt m.unpair_left_le hm
  have m2 : m.unpair.2 < n + 4 := lt_of_le_of_lt m.unpair_right_le hm
  simp [G₁]
  simp [List.get?_map, List.get?_range, hm, m1, m2]
  change of_nat code (n + 4) with of_nat_code (n + 4)
  simp [of_nat_code]
  cases n.bodd <;> cases n.div2.bodd <;> rfl
#align nat.partrec.code.rec_prim' Nat.Partrec.Code.rec_prim'

/-- Recursion on `nat.partrec.code` is primitive recursive. -/
theorem rec_prim {α σ} [Primcodable α] [Primcodable σ] {c : α → Code} (hc : Primrec c) {z : α → σ}
    (hz : Primrec z) {s : α → σ} (hs : Primrec s) {l : α → σ} (hl : Primrec l) {r : α → σ}
    (hr : Primrec r) {pr : α → Code → Code → σ → σ → σ}
    (hpr : Primrec fun a : α × Code × Code × σ × σ => pr a.1 a.2.1 a.2.2.1 a.2.2.2.1 a.2.2.2.2)
    {co : α → Code → Code → σ → σ → σ}
    (hco : Primrec fun a : α × Code × Code × σ × σ => co a.1 a.2.1 a.2.2.1 a.2.2.2.1 a.2.2.2.2)
    {pc : α → Code → Code → σ → σ → σ}
    (hpc : Primrec fun a : α × Code × Code × σ × σ => pc a.1 a.2.1 a.2.2.1 a.2.2.2.1 a.2.2.2.2)
    {rf : α → Code → σ → σ} (hrf : Primrec fun a : α × Code × σ => rf a.1 a.2.1 a.2.2) :
    let F (a : α) (c : Code) : σ :=
      Nat.Partrec.Code.recOn c (z a) (s a) (l a) (r a) (pr a) (co a) (pc a) (rf a)
    Primrec fun a => F a (c a) :=
  by
  intros
  let G₁ : (α × List σ) × ℕ × ℕ → Option σ := fun p =>
    let a := p.1.1
    let IH := p.1.2
    let n := p.2.1
    let m := p.2.2
    (IH.get? m).bind fun s =>
      (IH.get? m.unpair.1).bind fun s₁ =>
        (IH.get? m.unpair.2).map fun s₂ =>
          cond n.bodd
            (cond n.div2.bodd (rf a (of_nat code m) s)
              (pc a (of_nat code m.unpair.1) (of_nat code m.unpair.2) s₁ s₂))
            (cond n.div2.bodd (co a (of_nat code m.unpair.1) (of_nat code m.unpair.2) s₁ s₂)
              (pr a (of_nat code m.unpair.1) (of_nat code m.unpair.2) s₁ s₂))
  have : Primrec G₁ :=
    by
    refine' option_bind (list_nth.comp (snd.comp fst) (snd.comp snd)) _
    refine'
      option_bind
        ((list_nth.comp (snd.comp fst) (fst.comp <| primrec.unpair.comp (snd.comp snd))).comp fst) _
    refine'
      option_map
        ((list_nth.comp (snd.comp fst) (snd.comp <| primrec.unpair.comp (snd.comp snd))).comp <|
          fst.comp fst)
        _
    have a := fst.comp (fst.comp <| fst.comp <| fst.comp fst)
    have n := fst.comp (snd.comp <| fst.comp <| fst.comp fst)
    have m := snd.comp (snd.comp <| fst.comp <| fst.comp fst)
    have m₁ := fst.comp (primrec.unpair.comp m)
    have m₂ := snd.comp (primrec.unpair.comp m)
    have s := snd.comp (fst.comp fst)
    have s₁ := snd.comp fst
    have s₂ := snd
    exact
      (nat_bodd.comp n).cond
        ((nat_bodd.comp <| nat_div2.comp n).cond
          (hrf.comp <| a.pair (((Primrec.ofNat code).comp m).pair s))
          (hpc.comp <|
            a.pair
              (((Primrec.ofNat code).comp m₁).pair <|
                ((Primrec.ofNat code).comp m₂).pair <| s₁.pair s₂)))
        (Primrec.cond (nat_bodd.comp <| nat_div2.comp n)
          (hco.comp <|
            a.pair
              (((Primrec.ofNat code).comp m₁).pair <|
                ((Primrec.ofNat code).comp m₂).pair <| s₁.pair s₂))
          (hpr.comp <|
            a.pair
              (((Primrec.ofNat code).comp m₁).pair <|
                ((Primrec.ofNat code).comp m₂).pair <| s₁.pair s₂)))
  let G : α → List σ → Option σ := fun a IH =>
    IH.length.cases (some (z a)) fun n =>
      n.cases (some (s a)) fun n =>
        n.cases (some (l a)) fun n => n.cases (some (r a)) fun n => G₁ ((a, IH), n, n.div2.div2)
  have : Primrec₂ G :=
    nat_cases (list_length.comp snd) (option_some_iff.2 (hz.comp fst)) <|
      nat_cases snd (option_some_iff.2 (hs.comp (fst.comp fst))) <|
        nat_cases snd (option_some_iff.2 (hl.comp (fst.comp <| fst.comp fst))) <|
          nat_cases snd (option_some_iff.2 (hr.comp (fst.comp <| fst.comp <| fst.comp fst)))
            (this.comp <|
              ((fst.pair snd).comp <| fst.comp <| fst.comp <| fst.comp <| fst).pair <|
                snd.pair <| nat_div2.comp <| nat_div2.comp snd)
  refine'
    ((nat_strong_rec (fun a n => F a (of_nat code n)) this.to₂ fun a n => _).comp Primrec.id <|
          encode_iff.2 hc).of_eq
      fun a => by simp
  simp
  iterate 4 cases' n with n; · simp [of_nat_code_eq, of_nat_code] <;> rfl
  simp [G]
  rw [List.length_map, List.length_range]
  let m := n.div2.div2
  show
    G₁ ((a, (List.range (n + 4)).map fun n => F a (of_nat code n)), n, m) =
      some (F a (of_nat code (n + 4)))
  have hm : m < n + 4 := by
    simp [Nat.div2_val, m] <;>
      exact
        lt_of_le_of_lt (le_trans (Nat.div_le_self _ _) (Nat.div_le_self _ _))
          (Nat.succ_le_succ (Nat.le_add_right _ _))
  have m1 : m.unpair.1 < n + 4 := lt_of_le_of_lt m.unpair_left_le hm
  have m2 : m.unpair.2 < n + 4 := lt_of_le_of_lt m.unpair_right_le hm
  simp [G₁]
  simp [List.get?_map, List.get?_range, hm, m1, m2]
  change of_nat code (n + 4) with of_nat_code (n + 4)
  simp [of_nat_code]
  cases n.bodd <;> cases n.div2.bodd <;> rfl
#align nat.partrec.code.rec_prim Nat.Partrec.Code.rec_prim

end

section

open Computable

/-- Recursion on `nat.partrec.code` is computable. -/
theorem rec_computable {α σ} [Primcodable α] [Primcodable σ] {c : α → Code} (hc : Computable c)
    {z : α → σ} (hz : Computable z) {s : α → σ} (hs : Computable s) {l : α → σ} (hl : Computable l)
    {r : α → σ} (hr : Computable r) {pr : α → Code × Code × σ × σ → σ} (hpr : Computable₂ pr)
    {co : α → Code × Code × σ × σ → σ} (hco : Computable₂ co) {pc : α → Code × Code × σ × σ → σ}
    (hpc : Computable₂ pc) {rf : α → Code × σ → σ} (hrf : Computable₂ rf) :
    let PR (a) cf cg hf hg := pr a (cf, cg, hf, hg)
    let CO (a) cf cg hf hg := co a (cf, cg, hf, hg)
    let PC (a) cf cg hf hg := pc a (cf, cg, hf, hg)
    let RF (a) cf hf := rf a (cf, hf)
    let F (a : α) (c : Code) : σ :=
      Nat.Partrec.Code.recOn c (z a) (s a) (l a) (r a) (PR a) (CO a) (PC a) (RF a)
    Computable fun a => F a (c a) :=
  by
  -- TODO(Mario): less copy-paste from previous proof
  intros
  let G₁ : (α × List σ) × ℕ × ℕ → Option σ := fun p =>
    let a := p.1.1
    let IH := p.1.2
    let n := p.2.1
    let m := p.2.2
    (IH.get? m).bind fun s =>
      (IH.get? m.unpair.1).bind fun s₁ =>
        (IH.get? m.unpair.2).map fun s₂ =>
          cond n.bodd
            (cond n.div2.bodd (rf a (of_nat code m, s))
              (pc a (of_nat code m.unpair.1, of_nat code m.unpair.2, s₁, s₂)))
            (cond n.div2.bodd (co a (of_nat code m.unpair.1, of_nat code m.unpair.2, s₁, s₂))
              (pr a (of_nat code m.unpair.1, of_nat code m.unpair.2, s₁, s₂)))
  have : Computable G₁ :=
    by
    refine' option_bind (list_nth.comp (snd.comp fst) (snd.comp snd)) _
    refine'
      option_bind
        ((list_nth.comp (snd.comp fst) (fst.comp <| computable.unpair.comp (snd.comp snd))).comp
          fst)
        _
    refine'
      option_map
        ((list_nth.comp (snd.comp fst) (snd.comp <| computable.unpair.comp (snd.comp snd))).comp <|
          fst.comp fst)
        _
    have a := fst.comp (fst.comp <| fst.comp <| fst.comp fst)
    have n := fst.comp (snd.comp <| fst.comp <| fst.comp fst)
    have m := snd.comp (snd.comp <| fst.comp <| fst.comp fst)
    have m₁ := fst.comp (computable.unpair.comp m)
    have m₂ := snd.comp (computable.unpair.comp m)
    have s := snd.comp (fst.comp fst)
    have s₁ := snd.comp fst
    have s₂ := snd
    exact
      (nat_bodd.comp n).cond
        ((nat_bodd.comp <| nat_div2.comp n).cond
          (hrf.comp a (((Computable.ofNat code).comp m).pair s))
          (hpc.comp a
            (((Computable.ofNat code).comp m₁).pair <|
              ((Computable.ofNat code).comp m₂).pair <| s₁.pair s₂)))
        (Computable.cond (nat_bodd.comp <| nat_div2.comp n)
          (hco.comp a
            (((Computable.ofNat code).comp m₁).pair <|
              ((Computable.ofNat code).comp m₂).pair <| s₁.pair s₂))
          (hpr.comp a
            (((Computable.ofNat code).comp m₁).pair <|
              ((Computable.ofNat code).comp m₂).pair <| s₁.pair s₂)))
  let G : α → List σ → Option σ := fun a IH =>
    IH.length.cases (some (z a)) fun n =>
      n.cases (some (s a)) fun n =>
        n.cases (some (l a)) fun n => n.cases (some (r a)) fun n => G₁ ((a, IH), n, n.div2.div2)
  have : Computable₂ G :=
    nat_cases (list_length.comp snd) (option_some_iff.2 (hz.comp fst)) <|
      nat_cases snd (option_some_iff.2 (hs.comp (fst.comp fst))) <|
        nat_cases snd (option_some_iff.2 (hl.comp (fst.comp <| fst.comp fst))) <|
          nat_cases snd (option_some_iff.2 (hr.comp (fst.comp <| fst.comp <| fst.comp fst)))
            (this.comp <|
              ((fst.pair snd).comp <| fst.comp <| fst.comp <| fst.comp <| fst).pair <|
                snd.pair <| nat_div2.comp <| nat_div2.comp snd)
  refine'
    ((nat_strong_rec (fun a n => F a (of_nat code n)) this.to₂ fun a n => _).comp Computable.id <|
          encode_iff.2 hc).of_eq
      fun a => by simp
  simp
  iterate 4 cases' n with n; · simp [of_nat_code_eq, of_nat_code] <;> rfl
  simp [G]
  rw [List.length_map, List.length_range]
  let m := n.div2.div2
  show
    G₁ ((a, (List.range (n + 4)).map fun n => F a (of_nat code n)), n, m) =
      some (F a (of_nat code (n + 4)))
  have hm : m < n + 4 := by
    simp [Nat.div2_val, m] <;>
      exact
        lt_of_le_of_lt (le_trans (Nat.div_le_self _ _) (Nat.div_le_self _ _))
          (Nat.succ_le_succ (Nat.le_add_right _ _))
  have m1 : m.unpair.1 < n + 4 := lt_of_le_of_lt m.unpair_left_le hm
  have m2 : m.unpair.2 < n + 4 := lt_of_le_of_lt m.unpair_right_le hm
  simp [G₁]
  simp [List.get?_map, List.get?_range, hm, m1, m2]
  change of_nat code (n + 4) with of_nat_code (n + 4)
  simp [of_nat_code]
  cases n.bodd <;> cases n.div2.bodd <;> rfl
#align nat.partrec.code.rec_computable Nat.Partrec.Code.rec_computable

end

/-- The interpretation of a `nat.partrec.code` as a partial function.
* `nat.partrec.code.zero`: The constant zero function.
* `nat.partrec.code.succ`: The successor function.
* `nat.partrec.code.left`: Left unpairing of a pair of ℕ (encoded by `nat.mkpair`)
* `nat.partrec.code.right`: Right unpairing of a pair of ℕ (encoded by `nat.mkpair`)
* `nat.partrec.code.pair`: Pairs the outputs of argument codes using `nat.mkpair`.
* `nat.partrec.code.comp`: Composition of two argument codes.
* `nat.partrec.code.prec`: Primitive recursion. Given an argument of the form `nat.mkpair a n`:
  * If `n = 0`, returns `eval cf a`.
  * If `n = succ k`, returns `eval cg (mkpair a (mkpair k (eval (prec cf cg) (mkpair a k))))`
* `nat.partrec.code.rfind'`: Minimization. For `f` an argument of the form `nat.mkpair a m`,
  `rfind' f m` returns the least `a` such that `f a m = 0`, if one exists and `f b m` terminates
  for `b < a`
-/
def eval : Code → ℕ →. ℕ
  | zero => pure 0
  | succ => Nat.succ
  | left => ↑fun n : ℕ => n.unpair.1
  | right => ↑fun n : ℕ => n.unpair.2
  | pair cf cg => fun n => pair <$> eval cf n <*> eval cg n
  | comp cf cg => fun n => eval cg n >>= eval cf
  | prec cf cg =>
    Nat.unpaired fun a n =>
      n.elim (eval cf a) fun y IH => do
        let i ← IH
        eval cg (mkpair a (mkpair y i))
  | rfind' cf =>
    Nat.unpaired fun a m =>
      (Nat.rfind fun n => (fun m => m = 0) <$> eval cf (pair a (n + m))).map (· + m)
#align nat.partrec.code.eval Nat.Partrec.Code.eval

/-- Helper lemma for the evaluation of `prec` in the base case. -/
@[simp]
theorem eval_prec_zero (cf cg : Code) (a : ℕ) : eval (prec cf cg) (pair a 0) = eval cf a := by
  rw [eval, Nat.unpaired, Nat.unpair_pair, Nat.rec_zero]
#align nat.partrec.code.eval_prec_zero Nat.Partrec.Code.eval_prec_zero

/-- Helper lemma for the evaluation of `prec` in the recursive case. -/
theorem eval_prec_succ (cf cg : Code) (a k : ℕ) :
    eval (prec cf cg) (pair a (Nat.succ k)) = do
      let ih ← eval (prec cf cg) (pair a k)
      eval cg (mkpair a (mkpair k ih)) :=
  by
  rw [eval, Nat.unpaired, Part.bind_eq_bind, Nat.unpair_pair, Nat.rec_add_one]
  simp
#align nat.partrec.code.eval_prec_succ Nat.Partrec.Code.eval_prec_succ

instance : Membership (ℕ →. ℕ) Code :=
  ⟨fun f c => eval c = f⟩

@[simp]
theorem eval_const : ∀ n m, eval (Code.const n) m = Part.some n
  | 0, m => rfl
  | n + 1, m => by simp! [*]
#align nat.partrec.code.eval_const Nat.Partrec.Code.eval_const

@[simp]
theorem eval_id (n) : eval Code.id n = Part.some n := by simp! [(· <*> ·)]
#align nat.partrec.code.eval_id Nat.Partrec.Code.eval_id

@[simp]
theorem eval_curry (c n x) : eval (curry c n) x = eval c (pair n x) := by simp! [(· <*> ·)]
#align nat.partrec.code.eval_curry Nat.Partrec.Code.eval_curry

theorem const_prim : Primrec Code.const :=
  (Primrec.id.nat_iterate (Primrec.const zero)
        (comp_prim.comp (Primrec.const succ) Primrec.snd).to₂).of_eq
    fun n => by simp <;> induction n <;> simp [*, code.const, Function.iterate_succ']
#align nat.partrec.code.const_prim Nat.Partrec.Code.const_prim

theorem curry_prim : Primrec₂ curry :=
  comp_prim.comp Primrec.fst <| pair_prim.comp (const_prim.comp Primrec.snd) (Primrec.const Code.id)
#align nat.partrec.code.curry_prim Nat.Partrec.Code.curry_prim

theorem curry_inj {c₁ c₂ n₁ n₂} (h : curry c₁ n₁ = curry c₂ n₂) : c₁ = c₂ ∧ n₁ = n₂ :=
  ⟨by injection h, by
    injection h
    injection h with h₁ h₂
    injection h₂ with h₃ h₄
    exact const_inj h₃⟩
#align nat.partrec.code.curry_inj Nat.Partrec.Code.curry_inj

/--
The $S_n^m$ theorem: There is a computable function, namely `nat.partrec.code.curry`, that takes a
program and a ℕ `n`, and returns a new program using `n` as the first argument.
-/
theorem smn : ∃ f : Code → ℕ → Code, Computable₂ f ∧ ∀ c n x, eval (f c n) x = eval c (pair n x) :=
  ⟨curry, Primrec₂.to_comp curry_prim, eval_curry⟩
#align nat.partrec.code.smn Nat.Partrec.Code.smn

/-- A function is partial recursive if and only if there is a code implementing it. -/
theorem exists_code {f : ℕ →. ℕ} : Nat.Partrec f ↔ ∃ c : Code, eval c = f :=
  ⟨fun h => by
    induction h
    case zero => exact ⟨zero, rfl⟩
    case succ => exact ⟨succ, rfl⟩
    case left => exact ⟨left, rfl⟩
    case right => exact ⟨right, rfl⟩
    case pair f g pf pg hf hg =>
      rcases hf with ⟨cf, rfl⟩; rcases hg with ⟨cg, rfl⟩
      exact ⟨pair cf cg, rfl⟩
    case comp f g pf pg hf hg =>
      rcases hf with ⟨cf, rfl⟩; rcases hg with ⟨cg, rfl⟩
      exact ⟨comp cf cg, rfl⟩
    case prec f g pf pg hf hg =>
      rcases hf with ⟨cf, rfl⟩; rcases hg with ⟨cg, rfl⟩
      exact ⟨prec cf cg, rfl⟩
    case rfind f pf hf =>
      rcases hf with ⟨cf, rfl⟩
      refine' ⟨comp (rfind' cf) (pair code.id zero), _⟩
      simp [eval, (· <*> ·), pure, PFun.pure, Part.map_id'],
    fun h => by
    rcases h with ⟨c, rfl⟩; induction c
    case zero => exact Nat.Partrec.zero
    case succ => exact Nat.Partrec.succ
    case left => exact Nat.Partrec.left
    case right => exact Nat.Partrec.right
    case pair cf cg pf pg => exact pf.pair pg
    case comp cf cg pf pg => exact pf.comp pg
    case prec cf cg pf pg => exact pf.prec pg
    case rfind' cf pf => exact pf.rfind'⟩
#align nat.partrec.code.exists_code Nat.Partrec.Code.exists_code

/-- A modified evaluation for the code which returns an `option ℕ` instead of a `part ℕ`. To avoid
undecidability, `evaln` takes a parameter `k` and fails if it encounters a number ≥ k in the course
of its execution. Other than this, the semantics are the same as in `nat.partrec.code.eval`.
-/
def evaln : ∀ k : ℕ, Code → ℕ → Option ℕ
  | 0, _ => fun m => none
  | k + 1, zero => fun n => guard (n ≤ k) >> pure 0
  | k + 1, succ => fun n => guard (n ≤ k) >> pure (Nat.succ n)
  | k + 1, left => fun n => guard (n ≤ k) >> pure n.unpair.1
  | k + 1, right => fun n => guard (n ≤ k) >> pure n.unpair.2
  | k + 1, pair cf cg => fun n =>
    guard (n ≤ k) >> pair <$> evaln (k + 1) cf n <*> evaln (k + 1) cg n
  | k + 1, comp cf cg => fun n =>
    guard (n ≤ k) >> do
      let x ← evaln (k + 1) cg n
      evaln (k + 1) cf x
  | k + 1, prec cf cg => fun n =>
    guard (n ≤ k) >>
      n.unpaired fun a n =>
        n.cases (evaln (k + 1) cf a) fun y => do
          let i ← evaln k (prec cf cg) (pair a y)
          evaln (k + 1) cg (mkpair a (mkpair y i))
  | k + 1, rfind' cf => fun n =>
    guard (n ≤ k) >>
      n.unpaired fun a m => do
        let x ← evaln (k + 1) cf (pair a m)
        if x = 0 then pure m else evaln k (rfind' cf) (mkpair a (m + 1))
#align nat.partrec.code.evaln Nat.Partrec.Code.evaln

theorem evaln_bound : ∀ {k c n x}, x ∈ evaln k c n → n < k
  | 0, c, n, x, h => by simp [evaln] at h <;> cases h
  | k + 1, c, n, x, h =>
    by
    suffices ∀ {o : Option ℕ}, x ∈ guard (n ≤ k) >> o → n < k + 1 by
      cases c <;> rw [evaln] at h <;> exact this h
    simpa [(· >> ·)] using Nat.lt_succ_of_le
#align nat.partrec.code.evaln_bound Nat.Partrec.Code.evaln_bound

theorem evaln_mono : ∀ {k₁ k₂ c n x}, k₁ ≤ k₂ → x ∈ evaln k₁ c n → x ∈ evaln k₂ c n
  | 0, k₂, c, n, x, hl, h => by simp [evaln] at h <;> cases h
  | k + 1, k₂ + 1, c, n, x, hl, h =>
    by
    have hl' := Nat.le_of_succ_le_succ hl
    have :
      ∀ {k k₂ n x : ℕ} {o₁ o₂ : Option ℕ},
        k ≤ k₂ → (x ∈ o₁ → x ∈ o₂) → x ∈ guard (n ≤ k) >> o₁ → x ∈ guard (n ≤ k₂) >> o₂ :=
      by
      simp [(· >> ·)]
      introv h h₁ h₂ h₃
      exact ⟨le_trans h₂ h, h₁ h₃⟩
    simp at h⊢
    induction' c with cf cg hf hg cf cg hf hg cf cg hf hg cf hf generalizing x n <;>
        rw [evaln] at h⊢ <;>
      refine' this hl' (fun h => _) h
    iterate 4 exact h
    · -- pair cf cg
      simp [(· <*> ·)] at h⊢
      exact h.imp fun a => And.imp (hf _ _) <| Exists.imp fun b => And.imp_left (hg _ _)
    · -- comp cf cg
      simp at h⊢
      exact h.imp fun a => And.imp (hg _ _) (hf _ _)
    · -- prec cf cg
      revert h
      simp
      induction n.unpair.2 <;> simp
      · apply hf
      · exact fun y h₁ h₂ => ⟨y, evaln_mono hl' h₁, hg _ _ h₂⟩
    · -- rfind' cf
      simp at h⊢
      refine' h.imp fun x => And.imp (hf _ _) _
      by_cases x0 : x = 0 <;> simp [x0]
      exact evaln_mono hl'
#align nat.partrec.code.evaln_mono Nat.Partrec.Code.evaln_mono

theorem evaln_sound : ∀ {k c n x}, x ∈ evaln k c n → x ∈ eval c n
  | 0, _, n, x, h => by simp [evaln] at h <;> cases h
  | k + 1, c, n, x, h =>
    by
    induction' c with cf cg hf hg cf cg hf hg cf cg hf hg cf hf generalizing x n <;>
        simp [eval, evaln, (· >> ·), (· <*> ·)] at h⊢ <;>
      cases' h with _ h
    iterate 4 simpa [pure, PFun.pure, eq_comm] using h
    · -- pair cf cg
      rcases h with ⟨y, ef, z, eg, rfl⟩
      exact ⟨_, hf _ _ ef, _, hg _ _ eg, rfl⟩
    · --comp hf hg
      rcases h with ⟨y, eg, ef⟩
      exact ⟨_, hg _ _ eg, hf _ _ ef⟩
    · -- prec cf cg
      revert h
      induction' n.unpair.2 with m IH generalizing x <;> simp
      · apply hf
      · refine' fun y h₁ h₂ => ⟨y, IH _ _, _⟩
        · have := evaln_mono k.le_succ h₁
          simp [evaln, (· >> ·)] at this
          exact this.2
        · exact hg _ _ h₂
    · -- rfind' cf
      rcases h with ⟨m, h₁, h₂⟩
      by_cases m0 : m = 0 <;> simp [m0] at h₂
      ·
        exact
          ⟨0, ⟨by simpa [m0] using hf _ _ h₁, fun m => (Nat.not_lt_zero _).elim⟩, by
            injection h₂ with h₂ <;> simp [h₂]⟩
      · have := evaln_sound h₂
        simp [eval] at this
        rcases this with ⟨y, ⟨hy₁, hy₂⟩, rfl⟩
        refine'
          ⟨y + 1, ⟨by simpa [add_comm, add_left_comm] using hy₁, fun i im => _⟩, by
            simp [add_comm, add_left_comm]⟩
        cases' i with i
        · exact ⟨m, by simpa using hf _ _ h₁, m0⟩
        · rcases hy₂ (Nat.lt_of_succ_lt_succ im) with ⟨z, hz, z0⟩
          exact ⟨z, by simpa [Nat.succ_eq_add_one, add_comm, add_left_comm] using hz, z0⟩
#align nat.partrec.code.evaln_sound Nat.Partrec.Code.evaln_sound

theorem evaln_complete {c n x} : x ∈ eval c n ↔ ∃ k, x ∈ evaln k c n :=
  ⟨fun h => by
    rsuffices ⟨k, h⟩ : ∃ k, x ∈ evaln (k + 1) c n
    · exact ⟨k + 1, h⟩
    induction c generalizing n x <;> simp [eval, evaln, pure, PFun.pure, (· <*> ·), (· >> ·)] at h⊢
    iterate 4 exact ⟨⟨_, le_rfl⟩, h.symm⟩
    case pair cf cg hf hg =>
      rcases h with ⟨x, hx, y, hy, rfl⟩
      rcases hf hx with ⟨k₁, hk₁⟩; rcases hg hy with ⟨k₂, hk₂⟩
      refine' ⟨max k₁ k₂, _⟩
      refine'
        ⟨le_max_of_le_left <| Nat.le_of_lt_succ <| evaln_bound hk₁, _,
          evaln_mono (Nat.succ_le_succ <| le_max_left _ _) hk₁, _,
          evaln_mono (Nat.succ_le_succ <| le_max_right _ _) hk₂, rfl⟩
    case comp cf cg hf hg =>
      rcases h with ⟨y, hy, hx⟩
      rcases hg hy with ⟨k₁, hk₁⟩; rcases hf hx with ⟨k₂, hk₂⟩
      refine' ⟨max k₁ k₂, _⟩
      exact
        ⟨le_max_of_le_left <| Nat.le_of_lt_succ <| evaln_bound hk₁, _,
          evaln_mono (Nat.succ_le_succ <| le_max_left _ _) hk₁,
          evaln_mono (Nat.succ_le_succ <| le_max_right _ _) hk₂⟩
    case prec cf cg hf hg =>
      revert h
      generalize n.unpair.1 = n₁; generalize n.unpair.2 = n₂
      induction' n₂ with m IH generalizing x n <;> simp
      · intro
        rcases hf h with ⟨k, hk⟩
        exact ⟨_, le_max_left _ _, evaln_mono (Nat.succ_le_succ <| le_max_right _ _) hk⟩
      · intro y hy hx
        rcases IH hy with ⟨k₁, nk₁, hk₁⟩
        rcases hg hx with ⟨k₂, hk₂⟩
        refine'
          ⟨(max k₁ k₂).succ,
            Nat.le_succ_of_le <| le_max_of_le_left <| le_trans (le_max_left _ (mkpair n₁ m)) nk₁, y,
            evaln_mono (Nat.succ_le_succ <| le_max_left _ _) _,
            evaln_mono (Nat.succ_le_succ <| Nat.le_succ_of_le <| le_max_right _ _) hk₂⟩
        simp [evaln, (· >> ·)]
        exact ⟨le_trans (le_max_right _ _) nk₁, hk₁⟩
    case rfind' cf hf =>
      rcases h with ⟨y, ⟨hy₁, hy₂⟩, rfl⟩
      suffices ∃ k, y + n.unpair.2 ∈ evaln (k + 1) (rfind' cf) (mkpair n.unpair.1 n.unpair.2) by
        simpa [evaln, (· >> ·)]
      revert hy₁ hy₂
      generalize n.unpair.2 = m
      intros
      induction' y with y IH generalizing m <;> simp [evaln, (· >> ·)]
      · simp at hy₁
        rcases hf hy₁ with ⟨k, hk⟩
        exact ⟨_, Nat.le_of_lt_succ <| evaln_bound hk, _, hk, by simp <;> rfl⟩
      · rcases hy₂ (Nat.succ_pos _) with ⟨a, ha, a0⟩
        rcases hf ha with ⟨k₁, hk₁⟩
        rcases IH m.succ (by simpa [Nat.succ_eq_add_one, add_comm, add_left_comm] using hy₁)
            fun i hi => by
            simpa [Nat.succ_eq_add_one, add_comm, add_left_comm] using
              hy₂ (Nat.succ_lt_succ hi) with
          ⟨k₂, hk₂⟩
        use (max k₁ k₂).succ
        rw [zero_add] at hk₁
        use Nat.le_succ_of_le <| le_max_of_le_left <| Nat.le_of_lt_succ <| evaln_bound hk₁
        use a
        use evaln_mono (Nat.succ_le_succ <| Nat.le_succ_of_le <| le_max_left _ _) hk₁
        simpa [Nat.succ_eq_add_one, a0, -max_eq_left, -max_eq_right, add_comm, add_left_comm] using
          evaln_mono (Nat.succ_le_succ <| le_max_right _ _) hk₂,
    fun ⟨k, h⟩ => evaln_sound h⟩
#align nat.partrec.code.evaln_complete Nat.Partrec.Code.evaln_complete

section

open Primrec

private def lup (L : List (List (Option ℕ))) (p : ℕ × Code) (n : ℕ) := do
  let l ← L.get? (encode p)
  let o ← l.get? n
  o
#align nat.partrec.code.lup nat.partrec.code.lup

private theorem hlup : Primrec fun p : _ × (_ × _) × _ => lup p.1 p.2.1 p.2.2 :=
  option_bind (list_get?.comp fst (Primrec.encode.comp <| fst.comp snd))
    (option_bind (list_get?.comp snd <| snd.comp <| snd.comp fst) snd)
#align nat.partrec.code.hlup nat.partrec.code.hlup

private def G (L : List (List (Option ℕ))) : Option (List (Option ℕ)) :=
  Option.some <|
    let a := ofNat (ℕ × Code) L.length
    let k := a.1
    let c := a.2
    (List.range k).map fun n =>
      k.cases none fun k' =>
        Nat.Partrec.Code.recOn c (some 0)
          (-- zero
            some
            (Nat.succ n))
          (some n.unpair.1) (some n.unpair.2)
          (fun cf cg _ _ => do
            let x ← lup L (k, cf) n
            let y ← lup L (k, cg) n
            some (mkpair x y))
          (fun cf cg _ _ => do
            let x ← lup L (k, cg) n
            lup L (k, cf) x)
          (fun cf cg _ _ =>
            let z := n.unpair.1
            n.unpair.2.cases (lup L (k, cf) z) fun y => do
              let i ← lup L (k', c) (pair z y)
              lup L (k, cg) (mkpair z (mkpair y i)))
          fun cf _ =>
          let z := n.unpair.1
          let m := n.unpair.2
          do
          let x ← lup L (k, cf) (pair z m)
          x (some m) fun _ => lup L (k', c) (mkpair z (m + 1))
#align nat.partrec.code.G nat.partrec.code.G

private theorem hG : Primrec g :=
  by
  have a := (Primrec.ofNat (ℕ × code)).comp list_length
  have k := fst.comp a
  refine' option_some.comp (list_map (list_range.comp k) (_ : Primrec _))
  replace k := k.comp fst; have n := snd
  refine' nat_cases k (const none) (_ : Primrec _)
  have k := k.comp fst; have n := n.comp fst; have k' := snd
  have c := snd.comp (a.comp <| fst.comp fst)
  apply
    rec_prim c (const (some 0)) (option_some.comp (primrec.succ.comp n))
      (option_some.comp (fst.comp <| primrec.unpair.comp n))
      (option_some.comp (snd.comp <| primrec.unpair.comp n))
  · have L := (fst.comp fst).comp fst
    have k := k.comp fst
    have n := n.comp fst
    have cf := fst.comp snd
    have cg := (fst.comp snd).comp snd
    exact
      option_bind (hlup.comp <| L.pair <| (k.pair cf).pair n)
        (option_map ((hlup.comp <| L.pair <| (k.pair cg).pair n).comp fst)
          (primrec₂.mkpair.comp (snd.comp fst) snd))
  · have L := (fst.comp fst).comp fst
    have k := k.comp fst
    have n := n.comp fst
    have cf := fst.comp snd
    have cg := (fst.comp snd).comp snd
    exact
      option_bind (hlup.comp <| L.pair <| (k.pair cg).pair n)
        (hlup.comp ((L.comp fst).pair <| ((k.pair cf).comp fst).pair snd))
  · have L := (fst.comp fst).comp fst
    have k := k.comp fst
    have n := n.comp fst
    have cf := fst.comp snd
    have cg := (fst.comp snd).comp snd
    have z := fst.comp (primrec.unpair.comp n)
    refine'
      nat_cases (snd.comp (primrec.unpair.comp n)) (hlup.comp <| L.pair <| (k.pair cf).pair z)
        (_ : Primrec _)
    have L := L.comp fst
    have z := z.comp fst
    have y := snd
    refine'
      option_bind
        (hlup.comp <| L.pair <| (((k'.pair c).comp fst).comp fst).pair (primrec₂.mkpair.comp z y))
        (_ : Primrec _)
    have z := z.comp fst
    have y := y.comp fst
    have i := snd
    exact
      hlup.comp
        ((L.comp fst).pair <|
          ((k.pair cg).comp <| fst.comp fst).pair <|
            primrec₂.mkpair.comp z <| primrec₂.mkpair.comp y i)
  · have L := (fst.comp fst).comp fst
    have k := k.comp fst
    have n := n.comp fst
    have cf := fst.comp snd
    have z := fst.comp (primrec.unpair.comp n)
    have m := snd.comp (primrec.unpair.comp n)
    refine'
      option_bind (hlup.comp <| L.pair <| (k.pair cf).pair (primrec₂.mkpair.comp z m))
        (_ : Primrec _)
    have m := m.comp fst
    exact
      nat_cases snd (option_some.comp m)
        ((hlup.comp
              ((L.comp fst).pair <|
                ((k'.pair c).comp <| fst.comp fst).pair
                  (primrec₂.mkpair.comp (z.comp fst) (primrec.succ.comp m)))).comp
          fst)
#align nat.partrec.code.hG nat.partrec.code.hG

private theorem evaln_map (k c n) :
    ((((List.range k).get? n).map (evaln k c)).bind fun b => b) = evaln k c n :=
  by
  by_cases kn : n < k
  · simp [List.get?_range kn]
  · rw [List.get?_len_le]
    · cases e : evaln k c n
      · rfl
      exact kn.elim (evaln_bound e)
    simpa using kn
#align nat.partrec.code.evaln_map nat.partrec.code.evaln_map

/-- The `nat.partrec.code.evaln` function is primitive recursive. -/
theorem evaln_prim : Primrec fun a : (ℕ × Code) × ℕ => evaln a.1.1 a.1.2 a.2 :=
  have :
    Primrec₂ fun (_ : Unit) (n : ℕ) =>
      let a := ofNat (ℕ × Code) n
      (List.range a.1).map (evaln a.1 a.2) :=
    Primrec.nat_strong_rec _ (hG.comp snd).to₂ fun _ p =>
      by
      simp [G]
      rw [(_ : (of_nat (ℕ × code) _).snd = of_nat code p.unpair.2)]
      swap
      · simp
      apply List.map_congr fun n => _
      rw [(by simp :
          List.range p = List.range (mkpair p.unpair.1 (encode (of_nat code p.unpair.2))))]
      generalize p.unpair.1 = k
      generalize of_nat code p.unpair.2 = c
      intro nk
      cases' k with k'
      · simp [evaln]
      let k := k' + 1
      change k'.succ with k
      simp [Nat.lt_succ_iff] at nk
      have hg :
        ∀ {k' c' n},
          mkpair k' (encode c') < mkpair k (encode c) →
            lup
                ((List.range (mkpair k (encode c))).map fun n =>
                  (List.range n.unpair.1).map (evaln n.unpair.1 (of_nat code n.unpair.2)))
                (k', c') n =
              evaln k' c' n :=
        by
        intro k₁ c₁ n₁ hl
        simp [lup, List.get?_range hl, evaln_map, (· >>= ·)]
      cases' c with cf cg cf cg cf cg cf <;>
        simp [evaln, nk, (· >> ·), (· >>= ·), (· <$> ·), (· <*> ·), pure]
      · cases' encode_lt_pair cf cg with lf lg
        rw [hg (Nat.pair_lt_pair_right _ lf), hg (Nat.pair_lt_pair_right _ lg)]
        cases evaln k cf n
        · rfl
        cases evaln k cg n <;> rfl
      · cases' encode_lt_comp cf cg with lf lg
        rw [hg (Nat.pair_lt_pair_right _ lg)]
        cases evaln k cg n
        · rfl
        simp [hg (Nat.pair_lt_pair_right _ lf)]
      · cases' encode_lt_prec cf cg with lf lg
        rw [hg (Nat.pair_lt_pair_right _ lf)]
        cases n.unpair.2
        · rfl
        simp
        rw [hg (Nat.pair_lt_pair_left _ k'.lt_succ_self)]
        cases evaln k' _ _
        · rfl
        simp [hg (Nat.pair_lt_pair_right _ lg)]
      · have lf := encode_lt_rfind' cf
        rw [hg (Nat.pair_lt_pair_right _ lf)]
        cases' evaln k cf n with x
        · rfl
        simp
        cases x <;> simp [Nat.succ_ne_zero]
        rw [hg (Nat.pair_lt_pair_left _ k'.lt_succ_self)]
  (option_bind (list_get?.comp (this.comp (const ()) (encode_iff.2 fst)) snd) snd.to₂).of_eq
    fun ⟨⟨k, c⟩, n⟩ => by simp [evaln_map]
#align nat.partrec.code.evaln_prim Nat.Partrec.Code.evaln_prim

end

section

open Partrec Computable

theorem eval_eq_rfindOpt (c n) : eval c n = Nat.rfindOpt fun k => evaln k c n :=
  Part.ext fun x => by
    refine' evaln_complete.trans (Nat.rfindOpt_mono _).symm
    intro a m n hl; apply evaln_mono hl
#align nat.partrec.code.eval_eq_rfind_opt Nat.Partrec.Code.eval_eq_rfindOpt

theorem eval_part : Partrec₂ eval :=
  (rfindOpt (evaln_prim.to_comp.comp ((snd.pair (fst.comp fst)).pair (snd.comp fst))).to₂).of_eq
    fun a => by simp [eval_eq_rfind_opt]
#align nat.partrec.code.eval_part Nat.Partrec.Code.eval_part

/-- Roger's fixed-point theorem: Any total, computable `f` has a fixed point: That is, under the
interpretation given by `nat.partrec.code.eval`, there is a code `c` such that `c` and `f c` have
the same evaluation.
-/
theorem fixed_point {f : Code → Code} (hf : Computable f) : ∃ c : Code, eval (f c) = eval c :=
  let g (x y : ℕ) : Part ℕ := eval (ofNat Code x) x >>= fun b => eval (ofNat Code b) y
  have : Partrec₂ g :=
    (eval_part.comp ((Computable.ofNat _).comp fst) fst).bind
      (eval_part.comp ((Computable.ofNat _).comp snd) (snd.comp fst)).to₂
  let ⟨cg, eg⟩ := exists_code.1 this
  have eg' : ∀ a n, eval cg (pair a n) = Part.map encode (g a n) := by simp [eg]
  let F (x : ℕ) : Code := f (curry cg x)
  have : Computable F := hf.comp (curry_prim.comp (Primrec.const cg) Primrec.id).to_comp
  let ⟨cF, eF⟩ := exists_code.1 this
  have eF' : eval cF (encode cF) = Part.some (encode (F (encode cF))) := by simp [eF]
  ⟨curry cg (encode cF),
    funext fun n =>
      show eval (f (curry cg (encode cF))) n = eval (curry cg (encode cF)) n by
        simp [eg', eF', Part.map_id', g]⟩
#align nat.partrec.code.fixed_point Nat.Partrec.Code.fixed_point

theorem fixed_point₂ {f : Code → ℕ →. ℕ} (hf : Partrec₂ f) : ∃ c : Code, eval c = f c :=
  let ⟨cf, ef⟩ := exists_code.1 hf
  (fixed_point (curry_prim.comp (Primrec.const cf) Primrec.encode).to_comp).imp fun c e =>
    funext fun n => by simp [e.symm, ef, Part.map_id']
#align nat.partrec.code.fixed_point₂ Nat.Partrec.Code.fixed_point₂

end

end Nat.Partrec.Code


/-
Copyright (c) 2022 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/

import model_theory.syntax
import set_theory.cardinal_ordinal

/-! # Encodings and Cardinality of First-Order Syntax

## Main Definitions
* Terms can be encoded as lists with `first_order.language.term.list_encode` and
`first_order.language.term.list_decode`.

## Main Results
* `first_order.language.term.card_le` shows that the number of terms in `L.term α` is at most
`# (α ⊕ Σ i, L.functions i) + ω`.

## TODO
* Bundle `term.list_encode` and `term.list_decode` together with `computability.encoding`.
* An encoding for formulas
* `fin_encoding`s for terms and formulas, based on the `encoding`s
* Computability facts about these `fin_encoding`s, to set up a computability approach to
incompleteness

-/

universes u v w u' v'

namespace first_order
namespace language

variables {L : language.{u v}}
variables {M : Type w} {N P : Type*} [L.Structure M] [L.Structure N] [L.Structure P]
variables {α : Type u'} {β : Type v'}
open_locale first_order cardinal
open list Structure cardinal fin

namespace term

/-- Encodes a term as a list of variables and function symbols. -/
def list_encode : L.term α → list (α ⊕ (Σ i, L.functions i))
| (var i) := [sum.inl i]
| (func f ts) := ((sum.inr (⟨_, f⟩ : Σ i, L.functions i)) ::
    ((list.fin_range _).bind (λ i, (ts i).list_encode)))

/-- Decodes a list of variables and function symbols as a list of terms. -/
def list_decode [inhabited (L.term α)] :
  list (α ⊕ (Σ i, L.functions i)) → list (L.term α)
| [] := []
| ((sum.inl a) :: l) := var a :: list_decode l
| ((sum.inr ⟨n, f⟩) :: l) := func f (λ i, ((list_decode l).nth i).iget) :: ((list_decode l).drop n)

@[simp] theorem list_decode_encode_list [inhabited (L.term α)] (l : list (L.term α)) :
  list_decode (l.bind list_encode) = l :=
begin
  suffices h : ∀ (t : L.term α) (l : list (α ⊕ (Σ i, L.functions i))),
    list_decode (t.list_encode ++ l) = t :: list_decode l,
  { induction l with t l lih,
    { refl },
    { rw [cons_bind, h t (l.bind list_encode), lih] } },
  { intro t,
    induction t with a n f ts ih; intro l,
    { rw [list_encode, singleton_append, list_decode] },
    { rw [list_encode, cons_append, list_decode],
      have h : list_decode ((fin_range n).bind (λ (i : fin n), (ts i).list_encode) ++ l) =
        (fin_range n).map ts ++ list_decode l,
      { induction (fin_range n) with i l' l'ih,
        { refl },
        { rw [cons_bind, append_assoc, ih, map_cons, l'ih, cons_append] } },
      have h' : n ≤ (list_decode ((fin_range n).bind (λ (i : fin n),
        (ts i).list_encode) ++ l)).length,
      { rw [h, length_append, length_map, length_fin_range],
        exact le_self_add, },
      refine congr (congr rfl (congr rfl (funext (λ i, _)))) _,
      { rw [nth_le_nth (lt_of_lt_of_le i.is_lt h'), option.iget_some, nth_le_of_eq h, nth_le_append,
          nth_le_map, nth_le_fin_range, fin.eta],
        { rw [length_fin_range],
          exact i.is_lt },
        { rw [length_map, length_fin_range],
          exact i.is_lt } },
      { rw [h, drop_left'],
        rw [length_map, length_fin_range] } } }
end

lemma list_encode_injective :
  function.injective (list_encode : L.term α → list (α ⊕ (Σ i, L.functions i))) :=
begin
  cases is_empty_or_nonempty (L.term α) with he hne,
  { exact he.elim },
  { resetI,
    inhabit (L.term α),
    intros t1 t2 h,
    have h' : (list_decode ([t1].bind (list_encode))) = (list_decode ([t2].bind (list_encode))),
    { rw [bind_singleton, h, bind_singleton] },
    rw [list_decode_encode_list, list_decode_encode_list] at h',
    exact head_eq_of_cons_eq h' }
end

theorem card_le : # (L.term α) ≤ # (α ⊕ (Σ i, L.functions i)) + ω :=
begin
  have h := (mk_le_of_injective list_encode_injective),
  refine h.trans _,
  casesI fintype_or_infinite (α ⊕ (Σ i, L.functions i)) with ft inf,
  { haveI := fintype.encodable (α ⊕ (Σ i, L.functions i)),
    exact le_add_left (encodable_iff.1 ⟨encodable.list⟩) },
  { rw mk_list_eq_mk,
    exact le_self_add }
end

instance [encodable α] [encodable ((Σ i, L.functions i))] [inhabited (L.term α)] :
  encodable (L.term α) :=
encodable.of_left_injection list_encode (λ l, (list_decode l).head')
  (λ t, by rw [← bind_singleton list_encode, list_decode_encode_list, head'])

lemma card_le_omega [h1 : nonempty (encodable α)] [h2 : L.countable_functions] :
  # (L.term α) ≤ ω :=
begin
  refine (card_le.trans _),
  rw [add_le_omega, mk_sum, add_le_omega, lift_le_omega, lift_le_omega, ← encodable_iff],
  exact ⟨⟨h1, L.card_functions_le_omega⟩, refl _⟩,
end

instance small [small.{u} α] :
  small.{u} (L.term α) :=
small_of_injective list_encode_injective

end term

end language
end first_order


import .love05_inductive_predicates_demo

/- # LoVe Demo 11: Logical Foundations of Mathematics

We dive deeper into the logical foundations of Lean. Most of the features
described here are especially relevant for defining mathematical objects and
proving theorems about them. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/- ## Universes

Not only terms have a type, but also types have a type. For example, by the
Curry-Howard correspondence:

    `@and.intro : ∀a b, a → b → a ∧ b`

Moreover:

    `∀a b, a → b → a ∧ b : Prop`

Now, what is the type of `Prop`? `Prop` has the same type as virtually all other
types we have constructed so far:

    `Prop : Type`

What is the type of `Type`? The typing `Type : Type` would lead to a
contradiction, called **Girard's paradox**, resembling Russel's paradox.
Instead:

    `Type   : Type 1`
    `Type 1 : Type 2`
    `Type 2 : Type 3`
    ⋮

Aliases:

    `Type`   := `Type 0`
    `Prop`   := `Sort 0`
    `Type u` := `Sort (u + 1)`

The types of types (`Sort u`, `Type u`, and `Prop`) are called __universes__.
The `u` in `Sort u` is a __universe level__.

The hierarchy is captured by the following typing judgment:

    ————————————————————————— Sort
    C ⊢ Sort u : Sort (u + 1) -/

#check @and.intro
#check ∀a b : Prop, a → b → a ∧ b
#check Prop
#check ℕ
#check Type
#check Type 1
#check Type 2

universe variables u v

#check Type u

#check Sort 0
#check Sort 1
#check Sort 2
#check Sort u

#check Type*

/- ## The Peculiarities of Prop

`Prop` is different from the other universes in many respects.

### Impredicativity

The function type `σ → τ` is put into the larger one of the universes that
`σ` and `τ` live in:

    C ⊢ σ : Type u    C ⊢ τ : Type v
    ————————————————————————————————— Arrow-Type
    C ⊢ σ → τ : Type (max u v)

For dependent types, this generalizes to

    C ⊢ σ : Type u    C, x : σ ⊢ τ[x] : Type v
    ——————————————————————————————————————————— Forall-Type
    C ⊢ (∀x : σ, τ[x]) : Type (max u v)

This behavior of the universes `Type v` is called __predicativity__.

To force expressions such as `∀a : Prop, a → a` to be of type `Prop` anyway, we
need a special typing rule for `Prop`:

    C ⊢ σ : Sort u    x : σ ⊢ τ[x] : Prop
    —————————————————————————————————————— Forall-Prop
    C ⊢ (∀x : σ, τ[x]) : Prop

This behavior of `Prop` is called __impredicativity__.

The rules `Forall-Type` and `Forall-Prop` can be generalized into a single rule:

    C ⊢ σ : Sort u    C, x : σ ⊢ τ[x] : Sort v
    ——————————————————————————————————————————— Forall
    C ⊢ (∀x : σ, τ[x]) : Sort (imax u v)

where

    `imax u 0       = 0`
    `imax u (v + 1) = max u (v + 1)` -/

#check λ(α : Type u) (β : Type v), α → β
#check ∀a : Prop, a → a

/- ### Proof Irrelevance

A second difference between `Prop` and `Type u` is __proof irrelevance__:

    `∀(a : Prop) (h₁ h₂ : a), h₁ = h₂`

This and makes reasoning about dependent types easier.

When viewing a proposition as a type and a proof as an element of that type,
proof irrelevance means that a proposition is either an empty type or has
exactly one inhabitant.

Proof irrelevance can be proved `by refl`.

An unfortunate consequence of proof irrelevance is that it prevents us from
performing rule induction by pattern matching. -/

#check proof_irrel

lemma proof_irrel {a : Prop} (h₁ h₂ : a) :
  h₁ = h₂ :=
by refl

/- ### No Large Elimination

A further difference between `Prop` and `Type u` is that `Prop` does not allow
__large elimination__, meaning that it impossible to extract data from a proof
of a proposition.

This is necessary to allow proof irrelevance. -/

#check 0

-- fails
def unsquare (i : ℤ) (hsq : ∃j, i = j * j) : ℤ :=
match hsq with
| Exists.intro j _ := j
end

/- If the above were accepted, we could derive `false` as follows.

Let

    `hsq₁` := `Exists.intro 3 (by linarith)`
    `hsq₂` := `Exists.intro (-3) (by linarith)`

be two proofs of `∃j, (9 : ℤ) = j * j`. Then

    `unsquare 9 hsq₁ = 3`
    `unsquare 9 hsq₂ = -3`

However, by proof irrelevance, `hsq₁ = hsq₂`. Hence

    `unsquare 9 hsq₂ = 3`

Thus

    `3 = -3`

a contradiction.

As a compromise, Lean allows __small elimination__. It is called small
elimination because it eliminate only into `Prop`, whereas large elimination can
eliminate into an arbitrary large universe `Sort u`. This means we can use
`match` to analyze the structure of a proof, extract existential witnesses, and
so on, as long as the `match` expression is itself a proof. We have seen several
examples of this in lecture 5.

As a further compromise, Lean allows large elimination for
__syntactic subsingletons__: types in `Prop` for which it can be established
syntactically that they have cardinality 0 or 1. These are propositions such as
`false` and `a ∧ b` that can be proved in at most one way.

## The Axiom of Choice

Lean's logic includes the axiom of choice, which makes it possible to obtain an
arbitrary element from any nonempty type.

Consider Lean's `nonempty` inductive predicate: -/

#print nonempty

/- The predicate states that `α` has at least one element.

To prove `nonempty α`, we must provide an `α` value to `nonempty.intro`: -/

lemma nat.nonempty :
  nonempty ℕ :=
nonempty.intro 0

/- Since `nonempty` lives in `Prop`, large elimination is not available, and
thus we cannot extract the element that was used from a proof of `nonempty α`.

The axiom of choice allows us to obtain some element of type `α` if we can show
`nonempty α`: -/

#print classical.choice

/- It will just give us an arbitrary element of `α`; we have no way of knowing
whether this is the element that was used to prove `nonempty α`.

The constant `classical.choice` is noncomputable, one of the reasons why some
logicians prefer to work without this axiom. -/

#eval classical.choice nat.nonempty     -- fails
#reduce classical.choice nat.nonempty   -- result: classical.choice _

/- The axiom of choice is only an axiom in Lean's core library, giving users
the freedom to work with or without it.

Definitions using it must be marked as `noncomputable`: -/

noncomputable def arbitrary_nat : ℕ :=
classical.choice nat.nonempty

/- The following tools rely on choice.

### Law of Excluded Middle -/

#check classical.em
#check classical.by_contradiction

/- ### Hilbert Choice -/

#print classical.some
#print classical.some_spec

#check λ(p : ℕ → Prop) (h : ∃n : ℕ, p n), classical.some h
#check λ(p : ℕ → Prop) (h : ∃n : ℕ, p n), classical.some_spec h

/- ### Set-Theoretic Axiom of Choice -/

#print classical.axiom_of_choice

/- ## Subtypes

Subtyping is a mechanism to create new types from existing ones.

Given a predicate on the elements of the base type, the __subtype__ contains
only those elements of the base type that fulfill this property. More precisely,
the subtype contains element–proof pairs that combine an element of the base
type and a proof that it fulfills the property.

Subtyping is useful for those types that cannot be defined as an inductive
type. For example, any attempt at defining the type of finite sets along the
following lines is doomed to fail: -/

inductive finset (α : Type) : Type
| empty  : finset
| insert : α → finset → finset

/- Given a base type and a property, the subtype has the syntax

    `{` _variable_ `:` _base-type_ `//` _property-applied-to-variable_ `}`

Example:

    `{i : ℕ // i ≤ n}`

Alias:

    `{x : τ // P[x]}` := `@subtype τ (λx, P[x])`

### First Example: Full Binary Trees -/

#check btree
#check is_full
#check mirror
#check is_full_mirror
#check mirror_mirror

def full_btree (α : Type) : Type :=
{t : btree α // is_full t}

#print subtype
#check subtype.mk

/- To define elements of `full_btree`, we must provide a `btree` and a proof
that it is full: -/

def empty_full_btree : full_btree ℕ :=
subtype.mk btree.empty is_full.empty

def full_btree_6 : full_btree ℕ :=
subtype.mk (btree.node 6 btree.empty btree.empty)
  begin
    apply is_full.node,
    apply is_full.empty,
    apply is_full.empty,
    refl
  end

#reduce subtype.val full_btree_6
#check subtype.property full_btree_6

/- We can lift existing operations on `btree` to `full_btree`: -/

def full_btree.mirror {α : Type} (t : full_btree α) :
  full_btree α :=
subtype.mk (mirror (subtype.val t))
  begin
    apply is_full_mirror,
    apply subtype.property t
  end

#reduce subtype.val (full_btree.mirror full_btree_6)

/- And of course we can prove lemmas about the lifted operations: -/

lemma full_btree.mirror_mirror {α : Type} (t : full_btree α) :
  (full_btree.mirror (full_btree.mirror t)) = t :=
begin
  apply subtype.eq,
  simp [full_btree.mirror],
  apply mirror_mirror
end

#check subtype.eq

/- ### Second Example: Vectors -/

#check vector

def vector (α : Type) (n : ℕ) : Type :=
{xs : list α // list.length xs = n}

def vector_123 : vector ℤ 3 :=
subtype.mk [1, 2, 3] (by refl)

def vector.neg {n : ℕ} (v : vector ℤ n) : vector ℤ n :=
subtype.mk (list.map int.neg (subtype.val v))
  begin
    rw list.length_map,
    exact subtype.property v
  end

lemma vector.neg_neg (n : ℕ) (v : vector ℤ n) :
  vector.neg (vector.neg v) = v :=
begin
  apply subtype.eq,
  simp [vector.neg]
end

#check finset

/- ## Quotient Types

Quotients are a powerful construction in mathematics used to construct `ℤ`, `ℚ`,
`ℝ`, and many other types.

Like subtyping, quotienting constructs a new type from an existing type. Unlike
a subtype, a quotient type contains all of the elements of the base type, but
some elements that were different in the base type are considered equal in the
quotient type. In mathematical terms, the quotient type is isomorphic to a
partition of the base type.

To define a quotient type, we need to provide a type that it is derived from and
a equivalence relation on it that determines which elements are considered
equal. -/

#check quotient
#print setoid

#check quotient.mk
#check quotient.sound
#check quotient.exact

#check quotient.lift
#check quotient.lift₂
#check quotient.induction_on

/- ## First Example: Integers

Let us build the integers `ℤ` as a quotient over pairs of natural numbers
`ℕ × ℕ`.

A pair `(p, n)` of natural numbers represents the integer `p - n`. Nonnegative
integers `p` can be represented by `(p, 0)`. Negative integers `-n` can be
represented by `(0, n)`. However, many representations of the same integer are
possible; e.g., `(7, 0)`, `(8, 1)`, `(9, 2)`, and `(10, 3)` all represent the
integer `7`.

Which equivalence relation can we use?

We want two pairs `(p₁, n₁)` and `(p₂, n₂)` to be equal if `p₁ - n₁ = p₂ - n₂`.
However, this does not work because subtraction on `ℕ` is ill-behaved (e.g.,
`0 - 1 = 0`). Instead, we use `p₁ + n₂ = p₂ + n₁`. -/

@[instance] def int.rel : setoid (ℕ × ℕ) :=
{ r     :=
    λpn₁ pn₂ : ℕ × ℕ,
      prod.fst pn₁ + prod.snd pn₂ = prod.fst pn₂ + prod.snd pn₁,
  iseqv :=
    begin
      repeat { apply and.intro },
      { intro pn,
        refl },
      { intros pn₁ pn₂ h,
        rw h },
      { intros pn₁ pn₂ pn₃ h₁₂ h₂₃,
        apply @add_right_cancel _ _ _ (prod.snd pn₂),
        cc }
    end }

#print equivalence

lemma int.rel_iff (pn₁ pn₂ : ℕ × ℕ) :
  pn₁ ≈ pn₂ ↔
  prod.fst pn₁ + prod.snd pn₂ = prod.fst pn₂ + prod.snd pn₁ :=
by refl

def int : Type :=
quotient int.rel

def int.zero : int :=
⟦(0, 0)⟧

lemma int.zero_eq (m : ℕ) :
  int.zero = ⟦(m, m)⟧ :=
begin
  rw int.zero,
  apply quotient.sound,
  rw int.rel_iff,
  simp
end

def int.add : int → int → int :=
quotient.lift₂
  (λpn₁ pn₂ : ℕ × ℕ,
     ⟦(prod.fst pn₁ + prod.fst pn₂,
       prod.snd pn₁ + prod.snd pn₂)⟧)
  begin
    intros pn₁ pn₂ pn₁' pn₂' h₁ h₂,
    apply quotient.sound,
    rw int.rel_iff at *,
    linarith
  end

lemma int.add_eq (p₁ n₁ p₂ n₂ : ℕ) :
  int.add ⟦(p₁, n₁)⟧ ⟦(p₂, n₂)⟧ = ⟦(p₁ + p₂, n₁ + n₂)⟧ :=
by refl

lemma int.add_zero (i : int) :
  int.add int.zero i = i :=
begin
  apply quotient.induction_on i,
  intro pn,
  rw int.zero,
  cases' pn with p n,
  rw int.add_eq,
  apply quotient.sound,
  simp
end

/- This definitional syntax would be nice: -/

-- fails
def int.add : int → int → int
| ⟦(p₁, n₁)⟧ ⟦(p₂, n₂)⟧ := ⟦(p₁ + p₂, n₁ + n₂)⟧

/- But it would be dangerous: -/

-- fails
def int.fst : int → ℕ
| ⟦(p, n)⟧ := p

/- Using `int.fst`, we could derive `false`. First, we have

    `int.fst ⟦(0, 0)⟧ = 0`
    `int.fst ⟦(1, 1)⟧ = 1`

But since `⟦(0, 0)⟧ = ⟦(1, 1)⟧`, we get

    `0 = 1` -/

/- ### Second Example: Unordered Pairs

__Unordered pairs__ are pairs for which no distinction is made between the first
and second components. They are usually written `{a, b}`.

We will introduce the type `upair` of unordered pairs as the quotient of pairs
`(a, b)` with respect to the relation "contains the same elements as". -/

@[instance] def upair.rel (α : Type) : setoid (α × α) :=
{ r     := λab₁ ab₂ : α × α,
    ({prod.fst ab₁, prod.snd ab₁} : set α) =
    ({prod.fst ab₂, prod.snd ab₂} : set α),
  iseqv := by repeat { apply and.intro }; finish }

-- needed for technical reasons, to deprioritize `upair.rel` w.r.t. `int.rel`
attribute [instance, priority 999] upair.rel

lemma upair.rel_iff {α : Type} (ab₁ ab₂ : α × α) :
  ab₁ ≈ ab₂ ↔
  ({prod.fst ab₁, prod.snd ab₁} : set α) =
  ({prod.fst ab₂, prod.snd ab₂} : set α) :=
by refl

def upair (α : Type) : Type :=
quotient (upair.rel α)

def upair.mk {α : Type} (a b : α) : upair α :=
⟦(a, b)⟧

/- It is easy to prove that the `upair.mk` constructor is symmetric: -/

lemma upair.mk_symm {α : Type} (a b : α) :
  upair.mk a b = upair.mk b a :=
begin
  unfold upair.mk,
  apply quotient.sound,
  rw upair.rel_iff,
  apply set.union_comm
end

/- Another representation of unordered pairs is as sets of cardinality 1 or 2.
The following operation converts `upair` to that representation: -/

def set_of_upair {α : Type} : upair α → set α :=
quotient.lift (λab : α × α, {prod.fst ab, prod.snd ab})
  begin
    intros ab₁ ab₂ h,
    rw upair.rel_iff at *,
    exact h
  end

/- ### Alternative Definitions via Normalization and Subtyping

Each element of a quotient type correspond to an `≈`-equivalence class.
If there exists a systematic way to obtain a **canonical representative** for
each class, we can use a subtype instead of a quotient, keeping only the
canonical representatives.

Consider the quotient type `int` above. We could say that a pair `(p, n)` is
__canonical__ if `p` or `n` is `0`. -/

namespace alternative

inductive int.is_canonical : ℕ × ℕ → Prop
| nonpos {n : ℕ} : int.is_canonical (0, n)
| nonneg {p : ℕ} : int.is_canonical (p, 0)

def int : Type :=
{pn : ℕ × ℕ // int.is_canonical pn}

/- **Normalizing** pairs of natural numbers is easy: -/

def int.normalize : ℕ × ℕ → ℕ × ℕ
| (p, n) := if p ≥ n then (p - n, 0) else (0, n - p)

lemma int.is_canonical_normalize (pn : ℕ × ℕ) :
  int.is_canonical (int.normalize pn) :=
begin
  cases' pn with p n,
  simp [int.normalize],
  split_ifs,
  { exact int.is_canonical.nonneg },
  { exact int.is_canonical.nonpos }
end

/- For unordered pairs, there is no obvious normal form, except to always put
the smaller element first (or last). This requires a linear order `≤` on `α`. -/

def upair.is_canonical {α : Type} [linear_order α] :
  α × α → Prop
| (a, b) := a ≤ b

def upair (α : Type) [linear_order α] : Type :=
{ab : α × α // upair.is_canonical ab}

end alternative

end LoVe


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

import algebra.algebra.subalgebra

/-!
# Towers of algebras

In this file we prove basic facts about towers of algebra.

An algebra tower A/S/R is expressed by having instances of `algebra A S`,
`algebra R S`, `algebra R A` and `is_scalar_tower R S A`, the later asserting the
compatibility condition `(r • s) • a = r • (s • a)`.

An important definition is `to_alg_hom R S A`, the canonical `R`-algebra homomorphism `S →ₐ[R] A`.

-/

open_locale pointwise
universes u v w u₁ v₁

variables (R : Type u) (S : Type v) (A : Type w) (B : Type u₁) (M : Type v₁)

namespace algebra

variables [comm_semiring R] [semiring A] [algebra R A]
variables [add_comm_monoid M] [module R M] [module A M] [is_scalar_tower R A M]

variables {A}

/-- The `R`-algebra morphism `A → End (M)` corresponding to the representation of the algebra `A`
on the `R`-module `M`.

This is a stronger version of `distrib_mul_action.to_linear_map`, and could also have been
called `algebra.to_module_End`. -/
def lsmul : A →ₐ[R] module.End R M :=
{ to_fun := distrib_mul_action.to_linear_map R M,
  map_one' := linear_map.ext $ λ _, one_smul A _,
  map_mul' := λ a b, linear_map.ext $ smul_assoc a b,
  map_zero' := linear_map.ext $ λ _, zero_smul A _,
  map_add' := λ a b, linear_map.ext $ λ _, add_smul _ _ _,
  commutes' := λ r, linear_map.ext $ algebra_map_smul A r, }

@[simp] lemma lsmul_coe (a : A) : (lsmul R M a : M → M) = (•) a := rfl

lemma lmul_algebra_map (x : R) :
  lmul R A (algebra_map R A x) = algebra.lsmul R A x :=
eq.symm $ linear_map.ext $ smul_def x

end algebra

namespace is_scalar_tower

section module

variables [comm_semiring R] [semiring A] [algebra R A]
variables [add_comm_monoid M] [module R M] [module A M] [is_scalar_tower R A M]

variables {R} (A) {M}
theorem algebra_map_smul (r : R) (x : M) : algebra_map R A r • x = r • x :=
by rw [algebra.algebra_map_eq_smul_one, smul_assoc, one_smul]

end module

section semiring
variables [comm_semiring R] [comm_semiring S] [semiring A] [semiring B]
variables [algebra R S] [algebra S A] [algebra S B]

variables {R S A}
theorem of_algebra_map_eq [algebra R A]
  (h : ∀ x, algebra_map R A x = algebra_map S A (algebra_map R S x)) :
  is_scalar_tower R S A :=
⟨λ x y z, by simp_rw [algebra.smul_def, ring_hom.map_mul, mul_assoc, h]⟩

/-- See note [partially-applied ext lemmas]. -/
theorem of_algebra_map_eq' [algebra R A]
  (h : algebra_map R A = (algebra_map S A).comp (algebra_map R S)) :
  is_scalar_tower R S A :=
of_algebra_map_eq $ ring_hom.ext_iff.1 h

variables (R S A)

instance subalgebra (S₀ : subalgebra R S) : is_scalar_tower S₀ S A :=
of_algebra_map_eq $ λ x, rfl

variables [algebra R A] [algebra R B]
variables [is_scalar_tower R S A] [is_scalar_tower R S B]

theorem algebra_map_eq :
  algebra_map R A = (algebra_map S A).comp (algebra_map R S) :=
ring_hom.ext $ λ x, by simp_rw [ring_hom.comp_apply, algebra.algebra_map_eq_smul_one,
    smul_assoc, one_smul]

theorem algebra_map_apply (x : R) : algebra_map R A x = algebra_map S A (algebra_map R S x) :=
by rw [algebra_map_eq R S A, ring_hom.comp_apply]

instance subalgebra' (S₀ : subalgebra R S) : is_scalar_tower R S₀ A :=
@is_scalar_tower.of_algebra_map_eq R S₀ A _ _ _ _ _ _ $ λ _,
(is_scalar_tower.algebra_map_apply R S A _ : _)

@[ext] lemma algebra.ext {S : Type u} {A : Type v} [comm_semiring S] [semiring A]
  (h1 h2 : algebra S A) (h : ∀ {r : S} {x : A}, (by haveI := h1; exact r • x) = r • x) : h1 = h2 :=
begin
  unfreezingI { cases h1 with f1 g1 h11 h12, cases h2 with f2 g2 h21 h22, cases f1, cases f2, },
  congr',
  { ext r x, exact h },
  { ext r, erw [← mul_one (g1 r), ← h12, ← mul_one (g2 r), ← h22, h], refl, },
end

/-- In a tower, the canonical map from the middle element to the top element is an
algebra homomorphism over the bottom element. -/
def to_alg_hom : S →ₐ[R] A :=
{ commutes' := λ _, (algebra_map_apply _ _ _ _).symm,
  .. algebra_map S A }

lemma to_alg_hom_apply (y : S) : to_alg_hom R S A y = algebra_map S A y := rfl

@[simp] lemma coe_to_alg_hom : ↑(to_alg_hom R S A) = algebra_map S A :=
ring_hom.ext $ λ _, rfl

@[simp] lemma coe_to_alg_hom' : (to_alg_hom R S A : S → A) = algebra_map S A :=
rfl

variables {R S A B}

@[simp, priority 900] lemma _root_.alg_hom.map_algebra_map (f : A →ₐ[S] B) (r : R) :
  f (algebra_map R A r) = algebra_map R B r :=
by rw [algebra_map_apply R S A r, f.commutes, ← algebra_map_apply R S B]

variables (R)

@[simp, priority 900] lemma _root_.alg_hom.comp_algebra_map_of_tower (f : A →ₐ[S] B) :
  (f : A →+* B).comp (algebra_map R A) = algebra_map R B :=
ring_hom.ext f.map_algebra_map

variables (R) {S A B}

-- conflicts with is_scalar_tower.subalgebra
@[priority 999] instance subsemiring (U : subsemiring S) : is_scalar_tower U S A :=
of_algebra_map_eq $ λ x, rfl

@[nolint instance_priority]
instance of_ring_hom {R A B : Type*} [comm_semiring R] [comm_semiring A] [comm_semiring B]
  [algebra R A] [algebra R B] (f : A →ₐ[R] B) :
  @is_scalar_tower R A B _ (f.to_ring_hom.to_algebra.to_has_scalar) _ :=
by { letI := (f : A →+* B).to_algebra, exact of_algebra_map_eq (λ x, (f.commutes x).symm) }

end semiring

end is_scalar_tower

section homs

variables [comm_semiring R] [comm_semiring S] [semiring A] [semiring B]
variables [algebra R S] [algebra S A] [algebra S B]
variables [algebra R A] [algebra R B]
variables [is_scalar_tower R S A] [is_scalar_tower R S B]

variables (R) {A S B}

open is_scalar_tower

namespace alg_hom

/-- R ⟶ S induces S-Alg ⥤ R-Alg -/
def restrict_scalars (f : A →ₐ[S] B) : A →ₐ[R] B :=
{ commutes' := λ r, by { rw [algebra_map_apply R S A, algebra_map_apply R S B],
    exact f.commutes (algebra_map R S r) },
  .. (f : A →+* B) }

lemma restrict_scalars_apply (f : A →ₐ[S] B) (x : A) : f.restrict_scalars R x = f x := rfl

@[simp] lemma coe_restrict_scalars (f : A →ₐ[S] B) : (f.restrict_scalars R : A →+* B) = f := rfl

@[simp] lemma coe_restrict_scalars' (f : A →ₐ[S] B) : (restrict_scalars R f : A → B) = f := rfl

lemma restrict_scalars_injective :
  function.injective (restrict_scalars R : (A →ₐ[S] B) → (A →ₐ[R] B)) :=
λ f g h, alg_hom.ext (alg_hom.congr_fun h : _)

end alg_hom

namespace alg_equiv

/-- R ⟶ S induces S-Alg ⥤ R-Alg -/
def restrict_scalars (f : A ≃ₐ[S] B) : A ≃ₐ[R] B :=
{ commutes' := λ r, by { rw [algebra_map_apply R S A, algebra_map_apply R S B],
    exact f.commutes (algebra_map R S r) },
  .. (f : A ≃+* B) }

lemma restrict_scalars_apply (f : A ≃ₐ[S] B) (x : A) : f.restrict_scalars R x = f x := rfl

@[simp] lemma coe_restrict_scalars (f : A ≃ₐ[S] B) : (f.restrict_scalars R : A ≃+* B) = f := rfl

@[simp] lemma coe_restrict_scalars' (f : A ≃ₐ[S] B) : (restrict_scalars R f : A → B) = f := rfl

lemma restrict_scalars_injective :
  function.injective (restrict_scalars R : (A ≃ₐ[S] B) → (A ≃ₐ[R] B)) :=
λ f g h, alg_equiv.ext (alg_equiv.congr_fun h : _)

end alg_equiv

end homs

namespace subalgebra

open is_scalar_tower

section semiring

variables (R) {S A B} [comm_semiring R] [comm_semiring S] [semiring A] [semiring B]
variables [algebra R S] [algebra S A] [algebra R A] [algebra S B] [algebra R B]
variables [is_scalar_tower R S A] [is_scalar_tower R S B]

/-- Given a scalar tower `R`, `S`, `A` of algebras, reinterpret an `S`-subalgebra of `A` an as an
`R`-subalgebra. -/
def restrict_scalars (U : subalgebra S A) : subalgebra R A :=
{ algebra_map_mem' := λ x, by { rw algebra_map_apply R S A, exact U.algebra_map_mem _ },
  .. U }

@[simp] lemma coe_restrict_scalars {U : subalgebra S A} :
  (restrict_scalars R U : set A) = (U : set A) := rfl

@[simp] lemma restrict_scalars_top : restrict_scalars R (⊤ : subalgebra S A) = ⊤ :=
set_like.coe_injective rfl

@[simp] lemma restrict_scalars_to_submodule {U : subalgebra S A} :
  (U.restrict_scalars R).to_submodule = U.to_submodule.restrict_scalars R :=
set_like.coe_injective rfl

@[simp] lemma mem_restrict_scalars {U : subalgebra S A} {x : A} :
  x ∈ restrict_scalars R U ↔ x ∈ U := iff.rfl

lemma restrict_scalars_injective :
  function.injective (restrict_scalars R : subalgebra S A → subalgebra R A) :=
λ U V H, ext $ λ x, by rw [← mem_restrict_scalars R, H, mem_restrict_scalars]

/-- Produces an `R`-algebra map from `U.restrict_scalars R` given an `S`-algebra map from `U`.

This is a special case of `alg_hom.restrict_scalars` that can be helpful in elaboration. -/
@[simp]
def of_restrict_scalars (U : subalgebra S A) (f : U →ₐ[S] B) : U.restrict_scalars R →ₐ[R] B :=
f.restrict_scalars R

end semiring

end subalgebra

namespace is_scalar_tower

open subalgebra

variables [comm_semiring R] [comm_semiring S] [comm_semiring A]
variables [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A]

theorem adjoin_range_to_alg_hom (t : set A) :
  (algebra.adjoin (to_alg_hom R S A).range t).restrict_scalars R =
    (algebra.adjoin S t).restrict_scalars R :=
subalgebra.ext $ λ z,
show z ∈ subsemiring.closure (set.range (algebra_map (to_alg_hom R S A).range A) ∪ t : set A) ↔
  z ∈ subsemiring.closure (set.range (algebra_map S A) ∪ t : set A),
from suffices set.range (algebra_map (to_alg_hom R S A).range A) = set.range (algebra_map S A),
  by rw this,
by { ext z, exact ⟨λ ⟨⟨x, y, h1⟩, h2⟩, ⟨y, h2 ▸ h1⟩, λ ⟨y, hy⟩, ⟨⟨z, y, hy⟩, rfl⟩⟩ }

end is_scalar_tower

section semiring

variables {R S A}
variables [comm_semiring R] [semiring S] [add_comm_monoid A]
variables [algebra R S] [module S A] [module R A] [is_scalar_tower R S A]

namespace submodule

open is_scalar_tower

theorem smul_mem_span_smul_of_mem {s : set S} {t : set A} {k : S} (hks : k ∈ span R s)
  {x : A} (hx : x ∈ t) : k • x ∈ span R (s • t) :=
span_induction hks (λ c hc, subset_span $ set.mem_smul.2 ⟨c, x, hc, hx, rfl⟩)
  (by { rw zero_smul, exact zero_mem _ })
  (λ c₁ c₂ ih₁ ih₂, by { rw add_smul, exact add_mem _ ih₁ ih₂ })
  (λ b c hc, by { rw is_scalar_tower.smul_assoc, exact smul_mem _ _ hc })

theorem smul_mem_span_smul {s : set S} (hs : span R s = ⊤) {t : set A} {k : S}
  {x : A} (hx : x ∈ span R t) :
  k • x ∈ span R (s • t) :=
span_induction hx (λ x hx, smul_mem_span_smul_of_mem (hs.symm ▸ mem_top) hx)
  (by { rw smul_zero, exact zero_mem _ })
  (λ x y ihx ihy, by { rw smul_add, exact add_mem _ ihx ihy })
  (λ c x hx, smul_comm c k x ▸ smul_mem _ _ hx)

theorem span_smul {s : set S} (hs : span R s = ⊤) (t : set A) :
  span R (s • t) = (span S t).restrict_scalars R :=
le_antisymm (span_le.2 $ λ x hx, let ⟨p, q, hps, hqt, hpqx⟩ := set.mem_smul.1 hx in
  hpqx ▸ (span S t).smul_mem p (subset_span hqt)) $
λ p hp, span_induction hp (λ x hx, one_smul S x ▸ smul_mem_span_smul hs (subset_span hx))
  (zero_mem _)
  (λ _ _, add_mem _)
  (λ k x hx, smul_mem_span_smul' hs hx)

end submodule

end semiring

section ring

namespace algebra

variables [comm_semiring R] [ring A] [algebra R A]
variables [add_comm_group M] [module A M] [module R M] [is_scalar_tower R A M]

lemma lsmul_injective [no_zero_smul_divisors A M] {x : A} (hx : x ≠ 0) :
  function.injective (lsmul R M x) :=
smul_right_injective _ hx

end algebra

end ring


import measure_theory.integration
import data.real.ereal
import lemmas

/-
This file has been merged into mathlib. `measure_theory.vector_measure`

We will in this file attempt to define signed measure and develope basic APIs
for its use.
-/

noncomputable theory
open_locale classical big_operators nnreal ennreal

variables {α β : Type*}
variables [measurable_space α]

/-- A signed measure on a measurable space `α` is a σ-additive, real-valued function
that maps the empty set to zero. -/
structure signed_measure (α : Type*) [measurable_space α] :=
(measure_of : set α → ℝ)
(empty : measure_of ∅ = 0)
(not_measurable ⦃i : set α⦄ : ¬ measurable_set i → measure_of i = 0)
(m_Union ⦃f : ℕ → set α⦄ :
  (∀ i, measurable_set (f i)) → pairwise (disjoint on f) →
  measure_of (⋃ i, f i) = ∑' i, measure_of (f i))

instance : has_coe_to_fun (signed_measure α) :=
⟨λ _, set α → ℝ, signed_measure.measure_of⟩

open set measure_theory

namespace signed_measure

variables {s : signed_measure α} {f : ℕ → set α}

lemma apply (s : signed_measure α) (i : set α) : s i = s.measure_of i := rfl

@[simp]
lemma measure_of_empty (s : signed_measure α) : s ∅ = 0 := s.empty

lemma measure_of_not_measurable_set (s : signed_measure α)
  {i : set α} (hi : ¬ measurable_set i) : s i = 0 := s.not_measurable hi

lemma measure_of_disjoint_Union (s : signed_measure α)
  (hf₁ : ∀ i, measurable_set (f i)) (hf₂ : pairwise (disjoint on f)) :
  s (⋃ i, f i) = ∑' i, s (f i) := s.m_Union hf₁ hf₂

lemma ext_iff' (s t : signed_measure α) :
  s = t ↔ ∀ i : set α, s i = t i :=
begin
  cases s, cases t, simpa [function.funext_iff],
end

lemma ext_iff (s t : signed_measure α) :
  s = t ↔ ∀ i : set α, measurable_set i → s i = t i :=
begin
  split,
  { rintro rfl _ _, refl },
  { rw ext_iff',
    intros h i,
    by_cases hi : measurable_set i,
    { exact h i hi },
    { simp_rw [measure_of_not_measurable_set _ hi] } }
end

@[ext] lemma ext {s t : signed_measure α}
  (h : ∀ i : set α, measurable_set i → s i = t i) : s = t :=
(ext_iff s t).2 h

lemma measure_Union [encodable β] {f : β → set α}
  (hf₁ : ∀ i, measurable_set (f i)) (hf₂ : pairwise (disjoint on f)) :
  s (⋃ i, f i) = ∑' i, s (f i) :=
begin
  rw [← encodable.Union_decode₂, ← tsum_Union_decode₂],
  apply s.m_Union,
  { exact measurable_set.bUnion_decode₂ hf₁ },
  { exact encodable.Union_decode₂_disjoint_on hf₂ },
  { exact s.empty }
end

lemma measure_of_union {A B : set α}
  (h : disjoint A B) (hA : measurable_set A) (hB : measurable_set B) :
  s (A ∪ B) = s A + s B :=
begin
  rw [union_eq_Union, measure_Union, tsum_fintype, fintype.sum_bool, cond, cond],
  exacts [λ b, bool.cases_on b hB hA, pairwise_disjoint_on_bool.2 h]
end

lemma measure_of_diff {A B : set α} (hA : measurable_set A) (hB : measurable_set B)
  (h : A ⊆ B) : s A + s (B \ A) = s B :=
by rw [← measure_of_union disjoint_diff hA (hB.diff hA), union_diff_cancel h]

lemma measure_of_diff' {A B : set α} (hA : measurable_set A) (hB : measurable_set B)
  (h : A ⊆ B) : s (B \ A) = s B - s A :=
by rw [← measure_of_diff hA hB h, add_sub_cancel']

lemma measure_of_nonneg_disjoint_union_eq_zero {s : signed_measure α} {A B : set α}
  (h : disjoint A B) (hA₁ : measurable_set A) (hB₁ : measurable_set B)
  (hA₂ : 0 ≤ s A) (hB₂ : 0 ≤ s B)
  (hAB : s (A ∪ B) = 0) : s A = 0 :=
begin
  rw measure_of_union h hA₁ hB₁ at hAB,
  linarith,
end

lemma measure_of_nonpos_disjoint_union_eq_zero {s : signed_measure α} {A B : set α}
  (h : disjoint A B) (hA₁ : measurable_set A) (hB₁ : measurable_set B)
  (hA₂ : s A ≤ 0) (hB₂ : s B ≤ 0)
  (hAB : s (A ∪ B) = 0) : s A = 0 :=
begin
  rw measure_of_union h hA₁ hB₁ at hAB,
  linarith,
end

lemma measure_of_Union_nonneg (hf₁ : ∀ i, measurable_set (f i))
  (hf₂ : pairwise (disjoint on f)) (hf₃ : ∀ i, 0 ≤ s (f i)) :
  0 ≤ s (⋃ i, f i) :=
(s.measure_of_disjoint_Union hf₁ hf₂).symm ▸ tsum_nonneg hf₃

lemma measure_of_Union_nonpos (hf₁ : ∀ i, measurable_set (f i))
  (hf₂ : pairwise (disjoint on f)) (hf₃ : ∀ i, s (f i) ≤ 0) :
  s (⋃ i, f i) ≤ 0 :=
(s.measure_of_disjoint_Union hf₁ hf₂).symm ▸ tsum_nonpos hf₃

private lemma summable_measure_of_nonneg
  (hf₁ : ∀ i, measurable_set (f i)) (hf₂ : pairwise (disjoint on f))
  (hf₃ : ∀ i, 0 ≤ s (f i)) : summable (s ∘ f) :=
begin
  have := s.measure_of_disjoint_Union hf₁ hf₂,
  by_cases s (⋃ (i : ℕ), (λ (i : ℕ), f i) i) = 0,
  { suffices : ∀ i, s (f i) = 0,
    { convert summable_zero, ext i, exact this i },
    intro i, rw ← set.union_Union_neq_eq_Union f i at h,
    have hmeas : ∀ j, measurable_set (⋃ (hi : j ≠ i), f j),
    { intro j, by_cases i = j,
      { convert measurable_set.empty,
        rw Union_eq_empty,
        exact λ hij, false.elim (hij h.symm) },
      { convert hf₁ j,
        ext x, rw [mem_Union, exists_prop, and_iff_right_iff_imp],
        exact λ _, ne.symm h } },
    refine measure_of_nonneg_disjoint_union_eq_zero _ (hf₁ i) _ (hf₃ i) _ h,
    { intros x hx,
      simp only [exists_prop, mem_Union, mem_inter_eq, inf_eq_inter] at hx,
      exact let ⟨hfi, j, hij, hfj⟩ := hx in hf₂ j i hij ⟨hfj, hfi⟩ },
    { refine measurable_set.Union hmeas },
    { refine measure_of_Union_nonneg hmeas _ _,
      { intros l m hlm x hx,
        simp only [exists_prop, mem_Union, mem_inter_eq, inf_eq_inter] at hx,
        exact hf₂ l m hlm (let ⟨⟨_, h₁⟩, _, h₂⟩ := hx in ⟨h₁, h₂⟩) },
      { intro j, by_cases i = j,
        { apply le_of_eq,
          convert s.empty.symm,
          rw Union_eq_empty,
          exact λ hij, false.elim (hij h.symm) },
        { convert hf₃ j,
          ext, rw [mem_Union, exists_prop, and_iff_right_iff_imp],
          exact λ _, ne.symm h } } } },
  { revert h, contrapose, intro h,
    rw [not_not, this, tsum_eq_zero_of_not_summable h] },
end

private lemma summable_measure_of_nonpos
  (hf₁ : ∀ i, measurable_set (f i)) (hf₂ : pairwise (disjoint on f))
  (hf₃ : ∀ i, s (f i) ≤ 0) : summable (s ∘ f) :=
begin
  have := s.measure_of_disjoint_Union hf₁ hf₂,
  by_cases s (⋃ (i : ℕ), (λ (i : ℕ), f i) i) = 0,
  { suffices : ∀ i, s (f i) = 0,
    { convert summable_zero, ext i, exact this i },
    intro i, rw ← set.union_Union_neq_eq_Union f i at h,
    have hmeas : ∀ j, measurable_set (⋃ (hi : j ≠ i), f j),
    { intro j, by_cases i = j,
      { convert measurable_set.empty,
        rw Union_eq_empty,
        exact λ hij, false.elim (hij h.symm) },
      { convert hf₁ j,
        ext x, rw [mem_Union, exists_prop, and_iff_right_iff_imp],
        exact λ _, ne.symm h } },
    refine measure_of_nonpos_disjoint_union_eq_zero _ (hf₁ i) _ (hf₃ i) _ h,
    { intros x hx,
      simp only [exists_prop, mem_Union, mem_inter_eq, inf_eq_inter] at hx,
      exact let ⟨hfi, j, hij, hfj⟩ := hx in hf₂ j i hij ⟨hfj, hfi⟩ },
    { refine measurable_set.Union hmeas },
    { refine measure_of_Union_nonpos hmeas _ _,
      { intros l m hlm x hx,
        simp only [exists_prop, mem_Union, mem_inter_eq, inf_eq_inter] at hx,
        exact hf₂ l m hlm (let ⟨⟨_, h₁⟩, _, h₂⟩ := hx in ⟨h₁, h₂⟩) },
      { intro j, by_cases i = j,
        { apply le_of_eq,
          convert s.empty,
          rw Union_eq_empty,
          exact λ hij, false.elim (hij h.symm) },
        { convert hf₃ j,
          ext, rw [mem_Union, exists_prop, and_iff_right_iff_imp],
          exact λ _, ne.symm h } } } },
  { revert h, contrapose, intro h,
    rw [not_not, this, tsum_eq_zero_of_not_summable h] },
end

/-- For all `n : ℕ`, `measure_of_nonneg_seq s f n` returns `f n` if `0 ≤ s (f n)`
and `∅` otherwise. -/
def measure_of_nonneg_seq (s : signed_measure α) (f : ℕ → set α) : ℕ → set α :=
λ i, if 0 ≤ (s ∘ f) i then f i else ∅

lemma measure_of_nonneg_seq_nonneg (i : ℕ) :
  0 ≤ s (s.measure_of_nonneg_seq f i) :=
begin
  by_cases 0 ≤ (s ∘ f) i,
  { simp_rw [measure_of_nonneg_seq, if_pos h],
    exact h },
  { simp_rw [measure_of_nonneg_seq, if_neg h, s.measure_of_empty] }
end

lemma measure_of_nonneg_seq_of_measurable_set (hf : ∀ i, measurable_set (f i))
  (i : ℕ) : measurable_set $ measure_of_nonneg_seq s f i :=
begin
  by_cases 0 ≤ (s ∘ f) i,
  { simp_rw [measure_of_nonneg_seq, if_pos h],
    exact hf i },
  { simp_rw [measure_of_nonneg_seq, if_neg h],
    exact measurable_set.empty }
end

lemma measure_of_nonneg_seq_of_disjoint (hf : pairwise (disjoint on f)) :
  pairwise $ disjoint on (s.measure_of_nonneg_seq f) :=
begin
  rintro i j hij x ⟨hx₁, hx₂⟩,
  by_cases hi : 0 ≤ (s ∘ f) i,
  { by_cases hj : 0 ≤ (s ∘ f) j,
    { simp_rw [measure_of_nonneg_seq, if_pos hi] at hx₁,
      simp_rw [measure_of_nonneg_seq, if_pos hj] at hx₂,
      exact hf i j hij ⟨hx₁, hx₂⟩ },
    { simp_rw [measure_of_nonneg_seq, if_neg hj] at hx₂,
      exact false.elim hx₂ } },
  { simp_rw [measure_of_nonneg_seq, if_neg hi] at hx₁,
    exact false.elim hx₁ }
end

/-- For all `n : ℕ`, `measure_of_nonneg_seq s f n` returns `f n` if `¬ 0 ≤ s (f n)`
and `∅` otherwise. -/
def measure_of_nonpos_seq (s : signed_measure α) (f : ℕ → set α) : ℕ → set α :=
λ i, if ¬ 0 ≤ (s ∘ f) i then f i else ∅

lemma measure_of_nonpos_seq_nonpos (i : ℕ) :
  s (s.measure_of_nonpos_seq f i) ≤ 0 :=
begin
  by_cases ¬ 0 ≤ (s ∘ f) i,
  { simp_rw [measure_of_nonpos_seq, if_pos h],
    exact le_of_not_ge h },
  { simp_rw [measure_of_nonpos_seq, if_neg h, s.measure_of_empty] }
end

lemma measure_of_nonpos_seq_of_measurable_set (hf : ∀ i, measurable_set (f i))
  (i : ℕ) : measurable_set $ measure_of_nonpos_seq s f i :=
begin
  by_cases ¬ 0 ≤ (s ∘ f) i,
  { simp_rw [measure_of_nonpos_seq, if_pos h],
    exact hf i },
  { simp_rw [measure_of_nonpos_seq, if_neg h],
    exact measurable_set.empty }
end

lemma measure_of_nonpos_seq_of_disjoint (hf : pairwise (disjoint on f)) :
  pairwise $ disjoint on (s.measure_of_nonpos_seq f) :=
begin
  rintro i j hij x ⟨hx₁, hx₂⟩,
  by_cases hi : ¬ 0 ≤ (s ∘ f) i,
  { by_cases hj : ¬ 0 ≤ (s ∘ f) j,
    { simp_rw [measure_of_nonpos_seq, if_pos hi] at hx₁,
      simp_rw [measure_of_nonpos_seq, if_pos hj] at hx₂,
      exact hf i j hij ⟨hx₁, hx₂⟩ },
    { simp_rw [measure_of_nonpos_seq, if_neg hj] at hx₂,
      exact false.elim hx₂ } },
  { simp_rw [measure_of_nonpos_seq, if_neg hi] at hx₁,
    exact false.elim hx₁ }
end

lemma measure_of_seq_eq (i : ℕ) :
  ∥s (f i)∥ = s (s.measure_of_nonneg_seq f i) - s (s.measure_of_nonpos_seq f i) :=
begin
  rw [measure_of_nonneg_seq, measure_of_nonpos_seq],
  by_cases 0 ≤ (s ∘ f) i,
  { have : ¬¬0 ≤ (s ∘ f) i := not_not.2 h,
    simp_rw [real.norm_of_nonneg h, if_pos h, if_neg this,
             s.measure_of_empty, _root_.sub_zero] },
  { simp_rw [real.norm_of_neg (lt_of_not_ge h), if_pos h, if_neg h,
             s.measure_of_empty, _root_.zero_sub] }
end

/-- Given a signed measure `s`, `s ∘ f` is summable for all sequence
`f` of pairwise disjoint measurable sets. -/
theorem summable_measure_of
  (hf₁ : ∀ i, measurable_set (f i)) (hf₂ : pairwise (disjoint on f)) :
  summable (s ∘ f) :=
begin
  /-
    It suffices to show `∑ |s ∘ f| < ∞`.
    Let `N+ := { i | s(f i) ≥ 0 }`
    and `N- := { i | s(f i) < 0 }`
    Then, `Σ i, |s ∘ f i| = ∑ i ∈ N+, s ∘ f i - ∑ i ∈ N-, s ∘ f i`
    Clearly, both sum are finite since `s.range = ℝ`.
  -/
  apply summable_of_summable_norm,
  simp_rw measure_of_seq_eq,
  apply summable.sub,
  { apply summable_measure_of_nonneg,
    { exact measure_of_nonneg_seq_of_measurable_set hf₁ },
    { exact measure_of_nonneg_seq_of_disjoint hf₂ },
    { exact measure_of_nonneg_seq_nonneg } },
  { apply summable_measure_of_nonpos,
    { exact measure_of_nonpos_seq_of_measurable_set hf₁ },
    { exact measure_of_nonpos_seq_of_disjoint hf₂ },
    { exact measure_of_nonpos_seq_nonpos } },
end

/-- A finite measure coerced into a real function is a signed measure. -/
def of_measure (μ : measure α) [hμ : finite_measure μ] : signed_measure α :=
{ measure_of := λ i : set α, if measurable_set i then (μ.measure_of i).to_real else 0,
  empty := by simp [μ.empty],
  not_measurable := λ _ hi, if_neg hi,
  m_Union :=
  begin
    intros _ hf₁ hf₂,
    rw [μ.m_Union hf₁ hf₂, ennreal.tsum_to_real_eq, if_pos (measurable_set.Union hf₁)],
    { congr, ext n, rw if_pos (hf₁ n) },
    { intros a ha,
      apply ne_of_lt hμ.measure_univ_lt_top,
      rw [eq_top_iff, ← ha, outer_measure.measure_of_eq_coe, coe_to_outer_measure],
      exact measure_mono (set.subset_univ _) }
  end }

lemma of_measure_apply_measurable {μ : measure α} [finite_measure μ]
  {i : set α} (hi : measurable_set i) :
  of_measure μ i = (μ i).to_real :=
if_pos hi

lemma of_measure_apply_not_measurable {μ : measure α} [finite_measure μ]
  {i : set α} (hi : ¬ measurable_set i) :
  of_measure μ i = 0 :=
if_neg hi

/-- The zero signed measure. -/
def zero : signed_measure α := of_measure 0

instance : has_zero (signed_measure α) := ⟨zero⟩
instance : inhabited (signed_measure α) := ⟨0⟩

@[simp]
lemma zero_apply (i : set α) : (0 : signed_measure α) i = 0 :=
begin
  by_cases measurable_set i,
  { exact of_measure_apply_measurable h },
  { exact of_measure_apply_not_measurable h }
end

/-- The negative of a signed measure is a signed measure. -/
def neg (s : signed_measure α) : signed_measure α :=
{ measure_of := -s,
  empty := by simp [s.empty],
  not_measurable := λ _ hi, by simp [s.measure_of_not_measurable_set hi],
  m_Union :=
  begin
    intros f hf₁ hf₂,
    change - _ = _,
    rw [s.measure_of_disjoint_Union hf₁ hf₂, ← tsum_neg], refl,
    exact summable_measure_of hf₁ hf₂
  end }

/-- The sum of two signed measure is a signed measure. -/
def add (s t : signed_measure α) : signed_measure α :=
{ measure_of := s + t,
  empty := by simp [s.empty, t.empty],
  not_measurable := λ _ hi,
    by simp [s.measure_of_not_measurable_set hi, t.measure_of_not_measurable_set hi],
  m_Union :=
  begin
    intros f hf₁ hf₂,
    simp only [pi.add_apply],
    rw [tsum_add, s.measure_of_disjoint_Union hf₁ hf₂,
        t.measure_of_disjoint_Union hf₁ hf₂];
    exact summable_measure_of hf₁ hf₂
  end }

instance : has_add (signed_measure α) := ⟨add⟩
instance : has_neg (signed_measure α) := ⟨neg⟩

@[simp]
lemma neg_apply {s : signed_measure α} (i : set α) :
  (-s) i = - s i := rfl

@[simp]
lemma add_apply {s t : signed_measure α} (i : set α) :
  (s + t) i = s i + t i := rfl

instance : add_comm_group (signed_measure α) :=
{ add := (+), zero := (0),
  neg := signed_measure.neg,
  add_assoc := by { intros, ext i; simp [add_assoc] },
  zero_add := by { intros, ext i; simp },
  add_zero := by { intros, ext i; simp },
  add_comm := by { intros, ext i; simp [add_comm] },
  add_left_neg := by { intros, ext i, simp } } .

/-- Given two finite measures `μ, ν`, `of_sub_measure μ ν` is the signed measure
corresponding to the function `μ - ν`. -/
def of_sub_measure (μ ν : measure α) [hμ : finite_measure μ] [hν : finite_measure ν] :
  signed_measure α :=
of_measure μ + - of_measure ν

lemma of_sub_measure_apply {μ ν : measure α} [finite_measure μ] [finite_measure ν]
  {i : set α} (hi : measurable_set i) :
  of_sub_measure μ ν i = (μ i).to_real - (ν i).to_real :=
begin
  rw [of_sub_measure, add_apply, neg_apply, of_measure_apply_measurable hi,
      of_measure_apply_measurable hi, sub_eq_add_neg]
end

/-- Given a real number `r` and a signed measure `s`, `smul r s` is the signed
measure corresponding to the function `r • s`. -/
def smul (r : ℝ) (s : signed_measure α) : signed_measure α :=
{ measure_of := r • s,
  empty := by simp,
  not_measurable := λ _ hi, by simp [s.measure_of_not_measurable_set hi],
  m_Union :=
  begin
    intros f hf₁ hf₂,
    rw [pi.smul_apply, s.measure_of_disjoint_Union hf₁ hf₂, ← tsum_smul], refl,
    exact summable_measure_of hf₁ hf₂
  end }

instance : has_scalar ℝ (signed_measure α) := ⟨smul⟩

@[simp]
lemma smul_apply {s : signed_measure α} {r : ℝ} (i : set α) :
  (r • s) i = r • s i := rfl

instance : module ℝ (signed_measure α) :=
{ one_smul := by { intros, ext i; simp [one_smul] },
  mul_smul := by { intros, ext i; simp [mul_smul] },
  smul_add := by { intros, ext i; simp [smul_add] },
  smul_zero := by { intros, ext i; simp [smul_zero] },
  add_smul := by { intros, ext i; simp [add_smul] },
  zero_smul := by { intros, ext i; simp [zero_smul] } } .

end signed_measure