summaryrefslogtreecommitdiffstats
path: root/Idiffer.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit302e3218b7d487539ec305bf23881a6ee7d5be99 (patch)
treebf1adafe552a17b3b78522048bb7c24787696dd3 /Idiffer.scm
parentc7d035ae1a729232579a0fe41ed5affa131d3623 (diff)
downloadscm-302e3218b7d487539ec305bf23881a6ee7d5be99.tar.gz
scm-302e3218b7d487539ec305bf23881a6ee7d5be99.zip
Import Upstream version 5e1upstream/5e1
Diffstat (limited to 'Idiffer.scm')
-rw-r--r--Idiffer.scm112
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))))