11/-
22Copyright (c) 2025 Thomas Waring. All rights reserved.
33Released under Apache 2.0 license as described in the file LICENSE.
4- Authors: Thomas Waring
4+ Authors: Thomas Waring, Jesse Alama
55-/
66
77module
88
99public 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+
408567end SKI
409568
410569end Cslib
0 commit comments