[Back to the 30 Days of Programming Overview Page]

Huffman Coding in Guile (Scheme)

Really learning Scheme was interesting. It actually does feel quite like writing in the lambda calculus. Anyways, I spent a bunch of time learning the language today, so I'm not going to write much here. The code isn't great, but it works, and it's here.

Source Code (huffman.scm)

[raw] [download]

#!/usr/bin/env guile
vim: set nolisp et ts=2 sts=2 sw=2 : !#

;; Read a string to Huffman code
(define read-frequencies
  (lambda (allocation)
    (let ((frequencies (make-hash-table allocation)))
      (do ((c (read-char) (read-char)))
        ((eof-object? c))
        (let ((c-freq (hashq-ref frequencies c)))
          (hashq-set! frequencies c
            (if c-freq (+ c-freq 1) 1))))
      frequencies)))

;; Pairing heap implementation
(define find-min
  (lambda (heap)
    (if (null? heap) #f (car heap))))

(define merge
  (lambda (less-than heap-1 heap-2)
    (cond
      ((null? heap-1) heap-2)
      ((null? heap-2) heap-1)
      ((less-than (car heap-1) (car heap-2))
        (cons (car heap-1) (cons heap-2 (cdr heap-1))))
      (else
        (cons (car heap-2) (cons heap-1 (cdr heap-2)))))))

(define insert
  (lambda (less-than heap elem)
    (merge less-than heap (cons elem '()))))

(define delete-min
  (lambda (less-than heap)
    (letrec
      ((merge-pairs
        (lambda (trees)
          (cond
            ((null? trees) '())
            ((null? (cdr trees)) (car trees))
            (else (merge less-than
              (merge less-than (car trees) (cadr trees))
              (merge-pairs (cddr trees))))))))
      (if (null? heap) '() (merge-pairs (cdr heap))))))

;; Generate a Huffman tree
(define huffman-tree
  (lambda (frequencies)
    (letrec
      ( (sum-frequency
          (lambda (tree)
            (if (number? (cdr tree)) (cdr tree)
              (+ (sum-frequency (car tree)) (sum-frequency (cdr tree))))))
        (less-than
          (lambda (elem-1 elem-2)
            (< (sum-frequency elem-1) (sum-frequency elem-2))))
        (queue '()))
      (hash-for-each
        (lambda (key value)
          (set! queue (insert less-than queue (cons key value))))
        frequencies)
      (if (null? queue) '()
        (do ()
          ((null? (cdr queue)) (car queue))
          (let ((elem-1 (find-min queue)))
            ;;(write queue) (newline)
            (set! queue (delete-min less-than queue))
            ;;(write queue) (newline)
            (let ((elem-2 (find-min queue)))
              (set! queue (delete-min less-than queue))
              ;;(write queue) (newline)
              (set! queue (insert less-than queue (cons elem-1 elem-2))))))))))

;; Print out symbol-code pairs
(define write-huffman-code
  (lambda (prefix tree)
    (let
      (
        (write-code
          (lambda (sym code)
            (write sym)
            (display " ")
            (display code)
            (newline)))
        (code-0 (string-append prefix "0"))
        (code-1 (string-append prefix "1")))
      (if (number? (cdar tree))
        (write-code (caar tree) code-0)
        (write-huffman-code code-0 (car tree)))
      (if (number? (cddr tree))
        (write-code (cadr tree) code-1)
        (write-huffman-code code-1 (cdr tree))))))

;; Show the tree
(let*
  (
    (frequencies (read-frequencies 128))
    (tree (huffman-tree frequencies)))
  ;;(write tree) (newline)
  (write-huffman-code "" tree))