roman.ss
```;; Adam Shaw
;; This is my PLaneT hello, world.
;; Totally unoptimized, needs cleanup and refactoring etc.

;; See http://en.wikipedia.org/wiki/Roman_numerals for my source of info.

;; This is defined on the integers between 1 and 3999 inclusive only.

;; June 12, 2006
;; revised September 18, 2007 [added arithmetic operators]

(module roman mzscheme

(require (lib "contract.ss"))

(provide/contract
(int->roman (-> (integer-in 1 3999) string?))
(roman->int (-> string? (union (integer-in 1 3999) false/c))))

(provide summa differentia productum quotiens residuum test-all)

(define cat string-append)

(define (string-starts-with s prefix)
(cond
[(> (string-length prefix) (string-length s)) #f]
[else (string=? prefix (substring s 0 (string-length prefix)))]))

(define (string-drop s prefix)
(cond
[(string-starts-with s prefix) (substring s (string-length prefix) (string-length s))]
[else #f]))

(define (roms I V X)
(list I (cat I I) (cat I I I) (cat I V) V
(cat V I) (cat V I I) (cat V I I I) (cat I X)))

(define ones (roms "I" "V" "X"))
(define tens (roms "X" "L" "C"))
(define huns (roms "C" "D" "M"))

(define (int->roman n)
(cond
[(= n 0) ""]
[(< n 10)  (list-ref ones (sub1 n))]
[(< n 100) (cat (list-ref tens (sub1 (quotient n 10)))
(int->roman (remainder n 10)))]
[(< n 1000) (cat (list-ref huns (sub1 (quotient n 100)))
(int->roman (remainder n 100)))]
[else (cat (list-ref (list "M" "MM" "MMM") (sub1 (quotient n 1000)))
(int->roman (remainder n 1000)))]))

(define (roman->int r)
(cond
[(string=? r "") 0]
[else (let ((f (string-ref r 0)))
(cond
[(char=? f #\I) (cond
[(string=? r "I") 1]
[(string=? r "II") 2]
[(string=? r "III") 3]
[(string=? r "IV") 4]
[(string=? r "IX") 9]
[else #f])]
[(char=? f #\V) (cond
[(string=? r "V") 5]
[(string=? r "VI") 6]
[(string=? r "VII") 7]
[(string=? r "VIII") 8]
[else #f])]
[(char=? f #\X) (cond
[(string-starts-with r "XXX") (+ 30 (roman->int (string-drop r "XXX")))]
[(string-starts-with r "XL")  (+ 40 (roman->int (string-drop r "XL")))]
[(string-starts-with r "XC")  (+ 90 (roman->int (string-drop r "XC")))]
[(string-starts-with r "XX")  (+ 20 (roman->int (string-drop r "XX")))]
[(string-starts-with r "X")   (+ 10 (roman->int (string-drop r "X")))]
[else #f])]
[(char=? f #\L) (cond
[(string-starts-with r "LXXX") (+ 80 (roman->int (string-drop r "LXXX")))]
[(string-starts-with r "LXX")  (+ 70 (roman->int (string-drop r "LXX")))]
[(string-starts-with r "LX")   (+ 60 (roman->int (string-drop r "LX")))]
[(string-starts-with r "L")    (+ 50 (roman->int (string-drop r "L")))]
[else #f])]
[(char=? f #\D) (cond
[(string-starts-with r "DCCC") (+ 800 (roman->int (string-drop r "DCCC")))]
[(string-starts-with r "DCC")  (+ 700 (roman->int (string-drop r "DCC")))]
[(string-starts-with r "DC")   (+ 600 (roman->int (string-drop r "DC")))]
[(string-starts-with r "D")    (+ 500 (roman->int (string-drop r "D")))]
[else #f])]
[(char=? f #\C) (cond
[(string-starts-with r "CM")  (+ 900 (roman->int (string-drop r "CM")))]
[(string-starts-with r "CD")  (+ 400 (roman->int (string-drop r "CD")))]
[(string-starts-with r "CCC") (+ 300 (roman->int (string-drop r "CCC")))]
[(string-starts-with r "CC")  (+ 200 (roman->int (string-drop r "CC")))]
[(string-starts-with r "C")   (+ 100 (roman->int (string-drop r "C")))]
[else #f])]
[(char=? f #\M) (cond
[(string-starts-with r "MMM") (+ 3000 (roman->int (string-drop r "MMM")))]
[(string-starts-with r "MM")  (+ 2000 (roman->int (string-drop r "MM")))]
[(string-starts-with r "M")   (+ 1000 (roman->int (string-drop r "M")))]
[else #f])]
[else #f]))]))

;; foldl: (α β -> β) β (listof α) -> β
(define (foldl f b xs)
(define (fo b xs)
(cond
[(null? xs) b]
[else (fo (f (car xs) b) (cdr xs))]))
(fo b xs))

;; reduce : (nonempty list of roman) (roman * num -> num) -> roman
(define (reduce-romans op ident rs)
(let ((op* (lambda (r n) (op (roman->int r) n))))
(int->roman (foldl op* ident rs))))

;; summa : roman roman ... -> roman
(define (summa r . rs)
(reduce-romans + 0 (cons r rs)))

;; productum : roman ... -> roman
(define (productum r . rs)
(reduce-romans * 1 (cons r rs)))

;; binop : (num num -> num) -> roman roman -> roman
(define ((binop op) r1 r2)
(int->roman (op (roman->int r1) (roman->int r2))))

;; differentia : roman roman -> roman
(define differentia (binop -))

;; quotiens: roman roman -> roman
(define quotiens (binop quotient))

;; residuum: roman roman -> roman
(define residuum (binop remainder))

(define (test n)
(let* ((r (int->roman n))
(nn (roman->int r))
(success (= n nn)))
(printf "~a\n" (cat "n: " (number->string n) "; "
"roman: " r "; "
"and back again: " (number->string nn) "; "
"success? " (if success "yes" (error 'test "NO!!!!!"))))))

(define (megatest n)
(cond
[(< n 1) (print "Done.")]
[(> n 3999) (print "I can't do that.")]
[else (begin (test n) (megatest (sub1 n)))]))

(define (test-all) (megatest 3999))) ```