diff options
Diffstat (limited to 'decode.lisp')
| -rw-r--r-- | decode.lisp | 73 |
1 files changed, 50 insertions, 23 deletions
diff --git a/decode.lisp b/decode.lisp index df578a7..d569f6f 100644 --- a/decode.lisp +++ b/decode.lisp @@ -1,55 +1,82 @@ (in-package #:lempel) -(declaim (ftype (function ((array (unsigned-byte 8)) (unsigned-byte 8)) (array (unsigned-byte 8))) prefix-decode)) +(declaim (optimize (debug 3) (safety 3))) + +(declaim (ftype (function ((array (unsigned-byte 8)) (unsigned-byte 8)) (array (unsigned-byte 1))) prefix-decode)) (defun prefix-decode (data prefix) - (let ((result (queue:new))) + (let ((bits (make-array (* 8 (length data)) :element-type '(unsigned-byte 1))) + (result (queue:new)) + (point-count 0)) (dotimes (i (length data)) - (cond ((= (elt data i) prefix) - (let ((point (byte-pair->point data i))) + (byte->bits (elt data i) bits (* 8 i))) + (do ((i 0)) ((>= i (length bits)) nil) + (cond ((and (<= i (- (length bits) 8)) + (= (bits->byte bits i) prefix)) + (incf point-count) + (let ((point (byte-pair->point (bits->byte bits (+ i 8)) + (bits->byte bits (+ i 16))))) (if (= (point-size point) 0) (progn - (queue:push prefix result) - (incf i)) + (let ((prefix-bits (make-array 8 :element-type '(unsigned-byte 1)))) + (byte->bits prefix prefix-bits 0) + (dotimes (j 8) + (queue:push (elt prefix-bits j) result)) + (incf i 16))) (progn (queue:push point result) - (incf i 2))))) - (t (queue:push (elt data i) result)))) + (incf i 24))))) + (t (queue:push (elt bits i) result) + (incf i)))) + (format t "point count: ~a~&" point-count) (decompress (queue:to-list result)))) -(declaim (ftype (function (list) (array (unsigned-byte 8))) decompress)) +(declaim (ftype (function (list) (array (unsigned-byte 1))) decompress)) (defun decompress (data) - (declare (optimize (debug 3))) - (let ((result (make-array (get-uncompressed-size data) :element-type '(unsigned-byte 8))) + (let ((result (make-array (get-uncompressed-size data) :element-type '(unsigned-byte 1))) (fill-count 0)) + (format t "uncompressed size: ~a~&" (length result)) (dolist (point data) (cond ((point-p point) (let ((start (- fill-count (point-offset point)))) (dotimes (j (point-size point)) (setf (elt result (+ fill-count j)) (elt result (+ start j)))) (incf fill-count (point-size point)))) - ((typep point '(unsigned-byte 8)) + ((typep point '(unsigned-byte 1)) (setf (elt result fill-count) point) (incf fill-count)) (t (error (format nil "cannot handle type ~a" (type-of point)))))) (assert (= fill-count (length result))) result)) -(declaim (ftype (function ((array (unsigned-byte 8)) fixnum) point) byte-pair->point)) -(defun byte-pair->point (bytes index) - (let ((offset (elt bytes (+ (if reversed-byte-order 2 1) index))) - (size (elt bytes (+ (if reversed-byte-order 1 2) index))) +(declaim (ftype (function ((unsigned-byte 8) (unsigned-byte 8)) point) byte-pair->point)) +(defun byte-pair->point (b1 b2) + (let ((offset (if reversed-byte-order b2 b1)) + (size (if reversed-byte-order b1 b2)) (max-word-length (1- (ash 1 (- 16 window-bits))))) - (make-point :offset (logior offset - (ash (logand size (logxor #xff max-word-length)) - (- window-bits 8))) - :size (logand size max-word-length)))) + (make-point :offset (* 8 (logior offset + (ash (logand size (logxor #xff max-word-length)) + (- window-bits 8)))) + :size (* 8 (logand size max-word-length))))) (declaim (ftype (function (list) fixnum) get-uncompressed-size)) (defun get-uncompressed-size (data) (let ((size 0)) (dolist (point data) (cond ((point-p point) - (incf size (point-size point))) - (t - (incf size)))) + (if (= (point-size point) 0) + (incf size 8) + (incf size (point-size point)))) + (t (incf size)))) size)) + +(declaim (ftype (function ((array (unsigned-byte 1)) fixnum) (unsigned-byte 8)) bits->byte)) +(defun bits->byte (data index) + (let ((byte 0)) + (dotimes (i 8) + (setf byte (logior byte (ash (elt data (+ index i)) (- 7 i))))) + byte)) + +(declaim (ftype (function ((unsigned-byte 8) (array (unsigned-byte 1)) fixnum)) byte->bits)) +(defun byte->bits (data bits index) + (dotimes (i 8) + (setf (elt bits (+ index i)) (ash (logand data (ash 1 (- 7 i))) (- i 7))))) |