(define-library (csc compare)
  (export diff)
  (import (scheme base)
          (only (csc format) fprintf)
          (only (csc loop)
            loop
            return)
          (only (csc strings)
            contains
            split)
          (only (csc vec)
            vec
            vec-append))
  (begin
    ; compare is inspired by Go's cmp.Diff.


    (define (apply-transformer t x)
      (if (list? t)
        (loop for transformer in t
              do (set! x (apply-transformer transformer x))
              finally (return x))
        (if ((car t) x)
          ((cdr t) x)
          x)))


    (define (alist? l)
      (and (list? l)
           (loop for x in l
                 unless (and (pair? x)
                             (symbol? (car x)))
                   return #f
                 finally (return #t))))


    (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)))))
      (loop for i from 1 to (vector-length x-vals)
            do (loop for j from 1 to (vector-length y-vals)
                     if (cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1)))
                       do (vector-set! table (index i j) (+ 1 (vector-ref table (index (- i 1) (- j 1)))))
                     else
                       do (vector-set! table (index i j) (max (vector-ref table (index (- i 1) j))
                                                              (vector-ref table (index i (- j 1)))))))
      (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)
          (fprintf w "{}  (\n" indent)
          (loop with new-indent = (string-append indent "  ")
                for v in x
                do (pretty w v new-indent))
          (fprintf w "{}  )\n" indent))
        ((and (pair? x)
              (symbol? (car x)))
          (fprintf w "{}  ({} .\n" indent (car x))
          (pretty w (cdr x) (string-append indent "  "))
          (fprintf w "{}  )\n" indent))
        (else (fprintf w "{}  {}\n" indent x))))


    (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
              (fprintf w "{}   {}\n" indent x)
              #t)
            (begin
              (fprintf w "{}-  {}\n{}+  {}\n" indent x indent y)
              #f)))
        ((and (alist? x) (alist? y))
          (fprintf w "{}   (\n" indent)
          (let ((key-lcs (lcs (map car x) (map car y) symbol=?))
                (indent* (string-append indent "  "))
                (equal #t))
            (loop if (null? key-lcs)
                    if (null? x)
                      if (null? y)
                        do (return)
                      else
                        do (pretty w (car y) (string-append indent* "+"))
                           (set! y (cdr y))
                           (set! equal #f)
                    else
                      do (pretty w (car x) (string-append indent* "-"))
                         (set! x (cdr x))
                         (set! equal #f)
                  else
                    if (symbol=? (caar x) (caar y) (car key-lcs))
                      do (fprintf w "{}   ({} .\n" indent* (car key-lcs))
                         (set! equal (and (diff* w (cdar x) (cdar y) (string-append indent* "  "))
                                          equal))
                         (fprintf w "{}   )\n" indent*)
                         (set! x (cdr x))
                         (set! y (cdr y))
                         (set! key-lcs (cdr key-lcs))
                    else if (symbol=? (caar x) (car key-lcs))
                      do (pretty w (car y) (string-append indent* "+"))
                         (set! y (cdr y))
                         (set! equal #f)
                    else
                      do (pretty w (car x) (string-append indent* "-"))
                         (set! x (cdr x))
                         (set! equal #f))
            (fprintf w "{}   )\n" indent)
            equal))
        ((and (list? x) (list? y))
          (fprintf w "{}   (\n" indent)
          (let* ((common (lcs x y equal?))
                 (indent* (string-append indent "  "))
                 (equal #t))
            (loop if (null? common)
                    if (null? x)
                      if (null? y)
                        do (return)
                      else
                        do (pretty w (car y) (string-append indent* "+"))
                           (set! y (cdr y))
                           (set! equal #f)
                    else if (null? y)
                      do (pretty w (car x) (string-append indent* "-"))
                         (set! x (cdr x))
                         (set! equal #f)
                    else
                      do (diff* w (car x) (car y) indent*)
                         (set! x (cdr x))
                         (set! y (cdr y))
                         (set! equal #f)
                  else
                    if (equal? (car x) (car y))
                      do (pretty w (car x) (string-append indent* " "))
                         (set! x (cdr x))
                         (set! y (cdr y))
                         (set! common (cdr common))
                    else if (equal? (car x) (car common))
                      do (pretty w (car y) (string-append indent* "+"))
                         (set! y (cdr y))
                         (set! equal #f)
                    else if (equal? (car y) (car common))
                      do (pretty w (car x) (string-append indent* "-"))
                         (set! x (cdr x))
                         (set! equal #f)
                    else
                      do (diff* w (car x) (car y) indent*)
                         (set! x (cdr x))
                         (set! y (cdr y))
                         (set! equal #f))
            (fprintf w "{}   )\n" indent)
            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 (loop for i below (bytevector-length b)
                                                     collect (string-append "0x" (number->string
                                                                                   (bytevector-u8-ref b i)
                                                                                   16)))))))))


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