src/sicp/ch2_3_3.rkt

   1 #lang racket/load
   2
   3 (define (element-of-set? x set)
   4   (cond ((null? set) #f)
   5         ((equal? x (car set)) #t)
   6         (else (element-of-set? x (cdr set)))))
   7
   8 (define (adjoin-set x set)
   9   (cond ((element-of-set? x set) set)
  10         (else (cons x set))))
  11
  12 (define (intersection-set set1 set2)
  13   (cond ((or (null? set1) (null set2)) '())
  14         ((element-of-set? (car set1) set2) (cons (car set1) (intersection-set (cdr set1) set2)))
  15         (else (intersection-set (cdr set1) set2))))
  16
  17 ;;; huffman tree
  18 (define (make-leaf symbol weight)
  19   (list 'leaf symbol weight))
  20 (define (leaf? node)
  21   (eq? (car node) 'leaf))
  22 (define (symbol-leaf node)
  23   (car (cdr node)))
  24 (define (weight-leaf node)
  25   (car (cdr (cdr node))))
  26
  27 (define (make-code-tree left right)
  28   (list left
  29         right
  30         (append (symbols left) (symbols right))
  31         (+ (weight left) (weight right))))
  32
  33 (define (left-branch tree) (car tree))
  34 (define (right-branch tree) (car (cdr tree)))
  35 (define (symbols tree)
  36   (if (leaf? tree)
  37       (list (symbol-leaf tree))
  38       (car (cdr (cdr tree)))))
  39 (define (weight tree)
  40   (if (leaf? tree)
  41       (weight-leaf tree)
  42       (car (cdr (cdr (cdr tree))))))
  43
  44 ;; decoding
  45 (define (decode bits tree)
  46   (define (decode-1 bits current-branch)
  47     (if (null? bits)
  48         '()
  49         (let ((next-branch (choose-branch (car bits) tree)))
  50           (if (leaf? next-branch)
  51               (cons (symbol-leaf next-branch)
  52                     (decode-1 (cdr bits) tree))
  53               (decode-1 (cdr bits) next-branch)))))
  54   (decode-1 bits tree))
  55
  56 (define (choose-branch bit tree)
  57   (cond ((= bit 0) (left-branch tree))
  58         ((= bit 1) (right-branch tree))
  59         (else (error "bad bit -- choose-branch" bit))))
  60
  61 ;; sets of weighted elements
  62
  63 ;; arrange items in the increasing order of weight
  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 element-of-set? adjoin-set intersection-set)