Roman numbering (incerment)
Dear AllHOW TO CREATE IT
Roman numbering (incerment)
I
II
III
IV
V I suggest you to convert the number to a string and start processing from last digit to first one; increment the rule as you debase the digit. (rem) is going to be your friend here:
(initget 7) (setq tint (getint "\nTest Number: ")) (setq ones (cond ((= (rem tint 5) 0)"") ((= (rem tint 5) 1)"I") ((= (rem tint 5) 2)"II") ((= (rem tint 5) 3)"III") ((= (rem tint 5) 4)"IV"))) (setq fives (if (>= (rem tint 10) 5) "V" "")) (princ (strcat fives ones))
-David Hi,
This seems to from I to MMMCMXCIX (1 to 3999)
using examples:
(I+ "III") returns "IV"
(I+ "XV") returns "XVI"
(I+ "CXLIX") returns "CL"
(I+ "MMMCMXCIX") returns "MMMM"
(defun I+ (n) (setq n (reverse (vl-string->list n))) (vl-list->string (reverse (cond ((and (= 86 (car n)) (= 73 (cadr n))) (cons 86 (cddr n))); *IV -> *V ((= 73 (caddr n)) ; *III (if (= 86 (cadddr n)) ; *VIII (cons 88 (cons 73 (cddddr n))) ; -> *IX (cons 86 (cddr n)) ; -> *IV ) ) ((and (= 88 (car n)) (= 73 (cadr n))) ; *IX (if (= 88 (cadddr n)) ; *X-IX (cond ((= 76 (caddr n)) (cons 76 (cddddr n))) ; *XLIX -> *L ((= 88 (nth 4 n)) ; *XXXIX (if (= 76 (nth 5 n)) ; *LXXXIX (cons 67 (cons 88 (cdddr (cdddr n)))) ; -> *XC (cons 76 (cddddr n)) ; -> *XL ) ) (T ; *XCIX (if (= 67 (nth 5 n)) ; *C-XCIX (cond ((= 68 (nth 4 n)) (cons 68 (cdddr (cdddr n)))); *CDXCIX -> _D ((= 67 (nth 6 n)) ; *CCCXCIX (if (= 68 (nth 7 n)) ; *DCCCXCIX (cons 77 (cons 67 (cddddr (cddddr n)))) ; -> *CM (cons 68 (cdddr (cdddr n))) ; -> *CD ) ) (T (cons 77 (cdddr (cdddr n)))) ; -> *M ) (cons 67 (cddddr n)) ; -> *C ) ) ) (cons 88 (cddr n)) ; -> *X ) ) (T (cons 73 n)) ) ) )) I found this interesting:
http://www.novaroma.org/via_romana/numbers.html
I did finish it out to 4999:
(defun c:romannmb (/ tint ones fives tens fifty huns fvhun thos) (initget 7) (setq tint (getint "\nTest Number ( Less Than 4999 ): ")) (setq ones (cond ((= (rem tint 5) 0)"") ((= (rem tint 5) 1)"I") ((= (rem tint 5) 2)"II") ((= (rem tint 5) 3)"III") ((= (rem tint 5) 4)"IV"))) (setq fives (if (>= (rem tint 10) 5) "V" "")) (setq tens (cond ((>= (rem tint 50) 40)"XL") ((>= (rem tint 50) 30)"XXX") ((>= (rem tint 50) 20)"XX") ((>= (rem tint 50) 10)"X") ((<(rem tint 50) 10)""))) (setq fifty (if (>= (rem tint 100) 50) "L" "")) (setq huns (cond ((>= (rem tint 500) 400)"CD") ((>= (rem tint 500) 300)"CCC") ((>= (rem tint 500) 200)"CC") ((>= (rem tint 500) 100)"C") ((<(rem tint 500) 100)""))) (setq fvhun (if (>= (rem tint 1000) 500) "D" "")) (setq thos (cond ((>= (rem tint 5000) 4000)"MMMM") ((>= (rem tint 5000) 3000)"MMM") ((>= (rem tint 5000) 2000)"MM") ((>= (rem tint 5000) 1000)"M") ((<(rem tint 5000) 1000)""))) (princ (strcat thos fvhun huns fifty tens fives ones)) (prin1))
-David I said 3999 beacuse I didn't know how to write 4000 or 5000 with roman numbering.
But if MMMM or MMMMM are allowed for 4000 and 5000 and so on, the routine I posted doen't have limit... My way to convert arabic numbers to roman numbers and vice-versa
(defun arabic2roman (n / m s) (setq s "") (mapcar '(lambda (a r) (setq m (/ n a) n (rem n a) ) (repeat m (setq s (strcat s r))) ) '(1000 900 500 400 100 90 50 40 10 9 5 4 1) '("M" "CM" "D" "CD" "C" "XC" "L" "XL" "X" "IX" "V" "IV" "I") ) s)(defun roman2arabic (s / n) (setq n 0) (mapcar '(lambda (a r) (while (= r (substr s 1 (strlen r))) (setq n (+ n a) s (substr s (1+ (strlen r))) ) ) ) '(1000 900 500 400 100 90 50 40 10 9 5 4 1) '("M" "CM" "D" "CD" "C" "XC" "L" "XL" "X" "IX" "V" "IV" "I") ) n)
dear sir
gile & david
very good lisp
thx for reply dear sir
find lisp on net but error on this lisp
(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 0rn '(("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 Nice code Gile
页:
[1]
2