Modify the project structure.

Now the lib directory contains what will eventually end up on the
user's /usr/lib/csc. When I write make install, it will copy all of
the .csc files from lib into the destination lib directory. This means I
can start working on the standard library in lib/scheme.

1 files changed, 248 insertions, 0 deletions

diff --git a/lib/csc/compare.csc b/lib/csc/compare.csc
new file mode 100644
index 0000000..e8e68d3
--- /dev/null
+++ b/lib/csc/compare.csc
@@ -0,0 +1,248 @@
+(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)))))