huffman.lisp/huffman.lisp

(require :uiop)

(defun buffer-freq (stream)
  (let ((freq-map (make-hash-table)))
    (loop for c = (read-byte stream nil nil)
          while c
          do (setf (gethash c freq-map) (+ 1 (gethash c freq-map 0))))
    (loop for key being the hash-keys of freq-map
          using (hash-value value)
          collect (cons value key))
    ))

; ---

(defun merge-interim-nodes (left right)
  (cons (+ (car left) (car right)) (cons (cdr left) (cdr right))))

(defun singlep (lst)
  (and (consp lst) (not (cdr lst))))

(defun huffman-tree-encode (huffman-tree value depth)
  (if (consp huffman-tree)
      (append
       (huffman-tree-encode (car huffman-tree) (+ 1 (ash value 1)) (+ 1 depth))
       (huffman-tree-encode (cdr huffman-tree) (+ 0 (ash value 1)) (+ 1 depth)))
      (list (cons huffman-tree (cons value depth)))))

(defun comp-interim (left right)
  "sort interum nodes"
  (< (car left) (car right)))

(defun freq2huffman (interim-nodes)
  (loop
    until (singlep interim-nodes)
    do (progn
         (setq interim-nodes (sort interim-nodes #'comp-interim))
         (push (merge-interim-nodes (pop interim-nodes) (pop interim-nodes)) interim-nodes)
         ))
  (huffman-tree-encode (cdr (car interim-nodes)) 0 1))

; ---

(defmacro mkcanon (loop-args key-form codelen-form)
  `(let ((codelen nil) (code 0))
     (loop ,@loop-args
           do (if codelen
                  (progn
                    (setq code (+ code 1))
                    (when (> ,codelen-form codelen)
                      (setq codelen ,codelen-form)
                      (setq code (ash code 1))))
                  (setq codelen ,codelen-form))
           collect (cons ,key-form (cons code codelen)))))
;; (macroexpand '(mkcanon (for pair in sorted-huffman-list while pair) (car pair) (cdr (cdr pair))))

(defun comp-huffman (left right)
  "sort huffman mappings by code length & value"
  (if (= (cdr (cdr right)) (cdr (cdr left)))
      (< (car left) (car right)); sort by value
      (> (cdr (cdr right)) (cdr (cdr left))); sort by code length
      ))
(defmacro huffman2canon (unsorted-huffman-list)
  `(mkcanon (for pair in (sort ,unsorted-huffman-list #'comp-huffman) while pair) (car pair) (cdr (cdr pair))))
;(huffman2canon (list ))

(defmacro stream2canon (instream)
  `(let ((len (read-byte ,instream)))
     (mkcanon (for i from 0 to len for pair = (cons (read-byte ,instream) (read-byte ,instream))) (car pair) (cdr pair))))

; ---

(defmacro mk-mask (size)
  (loop for i from 0 to (- size 1) sum (ash 1 i)))
;(format t "~b" (mk-mask 4))

(defun bitstream-format (source)
  (format t "~%(~2d)~v,'0b" (cdr source) (cdr source) (car source)))
;(bitstream-format (cons 6 4))

(defun bitstream-push (sink source)
  "Copies all bits from source to sink, returns new sink."
  (cons (logior (ash (car sink) (cdr source)) (car source)) (+ (cdr sink) (cdr source))))
;(bitstream-format (bitstream-push (cons 11 5) (cons 0 4)))

(defmacro mk-bitstream-pop (source len)
  "Splits the bitstream by 'len bits returns the new source & the popped bits"
  `(let* ((new-len (- (cdr ,source) ,len))
          (mask (ash (mk-mask ,len) new-len)))
     (values 
      (cons (logxor (logior (car ,source) mask) mask) new-len)
      (ash (car ,source) (- ,len (cdr ,source))))))

(defun bitstream-pop8 (source)
  (mk-bitstream-pop source 8))
(defun bitstream-pop1 (source)
  (mk-bitstream-pop source 1))

; ---

(defun read-number (instream)
  (let* ((right-mask (mk-mask 5))
         (first-byte (read-byte instream nil nil))
         (bytes-to-read (ash first-byte -5))
         (result (logand first-byte right-mask)))
    (loop for i from 1 to bytes-to-read
          for c = (read-byte instream nil nil)
          do (setq result (logior (ash result 8) c)))
    result))

(defun write-number (num outstream)
  (let ((n 0)
        (temp num))
    (loop while (> (integer-length temp) 5)
          do (setq temp (ash temp -8))
             (incf n))
    (write-byte (logior (ash n 5) temp) outstream)
    (loop for i from (- n 1) downto 0
          do (write-byte (logand (ash num (* i -8)) (mk-mask 8)) outstream))))

;; (with-open-file (outstream "test" :element-type '(unsigned-byte 8) :direction :output :if-exists :supersede)
;;   (write-number 31 outstream)
;;   (write-number 32 outstream)
;;   (write-number 1024 outstream)
;;   (write-number 1099511627776 outstream)
;;   )
;; ;
;; (with-open-file (instream "test" :element-type '(unsigned-byte 8) :direction :input)
;;   (format t "~%~d" (read-number instream))
;;   (format t "~%~d" (read-number instream))
;;   (format t "~%~d" (read-number instream))
;;   (format t "~%~d" (read-number instream))
;;   )

; ---

(defmacro stream-drain-bitstream (outstream bit-stream cmp)
  `(loop while (>= (cdr ,bit-stream) ,cmp)
         do (multiple-value-bind (new-bit-stream popped-byte) (bitstream-pop8 ,bit-stream)
              (setq ,bit-stream new-bit-stream)
              (write-byte popped-byte ,outstream))))

(defun encode (instream outstream)
  (file-position instream :start)
  (let ((canon (huffman2canon (freq2huffman (buffer-freq instream))))
        (encoding-map (make-hash-table)))
    (when (consp canon); if instream is empty, do mothing
      ;; Writing the header
      (write-byte (- (length canon) 1) outstream); write length of map (assuming 0 is unrepresentable)
      (loop for pair in canon
            do (progn
                 (write-byte (car pair) outstream); write the key
                 (write-byte (cdr (cdr pair)) outstream); write the code-length
                 (setf (gethash (car pair) encoding-map) (cdr pair))
                 ))
      ;; Writing the contents
      (file-position instream :start)
      (let ((bit-stream (cons 0 0)))
        (write-number (file-length instream) outstream)
        (loop for c = (read-byte instream nil nil)
              while c
              do (setq bit-stream (bitstream-push bit-stream (gethash c encoding-map)))
                 (stream-drain-bitstream outstream bit-stream 8))
        (stream-drain-bitstream outstream bit-stream 1)))))

(defun decode (instream outstream)
  (let ((canon (stream2canon instream))
        (decoding-map (make-hash-table :test #'equal)))
    (loop for pair in canon
          do (setf (gethash (cdr pair) decoding-map) (car pair)))
    (let ((len (read-number instream)) (source (cons 0 0)) (sink (cons 0 0)))
      (loop for i from 1 to len
            do (loop until (gethash sink decoding-map)
                     do (when (= (cdr source) 0)
                          (setq source (cons (read-byte instream) 8)))
                        (multiple-value-bind (new-source popped) (bitstream-pop1 source)
                          (setq source new-source)
                          (setq sink (bitstream-push sink (cons popped 1))))
                     finally (write-byte (gethash sink decoding-map) outstream)
                             (setq sink (cons 0 0)))))))

(defmacro with-stream-translate (in-filename out-filename &body body)
  `(with-open-file (instream ,in-filename :element-type '(unsigned-byte 8) :direction :input)
     (with-open-file (outstream ,out-filename :element-type '(unsigned-byte 8) :direction :output :if-exists :supersede)
       (progn ,@body))))

(defun main (&optional (args (or #+CLISP *args* #+SBCL *posix-argv* #+LISPWORKS system:*line-arguments-list* #+CMU extensions:*command-line-words* nil)))
  (with-stream-translate (nth 2 args) (nth 3 args)
    (funcall
     (case (intern (string-upcase (nth 1 args))) (e #'encode) (d #'decode))
     instream outstream)))

;(main (list "_" "e" "test-input.txt" "test-output.txt.hf"))
;(main (list "_" "d" "test-output.txt.hf" "test-output.txt"))

(setq uiop:*image-entry-point* #'main)
(uiop:dump-image "build/huffman" :executable t)