核心提示:const MAX_WND_SIZE=1024;procedure Write12BitStream(pbuffer: pchar; bitoffset: ULONG);var bytebound,...
const MAX_WND_SIZE=1024;procedure Write12BitStream(pbuffer: pchar; bitoffset: ULONG);var
bytebound, bitinbyte: ULONG;
begin
bytebound := bitoffset shr 3;
bitinbyte := bitoffset and $7;
PByte(ULONG(pbuffer) + bytebound)^ := PByte(ULONG(pbuffer) + bytebound)^ or (1 shl bitinbyte);
end;
procedure Write02BitStream(pbuffer: pchar; bitoffset: ULONG);
var
bytebound, bitinbyte: ULONG;
begin
bytebound := bitoffset shr 3;
bitinbyte := bitoffset and $7;
PByte(ULONG(pbuffer) + bytebound)^ := PByte(ULONG(pbuffer) + bytebound)^ and not (1 shl bitinbyte);
end;
function ReadBitFromBitStream(pbuffer: pchar; bitoffset: ULONG): ULONG;
var
bytebound, bitinbyte: ULONG;
begin
result := 0;
bytebound := bitoffset shr 3;
bitinbyte := bitoffset and $7;
if (PByte(ULONG(pbuffer) + bytebound)^ and (1 shl bitinbyte)) = (1 shl bitinbyte) then
result := 1;
end;
function CompareStrings(pSrc: PChar; SrcLen: ULONG; pComp: PChar; CompLen: ULONG): ULONG;
var
step, MinLen: ULONG;
pStr1, pStr2: PChar;
begin
step := 0; result := 0;
if (pSrc = nil) or (pComp = nil) then exit;
pStr1 := pSrc; pStr2 := pComp;
if CompLen > SrcLen then
MinLen := SrcLen
else
MinLen := CompLen;
while (step < MinLen) do
begin
ULONG(pStr1) := ULONG(pSrc) + step;
ULONG(pStr2) := ULONG(pComp) + step;
if pStr1^ <> pStr2^ then break;
step := step + 1;
end;
result := step;
end;
function FindLongestSubString(pSrc: PChar; SrcLen: ULONG; pComp: PChar; Offset: PULONG): ULONG;
var
len, MaxLen, step, tmplen: ULONG;
pTmp: PChar;
begin
Result := 0; Offset^ := 0; len := 0; MaxLen := 0; step := 0; tmplen := SrcLen; pTmp := pSrc;
while tmplen > 0 do
begin
len := CompareStrings(pTmp, tmplen, pComp, tmplen);
if len > MaxLen then
begin
MaxLen := len;
Offset^ := step;
end;
tmplen := tmplen - 1;
ULONG(pTmp) := ULONG(pTmp) + 1;
step := step + 1;
end;
result := MaxLen;
end;
function ReadLengthInfo(pBuffer: PChar; bitoffset: ULONG; Offset: PULONG): ULONG;
var
{ offset length
+-------+-------+-------+
| 8 4 | 4 8 |
+-------+-------+-------+
}
b1, b2, b3: Byte; i: integer;
bytebound, bitinbyte, tmp1, tmp2: ULONG;
begin
//////////
bytebound := bitoffset shr 3;
bitinbyte := bitoffset and 7;
b1 := 0; b2 := 0; b3 := 0;
for i := 0 to 7 do
begin
b1 := b1 or (ReadbitFromBitStream(pchar(ULONG(pBuffer) + bytebound), i + bitinbyte) shl i);
end;
for i := 0 to 7 do
begin
b2 := b2 or (ReadbitFromBitStream(pchar(ULONG(pBuffer) + bytebound), i + 8 + bitinbyte) shl i);
end;
for i := 0 to 7 do
begin
b3 := b3 or (ReadbitFromBitStream(pchar(ULONG(pBuffer) + bytebound), i + 16 + bitinbyte) shl i);
end;
tmp1 := b2 and $F;
tmp1 := b1 or (tmp1 shl 8);
tmp2 := (b2 and $F0) shr 4;
tmp2 := (b3 shl 4) or tmp2;
result := tmp2;
offset^ := tmp1;
end;
procedure WriteLengthInfo(pBuffer: PChar; bitoffset: ULONG; Offset: ULONG; Leng: ULONG);
var
b1, b2, b3: Byte;
bytebound, bitinbyte: ULONG;
i: integer;
begin
if (Offset > MAX_WND_SIZE) or (Leng > MAX_WND_SIZE) then raise Exception.Create('Parameter is too long.');
{ offset length
+-------+-------+-------+
| 8 4 | 4 8 |
+-------+-------+-------+
}
bytebound := bitoffset shr 3;
bitinbyte := bitoffset and 7;
b1 := Offset and $FF;
b3 := (Leng and $FF0) shr 4;
b2 := (Offset and $FF00) shr 8;
b2 := b2 or ((Leng and $F) shl 4);
for i := 0 to 7 do
begin
if (b1 shr i) and 1 = 1 then
Write12bitStream(pchar(ULONG(pBuffer) + bytebound), i + bitinbyte)
else
Write02bitStream(pchar(ULONG(pBuffer) + bytebound), i + bitinbyte);
end;
for i := 0 to 7 do
begin
if (b2 shr i) and 1 = 1 then
Write12bitStream(pchar(ULONG(pBuffer) + bytebound), i + 8 + bitinbyte)
else
Write02bitStream(pchar(ULONG(pBuffer) + bytebound), i + 8 + bitinbyte);
end;
for i := 0 to 7 do
begin
if (b3 shr i) and 1 = 1 then
Write12bitStream(pchar(ULONG(pBuffer) + bytebound), i + 16 + bitinbyte)
else
Write02bitStream(pchar(ULONG(pBuffer) + bytebound), i + 16 + bitinbyte);
end;
end;
//解压代码
procedure lz77DeCompress(pBuffer: PChar; BitLen: ULONG; pOutBuffer: PChar; OutByteLen: PULONG);
var
offbit, leng, iSlideWndSize, offbyte, ipos, bytes: ULONG; b, d: byte;
pSlideWndPtr, poutptr, pSrc: PChar;
i: integer;
begin
pSrc := pBuffer; poutptr := pOutBuffer; offbit := 0; bytes := (BitLen + 7) shr 3;
while (offbit < BitLen) do
begin
if ULONG(poutptr) - MAX_WND_SIZE <= ULONG(pOutBuffer) then
begin
pSlideWndPtr := pOutBuffer;
iSlideWndSize := ULONG(poutptr) - ULONG(pOutBuffer);
end
else
begin
ULONG(pSlideWndPtr) := ULONG(poutptr) - MAX_WND_SIZE;
iSlideWndSize := MAX_WND_SIZE;
end;
b := ReadBitFromBitStream(pSrc, offbit);
offbit := offbit + 1;
if b = 1 then
begin
Leng := ReadLengthInfo(pSrc, offbit, @offbyte);
CopyMemory(poutptr, PChar(ULONG(pSlideWndPtr) + offbyte), Leng);
ULONG(poutptr) := ULONG(poutptr) + Leng;
offbit := offbit + 24;
end
else
begin
d := 0;
for i := 0 to 7 do
begin
d := d or (ReadBitFromBitStream(pSrc, offbit) shl i);
offbit := offbit + 1;
end;
PByte(poutptr)^ := d;
ULONG(poutptr) := ULONG(poutptr) + 1;
end;
ipos := (offbit + 7) shr 3;
if assigned(callback) then
callback(ipos, bytes);
end;
OutByteLen^ := ULONG(poutptr) - ULONG(pOutBuffer);
end;
//压缩代码
procedure lz77Compress(pBuffer: PChar; BufferLen: ULONG; pOutBuffer: PChar; OutBitLen: PULONG);
var
offbit, leng, iSlideWndSize, offbyte, ipos: ULONG; b: byte;
pSlideWndPtr, poutptr, pSrc: PChar;
i, j: integer;
begin
if (BufferLen > $FFFFFFFE shr 3) then raise Exception.Create('Input Stream is too long.');
pSrc := pBuffer; poutptr := pOutBuffer; offbit := 0;
while (ULONG(pSrc) - ULONG(pBuffer) < BufferLen) do
begin
if ULONG(pSrc) - MAX_WND_SIZE <= ULONG(pBuffer) then
begin
pSlideWndPtr := pBuffer;
iSlideWndSize := ULONG(pSrc) - ULONG(pBuffer);
end
else
begin
ULONG(pSlideWndPtr) := ULONG(pSrc) - MAX_WND_SIZE;
iSlideWndSize := MAX_WND_SIZE;
end;
leng := FindLongestSubString(pSlideWndPtr, iSlideWndSize, pSrc, @offbyte);
if leng > 3 then
begin
Write12BitStream(poutptr, offbit);
offbit := offbit + 1;
WriteLengthInfo(poutptr, offbit, offbyte, leng);
offbit := offbit + 24;
ULONG(PSrc) := ULONG(PSrc) + leng;
end
else
begin
repeat
b := PByte(PSrc)^;
Write02BitStream(poutptr, offbit);
offbit := offbit + 1;
for i := 0 to 7 do
begin
if (b shr i) and 1 = 1 then
begin
Write12BitStream(poutptr, offbit);
offbit := offbit + 1;
end
else
begin
Write02BitStream(poutptr, offbit);
offbit := offbit + 1;
end;
end;
ULONG(PSrc) := ULONG(PSrc) + 1;
leng := leng - 1;
until (leng > 0);
end;
ipos := ULONG(PSrc) - ULONG(pBuffer);
if assigned(callback) then
callback(ipos, BufferLen);
end;
OutBitLen^ := offbit;
end;
以上是新写的一个“压缩/解压缩”程序的核心代码,还有很大的提升空间,下面是使用它压缩一个BMP文件的图示,可以达到95%的压缩率(对于一般的DOC文件可以达到60-90%的压缩率,对于已经压缩的文件,反而会增大文件^_^),还不错。