Add translator

translate.scm

@@ -0,0 +1,115 @@
+(import (scheme base)
+        (scheme file)
+        (only (srfi 1) fold first second))
+
+(define rest cdr)
+
+(define (string-join list delimiter)
+  (if (null? list)
+      ""
+      (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")
+      (#\! "bang")
+      (#\+ "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 '()))
+    (cond ((= b (string-length str))
+           (reverse (eject a b words)))
+          (else
+           (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 (process translate from-file to-file)
+  (let* ((lines (with-input-from-file from-file read-all-lines))
+         (width (fold max 0 (map string-length lines))))
+    (writing to-file)
+    (with-output-to-file to-file
+      (lambda ()
+        (for-each (lambda (line)
+                    (let ((pad (max 0 (- width (string-length line)))))
+                      (write-string line)
+                      (write-string (make-string (+ pad 2) #\space))
+                      (write-string (translate line))
+                      (newline)))
+                  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)