huffman.scm

(define-syntax generate-huffman-encoder
  (lambda (x)
    (syntax-case x ()
      ((_ token-file)
       (let* ((frequencies (read-literal
                            (find-in-path (syntax->datum #'token-file))))
              (code-tree (token-frequencies->tree frequencies))
              (encoded-tree (encode-tree code-tree))
              (oddball-code (assoc-ref encoded-tree '*oddball*))
              (eof-code (assoc-ref encoded-tree '*eof*)))
         #`(lambda (in out)
             (let ((nbits-buffer 0)
                   (bits-buffer 0))
               (define (write-bits int len)
                 (let lp ((bits (logior (ash int nbits-buffer) bits-buffer))
                          (nbits (+ nbits-buffer len)))
                   (cond
                    ((< nbits 8)
                     (set! bits-buffer bits)
                     (set! nbits-buffer nbits))
                    (else
                     (put-u8 out (logand bits #xff))
                     (lp (ash bits -8) (- nbits 8))))))

               ;; FIXME: Assert i < (1 << 21)
               (define (write-oddball i)
                 (if (<= i #x7f)
                     (write-bits (ash i 1) 8)
                     (write-bits (logior (ash i 1) 1) 22)))

               (define (encode-one-token in)
                 #,(build-token-parser
                    (filter string? (map car frequencies))
                    #'in
                    (lambda (token)
                      (let ((bv (assoc-ref encoded-tree token)))
                        #`(begin
                            (write-bits #,(bitvector->int bv)
                                        #,(bitvector-length bv))
                            #t)))
                    (lambda (oddball)
                      #`(begin
                          (write-bits #,(bitvector->int oddball-code)
                                      #,(bitvector-length oddball-code))
                          (write-oddball (char->integer #,oddball))
                          #t))
                    (lambda (eof)
                      #`(begin
                          (write-bits #,(bitvector->int eof-code)
                                      #,(bitvector-length eof-code))
                          #f))))

               (let lp ()
                 (if (encode-one-token in)
                     (lp)
                     (unless (zero? nbits-buffer)
                       (write-bits 0 (- 8 nbits-buffer))))))))))))