Contributor: GREG ESTABROOKS
{$A+,B-,D-,E-,F-,I+,N-,O-,R-,S-,V+}
program TestStringComp;
uses
TpTimer; (* TurboPower's public domain TpTimer unit. *)
(* Run-Length-Encoded string compression. *)
function fustRLEcomp(stIn : string) : string;
var
byCount,
byStInSize,
byStTempPos : byte;
woStInPos : word;
stTemp : string;
begin
fillchar(stTemp, sizeof(stTemp), 0);
byCount := 1;
byStTempPos := 1;
woStInPos := 1;
byStInSize := ord(stIn[0]);
repeat
if (woStInPos < byStInSize)
and (stIn[woStInPos] = stIn[succ(woStInPos)])
and (byCount < $7F) then
inc(byCount)
else
if (byCount > 3) then
begin
stTemp[byStTempPos] := #0;
stTemp[(byStTempPos + 1)] := chr(byCount);
stTemp[(byStTempPos + 2)] := stIn[woStInPos];
inc(stTemp[0], 3);
inc(byStTempPos, 3);
byCount := 1
end
else
begin
move(stIn[succ(woStInPos - byCount)],
stTemp[byStTempPos], byCount);
inc(stTemp[0], byCount);
inc(byStTempPos, byCount);
byCount := 1
end;
inc(woStInPos, 1)
until (woStInPos > byStInSize);
fustRLEcomp := stTemp
end;
(* Run-Length-Encoded string expansion. *)
function fustRLEexp(stIn : string) : string;
var
byStInSize,
byStTempPos : byte;
woStInPos : word;
stTemp : string;
begin
fillchar(stTemp, sizeof(stTemp), 0);
byStInSize := ord(stIn[0]);
byStTempPos := 1;
woStInPos := 1;
repeat
if (stIn[woStInPos] <> #0) then
begin
stTemp[byStTempPos] := stIn[woStInPos];
inc(woStInPos, 1);
inc(byStTempPos, 1);
inc(stTemp[0], 1)
end
else
begin
fillchar(stTemp[byStTempPos], ord(stIn[succ(woStInPos)]),
stIn[(woStInPos + 2)]);
inc(byStTempPos, ord(stIn[succ(woStInPos)]));
inc(stTemp[0], ord(stIn[succ(woStInPos)]));
inc(woStInPos, 3)
end
until (woStInPos > byStInSize);
fustRLEexp := stTemp
end;
(* 8 bit into 7 bit string compression. *)
function fustComp87(stIn : string) : string;
var
stTemp : string;
byLoop, byTempSize, byOffset : byte;
begin
if (stIn[0] < #255) then
stIn[succ(ord(stIn[0]))] := #0;
fillchar(stTemp, sizeof(stTemp), 0);
byTempSize := ord(stIn[0]) shr 3;
if ((ord(stIn[0]) mod 8) <> 0) then
inc(byTempsize, 1);
byOffset := 0;
for byLoop := 1 to byTempSize do
begin
stTemp[(byOffset * 7) + 1] :=
chr( ( (ord(stIn[(byOffset * 8) + 1]) and $7F) shl 1) +
( (ord(stIn[(byOffset * 8) + 2]) and $40) shr 6) );
stTemp[(byOffset * 7) + 2] :=
chr( ( (ord(stIn[(byOffset * 8) + 2]) and $3F) shl 2) +
( (ord(stIn[(byOffset * 8) + 3]) and $60) shr 5) );
stTemp[(byOffset * 7) + 3] :=
chr( ( (ord(stIn[(byOffset * 8) + 3]) and $1F) shl 3) +
( (ord(stIn[(byOffset * 8) + 4]) and $70) shr 4) );
stTemp[(byOffset * 7) + 4] :=
chr( ( (ord(stIn[(byOffset * 8) + 4]) and $0F) shl 4) +
( (ord(stIn[(byOffset * 8) + 5]) and $78) shr 3) );
stTemp[(byOffset * 7) + 5] :=
chr( ( (ord(stIn[(byOffset * 8) + 5]) and $07) shl 5) +
( (ord(stIn[(byOffset * 8) + 6]) and $7C) shr 2) );
stTemp[(byOffset * 7) + 6] :=
chr( ( (ord(stIn[(byOffset * 8) + 6]) and $03) shl 6) +
( (ord(stIn[(byOffset * 8) + 7]) and $7E) shr 1) );
if (byOffset < 31) then
stTemp[(byOffset * 7) + 7] :=
chr( ( ( ord(stIn[(byOffset * 8) + 7]) and $01) shl 7) +
( ord(stIn[(byOffset * 8) + 8]) and $7F) )
else
stTemp[(byOffset * 7) + 7] :=
chr( ( ord(stIn[(byOffset * 8) + 7]) and $01) shl 7);
inc(byOffset, 1)
end;
stTemp[0] := chr(((ord(stIn[0]) div 8) * 7) + (ord(stIn[0]) mod 8) );
fustComp87 := stTemp
end;
(* 7 bit into 8 bit string expansion. *)
function fustExp78(stIn : string) : string;
var
stTemp : string;
byOffset, byTempSize, byLoop : byte;
begin
fillchar(stTemp, sizeof(stTemp), 0);
byTempSize := ord(stIn[0]) div 7;
if ((ord(stIn[0]) mod 7) <> 0)then
inc(byTempSize, 1);
byOffset := 0;
for byLoop := 1 to byTempSize do
begin
stTemp[(byOffset * 8) + 1] :=
chr( ord(stIn[(byOffset * 7) + 1]) shr 1);
stTemp[(byOffset * 8) + 2] :=
chr( ( ( ord(stIn[(byOffset * 7) + 1]) and $01) shl 6) +
( ( ord(stIn[(byOffset * 7) + 2]) and $FC) shr 2) );
stTemp[(byOffset * 8) + 3] :=
chr( ( ( ord(stIn[(byOffset * 7) + 2]) and $03) shl 5) +
( ord(stIn[(byOffset * 7) + 3]) shr 3) );
stTemp[(byOffset * 8) + 4] :=
chr( ( ( ord(stIn[(byOffset * 7) + 3]) and $07) shl 4) +
( ord(stIn[(byOffset * 7) + 4]) shr 4) );
stTemp[(byOffset * 8) + 5] :=
chr( ( ( ord(stIn[(byOffset * 7) + 4]) and $0F) shl 3) +
( ord(stIn[(byOffset * 7) + 5]) shr 5) );
stTemp[(byOffset * 8) + 6] :=
chr( ( ( ord(stIn[(byOffset * 7) + 5]) and $1F) shl 2) +
( ord(stIn[(byOffset * 7) + 6]) shr 6) );
stTemp[(byOffset * 8) + 7] :=
chr( ( ( ord(stIn[(byOffset * 7) + 6]) and $3F) shl 1) +
( ord(stIn[(byOffset * 7) + 7]) shr 7) );
if (byOffset < 31) then
stTemp[(byOffset * 8) + 8] :=
chr( (ord(stIn[(byOffset * 7) + 7]) and $7F) );
inc(byOffset, 1)
end;
stTemp[0] :=
chr( ( (ord(stIn[0]) div 7) * 8) + (ord(stIn[0]) mod 7) );
if (stTemp[ord(stTemp[0])] = #0) then
dec(stTemp[0], 1);
fustExp78 := stTemp
end;
var
loStart, loStop : longint;
stMy1,
stMy2,
stMy3 : string;
(* Main program execution block. *)
BEGIN
(* Test string 1. *)
stMy1 := '12345678901111111111123456789022222222221234567890' +
'33333333331234567890444444444412345678905555555555' +
'12345678906666666666123456789077777777771234567890' +
'88888888881234567890999999999912345678900000000000' +
'1234567890AAAAAAAAAA1234567890BBBBBBBBBB1234567890' +
'CCCCC';
(* Test string 2. *)
{ stMy1 := '12345678901234567890123456789012345678901234567890' +
'12345678901234567890123456789012345678901234567890' +
'12345678901234567890123456789012345678901234567890' +
'12345678901234567890123456789012345678901234567890' +
'12345678901234567890123456789012345678901234567890' +
'12345'; }
(* Test string 3. *)
{ stMy1 := '11111111111111111111111111111111111111111111111111' +
'11111111111111111111111111111111111111111111111111' +
'11111111111111111111111111111111111111111111111111' +
'11111111111111111111111111111111111111111111111111' +
'11111111111111111111111111111111111111111111111111' +
'11111'; }
loStart := ReadTimer;
stMy2 := fustComp87(fustRLEcomp(stMy1));
loStop := ReadTimer;
writeln(' Time to compress = ', ElapsedTimeString(loStart, loStop), ' ms');
loStart := ReadTimer;
stMy3 := fustRLEexp(fustExp78(stMy2));
loStop := ReadTimer;
writeln(' Time to expand = ', ElapsedTimeString(loStart, loStop), ' ms');
writeln;
writeln(stMy1);
writeln;
writeln(stMy2);
writeln;
writeln(stMy3);
writeln;
if (stMy1 <> stMy3) then
writeln(' Conversion Error')
else
writeln(' Conversion Match')
END.