scheme實作huffman編碼的完整代碼

來自sicp的完整代碼，包括書中給出的代碼以及習題，實作了huffman樹的生成、解碼、編碼過程，總共67行代碼，同樣的代碼有空用java、ruby改寫下，看看會有什麼不同。

(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)

      (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