119 lines
3.5 KiB
Scheme
119 lines
3.5 KiB
Scheme
(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)
|