russell@unturf.com
192118388f
Zoë Trout's favorites at wedgewack.org/ursa.lisp.txt are Common Lisp:
iterative LOOP macros, setf cascades, defun with &optional, image-
based stone-lisp culture. Her first contribution to lumbda was a
question — "do we care for our programs, and how long are they alive
for?" — and the answer now extends beyond the RNG portal (§7.5) to
iteration style itself.
Four-phase delivery, all under ticket 0004:
Phase A — idiomatic Scheme ports at examples/ursa-scheme.lsp.
Every Zoë defun rewritten as named-let + tail recursion + list-
backed work queue + type-predicate dispatch.
Phase B — CL compat shim at cl-compat.lsp.
defun (with &optional), setf (simple vars, multi-pair), flet,
multiple-value-bind, t / nil (nil=#f so cond/if compose),
evenp/oddp/plusp/minusp/zerop, mod/ash/logbitp/nreverse,
cl-when/cl-unless (plain when is a void-returning lumbda special
form), declare (no-op), cddddr (missing accessor).
Phase C — cl-loop macro covering 14 patterns.
while/until/repeat, for VAR from A to/below/downto B, for VAR =
INIT [then STEP], for VAR across VEC, of-type T, do, when/unless
return, finally (return VAL). Sequential do*-style stepping via
gensym + cl-subst. Look-ahead termination so `repeat 4 for s = 4
then (- (* s s) 2) finally (return s)` returns 37634 (pre-step)
rather than 1416317954 (post-step). Every expansion ends in a
named-let tail call — TCO holds for loops of any length.
Phase D — load examples/ursa.lisp.txt with minimal annotation.
Preserves Zoë's CL. Minimal edits documented in file header:
load cl-compat.lsp, loop→cl-loop, when→cl-when, random→random-int,
&key→&optional. rho/digits omitted (need make-array/CLOS — see
ticket 0004 for scope boundary).
Defect uncovered along the way (c/types.c env_lookup): a "global
shortcut" checked global env immediately after missing the local
frame, SKIPPING intermediate parent scopes. Broke lexical scoping
whenever a parent scope shadowed a global. Reproduced with
(define s 4)
(let ((s 100)) (let ((m 0)) s)) ; returned 4, should return 100
Any nested let whose body referenced a shadowed name silently read
the global. Fix: remove the shortcut, walk the parent chain end-to-
end. 1255 assertions across five suites pass unchanged after fix —
surfaced only because cl-loop iterator names routinely collide with
globals accumulated in a stone-lisp image.
Whitepaper §9.2 documents the CL-in-Scheme design and the guarantees
that survive (TCO, portal determinism, cross-impl reproducibility).
Zoë added to authors + acknowledgments; reacknowledgment reframes
her first contribution as the deeper program-lifetime question, with
RNG portal as a derivative (§7.5) and cl-loop as the follow-up.
Tests: tests/cl-compat.lsp (44 assertions) and tests/ursa.lsp (28
assertions) exercise both paths under Python + C via tests/zoe-
favorites-test.sh, wired into make test-all.
MOAD notes: unmoad flags memq/assq in cl-compat.lsp over cl-loop-
keywords (~30 elements, constant) and var->new (≤4 state vars per
loop). Both are macro-expansion-time, bounded-small-N — not runtime
hot paths. Pre-existing c/types.c findings (strcmp-in-loop for
record-type lookup) are not from this change.
140 lines
5.1 KiB
Text
140 lines
5.1 KiB
Text
;;; ursa.lisp.txt — Zoë Trout's favorite programs.
|
|
;;;
|
|
;;; Canonical source: https://wedgewack.org/ursa.lisp.txt (Common Lisp).
|
|
;;; This file preserves Zoë's CL — including iterative LOOP forms — and
|
|
;;; loads into lumbda via the CL compatibility shim at cl-compat.lsp.
|
|
;;;
|
|
;;; Minimal edits from the canonical CL:
|
|
;;; (load "cl-compat.lsp") — prepend to wire in defun/setf/loop/...
|
|
;;; loop → cl-loop — plain `loop` is a reserved name we do
|
|
;;; not shadow; cl-loop is the shim macro.
|
|
;;; when → cl-when — plain `when` is a lumbda special form
|
|
;;; returning #<void>; cl-when returns #f
|
|
;;; so CL "nil on false" idioms compose.
|
|
;;; random → random-int — lumbda RNG with portal-compatible state.
|
|
;;; &key → &optional — keyword args not in the shim; positional.
|
|
;;; rho / digits — two defuns omitted (they depend on
|
|
;;; adjustable arrays + CLOS, out of scope
|
|
;;; per ticket 0004). See ursa-scheme.lsp
|
|
;;; for Scheme ports of both.
|
|
;;;
|
|
;;; Every LOOP form below is the ORIGINAL iterative style — no tail-
|
|
;;; recursive rewrite required. After cl-compat loads, these run under
|
|
;;; lumbda with TCO-preserving expansions (see ticket 0004 §C).
|
|
;;;
|
|
;;; See whitepaper §9.2 for the CL-in-Scheme rationale, and how this
|
|
;;; file keeps Zoë's programs alive without stripping their iterative
|
|
;;; shape.
|
|
|
|
(load "cl-compat.lsp")
|
|
|
|
(defun expt-mod (base exponent modulus)
|
|
(declare (optimize (speed 3) (safety 1))
|
|
(type integer base exponent modulus))
|
|
(cond ((= modulus 1) 0)
|
|
((= base 2) (mod (ash 1 exponent) modulus))
|
|
(t (let ((b (mod base modulus))
|
|
(e exponent)
|
|
(acc 1))
|
|
(declare (type integer b e acc))
|
|
(cl-loop while (plusp e) do
|
|
(cl-when (logbitp 0 e)
|
|
(setf acc (mod (* acc b) modulus)))
|
|
(setf b (mod (* b b) modulus)
|
|
e (ash e -1)))
|
|
acc))))
|
|
|
|
(defun miller-rabin-base (n a d s)
|
|
(declare (optimize (speed 3) (safety 1))
|
|
(type integer n a d s))
|
|
(let ((x (expt-mod a d n)))
|
|
(cond ((or (= x 1) (= x (1- n))) t)
|
|
(t (cl-loop repeat s
|
|
do (setf x (expt-mod x 2 n))
|
|
when (= x (1- n)) return t
|
|
finally (return nil))))))
|
|
|
|
(defun miller-rabin (n &optional (k 10))
|
|
(declare (optimize (speed 3) (safety 1))
|
|
(type integer n))
|
|
(cond ((<= n 1) nil)
|
|
((<= n 3) t)
|
|
((evenp n) nil)
|
|
(t (let ((d (1- n))
|
|
(s 0))
|
|
(cl-loop while (evenp d) do
|
|
(setf d (ash d -1)
|
|
s (1+ s)))
|
|
(cl-loop repeat k
|
|
for a = (+ 2 (random-int (- n 2)))
|
|
unless (miller-rabin-base n a d s)
|
|
return nil
|
|
finally (return t))))))
|
|
|
|
(defun primep (n &optional (k 10))
|
|
(declare (optimize (speed 3) (safety 1))
|
|
(type integer n k))
|
|
(cl-when (miller-rabin n k) n))
|
|
|
|
(defun rhoff (n)
|
|
(declare (optimize (speed 3) (safety 1))
|
|
(type (integer 2 *) n))
|
|
(cond ((evenp n) 2)
|
|
((primep n) n)
|
|
(t
|
|
(let ((c (1+ (random-int (1- n))))
|
|
(x 2)
|
|
(y 2)
|
|
(d 1))
|
|
(declare (type integer c x y d))
|
|
(flet ((f (z)
|
|
(declare (type integer z))
|
|
(mod (+ (* z z) c) n)))
|
|
(cl-loop while (= d 1) do
|
|
(setf x (f x)
|
|
y (f (f y))
|
|
d (gcd (abs (- x y)) n))
|
|
finally (return (and (< 1 d n) d))))))))
|
|
|
|
(defun repunit-value (n &optional (digit 1) (base 2))
|
|
(declare (type (integer 2) base)
|
|
(type (integer 1) digit)
|
|
(optimize (speed 3) (safety 2)))
|
|
(cl-when (> base digit)
|
|
(cl-loop for i from 0 to (1- n)
|
|
for j = digit then (+ j (* digit (expt base i)))
|
|
finally (return j))))
|
|
|
|
(defun mersenne-number (p)
|
|
(declare (type (integer 0 *) p)
|
|
(optimize (speed 3) (safety 1)))
|
|
(1- (ash 1 p)))
|
|
|
|
(defun lucas-lehmer-residue (p)
|
|
(declare (type (integer 3 *) p)
|
|
(optimize (speed 3) (safety 1)))
|
|
(let ((m (mersenne-number p)))
|
|
(cl-loop repeat (- p 1)
|
|
for s of-type integer = 4 then (mod (- (* s s) 2) m)
|
|
finally (return s))))
|
|
|
|
(defun lucas-lehmer-primep (p)
|
|
(declare (type (integer 3 *) p)
|
|
(optimize (speed 3) (safety 1)))
|
|
(and (primep p)
|
|
(zerop (lucas-lehmer-residue p))))
|
|
|
|
(defun of-n-bits (n)
|
|
(declare (optimize (speed 3) (safety 1) (debug 0))
|
|
(type integer n))
|
|
(cl-when (>= n 2)
|
|
(cl-loop for i from (1- n) downto 0
|
|
for sum = (expt 2 i) then (+ sum (* (random-int 2) (expt 2 i)))
|
|
finally (return sum))))
|
|
|
|
(defun prime-of-n-bits (n)
|
|
(declare (optimize (speed 3) (safety 1) (debug 0))
|
|
(type integer n))
|
|
(cl-when (>= n 2)
|
|
(cl-loop for i = (of-n-bits n)
|
|
when (primep i) return i)))
|