codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; diff (define-syntax curried-lambda (syntax-rules () ((_ () body body* ...) (begin body body* ...)) ((_ (arg arg* ...) body body* ...) (lambda (arg) (curried-lambda (arg* ...) body body* ...))))) (define-syntax define-curried (syntax-rules () ((_ (func arg ...) body body* ...) (define func (curried-lambda (arg ...) body body* ...))))) (define (take-while pred? xs) (let loop ((xs xs) (ys '())) (if (or (null? xs) (not (pred? (car xs)))) (reverse ys) (loop (cdr xs) (cons (car xs) ys))))) (define (drop n xs) (let loop ((n n) (xs xs)) (if (or (zero? n) (null? xs)) xs (loop (- n 1) (cdr xs))))) (define (read-line . port) (define (eat p c) (if (and (not (eof-object? (peek-char p))) (char=? (peek-char p) c)) (read-char p))) (let ((p (if (null? port) (current-input-port) (car port)))) (let loop ((c (read-char p)) (line '())) (cond ((eof-object? c) (if (null? line) c (list->string (reverse line)))) ((char=? #\newline c) (eat p #\return) (list->string (reverse line))) ((char=? #\return c) (eat p #\newline) (list->string (reverse line))) (else (loop (read-char p) (cons c line))))))) (define (read-lines . port) (let ((p (if (null? port) (current-input-port) (car port)))) (let loop ((l (read-line p)) (ls '())) (if (eof-object? l) (reverse ls) (loop (read-line p) (cons l ls)))))) (define (read-lines filename) (with-input-from-file filename (lambda () (let loop ((l (read-line)) (ls '())) (if (eof-object? l) (reverse ls) (loop (read-line) (cons l ls))))))) (define (make-matrix rows columns) (do ((m (make-vector rows)) (i 0 (+ i 1))) ((= i rows) m) (vector-set! m i (make-vector columns)))) (define (matrix-rows x) (vector-length x)) (define (matrix-cols x) (vector-length (vector-ref x 0))) (define (matrix-ref m i j) (vector-ref (vector-ref m i) j)) (define (matrix-set! m i j x) (vector-set! (vector-ref m i) j x)) (define-syntax for (syntax-rules () ((for (var first past step) body ...) (let ((ge? (if (< first past) >= <=))) (do ((var first (+ var step))) ((ge? var past)) body ...))) ((for (var first past) body ...) (let* ((f first) (p past) (s (if (< first past) 1 -1))) (for (var f p s) body ...))) ((for (var past) body ...) (let* ((p past)) (for (var 0 p) body ...))))) (define (lcs eql? xs ys) (let* ((x-len (length xs)) (y-len (length ys)) (x1 (+ x-len 1)) (y1 (+ y-len 1)) (xv (list->vector xs)) (yv (list->vector ys)) (m (make-matrix x1 y1))) (for (x 0 x1) (for (y 0 y1) (cond ((or (zero? x) (zero? y)) (matrix-set! m x y 0)) ((eql? (vector-ref xv (- x 1)) (vector-ref yv (- y 1))) (matrix-set! m x y (+ 1 (matrix-ref m (- x 1) (- y 1))))) (else (matrix-set! m x y (max (matrix-ref m (- x 1) y) (matrix-ref m x (- y 1)))))))) (let loop ((x x-len) (y y-len) (zs '())) (cond ((or (zero? x) (zero? y)) zs) ((= (matrix-ref m x y) (matrix-ref m (- x 1) y)) (loop (- x 1) y zs)) ((= (matrix-ref m x y) (matrix-ref m x (- y 1))) (loop x (- y 1) zs)) (else (loop (- x 1) (- y 1) (cons (vector-ref xv (- x 1)) zs))))))) (define (display-header a b c d e) (display a) (when (not (= a b)) (display ",") (display b)) (display c) (display d) (when (not (= d e)) (display ",") (display e)) (newline)) (define-curried (display-line c s) (display c) (display " ") (display s) (newline)) (define (diff file1 file2) (let* ((f1 (read-lines file1)) (f2 (read-lines file2)) (ds (lcs string=? f1 f2))) (let loop ((f1 f1) (f2 f2) (ds ds) (n1 0) (n2 0)) (cond ((null? f1) (when (pair? f2) (display-header n1 n1 "a" (+ n2 1) (+ n2 (length f2))) (for-each (display-line ">") f2))) ((null? f2) (when (pair? f1) (display-header (+ n1 1) (+ n1 (length f1)) "d" n2 n2) (for-each (display-line "<") f1))) ((and (string=? (car f1) (car ds)) (string=? (car f2) (car ds))) (loop (cdr f1) (cdr f2) (cdr ds) (+ n1 1) (+ n2 1))) ((string=? (car f1) (car ds)) (let* ((xs (take-while (lambda (s) (not (string=? (car ds) s))) f2)) (len (length xs))) (display-header n1 n1 "a" (+ n2 1) (+ n2 len)) (for-each (display-line ">") xs) (loop f1 (drop len f2) ds n1 (+ n2 len)))) ((string=? (car f2) (car ds)) (let* ((xs (take-while (lambda (s) (not (string=? (car ds) s))) f1)) (len (length xs))) (display-header (+ n1 1) (+ n1 len) "d" n2 n2) (for-each (display-line "<") xs) (loop (drop len f1) f2 ds (+ n1 len) n2))) (else (let* ((x1 (take-while (lambda (s) (not (string=? (car ds) s))) f1)) (x2 (take-while (lambda (s) (not (string=? (car ds) s))) f2)) (len1 (length x1)) (len2 (length x2))) (display-header (+ n1 1) (+ n1 len1) "c" (+ n2 1) (+ n2 len2)) (for-each (display-line "<") x1) (display "---") (newline) (for-each (display-line ">") x2) (loop (drop len1 f1) (drop len2 f2) ds (+ n1 len1) (+ n2 len2))))))))
Private
[
?
]
Run code
Submit