[编程交流] 罗马数字转换器

(defun c:roman ( / stnum stst)
 (if (> (setq stnum (atoi (setq stst (getstring "\n Enter number between 1 (I) and 3999 (MMMCMXCIX): ")))) 0)
   (rn stnum)
   (rnrev stst))
 )
(defun rnrev (st / sl st pout rn prt)
 (setq sl (strlen (setq st (strcase st)))
   pout 0
   rn '(("MMM" . 3000) ("MM" . 2000) ("M" . 1000) ("CM" . 900) ("DCCC" . 800) ("DCC" . 700) ("DC" . 600) ("D" . 500) ("CD" . 400) ("CCC" . 300) ("CC" . 200) ("C" . 100) ("XC" . 90) ("LXXX" . 80) ("LXX" . 70) ("LX" . 60) ("L" . 50) ("XL" . 40) ("XXX" . 30) ("XX" . 20) ("X" . 10) ("IX" . 9) ("VIII" .  ("VII" . 7) ("VI" . 6) ("V" . 5) ("IV" . 4) ("III" . 3) ("II" . 2) ("I" . 1))); /setq
 (while (and (> sl 0)
         (cdr (assoc (substr st 1 1) rn))); /and
   (cond
     ((setq prt  (cdr (assoc (substr st 1 4) rn)))
      (setq st   (substr st 5))); /cond 1
     ((setq prt  (cdr (assoc (substr st 1 3) rn)))
      (setq st   (substr st 4))); /cond 2
     ((setq prt  (cdr (assoc (substr st 1 2) rn)))
      (setq st   (substr st 3))); /cond 3
     ((setq prt  (cdr (assoc (substr st 1 1) rn)))
      (setq st   (substr st 2))); /cond 4
     ); /cond
   (setq rn   (cutlst rn prt)
     sl   (strlen st)
     pout (+ pout prt)); /setq
   ); /while
 (if (= sl 0)
   (princ pout) (princ "Invalid format")); /if
 (princ); silent exit
 ); /defun
(defun rn (gi / sl is gi numlst pout)
 (setq sl (strlen (setq is (itoa gi)))
   numlst (list "1" "2" "3" "4" "5" "6" "7" "8" "9")
   pout "")
 (if (and (> gi 0)
      (< gi 4000))
   (progn
     (while (> sl 0)
   (cond
     ((= sl 4)
      (setq pout (strcat pout (nth (vl-position (substr is 1 1) numlst) (list "M" "MM" "MMM")))
        sl 3)); /cond1
     ((= sl 3)
      (setq pout (strcat pout (nth (vl-position (substr is 1 1) numlst) (list "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM")))
        sl 2)); /cond2
     ((= sl 2)
      (setq pout (strcat pout (nth (vl-position (substr is 1 1) numlst) (list "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC")))
        sl 1)); /cond3
     ((= sl 1)
      (setq pout (strcat pout (nth (vl-position (substr is 1 1) numlst) (list "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX")))
        sl 0)); /cond4
     ); /cond
   (setq is (substr is 2))
   ); /while
     (princ pout)
     ); /progn
   (princ "Number Invalid"); else
   ); /if
 (princ)
 ); /defun
(defun cutlst (lst num / z)
 (cond
   ((> num 900)
    (setq num 1000)); /cond 1
   ((> num 90)
    (setq num 100 )); /cond 2
   ((> num 9)
    (setq num 10 ))); /cond 3
 (setq lst (vl-remove-if
         '(lambda (z) (>= (cdr z) num)) lst)); /setq
 ); /defun