请问谁有简单的字符串压缩程序 ( 积分: 200 )

[0];
                  Inc(WinPos);
                  OldCode:=Code;
                End else

                  begin

                    H:=SLtable[OldCode];
                    SLTable[WinPos]:=H+1;
                     For J:=0 to H-1do

                       StringTable[WinPos][J]:=StringTable[OldCode][J];
                    StringTable[WinPos][H]:=StringTable[OldCode][0];
                    OutValue(WinPos);
                    Inc(WinPos);
                    OldCode:=Code;
                  end;

             end;

          GetNextValue;
       end;

   IF OS<>OutSize then
 MemStream.SetSize(OS);
   Result:=OS;
   MemStream.Position:=0;
end;



end.



虽然是采用流操作的，但是操作字符串一样很方便。 
 
52free (2003-04-24 14:11:00)  
记不得在哪儿找到的了

标题: 字符串压缩算法

Contributor: SWAG SUPPORT TEAM

{You won't get that sort of compression from my routines, but here

they are anyway. When testing, you'll get best compression if you

use English and longish Strings.

}

Unit Compress;

Interface

Const

CompressedStringArraySize = 500;
{ err on the side of generosity }

Type

tCompressedStringArray = Array[1..CompressedStringArraySize] of Byte;

Function GetCompressedString(Arr : tCompressedStringArray) : String;

Procedure CompressString(st : String;
Var Arr : tCompressedStringArray;

Var len : Integer);

{ converts st into a tCompressedStringArray of length len }

Implementation

Const

FreqChar : Array[4..14] of Char = 'etaonirshdl';

{ can't be in [0..3] because two empty bits signify a space }

　

Function GetCompressedString(Arr : tCompressedStringArray) : String;

Var

Shift : Byte;

I : Integer;

ch : Char;

st : String;

b : Byte;

Function GetHalfNibble : Byte;

begin


GetHalfNibble := (Arr[I] shr Shift) and 3;

if Shift = 0 then
 begin


Shift := 6;

inc(I);

end else
 dec(Shift,2);

end;


begin


st := '';

I := 1;

Shift := 6;

Repeat

b := GetHalfNibble;

if b = 0 then


ch := ' '

else
 begin


b := (b shl 2) or GetHalfNibble;

if b = $F then
 begin


b := GetHalfNibble shl 6;

b := b or GetHalfNibble shl 4;

b := b or GetHalfNibble shl 2;

b := b or GetHalfNibble;

ch := Char(b);

end else


ch := FreqChar[b];

end;


if ch <>
#0 then
 st := st + ch;

Until ch = #0;

GetCompressedString := st;

end;


Procedure CompressString(st : String;
Var Arr : tCompressedStringArray;

Var len : Integer);

{ converts st into a tCompressedStringArray of length len }

Var

I : Integer;

Shift : Byte;

Procedure OutHalfNibble(b : Byte);

begin


Arr[len] := Arr[len] or (b shl Shift);

if Shift = 0 then
 begin


Shift := 6;

inc(len);

end else
 dec(Shift,2);

end;


Procedure OutChar(ch : Char);

Var

I : Byte;

bych : Byte Absolute ch;

begin


if ch = ' ' then


OutHalfNibble(0)

else
 begin


I := 4;

While (I<15) and (FreqChar[I]<>ch)do
 inc(I);

OutHalfNibble(I shr 2);

OutHalfNibble(I and 3);

if I = $F then
 begin


OutHalfNibble(bych shr 6);

OutHalfNibble((bych shr 4) and 3);

OutHalfNibble((bych shr 2) and 3);

OutHalfNibble(bych and 3);

end;


end;


end;


begin


len := 1;

Shift := 6;

fillChar(Arr,sizeof(Arr),0);

For I := 1 to length(st)do
 OutChar(st[I]);

OutChar(#0);
{ end of compressed String signaled by #0 }

if Shift = 6

then
 dec(len);

end;


end.


测试压缩字符串

Contributor: SWAG SUPPORT TEAM

Program TestComp;
{ tests Compression }

{ kludgy test of Compress Unit }

Uses Crt,do
s, Compress;

Const

NumofStrings = 5;

Var

ch : Char;

LongestStringLength,I,j,len : Integer;

Textfname,Compfname : String;

TextFile : Text;

ByteFile : File;

CompArr : tCompressedStringArray;

st : Array[1..NumofStrings] of String;

Rec : SearchRec;

BigArr : Array[1..5000] of Byte;

Arr : Array[1..NumofStrings] of tCompressedStringArray;

begin


Writeln('note: No I/O checking in this test.');

Write('Test ompress or nCompress? ');

Repeat

ch := upCase(ReadKey);

Until ch in ['C','U',#27];

if ch = #27 then
 halt;

Writeln(ch);

if ch = 'C' then
 begin


Writeln('Enter ',NumofStrings,' Strings:');

LongestStringLength := 0;

For I := 1 to NumofStringsdo
 begin


Write(I,': ');

readln(st[I]);

if length(st[I]) >
LongestStringLength then


LongestStringLength := length(st[I]);

end;


Writeln;

Writeln('Enter name of File to store unCompressed Strings in.');

Writeln('ANY EXISTinG File With THIS NAME WILL BE OVERWRITTEN.');

readln(Textfname);

assign(TextFile,Textfname);

reWrite(TextFile);

For I := 1 to NumofStringsdo


Writeln(TextFile,st[I]);

close(TextFile);

Writeln;

Writeln('Enter name of File to store Compressed Strings in.');

Writeln('ANY EXISTinG File With THIS NAME WILL BE OVERWRITTEN.');

readln(Compfname);

assign(ByteFile,Compfname);

reWrite(ByteFile,1);

For I := 1 to NumofStringsdo
 begin


CompressString(st[I],CompArr,len);

blockWrite(ByteFile,CompArr,len);

end;


close(ByteFile);

FindFirst(Textfname,AnyFile,Rec);

Writeln;

Writeln;

Writeln('Size of Text File storing Strings: ',Rec.Size);

Writeln;

Writeln('Using Typed Files, a File of Type String[',

LongestStringLength,

'] would be necessary.');

Writeln('That would be ',

(LongestStringLength+1)*NumofStrings,

' long, including length Bytes.');

Writeln;

FindFirst(Compfname,AnyFile,Rec);

Writeln('Size of the Compressed File: ',Rec.Size);

Writeln;

Writeln('Now erase the Text File, and run this Program again, choosing');

Writeln('nCompress to show that the Compression retains all info.');

end else
 begin
 { ch = 'U' }

Write('Name of Compressed File: ');

readln(Compfname);

assign(ByteFile,Compfname);

reset(ByteFile,1);

blockread(ByteFile,BigArr,Filesize(ByteFile));

close(ByteFile);

For j := 1 to NumofStringsdo
 begin


I := 1;

While BigArr[I] <>
0do
 inc(I);

move(BigArr[1],Arr[j],I);

move(BigArr[I+1],BigArr[1],sizeof(BigArr));

end;


For I := 1 to NumofStringsdo


st[I] := GetCompressedString(Arr[I]);

For I := 1 to NumofStringsdo


Writeln(st[I]);

end;


end.


 
tianjh007 (2003-04-24 14:56:00)  
   Delphi提供了 Zlib.pas和 Zlibconst.pas两个单元文件来解决数据压缩问题，实现了很高的数据压缩比率。这两个文件保存在 Delphi 5.0安装光盘上 /Info/Extras/Zlib目录下，此外，在 Info/Extras/Zlib/Obj目录中还保存了 Zlib.pas单元引用的 Obj文件。

压缩函数
procedure CompressStream(inpStream, outStream: TStream);

var 
  InpBuf, OutBuf: Pointer;

  InpBytes, OutBytes: Integer;

begin
 
  InpBuf := nil;

  OutBuf := nil;

  try 
    GetMem(InpBuf, inpStream.Size);

    inpStream.Position := 0;

    InpBytes := inpStream.Read(InpBuf^, inpStream.Size);

    CompressBuf(InpBuf, InpBytes, OutBuf, OutBytes);

    outStream.Write(OutBuf^, OutBytes);

  finally 
    if InpBuf <>
nil then
 FreeMem(InpBuf);

    if OutBuf <>
nil then
 FreeMem(OutBuf);

  end;


end;



解压缩函数
{ Decompress a stream } 
procedure DecompressStream(inpStream, outStream: TStream);

var 
  InpBuf, OutBuf: Pointer;

  OutBytes, sz: Integer;

begin
 
  InpBuf := nil;

  OutBuf := nil;

  sz     := inpStream.Size - inpStream.Position;

  if sz >
0 then
  
    try 
      GetMem(InpBuf, sz);

      inpStream.Read(InpBuf^, sz);

      DecompressBuf(InpBuf, sz, 0, OutBuf, OutBytes);

      outStream.Write(OutBuf^, OutBytes);

    finally 
      if InpBuf <>
nil then
 FreeMem(InpBuf);

      if OutBuf <>
nil then
 FreeMem(OutBuf);

    end;


  outStream.Position := 0;

end;




 
amengdewo (2003-04-24 15:02:00)  
TO 远帆
  你提供的程序好像编译不通

TO tianjh007
  你把那两个文件发给我好吗？

 
远帆 (2003-04-24 15:05:00)  
哦，想起来了，那段代码是for d5的。 
 
duguqiubai (2004-03-05 14:09:03)  
给位大虾：我需要一个lzw得源码，需要压缩一个tif文件，本人愿出100，请帮忙！我的Email:wangsc@cs.daqing.com

 
app2001 (2004-03-05 14:25:40)  
ftp://61.129.70.192/datanew/20031223145233981.zip
注释 LZW和LZRW压缩算法源代码 -- 作者:Liu Yang老大 
开发语言： Delphi &
Kylix 
简介： LZW和LZRW压缩算法源代码，速度奇快。 
文件大小： 4.853Kb 

 
auleaf (2004-03-05 14:29:07)  
上网上搜一搜,好像有现成的,也有C的dll 
 
duguqiubai (2004-03-05 14:47:12)  
app2001:你好！我下载不了，可否发Email给我,Email:wangsc@cs.daqing.com 谢谢！ 
 
app2001 (2004-03-05 14:53:01)  
我发给你了 
 
apw (2004-03-05 15:09:11)  
在这试试看，总有一款适合你。
http://www.vclxx.org/DELPHIGB/AAAT1027.HTM#COMPRESS 
 
孤独之孤 (2004-03-05 19:06:58)  
用DELPHI自带的ZLIB库吧,对字符串压缩效果很好. 
 
dedema (2004-03-05 20:24:13)  
收藏中吧！ 
 
远帆 (2004-03-08 12:14:59)  
上面我贴的代码改动一点之后就可以通过，不过楼主好像都不见了？