一个控件，说是Zip压缩，但是我实验了一下，压缩后ZIP不能解压，但是他自己可以解压的。
压缩效果比WinZIP或者WinRAR差许多。不过还可以。
unit zip;
interface
uses
Windows, Messages, SysUtils, Classes
const maxt=2048;
bsize=4096;
isize=2048;
eof_code=256;
next_len=257;
start_len=258;
empty=259;
type
Tzip = class(TComponent)
private
tabl:array[0..2049] of integer;
bbuf:array[0..bsize] of byte;
ibuf:array[0..isize] of integer;
tabl_count,bpos,ipos,blen:integer;
code_len:integer;
free_bits,full_bits:integer;
out_c:integer;
Foutstream:Tstream;
Finstream:tstream;
Fetime:integer;
Fpos:integer;
outstr:string;
firstchar:char;
FOnupdate: TNotifyEvent;
{ Private declarations }
procedure init;
procedure addtotable(str: integer);
procedure setfinstream(const Value: Tstream);
procedure setfoutstream(const Value: Tstream);
procedure open_unzip;
procedure open_zip;
procedure close_zip;
procedure close_unzip;
function getbyte: integer;
function indexof(str, ch: integer): integer;
procedure putcode(code: integer);
procedure put_str(ix: integer
first: boolean);
function read_code: integer;
protected
public
procedure Zip;
procedure Unzip;
property instream:Tstream write setfinstream;
property outstream:Tstream write setfoutstream;
published
property Elapsed:integer read fetime;
property Onupdate:TNotifyEvent read fonupdate write fonupdate;
property Position:integer read fpos;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [Tzip]);
end;
procedure tzip.init;
var i:integer;
begin
code_len:=9;
tabl_count:=empty;
for i:=0 to 255 do tabl:=$ffff00+i;
end;
procedure tzip.addtotable(str:integer);
begin
if tabl_count>=maxt then tabl_count:=empty
else
begin
tabl[tabl_count]:=str;
inc(tabl_count);
end;
end;
procedure tzip.open_zip;
begin
blen:=finstream.Read(bbuf,bsize);
bpos:=0;
ipos:=0;
out_c:=0;
free_bits:=32;
fpos:=0;
end;
procedure tzip.close_zip;
begin
if ipos>0 then foutstream.Write(ibuf,ipos*4);
end;
procedure tzip.close_unzip;
begin
if bpos>0 then foutstream.Write(bbuf,bpos);
end;
procedure tzip.open_unzip;
begin
full_bits:=0;
ipos:=0;
bpos:=0;
finstream.Read(ibuf,isize*4);
fpos:=0;
end;
function tzip.getbyte:integer;
begin
if (bpos>=blen) then
begin
if blen<bsize then
begin
result:=eof_code;
exit;
end
else
begin
blen:=finstream.Read(bbuf,bsize);
bpos:=0;
fpos:=finstream.Position;
if assigned(fonupdate) then fonupdate(nil);
end;
end;
result:=bbuf[bpos];
inc(bpos);
end;
function tzip.indexof(str,ch:integer):integer;
var cd,mn,mx:integer;
begin
cd:=(str shl 8) + ch;
mn:=str+1;if mn<empty then mn:=empty;
mx:=tabl_count-1;
for result:=mn to mx do if tabl[result]=cd then exit;
result:=-1;
end;
procedure tzip.putcode(code:integer);
var shift_bits,tc,tf:integer;
procedure store_out_c;
begin
ibuf[ipos]:=out_c;
inc(ipos);
if ipos>=isize then
begin
foutstream.Write(ibuf,isize*4);
ipos:=0;
end;
out_c:=0;
free_bits:=32;
end;
begin
shift_bits:=free_bits-code_len;
if shift_bits<0 then
begin
tf:=free_bits;
shift_bits:=-shift_bits;
tc:=code shr shift_bits;
out_c:=out_c or tc;
store_out_c;
shift_bits:=32-shift_bits;
inc(free_bits,tf)
//add alredy pushed bits
end;
tc:=code shl shift_bits;
out_c:=out_c or tc;
dec(free_bits,code_len);
if (free_bits=0) or (code=eof_code) then store_out_c;
end;
procedure tzip.zip;
var str,ch,t:integer;
begin
init;
open_zip;
Fetime:=gettickcount;
str:=getbyte;
repeat
ch:=getbyte;
if ch=eof_code then break;
t:=indexof(str,ch);
if t<>-1 then str:=t else
begin
putcode(str);
if (tabl_count=512) or (tabl_count=1024) then
begin
putcode(next_len);
inc(code_len);
end;
if tabl_count=maxt then
begin
putcode(start_len);
code_len:=9;
end;
addtotable((str shl 8) +ch);
str:=ch;
end;
until false;
putcode(str);
putcode(eof_code);
fetime:=gettickcount-fetime;
close_zip;
end;
procedure tzip.put_str(ix:integer;first:boolean);
var i,l:integer;
begin
outstr:='';
repeat
i:=tabl[ix];
ix:=i shr 8;
outstr:=outstr+chr(i and $ff);
until ix=$ffff;
l:=length(outstr);
for i:=l downto 1 do
begin
bbuf[bpos]:=byte(outstr);
inc(bpos);
if bpos>=bsize then
begin
foutstream.Write(bbuf,bsize);
bpos:=0;
end
end;
firstchar:=outstr[l];
if first then
begin
bbuf[bpos]:=byte(firstchar);
inc(bpos);
if bpos>=bsize then
begin
foutstream.Write(bbuf,bsize);
bpos:=0;
end
end;
end;
function tzip.read_code:integer;
var mask,shift_bits,tf:integer;
procedure get_out_c;
begin
out_c:=ibuf[ipos];
inc(ipos);
if ipos>=isize then
begin
finstream.Read(ibuf,isize*4);
ipos:=0;
fpos:=finstream.Position;
if assigned(fonupdate) then fonupdate(nil);
end;
full_bits:=32;
end;
begin
if full_bits=0 then get_out_c;
mask:=(1 shl code_len) -1
//0111111
result:=0;
shift_bits:=full_bits-code_len;
if shift_bits<0 then
begin
tf:=full_bits;
shift_bits:=-shift_bits;
result:=(out_c shl shift_bits) and mask;
get_out_c;
shift_bits:=32-shift_bits;
inc(full_bits,tf);
end;
result:=result or ((out_c shr shift_bits) and mask);
dec(full_bits,code_len);
end;
procedure tzip.unzip;
var old,cod:integer;
begin
init;
open_unzip;
fetime:=gettickcount;
old:=read_code;
put_str(old,false);
while true do
begin
cod:=read_code;
if cod=eof_code then break;
if cod=next_len then begin inc(code_len);continue;end;
if cod=start_len then begin code_len:=9;continue;end;
if cod>=tabl_count then put_str(old,true) else put_str(cod,false);
addtotable(old shl 8 +byte(firstchar));
old:=cod;
end;
fetime:=gettickcount-fetime;
close_unzip;
end;
procedure Tzip.setfinstream(const Value: Tstream);
begin
finstream := Value;
end;
procedure Tzip.setfoutstream(const Value: Tstream);
begin
foutstream := Value;
end;
end.
