(import (scheme base)
        (scheme file)
        (only (srfi 1) fold first second))

(define rest cdr)

(define (string-join list delimiter)
  (fold (lambda (item result) (string-append result delimiter item))
        (first list)
        (rest list)))

(define (capitalize str)
  (string-append (string (ascii-upcase (string-ref str 0)))
                 (string-copy str 1 (string-length str))))

(define (ascii-alphanumeric? char)
  (or (char<=? #\0 char #\9)
      (char<=? #\A char #\Z)
      (char<=? #\a char #\z)))

(define (ascii-upcase char)
  (if (char<=? #\a char #\z)
      (integer->char (+ (char->integer #\A)
                        (- (char->integer char)
                           (char->integer #\a))))
      char))

(define (translate-words str)
  (define names
    '((#\. "dot")
      (#\? "p")
      (#\! "x")
      (#\+ "plus")
      (#\* "star")
      (#\- "minus")
      (#\/ "slash")
      (#\< "less")
      (#\= "equal")
      (#\> "greater")))
  (define (eject a b words)
    (if (< a b)
        (cons (string-copy str a b) words)
        words))
  (let loop ((a 0) (b 0) (words '()))
    (if (= b (string-length str))
        (reverse (eject a b words))
        (let* ((char (string-ref str b))
               (name* (assoc char names))
               (name (and name* (second name*))))
          (cond ((and (char=? #\- char)
                      (< b (- (string-length str) 1)))
                 (loop (+ b 1)
                       (+ b 1)
                       (eject a b words)))
                ((and (char=? #\> char)
                      (not (null? words))
                      (= a b))
                 (loop (+ b 1)
                       (+ b 1)
                       (cons "to" words)))
                (name
                 (loop (+ b 1)
                       (+ b 1)
                       (cons name (eject a b words))))
                ((ascii-alphanumeric? char)
                 (loop a (+ b 1) words))
                (else
                 (error "What?" char)))))))

(define (translate-camel str)
  (string-join (map capitalize (translate-words str))
               ""))

(define (translate-under str)
  (string-join (translate-words str) "_"))

(define (read-all-lines)
  (let loop ((lines '()))
    (let ((line (read-line)))
      (if (eof-object? line)
          (reverse lines)
          (loop (cons line lines))))))

(define (writing file)
  (write-string "Writing ")
  (write-string file)
  (newline))

(define (write-two-column-list list1 list2)
  (let ((width (fold max 0 (map string-length list1))))
    (for-each (lambda (item1 item2)
                (let ((pad (max 0 (- width (string-length item1)))))
                  (write-string item1)
                  (write-string (make-string (+ pad 2) #\space))
                  (write-string item2)
                  (newline)))
              list1
              list2)))

(define (process translate from-file to-file)
  (let* ((source-lines (with-input-from-file from-file read-all-lines))
         (target-lines (map translate source-lines)))
    (writing to-file)
    (with-output-to-file to-file
      (lambda ()
        (write-two-column-list source-lines
                               target-lines)))))

(define (main)
  (define sa string-append)
  (for-each (lambda (file)
              (let ((source (sa "source/" file)))
                (process translate-camel source (sa "target-camel/" file))
                (process translate-under source (sa "target-under/" file))))
            '("common-lisp"
              "r7rs-small")))

(main)