src/sicp/ex2_69.rkt

   1 #lang racket
   2
   3 (require rackunit
   4          "ch2_3.rkt")
   5
   6 (define (generate-huffman-tree pairs)
   7   (successive-merge (make-leaf-set pairs)))
   8
   9 (define (successive-merge set)
  10   (cond [(empty? (rest set)) (first set)]
  11         [else (successive-merge (adjoin-set (make-code-tree (first set)
  12                                                             (second set))
  13                                             (rest (rest set))))]))
  14
  15 (test-begin
  16  (let ([sample-tree (make-code-tree (make-leaf 'A 4)
  17                                     (make-code-tree
  18                                      (make-leaf 'B 2)
  19                                      (make-code-tree (make-leaf 'D 1)
  20                                                      (make-leaf 'C 1))))])
  21    (check equal?
  22           (generate-huffman-tree '((A 4) (B 2) (C 1) (D 1)))
  23           sample-tree)))
  24
  25 (provide generate-huffman-tree)