scheme实现huffman编码的完整代码

(define (make - leaf symbol weight)
  (list  ' leaf symbol weight))
(define (leaf? object)
  (eq? (car object)  ' leaf))
(define (symbol - leaf x) (cadr x))
(define (weight - 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)
      (list (symbol - leaf tree))
      (caddr tree)))
(define (weight tree)
  ( if  (leaf? tree)
      (weight - leaf tree)
      (cadddr tree)))
;解码
(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) tree))
              (decode - 1  (cdr bits) next - branch)))))
  (decode - 1  bits tree))
(define (choose - branch bit branch)
  (cond (( =  bit 0) (left - branch branch))
        (( =  bit  1 ) (right - branch branch))
        ( else  (display  " bad bit --CHOOSE-BRANCH " ))))
(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 (encode message tree)
  ( if  (null? message)
       ' ()
      (append (encode - symbol (car message) tree)
              (encode (cdr message) tree))))
(define (encode - symbol symbol tree)
  (define (iter branch)
    ( if  (leaf? branch)
         ' ()
        ( if  (memq symbol (symbols (left - branch branch)))
            (cons 0 (iter (left - branch branch)))
            (cons  1  (iter (right - branch branch))))
        ))
  ( if  (memq symbol (symbols tree))
      (iter tree)
      (display  " bad symbol -- UNKNOWN SYMBOL " )))
;生成hufman树
(define (generate - huffman - tree pairs)
  (successive - merge (make - leaf - set pairs)))

(define (successive - merge leaf - set)
  ( if  (null? (cdr leaf - set))
      (car leaf - set)
      (successive - merge (adjoin - set (make - code - tree (car leaf - set)
                                                    (cadr leaf - set))
                                    (cddr leaf - set)))))

文章转自庄周梦蝶  ，原文发布时间 2007-07-23