100分找压缩算法(delphi源码)不要控件,ziptv我已有了..... (100分)

  • 主题发起人 主题发起人 dingbaosheng
  • 开始时间 开始时间
D

dingbaosheng

Unregistered / Unconfirmed
GUEST, unregistred user!
如题~~~~~
 
C语言的示例源代码要不要?
要的话我就邮。
 
自己做吗？
看看ziptv的源码吧！
 
Here is a simple implemntation of LZW compression/Decompression algorithm.
It is not fast and compression ratio is very small. Here is the code.

-------------------------------------------------------------------------------
unit RevLZW;

interface

uses
sysutils,classes,dialogs,windows;

const
tabsize:integer=4095;
copybyte:integer=0;
compbyte:integer=1;
endlist:integer=-1;
nochar:integer=-2;
empty:integer=-3;
eofchar:integer=-4;
bufsize:integer=32768;
maxstack:integer=4096;
type
TStringObject = record
prevchar:integer;
nextchar:integer;
next:integer;
used:boolean;
nused:integer;
flocked:boolean;
end;

procedure Initialize;
procedure Terminate;
function OpenInputFile(fname:string):boolean;
function OpenOutputFile(fname:string):boolean;
function getbyte:integer;
procedure putbyte(c:integer);
procedure compress;
procedure decompress;
procedure putcode(code:integer;lbyte:boolean=false);
function getcode:integer;
function GetHashCode(prevc,nextc:integer):integer;
function findstring(prevc,nextc:integer):integer;
function MakeTableEntry(prevc:integer;nextc:integer):boolean;
procedure push(c:integer);
procedure pop(var c:integer);
procedure InitializeStringTable;

var
fsize:integer;
fread,fwrote:integer;
ihandle,ohandle:integer;
inbufpos,outbufpos:integer;
objectid:integer;
stringtable:array[0..4095] of TstringObject;
inblock:array[0..65535{32767}] of char;
outblock:array[0..65535{32767}] of char;
stack:array[0..4095] of char;
stackpointer:integer;
rembits:integer;
lastbyte:boolean;
rembitcount:integer;
lzwerr:boolean;
imap,omap:integer;
implementation

function OpenInputFile(fname:string):boolean;
begin
result:=true;
ihandle:=fileopen(fname,fmShareExclusive or fmOpenRead);
fsize:=getfilesize(ihandle,nil);
if fsize<32768 then
fileread(ihandle,inblock,fsize)
else
fileread(ihandle,inblock,32768);
if ihandle=-1 then
result:=false;
end;

function OpenOutputFile(fname:string):boolean;
begin
result:=true;
ohandle:=filecreate(fname);
if ohandle=-1 then
result:=false;
end;

function getbyte:integer;
begin
if inbufpos=32768 then
begin
inbufpos:=0;
fileread(ihandle,inblock,32768);
end;
if fread=fsize then
result:=eofchar
else
result:=integer(inblock[inbufpos]);
inc(inbufpos);
inc(fread);
end;

procedure putbyte(c:integer);
begin
if outbufpos=32768 then
begin
outbufpos:=0;
filewrite(ohandle,outblock,32768);
end;
outblock[outbufpos]:=char(c);
inc(outbufpos);
inc(fwrote);
end;

procedure Initialize;
begin
inbufpos:=0;
outbufpos:=0;
fread:=0;
fwrote:=0;
objectid:=0;
stackpointer:=0;
lastbyte:=false;
rembits:=empty;
rembitcount:=0;
lzwerr:=false;
InitializeStringtable;
end;

procedure InitializeStringTable;
var
i:integer;
begin
objectid:=0;
for i:=0 to 4095 do
begin
with stringtable do
begin
if not flocked then
begin
prevchar:=nochar;
nextchar:=nochar;
next:=endlist;
used:=false;
nused:=0;
flocked:=false;
end;
end;
if i<=255 then
begin
stringtable.nextchar:=i;
stringtable.used:=true;
inc(objectid);
end;
end;
end;

procedure Terminate;
begin
if outbufpos>0 then
filewrite(ohandle,outblock,outbufpos);
setendoffile(ohandle);
fileclose(ihandle);
fileclose(ohandle);
end;

function GetHashCode(prevc,nextc:integer):integer;
var
index,newindex:integer;
begin
index:= ((prevc shl 5) xor nextc) and tabsize;
if not stringtable[index].used then
result:=index
else
begin
while stringtable[index].next<>endlist do
index:=stringtable[index].next;
newindex:=index and tabsize;
while stringtable[newindex].used do
newindex:=succ(newindex) and tabsize;
stringtable[index].next:=newindex;
result:=newindex;
end;
end;

function findstring(prevc,nextc:integer):integer;
var
index:integer;
found:boolean;
begin
result:=endlist;
if (prevc=nochar) and (nextc<=255) then
result:=nextc
else
begin
index:=((prevc shl 5) xor nextc) and tabsize;
repeat
found:=(stringtable[index].prevchar=prevc) and(stringtable[index].nextchar=nextc);
if not found then
index:=stringtable[index].next;
until found or (index = endlist);
if found then
begin
result:=index;
inc(stringtable[index].nused);
end;
end;
end;

function MakeTableEntry(prevc:integer;nextc:integer):boolean;
var
index:integer;
begin
result:=true;
if objectid<=tabsize then
begin
index:=gethashcode(prevc,nextc);
with stringtable[index] do
begin
prevchar:=prevc;
nextchar:=nextc;
used:=true;
end;
inc(objectid);
if objectid=tabsize+1 then
result:=false;
end;
end;

procedure putcode(code:integer;lbyte:boolean);
var
tmpcode:integer;
begin
if stringtable
代码: 
.prevchar=nochar then 
begin 
if rembitcount<7 then 
begin 
tmpcode:=(rembits shl (8-rembitcount)) or (copybyte shl (7-rembitcount)) or ((code shr (rembitcount+1)) and ($7F shr rembitcount)); 
putbyte(tmpcode); 
inc(fwrote); 
rembits:= code and ($FF shr(7-rembitcount)); 
inc(rembitcount); 
end 
else if rembitcount=7 then 
begin 
tmpcode:=(rembits shl 1) or copybyte; 
putbyte(tmpcode); 
inc(fwrote,2); 
putbyte(code); 
rembits:=empty; 
rembitcount:=0; 
end; 
end 
else 
begin 
tmpcode:=(rembits shl (8-rembitcount)) or (compbyte shl(7-rembitcount)) or (code shr (5+rembitcount) and ($7F shr rembitcount)); 
putbyte(tmpcode); 
inc(fwrote); 
rembitcount:=rembitcount+5; 
if rembitcount<8 then 
rembits:=code and($FF shr(8-rembitcount)); 
if rembitcount>=8 then 
begin 
rembits:=(code shr(rembitcount-8)) and $FF; 
inc(fwrote); 
putbyte(rembits); 
rembitcount:=rembitcount-8; 
rembits:=code and ($FF shr(8-rembitcount)); 
end; 
end; 
if lbyte and (rembitcount>0) then 
begin 
tmpcode:=((rembits and ($FF shr (8-rembitcount))) shl (8-rembitcount)); 
putbyte(tmpcode); 
inc(fwrote); 
end; 
end; 

function getcode:integer; 
var 
part1,part2:integer; 
iscomp:integer; 
c1,c2:integer; 
begin 
result:=eofchar; 
if (fread=fsize) and (rembitcount=0) then 
begin 
result:=eofchar; 
exit; 
end; 
if rembitcount=0 then 
begin 
part1:=getbyte; 
part2:=getbyte; 
iscomp:=(part1 shr 7) and 1; 
if iscomp=1 then 
begin 
c1:=part1 and $7F; 
c2:=(part2 shr 3) and $1F; 
rembits:=part2 and $7; 
rembitcount:=3; 
result:=(c1 shl 5) or c2; 
end 
else if iscomp=0 then 
begin 
c1:=part1 and $7F; 
c2:=(part2 shr 7) and $1; 
result:=(c1 shl 1) or c2; 
rembits:=part2 and $7F; 
rembitcount:=7; 
end; 
end 
else if rembitcount=1 then 
begin 
part1:=getbyte; 
iscomp:=rembits; 
if iscomp=1 then 
begin 
part2:=getbyte; 
c1:=part1 and $FF; 
c2:=(part2 shr 4) and $F; 
rembits:=part2 and $F; 
rembitcount:=4; 
result:=(c1 shl 4) or c2; 
end 
else if iscomp=0 then 
begin 
c1:=part1 and $FF; 
result:=c1; 
rembits:=empty; 
rembitcount:=0; 
end; 
end 
else if rembitcount=2 then 
begin 
part1:=getbyte; 
iscomp:=(rembits shr 1) and 1; 
if iscomp=1 then 
begin 
part2:=getbyte; 
c1:=((rembits and 1) shl 7) or ((part1 shr 1) and $7F); 
c2:=((part1 and 1) shl 3) or ((part2 shr 5) and $7); 
rembits:=part2 and $1F; 
rembitcount:=5; 
result:=(c1 shl 4) or (c2 and $F); 
end 
else if iscomp=0 then 
begin 
c1:=((rembits and 1) shl 7) or ((part1 shr 1) and $7F); 
result:=c1; 
rembits:=part1 and 1; 
rembitcount:=1; 
end; 
end 
else if rembitcount=3 then 
begin 
part1:=getbyte; 
iscomp:=(rembits shr 2) and 1; 
if iscomp=1 then 
begin 
part2:=getbyte; 
c1:=((rembits and $3) shl 6) or ((part1 shr 2) and $3F); 
c2:=((part1 and $3) shl 2) or ((part2 shr 6) and $3); 
rembits:=part2 and $3F; 
rembitcount:=6; 
result:=(c1 shl 4) or (c2 and $F); 
end 
else if iscomp=0 then 
begin 
c1:=((rembits and $3) shl 6) or ((part1 shr 2) and $3F); 
result:=c1; 
rembits:=part1 and $3; 
rembitcount:=2; 
end; 
end 
else if rembitcount=4 then 
begin 
part1:=getbyte; 
iscomp:=(rembits shr 3) and 1; 
if iscomp=1 then 
begin 
part2:=getbyte; 
c1:=((rembits and $7) shl 5) or ((part1 shr 3) and $1F); 
c2:=((part1 and $7) shl 1) or ((part2 shr 7) and $1); 
rembits:=part2 and $7F; 
rembitcount:=7; 
result:=(c1 shl 4) or (c2 and $F); 
end 
else if iscomp=0 then 
begin 
c1:=((rembits and $7) shl 5) or ((part1 shr 3) and $1F); 
result:=c1; 
rembits:=part1 and $7; 
rembitcount:=3; 
end; 
end 
else if rembitcount=5 then 
begin 
part1:=getbyte; 
iscomp:=(rembits shr 4) and 1; 
if iscomp=1 then 
begin 
c1:=((rembits and $F) shl 4) or ((part1 shr 4) and $F); 
c2:=part1 and $F; 
rembits:=empty; 
rembitcount:=0; 
result:=(c1 shl 4) or (c2 and $F); 
end 
else if iscomp=0 then 
begin 
c1:=((rembits and $F) shl 4) or ((part1 shr 4) and $F); 
result:=c1; 
rembits:=part1 and $F; 
rembitcount:=4; 
end; 
end 
else if rembitcount=6 then 
begin 
part1:=getbyte; 
iscomp:=(rembits shr 5) and 1; 
if iscomp=1 then 
begin 
c1:=((rembits and $1F) shl 3) or ((part1 shr 5) and $7); 
c2:=(part1 shr 1) and $F; 
rembits:=part1 and 1; 
rembitcount:=1; 
result:=(c1 shl 4) or (c2 and $F); 
end 
else if iscomp=0 then 
begin 
c1:=((rembits and $1F) shl 3) or ((part1 shr 5) and $7); 
result:=c1; 
rembits:=part1 and $1F; 
rembitcount:=5; 
end; 
end 
else if rembitcount=7 then 
begin 
part1:=getbyte; 
iscomp:=(rembits shr 6) and 1; 
if iscomp=1 then 
begin 
c1:=((rembits and $3F) shl 2) or ((part1 shr 6) and $3); 
c2:=(part1 shr 2) and $F; 
rembits:=part1 and $3; 
rembitcount:=2; 
result:=(c1 shl 4) or (c2 and $F); 
end 
else if iscomp=0 then 
begin 
c1:=((rembits and $3F) shl 2) or ((part1 shr 6) and $3); 
result:=c1; 
rembits:=part1 and $3F; 
rembitcount:=6; 
end; 
end; 
end; 

procedure compress; 
var 
c,wc,w:integer; 
begin 
initialize; 
c:=getbyte; 
w:=findstring(nochar,c); 
c:=getbyte; 
while fread<=fsize-1 do 
begin 
if lastbyte then 
begin 
putcode(w); 
lastbyte:=false; 
InitializeStringtable; 
c:=getbyte; 
w:=findstring(nochar,c); 
c:=getbyte; 
end; 
wc:=findstring(w,c); 
if wc=endlist then 
begin 
lastbyte:=not(MakeTableEntry(w,c)); 
putcode(w); 
w:=findstring(nochar,c); 
end 
else 
w:=wc; 
if not lastbyte then 
c:=getbyte; 
end; 
putcode(w,true); 
end; 

procedure decompress; 
var 
unknown:boolean; 
finchar,lastchar:integer; 
code,oldcode,incode:integer; 
c,tempc:integer; 
begin 
initialize; 
unknown:=false; 
lastchar:=empty; 
oldcode:=getcode; 
code:=oldcode; 
c:=stringtable[code].nextchar; 
putbyte(c); 
finchar:=c; 
incode:=getcode; 
while incode<>eofchar do 
begin 
if lastbyte then 
begin 
lastbyte:=false; 
InitializeStringTable; 
stackpointer:=0; 
unknown:=false; 
lastchar:=empty; 
oldcode:=getcode; 
code:=oldcode; 
c:=stringtable[code].nextchar; 
putbyte(c); 
finchar:=c; 
incode:=getcode; 
end; 
code:=incode; 
if not stringtable[code].used then 
begin 
lastchar:=finchar; 
code:=oldcode; 
unknown:=true; 
end; 
while(stringtable[code].prevchar<>nochar) do 
begin 
push(stringtable[code].nextchar); 
if lzwerr=true then 
break; 
code:=stringtable[code].prevchar; 
end; 
if lzwerr=true then 
break; 
finchar:=stringtable[code].nextchar; 
putbyte(finchar); 
pop(tempc); 
while(tempc<>empty) do 
begin 
putbyte(tempc); 
pop(tempc); 
end; 
if unknown then 
begin 
finchar:=lastchar; 
putbyte(finchar); 
unknown:=false; 
end; 
lastbyte:=not(maketableentry(oldcode,finchar)); 
if not lastbyte then 
begin 
oldcode:=incode; 
incode:=getcode; 
end 
end; 
end; 

procedure push(c:integer); 
var 
s:string; 
begin 
if stackpointer<4096 then 
begin 
inc(stackpointer); 
stack[stackpointer]:=char(c); 
end; 
if stackpointer>=4096 then 
begin 
s:='Stack full at ' +inttostr(inbufpos); 
lzwerr:=true; 
showmessage(s); 
end; 
end; 

procedure pop(var c:integer); 
begin 
if stackpointer>0 then 
begin 
c:=integer(stack[stackpointer]); 
dec(stackpointer); 
end 
else 
c:=empty; 
end; 

end. 
------------------------------------------------------------------------------- 
To compress the file add the following code to a button 

openinputfile('C:/cdidxtmp/myfile.exe'); 
openoutputfile('C:/cdidxtmp/myfile.bak'); 
initialize; 
compress; 

To Decompress 
openinputfile('C:/cdidxtmp/myfile.bak'); 
openoutputfile('C:/cdidxtmp/myfile.exe'); 
initialize; 
decompress; 

欢迎访问vcl控件讨论区：http://vcl.xilubbs.com
 
ZipTV中不是有了么，何必骑着马儿找马儿！
 
压缩的我没有,但是有解压的,我自己写成dll了,delphi写的
如果需要的话请和我联系,另外如果压缩的也能找到请给我一份:xueminliu@263.net
 
To: xueminliu & Kylix㊣:

mail to: dbssbd@etang.com
 
您必须登录或注册才可回复。

Similar threads

Ray
[转]终于可以发布Delphi下收点OSGI精髓皮毛而设计的插件框架WisdomPluginFramework
回复
4
查看
4K
chlkuei
C
F
求实用的行程压缩算法、流压缩算法（不要整个文件压缩的），C代码！(200分)
回复
8
查看
484
freecom
F
C
各位大哥能不能在这里聊聊压缩算法啊(100分)
回复
6
查看
154
cyf_00002
C
D
请大家进来谈谈各种压缩控件的优劣（200分） (200分)
2
回复
35
查看
515
DLLKing
D
C
请问delphi中的自带的zlib压缩算法 到底是什么样的 为什么我用java.util.zip包下的压缩函数压缩 用delphi自带的解压却解不出来？(100
回复
3
查看
228
alum
A
后退
顶部