Merci pour le partage
de mémoire , ça a deja ete fait sur le forum
Oui je m'en rappelais aussi
Y'a des codes de pleins de monde, que j'ai pas testé :
AND51
Code : Tout sélectionner
Procedure.s Dec2Rome(number.q) ; AND51 / Dec-2007
Protected result.s, temp=number/1000
If temp > 0 ;{ thounsand's
result=Space(temp)
ReplaceString(result, " ", "M", 2)
number-temp*1000
EndIf ;}
While number > 99 ;{ hundred's
temp=number/100
Select temp
Case 1 To 3
result+Space(temp)
ReplaceString(result, " ", "C", 2)
Case 4
result+"CD"
Case 5 To 8
result+"D"
temp=5
Case 9
result+"CM"
EndSelect
number-temp*100
Wend ;}
While number > 9 ;{ ten's
temp=number/10
Select temp
Case 1 To 3
result+Space(temp)
ReplaceString(result, " ", "X", 2)
Case 4
result+"XL"
Case 5 To 8
result+"L"
temp=5
Case 9
result+"XC"
EndSelect
number-temp*10
Wend ;}
While number ;{ one's
temp=number
Select temp
Case 1 To 3
result+Space(temp)
ReplaceString(result, " ", "I", 2)
Case 4
result+"IV"
Case 5 To 8
result+"V"
temp=5
Case 9
result+"IX"
EndSelect
number-temp
Wend ;}
ProcedureReturn result
EndProcedure
For n=30 To 230 Step 21
Debug Str(n)+" to rome: "+Dec2Rome(n)
Next
ATHOW
Code : Tout sélectionner
; code Athow
; purebasic 4.10
Procedure.w nr_valeurChiffreRomain(l.s)
l=UCase(l)
Select l
Case "I"
ProcedureReturn 1
Case "V"
ProcedureReturn 5
Case "X"
ProcedureReturn 10
Case "L"
ProcedureReturn 50
Case "C"
ProcedureReturn 100
Case "D"
ProcedureReturn 500
Case "M"
ProcedureReturn 1000
Default
ProcedureReturn 0
EndSelect
EndProcedure
Procedure.w nr_valeurNombreRomain(nr.s)
If nr = ""
ProcedureReturn 0
Else
res.w = 0
If Len(nr) = 1
ProcedureReturn nr_valeurChiffreRomain(nr)
Else
res = nr_valeurChiffreRomain(Left(nr, 1))
If res < nr_valeurChiffreRomain(Mid(nr, 2, 1))
res = -res
EndIf
ProcedureReturn res + nr_valeurNombreRomain(Right(nr,Len(nr)-1))
EndIf
EndIf
EndProcedure
Procedure.s nr_toNombreRomain(n.w)
res.s = ""
tmp.w = n
While tmp >= 1000
res + "M"
tmp - 1000
Wend
If tmp >= 900
res + "CM"
tmp - 900
EndIf
If tmp >= 800
res + "DCCC"
tmp - 800
EndIf
If tmp >= 700
res + "DCC"
tmp - 700
EndIf
If tmp >= 600
res + "DC"
tmp - 600
EndIf
If tmp >= 500
res + "D"
tmp - 500
EndIf
If tmp >= 400
res + "CD"
tmp - 400
EndIf
If tmp >= 300
res + "CCC"
tmp - 300
EndIf
If tmp >= 200
res + "CC"
tmp - 200
EndIf
If tmp >= 100
res + "C"
tmp - 100
EndIf
If tmp >= 90
res + "XC"
tmp - 90
EndIf
If tmp >= 80
res + "LXXX"
tmp - 80
EndIf
If tmp >= 70
res + "LXX"
tmp - 70
EndIf
If tmp >= 60
res + "LX"
tmp - 60
EndIf
If tmp >= 50
res + "L"
tmp - 50
EndIf
If tmp >= 40
res + "XL"
tmp - 40
EndIf
If tmp >= 30
res + "XXX"
tmp - 30
EndIf
If tmp >= 20
res + "XX"
tmp - 20
EndIf
If tmp >= 10
res + "X"
tmp - 10
EndIf
If tmp = 9
res + "IX"
ElseIf tmp = 8
res + "VIII"
ElseIf tmp = 7
res + "VII"
ElseIf tmp = 6
res + "VI"
ElseIf tmp = 5
res + "V"
ElseIf tmp = 4
res + "IV"
ElseIf tmp = 3
res + "III"
ElseIf tmp = 2
res + "II"
ElseIf tmp = 1
res + "I"
EndIf
ProcedureReturn res
EndProcedure
For i.w=1 To 4000
nr.s = nr_toNombreRomain(i)
Debug Str(i) + " -> " + nr + " -> " + Str(nr_valeurNombreRomain(nr))
Next i
Plusieurs de FLYPE
Code : Tout sélectionner
-
;- Objet : Conversion d'un nombre entier en chiffres romains
;- Utilisation : String.s = IntToRom(Integer.l)
;- Pré-Requis : Integer doit être compris entre 1 et 10000
;-
Procedure.s IntToRom(n.l)
If (n<1) Or (n>10000)
ProcedureReturn "n/a"
EndIf
num.s = "1000,900,500,400,100,90,50,40,10,9,5,4,1"
rom.s = "M,CM,D,CD,C,XC,L,XL,X,IX,V,IV,I"
For i = 1 To 13
a = Val(StringField(num,i,","))
While n >= a
res.s + StringField(rom,i,",")
n - a
Wend
Next
ProcedureReturn res
EndProcedure
;- Exemples d'utilisation
Debug IntToRom(-45)
Debug IntToRom(1998)
Debug IntToRom(2005)
Debug IntToRom(10004)
Debug "----"
For i = 1900 To 2005
Debug Str(i) + " = " + IntToRom(i)
Next
Code : Tout sélectionner
Global Dim RC.l($FFFF), Dim RL.l(12), Dim RS.s(12)
RC('I') = 0001
RC('V') = 0005
RC('X') = 0010
RC('L') = 0050
RC('C') = 0100
RC('D') = 0500
RC('M') = 1000
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
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) ; Conversion d'un nombre entier en nombre romain. [0<n<10000]
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) ; Conversion d'un nombre romain en nombre entier. [I<n<MMMM]
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
z = ElapsedMilliseconds()
For j.l = 0 To 50
For i.w = 1 To 4000
TEST$ = Str(i) + " = " + StrR(i) + " = " + Str(ValR(StrR(i)))
Debug TEST$
Next i
Next j
MessageRequester("", Str(ElapsedMilliseconds()-z))
Mback2k
Code : Tout sélectionner
Procedure.s RomDec(dec.l)
Protected i.b, j.l, max.b, ind.w, num.w, chr.w, rom.s
Restore RomNum : Read.b max
For i = 1 To max
Read.w ind : Read.w num : Read.w chr
For j = 1 To Round((dec / num), #PB_Round_Down)
rom + Chr(chr)
Next : dec % num
Next
ProcedureReturn rom
EndProcedure
Procedure.l DecRom(rom.s)
Protected i.b, j.w, max.b, ind.w, num.w, chr.w, dec.l
Restore RomNum : Read.b max
For i = 1 To max
Read.w ind : Read.w num : Read.w chr
For j = 0 To Len(rom)-1
If PeekC(@rom+j) = chr : PokeC(@rom+j, ind)
If j And PeekC(@rom+(j-1)) < ind : dec - num
Else : dec + num : EndIf
EndIf
Next
Next
ProcedureReturn dec
EndProcedure
DataSection
RomNum:
Data.b 7 ; Total
Data.w 7, 1000, 'M'
Data.w 6, 500, 'D'
Data.w 5, 100, 'C'
Data.w 4, 50, 'L'
Data.w 3, 10, 'X'
Data.w 2, 5, 'V'
Data.w 1, 1, 'I'
EndDataSection
r.s = RomDec(1949)
d.l = DecRom(r)
Debug d
Debug r
Josef Sniatecki
Code : Tout sélectionner
Procedure RomDec(Rom.s)
Protected *Char.Character,Index.l
Protected Num.l,Level.l,ONum.l
*Char=@Rom+Len(Rom)-1
While *Char<>@Rom-1
Select *Char\C
Case 'I'
ONum=1
Case 'V'
ONum=5
Case 'X'
ONum=10
Case 'L'
ONum=50
Case 'C'
ONum=100
Case 'D'
ONum=500
Case 'M'
ONum=1000
EndSelect
If Level<=ONum
Level=ONum
Num+ONum
Else
Num-ONum
EndIf
*Char-1
Wend
ProcedureReturn Num
EndProcedure
Debug RomDec("XLCMX")
XABI
Code : Tout sélectionner
;/ Folker Linstedt
;/ 2007|12|23
;/ arabische Zahlen in römische Zahlen umwandeln
; I = 1, II = 2, III = 3, IV = 4, V = 5, VI = 6, VII = 7, VIII = 8, 9 = IX, 10 = X,
; XI = 11, XII = 12, ... 19 = XIX aber nicht IXX
; XXXIX = 39
;/ Regeln:
; - 5er können nicht addiert werden.
; - 1er können maximal drei addiert werden! Beachte 39, 390, 3900
; - 1er kann höchstens einer abgezogen werden
; - es können einer nur von 5er gleicher Ordnung oder 1ern einer Ordnung höher abgezogen werden
; - es können gleichzeitig keine 1er addiert und subtraiert werden (entweder oder)
;/ maximale Zahl: MMMCMXCIX - 3999
;/ oft verwendete Zahl : MCMXCIX - 1999 (Jahr-2000-Problem Y2K)
; 1 = I
; 5 = V, 10 = X
; 50 = L, 100 = C,
;500 = D,1000 = M,
;/ http://www.mathematische-basteleien.de/roemisch.htm
;/
Z$="2548" ;/ Beispiel-Zahl
;/ erwartetes Ergebnis: MMDXLVIII
R$="" ;/ römische Zahl
;/ Ansatz 1
; Z=Val(Z$)
; R$=RSet("",Z / 1000 ,"M")
;/ Ansatz 2
Dim R.s(4)
Procedure.s RepStr(R1$="",R2$="L",R3$="C")
Sx$="I;II;III;IV;V;VI;VII;VIII;IX"
If R1$
Sx$=ReplaceString(Sx$,"X",R3$)
Sx$=ReplaceString(Sx$,"V",R2$)
Sx$=ReplaceString(Sx$,"I",R1$)
EndIf
ProcedureReturn Sx$
EndProcedure
R(1)=RepStr()
R(2)=RepStr("X")
R(3)=RepStr("C","D","M")
R(4)=RepStr("M","Y","K") ;/ geht erstmal nur für "M"
Z$=InputRequester("Zahl eingeben","arabische Zahl","123")
If Val(Z$)<4000
;/ dieser Block erstellt römische Zahlen
L=Len(Z$)
For i=1 To L
R$+StringField(R(L+1-i),Val(Mid(Z$,i,1)),";")
Next
;/
MessageRequester("Ausgabe","arabische Zahl: "+Z$+" entspricht römischer Zahl: "+R$)
Else
MessageRequester("HINWEIS","Diese Zahl ("+Z$+") kann nicht römisch dargestellt werden")
EndIf
;/ umgekehrt ...
Z$=InputRequester("Zahl eingeben","römische Zahl","DCCXXXIX") ; MCMXCIX
;/ Ansatz : Alle Zahlen addieren bzw. Abziehen und das Ergebnis wieder in römische Zahl wandeln und Strings vergleichen.
Z$=Trim(Z$)
;/ Groß-Kleinschreibung-Umwandlung eventuell ...
R$=Z$
Z=0
For h=1 To 4
For i=1 To 9
SxF$=StringField(R(h),10-i,";")
G=FindString(Z$,SxF$,1)
If G
Z$=ReplaceString(Z$,SxF$,"")
Z+Pow(10,(h-1))*(10-i)
EndIf
Next
Next
Z$=Str(Z)
D$=""
;/ dieser Block erstellt römische Zahlen
L=Len(Z$)
For i=1 To L
D$+StringField(R(L+1-i),Val(Mid(Z$,i,1)),";")
Next
;/
If D$=R$
MessageRequester("Ausgabe","römische Zahl: "+R$+" entspricht arabischer Zahl: "+Str(Z))
Else
MessageRequester("Hinweis : Fehler bei der Eingabe!",Str(Z)+" : Ihre Eingabe: "+R$+Chr(10)+" - Mögliches Ergebnis: "+D$)
EndIf