aboutsummaryrefslogtreecommitdiffstats
path: root/lib/csc/compare.csc
diff options
context:
space:
mode:
Diffstat (limited to 'lib/csc/compare.csc')
-rw-r--r--lib/csc/compare.csc248
1 files changed, 0 insertions, 248 deletions
diff --git a/lib/csc/compare.csc b/lib/csc/compare.csc
deleted file mode 100644
index e8e68d3..0000000
--- a/lib/csc/compare.csc
+++ /dev/null
@@ -1,248 +0,0 @@
-(define-library (csc compare)
- (export diff apply-transformer)
- (import (scheme base)
- (only (scheme write)
- display
- write)
- (only (csc strings)
- contains?
- split))
- (begin
- ; compare is inspired by Go's cmp.Diff.
-
-
- (define (print w . xs)
- (unless (null? xs)
- (let ((x (car xs)))
- (if (or (string? x)
- (symbol? x))
- (display x w)
- (write x w)))
- (apply print w (cdr xs))))
-
-
- (define (apply-transformer t x)
- (if (list? t)
- (let loop ((transformers t)
- (x x))
- (if (null? transformers)
- x
- (loop (cdr transformers)
- (apply-transformer (car transformers) x))))
- (if ((car t) x)
- ((cdr t) x)
- x)))
-
-
- (define (alist? l)
- (and (list? l)
- (let loop ((l l))
- (cond
- ((null? l) #t)
- ((not (and (pair? (car l))
- (symbol? (caar l))))
- #f)
- (else (loop (cdr l)))))))
-
-
- (define (transform x transformers)
- (define x* (apply-transformer transformers x))
- (cond
- ((alist? x*)
- (map (lambda (elem)
- (define elem* (apply-transformer transformers elem))
- (if (pair? elem*)
- (cons (car elem) (transform (cdr elem) transformers))
- elem*))
- x*))
- ((list? x*)
- (map (lambda (elem) (transform elem transformers))
- x*))
- (else x*)))
-
-
- ; As always, I copied the algorithm from Wikipedia
- (define (lcs x y cmp)
- (define x-vals (list->vector x))
- (define y-vals (list->vector y))
- (define table (make-vector (* (+ 1 (vector-length x-vals)) (+ 1 (vector-length y-vals))) 0))
- (define (index i j)
- (+ j (* i (+ 1 (vector-length y-vals)))))
- (let loop-i ((i 1))
- (when (<= i (vector-length x-vals))
- (let loop-j ((j 1))
- (when (<= j (vector-length y-vals))
- (if (cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1)))
- (vector-set! table (index i j) (+ 1 (vector-ref table (index (- i 1) (- j 1)))))
- (vector-set! table (index i j) (max (vector-ref table (index (- i 1) j))
- (vector-ref table (index i (- j 1))))))
- (loop-j (+ 1 j))))
- (loop-i (+ 1 i))))
- (let loop ((i (vector-length x-vals))
- (j (vector-length y-vals))
- (lcs '()))
- (cond
- ((or (= 0 i) (= 0 j)) lcs)
- ((cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1)))
- (loop (- i 1) (- j 1) (cons (vector-ref x-vals (- i 1)) lcs)))
- ((> (vector-ref table (index i (- j 1))) (vector-ref table (index (- i 1) j)))
- (loop i (- j 1) lcs))
- (else (loop (- i 1) j lcs)))))
-
-
- (define (pretty w x indent)
- (cond
- ((list? x)
- (print w indent " (\n")
- (let ((new-indent (string-append indent " ")))
- (for-each (lambda (v)
- (pretty w v new-indent))
- x))
- (print w indent " )\n"))
- ((and (pair? x)
- (symbol? (car x)))
- (print w indent " (" (car x) " .\n")
- (pretty w (cdr x) (string-append indent " "))
- (print w indent " )\n"))
- (else (print w indent " " x "\n"))))
-
-
- (define (diff* w x y indent)
- (cond
- ((or (and (boolean? x) (boolean? y))
- (and (char? x) (char? y))
- (and (symbol? x) (symbol? y))
- (and (number? x) (number? y))
- (and (string? x) (string? y)))
- (if (equal? x y)
- (begin
- (print w indent " " x "\n")
- #t)
- (begin
- (print w indent "- " x "\n" indent "+ " y "\n")
- #f)))
- ((and (alist? x) (alist? y))
- (print w indent " (\n")
- (let ((key-lcs (lcs (map car x) (map car y) symbol=?))
- (indent* (string-append indent " "))
- (equal #t))
- (let loop ()
- (unless (and (null? key-lcs)
- (null? x)
- (null? y))
- (cond
- ((and (null? key-lcs)
- (null? x))
- (pretty w (car y) (string-append indent* "+"))
- (set! y (cdr y))
- (set! equal #f))
- ((null? key-lcs)
- (pretty w (car x) (string-append indent* "-"))
- (set! x (cdr x))
- (set! equal #f))
- ((symbol=? (caar x) (caar y) (car key-lcs))
- (print w indent* " (" (car key-lcs) " .\n")
- (set! equal (and (diff* w (cdar x) (cdar y) (string-append indent* " "))
- equal))
- (print w indent* " )\n")
- (set! x (cdr x))
- (set! y (cdr y))
- (set! key-lcs (cdr key-lcs)))
- ((symbol=? (caar x) (car key-lcs))
- (pretty w (car y) (string-append indent* "+"))
- (set! y (cdr y))
- (set! equal #f))
- (else
- (pretty w (car x) (string-append indent* "-"))
- (set! x (cdr x))
- (set! equal #f)))
- (loop)))
- (print w indent " )\n")
- equal))
- ((and (list? x) (list? y))
- (print w indent " (\n")
- (let* ((common (lcs x y equal?))
- (indent* (string-append indent " "))
- (equal #t))
- (let loop ()
- (unless (and (null? common)
- (null? x)
- (null? y))
- (cond
- ((and (null? common)
- (null? x))
- (pretty w (car y) (string-append indent* "+"))
- (set! y (cdr y))
- (set! equal #f))
- ((and (null? common)
- (null? y))
- (pretty w (car x) (string-append indent* "-"))
- (set! x (cdr x))
- (set! equal #f))
- ((null? common)
- (diff* w (car x) (car y) indent*)
- (set! x (cdr x))
- (set! y (cdr y))
- (set! equal #f))
- ((equal? (car x) (car y))
- (pretty w (car x) (string-append indent* " "))
- (set! x (cdr x))
- (set! y (cdr y))
- (set! common (cdr common)))
- ((equal? (car x) (car common))
- (pretty w (car y) (string-append indent* "+"))
- (set! y (cdr y))
- (set! equal #f))
- ((equal? (car y) (car common))
- (pretty w (car x) (string-append indent* "-"))
- (set! x (cdr x))
- (set! equal #f))
- (else
- (diff* w (car x) (car y) indent*)
- (set! x (cdr x))
- (set! y (cdr y))
- (set! equal #f)))
- (loop)))
- (print w indent " )\n")
- equal))
- (else
- (pretty w x (string-append indent "-"))
- (pretty w y (string-append indent "+"))
- #f)))
-
-
- (define default-transformers
- (list
- (cons (lambda (s)
- (and (string? s)
- (contains? s "\n")))
- (lambda (s)
- (list (cons '!type 'string)
- (cons 'value (split s "\n")))))
- (cons vector? (lambda (v)
- (list (cons '!type 'vector)
- (cons 'value (vector->list v)))))
- (cons bytevector? (lambda (b)
- (list (cons '!type 'bytevector)
- (cons 'value (let loop ((i 0)
- (acc '()))
- (when (< i (bytevector-length b))
- (loop (+ 1 i)
- (cons (string-append "0x" (number->string
- (bytevector-u8-ref b i)
- 16))
- acc)))
- (reverse acc))))))))
-
-
- ; Returns a string diff between x and y. Diff knows how to compare lists,
- ; alists and other primitive types. Any user-defined type needs a
- ; transformer. Each transformer is a pair of type predicate that the
- ; transformer matches on, and a function that transforms a value of that
- ; type into an alist.
- (define (diff x y . transformers)
- (define d (open-output-string))
- (define t* (cons default-transformers transformers))
- (if (diff* d (transform x t*) (transform y t*) "")
- ""
- (get-output-string d)))))
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-04 15:14:17 +0000