Programming Praxis

Scheme is a small language with limited libraries. This Standard Prelude provides several libraries used in Programming Praxis: list utilities, list comprehensions, pattern matching, structures, matrices, hash tables, dictionaries, input/output, strings, sorting, higher-order functions, math functions, bits, random numbers, control flow, date arithmetic,unit testing, and miscellaneous. This code should work directly in any R5RS Scheme. In R6RS Scheme, it will be useful to wrap the code using module system, based on local preference. The Standard Prelude changes from time to time, so check back often. The code is collected at http://programmingpraxis.codepad.org/hZnG9BCP.

List Utilities

Lists are ubiquitous in Scheme, so it is useful to have available a collection of utility functions that operate on lists.

Take returns a newly-allocated list containing the first n elements of the list xs; if xs has less than n elements, return all of them. Drop is the opposite of take, returning all elements of a list xs except the first n. Split combines take and drop:

(define (take n xs)
  (let loop ((n n) (xs xs) (ys '()))
    (if (or (zero? n) (null? xs))
        (reverse ys)
        (loop (- n 1) (cdr xs)
              (cons (car xs) ys)))))

(define (drop n xs)
  (let loop ((n n) (xs xs))
    (if (or (zero? n) (null? xs)) xs
      (loop (- n 1) (cdr xs)))))

(define (split n xs)
  (let loop ((n n) (xs xs) (zs '()))
    (if (or (zero? n) (null? xs))
        (values (reverse zs) xs)
        (loop (- n 1) (cdr xs) (cons (car xs) zs)))))

Take-while, drop-while, and split-while are similar to take, drop and split, but instead of counting elements, they operate on that prefix of the elements x of xs for which (pred? x) is non-#f:

(define (take-while pred? xs)
  (let loop ((xs xs) (ys '()))
    (if (or (null? xs) (not (pred? (car xs))))
        (reverse ys)
        (loop (cdr xs) (cons (car xs) ys)))))

(define (drop-while pred? xs)
  (let loop ((xs xs))
    (if (or (null? xs) (not (pred? (car xs)))) xs
      (loop (cdr xs)))))

(define (split-while pred? xs)
  (let loop ((xs xs) (ys '()))
    (if (or (null? xs) (not (pred? (car xs))))
        (values (reverse ys) xs)
        (loop (cdr xs) (cons (car xs) ys)))))

Cons* is similar to list, but handles the last pair differently; (list 1 2 3) forms the list (1 2 3 . ()), but (cons* 1 2 3) forms the list (1 2 . 3):

(define (cons* first . rest)
  (let loop ((curr first) (rest rest))
    (if (null? rest) curr
        (cons curr (loop (car rest) (cdr rest))))))

Folds use a user-specified function to reduce a list of values to a single value, and are one of the fundamental idioms of functional programming. Fold-left works left-to-right through the list xs, applying the binary op function to base and the first element of xs, then applying the binary op function to the result of the first op function and the second element of xs, and so on, at each step applying the binary op function to the result of the previous op function and the current element of xs; fold-right works the same way, but right-to-left.

(define (fold-left op base xs)
  (if (null? xs)
      base
      (fold-left op (op base (car xs)) (cdr xs))))

(define (fold-right op base xs)
  (if (null? xs)
      base
      (op (car xs) (fold-right op base (cdr xs)))))

The (range [first] past [step]) function takes three arguments and returns a list of numbers starting from first and ending before past, incrementing each number by step. If step is omitted, it defaults to 1 if first is less than past, and -1 otherwise; if first is also omitted, it defaults to 0. Arguments may be of any numeric type.

(define (range . args)
  (case (length args)
    ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
    ((2) (range (car args) (cadr args) (if (= <=)))
           (let loop ((x(car args)) (xs '()))
             (if (le? (cadr args) x)
                 (reverse xs)
                 (loop (+ x (caddr args)) (cons x xs))))))
    (else (error 'range "unrecognized arguments"))))

Mappend is like map, but assembles its pieces with append rather than cons. Iterate repeatedly evaluates a function f against the base values bs, after each iteration shifting the base values left by removing the first and appending the newly-calculated value at the end, returning the first n results in a list:

(define (mappend f . xss) (apply append (apply map f xss)))

(define (iterate n f . bs)
  (let loop ((n n) (b (car bs)) (bs (cdr bs)) (xs '()))
    (if (zero? n) (reverse xs)
      (let ((new-bs (append bs (list (apply f b bs)))))
        (loop (- n 1) (car new-bs) (cdr new-bs) (cons b xs))))))

For instance, (define (fib n) (iterate n + 1 1)) defines a function that calculates the first n fibonacci numbers

The (filter pred? xs) function returns a newly-allocated list that contains only those elements x of xs for which (pred? x) is true. The (remove x xs) function removes all occurrences of x from the list xs, using equal? to make comparisons:

(define (filter pred? xs)
  (let loop ((xs xs) (ys '()))
    (cond ((null? xs) (reverse ys))
          ((pred? (car xs))
            (loop (cdr xs) (cons (car xs) ys)))
          (else (loop (cdr xs) ys)))))

(define (remove x xs)
  (let loop ((xs xs) (zs '()))
    (cond ((null? xs) (reverse zs))
          ((equal? (car xs) x) (loop (cdr xs) zs))
          (else (loop (cdr xs) (cons (car xs) zs))))))

Flatten takes a tree represented as a list with sub-lists and returns a list containing only the fringe elements of the tree. The two trees (a (b c)) and ((a b) c) both cause flatten to return (a b c):

(define (flatten xs)
  (cond ((null? xs) xs)
        ((pair? xs)
          (append (flatten (car xs))
                  (flatten (cdr xs))))
        (else (list xs))))

All? and any? apply a predicate to each member of a list. All? returns #t if (pred? x) is non-#f for every x in the input list, or #f otherwise. Any? returns #f if (pred? x) is #f for every x in the input list, or #t otherwise. Both functions stop applying the predicate to elements of the input as list as soon as possible.

(define (all? pred? xs)
  (cond ((null? xs) #t)
        ((pred? (car xs))
          (all? pred? (cdr xs)))
        (else #f)))

(define (any? pred? xs)
  (cond ((null? xs) #f)
        ((pred? (car xs)) #t)
        (else (any? pred? (cdr xs)))))

Zip converts multiple lists into a list of lists:

(define (zip . xss) (apply map list xss))

Cross produces the cross product of one or more lists. The implementation is a functional pearl due to Christoper Strachey, collected by Mike Spivey:

(define (cross . xss)
  (define (f xs yss)
    (define (g x zss)
      (define (h ys uss)
        (cons (cons x ys) uss))
      (fold-right h zss yss))
    (fold-right g '() xs))
  (fold-right f (list '()) xss))

The (make-list n x) function returns a newly-allocated list containing n copies of x:

(define (make-list n x)
  (let loop ((n n) (xs '()))
    (if (zero? n) xs
      (loop (- n 1) (cons x xs)))))

It is frequently useful to calculate the sum of a list:

(define (sum xs) (apply + xs))

Maximum-by is like the built-in function max, except that it takes a lt? comparison function as its first argument before the items to be compared:

(define (maximum-by lt? . xs)
  (let loop ((xs (cdr xs)) (current-max (car xs)))
    (cond ((null? xs) current-max)
          ((lt? current-max (car xs))
            (loop (cdr xs) (car xs)))
          (else (loop (cdr xs) current-max)))))

List Comprehensions

List comprehensions join the higher-order idioms map, filter and fold into a highly useful form of syntactic sugar for performing looping computations involving lists. The Standard Prelude provides three types of list comprehension:

• (list-of expr clause ...) produces a possibly-null list of objects of the type returned by expr
• (sum-of expr clause ...) computes the sum of the elements computed by expr
• (fold-of op base expr clause ...) is like sum-of, but with a user-defined operator and base in place of the + and 0 of sum-of

Clauses may be of four types:

• (var range [first] past [step]) — Bind var to first, first + step, ..., until reaching past, which is not included in the output. If first is not given it defaults to 0. If step is not given, it defaults to 1 if (< first past) and -1 otherwise. First, past and step may be of any numeric type; if any of first, past or step are inexact, the length of the output list may differ from (ceiling (- (/ (- past first) step) 1).
• (var in list-expr) — Loop over the elements of list-expr, in order from the start of the list, binding each element of the list in turn to var.
• (var is expr) — Bind var to the value obtained by evaluating expr.
• (pred? expr) — Include in the output list only those elements x for which (pred? x) is non-#f.

The scope of variables bound in the list comprehension is the clauses to the right of the binding clause (but not the binding clause itself) plus the result expression. When two or more generators are present, the loops are processed as if they are nested from left to right; that is, the rightmost generator varies fastest. As a degenerate case, if no generators are present, the result of a list comprehension is a list containing the result expression; thus, (list-of 1) produces a list containing only the element 1.

List comprehensions are expanded by a macro that calls itself recursively, one level of recursion for each clause plus a final level of recursion for the base case. The complete implementation, which is based on the set constructor in Kent Dybvig’s book The Scheme Programming Language, is given below:

(define-syntax fold-of
  (syntax-rules (range in is)
    ((_ "z" f b e) (set! b (f b e)))
    ((_ "z" f b e (v range fst pst stp) c ...)
      (let* ((x fst) (p pst) (s stp)
             (le? (if (positive? s) =)))
        (do ((v x (+ v s))) ((le? p v) b)
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (v range fst pst) c ...)
      (let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
        (fold-of "z" f b e (v range x p s) c ...)))
    ((_ "z" f b e (v range pst) c ...)
      (fold-of "z" f b e (v range 0 pst) c ...))
    ((_ "z" f b e (x in xs) c ...)
      (do ((t xs (cdr t))) ((null? t) b)
        (let ((x (car t)))
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (x is y) c ...)
      (let ((x y)) (fold-of "z" f b e c ...)))
    ((_ "z" f b e p? c ...)
      (if p? (fold-of "z" f b e c ...)))
    ((_ f i e c ...)
      (let ((b i)) (fold-of "z" f b e c ...)))))

(define-syntax list-of (syntax-rules ()
  ((_ arg ...) (reverse (fold-of
    (lambda (d a) (cons a d)) '() arg ...)))))

(define-syntax sum-of (syntax-rules ()
  ((_ arg ...) (fold-of + 0 arg ...))))

The list comprehensions given here extend the usual notion of list comprehensions with the fold-of comprehension. Another extension is nth-of, which expands a list comprehension and returns the nth item:

(define-syntax nth-of
  (syntax-rules ()
    ((_ n expr clause ...)
      (let ((nth n))
        (call-with-current-continuation
          (lambda (return)
            (fold-of
              (lambda (fst snd)
                (if (zero? nth) (return snd)
                  (begin (set! nth (- nth 1)) snd)))
              #f expr clause ...)))))))

Pattern Matching

Pattern matching provides syntactic sugar to destructure lists, select alternatives, and bind variables, and is provided by the list-match macro. The syntax (list-match expr clause ...) takes an input expr that evaluates to a list. Clauses are of the form (pattern [fender] expr), consisting of a pattern that matches a list of a particular shape, an optional fender that must succeed if the pattern is to match, and an expr that is evaluated if the pattern matches. There are four types of patterns:

• () — Matches the null list.
• (pat₀ pat₁ ...) — Matches a list with length exactly equal to the number of pattern elements.
• (pat₀ pat₁ ... . pat_Rest) — Matches a list with length at least as great as the number of pattern elements before the literal dot. Pat_Rest is a list containing the remaining elements of the input list after the initial prefix of the list before the literal dot.
• pat — Matches an entire list. Should always appear as the last clause; it’s not an error to appear elsewhere, but subsequent clauses could never match.

Each pattern element may be:

• An identifier — Matches any list element. Additionally, the value of the list element is bound to the variable named by the identifier, which is in scope in the fender and expr of the corresponding clause. Each identifier in a single pattern must be unique.
• A literal underscore — Matches any list element, but creates no bindings.
• A constant — Matches if the expression equals the constant value, but creates no bindings.
• A quote expression — Matches if the expression equals the quote expression, but creates no bindings.
• A quasiquote expression — Matches if the expression equals the quasiquote expression, but creates no bindings.

All comparisons are made with equal?. The patterns are tested in order, left to right, until a matching pattern is found; if fender is present, it must evaluate as non-#f for the match to be successful. Pattern variables are bound in the corresponding fender and expression. Once the matching pattern is found, the corresponding expression is evaluated and returned as the result of the match. An error is signaled if no pattern matches the input list.

Pattern matching is performed by a macro that expands into a cond expression with one clause per pattern; an auxiliary macro handles the various types of pattern elements. The complete implementation, which is based on an idea of Jos Koot, is given below:

(define-syntax list-match
  (syntax-rules ()
    ((_ expr (pattern fender ... template) ...)
      (let ((obj expr))
        (cond ((list-match-aux obj pattern fender ...
                (list template)) => car) ...
              (else (error 'list-match "pattern failure")))))))

(define-syntax list-match-aux
  (lambda (stx)
    (define (underscore? x)
      (and (identifier? x) (free-identifier=? x (syntax _))))
    (syntax-case stx (quote quasiquote)
      ((_ obj pattern template)
        (syntax (list-match-aux obj pattern #t template)))
      ((_ obj () fender template)
        (syntax (and (null? obj) fender template)))
      ((_ obj underscore fender template)
        (underscore? (syntax underscore))
        (syntax (and fender template)))
      ((_ obj var fender template)
        (identifier? (syntax var))
        (syntax (let ((var obj)) (and fender template))))
      ((_ obj (quote datum) fender template)
        (syntax (and (equal? obj (quote datum)) fender template)))
      ((_ obj (quasiquote datum) fender template)
        (syntax (and (equal? obj (quasiquote datum)) fender template)))
      ((_ obj (kar . kdr) fender template)
        (syntax (and (pair? obj)
                (let ((kar-obj (car obj)) (kdr-obj (cdr obj)))
                  (list-match-aux kar-obj kar
                        (list-match-aux kdr-obj kdr fender template))))))
      ((_ obj const fender template)
        (syntax (and (equal? obj const) fender template))))))

Structures

R5RS Scheme does not provide any way to create new variable types or to combine multiple variables into a single unit; R6RS provides structures that perform these tasks. The structures given below are upward-compatible to R6RS structures. Calling (define-structure name field ...) creates a new structure. Define-structure expands into a constructor (make-name field ...), a type predicate (name? obj), and an accessor (name-field x) and setter (set-name-field! x value) for an object x of structure type name.

(define-syntax (define-structure x)
  (define (gen-id template-id . args)
    (datum->syntax-object template-id
      (string->symbol
        (apply string-append
               (map (lambda (x)
                      (if (string? x) x
                        (symbol->string
                            (syntax-object->datum x))))
                    args)))))
  (syntax-case x ()
    ((_ name field ...)
     (with-syntax
       ((constructor (gen-id (syntax name) "make-" (syntax name)))
        (predicate (gen-id (syntax name) (syntax name) "?"))
        ((access ...)
          (map (lambda (x) (gen-id x (syntax name) "-" x))
               (syntax (field ...))))
        ((assign ...)
          (map (lambda (x) (gen-id x "set-" (syntax name) "-" x "!"))
               (syntax (field ...))))
        (structure-length (+ (length (syntax (field ...))) 1))
        ((index ...) (let f ((i 1) (ids (syntax (field ...))))
                       (if (null? ids) '()
                         (cons i (f (+ i 1) (cdr ids)))))))
    (syntax (begin
              (define (constructor field ...)
                (vector 'name field ...))
              (define (predicate x)
                (and (vector? x)
                     (= (vector-length x) structure-length)
                     (eq? (vector-ref x 0) 'name)))
              (define (access x) (vector-ref x index)) ...
              (define (assign x update) (vector-set! x index update))
              ...))))))

Matrices

Scheme provides one-dimensional arrays, which it calls vectors, but no two-dimensional arrays. Kent Dybvig provides a matrix data structure defined as a vector of vectors in The Scheme Programming Language:

(define (make-matrix rows columns . value)
  (do ((m (make-vector rows)) (i 0 (+ i 1)))
      ((= i rows) m)
    (if (null? value)
        (vector-set! m i (make-vector columns))
        (vector-set! m i (make-vector columns (car value))))))

(define (matrix-rows x) (vector-length x))

(define (matrix-cols x) (vector-length (vector-ref x 0)))

(define (matrix-ref m i j) (vector-ref (vector-ref m i) j))

(define (matrix-set! m i j x) (vector-set! (vector-ref m i) j x))

The for macro is convenient for iterating over the rows and columns of a matrix. The syntax (for (var [first] past [step]) body ...) binds var to first, then iterates var by step until it reaches past, which is not bound; the body statements are executed only for their side-effects. Step defaults to 1 if first is less than past and -1 otherwise; if first is also not given, it defaults to 0:

(define-syntax for
  (syntax-rules ()
    ((for (var first past step) body ...)
      (let ((ge? (if (= <=)))
        (do ((var first (+ var step)))
            ((ge? var past))
          body ...)))
    ((for (var first past) body ...)
      (let* ((f first) (p past) (s (if (< first past) 1 -1)))
        (for (var f p s) body ...)))
    ((for (var past) body ...)
      (let* ((p past)) (for (var 0 p) body ...)))))

Hash Tables

Hash tables are one of the greatest inventions of computer science, permitting very fast retrieval of key/value pairs.

Make-hash creates an instance of an abstract data type of hash tables. Make-hash takes four arguments: Hash is a function that takes a key and returns an integer that provides an address for the bucket where the key/value pair is stored. Eql? is a predicate that takes two keys and returns #t if they are the same and #f otherwise. Oops is the default value returned by the hash table if a requested key is not present in the table. Size is the number of buckets where key/value pairs are stored; it is best to choose size as a prime number of magnitude similar to the expected number of key/value pairs. Make-hash returns a function that, when called with an appropriate message, performs the requested action; for a hash table created by

(define state-tab (make-hash string-hash string=? #f 4093))

the appropriate call is

(state-tab 'message args ...)

where message and args can be any of the following:

• insert key value— inserts a key/value pair in the hash table, overwriting any previous value associated with the key
• lookup key — retrieves the value associated with key
• delete key — removes key and its associated value from the hash table, if it exists
• update key proc default — proc is a function that takes a key and value as arguments and returns a new value; if key is present in the hash table, update calls proc with the key and its associated value and stores the value returned by proc in place of the original value, otherwise update inserts a new key/value pair in the hash table with key key> and value default.
• enlist — returns all the key/value pairs in the hash table as a list

Synonyms are provided for some of the messages; see the source code for details.

(define (make-hash hash eql? oops size)
  (let ((table (make-vector size '())))
    (lambda (message . args)
      (if (eq? message 'enlist)
          (let loop ((k 0) (result '()))
            (if (= size k)
                result
                (loop (+ k 1) (append (vector-ref table k) result))))
          (let* ((key (car args))
                 (index (modulo (hash key) size))
                 (bucket (vector-ref table index)))
            (case message
              ((lookup fetch get ref recall)
                (let loop ((bucket bucket))
                  (cond ((null? bucket) oops)
                        ((eql? (caar bucket) key) (cdar bucket))
                        (else (loop (cdr bucket))))))
              ((insert insert! ins ins! set set! store store! install install!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (cadr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key (cadr args)) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((delete delete! del del! remove remove!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket) '())
                          ((eql? (caar bucket) key)
                            (cdr bucket))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((update update!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (caddr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key ((cadr args) key (cdar bucket))) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              (else (error 'hash-table "unrecognized message")) ))))))

The most common data type used for hash-table keys is character strings, for which we provide this hash function:

(define (string-hash str)
  (let loop ((cs (string->list str)) (s 0))
    (if (null? cs) s
      (loop (cdr cs) (+ (* s 31)
        (char->integer (car cs)))))))

The list->hash function returns a newly-allocated hash table containing each of the key/value pairs in the input list, where the key is the car of the item and the value is the cdr of the item:

hash”>(define (list->hash hash eql? oops size xs)
  (let ((table (make-hash hash eql? oops size)))
    (do ((xs xs (cdr xs))) ((null? xs) table)
      (table 'insert (caar xs) (cdar xs)))))

Dictionaries

Make-dict provides the abstract data type of an ordered map, sometimes called a dictionary. Unlike hash tables that only take an equality predicate, the dictionary takes a less-than predicate lt? so that it can iterate over its key/value pairs in order. The dictionary also provides order statistics, so you can select the nth key/value pair in order or find the ordinal rank of a given key. The implementation uses avl trees, so any access to a particular key/value pair takes time O(log n). A dictionary is created by:

(make-dict lt?) — returns a newly-allocated, empty dictionary that obeys the less-than lt? ordering predicate

A dictionary is represented by a function, and once it has been created, say by (define dict (make-dict string<?)), operators are applied in message-passing style, such as (dict 'message args ...) where messageand args can be any of the following:

• empty? — returns #t if the dictionary is empty, else #f [nil?]
• lookup key ‐ returns a (key . value) pair corresponding to key, or #f if key is not present in the dictionary [fetch, get]
• insert key value — returns a newly-allocated dictionary that includes all the key/value pairs in the input dictionary plus the input key and value, which replaces any existing key/value pair with a matching key; duplicate keys are not permitted [store, put]
• update proc key value) — returns a newly-allocated dictionary; if key is already present in the dictionary, the value associated with the key is replaced by (proc k v), where k and v are the existing key and value; otherwise, the input key/value pair is added to the dictionary
• delete key — returns a newly-allocated dictionary in which key is not present, whether or not it is already present [remove]
• size — returns the number of key/value pairs in the dictionary [count, length]
• nth n — returns the nth key/value pair in the dictionary, counting from zero
• rank key — returns the ordinal position of key in the dictionary, counting from zero
• map proc) — returns a newly-allocated dictionary in which each value is replaced by (proc k v), where k and v are the existing key and value
• fold proc base &mdsah; returns the value accumulated by applying the function (proc k v b) to each key/value pair in the dictionary, accumulating the value of the base b at each step; pairs are accessed in order of ascending keys
• for-each proc — evaluates for its side-effects only (proc k v) for each key/value pair in the dictionary in ascending order
• to-list — returns a newly-allocated list of all the (key . value) pairs in the dictionary, in ascending order [enlist]
• from-list xs — returns a newly-allocated dictionary that includes all the key/value pairs in the original dictionary plus all the (key . value) pairs in xs; any key in xs that already exists in the dictionary has its value replaced by the corresponding value in xs
• make-gen — returns a function that, each time it is called, returns the next (key . value) pair from the dictionary, in ascending order; when the key/value pairs in the dictionary are exhausted, the function returns #f each time it is called [gen]

Synonyms are provided for some of the operations, as given in square brackets above.

(define (make-dict lt?)

  (define-syntax define-generator
    (lambda (x)
      (syntax-case x (lambda)
        ((stx name (lambda formals e0 e1 ...))
           (with-syntax ((yield (datum->syntax-object (syntax stx) 'yield)))
             (syntax (define name
               (lambda formals
                 (let ((resume #f) (return #f))
                   (define yield
                     (lambda args
                       (call-with-current-continuation
                        (lambda (cont)
                          (set! resume cont)
                          (apply return args)))))
                   (lambda ()
                     (call-with-current-continuation
                      (lambda (cont)
                        (set! return cont)
                        (cond (resume (resume))
                        (else (let () e0 e1 ...)
                              (error 'name "unexpected return"))))))))))))
          ((stx (name . formals) e0 e1 ...)
            (syntax (stx name (lambda formals e0 e1 ...)))))))

  (define (tree k v l r)
    (vector k v l r (+ (max (ht l) (ht r)) 1)
                    (+ (size l) (size r) 1)))
  (define (key t) (vector-ref t 0))
  (define (val t) (vector-ref t 1))
  (define (lkid t) (vector-ref t 2))
  (define (rkid t) (vector-ref t 3))
  (define (ht t) (vector-ref t 4))
  (define (size t) (vector-ref t 5))
  (define (bal t) (- (ht (lkid t)) (ht (rkid t))))
  (define nil (vector 'nil 'nil 'nil 'nil 0 0))
  (define (nil? t) (eq? t nil))

  (define (rot-left t)
    (if (nil? t) t
      (tree (key (rkid t))
            (val (rkid t))
            (tree (key t) (val t) (lkid t) (lkid (rkid t)))
            (rkid (rkid t)))))

  (define (rot-right t)
    (if (nil? t) t
      (tree (key (lkid t))
            (val (lkid t))
            (lkid (lkid t))
            (tree (key t) (val t) (rkid (lkid t)) (rkid t)))))

  (define (balance t)
    (let ((b (bal t)))
      (cond ((< (abs b) 2) t)
            ((positive? b)
              (if (< -1 (bal (lkid t))) (rot-right t)
                (rot-right (tree (key t) (val t)
                  (rot-left (lkid t)) (rkid t)))))
            ((negative? b)
              (if (< (bal (rkid t)) 1) (rot-left t)
                (rot-left (tree (key t) (val t)
                  (lkid t) (rot-right (rkid t)))))))))

  (define (lookup t k)
    (cond ((nil? t) #f)
          ((lt? k (key t)) (lookup (lkid t) k))
          ((lt? (key t) k) (lookup (rkid t) k))
          (else (cons k (val t)))))

  (define (insert t k v)
    (cond ((nil? t) (tree k v nil nil))
          ((lt? k (key t))
            (balance (tree (key t) (val t)
              (insert (lkid t) k v) (rkid t))))
          ((lt? (key t) k)
            (balance (tree (key t) (val t)
              (lkid t) (insert (rkid t) k v))))
          (else (tree k v (lkid t) (rkid t)))))

  (define (update t f k v)
    (cond ((nil? t) (tree k v nil nil))
          ((lt? k (key t))
            (balance (tree (key t) (val t)
              (update (lkid t) f k v) (rkid t))))
          ((lt? (key t) k)
            (balance (tree (key t) (val t)
              (lkid t) (update (rkid t) f k v))))
          (else (tree k (f k (val t)) (lkid t) (rkid t)))))

  (define (delete-successor t)
    (if (nil? (lkid t)) (values (rkid t) (key t) (val t))
      (call-with-values
        (lambda () (delete-successor (lkid t)))
        (lambda (l k v)
          (values (balance (tree (key t) (val t) l (rkid t))) k v)))))

  (define (delete t k)
    (cond ((nil? t) nil)
          ((lt? k (key t))
            (balance (tree (key t) (val t)
              (delete (lkid t) k) (rkid t))))
          ((lt? (key t) k)
            (balance (tree (key t) (val t)
              (lkid t) (delete (rkid t) k))))
          ((nil? (lkid t)) (rkid t))
          ((nil? (rkid t)) (lkid t))
          (else (call-with-values
                  (lambda () (delete-successor (rkid t)))
                  (lambda (r k v) (balance (tree k v (lkid t) r)))))))

  (define (nth t n)
    (if (negative? n) (error 'nth "must be non-negative")
      (let ((s (size (lkid t))))
        (cond ((< n s) (nth (lkid t) n))
              ((< s n) (nth (rkid t) (- n s 1)))
              ((nil? t) #f)
              (else (cons (key t) (val t)))))))

  (define (rank t k)
    (let loop ((t t) (s (size (lkid t))))
      (cond ((nil? t) #f)
            ((lt? k (key t))
              (loop (lkid t) (- s (size (rkid (lkid t))) 1)))
            ((lt? (key t) k)
              (loop (rkid t) (+ s (size (lkid (rkid t))) 1)))
            (else s))))

  (define (avl-map proc t) ; (proc key value)
    (if (nil? t) nil
      (tree (key t) (proc (key t) (val t))
            (avl-map proc (lkid t))
            (avl-map proc (rkid t)))))

  (define (avl-fold proc base t) ; (proc key value base)
    (if (nil? t) base
      (avl-fold proc
                (proc (key t) (val t)
                      (avl-fold proc base (lkid t)))
                (rkid t))))

  (define (avl-for-each proc t) ; (proc key value)
    (unless (nil? t)
      (avl-for-each proc (lkid t))
      (proc (key t) (val t))
      (avl-for-each proc (rkid t))))

  (define (to-list t)
    (cond ((nil? t) (list))
          ((and (nil? (lkid t)) (nil? (rkid t)))
            (list (cons (key t) (val t))))
          (else (append (to-list (lkid t))
                        (list (cons (key t) (val t)))
                        (to-list (rkid t))))))

  (define (from-list t xs)
    (let loop ((xs xs) (t t))
      (if (null? xs) t
        (loop (cdr xs) (insert t (caar xs) (cdar xs))))))

  (define-generator (make-gen t)
    (avl-for-each (lambda (k v) (yield (cons k v))) t)
    (do () (#f) (yield #f)))

  (define (new dict)
    (lambda (message . args) (dispatch dict message args)))

  (define (dispatch dict message args)
    (define (arity n)
      (if (not (= (length args) n)) (error 'dict "incorrect arity")))
    (case message
      ((empty? nil?) (arity 0) (nil? dict))
      ((lookup fetch get) (arity 1) (apply lookup dict args))
      ((insert store put) (arity 2) (new (apply insert dict args)))
      ((update) (arity 3) (new (apply update dict args)))
      ((delete remove) (arity 1) (new (apply delete dict args)))
      ((size count length) (arity 0) (size dict))
      ((nth) (arity 1) (apply nth dict args))
      ((rank) (arity 1) (apply rank dict args))
      ((map) (arity 1) (new (avl-map (car args) dict)))
      ((fold) (arity 2) (avl-fold (car args) (cadr args) dict))
      ((for-each) (arity 1) (avl-for-each (car args) dict))
      ((to-list enlist) (arity 0) (to-list dict))
      ((from-list) (arity 1) (new (apply from-list dict args)))
      ((make-gen gen) (arity 0) (make-gen dict))
      (else (error 'dict "invalid message"))))

  (vector-set! nil 2 nil) (vector-set! nil 3 nil) (new nil))

Input/Output

Read-file returns a list of the characters in a file:

(define (read-file file-name)
  (with-input-from-file file-name (lambda ()
    (let loop ((c (read-char)) (cs '()))
      (if (eof-object? c) (reverse cs)
        (loop (read-char) (cons c cs)))))))

The three input processors for-each-input, map-input and fold-input operate on an input file or port in a manner similar to the way for-each, map and fold-left operate on lists. All three take an optional final argument. If the final argument is missing, input is taken from the current input port; as a side effect, all characters on the port are exhausted. If the final argument is a port, input is taken from the port, which is left open when the function returns; as a side effect, all characters on the port are exhausted. If the final argument is a string, it is taken as the name of a file which is opened, used as the source of input, and closed before the function returns. For all three functions, reader is a function that returns the next item from the input, and proc is a function that operates on each item.

(define (for-each-input reader proc . pof)
  (let* ((f? (and (pair? pof) (string? (car pof))))
         (p (cond (f? (open-input-file (car pof)))
                  ((pair? pof) (car pof))
                  (else (current-input-port)))))
    (do ((item (reader p) (reader p)))
        ((eof-object? item)
          (if f? (close-input-port p)))
      (proc item))))

(define (map-input reader proc . pof)
  (let* ((f? (and (pair? pof) (string? (car pof))))
         (p (cond (f? (open-input-file (car pof)))
                  ((pair? pof) (car pof))
                  (else (current-input-port)))))
    (let loop ((item (reader p)) (result '()))
      (if (eof-object? item)
          (begin (if f? (close-input-port p)) (reverse result))
          (loop (reader p) (cons (proc item) result))))))

(define (fold-input reader proc base . pof)
  (let* ((f? (and (pair? pof) (string? (car pof))))
         (p (cond (f? (open-input-file (car pof)))
                  ((pair? pof) (car pof))
                  (else (current-input-port)))))
    (let loop ((item (reader p)) (base base))
      (if (eof-object? item)
          (begin (if f? (close-input-port p)) base)
          (loop (reader p) (proc base item))))))

Read-line reads the next line of text from a named port or, if none is given, from the current input port. A line is a maximal sequence of characters terminated by a newline, a carriage return, or both characters in either order; the final line in a file need not be terminated.

(define (read-line . port)
  (define (eat p c)
    (if (and (not (eof-object? (peek-char p)))
             (char=? (peek-char p) c))
        (read-char p)))
  (let ((p (if (null? port) (current-input-port) (car port))))
    (let loop ((c (read-char p)) (line '()))
      (cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
            ((char=? #\newline c) (eat p #\return) (list->string (reverse line)))
            ((char=? #\return c) (eat p #\newline) (list->string (reverse line)))
            (else (loop (read-char p) (cons c line)))))))

Filter-input is a combinator that takes a reader function and a predicate and returns a new reader function that only passes input items x for which (pred? x) is non-#f.

(define (filter-input reader pred?)
  (lambda args
    (let loop ((item (apply reader args)))
      (if (or (eof-object? item) (pred? item)) item
        (loop (apply reader args))))))

Strings

(String-index c str) returns the zero-based index of the first occurrence of c in str, or #f if c does not appear in str:

(define (string-index c str)
  (let loop ((ss (string->list str)) (k 0))
    (cond ((null? ss) #f)
          ((char=? (car ss) c) k)
          (else (loop (cdr ss) (+ k 1))))))

Case conversions are handled by string-downcase and string-upcase:

(define (string-downcase str)
  (list->string
    (map char-downcase
      (string->list str))))

(define (string-upcase str)
  (list->string
    (map char-upcase
      (string->list str))))

String-split takes a separator character and a string and returns a list of sub-strings bounded by the separator character. String-join is the inverse.

(define (string-split sep str)
  (define (f cs xs) (cons (list->string (reverse cs)) xs))
  (let loop ((ss (string->list str)) (cs '()) (xs '()))
    (cond ((null? ss) (reverse (if (null? cs) xs (f cs xs))))
          ((char=? (car ss) sep) (loop (cdr ss) '() (f cs xs)))
          (else (loop (cdr ss) (cons (car ss) cs) xs)))))

(define (string-join sep ss)
  (define (f s ss)
    (string-append s (string sep) ss))
  (define (join ss)
    (if (null? (cdr ss)) (car ss)
      (f (car ss) (join (cdr ss)))))
  (if (null? ss) "" (join ss)))

String-find returns the starting position of a pattern in a string, or #f if the string does not contain the pattern; it uses the Knuth-Morris-Pratt string search algorithm:

(define (string-find pat str . s)
  (let* ((plen (string-length pat))
         (slen (string-length str))
         (skip (make-vector plen 0)))
    (let loop ((i 1) (j 0))
      (cond ((= i plen))
            ((char=? (string-ref pat i) (string-ref pat j))
              (vector-set! skip i (+ j 1))
              (loop (+ i 1) (+ j 1)))
            ((< 0 j) (loop i (vector-ref skip (- j 1))))
            (else (vector-set! skip i 0)
                  (loop (+ i 1) j))))
    (let loop ((p 0) (s (if (null? s) 0 (car s))))
      (cond ((= s slen) #f)
            ((char=? (string-ref pat p) (string-ref str s))
              (if (= p (- plen 1))
                  (- s plen -1)
                  (loop (+ p 1) (+ s 1))))
            ((< 0 p) (loop (vector-ref skip (- p 1)) s))
            (else (loop p (+ s 1)))))))

Sorting

Most Scheme systems provide a sort function, and it is required in R6RS. For those that don’t, we provide this sort, which is stolen from Kent Dybvig’s book The Scheme Programming Language; it is stable, applicative, miserly about garbage generation, and fast, and it also provides a merge function. Lt? is a predicate that takes two elements of xs and returns #t if the first precedes the second and #f otherwise:

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

Like its unix counterpart, unique returns its input list with adjacent duplicates removed. Uniq-c returns its input list paired with a count of adjacent duplicates, just like unix uniq with the -c flag.

(define (unique eql? xs)
  (cond ((null? xs) '())
        ((null? (cdr xs)) xs)
        ((eql? (car xs) (cadr xs))
          (unique eql? (cdr xs)))
        (else (cons (car xs) (unique eql? (cdr xs))))))

(define (uniq-c eql? xs)
  (if (null? xs) xs
    (let loop ((xs (cdr xs)) (prev (car xs)) (k 1) (result '()))
      (cond ((null? xs) (reverse (cons (cons prev k) result)))
            ((eql? (car xs) prev) (loop (cdr xs) prev (+ k 1) result))
            (else (loop (cdr xs) (car xs) 1 (cons (cons prev k) result)))))))

Vectors are sorted with the Bentley/McIlroy quicksort. The comparison function (cmp a b) returns an integer that is less than, equal to, or greater than zero when its first argument is less than, equal to, or greater than its second.

(define (vector-sort! vec comp)
  (define-syntax while
    (syntax-rules ()
      ((while pred? body ...)
        (do () ((not pred?)) body ...))))
  (define-syntax assign!
    (syntax-rules ()
      ((assign! var expr)
        (begin (set! var expr) var))))

  (define len (vector-length vec))
  (define-syntax v (syntax-rules () ((v k) (vector-ref vec k))))
  (define-syntax v! (syntax-rules () ((v! k x) (vector-set! vec k x))))
  (define-syntax cmp (syntax-rules () ((cmp a b) (comp (v a) (v b)))))
  (define-syntax lt? (syntax-rules () ((lt? a b) (negative? (cmp a b)))))
  (define-syntax swap! (syntax-rules () ((swap! a b)
    (let ((t (v a))) (v! a (v b)) (v! b t)))))
  (define (vecswap! a b s)
    (do ((a a (+ a 1)) (b b (+ b 1)) (s s (- s 1))) ((zero? s))
      (swap! a b)))

  (define (med3 a b c)
    (if (lt? b c)
        (if (lt? b a) (if (lt? c a) c a) b)
        (if (lt? c a) (if (lt? b a) b a) c)))
  (define (pv-init a n)
    (let ((pm (+ a (quotient n 2))))
      (when (> n 7)
        (let ((pl a) (pn (+ a n -1)))
          (when (> n 40)
            (let ((s (quotient n 8)))
              (set! pl (med3 pl (+ pl s) (+ pl s s)))
              (set! pm (med3 (- pm s) pm (+ pm s)))
              (set! pn (med3 (- pn s s) (- pn s) pn))))
          (set! pm (med3 pl pm pn))))
      pm))

  (let qsort ((a 0) (n len))
    (if (< n 7)
        (do ((pm (+ a 1) (+ pm 1))) ((not ( pl a) (> (cmp (- pl 1) pl) 0))))
            (swap! pl (- pl 1))))
        (let ((pv (pv-init a n)) (r #f)
              (pa a) (pb a) (pc (+ a n -1)) (pd (+ a n -1)))
          (swap! a pv) (set! pv a)
          (let loop ()
            (while (and (<= pb pc) (= pc pb) (>= (assign! r (cmp pc pv)) 0))
              (when (= r 0) (swap! pc pd) (set! pd (- pd 1)))
              (set! pc (- pc 1)))
            (unless (> pb pc)
              (swap! pb pc) (set! pb (+ pb 1)) (set! pc (- pc 1)) (loop)))
          (let ((pn (+ a n)))
            (let ((s (min (- pa a) (- pb pa)))) (vecswap! a (- pb s) s))
            (let ((s (min (- pd pc) (- pn pd 1)))) (vecswap! pb (- pn s) s))
            (let ((s (- pb pa))) (when (> s 1) (qsort a s)))
            (let ((s (- pd pc))) (when (> s 1) (qsort (- pn s) s))))))))

Higher-Order Functions

Identity returns it only argument and constant returns a function that, when called, always returns the same value regardless of its argument. Both functions are useful as recursive bases when writing higher-order functions.

(define (identity x) x)

(define (constant x) (lambda ys x))

Fst returns it first argument and snd returns its second argument; both functions occasionally find use when composing strings of functions:

(define (fst x y) x)

(define (snd x y) y)

Function composition creates a new function by partially applying multiple functions, one after the other. In the simplest case, there are only two functions, f and g, composed as ((compose f g) x) ≡ (f (g x)); the composition can be bound to create a new function, as in (define fg (compose f g)). Compose takes one or more procedures and returns a new procedure that performs the same action as the individual procedures would if called in succession.

(define (compose . fns)
  (let comp ((fns fns))
    (cond
      ((null? fns) 'error)
      ((null? (cdr fns)) (car fns))
      (else
        (lambda args
          (call-with-values
            (lambda ()
              (apply
                (comp (cdr fns))
                args))
            (car fns)))))))

Complement takes a predicate and returns a new predicate that returns #t where the original returned #f and #f where the original returned non-#f. It is useful with functions like filter and take-while that take predicates as arguments.

(define (complement f) (lambda xs (not (apply f xs))))

Swap takes a binary function and returns a new function that is similar to the original but with arguments reversed. It is useful when composing or currying functions that take their arguments in an inconvenient order.

(define (swap f) (lambda (x y) (f y x)))

A section is a procedure which has been partially applied to some of its arguments; for instance, (double x), which returns twice its argument, is a partial application of the multiply operator to the number 2. Sections come in two kinds: left sections partially apply arguments starting from the left, and right sections partially apply arguments starting from the right. Left-section takes a procedure and some prefix of its arguments and returns a new procedure in which those arguments are partially applied. Right-section takes a procedure and some reversed suffix of its arguments and returns a new procedure in which those arguments are partially applied.

(define (left-section proc . args)
  (lambda xs (apply proc (append args xs))))

(define (right-section proc . args)
  (lambda xs (apply proc (reverse (append (reverse args) (reverse xs))))))

Currying is the technique of rewriting a function that takes multiple arguments so that it can be called as a chain of functions that each take a single argument; the technique is named after the mathematician Haskell Curry, who discovered it (Moses Schönfinkel discovered the technique independently, but the term schönfinkeling never caught on). For example, if div is the curried form of the division operator, defined as (define-curried (div x y) (/ x y)), then inv is the function that returns the inverse of its argument, defined as (define inv (div 1)).

(define-syntax curried-lambda
  (syntax-rules ()
    ((_ () body body* ...)
      (begin body body* ...))
    ((_ (arg arg* ...) body body* ...)
      (lambda (arg)
        (curried-lambda (arg* ...)
          body body* ...)))))

(define-syntax define-curried
  (syntax-rules ()
    ((_ (func arg ...) body body* ...)
      (define func
        (curried-lambda (arg ...)
          body body* ...)))))

Math Functions

The powering function (ipow b e) raises a base b to an integer power e; e must be non-negative:

(define (ipow b e)
  (if (= e 0) 1
    (let loop ((s b) (i e) (a 1)) ; a * s^i = b^e
      (let ((a (if (odd? i) (* a s) a)) (i (quotient i 2)))
        (if (zero? i) a (loop (* s s) i a))))))

The integer square root of a positive number is the greatest integer that, when multiplied by itself, does not exceed the given number. The integer square root can be computed by Newton’s method of approximation via derivatives:

(define (isqrt n)
  (if (not (and (positive? n) (integer? n)))
      (error 'isqrt "must be positive integer")
      (let loop ((x n))
        (let ((y (quotient (+ x (quotient n x)) 2)))
          (if (< y x) (loop y) x)))))

The integer logarithm base b of a number n is the number of times the number b can be multiplied by itself without exceeding n:

(define (ilog b n)
  (let loop1 ((lo 0) (b^lo 1) (hi 1) (b^hi b))
    (if (< b^hi n) (loop1 hi b^hi (* hi 2) (* b^hi b^hi))
      (let loop2 ((lo lo) (b^lo b^lo) (hi hi) (b^hi b^hi))
        (if (<= (- hi lo) 1) (if (= b^hi n) hi lo)
          (let* ((mid (quotient (+ lo hi) 2))
                 (b^mid (* b^lo (expt b (- mid lo)))))
            (cond ((< n b^mid) (loop2 lo b^lo mid b^mid))
                  ((< b^mid n) (loop2 mid b^mid hi b^hi))
                  (else mid))))))))

Modular exponentiation is provided by the function (expm b e m). This is equivalent to (modulo (expt b e) m), except that the algorithm avoids the calculation of the large intermediate exponentiation by performing multiply-and-square in stages.

(define (expm b e m)
  (define (m* x y) (modulo (* x y) m))
  (cond ((zero? e) 1)
        ((even? e) (expm (m* b b) (/ e 2) m))
        (else (m* b (expm (m* b b) (/ (- e 1) 2) m)))))

Halve, double, square, add1, sub1, log2 and log10 are convenient, especially as the function in a map:

(define (halve x) (/ x 2))

(define (double x) (+ x x))

(define (square x) (* x x))

(define (add1 x) (+ x 1))

(define (sub1 x) (- x 1))

(define (log2 x) (/ (log x) (log 2)))

(define (log10 x) (/ (log x) (log 10)))

It is sometimes necessary to extract the digits of a number, to varying bases. Here are functions that convert a number to its digits, and the converse:

(define (digits n . args)
  (let ((b (if (null? args) 10 (car args))))
    (let loop ((n n) (d '()))
      (if (zero? n) d
          (loop (quotient n b)
                (cons (modulo n b) d))))))

(define (undigits ds . args)
  (let ((b (if (null? args) 10 (car args))))
    (let loop ((ds ds) (n 0))
      (if (null? ds) n
          (loop (cdr ds) (+ (* n b) (car ds)))))))

Bits

Common Lisp provides a full suite of bit operators and a bit vector sequence datatype. Scheme, in its minimalism, provided neither until R6RS required a minimal suite of bit operators, but still no bit vectors. Our suite is small but useful. Note that all the bit functions are grossly inefficient; you should use whatever your Scheme implementation provides instead of relying on the functions given below.

Bit-wise operators consider numbers as a sequence of binary bits and operate on them using the logical operations and, inclusive-or, exclusive-or, and not; they are implemented using basic arithmetic. An arithmetic shift multiplies (positive shift) or divides (negative shift) by powers of two:

(define (logand a b)
  (if (or (zero? a) (zero? b)) 0
    (+ (* (logand (floor (/ a 2)) (floor (/ b 2))) 2)
       (if (or (even? a) (even? b)) 0 1))))

(define (logior x y)
  (cond ((= x y) x)
        ((zero? x) y)
        ((zero? y) x)
        (else
          (+ (* (logior (quotient x 2) (quotient y 2)) 2)
            (if (and (even? x) (even? y)) 0 1)))))

(define (logxor a b)
  (cond ((zero? a) b)
        ((zero? b) a)
        (else
         (+ (* (logxor (floor (/ a 2)) (floor (/ b 2))) 2)
            (if (even? a)
                (if (even? b) 0 1)
                (if (even? b) 1 0))))))

(define (lognot a) (- -1 a))

(define (ash int cnt)
  (if (negative? cnt)
      (let ((n (expt 2 (- cnt))))
        (if (negative? int)
            (+ -1 (quotient (+ 1 int) n))
            (quotient int n)))
      (* (expt 2 cnt) int)))

Bit vectors are implemented using arrays of characters. They are represented as a pair with a vector of eight-bit characters in the car and the length of the bit vector in the cdr. Make-bitvector creates a bit vector of the requested length with all bits zero unless the optional argument val is one; note the logic to ensure any “slop” bits at the end of the bit vector are set to zero, which is useful in the bitvector-count function:

(define (make-bitvector len . val)
  (let ((v (make-vector
             (ceiling (/ len 8))
             (if (and (pair? val) (= (car val) 1)) 255 0))))
    (if (and (pair? val) (= (car val) 1) (not (zero? (modulo len 8))))
      (do ((i 8 (- i 1))) ((= i (modulo len 8)))
        (vector-set! v (floor (/ len 8))
          (logand (vector-ref v (floor (/ len 8))) (lognot (ash 1 (- i 1)))))))
    (cons v len)))

Bitvector-ref returns the value of bv[idx], either zero or one:

(define (bitvector-ref bv idx)
  (if (< -1 idx (cdr bv))
      (let ((index (quotient idx 8)) (offset (modulo idx 8)))
        (if (odd? (ash (vector-ref (car bv) index) (- offset))) 1 0))
      (error 'bitvector-ref "out of range")))

Bitvector-set! sets the requested bit to one. Bitvector-reset! sets the requested bit to zero:

(define (bitvector-set! bv idx)
  (if (< -1 idx (cdr bv))
      (let ((index (quotient idx 8)) (offset (modulo idx 8)))
        (vector-set! (car bv) index
          (logior (vector-ref (car bv) index) (ash 1 offset))))
      (error 'bitvector-set! "out of range")))

(define (bitvector-reset! bv idx)
  (if (< -1 idx (cdr bv))
      (let ((index (quotient idx 8)) (offset (modulo idx 8)))
        (vector-set! (car bv) index
          (logand (vector-ref (car bv) index) (lognot (ash 1 offset)))))
      (error 'bitvector-reset! "out of range")))

Bitvector-count returns the number of one-bits in the input bit vector. The counts per byte are pre-calculated in the counts vector. Note that the last byte is not special, because make-bitvector was careful to ensure that any “slop” bits are zero:

(define (bitvector-count bv)
  (let* ((counts #(
          0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4 1 2 2 3 2 3 3 4 2 3 3 4 3 4 4 5
          1 2 2 3 2 3 3 4 2 3 3 4 3 4 4 5 2 3 3 4 3 4 4 5 3 4 4 5 4 5 5 6
          1 2 2 3 2 3 3 4 2 3 3 4 3 4 4 5 2 3 3 4 3 4 4 5 3 4 4 5 4 5 5 6
          2 3 3 4 3 4 4 5 3 4 4 5 4 5 5 6 3 4 4 5 4 5 5 6 4 5 5 6 5 6 6 7
          1 2 2 3 2 3 3 4 2 3 3 4 3 4 4 5 2 3 3 4 3 4 4 5 3 4 4 5 4 5 5 6
          2 3 3 4 3 4 4 5 3 4 4 5 4 5 5 6 3 4 4 5 4 5 5 6 4 5 5 6 5 6 6 7
          2 3 3 4 3 4 4 5 3 4 4 5 4 5 5 6 3 4 4 5 4 5 5 6 4 5 5 6 5 6 6 7
          3 4 4 5 4 5 5 6 4 5 5 6 5 6 6 7 4 5 5 6 5 6 6 7 5 6 6 7 6 7 7 8))
         (len (cdr bv)) (index (quotient len 8)) (offset (modulo len 8)))
    (do ((i 0 (+ i 1))
         (count 0 (+ count (vector-ref counts (vector-ref (car bv) i)))))
        ((= index i) count))))

Bitvector-length returns the number of bits in the bit vector:

(define (bitvector-length bv) (cdr bv))

Random Numbers

This is the portable, high-quality random number generator provided in the Stanford GraphBase by Donald E. Knuth. Based on the lagged fibonacci generator (Knuth calls it the subtractive method)a_n = (a_n-24 − a_n-55) mod m, where m is an even number (we take m = 2³¹) and the numbers a₀ through a₅₄ are not all even, it provides values on the range zero inclusive to 2³¹ exclusive, has a period of at least 2⁵⁵ − 1 but is plausibly conjectured to have a period of 2⁸⁵ − 2³⁰ for all but at most one choice of the seed value, and the low-order bits of the generated numbers are just as random as the high-order bits. You can read Knuth’s original version of the random number generator at http://tex.loria.fr/sgb/gb_flip.pdf; see also our exercise GB_FLIP. This random number generator is suitable for simulation but is not cryptographically secure.

Called with no arguments, (rand) returns an exact rational number on the range zero inclusive to one exclusive. Called with a single numeric argument, (rand seed) resets the seed of the random number generator; it is best if the seed is a large integer (eight to ten digits — dates in the form YYYYMMDD work well), though seeds like 0.3 (three-tenths of 2^35) and -42 (2^35-42) also work. Since the shuffling algorithm requires its own data store, knowing the current seed is not sufficient to restart the generator. Thus, (rand 'get) returns the complete current state of the generator, and (rand 'set state) resets the generator to the given state, given a state in the form provided by (rand 'get). (randint n) returns a random non-negative integer less than n and (randint first past) returns a random integer between first inclusive and past exclusive.

Two versions of the mod-diff function are included. You should use the fast version if your Scheme provides logand natively, or the generic version otherwise. Note that logand is sometimes provided under a different name; for instance, it is bitwise-and in R6RS.

(define rand #f)
(define randint #f)
(let ((two31 #x80000000) (a (make-vector 56 -1)) (fptr #f))
  (define (mod-diff x y) (modulo (- x y) two31)) ; generic version
  ; (define (mod-diff x y) (logand (- x y) #x7FFFFFFF)) ; fast version
  (define (flip-cycle)
    (do ((ii 1 (+ ii 1)) (jj 32 (+ jj 1))) ((< 55 jj))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (do ((ii 25 (+ ii 1)) (jj 1 (+ jj 1))) ((< 55 ii))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (set! fptr 54) (vector-ref a 55))
  (define (init-rand seed)
    (let* ((seed (mod-diff seed 0)) (prev seed) (next 1))
      (vector-set! a 55 prev)
      (do ((i 21 (modulo (+ i 21) 55))) ((zero? i))
        (vector-set! a i next) (set! next (mod-diff prev next))
        (set! seed (+ (quotient seed 2) (if (odd? seed) #x40000000 0)))
        (set! next (mod-diff next seed)) (set! prev (vector-ref a i)))
      (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle)))
  (define (next-rand)
    (if (negative? (vector-ref a fptr)) (flip-cycle)
      (let ((next (vector-ref a fptr))) (set! fptr (- fptr 1)) next)))
  (define (unif-rand m)
    (let ((t (- two31 (modulo two31 m))))
      (let loop ((r (next-rand)))
        (if (list a)))
          ((eq? (car seed) 'set) (set! fptr (caadr seed))
                                 (set! a (list->vector (cdadr seed))))
          (else (/ (init-rand (modulo (numerator
                  (inexact->exact (car seed))) two31)) two31)))))
  (set! randint (lambda args
    (cond ((null? (cdr args))
            (if (< (car args) two31) (unif-rand (car args))
              (floor (* (next-rand) (car args)))))
          ((< (car args) (cadr args))
            (let ((span (- (cadr args) (car args))))
              (+ (car args)
                 (if (< span two31) (unif-rand span)
                   (floor (* (next-rand) span))))))
          (else (let ((span (- (car args) (cadr args))))
                  (- (car args)
                     (if (< span two31) (unif-rand span)
                       (floor (* (next-rand) span))))))))))

Fortune selects an item randomly from a list; the first item is selected with probability 1/1, the second item replaces the selection with probability 1/2, the third item replaces that selection with probability 1/3, and so on, so that the k^th item is selected with probability 1/k. The name derives from the unix game of the same name, which selects an epigram randomly from a file containing one per line.

(define (fortune xs)
  (let loop ((n 1) (x #f) (xs xs))
    (cond ((null? xs) x)
          ((< (rand) (/ n))
            (loop (+ n 1) (car xs) (cdr xs)))
          (else (loop (+ n 1) x (cdr xs))))))

To shuffle a list, convert it to a vector, shuffle the vector by Knuth’s algorithm, and convert the result back to a list:

(define (shuffle x)
  (do ((v (list->vector x)) (n (length x) (- n 1)))
      ((zero? n) (vector->list v))
    (let* ((r (randint n)) (t (vector-ref v r)))
      (vector-set! v r (vector-ref v (- n 1)))
      (vector-set! v (- n 1) t))))

Control Flow

Rather than writing one-armed ifs, it is generally better to use a when or unless, which declares precisely what it is. When and unless are provided natively by many Scheme systems; for those that don’t, they are given below:

(define-syntax when
  (syntax-rules ()
    ((when pred? expr ...)
      (if pred? (begin expr ...)))))

(define-syntax unless
  (syntax-rules ()
    ((unless pred? expr ...)
      (if (not pred?) (begin expr ...)))))

While performs a block of code as long as the controlling predicate is true:

(define-syntax while
  (syntax-rules ()
    ((while pred? body ...)
      (do () ((not pred?)) body ...))))

The call-with-values syntax makes it difficult to use multiple values. The let-values syntax required by R6RS and present in many R5RS systems is far more convenient. An implementation, stolen from Kent Dybvig, is given below for those Scheme systems that lack let-values:

(define-syntax let-values
  (syntax-rules ()
    ((_ () f1 f2 ...) (let () f1 f2 ...))
    ((_ ((fmls1 expr1) (fmls2 expr2) ...) f1 f2 ...)
     (let-values-help fmls1 () () expr1 ((fmls2 expr2) ...) (f1 f2 ...)))))

(define-syntax let-values-help
  (syntax-rules ()
    ((_ (x1 . fmls) (x ...) (t ...) e m b)
     (let-values-help fmls (x ... x1) (t ... tmp) e m b))
    ((_ () (x ...) (t ...) e m b)
     (call-with-values
       (lambda () e)
       (lambda (t ...)
         (let-values m (let ((x t) ...) . b)))))
    ((_ xr (x ...) (t ...) e m b)
     (call-with-values
       (lambda () e)
       (lambda (t ... . tmpr)
         (let-values m (let ((x t) ... (xr tmpr)) . b)))))))

Generators provide an easy-to-use syntax for separating the production of values from their consumption, and are provided natively in many other languages (sometimes they are called iterators). A function defined by define-generator creates a function that, when called, returns the next value in a sequence. For instance:

> (define-generator (yield123)
(yield 1) (yield 2) (yield 3))
> (define y (yield123))
> (y)
1
> (y)
2
> (y)
3
> (y)
Exception in yield123: unexpected return

Define-generator is given below:

(define-syntax define-generator
  (lambda (x)
    (syntax-case x (lambda)
      ((stx name (lambda formals e0 e1 ...))
         (with-syntax ((yield (datum->syntax (syntax stx) 'yield)))
           (syntax (define name
             (lambda formals
               (let ((resume #f) (return #f))
                 (define yield
                   (lambda args
                     (call-with-current-continuation
                      (lambda (cont)
                        (set! resume cont)
                        (apply return args)))))
                 (lambda ()
                   (call-with-current-continuation
                    (lambda (cont)
                      (set! return cont)
                      (cond (resume (resume))
                      (else (let () e0 e1 ...)
                            (error 'name "unexpected return"))))))))))))
        ((stx (name . formals) e0 e1 ...)
          (syntax (stx name (lambda formals e0 e1 ...)))))))

Date Arithmetic

Astronomers calculate the julian number of a date as the number of days elapsed since January 1, 4713 BC. The Gregorian calendar, promulgated by Pope Gregory XIII on February 24, 1582, is the civil calendar used in much of the world. Functions julian and gregorian translate between the two calendars; year must be specified as the full four-digit number (unless you want years in the first millenium), month ranges from 1 for January to 12 for December, day ranges from 1 to 31, and the day of the week can be calculated as the julian number modulo 7, with 0 for Monday and 6 for Sunday:

(define (julian year month day)
  (let* ((a (quotient (- 14 month) 12))
         (y (+ year 4800 (- a)))
         (m (+ month (* 12 a) -3)))
    (+ day
       (quotient (+ (* 153 m) 2) 5)
       (* 365 y)
       (quotient y 4)
       (- (quotient y 100))
       (quotient y 400)
       (- 32045))))

(define (gregorian julian)
  (let* ((j (+ julian 32044))
         (g (quotient j 146097))
         (dg (modulo j 146097))
         (c (quotient (* (+ (quotient dg 36524) 1) 3) 4))
         (dc (- dg (* c 36524)))
         (b (quotient dc 1461))
         (db (modulo dc 1461))
         (a (quotient (* (+ (quotient db 365) 1) 3) 4))
         (da (- db (* a 365)))
         (y (+ (* g 400) (* c 100) (* b 4) a))
         (m (- (quotient (+ (* da 5) 308) 153) 2))
         (d (+ da (- (quotient (* (+ m 4) 153) 5)) 122))
         (year (+ y (- 4800) (quotient (+ m 2) 12)))
         (month (+ (modulo (+ m 2) 12) 1))
         (day (+ d 1)))
    (values year month day)))

For several centuries, the calculation of the date of Easter, a calculation known as the computus, was the most important scientific endeavor of the entire world. Function easter calculates the julian number of the date of Easter for a given year. If offset is given, it is the number of days before or after Easter; for instance, to compute the date of Mardi Gras, give an offset of -47:

(define (easter year . offset)
  (let* ((a (modulo year 19))
         (b (quotient year 100))
         (c (modulo year 100))
         (d (quotient b 4))
         (e (modulo b 4))
         (f (quotient (+ b 8) 25))
         (g (quotient (+ (- b f) 1) 3))
         (h (modulo (- (+ (* 19 a) b 15) d g) 30))
         (i (quotient c 4))
         (k (modulo c 4))
         (l (modulo (- (+ 32 (* 2 e) (* 2 i)) h k) 7))
         (m (quotient (+ a (* 11 h) (* 22 l)) 451))
         (month (quotient (- (+ h l 114) (* 7 m)) 31))
         (day (+ (modulo (- (+ h l 114) (* 7 m)) 31) 1))
         (q (if (pair? offset) (car offset) 0)))
    (+ (julian year month day) q)))

Calculating the current date requires help from the local Scheme interpreter, since Scheme defines no standard functions on dates. Shown below are versions for two popular Scheme interpreters:

(define (today) ; Chez Scheme
  (julian
    (date-year (current-date))
    (+ (date-month (current-date)) 1)
    (date-day (current-date))))

(define (today) ; MzScheme
  (let ((today (seconds->date (current-seconds))))
    (julian (date-year today) (date-month today) (date-day today))))

Unit Testing

The assert macro is useful when testing programs. The syntax (assert expr result) computes expr and result; if they are the same, assert produces no output and returns no value. But if expr and result differ, assert writes a message that includes the text of expr and the result of computing both expr and result. Assert is a macro, not a function, because it prints the literal expr as part of its output, making it easy in a long sequence of assertions to know which is in error. Assert produces no output if all is well, on the theory that “No news is good news.”

(define-syntax assert
  (syntax-rules ()
    ((assert expr result)
      (if (not (equal? expr result))
          (for-each display `(
            #\newline "failed assertion:" #\newline
            expr #\newline "expected: " ,result
            #\newline "returned: " ,expr #\newline))))))

Miscellaneous

Define-integrable is similar to define for procedure definitions except that the code for the procedure is integrated (some people would say inlined) whenever the procedure is called, eliminating the function-call overhead associated with the procedure. Any procedure defined with define-integrable must appear in the source code before the first reference to the defined identifier. Lexical scoping is preserved, macros within the body of the defined procedure are expanded at the point of call, the actual parameters to an integrated procedure are evaluated once and at the proper time, integrable procedures may be used as first-class values, and recursive procedures do not cause indefinite recursive expansion. Define-integrable appears in Section 8.4 of R. Kent Dybvig’s book The Scheme Programming Language:

(define-syntax (define-integrable x)
  (define (make-residual-name name)
    (datum->syntax-object name
      (string->symbol
        (string-append "residual-"
          (symbol->string (syntax-object->datum name))))))
  (syntax-case x (lambda)
    ((_ (name . args) . body)
      (syntax (define-integrable name (lambda args . body))))
    ((_ name (lambda formals form1 form2 ...))
     (identifier? (syntax name))
     (with-syntax ((xname (make-residual-name (syntax name))))
       (syntax
         (begin
           (define-syntax (name x)
             (syntax-case x ()
               (_ (identifier? x) (syntax xname))
               ((_ arg (... ...))
                (syntax
                  ((fluid-let-syntax
                     ((name (identifier-syntax xname)))
                     (lambda formals form1 form2 ...))
                   arg (... ...))))))
           (define xname
             (fluid-let-syntax ((name (identifier-syntax xname)))
               (lambda formals form1 form2 ...)))))))))

Scheme provides hygienic macros (though syntax-case provides a way to safely bend hygiene); Common Lisp, by comparison, provides unhygienic macros. There are some circumstances where unhygienic macros are more convenient than hygienic macros; Paul Graham provides numerous examples in his book On Lisp. Define-macro provides unhygienic macros for Scheme:

(define-syntax (define-macro x)
  (syntax-case x ()
    ((_ (name . args) . body)
      (syntax (define-macro name (lambda args . body))))
    ((_ name transformer)
      (syntax
       (define-syntax (name y)
         (syntax-case y ()
           ((_ . args)
             (datum->syntax-object
               (syntax _)
               (apply transformer
                 (syntax-object->datum (syntax args)))))))))))

The following examples are adapted from Graham’s book:

(define-macro (when test . body) `(cond (,test . ,body)))

(define-macro (aif test-form then-else-forms)
  `(let ((it ,test-form))
     (if it ,then-else-forms)))

(define-macro (awhen pred? . body)
  `(aif ,pred? (begin ,@body)))

When a macro breaks hygiene, it is sometimes useful to generate a unique symbol, which can be used as a variable name or in some other way. Here is the gensym procedure:

(define gensym
  (let ((n -1))
    (lambda ()
      (set! n (+ n 1))
      (string->symbol
        (string-append "gensym-"
          (number->string n))))))

Boxes provide a way to pass arguments to procedures by reference instead of the usual passing by value; put the argument in a box, then access and reset the argument in the procedure:

(define (box v) (vector v))
(define (unbox box) (vector-ref box 0))
(define (box! box v) (vector-set! box 0 v))