; roman numerals
(define-syntax list-match
(syntax-rules ()
((_ expr (pattern fender ... template) ...)
(let ((obj expr))
(cond ((list-match-aux obj pattern fender ...
(list template)) => car) ...
(else (error 'list-match "pattern failure")))))))
(define-syntax list-match-aux
(lambda (stx)
(define (underscore? x)
(and (identifier? x) (free-identifier=? x (syntax _))))
(syntax-case stx (quote quasiquote)
((_ obj pattern template)
(syntax (list-match-aux obj pattern #t template)))
((_ obj () fender template)
(syntax (and (null? obj) fender template)))
((_ obj underscore fender template)
(underscore? (syntax underscore))
(syntax (and fender template)))
((_ obj var fender template)
(identifier? (syntax var))
(syntax (let ((var obj)) (and fender template))))
((_ obj (quote datum) fender template)
(syntax (and (equal? obj (quote datum)) fender template)))
((_ obj (quasiquote datum) fender template)
(syntax (and (equal? obj (quasiquote datum)) fender template)))
((_ obj (kar . kdr) fender template)
(syntax (and (pair? obj)
(let ((kar-obj (car obj)) (kdr-obj (cdr obj)))
(list-match-aux kar-obj kar
(list-match-aux kdr-obj kdr fender template))))))
((_ obj const fender template)
(syntax (and (equal? obj const) fender template))))))
(define-syntax assert
(syntax-rules ()
((assert expr result)
(if (not (equal? expr result))
(for-each display `(
#\newline "failed assertion:" #\newline
expr #\newline "expected: " ,result
#\newline "returned: " ,expr #\newline))))))
(define (integer->roman n)
(let loop ((n n) (nums '((1000 #\M) (900 #\M #\C)
(500 #\D) (400 #\D #\C) (100 #\C) (90 #\C #\X)
(50 #\L) (40 #\L #\X) (10 #\X) (9 #\X #\I)
(5 #\V) (4 #\V #\I) (1 #\I))) (xs '()))
(cond ((zero? n) (list->string (reverse xs)))
((<= (caar nums) n)
(loop (- n (caar nums))
nums (append (cdar nums) xs)))
(else (loop n (cdr nums) xs)))))
(define (roman->integer str)
(let loop ((cs (string->list str)) (n 0))
(list-match cs
(() n)
((#\M . rest) (loop rest (+ n 1000)))
((#\C #\M . rest) (loop rest (+ n 900)))
((#\D . rest) (loop rest (+ n 500)))
((#\C #\D . rest) (loop rest (+ n 400)))
((#\C . rest) (loop rest (+ n 100)))
((#\X #\C . rest) (loop rest (+ n 90)))
((#\L . rest) (loop rest (+ n 50)))
((#\X #\L . rest) (loop rest (+ n 40)))
((#\X . rest) (loop rest (+ n 10)))
((#\I #\X . rest) (loop rest (+ n 9)))
((#\V . rest) (loop rest (+ n 5)))
((#\I #\V . rest) (loop rest (+ n 4)))
((#\I . rest) (loop rest (+ n 1)))
(else (error 'roman->integer "invalid character")))))
(do ((i 1 (+ i 1))) ((= i 5000))
(assert i (roman->integer (integer->roman i))))
(display (integer->roman 2014)) (newline)
(display (roman->integer "MMXIV")) (newline)