Conversion en chiffres romains

[Micoute]

Bonjour à tous,

pour mes besoins personnels, j'ai eut besoin d'une conversion en chiffres romains, alors si ça intéresse quelqu'un, voici ma contribution.

Code : Tout sélectionner

;Conversion en chiffres_romains

Global nombre, Dim romain.s(6), Dim arabe.i(6), somme_temporaire, i, a, g, sortie.s = ""

romain(0) = "I"
romain(1) = "V"
romain(2) = "X"
romain(3) = "L"
romain(4) = "C"
romain(5) = "D"
romain(6) = "M"

arabe(0) = 1
arabe(1) = 5
arabe(2) = 10
arabe(3) = 50
arabe(4) = 100
arabe(5) = 500
arabe(6) = 1000


Procedure.s EntrerNombre(nombre)
  sortie = ""
  i = 6
  
  somme_temporaire = nombre
  
  While (somme_temporaire > 0)
    
    If (somme_temporaire / arabe(i) >= 1)
      
      a = somme_temporaire / arabe(i)
      g = 0
      
      While (g < a)
        sortie + romain(i)
        g = g+1
      Wend
      
    EndIf
    
    somme_temporaire = Mod(somme_temporaire, arabe(i))
    i = i - 1
    
  Wend
  
  ProcedureReturn sortie
  
EndProcedure

CompilerIf #PB_Compiler_IsMainFile  
Debug EntrerNombre(2017)
CompilerEndIf

[Zorro]

cool,
de mémoire , ça a deja ete fait sur le forum
mais faire et refaire, c'est toujours travailler

[Micoute]

J'aurais chercher avant, ça aurait été moins laborieux.

[Marc56]

Ton programme donne certains selon la méthode ancienne: Dans la méthode classique, seul M (1000) peut être répété 4 fois, pour les autres il faut soustraire

Code : Tout sélectionner

Debug EntrerNombre(2009)
Debug EntrerNombre(9)
Debug EntrerNombre(90)

MMVIIII
VIIII
LXXXX

2009 -> MMIX (2010 - 1)
9 : VIIII devrait être IX (10 - 1)
90: LXXXX devrait être XC (100 - 10)
etc

Mais comme dit Wikipedia « L'épigraphie prouve que plusieurs graphies ont coexisté librement et le mode opératoire décrit ci-dessus ne s'est fixé que tardivement. Certains nombres peuvent s'écrire sous différentes formes, comme 4 écrit IIII plutôt que IV, 8 écrit IIX plutôt que VIII, 9 écrit VIIII plutôt que IX, 40 écrit XXXX plutôt que XL, 95 écrit LXXXXV plutôt que XCV, ou 400 écrit CCCC plutôt que CD. La monnaie romaine privilégie d'ailleurs les formes additives, préférant IIII à IV et VIIII à IX7. »
https://fr.wikipedia.org/wiki/Num%C3%A9 ... 9sentation

Mais c'est la forme soustractive (10 = 9-1) qui est le plus souvent utilisée (notamment pour mettre la date des films et la rendre la plus illisible possible)

[Kwai chang caine]

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  

[Micoute]

Pour une fois que je n'implore l'aide de quelqu'un, je regrette presque de ne pas l'avoir fait, heureusement que je n'ai pas réinventé un code existant.

[Kwai chang caine]

Comme dit ZORRO, c'est cool de le faire nous même....et après au pire de comparer avec ce qui a été fait, parfois par des meilleurs que nous (enfin pour ma part, presque toujours )

Te plaint pas...alors moi aujourd'hui je crois que j'ai battu le record à ce jeu.
Ca fait 2 jours donc 20 heures que je planche à grand coups de bassines d'API, CallBack et SubClassing, pour essayer de créer quelque chose qui existe déjà, le "MdiGadget"

Put...mais quelle idée qu'il a eu le FREDO de nommer "GADGET" un truc qui gère les fenêtre
Je l'ai vu passer plusieurs fois en plus de 10 ans...mais jamais percuté

Je me suis fait chier à tout reproduire, J'ai utilisé l'API pour mettre les fenêtres en filles, et roule ma poule,
Y'a fallu que je créé, la réduction des fenêtres en icône (merci Zorro ), les déplacements, la gestion des clipcontrols de fenêtre qui au maximize, vont s'installer dans le menu, et encore what mille fonctions qui au début paraissaient simples
J'ai retapissé toute la chambre de mon IDE d'API
Et quant j'ai compris que ça existait....ça a allégé mon code de moitié
alors bienvenue au club

[beruska]

Le plus simple que j'ai trouvé...

Code : Tout sélectionner

Procedure.s Romani(number.l) ; Conversion d'un nombre entier en chiffres romains 
  
  Protected i.l, value.l, result.s 
  
  For i = 1 To 13 
    value = Val(StringField("1000,900,500,400,100,90,50,40,10,9,5,4,1", i, ",")) 
    While number >= value 
      result + StringField("M,CM,D,CD,C,XC,L,XL,X,IX,V,IV,I", i, ",") 
      number - value 
    Wend 
  Next 
  
  ProcedureReturn result 
  
EndProcedure 

; une série  
For i = 1900 To 2017 
  Debug Str(i) + " = " + Romani(i) 
Next

[Zorro]

@beruska:
Vraiment un tres tres bon code !!

[Ollivier]

Oui, je crois que là, tu es le premier. On ne peut pas mieux...

[beruska]

Pour cette conversion en chiffres romains, je n'ai aucun mérite; je l'ai déniché quelque part en 2014, et je l'ai ramassé dans mes "trucs"; c'est vraiment très concis. Salut à tous.

[Micoute]

Le plus grand défaut avec ce genre de programme, c'est qu'il ne faut pas dépasser l'an 4999, sinon ça fait une grande série de M, il suffirait de faire une convention pour écrire les nombres supérieurs à 5000, voire au-delà.

[Zorro]

ha oui c'etait un code de Flype
Posté: Dim 18/Juin/2006 à 23:58

http://www.purebasic.fr/french/viewtopic.php?f=6&t=5239

[falsam]

ha oui c'etait un code de Flype

sapristi, sapristi !!!!! un plagiat sur ce forum. au bûcher le manant qui ne cite pas les sources !

[Kwai chang caine]

qu’on a pendu un beau matiiiiiiiiiiiin !!!
Qu’on a penduuuuuuuuu avec ses triiiiiipeeeeeuuuuuu !!!