Buchempfehlung
Mikrocomputertechnik mit Controllern der Atmel AVR-RISC-Familie
Mikrocomputertechnik mit Controllern der Atmel AVR-RISC-Familie
Umfassend, aber leicht verständlich führt dieses Buch in die Programmierung von ATMEL AVR Mikrocontrollern ein. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

Code-Beispiel

Code-Beispiele » Mathematik

Die römischen Zahlen

Lizenz:Erster Autor:Letzte Bearbeitung:
k. A.RedakteurVolta 27.07.2011

Wer die römischen Zahlen noch nicht kennt hier
Externer Link!Römische Zahlendarstellung findet ihr alle nötigen Erklärungen.
Heute findet man römischen Zahlen nur noch auf alten Zifferblättern oder im Filmabspann. Sicher haben diese Funktionen keinen hohen Gebrauchswert, es war nur als Gedächtnistraining geplant.

Function Num2Rom(Number As Integer) As String
    'nur für positive Zahlen von 1 - 3999
    Dim As Integer i = 1, nDigitValue
    Dim As String c, v ,nRoman, nDigits = " IVXLCDM"

    Select Case Number
        Case 1 To 3999
        Case Else
            Return ""
    End Select

    Do While Number > 0
        nDigitValue = Number Mod 10
        c = Chr(nDigits[i])
        v = Chr(nDigits[i + 1])
        Select Case nDigitValue
            Case 1 : nRoman = c & nRoman
            Case 2 : nRoman = c & c & nRoman
            Case 3 : nRoman = c & c & c & nRoman
            Case 4 : nRoman = c & v & nRoman
            Case 5 : nRoman = v & nRoman
            Case 6 : nRoman = v & c & nRoman
            Case 7 : nRoman = v & c & c & nRoman
            Case 8 : nRoman = v & c & c & c & nRoman
            Case 9 : nRoman = c & Chr(nDigits[i + 2]) & nRoman
        End Select
        i = i + 2
        Number = Number \ 10
    Loop
    Function = nRoman
End Function

Function Rom2Num(r As String) As Integer
    'nur für positive Zahlen von 1 - 3999
    Dim As String x = "MDCLXVI", u = "IVIXXLXCCDCM"
    Dim As Integer j, k, z, _
    b(7) = {1000,500,100,50,10,5,1}, _
    c(5) = {2,2,20,20,200,200}

    r = Trim(UCase(r))
    For j = 0 To Len(r)-1
        k = 0
        While r[j] <> x[k]
            k = k + 1
            If k > 6 Then Return 0
        Wend
        z = z + b(k)
    Next j
    For j =  0 To Len(r)-1
        k = 0
        While (r[j] <> u[k]) Or (r[j+1] <> u[k+1])
            k = k + 2
            If k > 10 Then GoTo nx
        Wend
        z = z - c(k/2)
        nx:
    Next j
    Function = z
End Function


Print "3999"; " entspricht "; Num2Rom(3999)
Print "MCMXCVIII"; " entspricht"; Rom2Num("MCMXCVIII")

Sleep

Die Umwandlung von arabischen Zahlen in römische erledigt auch das folgende Programm(Es war jedoch nicht ganz einfach, kein GoTo zu benutzen):

Function Ara2Roem(a As Integer) As String 'arabische Zahlen in römische 'Zahlen' umformen
  Dim As String t(1 To 4, 1 To 10)={{"", "M", "MM", "MMM", "", "", "", "", "", ""}, _ 'Array vorbelegen
                    {"" ,"C", "CC", "CCC", "CD", "D", "", "DCC", "DCCC", "CM"}, _       'Index 0=Leerzeichen
                    {"", "X", "XX", "XXX", "XL", "L", "LX", "LXX", "LXXX", "XC"}, _       'fehlende kriegen Leerzeichen
                    {"", "I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX"}}
  Var az=Str(a+10000) 'arabische Zahl 5-stellig machen, nur die letzten 4 werden gebraucht..
  If a<1 Or a>3999 Then Return "?" 'a ist ungültig, Fragezeichen zurückgeben!
  Return t(1, az[1]-47) & t(2, az[2]-47) & t(3, az[3]-47) & t(4, az[4]-47) 'Schleife nicht nötig ;-))
End Function

'aber dies ist ein neues FB-Programm(natürlich ohne GoTo)..
Function Roem3Ara(r As String) As Integer 'gültige Rückgaben 1..3999, Fehler ist 0 bzw -Fehlerposition
  Dim As Integer aw(1 To 7)={1000, 500, 100, 50, 10, 5, 1}, av(1 To 6)={900, 400, 90, 40, 9, 4}
  Var a=0, i=0, rw="MDCLXVI", rv="CMCDXCXLIXIV", rt=Trim(UCase(r)), lrt=Len(rt)-1
  Do
    If InStr(rw, Chr(rt[i]))=0 Then   Return -i 'negative Fehlerposition zurückgeben..
    If i<lrt Then 'nur wenn es i+1 auch gibt(wg Pointerschreibweise)..
      If InStr(rw, Chr(rt[i]))>InStr(rw, Chr(rt[i+1])) Then 'prüfen ob es ein av(..) sein kann
        a += av(InStr(rv, Chr(rt[i], rt[i+1]))\2+1) '..es ist..
        i += 2 ' i muß dann um 2 erhöht werden
        Continue Do 'weiter bei Loop..
      EndIf
    EndIf
    a += aw(InStr(rw, Chr(rt[i]))) 'normalen Wert ermitteln und summieren
    i += 1 ' i ein Zeichen weiter setzen..
  Loop While i<=lrt 'Stringende=Schleifenende
  Return IIf(a<1 Or a>3999, 0, a) 'nur einen gültigen Wert zurückgeben, sonst 0
End Function

Var a=0, az=""
Do
  Do
    Input "Eine Zahl von 1..3999 eingeben(0=Ende):", a
    If a=0 Then End
  Loop Until (a>=0) And (a<4000)
  az=Ara2Roem(a)
  Print a &" als r”mische Zahl:" & az
  Print az &" als arabische Zahl:" & Roem3Ara(az)
Loop


Zusätzliche Informationen und Funktionen
  • Das Code-Beispiel wurde am 23.07.2011 von RedakteurVolta angelegt.
  • Die aktuellste Version wurde am 27.07.2011 von Redakteurytwinky gespeichert.
  Bearbeiten Bearbeiten  

  Versionen Versionen