Add LCS-based diff algorithm (#33)
ober
5ddbe76d5c5ca3a31b44dadaec076ec958ce8ed6
new file mode 100644 --- /dev/null +++ b/lib/std/misc/diff.sls @@ -0,0 +1,163 @@ +#!chezscheme +;;; (std misc diff) — LCS-based diff algorithm +;;; +;;; (diff '(a b c) '(b c d)) => ((remove a) (same b) (same c) (add d)) +;;; (edit-distance '(a b c) '(b c d)) => 2 +;;; (lcs '(a b c d) '(b d f)) => (b d) + +(library (std misc diff) + (export diff diff-strings edit-distance lcs diff->string diff-report) + (import (chezscheme)) + + ;; Compute the longest common subsequence of two lists. + ;; Uses a DP table approach. Returns the LCS as a list. + (define lcs + (case-lambda + [(xs ys) (lcs xs ys equal?)] + [(xs ys =?) + (let* ([xv (list->vector xs)] + [yv (list->vector ys)] + [m (vector-length xv)] + [n (vector-length yv)] + ;; dp is (m+1) x (n+1) table storing LCS lengths + [dp (make-vector (* (+ m 1) (+ n 1)) 0)]) + (define (ref i j) + (vector-ref dp (+ (* i (+ n 1)) j))) + (define (set! i j v) + (vector-set! dp (+ (* i (+ n 1)) j) v)) + ;; Fill the DP table bottom-up + (let loop-i ([i (- m 1)]) + (when (>= i 0) + (let loop-j ([j (- n 1)]) + (when (>= j 0) + (if (=? (vector-ref xv i) (vector-ref yv j)) + (set! i j (+ 1 (ref (+ i 1) (+ j 1)))) + (set! i j (max (ref (+ i 1) j) (ref i (+ j 1))))) + (loop-j (- j 1)))) + (loop-i (- i 1)))) + ;; Backtrack to recover the LCS + (let backtrack ([i 0] [j 0] [acc '()]) + (cond + [(or (= i m) (= j n)) + (reverse acc)] + [(=? (vector-ref xv i) (vector-ref yv j)) + (backtrack (+ i 1) (+ j 1) (cons (vector-ref xv i) acc))] + [(> (ref (+ i 1) j) (ref i (+ j 1))) + (backtrack (+ i 1) j acc)] + [else + (backtrack i (+ j 1) acc)])))])) + + ;; Compute the diff between two lists, returning a list of edit operations: + ;; (same val) — element present in both + ;; (add val) — element added (in ys but not xs) + ;; (remove val) — element removed (in xs but not ys) + (define diff + (case-lambda + [(xs ys) (diff xs ys equal?)] + [(xs ys =?) + (let ([common (lcs xs ys =?)]) + ;; Walk xs, ys, and the LCS simultaneously to produce edit ops + (let loop ([xs xs] [ys ys] [cs common] [acc '()]) + (cond + ;; LCS exhausted — remaining xs are removals, remaining ys are additions + [(null? cs) + (let ([removes (map (lambda (x) (list 'remove x)) xs)] + [adds (map (lambda (y) (list 'add y)) ys)]) + (reverse (append (reverse adds) (reverse removes) acc)))] + ;; Current x matches LCS head — but check if y also matches + [(and (not (null? xs)) (=? (car xs) (car cs))) + (if (and (not (null? ys)) (=? (car ys) (car cs))) + ;; Both match LCS — it's a 'same' + (loop (cdr xs) (cdr ys) (cdr cs) + (cons (list 'same (car cs)) acc)) + ;; y doesn't match LCS — it's an addition, keep going + (if (null? ys) + (loop xs ys cs acc) + (loop xs (cdr ys) cs + (cons (list 'add (car ys)) acc))))] + ;; Current x doesn't match LCS — it's a removal + [(not (null? xs)) + (loop (cdr xs) ys cs + (cons (list 'remove (car xs)) acc))] + ;; xs exhausted but ys remain — additions + [(not (null? ys)) + (loop xs (cdr ys) cs + (cons (list 'add (car ys)) acc))] + [else + (reverse acc)])))])) + + ;; Compute the Levenshtein edit distance between two lists. + (define edit-distance + (case-lambda + [(xs ys) (edit-distance xs ys equal?)] + [(xs ys =?) + (let* ([xv (list->vector xs)] + [yv (list->vector ys)] + [m (vector-length xv)] + [n (vector-length yv)] + [dp (make-vector (* (+ m 1) (+ n 1)) 0)]) + (define (ref i j) + (vector-ref dp (+ (* i (+ n 1)) j))) + (define (set! i j v) + (vector-set! dp (+ (* i (+ n 1)) j) v)) + ;; Base cases + (let init-i ([i 0]) + (when (<= i m) + (set! i 0 i) + (init-i (+ i 1)))) + (let init-j ([j 0]) + (when (<= j n) + (set! 0 j j) + (init-j (+ j 1)))) + ;; Fill DP table + (let loop-i ([i 1]) + (when (<= i m) + (let loop-j ([j 1]) + (when (<= j n) + (if (=? (vector-ref xv (- i 1)) (vector-ref yv (- j 1))) + (set! i j (ref (- i 1) (- j 1))) + (set! i j (+ 1 (min (ref (- i 1) j) + (ref i (- j 1)) + (ref (- i 1) (- j 1)))))) + (loop-j (+ j 1)))) + (loop-i (+ i 1)))) + (ref m n))])) + + ;; Format a diff as a unified-diff-style string with +/- prefixes. + ;; Each edit op becomes a line: " val" for same, "+val" for add, "-val" for remove. + (define (diff->string ops) + (let ([port (open-output-string)]) + (for-each + (lambda (op) + (let ([tag (car op)] + [val (cadr op)]) + (case tag + [(same) (display " " port) (display val port) (newline port)] + [(add) (display "+" port) (display val port) (newline port)] + [(remove) (display "-" port) (display val port) (newline port)]))) + ops) + (get-output-string port))) + + ;; Pretty-print a diff to current-output-port. + (define (diff-report ops) + (display (diff->string ops))) + + ;; Split a string into lines by newline character. + (define (string-split-lines s) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(= i (string-length s)) + (reverse (cons (substring s start i) acc))] + [(char=? (string-ref s i) #\newline) + (loop (+ i 1) (+ i 1) (cons (substring s start i) acc))] + [else + (loop (+ i 1) start acc)]))) + + ;; Diff two strings line-by-line. Returns a formatted diff string. + (define (diff-strings s1 s2) + (let* ([lines1 (string-split-lines s1)] + [lines2 (string-split-lines s2)] + [ops (diff lines1 lines2 string=?)]) + (diff->string ops))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-diff.ss @@ -0,0 +1,206 @@ +#!/usr/bin/env scheme-script +#!chezscheme +(import (chezscheme) + (std misc diff)) + +(define test-count 0) +(define pass-count 0) + +(define (test name thunk) + (set! test-count (+ test-count 1)) + (guard (e [#t (display "FAIL: ") (display name) (newline) + (display " Error: ") (display (condition-message e)) (newline)]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert-equal + (string-append msg ": expected " (format "~s" expected) + " got " (format "~s" actual))))) + +;;; --- LCS tests --- + +(test "lcs: both empty" + (lambda () + (assert-equal (lcs '() '()) '() "lcs of empty lists"))) + +(test "lcs: one empty" + (lambda () + (assert-equal (lcs '(a b c) '()) '() "lcs with empty second") + (assert-equal (lcs '() '(a b c)) '() "lcs with empty first"))) + +(test "lcs: identical" + (lambda () + (assert-equal (lcs '(a b c) '(a b c)) '(a b c) "lcs of identical"))) + +(test "lcs: no common" + (lambda () + (assert-equal (lcs '(a b) '(c d)) '() "lcs with no common"))) + +(test "lcs: partial overlap" + (lambda () + (assert-equal (lcs '(a b c d) '(b d f)) '(b d) "lcs partial"))) + +(test "lcs: interleaved" + (lambda () + (let ([result (lcs '(a b c d e) '(a c e))]) + (assert-equal result '(a c e) "lcs interleaved")))) + +(test "lcs: custom equality" + (lambda () + (assert-equal (lcs '(1 2 3) '(1.0 2.0 3.0) =) '(1 2 3) + "lcs with numeric ="))) + +;;; --- diff tests --- + +(test "diff: both empty" + (lambda () + (assert-equal (diff '() '()) '() "diff of empty"))) + +(test "diff: identical lists" + (lambda () + (assert-equal (diff '(a b c) '(a b c)) + '((same a) (same b) (same c)) + "diff identical"))) + +(test "diff: complete removal" + (lambda () + (assert-equal (diff '(a b c) '()) + '((remove a) (remove b) (remove c)) + "diff all removed"))) + +(test "diff: complete addition" + (lambda () + (assert-equal (diff '() '(x y z)) + '((add x) (add y) (add z)) + "diff all added"))) + +(test "diff: complete replacement" + (lambda () + (assert-equal (diff '(a b) '(x y)) + '((remove a) (remove b) (add x) (add y)) + "diff complete replace"))) + +(test "diff: insertion at beginning" + (lambda () + (assert-equal (diff '(b c) '(a b c)) + '((add a) (same b) (same c)) + "diff insert at start"))) + +(test "diff: insertion at end" + (lambda () + (assert-equal (diff '(a b) '(a b c)) + '((same a) (same b) (add c)) + "diff insert at end"))) + +(test "diff: deletion from middle" + (lambda () + (assert-equal (diff '(a b c) '(a c)) + '((same a) (remove b) (same c)) + "diff remove middle"))) + +(test "diff: mixed changes" + (lambda () + (let ([result (diff '(a b c d e) '(a c d f))]) + ;; a is same, b removed, c same, d same, e removed, f added + (assert-equal result + '((same a) (remove b) (same c) (same d) (remove e) (add f)) + "diff mixed")))) + +(test "diff: custom equality" + (lambda () + (let ([result (diff '(1 2 3) '(1.0 3.0 4.0) =)]) + (assert-equal result + '((same 1) (remove 2) (same 3) (add 4.0)) + "diff with numeric =")))) + +;;; --- edit-distance tests --- + +(test "edit-distance: both empty" + (lambda () + (assert-equal (edit-distance '() '()) 0 "edit-dist empty"))) + +(test "edit-distance: one empty" + (lambda () + (assert-equal (edit-distance '(a b c) '()) 3 "edit-dist from non-empty") + (assert-equal (edit-distance '() '(a b c)) 3 "edit-dist to non-empty"))) + +(test "edit-distance: identical" + (lambda () + (assert-equal (edit-distance '(a b c) '(a b c)) 0 "edit-dist identical"))) + +(test "edit-distance: single insertion" + (lambda () + (assert-equal (edit-distance '(a b) '(a b c)) 1 "edit-dist insert one"))) + +(test "edit-distance: single deletion" + (lambda () + (assert-equal (edit-distance '(a b c) '(a b)) 1 "edit-dist delete one"))) + +(test "edit-distance: substitution" + (lambda () + (assert-equal (edit-distance '(a b c) '(a x c)) 1 "edit-dist substitute"))) + +(test "edit-distance: complete replacement" + (lambda () + (assert-equal (edit-distance '(a b) '(x y)) 2 "edit-dist full replace"))) + +(test "edit-distance: custom equality" + (lambda () + (assert-equal (edit-distance '(1 2 3) '(1.0 2.0 3.0) =) 0 + "edit-dist with numeric ="))) + +;;; --- diff->string tests --- + +(test "diff->string: formats correctly" + (lambda () + (let ([result (diff->string '((same a) (remove b) (add c)))]) + (assert-equal result " a\n-b\n+c\n" "diff->string format")))) + +(test "diff->string: empty diff" + (lambda () + (assert-equal (diff->string '()) "" "diff->string empty"))) + +;;; --- diff-report tests --- + +(test "diff-report: prints to stdout" + (lambda () + (let ([output (with-output-to-string + (lambda () (diff-report '((same x) (add y)))))]) + (assert-equal output " x\n+y\n" "diff-report output")))) + +;;; --- diff-strings tests --- + +(test "diff-strings: identical strings" + (lambda () + (let ([result (diff-strings "hello\nworld" "hello\nworld")]) + (assert-equal result " hello\n world\n" "diff-strings identical")))) + +(test "diff-strings: line added" + (lambda () + (let ([result (diff-strings "a\nb" "a\nb\nc")]) + (assert-equal result " a\n b\n+c\n" "diff-strings add line")))) + +(test "diff-strings: line removed" + (lambda () + (let ([result (diff-strings "a\nb\nc" "a\nc")]) + (assert-equal result " a\n-b\n c\n" "diff-strings remove line")))) + +(test "diff-strings: line changed" + (lambda () + (let ([result (diff-strings "a\nb\nc" "a\nx\nc")]) + (assert-equal result " a\n-b\n+x\n c\n" "diff-strings change line")))) + +(test "diff-strings: empty strings" + (lambda () + (let ([result (diff-strings "" "")]) + (assert-equal result " \n" "diff-strings empty")))) + +(newline) +(display "=========================================") (newline) +(display (format "Results: ~a/~a passed" pass-count test-count)) (newline) +(display "=========================================") (newline) +(when (< pass-count test-count) + (exit 1))