(define-library (csc compare)
  (export diff)
  (import (scheme base)
          (only (csc format) fprintf)
          (only (csc loop)
            loop
            return)
          (only (csc match) match)
          (only (csc sort) sort)
          (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)
      (match l
        (((key . _) . _)
          (symbol? key))
        (_ #f)))


    (define (transform x transformers)
      (define x* (apply-transformer transformers x))
      (cond
        ((alist? x*)
          (sort (lambda (a b) (string<? (symbol->string (car a)) (symbol->string (car b))))
            (map (lambda (elem)
                   (cons (car elem) (transform (cdr elem) transformers)))
                 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))))


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


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