Import Upstream version 5e1upstream/5e1

1 files changed, 112 insertions, 0 deletions

diff --git a/Idiffer.scm b/Idiffer.scm
new file mode 100644
index 0000000..ee36485
--- /dev/null
+++ b/Idiffer.scm
@@ -0,0 +1,112 @@
+;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of SCM.
+;;
+;; The exception is that, if you link the SCM library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the SCM library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name SCM.  If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; SCM, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way.  To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for SCM, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; Linear-space O(PN) sequence comparison.
+;;; "Idiffer.scm" Top-level sequence-comparison functions.
+;;; Author: Aubrey Jaffer
+
+(define (diff:invert-edits! edits)
+  (define cost (car (array-dimensions edits)))
+  (do ((idx (+ -1 cost) (+ -1 idx)))
+      ((negative? idx))
+    (array-set! edits (- (array-ref edits idx)) idx)))
+
+(define (edits2lcs! lcs edits A)
+  (define cost (car (array-dimensions edits)))
+  (define len-a (car (array-dimensions A)))
+  (let loop ((edx 0)
+	     (sdx 0)
+	     (adx 0))
+    (let ((edit (if (< edx cost) (array-ref edits edx) 0)))
+      (cond ((>= adx len-a))
+	    ((positive? edit)
+	     (loop (+ 1 edx) sdx adx))
+	    ((zero? edit)
+	     (array-set! lcs (array-ref A adx) sdx)
+	     (loop edx (+ 1 sdx) (+ 1 adx)))
+	    ((>= adx (- -1 edit))
+	     (loop (+ 1 edx) sdx (+ 1 adx)))
+	    (else
+	     (array-set! lcs (array-ref A adx) sdx)
+	     (loop edx (+ 1 sdx) (+ 1 adx)))))))
+
+(define (diff:longest-common-subsequence A B . p-lim)
+  (define M (car (array-dimensions A)))
+  (define N (car (array-dimensions B)))
+  (set! p-lim (if (null? p-lim) -1 (car p-lim)))
+  (let ((edits (if (< N M)
+		   (diff:edits B A p-lim)
+		   (diff:edits A B p-lim))))
+    (and edits
+	 (let* ((cost (car (array-dimensions edits)))
+		(lcs (make-array A (/ (- (+ N M) cost) 2))))
+	   (edits2lcs! lcs edits (if (< N M) B A))
+	   lcs))))
+
+(define (diff:edits A B . p-lim)
+  (define M (car (array-dimensions A)))
+  (define N (car (array-dimensions B)))
+  (set! p-lim (if (null? p-lim) -1 (car p-lim)))
+  (let ((fp (make-array (A:fixZ32b) (if (negative? p-lim)
+					(+ 3 M N)
+					(+ 3 (abs (- N M)) p-lim p-lim)))))
+    (define est (if (< N M)
+		    (diff2editlen fp B A p-lim)
+		    (diff2editlen fp A B p-lim)))
+    (and est
+	 (let ((edits (make-array (A:fixZ32b) est))
+	       (CCRR (make-array (A:fixZ32b) (* 2 (+ (max M N) 1)))))
+	   (cond ((< N M)
+		  (diff2edits! edits fp CCRR B A)
+		  (diff:invert-edits! edits))
+		 (else
+		  (diff2edits! edits fp CCRR A B)))
+	   edits))))
+
+(define (diff:edit-length A B . p-lim)
+  (define M (car (array-dimensions A)))
+  (define N (car (array-dimensions B)))
+  (set! p-lim (if (null? p-lim) -1 (car p-lim)))
+  (let ((fp (make-array (A:fixZ32b) (if (negative? p-lim)
+					(+ 3 M N)
+					(+ 3 (abs (- N M)) p-lim p-lim)))))
+    (if (< N M)
+	(diff2editlen fp B A p-lim)
+	(diff2editlen fp A B p-lim))))