src/sicp/ch2_3.rkt

   1 #lang racket
   2
   3 ;; leaf nodes
   4 (define (make-leaf leaf weight)
   5   (list 'leaf leaf weight))
   6
   7 (define (leaf? object)
   8   (eq? (car object) 'leaf))
   9
  10 (define (symbol-leaf object)
  11   (cadr object))
  12
  13 (define (weight-leaf object)
  14   (caddr object))
  15
  16 ;;;; constructors and selectors
  17
  18 ;; tree node consists of a list which has left branch, right branch
  19 ;; set of symbols in left and right and total weight
  20 (define (make-code-tree left right)
  21   (list left
  22         right
  23         (append (symbols left)
  24                 (symbols right))
  25         (+ (weight left)
  26            (weight right))))
  27
  28 (define (left-branch tree) (car tree))
  29
  30 (define (right-branch tree) (cadr tree))
  31
  32 (define (symbols tree)
  33   (if (leaf? tree)
  34       (list (symbol-leaf tree))
  35       (caddr tree)))
  36
  37 (define (weight tree)
  38   (if (leaf? tree)
  39       (weight-leaf tree)
  40       (cadddr tree)))
  41
  42 ;; now decoding
  43 (define (decode bits tree)
  44   (define (decode-1 bits current-branch)
  45     (if (null? bits)
  46         '()
  47         (let ([next-branch (choose-branch (car bits) current-branch)])
  48           (if (leaf? next-branch)
  49               (cons (symbol-leaf next-branch)
  50                     (decode-1 (cdr bits) tree))
  51               (decode-1 (cdr bits) next-branch)))))
  52   (decode-1 bits tree))
  53
  54 (define (choose-branch bit tree)
  55   (cond [(= bit 0) (left-branch tree)]
  56         [(= bit 1) (right-branch tree)]
  57         [else (error "Bad bit -- CHOOSE-BRANCH" bit)]))
  58
  59 (define (adjoin-set x set)
  60   (cond [(null? set) (list x)]
  61         [(< (weight x) (weight (car set))) (cons x set)]
  62         [else (cons (car set)
  63                     (adjoin-set x (cdr set)))]))
  64
  65 (define (make-leaf-set pairs)
  66   (if (null? pairs)
  67       '()
  68       (let ([pair (car pairs)])
  69         (adjoin-set (make-leaf (car pair)
  70                                (cadr pair))
  71                     (make-leaf-set (cdr pairs))))))
  72
  73 (provide make-code-tree
  74          make-leaf
  75          decode
  76          leaf?
  77          symbol-leaf
  78          left-branch
  79          right-branch
  80          symbols
  81          make-leaf-set
  82          adjoin-set)