;; 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

(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 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 (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)))