Code

#lang racket

; encoding tree

(define (make-leaf symbol weight)
  (list 'leaf symbol weight))

(define (leaf? object)
  (eq? (car object) 'leaf))

(define (symbol-leaf x) (cadr x))

(define (weight-leaf x) (caddr x))

(define (make-code-tree left right)
  (list left
        right
        (append (symbols left) (symbols right)) ; or union-set
        (+ (weight left) (weight right))))

(define (left-branch tree) (car tree))

(define (right-branch tree) (cadr tree))

(define (symbols tree)
  (if (leaf? tree)
      (list (symbol-leaf tree))
      (caddr tree)))

(define (weight tree)
  (if (leaf? tree)
      (weight-leaf tree)
      (cadddr tree)))

; encoding procedure

(define (element-of-set? x set)
  (cond ((null? set) false)
        ((equal? x (car set)) true)
        (else (element-of-set? x (cdr set)))))

(define (encode message tree)
  (if (null? message)
      '()
      (append (encode-symbol (car message) tree)
              (encode (cdr message) tree))))

(define (encode-symbol symbol tree)
  (cond
    ((leaf? tree) '())
    ((element-of-set? symbol (symbols (left-branch tree)))
     (cons 0 (encode-symbol symbol (left-branch tree))))
    ((element-of-set? symbol (symbols (right-branch tree)))
     (cons 1 (encode-symbol symbol (right-branch tree))))
    (else (error "bad symbol: ENCODE_SYMBOL" symbol))))

; ordered-by-weight set of leaves

(define (adjoin-set x set)
  (cond ((null? set) (list x))
        ((< (weight x) (weight (car set))) (cons x set))
        (else (cons (car set) (adjoin-set x (cdr set))))))

(define (make-leaf-set pairs)
  (if (null? pairs)
      '()
      (let ((pair (car pairs)))
        (adjoin-set (make-leaf (car pair) (cadr pair))
                    (make-leaf-set (cdr pairs))))))

(define (successive-merge set)
  (if (eq? (cdr set) '())
      (car set)
      (let ((leaf1 (car set))
            (leaf2 (cadr set)))
        (successive-merge (adjoin-set (make-code-tree leaf1 leaf2)
                                      (cddr set))))))

(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))

; tests

(define htree (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (SHA 3) (NA 16) (WAH 1) (YIP 9))))
(define sjob (encode '(GET A JOB) htree))
(define sna (encode '(SHA NA NA NA NA NA NA NA NA) htree))
(define syip (encode '(WAH YIP YIP YIP YIP YIP YIP YIP YIP YIP) htree))
(define sboom (encode '(SHA BOOM) htree))

sjob
sna
sjob
sna
syip
sboom

(require "common.scm")

(display "Number of bits: ")
(accumulate
 (lambda (x y) (+ (length x) y))
 0
 (list sjob sna sjob sna syip sboom))

(display "Number of bits in a fixed-length code for 8 symbols: ")
(display (* 3 36))
(newline)

Output

'(1 1 1 1 1 1 1 0 0 1 1 1 1 0)
'(1 1 1 0 0 0 0 0 0 0 0 0)
'(1 1 1 1 1 1 1 0 0 1 1 1 1 0)
'(1 1 1 0 0 0 0 0 0 0 0 0)
'(1 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0)
'(1 1 1 0 1 1 0 1 1)
Number of bits: 84
Number of bits in a fixed-length code for 8 symbols: 108