src/sicp/ch2_3.rkt

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