1 files changed, 57 insertions, 0 deletions
diff --git a/encode.lisp b/encode.lisp
new file mode 100644
index 0000000..2a50828
--- /dev/null
+++ b/encode.lisp
@@ -0,0 +1,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)))))