lumbda/stdlib.lsp

;;; stdlib.lsp — standard library for uncommonlisp
;;; Load with: (load "stdlib.lsp")
;;; Automatically loaded by the interpreter if found next to uncommonlisp.py.

;;;; ── Syntax-rules versions of core macros ────────────────────────────────

(define-syntax my-let
  (syntax-rules ()
    ((my-let ((var val) ...) body ...)
     ((lambda (var ...) body ...) val ...))))

(define-syntax my-let*
  (syntax-rules ()
    ((my-let* () body ...)
     (begin body ...))
    ((my-let* ((var val) rest ...) body ...)
     (let ((var val)) (my-let* (rest ...) body ...)))))

(define-syntax my-and
  (syntax-rules ()
    ((my-and) #t)
    ((my-and e) e)
    ((my-and e1 e2 ...)
     (if e1 (my-and e2 ...) #f))))

(define-syntax my-or
  (syntax-rules ()
    ((my-or) #f)
    ((my-or e) e)
    ((my-or e1 e2 ...)
     (let ((t e1))
       (if t t (my-or e2 ...))))))

(define-syntax my-cond
  (syntax-rules (else =>)
    ((my-cond (else e ...)) (begin e ...))
    ((my-cond (test => f) rest ...)
     (let ((t test)) (if t (f t) (my-cond rest ...))))
    ((my-cond (test e ...) rest ...)
     (if test (begin e ...) (my-cond rest ...)))
    ((my-cond) (void))))

(define-syntax my-case
  (syntax-rules (else)
    ((my-case key (else e ...)) (begin e ...))
    ((my-case key ((datum ...) e ...) rest ...)
     (if (memv key '(datum ...))
         (begin e ...)
         (my-case key rest ...)))
    ((my-case key) (void))))

(define-syntax my-when
  (syntax-rules ()
    ((my-when test body ...)
     (if test (begin body ...) (void)))))

(define-syntax my-unless
  (syntax-rules ()
    ((my-unless test body ...)
     (if test (void) (begin body ...)))))

(define-syntax my-do
  (syntax-rules ()
    ((my-do ((var init step ...) ...)
            (test result ...)
            body ...)
     (let loop ((var init) ...)
       (if test
           (begin result ...)
           (begin body ...
                  (loop (if (null? '(step ...)) var (car '(step ...))) ...)))))))

;;;; ── Pattern-matched swap ────────────────────────────────────────────────

(define-syntax swap!
  (syntax-rules ()
    ((swap! a b)
     (let ((tmp a))
       (set! a b)
       (set! b tmp)))))

;;;; ── fluid-let ──────────────────────────────────────────────────────────

(define-syntax fluid-let
  (syntax-rules ()
    ((fluid-let ((var val) ...) body ...)
     (let ((old-var var) ...)
       (set! var val) ...
       (let ((result (begin body ...)))
         (set! var old-var) ...
         result)))))

;;;; ── receive (SRFI-8) ───────────────────────────────────────────────────

(define-syntax receive
  (syntax-rules ()
    ((receive formals expression body ...)
     (call-with-values (lambda () expression)
                       (lambda formals body ...)))))

;;;; ── begin0 ────────────────────────────────────────────────────────────

(define-syntax begin0
  (syntax-rules ()
    ((begin0 first rest ...)
     (let ((result first))
       rest ...
       result))))

;;;; ── while / until ──────────────────────────────────────────────────────

(define-syntax while
  (syntax-rules ()
    ((while test body ...)
     (let loop ()
       (when test body ... (loop))))))

(define-syntax until
  (syntax-rules ()
    ((until test body ...)
     (let loop ()
       (unless test body ... (loop))))))

;;;; ── dotimes / dolist ───────────────────────────────────────────────────

(define-syntax dotimes
  (syntax-rules ()
    ((dotimes (var n result ...) body ...)
     (let loop ((var 0))
       (if (= var n)
           (begin result ...)
           (begin body ... (loop (+ var 1))))))))

(define-syntax dolist
  (syntax-rules ()
    ((dolist (var lst result ...) body ...)
     (begin
       (for-each (lambda (var) body ...) lst)
       result ...))))

;;;; ── push! / pop! ───────────────────────────────────────────────────────

(define-syntax push!
  (syntax-rules ()
    ((push! val lst)
     (set! lst (cons val lst)))))

(define-syntax pop!
  (syntax-rules ()
    ((pop! lst)
     (let ((top (car lst)))
       (set! lst (cdr lst))
       top))))

;;;; ── and-let* (SRFI-2) ─────────────────────────────────────────────────

(define-syntax and-let*
  (syntax-rules ()
    ((and-let* () body ...)  (begin body ...))
    ((and-let* ((var expr) rest ...) body ...)
     (let ((var expr))
       (if var (and-let* (rest ...) body ...) #f)))
    ((and-let* ((expr) rest ...) body ...)
     (if expr (and-let* (rest ...) body ...) #f))))

;;;; ── string utilities ───────────────────────────────────────────────────

(define (string-repeat s n)
  (apply string-append (map (lambda (_) s) (iota n))))

(define (string-pad-left s len ch)
  (let ((pad (- len (string-length s))))
    (if (<= pad 0) s
        (string-append (make-string pad ch) s))))

(define (string-pad-right s len ch)
  (let ((pad (- len (string-length s))))
    (if (<= pad 0) s
        (string-append s (make-string pad ch)))))

(define (string->chars s) (string->list s))
(define (chars->string cs) (list->string cs))

;;;; ── list utilities ─────────────────────────────────────────────────────

(define (list-update! lst i val)
  (list-set! lst i val)
  lst)

(define (enumerate lst)
  (map list (iota (length lst)) lst))

(define (transpose lsts)
  (apply map list lsts))

(define (interleave lst sep)
  (if (or (null? lst) (null? (cdr lst)))
      lst
      (cons (car lst) (cons sep (interleave (cdr lst) sep)))))

(define (chunks lst n)
  (if (null? lst)
      '()
      (cons (take lst (min n (length lst)))
            (chunks (drop lst n) n))))

(define (repeat-list x n)
  (map (lambda (_) x) (iota n)))

(define (zip-with f . lsts)
  (apply map f lsts))

(define (sum lst)   (fold-left + 0 lst))
(define (product lst) (fold-left * 1 lst))
(define (maximum lst) (fold-left max (car lst) (cdr lst)))
(define (minimum lst) (fold-left min (car lst) (cdr lst)))
(define (average lst) (/ (sum lst) (length lst)))

;;;; ── numeric utilities ──────────────────────────────────────────────────

(define (clamp x lo hi) (max lo (min hi x)))
(define (between? x lo hi) (and (>= x lo) (<= x hi)))

(define (factorial n)
  (let loop ((i n) (acc 1))
    (if (<= i 1) acc (loop (- i 1) (* acc i)))))

(define (fib n)
  (let loop ((a 0) (b 1) (i 0))
    (if (= i n) a (loop b (+ a b) (+ i 1)))))

(define (prime? n)
  (if (< n 2) #f
      (let loop ((i 2))
        (cond ((> (* i i) n) #t)
              ((= (remainder n i) 0) #f)
              (else (loop (+ i 1)))))))

(define (primes-up-to n)
  (filter prime? (range 2 (+ n 1))))

;;;; ── I/O utilities ──────────────────────────────────────────────────────

(define (println . args)
  (for-each (lambda (x) (display x) (display " ")) args)
  (newline))

(define (print-table rows)
  (for-each (lambda (row)
              (for-each (lambda (cell) (display cell) (display "\t")) row)
              (newline))
            rows))

(define (with-output-string thunk)
  (with-output-to-string thunk))

;;;; ── association-list utilities ─────────────────────────────────────────

(define (alist-get key alist . default)
  (let ((pair (assoc key alist)))
    (if pair (cdr pair)
        (if (null? default) #f (car default)))))

(define (alist-set key val alist)
  (cons (cons key val)
        (filter (lambda (p) (not (equal? (car p) key))) alist)))

(define (alist-remove key alist)
  (filter (lambda (p) (not (equal? (car p) key))) alist))

(define (alist-keys alist) (map car alist))
(define (alist-values alist) (map cdr alist))

;;;; ── hash-table utilities ───────────────────────────────────────────────

(define (hash-table-map h f)
  (let ((result (make-hash-table)))
    (hash-table-walk h (lambda (k v) (hash-table-set! result k (f v))))
    result))

(define (hash-table-filter h pred)
  (let ((result (make-hash-table)))
    (hash-table-walk h (lambda (k v) (when (pred k v) (hash-table-set! result k v))))
    result))

(define (hash-table-from-lists keys vals)
  (let ((h (make-hash-table)))
    (for-each (lambda (k v) (hash-table-set! h k v)) keys vals)
    h))

;;;; ── tree utilities ─────────────────────────────────────────────────────

(define (tree-map f tree)
  (if (pair? tree)
      (cons (tree-map f (car tree)) (tree-map f (cdr tree)))
      (f tree)))

(define (tree-fold f init tree)
  (if (pair? tree)
      (tree-fold f (tree-fold f init (car tree)) (cdr tree))
      (f init tree)))

(define (tree-member? x tree)
  (cond ((null? tree) #f)
        ((equal? x tree) #t)
        ((pair? tree) (or (tree-member? x (car tree))
                          (tree-member? x (cdr tree))))
        (else #f)))

;;;; ── simple object system ───────────────────────────────────────────────
;;; (make-object methods-alist) → an object
;;; (send obj 'method arg...) → dispatch

(define (make-object methods)
  (lambda (msg . args)
    (let ((m (assoc msg methods)))
      (if m
          (apply (cdr m) args)
          (error "unknown method" msg)))))

(define (send obj msg . args)
  (apply obj msg args))

;;;; ── coroutine via call/cc ───────────────────────────────────────────────

(define (make-generator thunk)
  (let ((k #f) (done #f))
    (lambda ()
      (if done 'done
          (call/cc
            (lambda (return)
              (if k
                  (k return)
                  (begin
                    (thunk (lambda (val)
                             (call/cc (lambda (next)
                                        (set! k next)
                                        (return val)))))
                    (set! done #t)
                    (return 'done)))))))))