(defconstant tab '(("" "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX")
                   ("" "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC")
                   ("" "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM")
                   ("" "M" "MM" "MMM"                                )))

(defconstant exc '(( 0 . "NIHIL")
                   (18 . "XIIX" )
                   (22 . "IIXX" )))

(defun starts-with (x y)
  (and (>= (length x) (length y))
       (equal y (subseq x 0 (length y)))))

(defun roman (x base)
  (unless (zerop x)
    (concatenate 'string
                 (roman (floor x 10) (cdr base))
                 (nth   (mod   x 10) (car base)))))

(defun romin (x m base)
  (if (zerop (length x))
    0
    (let ((p (position-if #'(lambda (y) (starts-with x y))
                          (car base) :from-end t)))
      (+ (* m p) (romin (subseq x (length (nth p (car base))))
                        (floor m 10)
                        (cdr base))))))

(defun romanus-maximus (x)
  (check-type x (integer 0 3999))
  (or (cdr (assoc x exc))
      (roman x tab)))

(defun romanus-minimus (x)
  (or (car (rassoc x exc :test #'equal))
      (romin x 1000 (reverse tab))))