blob: 2a50828217737e20be416209239374e670c81209 (
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
56
57
|
(in-package #:lempel)
(declaim (ftype (function (point) (cons (unsigned-byte 8))) point->bytes))
(defun point->bytes (p)
(let ((window-width (1- (ash 1 window-bits))))
(let ((offset (logand (point-offset p) #xff))
(size (logior (ash (logand (point-offset p)
(logxor window-width #xff))
(- 8 window-bits))
(point-size p))))
(if reversed-byte-order
(cons size offset)
(cons offset size)))))
(defun prefix-encode (data prefix)
(let ((result '()))
(dolist (point data)
(cond ((characterp point)
(push (char-code point) result))
((point-p point)
(push prefix result)
(let ((encoded-pair (point->bytes point)))
(push (car encoded-pair) result)
(push (cdr encoded-pair) result)))
(t (error "Invalid point type"))))
(make-array (length result)
:element-type '(unsigned-byte 8)
:initial-contents (reverse result))))
(defun compress (data)
(let ((result '())
(window-width (1- (ash 1 window-bits))))
(dotimes (cursor (length data))
(let* ((window-start (max 0 (- cursor window-width)))
(match (search-window data window-start cursor)))
(if match
(progn
(push match result)
(incf cursor (1- (point-size match))))
(push (elt data cursor) result))))
(reverse result)))
(defun search-window (data start end)
(let ((offset 0)
(size 0)
(max-word-length (1- (ash 1 (- 16 window-bits)))))
(do ((i (min (1+ end) (1- (length data))) (1+ i)))
((let ((match (search data data :start1 end :end1 i :start2 start :end2 end)))
(when match
(setf offset (- end match))
(setf size (- i end)))
(or (not match)
(>= size max-word-length)
(> i (1- (length data)))))
(if (>= size break-even-threshold)
(make-point :offset offset :size size)
nil)))))
|
