blob: df578a7e4afb074a719037b19b79b983b7639450 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
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))
|
