(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)))))