Roman Numeral / Decimal Number converter

[Jaze]

Code: QB64: [Select]

1. CONST TRUE = 1
2. CONST FALSE = 0
3. DIM SHARED romanNumeral$: romanNumeral$ = ""
4. DIM SHARED decimalNumber: decimalNumber = 0
5.  
6. PRINT "Type 1 or 'R' to convert decimal number to Roman Numeral"
7. PRINT "           or anything else to convert Roman Numeral to decimal number"
8. c$ = P$(TRUE)
9. IF c$ = "1" OR UCASE$(c$) = "R" THEN
10.     CALL ConvertToRoman
11. ELSE
12.     CALL ConvertToDecimal
13. END IF
14.  
15. SUB ConvertToDecimal
16.     decimalNumber = 0
17.     invalidInput:
18.     INPUT "Type in the Roman Numeral: ", romanNumeral$
19.     rn$ = UCASE$(romanNumeral$)
20.     FOR count = 1 TO LEN(rn$)
21.         a$ = MID$(rn$, count, 1)
22.         SELECT CASE a$
23.             CASE "I", "V", "X", "L", "C", "D", "M"
24.                 'do nothing
25.             CASE ELSE
26.                 GOTO invalidInput
27.         END SELECT
28.     NEXT count
29.     DO
30.         r$ = LEFT$(rn$, 1)
31.         SELECT CASE r$
32.             CASE "M"
33.                 decimalNumber = decimalNumber + 1000
34.                 rn$ = MID$(rn$, 2, LEN(rn$))
35.             CASE "C"
36.                 IF LEFT$(rn$, 2) = "CM" THEN
37.                     decimalNumber = decimalNumber + 900
38.                     rn$ = MID$(rn$, 3, LEN(rn$))
39.                 ELSEIF LEFT$(rn$, 2) = "CD" THEN
40.                     decimalNumber = decimalNumber + 400
41.                     rn$ = MID$(rn$, 3, LEN(rn$))
42.                 ELSE
43.                     decimalNumber = decimalNumber + 100
44.                     rn$ = MID$(rn$, 2, LEN(rn$))
45.                 END IF
46.             CASE "D"
47.                 decimalNumber = decimalNumber + 500
48.                 rn$ = MID$(rn$, 2, LEN(rn$))
49.             CASE "X"
50.                 IF LEFT$(rn$, 2) = "XC" THEN
51.                     decimalNumber = decimalNumber + 90
52.                     rn$ = MID$(rn$, 3, LEN(rn$))
53.                 ELSEIF LEFT$(rn$, 2) = "XL" THEN
54.                     decimalNumber = decimalNumber + 40
55.                     rn$ = MID$(rn$, 3, LEN(rn$))
56.                 ELSE
57.                     decimalNumber = decimalNumber + 10
58.                     rn$ = MID$(rn$, 2, LEN(rn$))
59.                 END IF
60.             CASE "L"
61.                 decimalNumber = decimalNumber + 50
62.                 rn$ = MID$(rn$, 2, LEN(rn$))
63.             CASE "I"
64.                 IF LEFT$(rn$, 2) = "IX" THEN
65.                     decimalNumber = decimalNumber + 9
66.                     rn$ = MID$(rn$, 3, LEN(rn$))
67.                 ELSEIF LEFT$(rn$, 2) = "IV" THEN
68.                     decimalNumber = decimalNumber + 4
69.                     rn$ = MID$(rn$, 3, LEN(rn$))
70.                 ELSE
71.                     decimalNumber = decimalNumber + 1
72.                     rn$ = MID$(rn$, 2, LEN(rn$))
73.                 END IF
74.             CASE "V"
75.                 decimalNumber = decimalNumber + 5
76.                 rn$ = MID$(rn$, 2, LEN(rn$))
77.         END SELECT
78.     LOOP UNTIL rn$ = ""
79.     COLOR n15, 0: PRINT "Decimal number: " + S$(decimalNumber)
80. END SUB
81.  
82. SUB ConvertToRoman
83.     decimalNumber = 0
84.     romanNumeral$ = ""
85.     INPUT "Type in the decimal number: ", decimalNumber
86.     DO
87.         IF decimalNumber >= 1000 THEN
88.             romanNumeral$ = romanNumeral$ + "M"
89.             decimalNumber = decimalNumber - 1000
90.         ELSEIF decimalNumber >= 900 THEN
91.             romanNumeral$ = romanNumeral$ + "CM"
92.             decimalNumber = decimalNumber - 900
93.         ELSEIF decimalNumber >= 500 THEN
94.             romanNumeral$ = romanNumeral$ + "D"
95.             decimalNumber = decimalNumber - 500
96.         ELSEIF decimalNumber >= 400 THEN
97.             romanNumeral$ = romanNumeral$ + "CD"
98.             decimalNumber = decimalNumber - 400
99.         ELSEIF decimalNumber >= 100 THEN
100.             romanNumeral$ = romanNumeral$ + "C"
101.             decimalNumber = decimalNumber - 100
102.         ELSEIF decimalNumber >= 90 THEN
103.             romanNumeral$ = romanNumeral$ + "XC"
104.             decimalNumber = decimalNubmer - 90
105.         ELSEIF decimalNumber >= 50 THEN
106.             romanNumeral$ = romanNumeral$ + "L"
107.             decimalNumber = decimalNumber - 50
108.         ELSEIF decimalNumber >= 40 THEN
109.             romanNumeral$ = romanNumeral$ + "XL"
110.             decimalNumber = decimalNumber - 40
111.         ELSEIF decimalNumber >= 10 THEN
112.             romanNumeral$ = romanNumeral$ + "X"
113.             decimalNumber = decimalNumber - 10
114.         ELSEIF decimalNumber >= 9 THEN
115.             romanNumeral$ = romanNumeral$ + "IX"
116.             decimalNumber = decimalNumer - 9
117.         ELSEIF decimalNumber >= 5 THEN
118.             romanNumeral$ = romanNumeral$ + "V"
119.             decimalNumber = decimalNumber - 5
120.         ELSEIF decimalNumber >= 4 THEN
121.             romanNumeral$ = romanNumeral$ + "IV"
122.             decimalNumber = decimalNumber - 4
123.         ELSEIF decimalNumber >= 1 THEN
124.             romanNumeral$ = romanNumeral$ + "I"
125.             decimalNumber = decimalNumber - 1
126.         END IF
127.     LOOP UNTIL decimalNumber = 0
128.     COLOR 15, 0: PRINT "The Roman Numeral is " + romanNumeral$
129. END SUB
130.  
131. 'for debugging
132. FUNCTION P$ (escape)
133.     pause$ = INPUT$(1)
134.     IF escape = TRUE AND pause$ = CHR$(27) THEN END
135.     P$ = pause$
136. END FUNCTION
137. FUNCTION S$ (number)
138.     rtn$ = ""
139.     rtn$ = STR$(number)
140.     rtn$ = LTRIM$(rtn$)
141.     S$ = rtn$
142. END FUNCTION

I thought this would be a lot more difficult than it was

[Pete]

You wanted more difficult? Try converting to Judaism next time!

Nice. I gave it IV out of V stars.

Pete

[bplus]

We played with this about a year ago:

Code: QB64: [Select]

1. Option _Explicit
2. _Title "Roman$ Function Test and Demo" ' b+ 2020-09-01 revise Roman SUB to latest changes at forum
3. Dim q~&, output$, num As _Unsigned Long, test$
4. q~& = -1: num = 4294967295 'quick test of big number limit
5. Print num; "= "; Roman$(Str$(num))
6. '         4294967295    4294967295   'limit
7. For num = 4294967200 To 4294967220
8.     output$ = Roman$(Str$(num))
9.     test$ = Roman$(output$)
10.     Locate CsrLin, 1: Print num;
11.     Locate CsrLin, 20: Print output$;
12.     Locate CsrLin, 50: Print test$
13.     If num <> Val(test$) Then Beep: Sleep
14. Next
15. Do
16.     Print " Testing conversion of numbers 0 to"; q~&; " to or from Roman Numerals >"
17.     Input " Enter a string to test "; test$
18.     output$ = Roman$(test$)
19.     Print " The Roman SUB returned: "; output$
20.     Print
21. Loop Until test$ = ""
22.  
23. Function Roman$ (instrg$) ' for extended Roman Numeral conversions
24.     Static d(12) As _Unsigned Long, c(12) As String, R$(1 To 3999)
25.     Dim v As _Unsigned Long, k As _Unsigned Long, conv As String
26.     Dim ub As Integer, i As Integer, j As Integer, s As String, p As _Unsigned Long, x As _Unsigned Long
27.     Dim pd As Integer, pr As Integer, lastpd As Integer, lastpr As Integer
28.     If d(0) = 0 Then ' load n and c arrays
29.         For ub = 0 To 12
30.             Read d(ub), c(ub)
31.         Next
32.         For i = 1 To 3999
33.             ub = 12: x = i: conv = ""
34.             Do ' *** Ashish uses same method as Euklides but condensed beautifully here ***
35.                 If x >= d(ub) And x < 4 * d(ub) Then ' x falls between which two decimal amounts?
36.                     p = Int(x / d(ub)): s = "" 'setup to copy Roman symbol(s) p times
37.                     For j = 1 To p: s = s + c(ub): Next 'string copy
38.                     conv = conv + s: x = x - d(ub) * p
39.                 Else
40.                     ub = ub - 1 'move index ub down
41.                 End If
42.             Loop Until x = 0
43.             R$(i) = conv
44.         Next
45.     End If 'end of setup, one time only
46.     s = _Trim$(UCase$(instrg$))
47.     If s = "" Or s = "0" Then Roman$ = "Error: nada": Exit Function 'handle nothing
48.     For i = 1 To Len(s) ' character checkup
49.         pd = InStr("0123456789", Mid$(s, i, 1)): pr = InStr(" MDCLXVI", Mid$(s, i, 1))
50.         If pd = 0 And pr = 0 Then Roman$ = "Error: unknown character.": Exit Function 'handle wrong alpha
51.         If i > 1 Then 'check for mixed messages
52.             If (lastpd = 0 And pd > 0) Or (lastpr = 0 And pr > 0) Then Roman$ = "Error: digits mixed with letters.": Exit Function
53.         End If
54.         lastpd = pd: lastpr = pr
55.     Next
56.     v = Val(s) 'is s a number or a Roman Numeral string?
57.     If v = 0 Then
58.         ReDim vs(0) As String ' vs for value strings
59.         Split s, " M", vs() '   Handy Split for parsing *M sections
60.         conv = "" '             Build our string on this variable (reusing)
61.         For j = 0 To UBound(vs)
62.             pd = 0 'reuse an integer for found match
63.             For i = 1 To 3999
64.                 If R$(i) = vs(j) Then ' When stringing together numbers after first set need 0 fillers.
65.                     If j > 0 Then conv = conv + Right$("000" + _Trim$(Str$(i)), 3) Else conv = conv + _Trim$(Str$(i))
66.                     pd = 1: Exit For 'pd indeicates a match was found
67.                 End If
68.             Next
69.             If pd <> 1 Then ' No match found, maybe this is empty 000 space?
70.                 If vs(j) = "" Then conv = conv + "000" Else Roman$ = "Error: Invalid Roman Numeral? string.": Exit Function
71.             End If
72.         Next
73.         Roman$ = conv
74.     ElseIf v >= 4000 Then ' Beyond our Roman String Table
75.         k = Int(v / 1000)
76.         Roman$ = Roman$(Str$(k)) + " " + Roman$(Str$(v - (k - 1) * 1000)) ' Go recursive until v < 4000
77.     Else
78.         Roman$ = R$(v) 'Table lookup
79.     End If
80.     Exit Function 'below is nice condensed data Ashish uses same method as Euklides but condensed beautifully
81.     Data 1,"I",4,"IV",5,"V",9,"IX",10,"X",40,"XL",50,"L",90,"XC",100,"C",400,"CD",500,"D",900,"CM",1000,"M"
82. End Function
83.  
84. Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
85.     Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
86.     curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
87.     dpos = InStr(curpos, SplitMeString, delim)
88.     Do Until dpos = 0
89.         loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
90.         arrpos = arrpos + 1
91.         If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
92.         curpos = dpos + LD
93.         dpos = InStr(curpos, SplitMeString, delim)
94.     Loop
95.     loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
96.     ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
97. End Sub
98.  
99.  

[George McGinn]

Here is one I wrote back in 2019, originally in TechBASIC (iPad).

I also thought I posted one for QB64 as well. If not, here is my version, a bit more simplified but still works.

Code: QB64: [Select]

1. _TITLE "Roman Numeral Decode.bas"
2. ' Roman Numeral Decode.bas    Version 1.0  05/23/2019
3. '-------------------------------------------------------------------------
4. '       PROGRAM: Roman Numeral Decode.bas
5. '        AUTHOR: George McGinn
6. '
7. '  DATE WRITTEN: 05/23/2019
8. '       VERSION: 1.0
9. '       PROJECT: Rosetta Code Challenge
10. '
11. '   DESCRIPTION: Decode Roman Numerals to Decimal Values
12. '
13. ' Written by George McGinn
14. ' Version 1.0 - Created 05/23/2019
15. '
16. '
17. ' CHANGE LOG
18. '-------------------------------------------------------------------------
19. ' 05/23/2019 v1.0 GJM - New Program.
20. '-------------------------------------------------------------------------
21. '
22.  
23. DIM SHARED roman AS STRING
24.  
25. Main:
26. '------------------------------------------------
27. ' CALLS THE romToDec FUNCTION WITH THE ROMAN
28. ' NUMERALS AND RETURNS ITS DECIMAL EQUIVELENT.
29. '
30.    
31.     PRINT "MDCCIV  = "; romToDec("MDCCIV") '1704
32.     PRINT "MCMXC   = "; romToDec("MCMXC") '1990
33.     PRINT "MMVIII  = "; romToDec("MMVIII") '2008
34.     PRINT "MDCLXVI = "; romToDec("MDCLXVI") '1666
35.     PRINT: PRINT
36.     PRINT "Here are other solutions not from the TASK:"
37.     PRINT "MCMXCIX = "; romToDec("MCMXCIX") '1999
38.     PRINT "XXV     = "; romToDec("XXV") '25
39.     PRINT "CMLIV   = "; romToDec("CMLIV") '954
40.     PRINT "MMXI    = "; romToDec("MMXI") '2011
41.     PRINT: PRINT
42.     PRINT "Without error checking, this is also wrong. Gives 2011. Should be 2013."
43.     PRINT "MMIIIX  = "; romToDec("MMIIIX") 'INVAID, 2011, by rules should be 2013
44.  
45.     END
46.  
47.  
48. FUNCTION romToDec (roman AS STRING)
49. '------------------------------------------------------
50. ' FUNCTION THAT CONVERTS ANY ROMAN NUMERAL TO A DECIMAL
51. '
52. prenum = 0: num = 0
53. LN = LEN(roman)
54. FOR i = LN TO 1 STEP -1
55.     x$ = MID$(roman, i, 1)
56.     n = 1000
57.     SELECT CASE x$
58.         CASE "M": n = n / 1
59.         CASE "D": n = n / 2
60.         CASE "C": n = n / 10
61.         CASE "L": n = n / 20
62.         CASE "X": n = n / 100
63.         CASE "V": n = n / 200
64.         CASE "I": n = n / n
65.         CASE ELSE: n = 0
66.     END SELECT
67.     IF n < prenum THEN num = num - n ELSE num = num + n
68.     prenum = n
69. NEXT i
70.  
71. romToDec = num
72.  
73. END FUNCTION