Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

193 lines (175 sloc) 7.944 kB
;;;; vdelta.lisp - computing copy/insert deltas with the vdelta algorithm
(in-package :diff)
(defconstant +buffer-size+ 1024)
(deftype op-kind () '(member :copy-target :copy-source :new-data))
(deftype bytebuf () '(simple-array (unsigned-byte 8) (*)))
;;; a convenience class for writing byte buffers
(defclass byte-buffer-stream (trivial-gray-streams:fundamental-binary-output-stream)
((buffer :accessor buffer :initarg :buffer :type bytebuf)
(index :accessor index :initform 0 :type fixnum)))
(defmethod trivial-gray-streams:stream-write-byte ((stream byte-buffer-stream) byte)
(with-slots (buffer index) stream
(when (>= index (length buffer))
(error "Cannot write any more data to stream!"))
(setf (aref buffer index) byte)
(incf index)
byte))
(defmacro with-binary-file ((stream-name pathname direction) &body body)
"A wrapper for WITH-OPEN-FILE that opens the stream with an element-type
of (UNSIGNED-BYTE 8). DIRECTION is passed as the argument to :DIRECTION."
`(with-open-file (,stream-name ,pathname
:direction ,direction
:element-type '(unsigned-byte 8))
,@body))
(defstruct svndiff-window
(source-offset 0 :type (unsigned-byte 32))
(source-len 0 :type (unsigned-byte 32))
(target-len 0 :type (unsigned-byte 32))
(ops (error "required argument") :type bytebuf)
(new-data (error "required argument") :type bytebuf))
(defstruct (svndiff-op
(:constructor make-svndiff-op (kind offset bytes)))
(kind :new-data :type op-kind)
(offset 0 :type (unsigned-byte 32))
(bytes 0 :type (unsigned-byte 32)))
(defun match-length (seq1 start1 end1 seq2 start2 end2)
(declare (type bytebuf seq1 seq2))
(declare (type fixnum start1 end1 start2 end2))
(do ((index1 start1 (1+ index1))
(index2 start2 (1+ index2)))
((or (= index1 end1) (= index2 end2))
(- index1 start1))
(declare (type fixnum index1 index2))
(when (/= (aref seq1 index1) (aref seq2 index2))
(return (- index1 start1)))))
(defun string-to-byteseq (string)
"Convert STRING to an array of (UNSIGNED-BYTE 8). Assumes that the
Common Lisp implementation is underpinned with 8-bit characters."
(let ((buf (make-array (length string)
:element-type '(unsigned-byte 8))))
(map-into buf #'char-code string)))
;;; vdelta calculation
(declaim (inline combine-bytes))
(defun combine-bytes (byteseq start)
(declare (type bytebuf byteseq))
(let ((int 0))
(dotimes (i 4)
(setf int (logior int
(ash (aref byteseq (+ start i))
(* 8 i)))))
int))
(defclass vdelta-context ()
((buffer :initform (make-array (* 2 +buffer-size+) :element-type '(unsigned-byte 8))
:reader buffer)
(source-start :initform 0
:accessor source-start)
(source-length :initform 0
:accessor source-length)
(target-start :initform 0
:accessor target-start)
(target-length :initform 0
:accessor target-length)
(table :initform (make-hash-table :test #'eql)
:accessor table)))
(defun key-to-chars (key)
(with-output-to-string (stream)
(flet ((char-at (pos)
(code-char (ldb (byte 8 pos) key))))
(format stream "~A~A~A~A"
(char-at 0) (char-at 8) (char-at 16) (char-at 24)))))
(defun print-match-table (table)
(with-hash-table-iterator (fn table)
(loop
(multiple-value-bind (more-p key value) (fn)
(unless more-p (return))
(format t "~A: ~A~%" (key-to-chars key) value)))))
(defun initialize-match-table (context)
(let ((buffer (buffer context))
(start (source-start context))
(length (source-length context))
(table (table context)))
(declare (type bytebuf buffer))
(do ((i start (1+ i)))
((>= i (- length 3)) (print-match-table table))
(let ((key (combine-bytes buffer i)))
(multiple-value-bind (index presentp) (gethash key table)
(if (not presentp)
(setf (gethash key table) i)
(let ((match-length (match-length buffer i length
buffer index length)))
(dotimes (j 3)
(let ((insert-index (+ start (- match-length 1 j))))
(setf (gethash (combine-bytes buffer insert-index)
table)
insert-index)))
(assert (> match-length 0))
(incf i match-length))))))))
(defun calculate-svndiff-ops (context)
(let ((buffer (buffer context))
(source-start (source-start context))
(source-length (source-length context))
(target-start (target-start context))
(target-length (target-length context))
(target-end (+ (target-start context) (target-length context)))
(table (table context))
(add-start -1)
(add-length 0)
(instructions nil))
(declare (type bytebuf buffer)
(type fixnum source-length target-length add-start add-length))
(flet ((push-new-data (index)
(when (= -1 add-start)
(setf add-start index))
(incf add-length))
(add-data-insn ()
(when (not (= -1 add-start))
(push (make-svndiff-op :new-data add-start add-length)
instructions)
(setf add-start -1 add-length 0)))
(add-copy-insn (index len)
(let* ((targetp (>= index source-length))
(op-kind (if targetp :copy-target :copy-source))
(offset index))
(push (make-svndiff-op op-kind offset len)
instructions))))
(do ((i target-start (1+ i)))
((>= i target-end))
;; pick up any stragglers at the end of the string
(cond
((<= (- target-end 3) i) (push-new-data i))
(t
(let ((key (combine-bytes buffer i)))
(format t "Key: ~A~%" (key-to-chars key))
(multiple-value-bind (index presentp) (gethash key table)
(if (not presentp)
(progn
(push-new-data i)
;; record a new position index
(setf (gethash key table) i))
(flet ((find-diff-loc ()
(if (>= index source-length)
;; a index in version2
(values (match-length buffer i target-end
buffer index target-end)
t)
(values (match-length buffer index source-length
buffer i target-end)
nil))))
(format t "i: ~A, index: ~A~%" i index)
;; clear any pending additions
(add-data-insn)
(multiple-value-bind (match-length targetp) (find-diff-loc)
(format t "match-length: ~A, ~A~%" match-length targetp)
(assert (> match-length 0))
(when targetp
(dotimes (j 3)
(let ((insert-index (+ target-start
(- match-length j))))
(assert (>= insert-index target-start))
(setf (gethash (combine-bytes buffer insert-index)
table)
insert-index))))
(add-copy-insn index match-length)
(incf i (1- match-length))))))))))
(add-data-insn)
(nreverse instructions))))
Jump to Line
Something went wrong with that request. Please try again.