aland/huffman.lisp
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

instead of many blocks of length 1-256, one block of length up to 2^61

Browse source
This commit is contained in:
Alan Daniels 2026-01-27 20:41:43 +11:00
parent c079da575d
commit 670d584204
1 changed files with 65 additions and 47 deletions
Download patch file Download diff file Expand all files Collapse all files

112
huffman.lisp
View file

@ -97,34 +97,47 @@
; --- ; ---
(defmacro buf-drain-bitstream (buf bit-stream cmp) (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) `(loop while (>= (cdr ,bit-stream) ,cmp)
do (multiple-value-bind (new-bit-stream popped-byte) (bitstream-pop8 ,bit-stream) do (multiple-value-bind (new-bit-stream popped-byte) (bitstream-pop8 ,bit-stream)
(setq ,bit-stream new-bit-stream) (setq ,bit-stream new-bit-stream)
(push popped-byte ,buf)))) (write-byte popped-byte ,outstream))))
(defmacro build-encoded-message-block (encoding-map instream buf bit-stream)
`(loop
for i from 0 to 255
for c = (read-byte ,instream nil nil)
while c
do (setq ,bit-stream (bitstream-push ,bit-stream (gethash c ,encoding-map)))
do (buf-drain-bitstream ,buf ,bit-stream 8)
finally (return i)))
(defmacro write-encoded-message-block (encoding-map instream outstream)
`(let* ((bit-stream (cons 0 0))
(buf (list))
(len (build-encoded-message-block ,encoding-map ,instream buf bit-stream)))
(buf-drain-bitstream buf bit-stream 1)
(when (> len 0)
(write-byte (- len 1) ,outstream)
(write-sequence (reverse buf) ,outstream)
)
len))
(defmacro write-encoded-message (encoding-map instream outstream)
`(loop for blk-count from 1 while (= 256 (write-encoded-message-block ,encoding-map ,instream ,outstream)) finally (return blk-count)))
(defun encode (instream outstream) (defun encode (instream outstream)
(file-position instream :start) (file-position instream :start)
@ -141,7 +154,14 @@
)) ))
;; Writing the contents ;; Writing the contents
(file-position instream :start) (file-position instream :start)
(write-encoded-message encoding-map instream outstream) (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)))
do (stream-drain-bitstream outstream bit-stream 8))
(stream-drain-bitstream outstream bit-stream 1)
)
))) )))
(defun decode (instream outstream) (defun decode (instream outstream)
@ -149,23 +169,20 @@
(decoding-map (make-hash-table :test #'equal))) (decoding-map (make-hash-table :test #'equal)))
(loop for pair in canon (loop for pair in canon
do (setf (gethash (cdr pair) decoding-map) (car pair))) do (setf (gethash (cdr pair) decoding-map) (car pair)))
(loop for len = (read-byte instream nil nil) (let ((len (read-number instream)) (source (cons 0 0)) (sink (cons 0 0)))
while len (loop for i from 1 to len
do (let ((source (cons 0 0))) do
(write-sequence (loop until (gethash sink decoding-map)
(loop for k from 0 to len do (progn
collect (let ((sink (cons 0 0))) (when (= (cdr source) 0)
(loop until (gethash sink decoding-map) (setq source (cons (read-byte instream) 8)))
do (progn (multiple-value-bind (new-source popped) (bitstream-pop1 source)
(when (= (cdr source) 0) (setq source new-source)
(setq source (cons (read-byte instream) 8))) (setq sink (bitstream-push sink (cons popped 1)))))
(multiple-value-bind (new-source popped) (bitstream-pop1 source) finally (write-byte (gethash sink decoding-map) outstream)
(setq source new-source) (setq sink (cons 0 0)))
(setq sink (bitstream-push sink (cons popped 1)))) )
) )
finally (return (gethash sink decoding-map)))))
outstream)
))
)) ))
(defmacro with-stream-translate (in-filename out-filename &body body) (defmacro with-stream-translate (in-filename out-filename &body body)
@ -176,10 +193,11 @@
(defun main (&optional (args (or #+CLISP *args* #+SBCL *posix-argv* #+LISPWORKS system:*line-arguments-list* #+CMU extensions:*command-line-words* nil))) (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) (with-stream-translate (nth 2 args) (nth 3 args)
(funcall (funcall
(case (intern (string-upcase (nth 1 args))) ('e #'encode) ('d #'decode)) (case (intern (string-upcase (nth 1 args))) (e #'encode) (d #'decode))
instream outstream))) instream outstream)))
;(main (list "_" "e" "test-input.txt" "test-output.txt.hf")) ;(main (list "_" "e" "test-input.txt" "test-output.txt.hf"))
;(main (list "_" "d" "test-output.txt.hf" "test-output.txt")) ;(main (list "_" "d" "test-output.txt.hf" "test-output.txt"))
(setq uiop:*image-entry-point* #'main) ;; (setq uiop:*image-entry-point* #'main)
(uiop:dump-image "build/huffman" :executable t) ;; (uiop:dump-image "build/huffman" :executable t)