我已经为这个问题困扰了几天了。如何使用以下站点上指定的数据构建树：
http://www.impulseadventure.com/photo/jpeg-huffman-coding.html，话题下：
JPEG 文件中的实际 DHT
我会在这里重新解释一下，
你有：
现在我想用这两个参数构建一个二叉树。每次从左到右填充相应长度的数据。你越深入树，你的长度就越长。长度从 1 到 16 不等。看看这个网站，它应该会变得清晰。
现在我想在 Scheme/Racket 中制作这样一棵树，这样我就可以走到这棵树并为每个编码值构建一个表。
我心中的树应该是这样的：
'((x01 x02)((x03 (x11 x04))(((x00 ...)(...)))))
【问题讨论】：
标签： scheme binary-tree jpeg racket huffman-code
这很有趣！
好的，我真的希望那不是家庭作业。
事实证明，有一个非常简单的递归解决方案。在每一层你想要的是获取一个树列表，将它们成对地收集到一个更深的树中，然后在这个级别附加新的叶子。这可以使用'foldr'来编写，但我认为它会不太清楚。
我应该澄清一下输入；在您提到的页面上，规格看起来像
在 0 级离开 :
离开 1 级 :
在第 2 级离开：x23、x42、x23
在第 3 级离开：x24, x23
这将对应于输入
'(() () (x23 x42 x23) (x24 x23))
到下面的程序。
另外，这里唯一要做的就是将此表映射到二叉树，这只有在解码时才有帮助。对于编码，这棵二叉树是没用的。
最后，向How To Design Programs 致敬；我仔细地按照设计配方，点缀我所有的 i 并穿过我所有的 t。请先测试用例！
干杯！
约翰·克莱门茨
#lang racket
(require rackunit)
;; a tree is either
;; a symbol, or
;; (list tree tree)
;; a specification is
;; (listof (listof symbol))
;; spec->tree : specification -> tree
;; run spec->treelist, ensure that it's a list of length 1, return it.
(define (spec->tree spec)
(match (spec->treelist spec)
[(list tree) tree]
[other (error 'spec->tree "multiple trees produced")]))
;; spec->treelist : specification -> (listof tree)
;; given a *legal* specification, produce
;; the corresponding tree. ONLY WORKS FOR LEGAL SPECIFICATIONS...
(define (spec->treelist spec)
(cond [(empty? spec) empty]
[else (append (first spec) (gather-pairs (spec->treelist (rest spec))))]))
;; go "up one level" by grouping each pair of trees into one tree.
;; The length of the list must be a number divisible by two.
(define (gather-pairs trees)
(match trees
[(list) empty]
[(list-rest a b remaining) (cons (list a b) (gather-pairs remaining))]
[other (error 'gather "improperly formed specification")]))
;; TEST CASES
(check-equal? (gather-pairs '(a b c d)) '((a b) (c d)))
(check-equal? (spec->treelist '((top))) '(top))
(check-equal? (spec->treelist '(() (two-a two-b))) '((two-a two-b)))
(check-equal? (spec->treelist '(() (two-a) (three-a three-b)))
'((two-a (three-a three-b))))
(check-equal? (spec->treelist '(() () (three-a three-b three-c) (four-a four-b)))
'(((three-a three-b) (three-c (four-a four-b)))))
(check-equal? (spec->tree '(() () (three-a three-b three-c) (four-a four-b)))
'((three-a three-b) (three-c (four-a four-b))))
【讨论】：
首先计算每个符号，然后对结果列表进行排序，然后从排序列表中的前 2 个条目中创建一个节点，并将它们从列表中删除。继续，直到您的列表为空。构建树非常简单：如果您拥有所有符号和频率，您可以将 2 个符号分组到一个节点，并将左侧值设为左侧频率的编号，将右侧编号设为左侧 + 右侧频率的编号。这也称为嵌套集或 Celko-Tree。
【讨论】：
#lang r6rs
(library
(huffman-table)
(export make-table find)
(import (rnrs base (6))
(rnrs io simple)
(only (racket base) bytes bytes-length bytes-ref make-hash hash-set! hash-ref do)
(rnrs mutable-pairs (6)))
(define (make-node left right)
(list left right))
(define (left node)
(car node))
(define (right node)
(cadr node))
(define (left! node left)
(set-car! node left)
left)
(define (right! node right)
(set-car! (cdr node) right)
right)
(define (node? object)
(eq? (car object) 'node))
(define (make-leaf value)
(list 'leaf value))
(define (value leaf)
(cadr leaf))
(define (leaf? object)
(eq? (car object) 'leaf))
(define (generate-pairs lengths data)
(define length (bytes-length lengths))
(let out-loop ((l-idx 0)
(d-idx 0)
(res '()))
(if (= l-idx length)
(reverse res)
(let in-loop
((t 0)
(amt (bytes-ref lengths l-idx))
(temp-res '()))
(if (= t amt)
(out-loop (+ l-idx 1)(+ d-idx (bytes-ref lengths l-idx))(cons temp-res res))
(in-loop (+ t 1) amt (cons (bytes-ref data (+ d-idx t)) temp-res)))))))
(define (add-nodes node-lst)
(let loop ((added-nodes '())
(node-lst node-lst))
(cond ((null? node-lst) (reverse added-nodes))
(else (let ((node (car node-lst))
(left-child (make-node '() '()))
(right-child (make-node '() '())))
(if (null? (left node))
(begin (left! node left-child)
(right! node right-child)
(loop (cons right-child (cons left-child added-nodes))
(cdr node-lst)))
(begin (right! node right-child)
(loop (cons right-child added-nodes)
(cdr node-lst)))))))))
(define (label-nodes! node-lst values)
(let loop ((node-lst node-lst)
(values values))
(cond ((null? values) node-lst)
((null? (cdr values))(if (null? (left (car node-lst)))
(left! (car node-lst) (car values))
(right! (car node-lst) (car values)))
node-lst)
(else (if (null? (left (car node-lst)))
(begin (left! (car node-lst) (car values))
(right! (car node-lst) (cadr values))
(loop (cdr node-lst)(cddr values)))
(begin (right! (car node-lst)(make-leaf (car values)))
(loop (cdr node-lst)(cdr values))))))))
(define (make-tree pairs)
(define root (make-node '() '()))
;(define curr-nodes (list root))
(let loop ((curr-nodes (list root))
(pairs pairs))
(cond
((null? pairs) root)
(else (loop (add-nodes (label-nodes! curr-nodes (car pairs)))
(cdr pairs))))))
(define (atom? el)
(not (pair? el)))
(define (add bit bitstr)
(if bitstr
(string-append (number->string bit) bitstr)
#f))
(define (code symbol tree)
(cond ((null? tree) #f)
((atom? tree) (if (= tree symbol)
""
#f))
(else (or (add 0 (code symbol (left tree)))
(add 1 (code symbol (right tree)))))))
(define (make-table lengths data)
(define pairs (generate-pairs lengths data))
(define tree (make-tree pairs))
(define table (make-hash))
(do ((i 0 (+ i 1)))
((= i (bytes-length data)) table)
(let ((val (bytes-ref data i)))
(hash-set! table (code val tree) val))))
(define (find table bitstring)
(hash-ref table bitstring #f))
)
【讨论】：