Title: Simple Implementation of LZW Compression/Decompression Algorithm
Question: How do I Compress and Decompress fils using LZW Algorithm.
Answer:
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 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[i] do
begin
if not flocked then
begin
prevchar:=nochar;
nextchar:=nochar;
next:=endlist;
used:=false;
nused:=0;
flocked:=false;
end;
end;
if i begin
stringtable[i].nextchar:=i;
stringtable[i].used:=true;
inc(objectid);
end;
end;
end;
procedure Terminate;
begin
if outbufpos0 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].nextendlist 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 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 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[code].prevchar=nochar then
begin
if rembitcount 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 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 (rembitcount0) 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 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 incodeeofchar 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].prevcharnochar) 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(tempcempty) 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 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 stackpointer0 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;