(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]))]))
(define (foldl f b xs)
(define (fo b xs)
(cond
[(null? xs) b]
[else (fo (f (car xs) b) (cdr xs))]))
(fo b xs))
(define (reduce-romans op ident rs)
(let ((op* (lambda (r n) (op (roman->int r) n))))
(int->roman (foldl op* ident rs))))
(define (summa r . rs)
(reduce-romans + 0 (cons r rs)))
(define (productum r . rs)
(reduce-romans * 1 (cons r rs)))
(define ((binop op) r1 r2)
(int->roman (op (roman->int r1) (roman->int r2))))
(define differentia (binop -))
(define quotiens (binop quotient))
(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)))