霍夫曼编码—scheme

　　最近在看SICP书，第二章有一节关于霍夫曼编码的，把书上的部分代码，再加上我自己做的练习，整理出来一些代码。

　　包括编码，解码，生成编码树。

　　传说中的Scheme哦:(

　　

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



;; makers

(define (make-code-tree left right)

  (list left

        right

        (append (symbols left) (symbols right))

        (+ (weight left) (weight right))))

        

;; selectors

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

      

;; decoding

(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 (error "bad bit -- CHOOSE-BRANCH" bit))))



;; encoding

(define (encode message tree)

  (if (null? message)

      '()

      (append (encode-symbol (car message) tree)

              (encode (cdr message) tree))))



(define (member? x ls) (and (member x ls) #t))

(define (encode-symbol s tree) ; 2.68

  (cond ((null? tree) '())

        ((leaf? tree) '())

        ((member? s (symbols (left-branch tree)))

         (cons '0 (encode-symbol s (left-branch tree))))

        ((member? s (symbols (right-branch tree)))

         (cons '1 (encode-symbol s (right-branch tree))))

        (else (error "bad symbol -- encode-sympol" s))))



;; generate 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)    ; symbol

                               (cadr pair))  ; frequency

                    (make-leaf-set (cdr pairs))))))



(define (generate-huffman-tree pairs)

  (successive-merge (make-leaf-set pairs)))



(define (successive-merge sub-trees) ; 2.69

  (if (= (length sub-trees) 1)

      (car sub-trees)

      (let ((new-node (make-code-tree (car sub-trees)

                                      (cadr sub-trees))))

        (successive-merge (adjoin-set new-node (cddr sub-trees))))))

                                 

; for test

(define sample-tree

  (make-code-tree (make-leaf 'A 4)

                  (make-code-tree

                   (make-leaf 'B 2)

                   (make-code-tree (make-leaf 'D 1)

                                   (make-leaf 'C 1)))))

(define sample-bits '(0 1 1 0 0 1 0 1 0 1 1 1 0))

(equal? sample-bits

        (encode (decode sample-bits sample-tree) sample-tree))

(equal? sample-tree  

        (generate-huffman-tree '((A 4) (B 2) (C 1) (D 1))))

博客园不支持scheme代码，只能贴plaintext了:P