1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128
|
{
RomanUtils unit v0.0.1.3 - 03/11/2006
Main code :
Deefaze [f0xi/Dr.Who - delphifr/www.developpez.com] 5/11/2005
Additionnal code :
Florenth - delphifr
Special thanks :
Delphiprog - delphifr
Florenth - delphifr
RomanUtils link, news and support :
delphifr
}
UNIT RomanUtils;
////////////////////////////////////////////////////////////////////////////////////////////////////
INTERFACE
////////////////////////////////////////////////////////////////////////////////////////////////////
// INTERFACE_USES ----------------------------------------------------------------------------------
USES SysUtils, Dialogs, math;
// INTERFACE_FUNCTIONS -----------------------------------------------------------------------------
Function IsRomanNumber(const RN : string) : boolean; overload;
Function IsRomanNumber(const I : integer) : boolean; overload;
Function RomanCharToValue(const RV : char) : integer;
Function RomanToInt(const RN : string) : integer;
Function IntToRoman(const I : integer) : String;
// INTERFACE_VARS ----------------------------------------------------------------------------------
VAR
RomanValidWarnMessage : string;
RomanRangeWarnMessage : string;
RomanDisableWarnMessage: boolean = false;
// INTERFACE_CONSTS --------------------------------------------------------------------------------
CONST
RomanNumber = ['I','V','X','L','C','D','M'];
////////////////////////////////////////////////////////////////////////////////////////////////////
IMPLEMENTATION
////////////////////////////////////////////////////////////////////////////////////////////////////
// MESSAGE_ROMANNOTVALID (private) ----------------------------------------------------------------
procedure Message_RomanNotValid(const value : string);
begin
if length(RomanValidWarnMessage) = 0 then
RomanValidWarnMessage := 'not a valid Roman number.';
MessageDlg(format('<%s> %s',[value,RomanValidWarnMessage]),mtWarning,[mbOk],0);
end;
// MESSAGE_OUTOFROMANRANGE (private) ----------------------------------------------------------------
procedure Message_OutOfRomanRange(const value : integer);
begin
if length(RomanRangeWarnMessage) = 0 then
RomanRangeWarnMessage := 'not in interval';
MessageDlg(format('<%d> %s 1 > 3999.',[value,RomanRangeWarnMessage]),mtWarning,[mbOk],0);
end;
// ROMANCHARTOVALUE --------------------------------------------------------------------------------
function RomanCharToValue(const RV : char) : integer;
begin
result := 0;
case RV of
'I','i' : result := 1;
'V','v' : result := 5;
'X','x' : result := 10;
'L','l' : result := 50;
'C','c' : result := 100;
'D','d' : result := 500;
'M','m' : result := 1000;
end;
end;
// ISROMANNUMBER -----------------------------------------------------------------------------------
function IsRomanNumber(const RN : string) : boolean;
var oc : integer;
begin
result := true;
for oc := 1 to length(RN) do
if not (Rn[oc] in RomanNumber) then begin
result := false;
exit;
end;
end;
function IsRomanNumber(const I : integer) : boolean;
begin
result := (I >= 1) and (I <= 3999);
end;
// ROMANTOINT --------------------------------------------------------------------------------------
function RomanToInt(const RN : string) : integer;
var oc, OldRV, NewRV : integer;
begin
Result := 0;
OldRV := 0;
if IsRomanNumber(RN) then begin
for oc := 1 to length(RN) do begin
NewRV := RomanCharToValue(RN[oc]);
if NewRV > OldRV then
inc(Result, NewRV-(OldRV shl 1))
else
inc(Result, NewRV);
OldRv := NewRV;
end;
end else begin
if RomanDisableWarnMessage = false then
Message_RomanNotValid(RN);
end;
end;
// INTTOROMAN --------------------------------------------------------------------------------------
const
_RRUTR : array [0..9] of string = ('','I','II','III','IV','V','VI','VII','VIII','IX');
_RRDTR : array [0..9] of string = ('','X','XX','XXX','XL','L','LX','LXX','LXXX','XC');
_RRCTR : array [0..9] of string = ('','C','CC','CCC','CD','D','DC','DCC','DCCC','CM');
_RRMTR : array [0..9] of string = ('','M','MM','MMM','','','','','','');
function IntToRoman(const I : integer) : string;
begin
result := '';
if IsRomanNumber(i) then begin
case I of
0..9 : Result := _RRUTR[i];
10..99 : Result := _RRDTR[i div 10]+
_RRUTR[i mod 10];
100..999 : Result := _RRCTR[i div 100]+
_RRDTR[i div 10 mod 10]+
_RRUTR[i mod 10];
1000..3999 : Result := _RRMTR[i div 1000]+
_RRCTR[i div 100 mod 10]+
_RRDTR[i div 10 mod 10]+
_RRUTR[i mod 10];
end;
end else begin
if RomanDisableWarnMessage = false then
Message_OutOfRomanRange(I);
end;
end;
end. |
Partager