Programming Praxis

This is easier than it looks, since bit-twiddling is ugly in Scheme. We start with compression:

(define (pack str)
  (define (compress c) (bitwise-and c #x3F))
  (define (c cs n) (let ((xs (drop n cs))) (if (null? xs) 32 (car xs))))
  (define (b n) (bitwise-and n #xFF))
  (let loop ((cs (map char->integer (string->list str))) (out (list)))
    (if (null? cs) (list->string (map integer->char (reverse out)))
      (let* ((p (+ (ash (compress (c cs 0)) 18) (ash (compress (c cs 1)) 12)
                   (ash (compress (c cs 2)) 6) (compress (c cs 3))))
             (out1 (b (ash p -16))) (out2 (b (ash p -8))) (out3 (b p)))
        (loop (drop 4 cs) (cons* out3 out2 out1 out))))))

The internal c function returns space characters if needed for padding, and the internal b function performs a bitwise-and with 11111111_b. The loop processes blocks of four characters, building up the 6-bit representations of the characters in an integer p, then splitting p eight bits at a time. Expansion is the opposite:

(define (unpack str)
  (define (expand p) (+ (ash (bitwise-xor 1 (ash p -5)) 6) p))
  (define (b n) (bitwise-and n #x3F))
  (let loop ((cs (map char->integer (string->list str))) (out (list)))
    (if (null? cs) (list->string (map integer->char (reverse out)))
      (let* ((p (+ (ash (car cs) 16) (ash (cadr cs) 8) (caddr cs)))
             (out1 (expand (b (ash p -18)))) (out2 (expand (b (ash p -12))))
             (out3 (expand (b (ash p -6)))) (out4 (expand (b p))))
        (loop (cdddr cs) (cons* out4 out3 out2 out1 out))))))

It’s easy to check that our functions work:

> (unpack (pack "PROGRAMMING PRAXIS"))
"PROGRAMMING PRAXIS "

We used drop and cons* from the Standard Prelude, and the new bitwise- functions from R7RS. You can run the program at http://programmingpraxis.codepad.org/bDpcnppQ, where you will also see implementations of the bitwise- functions if your Scheme doesn’t yet provide them.

Pages: 1 2