SICP第二章关于哈夫曼编码的代码

树叶的构造与选择函数

(define (make-leaf symbol weight)
  (list 'leaf symbol weight))
(define (leaf? x) (eq? (car x) 'leaf))
(define (symbol-leaf x) (cadr x))
(define (symbol-leaf x) (caddr x))

树的构造与选择函数

(define (make-code-tree left right)
  (list left
        right
        (append (symbols left) (symbols right))
        (+ (weight left) (weight right))))
(define (left-branch tree) (car tree))
(define (right-branch tree) (cadr tree))
(define (symbols tree)
  (if (leaf? tree)
      (symbol-leaf tree)
      (caddr tree)))
 (define (weight tree)
   (if (leaf? tree)
       (weight-leaf tree)
       (cadddr tree)))

有序集合的插入操作

(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 (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))
(define (successive-merge set)
  (if (null? (cadr set))
      set
      (let ((tree (make-code-tree (car set) (cadr set))))
        (successive-merge (adjoin-set tree (cddr set))))))

对消息进行二进制位的编码

(define (encode message tree)
  (if (null? message)
      '()
      (append (encode-symbol (car message) tree)
              (encode (cdr message) tree)))
 (define (encode-symbol message tree)
   (cond ((leaf? tree) '())
         ((memq message (left-branch tree))
          (cons '0 (encode-symbol message (left-branch tree)) ((memq message (right-branch tree)) (cons '1 (encode-symbol message (right-branch tree)) (else (error "symbol doesn't exist" message)))) (define (memq item x) (cond ((null? x) false) ((eq? item (car x)) true) (else (memq item (cdr x)))))

对二进制位编码解码

(define (decode bits tree)
  (define (decode-1 bits current-branch)
    (if (null? bits)
        '()
        (let ((next-branch (choose-branch (car bits) current-branch)))
          (if (leaf? next-branch) (cons (symbol-leaf next-branch) (decode-1 (cdr bits) next-branch)))))
  (decode-1 bits tree))

(define (choose-branch bit branch)
  (cond ((= bit 0) (leaf-branch branch))
        ((= bit 1) (right-branch branch))
        (else (error "bad bit" bit))))