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

Godel numbering for partial recursive functions.
-/
import computability.partrec

open encodable denumerable

namespace nat.partrec
open nat (mkpair)

theorem rfind' {f} (hf : nat.partrec f) : nat.partrec (nat.unpaired (λ a m,
  (nat.rfind (λ n, (λ m, m = 0) <$> f (mkpair a (n + m)))).map (+ m))) :=
partrec₂.unpaired'.2 $
begin
  refine partrec.map
    ((@partrec₂.unpaired' (λ (a b : ℕ),
      nat.rfind (λ n, (λ 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
end

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

end nat.partrec

namespace nat.partrec.code
open nat (mkpair unpair)
open nat.partrec (code)

protected def const : ℕ → code
| 0     := zero
| (n+1) := comp succ (const n)

protected def id : code := pair left right

def curry (c : code) (n : ℕ) : code :=
comp c (pair (code.const n) code.id)

def encode_code : code → ℕ
| zero         := 0
| succ         := 1
| left         := 2
| right        := 3
| (pair cf cg) := bit0 (bit0 $ mkpair (encode_code cf) (encode_code cg)) + 4
| (comp cf cg) := bit0 (bit1 $ mkpair (encode_code cf) (encode_code cg)) + 4
| (prec cf cg) := bit1 (bit0 $ mkpair (encode_code cf) (encode_code cg)) + 4
| (rfind' cf)  := bit1 (bit1 $ encode_code cf) + 4

def of_nat_code : ℕ → code
| 0     := zero
| 1     := succ
| 2     := left
| 3     := right
| (n+4) := let m := n.div2.div2 in
  have hm : m < n + 4, by simp [m, nat.div2_val];
  from 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, from lt_of_le_of_lt m.unpair_le_left hm,
  have m2 : m.unpair.2 < n + 4, from lt_of_le_of_lt m.unpair_le_right 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)
  end

private theorem encode_of_nat_code : ∀ n, encode_code (of_nat_code n) = n
| 0     := rfl
| 1     := rfl
| 2     := rfl
| 3     := rfl
| (n+4) := let m := n.div2.div2 in
  have hm : m < n + 4, by simp [m, nat.div2_val];
  from 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, from lt_of_le_of_lt m.unpair_le_left hm,
  have m2 : m.unpair.2 < n + 4, from lt_of_le_of_lt m.unpair_le_right 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,
  begin
    transitivity, 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]
  end

instance : denumerable code :=
mk' ⟨encode_code, of_nat_code,
  λ c, by induction c; try {refl}; simp [
    encode_code, of_nat_code, -add_comm, *],
  encode_of_nat_code⟩

theorem encode_code_eq : encode = encode_code := rfl
theorem of_nat_code_eq : of_nat code = of_nat_code := rfl

theorem encode_lt_pair (cf cg) :
  encode cf < encode (pair cf cg) ∧
  encode cg < encode (pair cf cg) :=
begin
  simp [encode_code_eq, encode_code, -add_comm],
  have := nat.mul_le_mul_right _ (dec_trivial : 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 _ (dec_trivial:0<4)),
  exact ⟨
    lt_of_le_of_lt (nat.le_mkpair_left _ _) this,
    lt_of_le_of_lt (nat.le_mkpair_right _ _) this⟩
end

theorem encode_lt_comp (cf cg) :
  encode cf < encode (comp cf cg) ∧
  encode cg < encode (comp cf cg) :=
begin
  suffices, exact (encode_lt_pair cf cg).imp
    (λ h, lt_trans h this) (λ h, lt_trans h this),
  change _, simp [encode_code_eq, encode_code, -add_comm],
  exact nat.bit0_lt (nat.lt_succ_self _),
end

theorem encode_lt_prec (cf cg) :
  encode cf < encode (prec cf cg) ∧
  encode cg < encode (prec cf cg) :=
begin
  suffices, exact (encode_lt_pair cf cg).imp
    (λ h, lt_trans h this) (λ h, lt_trans h this),
  change _, simp [encode_code_eq, encode_code, -add_comm],
  exact nat.lt_succ_self _,
end

theorem encode_lt_rfind' (cf) : encode cf < encode (rfind' cf) :=
begin
  simp [encode_code_eq, encode_code, -add_comm],
  have := nat.mul_le_mul_right _ (dec_trivial : 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 _ (dec_trivial:0<4)),
  exact le_of_lt (nat.bit0_lt_bit1 $ le_of_lt $
    nat.bit0_lt_bit1 $ le_refl _),
end

section
open primrec

theorem pair_prim : primrec₂ pair :=
primrec₂.of_nat_iff.2 $ primrec₂.encode_iff.1 $ nat_add.comp
  (nat_bit0.comp $ nat_bit0.comp $
    primrec₂.mkpair.comp
      (encode_iff.2 $ (primrec.of_nat code).comp fst)
      (encode_iff.2 $ (primrec.of_nat code).comp snd))
  (primrec₂.const 4)

theorem comp_prim : primrec₂ comp :=
primrec₂.of_nat_iff.2 $ primrec₂.encode_iff.1 $ nat_add.comp
  (nat_bit0.comp $ nat_bit1.comp $
    primrec₂.mkpair.comp
      (encode_iff.2 $ (primrec.of_nat code).comp fst)
      (encode_iff.2 $ (primrec.of_nat code).comp snd))
  (primrec₂.const 4)

theorem prec_prim : primrec₂ prec :=
primrec₂.of_nat_iff.2 $ primrec₂.encode_iff.1 $ nat_add.comp
  (nat_bit1.comp $ nat_bit0.comp $
    primrec₂.mkpair.comp
      (encode_iff.2 $ (primrec.of_nat code).comp fst)
      (encode_iff.2 $ (primrec.of_nat code).comp snd))
  (primrec₂.const 4)

theorem rfind_prim : primrec rfind' :=
of_nat_iff.2 $ encode_iff.1 $ nat_add.comp
  (nat_bit1.comp $ nat_bit1.comp $
    encode_iff.2 $ primrec.of_nat code)
  (const 4)

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),
    CO (a) := λ cf cg hf hg, co a (cf, cg, hf, hg),
    PC (a) := λ cf cg hf hg, pc a (cf, cg, hf, hg),
    RF (a) := λ cf hf, rf a (cf, hf),
    F (a c) : σ := nat.partrec.code.rec_on c
      (z a) (s a) (l a) (r a) (PR a) (CO a) (PC a) (RF a) in
    primrec (λ a, F a (c a)) :=
begin
  intros,
  let G₁ : (α × list σ) × ℕ × ℕ → option σ := λ p,
    let a := p.1.1, IH := p.1.2, n := p.2.1, m := p.2.2 in
    (IH.nth m).bind $ λ s,
    (IH.nth m.unpair.1).bind $ λ s₁,
    (IH.nth m.unpair.2).map $ λ 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₁,
  { 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.of_nat code).comp m).pair s))
        (hpc.comp a (((primrec.of_nat code).comp m₁).pair $
          ((primrec.of_nat code).comp m₂).pair $ s₁.pair s₂)))
      (primrec.cond (nat_bodd.comp $ nat_div2.comp n)
        (hco.comp a (((primrec.of_nat code).comp m₁).pair $
          ((primrec.of_nat code).comp m₂).pair $ s₁.pair s₂))
        (hpr.comp a (((primrec.of_nat code).comp m₁).pair $
          ((primrec.of_nat code).comp m₂).pair $ s₁.pair s₂))) },
  let G : α → list σ → option σ := λ a IH,
    IH.length.cases (some (z a)) $ λ n,
    n.cases (some (s a)) $ λ n,
    n.cases (some (l a)) $ λ n,
    n.cases (some (r a)) $ λ 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
    (λ a n, F a (of_nat code n)) this.to₂ $ λ a n, _).comp
    primrec.id $ encode_iff.2 hc).of_eq (λ a, by simp),
  simp,
  iterate 4 {cases n with n, {refl}},
  simp [G], rw [list.length_map, list.length_range],
  let m := n.div2.div2,
  show G₁ ((a, (list.range (n+4)).map (λ 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];
  from 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, from lt_of_le_of_lt m.unpair_le_left hm,
  have m2 : m.unpair.2 < n + 4, from lt_of_le_of_lt m.unpair_le_right hm,
  simp [G₁], simp [list.nth_map, list.nth_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; refl
end

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 (λ 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 (λ 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 (λ 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 (λ a : α × code × σ, rf a.1 a.2.1 a.2.2)) :
let F (a c) : σ := nat.partrec.code.rec_on c
      (z a) (s a) (l a) (r a) (pr a) (co a) (pc a) (rf a) in
    primrec (λ a, F a (c a)) :=
begin
  intros,
  let G₁ : (α × list σ) × ℕ × ℕ → option σ := λ p,
    let a := p.1.1, IH := p.1.2, n := p.2.1, m := p.2.2 in
    (IH.nth m).bind $ λ s,
    (IH.nth m.unpair.1).bind $ λ s₁,
    (IH.nth m.unpair.2).map $ λ 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₁,
  { 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.of_nat code).comp m).pair s))
        (hpc.comp $ a.pair (((primrec.of_nat code).comp m₁).pair $
          ((primrec.of_nat code).comp m₂).pair $ s₁.pair s₂)))
      (primrec.cond (nat_bodd.comp $ nat_div2.comp n)
        (hco.comp $ a.pair (((primrec.of_nat code).comp m₁).pair $
          ((primrec.of_nat code).comp m₂).pair $ s₁.pair s₂))
        (hpr.comp $ a.pair (((primrec.of_nat code).comp m₁).pair $
          ((primrec.of_nat code).comp m₂).pair $ s₁.pair s₂))) },
  let G : α → list σ → option σ := λ a IH,
    IH.length.cases (some (z a)) $ λ n,
    n.cases (some (s a)) $ λ n,
    n.cases (some (l a)) $ λ n,
    n.cases (some (r a)) $ λ 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
    (λ a n, F a (of_nat code n)) this.to₂ $ λ a n, _).comp
    primrec.id $ encode_iff.2 hc).of_eq (λ a, by simp),
  simp,
  iterate 4 {cases n with n, {refl}},
  simp [G], rw [list.length_map, list.length_range],
  let m := n.div2.div2,
  show G₁ ((a, (list.range (n+4)).map (λ 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];
  from 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, from lt_of_le_of_lt m.unpair_le_left hm,
  have m2 : m.unpair.2 < n + 4, from lt_of_le_of_lt m.unpair_le_right hm,
  simp [G₁], simp [list.nth_map, list.nth_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; refl
end

end

section
open computable

/- TODO(Mario): less copy-paste from previous proof -/
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),
    CO (a) := λ cf cg hf hg, co a (cf, cg, hf, hg),
    PC (a) := λ cf cg hf hg, pc a (cf, cg, hf, hg),
    RF (a) := λ cf hf, rf a (cf, hf),
    F (a c) : σ := nat.partrec.code.rec_on c
      (z a) (s a) (l a) (r a) (PR a) (CO a) (PC a) (RF a) in
    computable (λ a, F a (c a)) :=
begin
  intros,
  let G₁ : (α × list σ) × ℕ × ℕ → option σ := λ p,
    let a := p.1.1, IH := p.1.2, n := p.2.1, m := p.2.2 in
    (IH.nth m).bind $ λ s,
    (IH.nth m.unpair.1).bind $ λ s₁,
    (IH.nth m.unpair.2).map $ λ 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₁,
  { 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.of_nat code).comp m).pair s))
        (hpc.comp a (((computable.of_nat code).comp m₁).pair $
          ((computable.of_nat code).comp m₂).pair $ s₁.pair s₂)))
      (computable.cond (nat_bodd.comp $ nat_div2.comp n)
        (hco.comp a (((computable.of_nat code).comp m₁).pair $
          ((computable.of_nat code).comp m₂).pair $ s₁.pair s₂))
        (hpr.comp a (((computable.of_nat code).comp m₁).pair $
          ((computable.of_nat code).comp m₂).pair $ s₁.pair s₂))) },
  let G : α → list σ → option σ := λ a IH,
    IH.length.cases (some (z a)) $ λ n,
    n.cases (some (s a)) $ λ n,
    n.cases (some (l a)) $ λ n,
    n.cases (some (r a)) $ λ 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
    (λ a n, F a (of_nat code n)) this.to₂ $ λ a n, _).comp
    computable.id $ encode_iff.2 hc).of_eq (λ a, by simp),
  simp,
  iterate 4 {cases n with n, {refl}},
  simp [G], rw [list.length_map, list.length_range],
  let m := n.div2.div2,
  show G₁ ((a, (list.range (n+4)).map (λ 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];
  from 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, from lt_of_le_of_lt m.unpair_le_left hm,
  have m2 : m.unpair.2 < n + 4, from lt_of_le_of_lt m.unpair_le_right hm,
  simp [G₁], simp [list.nth_map, list.nth_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; refl
end

end

def eval : code → ℕ →. ℕ
| zero         := pure 0
| succ         := nat.succ
| left         := λ n, n.unpair.1
| right        := λ n, n.unpair.2
| (pair cf cg) := λ n, mkpair <$> eval cf n <*> eval cg n
| (comp cf cg) := λ n, eval cg n >>= eval cf
| (prec cf cg) := nat.unpaired (λ a n,
    n.elim (eval cf a) (λ y IH, do i ← IH, eval cg (mkpair a (mkpair y i))))
| (rfind' cf)  := nat.unpaired (λ a m,
    (nat.rfind (λ n, (λ m, m = 0) <$>
      eval cf (mkpair a (n + m)))).map (+ m))

instance : has_mem (ℕ →. ℕ) code := ⟨λ f c, eval c = f⟩

@[simp] theorem eval_const : ∀ n m, eval (code.const n) m = roption.some n
| 0     m := rfl
| (n+1) m := by simp! *

@[simp] theorem eval_id (n) : eval code.id n = roption.some n := by simp! [(<*>)]

@[simp] theorem eval_curry (c n x) : eval (curry c n) x = eval c (mkpair n x) :=
by simp! [(<*>)]

theorem const_prim : primrec code.const :=
(primrec.id.nat_iterate (primrec.const zero)
  (comp_prim.comp (primrec.const succ) primrec.snd).to₂).of_eq $
λ n, by simp; induction n; simp [*, code.const, nat.iterate_succ']

theorem curry_prim : primrec₂ curry :=
comp_prim.comp primrec.fst $
pair_prim.comp (const_prim.comp primrec.snd) (primrec.const code.id)

theorem exists_code {f : ℕ →. ℕ} : nat.partrec f ↔ ∃ c : code, eval c = f :=
⟨λ h, begin
  induction h,
  case nat.partrec.zero { exact ⟨zero, rfl⟩ },
  case nat.partrec.succ { exact ⟨succ, rfl⟩ },
  case nat.partrec.left { exact ⟨left, rfl⟩ },
  case nat.partrec.right { exact ⟨right, rfl⟩ },
  case nat.partrec.pair : f g pf pg hf hg {
    rcases hf with ⟨cf, rfl⟩, rcases hg with ⟨cg, rfl⟩,
    exact ⟨pair cf cg, rfl⟩ },
  case nat.partrec.comp : f g pf pg hf hg {
    rcases hf with ⟨cf, rfl⟩, rcases hg with ⟨cg, rfl⟩,
    exact ⟨comp cf cg, rfl⟩ },
  case nat.partrec.prec : f g pf pg hf hg {
    rcases hf with ⟨cf, rfl⟩, rcases hg with ⟨cg, rfl⟩,
    exact ⟨prec cf cg, rfl⟩ },
  case nat.partrec.rfind : f pf hf {
    rcases hf with ⟨cf, rfl⟩,
    refine ⟨comp (rfind' cf) (pair code.id zero), _⟩,
    simp [eval, (<*>), pure, pfun.pure, roption.map_id'] },
end, λ h, begin
  rcases h with ⟨c, rfl⟩, induction c,
  case nat.partrec.code.zero { exact nat.partrec.zero },
  case nat.partrec.code.succ { exact nat.partrec.succ },
  case nat.partrec.code.left { exact nat.partrec.left },
  case nat.partrec.code.right { exact nat.partrec.right },
  case nat.partrec.code.pair : cf cg pf pg { exact pf.pair pg },
  case nat.partrec.code.comp : cf cg pf pg { exact pf.comp pg },
  case nat.partrec.code.prec : cf cg pf pg { exact pf.prec pg },
  case nat.partrec.code.rfind' : cf pf { exact pf.rfind' },
end⟩

def evaln : ∀ k : ℕ, code → ℕ → option ℕ
| 0     _            := λ m, none
| (k+1) zero         := λ n, guard (n ≤ k) >> pure 0
| (k+1) succ         := λ n, guard (n ≤ k) >> pure (nat.succ n)
| (k+1) left         := λ n, guard (n ≤ k) >> pure n.unpair.1
| (k+1) right        := λ n, guard (n ≤ k) >> pure n.unpair.2
| (k+1) (pair cf cg) := λ n, guard (n ≤ k) >>
  mkpair <$> evaln (k+1) cf n <*> evaln (k+1) cg n
| (k+1) (comp cf cg) := λ n, guard (n ≤ k) >>
  do x ← evaln (k+1) cg n, evaln (k+1) cf x
| (k+1) (prec cf cg) := λ n, guard (n ≤ k) >>
  n.unpaired (λ a n,
  n.cases (evaln (k+1) cf a) $ λ y, do
    i ← evaln k (prec cf cg) (mkpair a y),
    evaln (k+1) cg (mkpair a (mkpair y i)))
| (k+1) (rfind' cf)  := λ n, guard (n ≤ k) >>
  n.unpaired (λ a m, do
  x ← evaln (k+1) cf (mkpair a m),
  if x = 0 then pure m else
  evaln k (rfind' cf) (mkpair a (m+1)))

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 := begin
  suffices : ∀ {o : option ℕ}, x ∈ guard (n ≤ k) >> o → n < k + 1,
  { cases c; rw [evaln] at h; exact this h },
  simp [(>>)], exact λ _ h _, nat.lt_succ_of_le h
end

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 := begin
  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₂,
  { 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' (λ h, _) h,
  iterate 4 {exact h},
  { -- pair cf cg
    simp [(<*>)] at h ⊢,
    exact h.imp (λ a, and.imp
      (Exists.imp (λ b, and.imp_left (hf _ _)))
      (Exists.imp (λ b, and.imp_left (hg _ _)))) },
  { -- comp cf cg
    simp at h ⊢,
    exact h.imp (λ a, and.imp (hg _ _) (hf _ _)) },
  { -- prec cf cg
    revert h, simp,
    induction n.unpair.2; simp,
    { apply hf },
    { exact λ y h₁ h₂, ⟨y, evaln_mono hl' h₁, hg _ _ h₂⟩ } },
  { -- rfind' cf
    simp at h ⊢,
    refine h.imp (λ x, and.imp (hf _ _) _),
    by_cases x0 : x = 0; simp [x0],
    exact evaln_mono hl' }
end

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 := begin
  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, rfl⟩, 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 λ 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₁,
        λ 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 using hy₁, λ i im, _⟩, by simp⟩,
      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] using hz, z0⟩ } } }
end

theorem evaln_complete {c n x} : x ∈ eval c n ↔ ∃ k, x ∈ evaln k c n :=
⟨λ h, begin
  suffices : ∃ k, x ∈ evaln (k+1) c n,
  { exact let ⟨k, h⟩ := this in ⟨k+1, h⟩ },
  induction c generalizing n x;
    simp [eval, evaln, pure, pfun.pure, (<*>), (>>)] at h ⊢,
  iterate 4 { exact ⟨⟨_, le_refl _⟩, h.symm⟩ },
  case nat.partrec.code.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₂, _⟩,
    exact ⟨le_max_left_of_le $ nat.le_of_lt_succ $ evaln_bound hk₁, _,
     ⟨_, evaln_mono (nat.succ_le_succ $ le_max_left _ _) hk₁, rfl⟩,
      _, evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk₂, rfl⟩ },
  case nat.partrec.code.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_left_of_le $ 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 nat.partrec.code.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⟩ },
    { intros 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_left_of_le $
        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 nat.partrec.code.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), {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; refl⟩ },
    { 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] using hy₁)
          (λ i hi, by simpa [nat.succ_eq_add_one] using hy₂ (nat.succ_lt_succ hi))
        with ⟨k₂, hk₂⟩,
      simp at hk₁,
      exact ⟨(max k₁ k₂).succ, nat.le_succ_of_le $
        le_max_left_of_le $ nat.le_of_lt_succ $ evaln_bound hk₁, a,
        evaln_mono (nat.succ_le_succ $ nat.le_succ_of_le $ le_max_left _ _) hk₁,
        by simpa [nat.succ_eq_add_one, a0, -max_eq_left, -max_eq_right] using
          evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk₂⟩ } }
end, λ ⟨k, h⟩, evaln_sound h⟩

section
open primrec

private def lup (L : list (list (option ℕ))) (p : ℕ × code) (n : ℕ) :=
do l ← L.nth (encode p), o ← l.nth n, o

private lemma hlup : primrec (λ p:_×(_×_)×_, lup p.1 p.2.1 p.2.2) :=
option_bind
  (list_nth.comp fst (primrec.encode.comp $ fst.comp snd))
  (option_bind (list_nth.comp snd $ snd.comp $ snd.comp fst) snd)

private def G (L : list (list (option ℕ))) : option (list (option ℕ)) :=
option.some $
let a := of_nat (ℕ × code) L.length,
    k := a.1, c := a.2 in
(list.range k).map (λ n,
  k.cases none $ λ k',
  nat.partrec.code.rec_on c
    (some 0) -- zero
    (some (nat.succ n))
    (some n.unpair.1)
    (some n.unpair.2)
    (λ cf cg _ _, do
      x ← lup L (k, cf) n,
      y ← lup L (k, cg) n,
      some (mkpair x y))
    (λ cf cg _ _, do
      x ← lup L (k, cg) n,
      lup L (k, cf) x)
    (λ cf cg _ _,
      let z := n.unpair.1 in
      n.unpair.2.cases
        (lup L (k, cf) z)
        (λ y, do
          i ← lup L (k', c) (mkpair z y),
          lup L (k, cg) (mkpair z (mkpair y i))))
    (λ cf _,
      let z := n.unpair.1, m := n.unpair.2 in do
      x ← lup L (k, cf) (mkpair z m),
      x.cases
        (some m)
        (λ _, lup L (k', c) (mkpair z (m+1)))))

private lemma hG : primrec G :=
begin
  have a := (primrec.of_nat (ℕ × 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) }
end

private lemma evaln_map (k c n) :
  (((list.range k).nth n).map (evaln k c)).bind (λ b, b) = evaln k c n :=
begin
  by_cases kn : n < k,
  { simp [list.nth_range kn] },
  { rw list.nth_ge_len,
    { cases e : evaln k c n, {refl},
      exact kn.elim (evaln_bound e) },
    simpa using kn }
end

theorem evaln_prim : primrec (λ (a : (ℕ × code) × ℕ), evaln a.1.1 a.1.2 a.2) :=
have primrec₂ (λ (_:unit) (n : ℕ),
  let a := of_nat (ℕ × code) n in
  (list.range a.1).map (evaln a.1 a.2)), from
primrec.nat_strong_rec _ (hG.comp snd).to₂ $
  λ _ p, begin
    simp [G],
    rw (_ : (of_nat (ℕ × code) _).snd =
      of_nat code p.unpair.2), swap, {simp},
    apply list.map_congr (λ 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 (λ n,
        (list.range n.unpair.1).map
          (evaln n.unpair.1 (of_nat code n.unpair.2))))
        (k', c') n = evaln k' c' n,
    { intros k₁ c₁ n₁ hl,
      simp [lup, list.nth_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.mkpair_lt_mkpair_right _ lf),
          hg (nat.mkpair_lt_mkpair_right _ lg)],
      cases evaln k cf n, {refl},
      cases evaln k cg n; refl },
    { cases encode_lt_comp cf cg with lf lg,
      rw hg (nat.mkpair_lt_mkpair_right _ lg),
      cases evaln k cg n, {refl},
      simp [hg (nat.mkpair_lt_mkpair_right _ lf)] },
    { cases encode_lt_prec cf cg with lf lg,
      rw hg (nat.mkpair_lt_mkpair_right _ lf),
      cases n.unpair.2, {refl},
      simp,
      rw hg (nat.mkpair_lt_mkpair_left _ k'.lt_succ_self),
      cases evaln k' _ _, {refl},
      simp [hg (nat.mkpair_lt_mkpair_right _ lg)] },
    { have lf := encode_lt_rfind' cf,
      rw hg (nat.mkpair_lt_mkpair_right _ lf),
      cases evaln k cf n with x, {refl},
      simp,
      cases x; simp [nat.succ_ne_zero],
      rw hg (nat.mkpair_lt_mkpair_left _ k'.lt_succ_self) }
  end,
(option_bind (list_nth.comp
  (this.comp (const ()) (encode_iff.2 fst)) snd)
  snd.to₂).of_eq $ λ ⟨⟨k, c⟩, n⟩, by simp [evaln_map]

end

section
open partrec computable

theorem eval_eq_rfind_opt (c n) :
  eval c n = nat.rfind_opt (λ k, evaln k c n) :=
roption.ext $ λ x, begin
  refine evaln_complete.trans (nat.rfind_opt_mono _).symm,
  intros a m n hl, apply evaln_mono hl,
end

theorem eval_part : partrec₂ eval :=
(rfind_opt (evaln_prim.to_comp.comp
  ((snd.pair (fst.comp fst)).pair (snd.comp fst))).to₂).of_eq $
λ a, by simp [eval_eq_rfind_opt]

theorem fixed_point
  {f : code → code} (hf : computable f) : ∃ c : code, eval (f c) = eval c :=
begin
  let g : ℕ → ℕ →. ℕ := λ x y,
    roption.bind (eval (of_nat code x) x) (λ b, eval (of_nat code b) y),
  have : partrec₂ g :=
    (eval_part.comp ((computable.of_nat _).comp fst) fst).bind
    (eval_part.comp ((computable.of_nat _).comp snd) (snd.comp fst)).to₂,
  rcases exists_code.1 this with ⟨cg, eg⟩,
  have := hf.comp (curry_prim.comp (primrec.const cg) primrec.id).to_comp,
  rcases exists_code.1 this with ⟨cF, eF⟩,
  refine ⟨curry cg (encode cF), funext $ λ n, _⟩,
  have := congr_fun eF (encode cF), simp at this,
  simp [eg, this, roption.map_id', g]
end

theorem fixed_point₂
  {f : code → ℕ →. ℕ} (hf : partrec₂ f) : ∃ c : code, eval c = f c :=
let ⟨cf, ef⟩ := exists_code.1 hf in
(fixed_point (curry_prim.comp
  (primrec.const cf) primrec.encode).to_comp).imp $
λ c e, funext $ λ n, by simp [e.symm, ef, roption.map_id']

end

end nat.partrec.code


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.box_integral.basic
import analysis.box_integral.partition.additive
import analysis.calculus.fderiv

/-!
# Divergence integral for Henstock-Kurzweil integral

In this file we prove the Divergence Theorem for a Henstock-Kurzweil style integral. The theorem
says the following. Let `f : ℝⁿ → Eⁿ` be a function differentiable on a closed rectangular box
`I` with derivative `f' x : ℝⁿ →L[ℝ] Eⁿ` at `x ∈ I`. Then the divergence `λ x, ∑ k, f' x eₖ k`,
where `eₖ = pi.single k 1` is the `k`-th basis vector, is integrable on `I`, and its integral is
equal to the sum of integrals of `f` over the faces of `I` taken with appropriate signs.

To make the proof work, we had to ban tagged partitions with “long and thin” boxes. More precisely,
we use the following generalization of one-dimensional Henstock-Kurzweil integral to functions
defined on a box in `ℝⁿ` (it corresponds to the value `box_integral.integration_params.GP = ⊥` of
`box_integral.integration_params` in the definition of `box_integral.has_integral`).

We say that `f : ℝⁿ → E` has integral `y : E` over a box `I ⊆ ℝⁿ` if for an arbitrarily small
positive `ε` and an arbitrarily large `c`, there exists a function `r : ℝⁿ → (0, ∞)` such that for
any tagged partition `π` of `I` such that

* `π` is a Henstock partition, i.e., each tag belongs to its box;
* `π` is subordinate to `r`;
* for every box of `π`, the maximum of the ratios of its sides is less than or equal to `c`,

the integral sum of `f` over `π` is `ε`-close to `y`. In case of dimension one, the last condition
trivially holds for any `c ≥ 1`, so this definition is equivalent to the standard definition of
Henstock-Kurzweil integral.

## Tags

Henstock-Kurzweil integral, integral, Stokes theorem, divergence theorem
-/

open_locale classical big_operators nnreal ennreal topology box_integral
open continuous_linear_map (lsmul) filter set finset metric
  box_integral.integration_params (GP GP_le)
noncomputable theory

universes u
variables {E : Type u} [normed_add_comm_group E] [normed_space ℝ E] {n : ℕ}

namespace box_integral

local notation `ℝⁿ` := fin n → ℝ
local notation `ℝⁿ⁺¹` := fin (n + 1) → ℝ
local notation `Eⁿ⁺¹` := fin (n + 1) → E

variables [complete_space E] (I : box (fin (n + 1))) {i : fin (n + 1)}

open measure_theory

/-- Auxiliary lemma for the divergence theorem. -/
lemma norm_volume_sub_integral_face_upper_sub_lower_smul_le
  {f : ℝⁿ⁺¹ → E} {f' : ℝⁿ⁺¹ →L[ℝ] E} (hfc : continuous_on f I.Icc)
  {x : ℝⁿ⁺¹} (hxI : x ∈ I.Icc) {a : E} {ε : ℝ} (h0 : 0 < ε)
  (hε : ∀ y ∈ I.Icc, ‖f y - a - f' (y - x)‖ ≤ ε * ‖y - x‖) {c : ℝ≥0} (hc : I.distortion ≤ c) :
  ‖(∏ j, (I.upper j - I.lower j)) • f' (pi.single i 1) -
    (integral (I.face i) ⊥ (f ∘ i.insert_nth (I.upper i)) box_additive_map.volume -
      integral (I.face i) ⊥ (f ∘ i.insert_nth (I.lower i)) box_additive_map.volume)‖ ≤
    2 * ε * c * ∏ j, (I.upper j - I.lower j) :=
begin
  /- **Plan of the proof**. The difference of the integrals of the affine function
  `λ y, a + f' (y - x)` over the faces `x i = I.upper i` and `x i = I.lower i` is equal to the
  volume of `I` multiplied by `f' (pi.single i 1)`, so it suffices to show that the integral of
  `f y - a - f' (y - x)` over each of these faces is less than or equal to `ε * c * vol I`. We
  integrate a function of the norm `≤ ε * diam I.Icc` over a box of volume
  `∏ j ≠ i, (I.upper j - I.lower j)`. Since `diam I.Icc ≤ c * (I.upper i - I.lower i)`, we get the
  required estimate.  -/
  have Hl : I.lower i ∈ Icc (I.lower i) (I.upper i) := set.left_mem_Icc.2 (I.lower_le_upper i),
  have Hu : I.upper i ∈ Icc (I.lower i) (I.upper i) := set.right_mem_Icc.2 (I.lower_le_upper i),
  have Hi : ∀ x ∈ Icc (I.lower i) (I.upper i),
    integrable.{0 u u} (I.face i) ⊥ (f ∘ i.insert_nth x) box_additive_map.volume,
    from λ x hx, integrable_of_continuous_on _ (box.continuous_on_face_Icc hfc hx) volume,
  /- We start with an estimate: the difference of the values of `f` at the corresponding points
  of the faces `x i = I.lower i` and `x i = I.upper i` is `(2 * ε * diam I.Icc)`-close to the value
  of `f'` on `pi.single i (I.upper i - I.lower i) = lᵢ • eᵢ`, where `lᵢ = I.upper i - I.lower i`
  is the length of `i`-th edge of `I` and `eᵢ = pi.single i 1` is the `i`-th unit vector. -/
  have : ∀ y ∈ (I.face i).Icc, ‖f' (pi.single i (I.upper i - I.lower i)) -
    (f (i.insert_nth (I.upper i) y) - f (i.insert_nth (I.lower i) y))‖ ≤ 2 * ε * diam I.Icc,
  { intros y hy,
    set g := λ y, f y - a - f' (y - x) with hg,
    change ∀ y ∈ I.Icc, ‖g y‖ ≤ ε * ‖y - x‖ at hε,
    clear_value g, obtain rfl : f = λ y, a + f' (y - x) + g y, by simp [hg],
    convert_to ‖g (i.insert_nth (I.lower i) y) - g (i.insert_nth (I.upper i) y)‖ ≤ _,
    { congr' 1,
      have := fin.insert_nth_sub_same i (I.upper i) (I.lower i) y,
      simp only [← this, f'.map_sub], abel },
    { have : ∀ z ∈ Icc (I.lower i) (I.upper i), i.insert_nth z y ∈ I.Icc,
        from λ z hz, I.maps_to_insert_nth_face_Icc hz hy,
      replace hε : ∀ y ∈ I.Icc, ‖g y‖ ≤ ε * diam I.Icc,
      { intros y hy,
        refine (hε y hy).trans (mul_le_mul_of_nonneg_left _ h0.le),
        rw ← dist_eq_norm,
        exact dist_le_diam_of_mem I.is_compact_Icc.bounded hy hxI },
      rw [two_mul, add_mul],
      exact norm_sub_le_of_le (hε _ (this _ Hl)) (hε _ (this _ Hu)) } },
  calc ‖(∏ j, (I.upper j - I.lower j)) • f' (pi.single i 1) -
    (integral (I.face i) ⊥ (f ∘ i.insert_nth (I.upper i)) box_additive_map.volume -
      integral (I.face i) ⊥ (f ∘ i.insert_nth (I.lower i)) box_additive_map.volume)‖
      = ‖integral.{0 u u} (I.face i) ⊥
          (λ (x : fin n → ℝ), f' (pi.single i (I.upper i - I.lower i)) -
          (f (i.insert_nth (I.upper i) x) - f (i.insert_nth (I.lower i) x)))
          box_additive_map.volume‖ :
    begin
      rw [← integral_sub (Hi _ Hu) (Hi _ Hl), ← box.volume_face_mul i, mul_smul, ← box.volume_apply,
        ← box_additive_map.to_smul_apply, ← integral_const, ← box_additive_map.volume,
        ← integral_sub (integrable_const _) ((Hi _ Hu).sub (Hi _ Hl))],
      simp only [(∘), pi.sub_def, ← f'.map_smul, ← pi.single_smul', smul_eq_mul, mul_one]
    end
  ... ≤ (volume (I.face i : set ℝⁿ)).to_real * (2 * ε * c * (I.upper i - I.lower i)) :
    begin
      -- The hard part of the estimate was done above, here we just replace `diam I.Icc`
      -- with `c * (I.upper i - I.lower i)`
      refine norm_integral_le_of_le_const (λ y hy, (this y hy).trans _) volume,
      rw mul_assoc (2 * ε),
      exact mul_le_mul_of_nonneg_left (I.diam_Icc_le_of_distortion_le i hc)
        (mul_nonneg zero_le_two h0.le)
    end
  ... = 2 * ε * c * ∏ j, (I.upper j - I.lower j) :
    begin
      rw [← measure.to_box_additive_apply, box.volume_apply, ← I.volume_face_mul i],
      ac_refl
    end
end

/-- If `f : ℝⁿ⁺¹ → E` is differentiable on a closed rectangular box `I` with derivative `f'`, then
the partial derivative `λ x, f' x (pi.single i 1)` is Henstock-Kurzweil integrable with integral
equal to the difference of integrals of `f` over the faces `x i = I.upper i` and `x i = I.lower i`.

More precisely, we use a non-standard generalization of the Henstock-Kurzweil integral and
we allow `f` to be non-differentiable (but still continuous) at a countable set of points.

TODO: If `n > 0`, then the condition at `x ∈ s` can be replaced by a much weaker estimate but this
requires either better integrability theorems, or usage of a filter depending on the countable set
`s` (we need to ensure that none of the faces of a partition contain a point from `s`). -/
lemma has_integral_GP_pderiv (f : ℝⁿ⁺¹ → E) (f' : ℝⁿ⁺¹ → ℝⁿ⁺¹ →L[ℝ] E) (s : set ℝⁿ⁺¹)
  (hs : s.countable) (Hs : ∀ x ∈ s, continuous_within_at f I.Icc x)
  (Hd : ∀ x ∈ I.Icc \ s, has_fderiv_within_at f (f' x) I.Icc x) (i : fin (n + 1)) :
  has_integral.{0 u u} I GP (λ x, f' x (pi.single i 1)) box_additive_map.volume
    (integral.{0 u u} (I.face i) GP (λ x, f (i.insert_nth (I.upper i) x)) box_additive_map.volume -
      integral.{0 u u} (I.face i) GP (λ x, f (i.insert_nth (I.lower i) x))
        box_additive_map.volume) :=
begin
  /- Note that `f` is continuous on `I.Icc`, hence it is integrable on the faces of all boxes
  `J ≤ I`, thus the difference of integrals over `x i = J.upper i` and `x i = J.lower i` is a
  box-additive function of `J ≤ I`. -/
  have Hc : continuous_on f I.Icc,
  { intros x hx,
    by_cases hxs : x ∈ s,
    exacts [Hs x hxs, (Hd x ⟨hx, hxs⟩).continuous_within_at] },
  set fI : ℝ → box (fin n) → E := λ y J,
    integral.{0 u u} J GP (λ x, f (i.insert_nth y x)) box_additive_map.volume,
  set fb : Icc (I.lower i) (I.upper i) → fin n →ᵇᵃ[↑(I.face i)] E :=
    λ x, (integrable_of_continuous_on GP (box.continuous_on_face_Icc Hc x.2)
      volume).to_box_additive,
  set F : fin (n + 1) →ᵇᵃ[I] E := box_additive_map.upper_sub_lower I i fI fb (λ x hx J, rfl),
  /- Thus our statement follows from some local estimates. -/
  change has_integral I GP (λ x, f' x (pi.single i 1)) _ (F I),
  refine has_integral_of_le_Henstock_of_forall_is_o GP_le _ _ _ s hs _ _,
  { /- We use the volume as an upper estimate. -/
    exact (volume : measure ℝⁿ⁺¹).to_box_additive.restrict _ le_top },
  { exact λ J, ennreal.to_real_nonneg },
  { intros c x hx ε ε0,
    /- Near `x ∈ s` we choose `δ` so that both vectors are small. `volume J • eᵢ` is small because
    `volume J ≤ (2 * δ) ^ (n + 1)` is small, and the difference of the integrals is small
    because each of the integrals is close to `volume (J.face i) • f x`.
    TODO: there should be a shorter and more readable way to formalize this simple proof. -/
    have : ∀ᶠ δ in 𝓝[>] (0 : ℝ), δ ∈ Ioc (0 : ℝ) (1 / 2) ∧
      (∀ y₁ y₂ ∈ closed_ball x δ ∩ I.Icc, ‖f y₁ - f y₂‖ ≤ ε / 2) ∧
      ((2 * δ) ^ (n + 1) * ‖f' x (pi.single i 1)‖ ≤ ε / 2),
    { refine eventually.and _ (eventually.and _ _),
      { exact Ioc_mem_nhds_within_Ioi ⟨le_rfl, one_half_pos⟩ },
      { rcases ((nhds_within_has_basis nhds_basis_closed_ball _).tendsto_iff
          nhds_basis_closed_ball).1 (Hs x hx.2) _ (half_pos $ half_pos ε0) with ⟨δ₁, δ₁0, hδ₁⟩,
        filter_upwards [Ioc_mem_nhds_within_Ioi ⟨le_rfl, δ₁0⟩] with δ hδ y₁ hy₁ y₂ hy₂,
        have : closed_ball x δ ∩ I.Icc ⊆ closed_ball x δ₁ ∩ I.Icc,
          from inter_subset_inter_left _ (closed_ball_subset_closed_ball hδ.2),
        rw ← dist_eq_norm,
        calc dist (f y₁) (f y₂) ≤ dist (f y₁) (f x) + dist (f y₂) (f x) : dist_triangle_right _ _ _
        ... ≤ ε / 2 / 2 + ε / 2 / 2 : add_le_add (hδ₁ _ $ this hy₁) (hδ₁ _ $ this hy₂)
        ... = ε / 2 : add_halves _ },
      { have : continuous_within_at (λ δ, (2 * δ) ^ (n + 1) * ‖f' x (pi.single i 1)‖)
          (Ioi (0 : ℝ)) 0 := ((continuous_within_at_id.const_mul _).pow _).mul_const _,
        refine this.eventually (ge_mem_nhds _),
        simpa using half_pos ε0 } },
    rcases this.exists with ⟨δ, ⟨hδ0, hδ12⟩, hdfδ, hδ⟩,
    refine ⟨δ, hδ0, λ J hJI hJδ hxJ hJc, add_halves ε ▸ _⟩,
    have Hl : J.lower i ∈ Icc (J.lower i) (J.upper i) := set.left_mem_Icc.2 (J.lower_le_upper i),
    have Hu : J.upper i ∈ Icc (J.lower i) (J.upper i) := set.right_mem_Icc.2 (J.lower_le_upper i),
    have Hi : ∀ x ∈ Icc (J.lower i) (J.upper i),
      integrable.{0 u u} (J.face i) GP (λ y, f (i.insert_nth x y)) box_additive_map.volume,
      from λ x hx, integrable_of_continuous_on _
        (box.continuous_on_face_Icc (Hc.mono $ box.le_iff_Icc.1 hJI) hx) volume,
    have hJδ' : J.Icc ⊆ closed_ball x δ ∩ I.Icc,
      from subset_inter hJδ (box.le_iff_Icc.1 hJI),
    have Hmaps : ∀ z ∈ Icc (J.lower i) (J.upper i),
      maps_to (i.insert_nth z) (J.face i).Icc (closed_ball x δ ∩ I.Icc),
      from λ z hz, (J.maps_to_insert_nth_face_Icc hz).mono subset.rfl hJδ',
    simp only [dist_eq_norm, F, fI], dsimp,
    rw [← integral_sub (Hi _ Hu) (Hi _ Hl)],
    refine (norm_sub_le _ _).trans (add_le_add _ _),
    { simp_rw [box_additive_map.volume_apply, norm_smul, real.norm_eq_abs, abs_prod],
      refine (mul_le_mul_of_nonneg_right _ $ norm_nonneg _).trans hδ,
      have : ∀ j, |J.upper j - J.lower j| ≤ 2 * δ,
      { intro j,
        calc dist (J.upper j) (J.lower j) ≤ dist J.upper J.lower : dist_le_pi_dist _ _ _
        ... ≤ dist J.upper x + dist J.lower x : dist_triangle_right _ _ _
        ... ≤ δ + δ : add_le_add (hJδ J.upper_mem_Icc) (hJδ J.lower_mem_Icc)
        ... = 2 * δ : (two_mul δ).symm },
      calc (∏ j, |J.upper j - J.lower j|) ≤ ∏ j : fin (n + 1), (2 * δ) :
        prod_le_prod (λ _ _ , abs_nonneg _) (λ j hj, this j)
      ... = (2 * δ) ^ (n + 1) : by simp },
    { refine (norm_integral_le_of_le_const (λ y hy,
        hdfδ _ (Hmaps _ Hu hy) _ (Hmaps _ Hl hy)) _).trans _,
      refine (mul_le_mul_of_nonneg_right _ (half_pos ε0).le).trans_eq (one_mul _),
      rw [box.coe_eq_pi, real.volume_pi_Ioc_to_real (box.lower_le_upper _)],
      refine prod_le_one (λ _ _, sub_nonneg.2 $ box.lower_le_upper _ _) (λ j hj, _),
      calc J.upper (i.succ_above j) - J.lower (i.succ_above j)
          ≤ dist (J.upper (i.succ_above j)) (J.lower (i.succ_above j)) : le_abs_self _
      ... ≤ dist J.upper J.lower : dist_le_pi_dist J.upper J.lower (i.succ_above j)
      ... ≤ dist J.upper x + dist J.lower x : dist_triangle_right _ _ _
      ... ≤ δ + δ : add_le_add (hJδ J.upper_mem_Icc) (hJδ J.lower_mem_Icc)
      ... ≤ 1 / 2 + 1 / 2 : add_le_add hδ12 hδ12
      ... = 1 : add_halves 1 } },
  { intros c x hx ε ε0,
    /- At a point `x ∉ s`, we unfold the definition of Fréchet differentiability, then use
    an estimate we proved earlier in this file. -/
    rcases exists_pos_mul_lt ε0 (2 * c) with ⟨ε', ε'0, hlt⟩,
    rcases (nhds_within_has_basis nhds_basis_closed_ball _).mem_iff.1 ((Hd x hx).def ε'0)
      with ⟨δ, δ0, Hδ⟩,
    refine ⟨δ, δ0, λ J hle hJδ hxJ hJc, _⟩,
    simp only [box_additive_map.volume_apply, box.volume_apply, dist_eq_norm],
    refine (norm_volume_sub_integral_face_upper_sub_lower_smul_le _
      (Hc.mono $ box.le_iff_Icc.1 hle) hxJ ε'0 (λ y hy, Hδ _) (hJc rfl)).trans _,
    { exact ⟨hJδ hy, box.le_iff_Icc.1 hle hy⟩ },
    { rw [mul_right_comm (2 : ℝ), ← box.volume_apply],
      exact mul_le_mul_of_nonneg_right hlt.le ennreal.to_real_nonneg } }
end

/-- Divergence theorem for a Henstock-Kurzweil style integral.

If `f : ℝⁿ⁺¹ → Eⁿ⁺¹` is differentiable on a closed rectangular box `I` with derivative `f'`, then
the divergence `∑ i, f' x (pi.single i 1) i` is Henstock-Kurzweil integrable with integral equal to
the sum of integrals of `f` over the faces of `I` taken with appropriate signs.

More precisely, we use a non-standard generalization of the Henstock-Kurzweil integral and
we allow `f` to be non-differentiable (but still continuous) at a countable set of points. -/
lemma has_integral_GP_divergence_of_forall_has_deriv_within_at
  (f : ℝⁿ⁺¹ → Eⁿ⁺¹) (f' : ℝⁿ⁺¹ → ℝⁿ⁺¹ →L[ℝ] Eⁿ⁺¹) (s : set ℝⁿ⁺¹) (hs : s.countable)
  (Hs : ∀ x ∈ s, continuous_within_at f I.Icc x)
  (Hd : ∀ x ∈ I.Icc \ s, has_fderiv_within_at f (f' x) I.Icc x) :
  has_integral.{0 u u} I GP (λ x, ∑ i, f' x (pi.single i 1) i)
    box_additive_map.volume
    (∑ i, (integral.{0 u u} (I.face i) GP (λ x, f (i.insert_nth (I.upper i) x) i)
      box_additive_map.volume -
      integral.{0 u u} (I.face i) GP (λ x, f (i.insert_nth (I.lower i) x) i)
        box_additive_map.volume)) :=
begin
  refine has_integral_sum (λ i hi, _), clear hi,
  simp only [has_fderiv_within_at_pi', continuous_within_at_pi] at Hd Hs,
  convert has_integral_GP_pderiv I _ _ s hs (λ x hx, Hs x hx i) (λ x hx, Hd x hx i) i
end

end box_integral


import data.real.basic

#check ∀ x : ℝ, 0 ≤ x → abs x = x

#check ∀ x y ε : ℝ, 0 < ε → ε ≤ 1 → abs x < ε → abs y < ε → abs (x * y) < ε

lemma my_lemma : ∀ x y ε : ℝ,
  0 < ε → ε ≤ 1 → abs x < ε → abs y < ε → abs (x * y) < ε :=
sorry

section
  variables a b δ : ℝ
  variables (h₀ : 0 < δ) (h₁ : δ ≤ 1)
  variables (ha : abs a < δ) (hb : abs b < δ)

  #check my_lemma a b δ
  #check my_lemma a b δ h₀ h₁
  #check my_lemma a b δ h₀ h₁ ha hb
end

lemma my_lemma2 : ∀ {x y ε : ℝ},
  0 < ε → ε ≤ 1 → abs x < ε → abs y < ε → abs (x * y) < ε :=
sorry

section
  variables a b δ : ℝ
  variables (h₀ : 0 < δ) (h₁ : δ ≤ 1)
  variables (ha : abs a < δ) (hb : abs b < δ)

  #check my_lemma2 h₀ h₁ ha hb
end

lemma my_lemma3 : ∀ {x y ε : ℝ},
  0 < ε → ε ≤ 1 → abs x < ε → abs y < ε → abs (x * y) < ε :=
begin
  intros x y ε epos ele1 xlt ylt,
  sorry
end

lemma my_lemma4 : ∀ {x y ε : ℝ},
  0 < ε → ε ≤ 1 → abs x < ε → abs y < ε → abs (x * y) < ε :=
begin
  intros x y ε epos ele1 xlt ylt,
  calc
    abs (x * y) = abs x * abs y : sorry
    ... ≤ abs x * ε             : sorry
    ... < 1 * ε                 : sorry
    ... = ε                     : sorry
end

def fn_ub (f : ℝ → ℝ) (a : ℝ) : Prop := ∀ x, f x ≤ a
def fn_lb (f : ℝ → ℝ) (a : ℝ) : Prop := ∀ x, a ≤ f x

section
variables (f g : ℝ → ℝ) (a b : ℝ)

example (hfa : fn_ub f a) (hgb : fn_ub g b) :
  fn_ub (λ x, f x + g x) (a + b) :=
begin
  intro x,
  dsimp,
  apply add_le_add,
  apply hfa,
  apply hgb
end

example (hfa : fn_lb f a) (hgb : fn_lb g b) :
  fn_lb (λ x, f x + g x) (a + b) :=
begin
  intros x,
  change a + b ≤ f x + g x,
  /-
  Need partial applications next, otherwise it won't unfold `fn_lb`. Without them, it fails.
  `apply` also does that job.
  -/
  exact add_le_add (hfa _) (hgb _),
end

example (nnf : fn_lb f 0) (nng : fn_lb g 0) :
  fn_lb (λ x, f x * g x) 0 :=
begin
  -- A declarative try
  intro x,
  suffices : 0 ≤ f x * g x,
  assumption, -- neither `linarith` nor `norm_num`, but `exact this` works
  have nnfx: 0 ≤ f x := nnf x,
  have nngx: 0 ≤ g x := nng x,
  calc
  0   = 0 * 0     : by norm_num
  ... ≤ f x * 0   : by { linarith }
  ... ≤ f x * g x : mul_le_mul_of_nonneg_left nngx nnfx
end

example (hfa : fn_ub f a) (hfb : fn_ub g b)
    (nng : fn_lb g 0) (nna : 0 ≤ a) :
  fn_ub (λ x, f x * g x) (a * b) :=
sorry

end

section
variables {α : Type*} {R : Type*} [ordered_cancel_add_comm_monoid R]

#check @add_le_add

def fn_ub' (f : α → R) (a : R) : Prop := ∀ x, f x ≤ a

theorem fn_ub_add {f g : α → R} {a b : R}
    (hfa : fn_ub' f a) (hgb : fn_ub' g b) :
  fn_ub' (λ x, f x + g x) (a + b) :=
λ x, add_le_add (hfa x) (hgb x)
end

example (f : ℝ → ℝ) (h : monotone f) :
  ∀ {a b}, a ≤ b → f a ≤ f b := h

section
variables (f g : ℝ → ℝ)

example (mf : monotone f) (mg : monotone g) :
  monotone (λ x, f x + g x) :=
begin
  intros a b aleb,
  apply add_le_add,
  apply mf aleb,
  apply mg aleb
end

example (mf : monotone f) (mg : monotone g) :
  monotone (λ x, f x + g x) :=
λ a b aleb, add_le_add (mf aleb) (mg aleb)

example {c : ℝ} (mf : monotone f) (nnc : 0 ≤ c) :
  monotone (λ x, c * f x) :=
sorry

example (mf : monotone f) (mg : monotone g) :
  monotone (λ x, f (g x)) :=
sorry

def fn_even (f : ℝ → ℝ) : Prop := ∀ x, f x = f (-x)
def fn_odd (f : ℝ → ℝ) : Prop := ∀ x, f x = - f (-x)

example (ef : fn_even f) (eg : fn_even g) : fn_even (λ x, f x + g x) :=
begin
  intro x,
  calc
    (λ x, f x + g x) x = f x + g x       : rfl
                    ... = f (-x) + g (-x) : by rw [ef, eg]
end

example (of : fn_odd f) (og : fn_odd g) : fn_even (λ x, f x * g x) :=
sorry

example (ef : fn_even f) (og : fn_odd g) : fn_odd (λ x, f x * g x) :=
sorry

example (ef : fn_even f) (og : fn_odd g) : fn_even (λ x, f (g x)) :=
sorry

end

section
variables {α : Type*} (r s t : set α)

example : s ⊆ s :=
by { intros x xs, exact xs }

theorem subset.refl : s ⊆ s := λ x xs, xs

theorem subset.trans : r ⊆ s → s ⊆ t → r ⊆ t :=
begin
  intros rs st x xinr,
  exact st (rs xinr),
end

end

section

variables {α : Type*} [partial_order α]
variables (s : set α) (a b : α)

def set_ub (s : set α) (a : α) := ∀ x, x ∈ s → x ≤ a

example (h : set_ub s a) (h' : a ≤ b) : set_ub s b :=
sorry

end

section
open function

example (c : ℝ) : injective (λ x, x + c) :=
begin
  intros x₁ x₂ h',
  exact (add_left_inj c).mp h',
end

example {c : ℝ} (h : c ≠ 0) : injective (λ x, c * x) :=
begin
  intros x y h',
  dsimp at h',
  calc
  x   = c⁻¹ * (c * x)  : (eq_inv_mul_iff_mul_eq₀ h).mpr rfl
  -- `library_search` said it
  ... = c⁻¹ * (c * y)  : by congr' -- depth 1
  ... = y              : by rw ← (eq_inv_mul_iff_mul_eq₀ h).mpr rfl
  /-
  The official solution involved the instance `cancel_monoid_with_zero`,
  instead of something about groups as above
  -/
end

variables {α : Type*} {β : Type*} {γ : Type*}
variables {g : β → γ} {f : α → β}

example (injg : injective g) (injf : injective f) :
  injective (λ x, g (f x)) :=
/-
-- long proof
begin
  intros x y h,
  apply injf,
  apply injg,
  exact h,
end
-/
λ x y h, injf (injg h) -- long-sought proof term

end


/-
Copyright (c) 2021 Julian Kuelshammer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Julian Kuelshammer
-/
import algebra.pempty_instances
import category_theory.concrete_category.bundled_hom
import category_theory.functor.reflects_isomorphisms

/-!
# Category instances for has_mul, has_add, semigroup and add_semigroup

We introduce the bundled categories:
* `Magma`
* `AddMagma`
* `Semigroup`
* `AddSemigroup`
along with the relevant forgetful functors between them.

This closely follows `algebra.category.Mon.basic`.

## TODO

* Limits in these categories
* free/forgetful adjunctions
-/

universes u v

open category_theory

/-- The category of magmas and magma morphisms. -/
@[to_additive AddMagma]
def Magma : Type (u+1) := bundled has_mul

/-- The category of additive magmas and additive magma morphisms. -/
add_decl_doc AddMagma

namespace Magma

@[to_additive]
instance bundled_hom : bundled_hom @mul_hom :=
⟨@mul_hom.to_fun, @mul_hom.id, @mul_hom.comp, @mul_hom.coe_inj⟩

attribute [derive [large_category, concrete_category]] Magma
attribute [to_additive] Magma.large_category Magma.concrete_category

@[to_additive] instance : has_coe_to_sort Magma Type* := bundled.has_coe_to_sort

/-- Construct a bundled `Magma` from the underlying type and typeclass. -/
@[to_additive]
def of (M : Type u) [has_mul M] : Magma := bundled.of M

/-- Construct a bundled `AddMagma` from the underlying type and typeclass. -/
add_decl_doc AddMagma.of

/-- Typecheck a `mul_hom` as a morphism in `Magma`. -/
@[to_additive] def of_hom {X Y : Type u} [has_mul X] [has_mul Y] (f : mul_hom X Y) :
  of X ⟶ of Y := f

/-- Typecheck a `add_hom` as a morphism in `AddMagma`. -/
add_decl_doc AddMagma.of_hom

@[simp, to_additive] lemma of_hom_apply {X Y : Type u} [has_mul X] [has_mul Y] (f : mul_hom X Y)
  (x : X) : of_hom f x = f x := rfl

@[to_additive]
instance : inhabited Magma := ⟨Magma.of pempty⟩

@[to_additive]
instance (M : Magma) : has_mul M := M.str

@[simp, to_additive] lemma coe_of (R : Type u) [has_mul R] : (Magma.of R : Type u) = R := rfl

end Magma

/-- The category of semigroups and semigroup morphisms. -/
@[to_additive AddSemigroup]
def Semigroup : Type (u+1) := bundled semigroup

/-- The category of additive semigroups and semigroup morphisms. -/
add_decl_doc AddSemigroup

namespace Semigroup

@[to_additive]
instance : bundled_hom.parent_projection semigroup.to_has_mul := ⟨⟩

attribute [derive [large_category, concrete_category]] Semigroup
attribute [to_additive] Semigroup.large_category Semigroup.concrete_category

@[to_additive] instance : has_coe_to_sort Semigroup Type* := bundled.has_coe_to_sort

/-- Construct a bundled `Semigroup` from the underlying type and typeclass. -/
@[to_additive]
def of (M : Type u) [semigroup M] : Semigroup := bundled.of M

/-- Construct a bundled `AddSemigroup` from the underlying type and typeclass. -/
add_decl_doc AddSemigroup.of

/-- Typecheck a `mul_hom` as a morphism in `Semigroup`. -/
@[to_additive] def of_hom {X Y : Type u} [semigroup X] [semigroup Y] (f : mul_hom X Y) :
  of X ⟶ of Y := f

/-- Typecheck a `add_hom` as a morphism in `AddSemigroup`. -/
add_decl_doc AddSemigroup.of_hom

@[simp, to_additive] lemma of_hom_apply {X Y : Type u} [semigroup X] [semigroup Y] (f : mul_hom X Y)
  (x : X) : of_hom f x = f x := rfl

@[to_additive]
instance : inhabited Semigroup := ⟨Semigroup.of pempty⟩

@[to_additive]
instance (M : Semigroup) : semigroup M := M.str

@[simp, to_additive] lemma coe_of (R : Type u) [semigroup R] : (Semigroup.of R : Type u) = R := rfl

@[to_additive has_forget_to_AddMagma]
instance has_forget_to_Magma : has_forget₂ Semigroup Magma := bundled_hom.forget₂ _ _

end Semigroup

variables {X Y : Type u}

section
variables [has_mul X] [has_mul Y]

/-- Build an isomorphism in the category `Magma` from a `mul_equiv` between `has_mul`s. -/
@[to_additive add_equiv.to_AddMagma_iso "Build an isomorphism in the category `AddMagma` from
an `add_equiv` between `has_add`s.", simps]
def mul_equiv.to_Magma_iso (e : X ≃* Y) : Magma.of X ≅ Magma.of Y :=
{ hom := e.to_mul_hom,
  inv := e.symm.to_mul_hom }

end

section
variables [semigroup X] [semigroup Y]

/-- Build an isomorphism in the category `Semigroup` from a `mul_equiv` between `semigroup`s. -/
@[to_additive add_equiv.to_AddSemigroup_iso "Build an isomorphism in the category
`AddSemigroup` from an `add_equiv` between `add_semigroup`s.", simps]
def mul_equiv.to_Semigroup_iso (e : X ≃* Y) : Semigroup.of X ≅ Semigroup.of Y :=
{ hom := e.to_mul_hom,
  inv := e.symm.to_mul_hom }

end

namespace category_theory.iso

/-- Build a `mul_equiv` from an isomorphism in the category `Magma`. -/
@[to_additive AddMagma_iso_to_add_equiv "Build an `add_equiv` from an isomorphism in the category
`AddMagma`."]
def Magma_iso_to_mul_equiv {X Y : Magma} (i : X ≅ Y) : X ≃* Y :=
{ to_fun := i.hom,
  inv_fun := i.inv,
  left_inv := begin rw function.left_inverse, simp end,
  right_inv := begin rw function.right_inverse, rw function.left_inverse, simp end,
  map_mul' := by simp }

/-- Build a `mul_equiv` from an isomorphism in the category `Semigroup`. -/
@[to_additive "Build an `add_equiv` from an isomorphism in the category
`AddSemigroup`."]
def Semigroup_iso_to_mul_equiv {X Y : Semigroup} (i : X ≅ Y) : X ≃* Y :=
{ to_fun := i.hom,
  inv_fun := i.inv,
  left_inv := begin rw function.left_inverse, simp end,
  right_inv := begin rw function.right_inverse, rw function.left_inverse, simp end,
  map_mul' := by simp }

end category_theory.iso

/-- multiplicative equivalences between `has_mul`s are the same as (isomorphic to) isomorphisms
in `Magma` -/
@[to_additive add_equiv_iso_AddMagma_iso "additive equivalences between `has_add`s are the same
as (isomorphic to) isomorphisms in `AddMagma`"]
def mul_equiv_iso_Magma_iso {X Y : Type u} [has_mul X] [has_mul Y] :
  (X ≃* Y) ≅ (Magma.of X ≅ Magma.of Y) :=
{ hom := λ e, e.to_Magma_iso,
  inv := λ i, i.Magma_iso_to_mul_equiv }

/-- multiplicative equivalences between `semigroup`s are the same as (isomorphic to) isomorphisms
in `Semigroup` -/
@[to_additive add_equiv_iso_AddSemigroup_iso "additive equivalences between `add_semigroup`s are
the same as (isomorphic to) isomorphisms in `AddSemigroup`"]
def mul_equiv_iso_Semigroup_iso {X Y : Type u} [semigroup X] [semigroup Y] :
  (X ≃* Y) ≅ (Semigroup.of X ≅ Semigroup.of Y) :=
{ hom := λ e, e.to_Semigroup_iso,
  inv := λ i, i.Semigroup_iso_to_mul_equiv }

@[to_additive]
instance Magma.forget_reflects_isos : reflects_isomorphisms (forget Magma.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget Magma).map f),
    let e : X ≃* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_Magma_iso).1⟩,
  end }

@[to_additive]
instance Semigroup.forget_reflects_isos : reflects_isomorphisms (forget Semigroup.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget Semigroup).map f),
    let e : X ≃* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_Semigroup_iso).1⟩,
  end }

/-!
Once we've shown that the forgetful functors to type reflect isomorphisms,
we automatically obtain that the `forget₂` functors between our concrete categories
reflect isomorphisms.
-/
example : reflects_isomorphisms (forget₂ Semigroup Magma) := by apply_instance


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

! This file was ported from Lean 3 source module algebra.direct_sum.module
! leanprover-community/mathlib commit 6623e6af705e97002a9054c1c05a980180276fc1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.DirectSum.Basic
import Mathlib.LinearAlgebra.Dfinsupp

/-!
# Direct sum of modules

The first part of the file provides constructors for direct sums of modules. It provides a
construction of the direct sum using the universal property and proves its uniqueness
(`DirectSum.toModule.unique`).

The second part of the file covers the special case of direct sums of submodules of a fixed module
`M`.  There is a canonical linear map from this direct sum to `M` (`DirectSum.coeLinearMap`), and
the construction is of particular importance when this linear map is an equivalence; that is, when
the submodules provide an internal decomposition of `M`.  The property is defined more generally
elsewhere as `DirectSum.IsInternal`, but its basic consequences on `Submodule`s are established
in this file.

-/

universe u v w u₁

namespace DirectSum

open DirectSum

section General

variable {R : Type u} [Semiring R]

variable {ι : Type v} [dec_ι : DecidableEq ι]

variable {M : ι → Type w} [∀ i, AddCommMonoid (M i)] [∀ i, Module R (M i)]

instance : Module R (⨁ i, M i) :=
  Dfinsupp.module

instance {S : Type _} [Semiring S] [∀ i, Module S (M i)] [∀ i, SMulCommClass R S (M i)] :
    SMulCommClass R S (⨁ i, M i) :=
  Dfinsupp.smulCommClass

instance {S : Type _} [Semiring S] [SMul R S] [∀ i, Module S (M i)] [∀ i, IsScalarTower R S (M i)] :
    IsScalarTower R S (⨁ i, M i) :=
  Dfinsupp.isScalarTower

instance [∀ i, Module Rᵐᵒᵖ (M i)] [∀ i, IsCentralScalar R (M i)] : IsCentralScalar R (⨁ i, M i) :=
  Dfinsupp.isCentralScalar

theorem smul_apply (b : R) (v : ⨁ i, M i) (i : ι) : (b • v) i = b • v i :=
  Dfinsupp.smul_apply _ _ _
#align direct_sum.smul_apply DirectSum.smul_apply

variable (R ι M)

/-- Create the direct sum given a family `M` of `R` modules indexed over `ι`. -/
def lmk : ∀ s : Finset ι, (∀ i : (↑s : Set ι), M i.val) →ₗ[R] ⨁ i, M i :=
  Dfinsupp.lmk
#align direct_sum.lmk DirectSum.lmk

/-- Inclusion of each component into the direct sum. -/
def lof : ∀ i : ι, M i →ₗ[R] ⨁ i, M i :=
  Dfinsupp.lsingle
#align direct_sum.lof DirectSum.lof

theorem lof_eq_of (i : ι) (b : M i) : lof R ι M i b = of M i b := rfl
#align direct_sum.lof_eq_of DirectSum.lof_eq_of

variable {ι M}

theorem single_eq_lof (i : ι) (b : M i) : Dfinsupp.single i b = lof R ι M i b := rfl
#align direct_sum.single_eq_lof DirectSum.single_eq_lof

/-- Scalar multiplication commutes with direct sums. -/
theorem mk_smul (s : Finset ι) (c : R) (x) : mk M s (c • x) = c • mk M s x :=
  (lmk R ι M s).map_smul c x
#align direct_sum.mk_smul DirectSum.mk_smul

/-- Scalar multiplication commutes with the inclusion of each component into the direct sum. -/
theorem of_smul (i : ι) (c : R) (x) : of M i (c • x) = c • of M i x :=
  (lof R ι M i).map_smul c x
#align direct_sum.of_smul DirectSum.of_smul

variable {R}

theorem support_smul [∀ (i : ι) (x : M i), Decidable (x ≠ 0)] (c : R) (v : ⨁ i, M i) :
    (c • v).support ⊆ v.support :=
  Dfinsupp.support_smul _ _
#align direct_sum.support_smul DirectSum.support_smul

variable {N : Type u₁} [AddCommMonoid N] [Module R N]

variable (φ : ∀ i, M i →ₗ[R] N)

variable (R ι N)

/-- The linear map constructed using the universal property of the coproduct. -/
def toModule : (⨁ i, M i) →ₗ[R] N :=
  FunLike.coe (Dfinsupp.lsum ℕ) φ
#align direct_sum.to_module DirectSum.toModule

/-- Coproducts in the categories of modules and additive monoids commute with the forgetful functor
from modules to additive monoids. -/
theorem coe_toModule_eq_coe_toAddMonoid :
    (toModule R ι N φ : (⨁ i, M i) → N) = toAddMonoid fun i ↦ (φ i).toAddMonoidHom := rfl
#align direct_sum.coe_to_module_eq_coe_to_add_monoid DirectSum.coe_toModule_eq_coe_toAddMonoid

variable {ι N φ}

/-- The map constructed using the universal property gives back the original maps when
restricted to each component. -/
@[simp]
theorem toModule_lof (i) (x : M i) : toModule R ι N φ (lof R ι M i x) = φ i x :=
  toAddMonoid_of (fun i ↦ (φ i).toAddMonoidHom) i x
#align direct_sum.to_module_lof DirectSum.toModule_lof

variable (ψ : (⨁ i, M i) →ₗ[R] N)

/-- Every linear map from a direct sum agrees with the one obtained by applying
the universal property to each of its components. -/
theorem toModule.unique (f : ⨁ i, M i) : ψ f = toModule R ι N (fun i ↦ ψ.comp <| lof R ι M i) f :=
  toAddMonoid.unique ψ.toAddMonoidHom f
#align direct_sum.to_module.unique DirectSum.toModule.unique

variable {ψ} {ψ' : (⨁ i, M i) →ₗ[R] N}

/-- Two `LinearMap`s out of a direct sum are equal if they agree on the generators.

See note [partially-applied ext lemmas]. -/
@[ext]
theorem linearMap_ext ⦃ψ ψ' : (⨁ i, M i) →ₗ[R] N⦄
    (H : ∀ i, ψ.comp (lof R ι M i) = ψ'.comp (lof R ι M i)) : ψ = ψ' :=
  Dfinsupp.lhom_ext' H
#align direct_sum.linear_map_ext DirectSum.linearMap_ext

/-- The inclusion of a subset of the direct summands
into a larger subset of the direct summands, as a linear map. -/
def lsetToSet (S T : Set ι) (H : S ⊆ T) : (⨁ i : S, M i) →ₗ[R] ⨁ i : T, M i :=
  toModule R _ _ fun i ↦ lof R T (fun i : Subtype T ↦ M i) ⟨i, H i.prop⟩
#align direct_sum.lset_to_set DirectSum.lsetToSet

variable (ι M)

/-- Given `Fintype α`, `linearEquivFunOnFintype R` is the natural `R`-linear equivalence
between `⨁ i, M i` and `∀ i, M i`. -/
@[simps apply]
def linearEquivFunOnFintype [Fintype ι] : (⨁ i, M i) ≃ₗ[R] ∀ i, M i :=
  { Dfinsupp.equivFunOnFintype with
    toFun := (↑)
    map_add' := fun f g ↦ by
      ext
      rw [add_apply, Pi.add_apply]
    map_smul' := fun c f ↦ by
      simp_rw [RingHom.id_apply]
      rw [Dfinsupp.coe_smul] }
#align direct_sum.linear_equiv_fun_on_fintype DirectSum.linearEquivFunOnFintype

variable {ι M}

@[simp]
theorem linearEquivFunOnFintype_lof [Fintype ι] [DecidableEq ι] (i : ι) (m : M i) :
    (linearEquivFunOnFintype R ι M) (lof R ι M i m) = Pi.single i m := by
  ext a
  change (Dfinsupp.equivFunOnFintype (lof R ι M i m)) a = _
  convert _root_.congr_fun (Dfinsupp.equivFunOnFintype_single i m) a
#align direct_sum.linear_equiv_fun_on_fintype_lof DirectSum.linearEquivFunOnFintype_lof

@[simp]
theorem linearEquivFunOnFintype_symm_single [Fintype ι] [DecidableEq ι] (i : ι) (m : M i) :
    (linearEquivFunOnFintype R ι M).symm (Pi.single i m) = lof R ι M i m := by
  change (Dfinsupp.equivFunOnFintype.symm (Pi.single i m)) = _
  rw [Dfinsupp.equivFunOnFintype_symm_single i m]
  rfl
#align direct_sum.linear_equiv_fun_on_fintype_symm_single DirectSum.linearEquivFunOnFintype_symm_single

@[simp]
theorem linearEquivFunOnFintype_symm_coe [Fintype ι] (f : ⨁ i, M i) :
    (linearEquivFunOnFintype R ι M).symm f = f := by
  simp [linearEquivFunOnFintype]
#align direct_sum.linear_equiv_fun_on_fintype_symm_coe DirectSum.linearEquivFunOnFintype_symm_coe

/-- The natural linear equivalence between `⨁ _ : ι, M` and `M` when `Unique ι`. -/
protected def lid (M : Type v) (ι : Type _ := PUnit) [AddCommMonoid M] [Module R M] [Unique ι] :
    (⨁ _i : ι, M) ≃ₗ[R] M :=
  { DirectSum.id M ι, toModule R ι M fun _ ↦ LinearMap.id with }
#align direct_sum.lid DirectSum.lid

variable (ι M)

/-- The projection map onto one component, as a linear map. -/
def component (i : ι) : (⨁ i, M i) →ₗ[R] M i :=
  Dfinsupp.lapply i
#align direct_sum.component DirectSum.component

variable {ι M}

theorem apply_eq_component (f : ⨁ i, M i) (i : ι) : f i = component R ι M i f := rfl
#align direct_sum.apply_eq_component DirectSum.apply_eq_component

@[ext]
theorem ext {f g : ⨁ i, M i} (h : ∀ i, component R ι M i f = component R ι M i g) : f = g :=
  Dfinsupp.ext h
#align direct_sum.ext DirectSum.ext

theorem ext_iff {f g : ⨁ i, M i} : f = g ↔ ∀ i, component R ι M i f = component R ι M i g :=
  ⟨fun h _ ↦ by rw [h], ext R⟩
#align direct_sum.ext_iff DirectSum.ext_iff

@[simp]
theorem lof_apply (i : ι) (b : M i) : ((lof R ι M i) b) i = b :=
  Dfinsupp.single_eq_same
#align direct_sum.lof_apply DirectSum.lof_apply

@[simp]
theorem component.lof_self (i : ι) (b : M i) : component R ι M i ((lof R ι M i) b) = b :=
  lof_apply R i b
#align direct_sum.component.lof_self DirectSum.component.lof_self

theorem component.of (i j : ι) (b : M j) :
    component R ι M i ((lof R ι M j) b) = if h : j = i then Eq.recOn h b else 0 :=
  Dfinsupp.single_apply
#align direct_sum.component.of DirectSum.component.of

section CongrLeft

variable {κ : Type _}

/-- Reindexing terms of a direct sum is linear. -/
def lequivCongrLeft (h : ι ≃ κ) : (⨁ i, M i) ≃ₗ[R] ⨁ k, M (h.symm k) :=
  { equivCongrLeft h with map_smul' := Dfinsupp.comapDomain'_smul h.invFun h.right_inv }
#align direct_sum.lequiv_congr_left DirectSum.lequivCongrLeft

@[simp]
theorem lequivCongrLeft_apply (h : ι ≃ κ) (f : ⨁ i, M i) (k : κ) :
    lequivCongrLeft R h f k = f (h.symm k) :=
  equivCongrLeft_apply _ _ _
#align direct_sum.lequiv_congr_left_apply DirectSum.lequivCongrLeft_apply

end CongrLeft

section Sigma

variable {α : ι → Type _} {δ : ∀ i, α i → Type w}

variable [∀ i j, AddCommMonoid (δ i j)] [∀ i j, Module R (δ i j)]

/-- `curry` as a linear map. -/
noncomputable def sigmaLcurry : (⨁ i : Σi, _, δ i.1 i.2) →ₗ[R] ⨁ (i) (j), δ i j :=
  { sigmaCurry with map_smul' := fun r ↦ by convert @Dfinsupp.sigmaCurry_smul _ _ _ δ _ _ _ r }
#align direct_sum.sigma_lcurry DirectSum.sigmaLcurry

@[simp]
theorem sigmaLcurry_apply (f : ⨁ i : Σ_, _, δ i.1 i.2) (i : ι) (j : α i) :
    sigmaLcurry R f i j = f ⟨i, j⟩ :=
  sigmaCurry_apply f i j
#align direct_sum.sigma_lcurry_apply DirectSum.sigmaLcurry_apply

-- Porting note: marked noncomputable
/-- `uncurry` as a linear map. -/
noncomputable def sigmaLuncurry [∀ i, DecidableEq (α i)] [∀ i j, DecidableEq (δ i j)] :
    (⨁ (i) (j), δ i j) →ₗ[R] ⨁ i : Σ_, _, δ i.1 i.2 :=
  { sigmaUncurry with map_smul' := Dfinsupp.sigmaUncurry_smul }
#align direct_sum.sigma_luncurry DirectSum.sigmaLuncurry

@[simp]
theorem sigmaLuncurry_apply [∀ i, DecidableEq (α i)] [∀ i j, DecidableEq (δ i j)]
    (f : ⨁ (i) (j), δ i j) (i : ι) (j : α i) : sigmaLuncurry R f ⟨i, j⟩ = f i j :=
  sigmaUncurry_apply f i j
#align direct_sum.sigma_luncurry_apply DirectSum.sigmaLuncurry_apply

/-- `curryEquiv` as a linear equiv. -/
noncomputable def sigmaLcurryEquiv [∀ i, DecidableEq (α i)] [∀ i j, DecidableEq (δ i j)] :
    (⨁ i : Σ_, _, δ i.1 i.2) ≃ₗ[R] ⨁ (i) (j), δ i j :=
  { sigmaCurryEquiv, sigmaLcurry R with }
#align direct_sum.sigma_lcurry_equiv DirectSum.sigmaLcurryEquiv

end Sigma

section Option

variable {α : Option ι → Type w} [∀ i, AddCommMonoid (α i)] [∀ i, Module R (α i)]

/-- Linear isomorphism obtained by separating the term of index `none` of a direct sum over
`Option ι`. -/
@[simps]
noncomputable def lequivProdDirectSum : (⨁ i, α i) ≃ₗ[R] α none × ⨁ i, α (some i) :=
  { addEquivProdDirectSum with map_smul' := Dfinsupp.equivProdDfinsupp_smul }
#align direct_sum.lequiv_prod_direct_sum DirectSum.lequivProdDirectSum

end Option

end General

section Submodule

section Semiring

variable {R : Type u} [Semiring R]

variable {ι : Type v} [dec_ι : DecidableEq ι]

variable {M : Type _} [AddCommMonoid M] [Module R M]

variable (A : ι → Submodule R M)

/-- The canonical embedding from `⨁ i, A i` to `M` where `A` is a collection of `Submodule R M`
indexed by `ι`. This is `DirectSum.coeAddMonoidHom` as a `LinearMap`. -/
def coeLinearMap : (⨁ i, A i) →ₗ[R] M :=
  toModule R ι M fun i ↦ (A i).subtype
#align direct_sum.coe_linear_map DirectSum.coeLinearMap

@[simp]
theorem coeLinearMap_of (i : ι) (x : A i) : DirectSum.coeLinearMap A (of (fun i ↦ A i) i x) = x :=
-- Porting note: spelled out arguments. (I don't know how this works.)
toAddMonoid_of (β := fun i => A i) (fun i ↦ ((A i).subtype : A i →+ M)) i x
#align direct_sum.coe_linear_map_of DirectSum.coeLinearMap_of

variable {A}

/-- If a direct sum of submodules is internal then the submodules span the module. -/
theorem IsInternal.submodule_supᵢ_eq_top (h : IsInternal A) : supᵢ A = ⊤ := by
  rw [Submodule.supᵢ_eq_range_dfinsupp_lsum, LinearMap.range_eq_top]
  exact Function.Bijective.surjective h
#align direct_sum.is_internal.submodule_supr_eq_top DirectSum.IsInternal.submodule_supᵢ_eq_top

/-- If a direct sum of submodules is internal then the submodules are independent. -/
theorem IsInternal.submodule_independent (h : IsInternal A) : CompleteLattice.Independent A :=
  CompleteLattice.independent_of_dfinsupp_lsum_injective _ h.injective
#align direct_sum.is_internal.submodule_independent DirectSum.IsInternal.submodule_independent

/-- Given an internal direct sum decomposition of a module `M`, and a basis for each of the
components of the direct sum, the disjoint union of these bases is a basis for `M`. -/
noncomputable def IsInternal.collectedBasis (h : IsInternal A) {α : ι → Type _}
    (v : ∀ i, Basis (α i) R (A i)) : Basis (Σi, α i) R M
    where repr :=
    ((LinearEquiv.ofBijective (DirectSum.coeLinearMap A) h).symm ≪≫ₗ
        Dfinsupp.mapRange.linearEquiv fun i ↦ (v i).repr) ≪≫ₗ
      (sigmaFinsuppLequivDfinsupp R).symm
#align direct_sum.is_internal.collected_basis DirectSum.IsInternal.collectedBasis

@[simp]
theorem IsInternal.collectedBasis_coe (h : IsInternal A) {α : ι → Type _}
    (v : ∀ i, Basis (α i) R (A i)) : ⇑(h.collectedBasis v) = fun a : Σi, α i ↦ ↑(v a.1 a.2) := by
  funext a
  -- Porting note: was
  -- simp only [IsInternal.collectedBasis, toModule, coeLinearMap, Basis.coe_ofRepr,
  --   Basis.repr_symm_apply, Dfinsupp.lsum_apply_apply, Dfinsupp.mapRange.linearEquiv_apply,
  --   Dfinsupp.mapRange.linearEquiv_symm, Dfinsupp.mapRange_single, Finsupp.total_single,
  --   LinearEquiv.ofBijective_apply, LinearEquiv.symm_symm, LinearEquiv.symm_trans_apply, one_smul,
  --   sigmaFinsuppAddEquivDfinsupp_apply, sigmaFinsuppEquivDfinsupp_single,
  --   sigmaFinsuppLequivDfinsupp_apply]
  -- convert Dfinsupp.sumAddHom_single (fun i ↦ (A i).subtype.toAddMonoidHom) a.1 (v a.1 a.2)
  simp only [IsInternal.collectedBasis, coeLinearMap, Basis.coe_ofRepr, LinearEquiv.trans_symm,
    LinearEquiv.symm_symm, LinearEquiv.trans_apply, sigmaFinsuppLequivDfinsupp_apply,
    sigmaFinsuppEquivDfinsupp_single, LinearEquiv.ofBijective_apply,
    sigmaFinsuppAddEquivDfinsupp_apply]
  rw [Dfinsupp.mapRange.linearEquiv_symm]
  erw [Dfinsupp.mapRange.linearEquiv_apply]
  simp only [Dfinsupp.mapRange_single, Basis.repr_symm_apply, Finsupp.total_single, one_smul,
    toModule]
  erw [Dfinsupp.lsum_single]
  simp only [Submodule.coeSubtype]
#align direct_sum.is_internal.collected_basis_coe DirectSum.IsInternal.collectedBasis_coe

theorem IsInternal.collectedBasis_mem (h : IsInternal A) {α : ι → Type _}
    (v : ∀ i, Basis (α i) R (A i)) (a : Σi, α i) : h.collectedBasis v a ∈ A a.1 := by simp
#align direct_sum.is_internal.collected_basis_mem DirectSum.IsInternal.collectedBasis_mem

/-- When indexed by only two distinct elements, `DirectSum.IsInternal` implies
the two submodules are complementary. Over a `Ring R`, this is true as an iff, as
`DirectSum.isInternal_submodule_iff_isCompl`. -/
theorem IsInternal.isCompl {A : ι → Submodule R M} {i j : ι} (hij : i ≠ j)
    (h : (Set.univ : Set ι) = {i, j}) (hi : IsInternal A) : IsCompl (A i) (A j) :=
  ⟨hi.submodule_independent.pairwiseDisjoint hij,
    codisjoint_iff.mpr <| Eq.symm <| hi.submodule_supᵢ_eq_top.symm.trans <| by
      rw [← supₛ_pair, supᵢ, ← Set.image_univ, h, Set.image_insert_eq, Set.image_singleton]⟩
#align direct_sum.is_internal.is_compl DirectSum.IsInternal.isCompl

end Semiring

section Ring

variable {R : Type u} [Ring R]

variable {ι : Type v} [dec_ι : DecidableEq ι]

variable {M : Type _} [AddCommGroup M] [Module R M]

/-- Note that this is not generally true for `[Semiring R]`; see
`CompleteLattice.Independent.dfinsupp_lsum_injective` for details. -/
theorem isInternal_submodule_of_independent_of_supᵢ_eq_top {A : ι → Submodule R M}
    (hi : CompleteLattice.Independent A) (hs : supᵢ A = ⊤) : IsInternal A :=
  ⟨hi.dfinsupp_lsum_injective,
    LinearMap.range_eq_top.1 <| (Submodule.supᵢ_eq_range_dfinsupp_lsum _).symm.trans hs⟩
#align direct_sum.is_internal_submodule_of_independent_of_supr_eq_top DirectSum.isInternal_submodule_of_independent_of_supᵢ_eq_top

/-- `iff` version of `DirectSum.isInternal_submodule_of_independent_of_supᵢ_eq_top`,
`DirectSum.IsInternal.submodule_independent`, and `DirectSum.IsInternal.submodule_supᵢ_eq_top`. -/
theorem isInternal_submodule_iff_independent_and_supᵢ_eq_top (A : ι → Submodule R M) :
    IsInternal A ↔ CompleteLattice.Independent A ∧ supᵢ A = ⊤ :=
  ⟨fun i ↦ ⟨i.submodule_independent, i.submodule_supᵢ_eq_top⟩,
    And.rec isInternal_submodule_of_independent_of_supᵢ_eq_top⟩
#align direct_sum.is_internal_submodule_iff_independent_and_supr_eq_top DirectSum.isInternal_submodule_iff_independent_and_supᵢ_eq_top

/-- If a collection of submodules has just two indices, `i` and `j`, then
`DirectSum.IsInternal` is equivalent to `isCompl`. -/
theorem isInternal_submodule_iff_isCompl (A : ι → Submodule R M) {i j : ι} (hij : i ≠ j)
    (h : (Set.univ : Set ι) = {i, j}) : IsInternal A ↔ IsCompl (A i) (A j) := by
  have : ∀ k, k = i ∨ k = j := fun k ↦ by simpa using Set.ext_iff.mp h k
  rw [isInternal_submodule_iff_independent_and_supᵢ_eq_top, supᵢ, ← Set.image_univ, h,
    Set.image_insert_eq, Set.image_singleton, supₛ_pair, CompleteLattice.independent_pair hij this]
  exact ⟨fun ⟨hd, ht⟩ ↦ ⟨hd, codisjoint_iff.mpr ht⟩, fun ⟨hd, ht⟩ ↦ ⟨hd, ht.eq_top⟩⟩
#align direct_sum.is_internal_submodule_iff_is_compl DirectSum.isInternal_submodule_iff_isCompl

/-! Now copy the lemmas for subgroup and submonoids. -/

theorem IsInternal.addSubmonoid_independent {M : Type _} [AddCommMonoid M] {A : ι → AddSubmonoid M}
    (h : IsInternal A) : CompleteLattice.Independent A :=
  CompleteLattice.independent_of_dfinsupp_sumAddHom_injective _ h.injective
#align direct_sum.is_internal.add_submonoid_independent DirectSum.IsInternal.addSubmonoid_independent

theorem IsInternal.addSubgroup_independent {M : Type _} [AddCommGroup M] {A : ι → AddSubgroup M}
    (h : IsInternal A) : CompleteLattice.Independent A :=
  CompleteLattice.independent_of_dfinsupp_sumAddHom_injective' _ h.injective
#align direct_sum.is_internal.add_subgroup_independent DirectSum.IsInternal.addSubgroup_independent

end Ring

end Submodule

end DirectSum