DBR Delphi-Ecke

// Wenn ich mich richtig an meine Schulzeit (die schon etwas her ist)
// erinnere, stellen folgende Buchstaben römische Ziffern dar:
// I = 1
// V = 5
// X = 10
// L = 50
// C = 100
// D = 500
// M = 1000
// Mit diesen Werten lassen sich Zahlen von 1 bis 3999 darstellen, denn
// die Zeichen für 1, 10, 100 und 1000 (I, X, C, M) dürfen höchstens
// dreimal nebeneinanderstehen, die Zeichen für 5, 50 und 500 (V, L, D)
// nur einmal. Steht ein kleinerer Wert links neben einem größeren, wird
// er subtrahiert, steht er rechts, wird er addiert.
// Beispiele:
// VI = 6 aber IV = 4
// CIX = 109 aber XCIX = 99

// Getestet mit D4 unter XP

// Variante 1: 
 
function roemisch1(zahl: word): string; 
const 
  rz: array[0..6] of char = ('I', 'V', 'X', 'L', 'C', 'D', 'M'); 
var 
  s: string; 
  st, x, lg: Integer; 
begin 
  result := ''; 
  if (zahl > 0) and (zahl < 4000) then begin 
    s := inttostr(zahl); 
    lg := length(s); 
    for x := 1 to lg do begin 
      st := (lg - x) * 2; 
      case s[x] of 
        '1': result := result + rz[st]; 
        '2': result := result + rz[st] + rz[st]; 
        '3': result := result + rz[st] + rz[st] + rz[st]; 
        '4': result := result + rz[st] + rz[st + 1]; 
        '5': result := result + rz[st + 1]; 
        '6': result := result + rz[st + 1] + rz[st]; 
        '7': result := result + rz[st + 1] + rz[st] + rz[st]; 
        '8': result := result + rz[st + 1] + rz[st] + rz[st] + rz[st]; 
        '9': result := result + rz[st] + rz[st + 2]; 
      end; 
    end; 
  end; 
end; 
 
 
// Variante 2: 
 
function roemisch2(zahl: word): string; 
const 
  zhln: array[1..13] of word = 
     (1,   4,   5,   9, 
     10,  40,  50,  90, 
    100, 400, 500, 900, 
   1000); 
  strngs: array[1..13] of string = 
   ('I', 'IV', 'V', 'IX', 
    'X', 'XL', 'L', 'XC', 
    'C', 'CD', 'D', 'CM', 
    'M'); 
var 
  x: integer; 
begin 
  result := ''; 
  if (zahl > 0) and (zahl < 4000) then begin 
    for x := 13 downto 1 do 
      while (zahl >= zhln[x]) do begin 
        zahl := zahl - zhln[x]; 
        result := result + strngs[x];      
      end; 
  end; 
end; 
 
 
// Beispielaufrufe 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Label1.Caption := roemisch1(749); 
  label2.Caption := roemisch2(749); 
end;

// --------------------------------------------------------------

// Und so funktioniert der umgekehrte Weg (also römische Zahlen
// in arabische Zahlen wandeln):

function arabisch(roemisch: string; IgnoreCase: boolean): integer; 
var 
  x, p, lg, Summe: integer; 
const 
  r: array[1..13] of string = 
  ('CM', 'M', 'CD', 'D', 'XC', 'C', 'XL', 'L', 'IX', 'X', 'IV', 'V', 'I'); 
  a: array[1..13] of integer = 
  (900, 1000, 400, 500, 90, 100, 40, 50, 9, 10, 4, 5, 1); 
 
  function test1: boolean; 
  begin 
    result := pos('IIII', roemisch) or pos('XXXX', roemisch) or 
      pos('CCCC', roemisch) or pos('MMMM', roemisch) or pos('VV', roemisch) 
      or pos('LL', roemisch) or pos('DD', roemisch) > 0; 
  end; 
 
  function test2: boolean; 
  var 
    z: integer; 
  begin 
    if p + 2 <= length(roemisch) then begin 
      for z := 1 to 13 do 
        if (r[z] = roemisch[p + 2]) then begin 
          result := a[z] > a[x]; 
          exit; 
        end; 
    end else result := false; 
  end; 
 
  function test3: boolean; 
  var 
    y: integer; 
  begin 
    result := lg = 1; 
    if not result then 
      for y := 1 to 13 do 
        if (r[y] = roemisch[p - 1]) then begin 
          result := a[y] < a[x]; 
          break; 
        end; 
  end; 
 
begin 
  Result := 0; 
  if IgnoreCase then 
    roemisch := uppercase(roemisch); 
  if test1 then exit; 
  Summe := 0; 
  for x := 1 to 13 do 
    repeat 
      p := pos(r[x], roemisch); 
      if p > 0 then begin 
        lg := length(r[x]); 
        if (lg > 1) then if test2 then exit; 
        if (p > 1) then if test3 then exit; 
        inc(Summe, a[x]); 
        delete(roemisch, p, lg); 
      end else break 
    until false; 
  if (Summe > 3999) or (roemisch <> '') then exit; 
  Result := Summe; 
end; 
 
 
 
// Beispielaufruf 
 
procedure TForm1.Button8Click(Sender: TObject); 
var i: Integer; 
begin 
  i := arabisch('MCCXXXIV', false); 
  if i = 0 then showmessage('Das war jetzt aber keine römische Zahl') 
  else showmessage(inttostr(i)); 
end;