在方案中建立霍夫曼树

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

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


)