codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; 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)
Private
[
?
]
Run code
Submit