Code-Beispiel

Die römischen Zahlen

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

Wer die römischen Zahlen noch nicht kennt hier
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 Volta angelegt.
Die aktuellste Version wurde am 27.07.2011 von ytwinky gespeichert.

Bearbeiten

Versionen