Page 1 of 1
Convert Integer values to Roman values
Posted: Mon Aug 22, 2005 8:47 am
by Flype
Code updated For 5.20+
Code: Select all
;
; Integer value -> Roman value
; Philippe Carpentier - 2005
;
Procedure.s RomVal(num)
res.s = ""
For i = 1 To 13
a.s = StringField("1000,M;900,CM;500,D;400,CD;100,C;90,XC;50,L;40,XL;10,X;9,IX;5,V;4,IV;1,I", i, ";")
b = Val(StringField(a, 1, ","))
c.s = StringField(a, 2, ",")
While num >= b
res + c : num - b
Wend
Next
ProcedureReturn res
EndProcedure
;- exemple
For i = 1 To 50
msg.s + RomVal(i) + Chr(10)
Next
MessageRequester("",msg)
It will be faster by using an array or a list, but works well.
best regards.
Posted: Wed Jun 21, 2006 6:29 pm
by Flype
optimised one (with reverse procedure) :
Code: Select all
Global Dim RC.l('X') ; RC.l($FFFF) for unicode
RC('I') = 0001
RC('V') = 0005
RC('X') = 0010
RC('L') = 0050
RC('C') = 0100
RC('D') = 0500
RC('M') = 1000
Global Dim RL.l(12)
RL(00) = 1000
RL(01) = 0900
RL(02) = 0500
RL(03) = 0400
RL(04) = 0100
RL(05) = 0090
RL(06) = 0050
RL(07) = 0040
RL(08) = 0010
RL(09) = 0009
RL(10) = 0005
RL(11) = 0004
RL(12) = 0001
Global Dim RS.s(12)
RS(00) = "M"
RS(01) = "CM"
RS(02) = "D"
RS(03) = "CD"
RS(04) = "C"
RS(05) = "XC"
RS(06) = "L"
RS(07) = "XL"
RS(08) = "X"
RS(09) = "IX"
RS(10) = "V"
RS(11) = "IV"
RS(12) = "I"
Procedure.s StrR(number.l)
Protected i.l, result.s
For i = 0 To 12
While number >= RL(i)
number - RL(i)
result + RS(i)
Wend
Next
ProcedureReturn result
EndProcedure
Procedure.l ValR(number.s)
Protected oldvalue.l, result.l
Protected *num.Character = @number + Len(number) * SizeOf(Character) - SizeOf(Character)
While *num\c
If oldvalue > RC(*num\c)
result - RC(*num\c)
Else
result + RC(*num\c)
EndIf
oldvalue = RC(*num\c)
*num - SizeOf(Character)
Wend
ProcedureReturn result
EndProcedure
Posted: Thu Jun 22, 2006 3:58 am
by Konne
Nice
Posted: Thu Jun 22, 2006 8:14 am
by Flype
and unicode ready.
maybe droopy can embed it in his userlib.
and could be useful (for me but also for others) in conjonction with PurePDF to make what you guess...
Posted: Thu Jun 22, 2006 9:00 pm
by kenmo
Cool, but...
There's gotta be a more efficient way to do it than allocating 65535 longs and only using 7 of them!
Posted: Thu Jun 22, 2006 11:03 pm
by Flype
yes but it's for unicode-length cars and for speed i don't think it's a problem, and it works with Global Dim RC('X').
but i made for my own plenty of differents way, stringfield way is the shortest, but slower. array is the longest but the faster.
as long as there's no associative array in pb...
Posted: Sat Jun 24, 2006 10:59 am
by Konne
Sry but for such a thing a array with this size ! That's insane!!!
Posted: Sat Jun 24, 2006 12:54 pm
by Flype
a array of Dim('X') is only (88*4)=352 bytes.
but, ok, i take care of your remarks and i publish a modified version
based on Select/Case/EndSelect method which is just a little bit slower.
Code: Select all
Procedure.s StrR(number.l)
Protected i.l, value.l, result.s
For i = 0 To 12
Select i
Case 0: value = 1000
Case 1: value = 900
Case 2: value = 500
Case 3: value = 400
Case 4: value = 100
Case 5: value = 90
Case 6: value = 50
Case 7: value = 40
Case 8: value = 10
Case 9: value = 9
Case 10: value = 5
Case 11: value = 4
Case 12: value = 1
EndSelect
While number >= value
Select i
Case 0: result + "M"
Case 1: result + "CM"
Case 2: result + "D"
Case 3: result + "CD"
Case 4: result + "C"
Case 5: result + "XC"
Case 6: result + "L"
Case 7: result + "XL"
Case 8: result + "X"
Case 9: result + "IX"
Case 10: result + "V"
Case 11: result + "IV"
Case 12: result + "I"
EndSelect
number - value
Wend
Next
ProcedureReturn result
EndProcedure
Procedure.l ValR(number.s)
Protected oldvalue.l, value.l, result.l, offset = Len(number)
While offset
Select Asc(Mid(number, offset, 1))
Case 'I': value = 1
Case 'V': value = 5
Case 'X': value = 10
Case 'L': value = 50
Case 'C': value = 100
Case 'D': value = 500
Case 'M': value = 1000
EndSelect
If oldvalue > value
result - value
Else
result + value
EndIf
oldvalue = value
offset - 1
Wend
ProcedureReturn result
EndProcedure