;leaf
(define (make-leaf symbol weight)
(list 'leaf symbol weight))
(define (symbol-leaf leaf)
(cadr leaf))
(define (weight-leaf leaf)
(caddr leaf))
(define (leaf? obj)
(eq? 'leaf (car obj)))
;tree
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence) (accumulate op initial (cdr sequence)))))
(define (append x y)
(accumulate cons y x))
(define (make-tree left right)
(list left right
(append (symbols left)
(symbols right))
(+ (weight left) (weight right))))
(define (symbols obj)
(if (leaf? obj)
(list (symbol-leaf obj))
(caddr obj)))
(define (weight obj)
(if (leaf? obj)
(weight-leaf obj)
(cadddr obj)))
(define (left-branch tree)
(car tree))
(define (right-branch tree)
(cadr tree))
;decode
(define (decode bits tree)
(define (decode1 bits tmp)
(if (null? bits)
'()
(let ((next-branch (choose-branch (car bits) tmp)))
(if (leaf? next-branch)
(cons (symbol-leaf next-branch)
(decode1 (cdr bits) tree))
(decode1 (cdr bits) next-branch)))))
(decode1 bits tree))
(define (choose-branch bit branch)
(cond ((= 0 bit) (left-branch branch))
((= 1 bit) (right-branch branch))))
;2.68 encode
;由于从小到大排序编码数,导致频率高的字符出现在树的右方,因此应优先访问右子树,这里encode-in返回一个序对,其car值表示字符是否在当前子树,cdr值表示最后几位编码,其实也可以不这么复杂,因为树的每个节点实际上存了字符信息,不过考虑到检查此信息的时间消耗,作罢
(define (encode message tree)
(if (null? message)
'()
(append (encode-symbol (car message) tree)
(encode (cdr message) tree))))
(define (encode-symbol symbol tree)
(define (encode-in current)
(if (leaf? current)
(if (eq? symbol (symbol-leaf current))
'(#t)
'(#f))
(let ((right-result (encode-in (right-branch current))))
(if (car right-result)
(cons #t (cons 1 (cdr right-result)))
(let ((left-result
(encode-in
(left-branch current))))
(if (car left-result)
(cons #t (cons 0 (cdr left-result)))
'(#f)))))))
(let ((result (encode-in tree)))
(if (car result)
(cdr result)
(error "no match symbol!"))))
;;这个版本性能不好,主要利用了
;(if x 1 2)这个表达式只有在x是#f时才返回2的事实,当x是数啊,表啊等等,都返回1
;; (define (encode-symbol symbol tree)
;; (define (encode-symbol1 tmp ans)
;; (if (leaf? tmp)
;; (if (eq? symbol (symbol-leaf tmp))
;; ans
;; #f)
;; (let ((left-result
;; (encode-symbol1
;; (left-branch tmp)
;; (append ans '(0)))))
;; (if left-result
;; left-result
;; (encode-symbol1 (right-branch tmp) (append ans '(1)))))))
;; (let ((result (encode-symbol1 tree '())))
;; (if result
;; result
;; (error "no match symbol"))))
;insert&sort
;实际上是个插入排序,还不知道scheme怎么写快排
(define (adjoin-set item set)
(if (null? set)
(list item)
(cond ((> (weight (car set)) (weight item))
(cons item set))
(else (cons (car set) (adjoin-set item (cdr set)))))))
(define (make-leaf-set pairs);o(n^2)
(if (null? pairs)
'()
(let ((pair (car pairs)))
(adjoin-set (make-leaf (car pair) (cadr pair))
(make-leaf-set (cdr pairs))))))
;;2.69就是合并n-1次
(define (generate-huffman-tree pairs);o(n^2)
(successive-merge (make-leaf-set pairs)))
(define (successive-merge pairs)
(define (make-code-tree pairs)
(cond ((or (null? pairs) (null? (cdr pairs))) pairs)
(else (adjoin-set
(make-tree (car pairs) (cadr pairs))
(cddr pairs)))))
(define (successive-merge-iter pairs)
(cond ((null? pairs) '())
((null? (cdr pairs)) (car pairs))
(else (successive-merge-iter (make-code-tree pairs)))))
(successive-merge-iter pairs))
huffman编码树
發表評論
所有評論
還沒有人評論,想成為第一個評論的人麼? 請在上方評論欄輸入並且點擊發布.