Working decoder on byte level

1 files changed, 55 insertions, 0 deletions

diff --git a/decode.lisp b/decode.lisp
new file mode 100644
index 0000000..df578a7
--- /dev/null
+++ b/decode.lisp
@@ -0,0 +1,55 @@
+(in-package #:lempel)
+
+(declaim (ftype (function ((array (unsigned-byte 8)) (unsigned-byte 8)) (array (unsigned-byte 8))) prefix-decode))
+(defun prefix-decode (data prefix)
+  (let ((result (queue:new)))
+    (dotimes (i (length data))
+      (cond ((= (elt data i) prefix)
+             (let ((point (byte-pair->point data i)))
+               (if (= (point-size point) 0)
+                 (progn
+                   (queue:push prefix result)
+                   (incf i))
+                 (progn
+                   (queue:push point result)
+                   (incf i 2)))))
+            (t (queue:push (elt data i) result))))
+    (decompress (queue:to-list result))))
+
+(declaim (ftype (function (list) (array (unsigned-byte 8))) decompress))
+(defun decompress (data)
+  (declare (optimize (debug 3)))
+  (let ((result (make-array (get-uncompressed-size data) :element-type '(unsigned-byte 8)))
+        (fill-count 0))
+    (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))
+             (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)))
+        (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))))
+
+(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))))
+    size))