Huffman encoding and decoding in Racket - sample code

huffman.rkt

#lang racket


(define (freq-list str)
  (let ([sl (map (λ (x) (format "~a" x))
                 (string->list str))])
    (hash->list
     (make-hash
      (map (λ (x) (cons (list x)
                        (count (λ (y) (string=? x y)) sl)))
           sl)))))

(define (order-list sl)
  (sort sl
        (λ (x y)
          (< (cdr x)
             (cdr y)))))

(define (gen-huff-tree sl tree)
  (cond
    ((= (length sl) 1) (list sl tree))
    (else
     (let* ([x (car sl)]
            [y (cadr sl)]
            [comb (combine-nodes x y tree)])
       (gen-huff-tree
        (order-list
         (cons (car comb)
               (cddr sl)))
        (cadr comb))))))

(define (combine-nodes x y tree)
  (let ([p (cons
            (append
             (car x)
             (car y))
            (+ (cdr x) (cdr y)))])
    (list p (hash-set tree p (list y x)))))

(define (node-contains? node x)
  (member x (car node)))

     
(define (traverse-tree root tree x path)
  (if (node-contains? root x)
      (let* ([subtree (hash-ref tree root #f)])
        (if (not subtree)
            (reverse path)
            (let ([left (car subtree)]
                  [right (cadr subtree)])
              (if (node-contains? left x)
                  (traverse-tree left tree x (cons 0 path))
                  (traverse-tree right tree x (cons 1 path))))))
      #f))


(define (traverse-code root tree current-root code-list results)
  ;(println (format "~a ~a" current-root code-list))
  (cond
    ((empty? code-list) (reverse (cons (caar current-root) results)))
    ((not (hash-ref tree current-root #f))
     (traverse-code root
                    tree
                    root
                    code-list
                    (cons (caar current-root) results)))
    (else
     (let* ([subtree (hash-ref tree current-root)]
            [left (car subtree)]
            [right (cadr subtree)])
       (traverse-code root
                      tree
                      (if (= (car code-list) 0) left right)
                      (cdr code-list)
                      results)))))


(define test "BACADAEAFABBAAAGAH")

(define root-tree (gen-huff-tree (order-list (freq-list test))
                                 (hash)))


;> (traverse-tree (caar root-tree)
;                 (cadr root-tree)
;                 "A"
;                 '())
;'(0)
;> (traverse-tree (caar root-tree)
;                 (cadr root-tree)
;                 "E"
;                 '())
;'(1 0 1 0)
;> (traverse-tree (caar root-tree)
;                 (cadr root-tree)
;                 "D"
;                 '())
;'(1 1 1 1)
;> (traverse-code (caar root-tree)
;                 (cadr root-tree)
;                 (caar root-tree)
;                 '(0 1 0 1 0 1 1 1 1)
;                 '())
;'("A" "E" "D")