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

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