Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Browse files

Adding SPLIT-VECTOR function.

  • Loading branch information...
commit 7a6cac027efae7e75d8e53a6ec8665fdb7af54c5 1 parent 6bf2887
@gigamonkey authored
Showing with 63 additions and 12 deletions.
  1. +26 −0 diff.lisp
  2. +24 −12 lcs.lisp
  3. +13 −0 utilities.lisp
26 diff.lisp
@@ -71,7 +71,33 @@ Optionally frob the computed LCS before computing the diff."
(let ((diff (diff-vectors a b #'collapse-spaces-in-lcs)))
(remove-if #'empty-delete? (map-into diff #'translate-textified diff)))))
+(defun split-positions (one-chunk parts)
+ "Find the positions where one-chunk should be split to get pieces
+ corresponding to the given parts, which are derived from one-chunk.
+ For instance, if one-chunk is a piece of text that was split up and
+ the pieces inserted at various places in the new document, it will
+ show up as a single deletion in the diff and multiple additions. Or
+ conversely, if a bunch of separate pieces (from different
+ paragraphs) in the original document were combined into contiguous
+ text in the edited document, we would have a single addition and
+ multiple deletions."
+ (multiple-value-bind (one-chunk-lcs-indices combined-lcs-indices)
+ (lcs-positions one-chunk (concatenate-vectors parts))
+ (setf one-chunk-lcs-indices (coerce one-chunk-lcs-indices 'vector))
+ (setf combined-lcs-indices (coerce combined-lcs-indices 'vector))
+ (loop for s in (part-starts parts)
+ for prev-x = 0 then x
+ for x = (position-if (lambda (x) (>= x s)) combined-lcs-indices :start prev-x)
+ collect (aref one-chunk-lcs-indices x))))
+(defun split-vector (one-chunk parts)
+ (loop for (start end) on (split-positions one-chunk parts)
+ collect (subseq one-chunk start end)))
+(defun part-starts (parts)
+ (loop for (p . rest) on parts
+ summing (length p) into total
+ when rest collect total into starts
+ finally (return (cons 0 starts))))
36 lcs.lisp
@@ -2,26 +2,38 @@
(defun lcs (a b)
"Compute the longest common subsequence of vectors `a' and `b'"
- (let ((table (%lcs-table a b))
- (lcs ())
- (i (length a))
- (j (length b)))
+ (extract-lcs a (lcs-positions a b)))
+(defun lcs-positions (a b)
+ "Find the indices in a and b of the elements of the LCS."
+ (multiple-value-bind (table m n) (%lcs-table a b)
+ (let* ((len (aref table n m))
+ (a-indices (make-array len))
+ (b-indices (make-array len))
+ (idx (1- len))
+ (i (length a))
+ (j (length b)))
(loop while (> (aref table j i) 0) do
(let* ((current (aref table j i))
(previous (1- current)))
- ((and (eql previous (aref table (1- j) (1- i)))
- (eql previous (aref table j (1- i)))
- (eql previous (aref table (1- j) i)))
- (push (aref a (1- i)) lcs)
+ ((and (= previous (aref table (1- j) (1- i)))
+ (= previous (aref table j (1- i)))
+ (= previous (aref table (1- j) i)))
(decf j)
- (decf i))
- ((eql current (aref table (1- j) i)) (decf j))
- ((eql current (aref table j (1- i))) (decf i))
+ (decf i)
+ (setf (aref a-indices idx) i)
+ (setf (aref b-indices idx) j)
+ (decf idx))
+ ((= current (aref table (1- j) i)) (decf j))
+ ((= current (aref table j (1- i))) (decf i))
(t (error "Assertion gone haywire: ~s ~s" j i)))))
- (coerce lcs 'vector)))
+ (values a-indices b-indices))))
+(defun extract-lcs (v indices)
+ (map 'vector (lambda (i) (aref v i)) indices))
(defun lcs-length (a b)
"Compute the length of the longest common subsequence of vectors `a' and `b'"
13 utilities.lisp
@@ -4,6 +4,17 @@
;;; com.gigamonkeys.utilities or replaced with calls to equivalent
;;; bits o fsome standard utility library.
+(defun maximum (list &key (key #'identity))
+ (destructuring-bind (first . rest) list
+ (loop with best-score = (funcall key first)
+ with best = first
+ for x in rest
+ for score = (funcall key x) do
+ (when (> score best-score)
+ (setf best-score score)
+ (setf best x))
+ finally (return best))))
(defun take (list n)
"Return a list of of the first n values of list and the left-over
tail as a secondary value."
@@ -26,4 +37,6 @@ tail as a secondary value."
(t (longer (cdr list-a) (cdr list-b)))))
+(defun concatenate-vectors (vectors)
+ (reduce (lambda (a b) (concatenate (class-of a) a b)) vectors))

0 comments on commit 7a6cac0

Please sign in to comment.
Something went wrong with that request. Please try again.