[ create a new paste ] login | about

Link: http://codepad.org/tAMHXbsq    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on May 30:
; 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)


Output:
1
2
MMXIV
2014


Create a new paste based on this one


Comments: