Skip to content

Commit d2d33ff

Browse files
feat(CombinatoryLogic): SKI terms for Nat.sqrt, Nat.pair, and Nat.unpair (#445)
Implement SKI combinator terms for Nat.sqrt, Nat.pair, and Nat.unpair with correctness proofs against Mathlib definitions. Split out from #403 to make review easier. --------- Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com>
1 parent 2d9ad57 commit d2d33ff

1 file changed

Lines changed: 160 additions & 1 deletion

File tree

Cslib/Languages/CombinatoryLogic/Recursion.lean

Lines changed: 160 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,13 @@
11
/-
22
Copyright (c) 2025 Thomas Waring. All rights reserved.
33
Released under Apache 2.0 license as described in the file LICENSE.
4-
Authors: Thomas Waring
4+
Authors: Thomas Waring, Jesse Alama
55
-/
66

77
module
88

99
public import Cslib.Languages.CombinatoryLogic.Basic
10+
public import Mathlib.Data.Nat.Pairing
1011

1112
@[expose] public section
1213

@@ -30,6 +31,13 @@ implies `Rec ⬝ x ⬝ g ⬝ a ↠ x`.
3031
- Unbounded root finding (μ-recursion) : given a term `f` representing a function `fℕ: Nat → Nat`,
3132
which takes on the value 0 a term `RFind` such that (`rFind_correct`) `RFind ⬝ f ↠ a` such that
3233
`IsChurch n a` for `n` the smallest root of `fℕ`.
34+
- Integer square root : a term `Sqrt` so that (`sqrt_correct`)
35+
`IsChurch n a → IsChurch n.sqrt (Sqrt ⬝ a)`.
36+
- Nat pairing : a term `NatPair` so that (`natPair_correct`)
37+
`IsChurch a x → IsChurch b y → IsChurch (Nat.pair a b) (NatPair ⬝ x ⬝ y)`.
38+
- Nat unpairing : terms `NatUnpairLeft` and `NatUnpairRight` so that (`natUnpairLeft_correct`)
39+
`IsChurch n a → IsChurch n.unpair.1 (NatUnpairLeft ⬝ a)` and (`natUnpairRight_correct`)
40+
`IsChurch n a → IsChurch n.unpair.2 (NatUnpairRight ⬝ a)`.
3341
3442
## References
3543
@@ -405,6 +413,157 @@ theorem le_correct (n m : Nat) (a b : SKI) (ha : IsChurch n a) (hb : IsChurch m
405413
apply isZero_correct
406414
apply sub_correct <;> assumption
407415

416+
/-! ### Integer square root -/
417+
418+
/-- Inner condition for Sqrt: with &0 = n, &1 = k,
419+
computes `if n < (k+1)² then 0 else 1`. -/
420+
def SqrtCondPoly : SKI.Polynomial 2 :=
421+
SKI.Cond ⬝' SKI.Zero ⬝' SKI.One
422+
⬝' (SKI.Neg ⬝' (SKI.LE ⬝' (SKI.Mul ⬝' (SKI.Succ ⬝' &1) ⬝' (SKI.Succ ⬝' &1)) ⬝' &0))
423+
424+
/-- SKI term for the inner condition of Sqrt -/
425+
def SqrtCond : SKI := SqrtCondPoly.toSKI
426+
427+
/-- `SqrtCond ⬝ n ⬝ k` reduces to: return 0 if `(k+1)² > n`, else 1.
428+
Used by `RFind` to locate the smallest such `k`, which is `√n`. -/
429+
theorem sqrtCond_def (cn ck : SKI) :
430+
(SqrtCond ⬝ cn ⬝ ck) ↠
431+
SKI.Cond ⬝ SKI.Zero ⬝ SKI.One ⬝
432+
(SKI.Neg ⬝ (SKI.LE ⬝ (SKI.Mul ⬝ (SKI.Succ ⬝ ck) ⬝ (SKI.Succ ⬝ ck)) ⬝ cn)) :=
433+
SqrtCondPoly.toSKI_correct [cn, ck] (by simp)
434+
435+
/-- Sqrt n = smallest k such that (k+1)² > n, i.e., the integer square root.
436+
Defined as `λ n. RFind (SqrtCond n)`. -/
437+
def SqrtPoly : SKI.Polynomial 1 := RFind ⬝' (SqrtCond ⬝' &0)
438+
439+
/-- SKI term for integer square root -/
440+
def Sqrt : SKI := SqrtPoly.toSKI
441+
442+
/-- `Sqrt ⬝ n` reduces to an `RFind` search for the smallest `k` with `(k+1)² > n`. -/
443+
theorem sqrt_def (cn : SKI) : (Sqrt ⬝ cn) ↠ RFind ⬝ (SqrtCond ⬝ cn) :=
444+
SqrtPoly.toSKI_correct [cn] (by simp)
445+
446+
/-- `Sqrt` correctly computes `Nat.sqrt`. -/
447+
theorem sqrt_correct (n : Nat) (cn : SKI) (hcn : IsChurch n cn) :
448+
IsChurch (Nat.sqrt n) (Sqrt ⬝ cn) := by
449+
apply isChurch_trans _ (sqrt_def cn)
450+
apply RFind_correct (fun k => if n < (k + 1) * (k + 1) then 0 else 1) (SqrtCond ⬝ cn)
451+
· -- SqrtCond ⬝ cn correctly computes the function
452+
intro i y hy
453+
apply isChurch_trans _ (sqrtCond_def cn y)
454+
have hsucc := succ_correct i y hy
455+
have hle := le_correct _ n _ cn (mul_correct hsucc hsucc) hcn
456+
have hneg := neg_correct _ _ hle
457+
apply isChurch_trans _ (cond_correct _ _ _ _ hneg)
458+
grind
459+
· -- fNat (Nat.sqrt n) = 0
460+
simp [Nat.lt_succ_sqrt]
461+
· -- ∀ i < Nat.sqrt n, fNat i ≠ 0
462+
grind [Nat.le_sqrt]
463+
464+
/-! ### Nat pairing (matching Mathlib's `Nat.pair`) -/
465+
466+
/-- NatPair a b = if a < b then b*b + a else a*a + a + b.
467+
With &0 = a, &1 = b. The condition `a < b` is `¬(b ≤ a)`. -/
468+
def NatPairPoly : SKI.Polynomial 2 :=
469+
SKI.Cond ⬝' (SKI.Add ⬝' (SKI.Mul ⬝' &1 ⬝' &1) ⬝' &0)
470+
⬝' (SKI.Add ⬝' (SKI.Add ⬝' (SKI.Mul ⬝' &0 ⬝' &0) ⬝' &0) ⬝' &1)
471+
⬝' (SKI.Neg ⬝' (SKI.LE ⬝' &1 ⬝' &0))
472+
473+
/-- SKI term for Nat pairing -/
474+
def NatPair : SKI := NatPairPoly.toSKI
475+
476+
/-- `NatPair ⬝ a ⬝ b` reduces to: if `a < b` then `b² + a`, else `a² + a + b`. -/
477+
theorem natPair_def (ca cb : SKI) :
478+
(NatPair ⬝ ca ⬝ cb) ↠
479+
SKI.Cond ⬝ (SKI.Add ⬝ (SKI.Mul ⬝ cb ⬝ cb) ⬝ ca)
480+
⬝ (SKI.Add ⬝ (SKI.Add ⬝ (SKI.Mul ⬝ ca ⬝ ca) ⬝ ca) ⬝ cb)
481+
⬝ (SKI.Neg ⬝ (SKI.LE ⬝ cb ⬝ ca)) :=
482+
NatPairPoly.toSKI_correct [ca, cb] (by simp)
483+
484+
/-- `NatPair` correctly computes `Nat.pair`. -/
485+
theorem natPair_correct (a b : Nat) (ca cb : SKI)
486+
(ha : IsChurch a ca) (hb : IsChurch b cb) :
487+
IsChurch (Nat.pair a b) (NatPair ⬝ ca ⬝ cb) := by
488+
simp only [Nat.pair]
489+
apply isChurch_trans _ (natPair_def ca cb)
490+
have hcond := neg_correct _ _ (le_correct b a cb ca hb ha)
491+
apply isChurch_trans _ (cond_correct _ _ _ _ hcond)
492+
by_cases hab : a < b
493+
· grind [add_correct _ _ _ _ (mul_correct hb hb) ha]
494+
· grind [add_correct _ _ _ _ (add_correct _ _ _ _ (mul_correct ha ha) ha) hb]
495+
496+
/-! ### Nat unpairing (matching Mathlib's `Nat.unpair`) -/
497+
498+
/-- `NatUnpairLeft n = if n - s² < s then n - s² else s` where `s = Nat.sqrt n`. -/
499+
def NatUnpairLeftPoly : SKI.Polynomial 1 :=
500+
let s := Sqrt ⬝' &0
501+
let s2 := SKI.Mul ⬝' s ⬝' s
502+
let diff := SKI.Sub ⬝' &0 ⬝' s2
503+
let cond := SKI.Neg ⬝' (SKI.LE ⬝' s ⬝' diff)
504+
SKI.Cond ⬝' diff ⬝' s ⬝' cond
505+
506+
/-- SKI term for left projection of Nat.unpair -/
507+
def NatUnpairLeft : SKI := NatUnpairLeftPoly.toSKI
508+
509+
/-- `NatUnpairLeft ⬝ n` reduces to: let `s = √n` and `d = n - s²`;
510+
return `d` if `d < s`, else `s`. -/
511+
theorem natUnpairLeft_def (cn : SKI) :
512+
(NatUnpairLeft ⬝ cn) ↠
513+
SKI.Cond ⬝ (SKI.Sub ⬝ cn ⬝ (SKI.Mul ⬝ (Sqrt ⬝ cn) ⬝ (Sqrt ⬝ cn)))
514+
⬝ (Sqrt ⬝ cn)
515+
⬝ (SKI.Neg ⬝ (SKI.LE ⬝ (Sqrt ⬝ cn)
516+
⬝ (SKI.Sub ⬝ cn ⬝ (SKI.Mul ⬝ (Sqrt ⬝ cn) ⬝ (Sqrt ⬝ cn))))) :=
517+
NatUnpairLeftPoly.toSKI_correct [cn] (by simp)
518+
519+
/-- Common Church numeral witnesses for `Nat.sqrt` and the difference `n - (Nat.sqrt n)²`. -/
520+
private theorem natUnpair_church (n : Nat) (cn : SKI) (hcn : IsChurch n cn) :
521+
IsChurch (Nat.sqrt n) (Sqrt ⬝ cn) ∧
522+
IsChurch (n - Nat.sqrt n * Nat.sqrt n)
523+
(SKI.Sub ⬝ cn ⬝ (SKI.Mul ⬝ (Sqrt ⬝ cn) ⬝ (Sqrt ⬝ cn))) := by
524+
have hs := sqrt_correct n cn hcn
525+
exact ⟨hs, sub_correct n _ cn _ hcn (mul_correct hs hs)⟩
526+
527+
/-- `NatUnpairLeft` correctly computes the first component of `Nat.unpair`. -/
528+
theorem natUnpairLeft_correct (n : Nat) (cn : SKI) (hcn : IsChurch n cn) :
529+
IsChurch (Nat.unpair n).1 (NatUnpairLeft ⬝ cn) := by
530+
apply isChurch_trans _ (natUnpairLeft_def cn)
531+
obtain ⟨hs, hdiff⟩ := natUnpair_church n cn hcn
532+
have hcond := neg_correct _ _ (le_correct _ _ _ _ hs hdiff)
533+
apply isChurch_trans _ (cond_correct _ _ _ _ hcond)
534+
by_cases h : n - n.sqrt ^ 2 < n.sqrt <;> grind [Nat.unpair]
535+
536+
/-- NatUnpairRight n = let s = sqrt n in if n - s² < s then s else n - s² - s. -/
537+
def NatUnpairRightPoly : SKI.Polynomial 1 :=
538+
let s := Sqrt ⬝' &0
539+
let s2 := SKI.Mul ⬝' s ⬝' s
540+
let diff := SKI.Sub ⬝' &0 ⬝' s2
541+
let cond := SKI.Neg ⬝' (SKI.LE ⬝' s ⬝' diff)
542+
SKI.Cond ⬝' s ⬝' (SKI.Sub ⬝' diff ⬝' s) ⬝' cond
543+
544+
/-- SKI term for right projection of Nat.unpair -/
545+
def NatUnpairRight : SKI := NatUnpairRightPoly.toSKI
546+
547+
/-- `NatUnpairRight ⬝ n` reduces to: let `s = √n` and `d = n - s²`;
548+
return `s` if `d < s`, else `d - s`. -/
549+
theorem natUnpairRight_def (cn : SKI) :
550+
(NatUnpairRight ⬝ cn) ↠
551+
SKI.Cond ⬝ (Sqrt ⬝ cn)
552+
⬝ (SKI.Sub ⬝ (SKI.Sub ⬝ cn ⬝ (SKI.Mul ⬝ (Sqrt ⬝ cn) ⬝ (Sqrt ⬝ cn)))
553+
⬝ (Sqrt ⬝ cn))
554+
⬝ (SKI.Neg ⬝ (SKI.LE ⬝ (Sqrt ⬝ cn)
555+
⬝ (SKI.Sub ⬝ cn ⬝ (SKI.Mul ⬝ (Sqrt ⬝ cn) ⬝ (Sqrt ⬝ cn))))) :=
556+
NatUnpairRightPoly.toSKI_correct [cn] (by simp)
557+
558+
/-- `NatUnpairRight` correctly computes the second component of `Nat.unpair`. -/
559+
theorem natUnpairRight_correct (n : Nat) (cn : SKI) (hcn : IsChurch n cn) :
560+
IsChurch (Nat.unpair n).2 (NatUnpairRight ⬝ cn) := by
561+
apply isChurch_trans _ (natUnpairRight_def cn)
562+
obtain ⟨hs, hdiff⟩ := natUnpair_church n cn hcn
563+
have hcond := neg_correct _ _ (le_correct _ _ _ _ hs hdiff)
564+
apply isChurch_trans _ (cond_correct _ _ _ _ hcond)
565+
grind [Nat.unpair, sub_correct _ _ _ _ hdiff hs]
566+
408567
end SKI
409568

410569
end Cslib

0 commit comments

Comments
 (0)