{$IFNDEF __TMT__} {$N+} {$ENDIF}

program Cvt_Rome
  (* Converts between Longint and Roman Numerals, 1998<->MCMXCVIII *) ;

function LongintToRoman(const N : longint) : string { from WR-ROMAN.PAS } ;
const Digits = 7 ; Four = 4 ;
type Decades = 0..Pred(Digits) ;
const Pattern : array ['0'..'9'] of string [Four] =
  ('', 'x', 'xx', 'xxx', 'xy', 'y', 'yx', 'yxx', 'yxxx', 'xz') ;
const DecXlatn : array [Decades] of array ['x'..'z'] of char =
  ('IVX', 'XLC', 'CDM', 'Mvx', 'xlc', 'cdm', 'm?!' {, ...}) ;
var DecDigit, Ch : byte ; S : string [Succ(Digits)] ;
PartRomn : string [Four] ; Romn : string [Four*Digits] ;
begin Romn := '' ;
  if N<0 then begin LongintToRoman := 'Negative' ; EXIT end ;
  Str(N, S) ;
  if Length(S)>Digits then begin LongintToRoman := 'Too Big' ; EXIT end ;
  for DecDigit := 1 to Length(S) do begin
    PartRomn := Pattern[S[DecDigit]] ;
    for Ch := 1 to Length(PartRomn) do
      PartRomn[Ch] := DecXlatn[Length(S)-DecDigit][PartRomn[Ch]] ;
    Romn := Romn + PartRomn end {DecDigit} ;
  LongintToRoman := Romn end {LongintToRoman} ;


{ Function adapted from Delphi code of Philippe Ranger, OK up to 3999 }
function PhRoman(num : longint) : string
  (* returns num in capital roman digits *) ;
const Nvals = 13 ;
type Tval = 1..NVals ;
const
vals : array [Tval] of word =      ( 1,     4,   5,    9,  10,
  {}    40,  50,   90, 100,  400, 500, 900, 1000) ;
roms : array [Tval] of string [2] = ('I', 'IV', 'V', 'IX', 'X',
  {}   'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M') ;
var b : Tval ; Answer : string [15] ;
begin Answer := '' ;  b := Nvals ;
  while num>0 do begin
    while vals[b] > num do Dec(b) ;
    Dec(num, vals[b]) ;
    Answer := Answer + roms[b] ;
    end ;
  PhRoman := Answer end { End PhR code } ;


function RomanToLongint1(const S : string) : longint ;
const Chars = 'IVXLCDMvxlcdm?!' ;
Valu : array [0..Length(Chars)] of longint =
  (0, 1, 5, 10, 50, 100, 500, 1000, 5000, 10000, 50000, 100000,
  500000, 1000000, 5000000, 10000000) ;
var Sum, NewV, OldV : longint ; K : byte ;
begin Sum := 0 ; OldV := 0 ;
  for K := Length(S) downto 1 do begin
    NewV := Valu[Pos(S[K], Chars)] ;
    if NewV=0 then begin Write(' Duff! ') ; Sum := -1 ; BREAK end ;
    if NewV<OldV then NewV := - NewV ;
    Inc(Sum, NewV) ; OldV := NewV end ;
  RomanToLongint1 := Sum ;
  end {RomanToLongint1} ;

function RomanToLongint2(const S : string) : longint ;
const Chars = 'IVXLCDMvxlcdm?!#' ;
Valu : array [0..Length(Chars) div 2] of longint =
  (0, 1, 10, 100, 1000, 10000, 100000, 1000000, 10000000) ;
OneOrFive : array [boolean] of byte = (1, 5) ;
var Sum, NewV, OldV : longint ; K, P : byte ;
begin Sum := 0 ; OldV := 0 ;
  for K := Length(S) downto 1 do begin
    P := Succ(Pos(S[K], Chars)) ;
    NewV := OneOrFive[Odd(P)]*Valu[P div 2] ;
    if NewV=0 then begin Write(' Duff! ') ; Sum := -1 ; BREAK end ;
    if NewV<OldV then NewV := - NewV ;
    Inc(Sum, NewV) ; OldV := NewV end ;
  RomanToLongint2 := Sum ;
  end {RomanToLongint2} ;

var R : single ; J, L1, L2, OldJ : longint ; St1, St2 : string [30] ;

BEGIN Writeln('CVT_ROME www.merlyn.demon.co.uk >= 2000-10-03') ;
Writeln(' - lower-case letters need over-bar => *1000') ;
R := 0.1 ; OldJ := -1 ;
repeat { test }
  J := Round(R) ;
  if J>OldJ then begin OldJ := J ; Write(J:8) ;
    St1 := LongintToRoman(J) ; Write(St1:24, '':2) ;
    St2 := PhRoman(J) ; Write(St2:20, '':2) ;
    L1 := RomanToLongint1(St1) ; Write(L1:8) ;
    L2 := RomanToLongint2(St1) ; Write(L2:8) ;
    if (L1=J) and (L2=J) then Writeln else
      begin Write(' TestFail! ') ; BREAK end ;
    end ;
  case 3 of { <- Alter case statement & until limit to test }
    1 : R := R+1 ;
    2 : R := R*1.007 ;
    3 : R := R*1.06 ;
    end ;
  until R>=1111111 ;
Write('<cr>') ; Readln ;
Writeln('First numbers of each length :') ;
L1 := 0 ;
for J := 1 to 1000000 do begin St2 := LongintToRoman(J) ;
  if length(St2) >L1 then begin L1 := Length(St2) ;
    writeln(J:8, L1:4, St2:26) end ;
  end ;
Write('<cr>') ; Readln ;
END.