;;; 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)))
