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