Articles   Members Online:
-Article/Tip Search
-News Group Search over 21 Million news group articles.
-Delphi/Pascal
-CBuilder/C++
-C#Builder/C#
-JBuilder/Java
-Kylix
Member Area
-Home
-Account Center
-Top 10 NEW!!
-Submit Article/Tip
-Forums Upgraded!!
-My Articles
-Edit Information
-Login/Logout
-Become a Member
-Why sign up!
-Newsletter
-Chat Online!
-Indexes NEW!!
Employment
-Build your resume
-Find a job
-Post a job
-Resume Search
Contacts
-Contacts
-Feedbacks
-Link to us
-Privacy/Disclaimer
Embarcadero
Visit Embarcadero
Embarcadero Community
JEDI
Links
Simple Implementation of LZW Compression / Decompression Algorithm Turn on/off line numbers in source code. Switch to Orginial background IDE or DSP color Comment or reply to this aritlce/tip for discussion. Bookmark this article to my favorite article(s). Print this article
18-Oct-03
Category
Algorithm
Language
Delphi 2.x
Views
275
User Rating
No Votes
# Votes
0
Replies
0
Publisher:
DSP, Administrator
Reference URL:
DKB
			Author: Vimil Saju

How do I Compress and Decompress files 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. 

1   unit RevLZW;
2   
3   interface
4   
5   uses
6     sysutils, classes, dialogs, windows;
7   
8   const
9     tabsize: integer = 4095;
10    copybyte: integer = 0;
11    compbyte: integer = 1;
12    endlist: integer = -1;
13    nochar: integer = -2;
14    empty: integer = -3;
15    eofchar: integer = -4;
16    bufsize: integer = 32768;
17    maxstack: integer = 4096;
18  type
19    TStringObject = record
20      prevchar: integer;
21      nextchar: integer;
22      next: integer;
23      used: boolean;
24      nused: integer;
25      flocked: boolean;
26    end;
27  
28  procedure Initialize;
29  procedure Terminate;
30  function OpenInputFile(fname: string): boolean;
31  function OpenOutputFile(fname: string): boolean;
32  function getbyte: integer;
33  procedure putbyte(c: integer);
34  procedure compress;
35  procedure decompress;
36  procedure putcode(code: integer; lbyte: boolean = false);
37  function getcode: integer;
38  function GetHashCode(prevc, nextc: integer): integer;
39  function findstring(prevc, nextc: integer): integer;
40  function MakeTableEntry(prevc: integer; nextc: integer): boolean;
41  procedure push(c: integer);
42  procedure pop(var c: integer);
43  procedure InitializeStringTable;
44  
45  var
46    fsize: integer;
47    fread, fwrote: integer;
48    ihandle, ohandle: integer;
49    inbufpos, outbufpos: integer;
50    objectid: integer;
51    stringtable: array[0..4095] of TstringObject;
52    inblock: array[0..65535 {32767}] of char;
53    outblock: array[0..65535 {32767}] of char;
54    stack: array[0..4095] of char;
55    stackpointer: integer;
56    rembits: integer;
57    lastbyte: boolean;
58    rembitcount: integer;
59    lzwerr: boolean;
60    imap, omap: integer;
61  implementation
62  
63  function OpenInputFile(fname: string): boolean;
64  begin
65    result := true;
66    ihandle := fileopen(fname, fmShareExclusive or fmOpenRead);
67    fsize := getfilesize(ihandle, nil);
68    if fsize < 32768 then
69      fileread(ihandle, inblock, fsize)
70    else
71      fileread(ihandle, inblock, 32768);
72    if ihandle = -1 then
73      result := false;
74  end;
75  
76  function OpenOutputFile(fname: string): boolean;
77  begin
78    result := true;
79    ohandle := filecreate(fname);
80    if ohandle = -1 then
81      result := false;
82  end;
83  
84  function getbyte: integer;
85  begin
86    if inbufpos = 32768 then
87    begin
88      inbufpos := 0;
89      fileread(ihandle, inblock, 32768);
90    end;
91    if fread = fsize then
92      result := eofchar
93    else
94      result := integer(inblock[inbufpos]);
95    inc(inbufpos);
96    inc(fread);
97  end;
98  
99  procedure putbyte(c: integer);
100 begin
101   if outbufpos = 32768 then
102   begin
103     outbufpos := 0;
104     filewrite(ohandle, outblock, 32768);
105   end;
106   outblock[outbufpos] := char(c);
107   inc(outbufpos);
108   inc(fwrote);
109 end;
110 
111 procedure Initialize;
112 begin
113   inbufpos := 0;
114   outbufpos := 0;
115   fread := 0;
116   fwrote := 0;
117   objectid := 0;
118   stackpointer := 0;
119   lastbyte := false;
120   rembits := empty;
121   rembitcount := 0;
122   lzwerr := false;
123   InitializeStringtable;
124 end;
125 
126 procedure InitializeStringTable;
127 var
128   i: integer;
129 begin
130   objectid := 0;
131   for i := 0 to 4095 do
132   begin
133     with stringtable[i] do
134     begin
135       if not flocked then
136       begin
137         prevchar := nochar;
138         nextchar := nochar;
139         next := endlist;
140         used := false;
141         nused := 0;
142         flocked := false;
143       end;
144     end;
145     if i <= 255 then
146     begin
147       stringtable[i].nextchar := i;
148       stringtable[i].used := true;
149       inc(objectid);
150     end;
151   end;
152 end;
153 
154 procedure Terminate;
155 begin
156   if outbufpos > 0 then
157     filewrite(ohandle, outblock, outbufpos);
158   setendoffile(ohandle);
159   fileclose(ihandle);
160   fileclose(ohandle);
161 end;
162 
163 function GetHashCode(prevc, nextc: integer): integer;
164 var
165   index, newindex: integer;
166 begin
167   index := ((prevc shl 5) xor nextc) and tabsize;
168   if not stringtable[index].used then
169     result := index
170   else
171   begin
172     while stringtable[index].next <> endlist do
173       index := stringtable[index].next;
174     newindex := index and tabsize;
175     while stringtable[newindex].used do
176       newindex := succ(newindex) and tabsize;
177     stringtable[index].next := newindex;
178     result := newindex;
179   end;
180 end;
181 
182 function findstring(prevc, nextc: integer): integer;
183 var
184   index: integer;
185   found: boolean;
186 begin
187   result := endlist;
188   if (prevc = nochar) and (nextc <= 255) then
189     result := nextc
190   else
191   begin
192     index := ((prevc shl 5) xor nextc) and tabsize;
193     repeat
194       found := (stringtable[index].prevchar = prevc) and 
195 (stringtable[index].nextchar
196         = nextc);
197       if not found then
198         index := stringtable[index].next;
199     until found or (index = endlist);
200     if found then
201     begin
202       result := index;
203       inc(stringtable[index].nused);
204     end;
205   end;
206 end;
207 
208 function MakeTableEntry(prevc: integer; nextc: integer): boolean;
209 var
210   index: integer;
211 begin
212   result := true;
213   if objectid <= tabsize then
214   begin
215     index := gethashcode(prevc, nextc);
216     with stringtable[index] do
217     begin
218       prevchar := prevc;
219       nextchar := nextc;
220       used := true;
221     end;
222     inc(objectid);
223     if objectid = tabsize + 1 then
224       result := false;
225   end;
226 end;
227 
228 procedure putcode(code: integer; lbyte: boolean);
229 var
230   tmpcode: integer;
231 begin
232   if stringtable[code].prevchar = nochar then
233   begin
234     if rembitcount < 7 then
235     begin
236       tmpcode := (rembits shl (8 - rembitcount)) or (copybyte shl (7 - rembitcount))
237         or ((code shr (rembitcount + 1)) and ($7F shr rembitcount));
238       putbyte(tmpcode);
239       inc(fwrote);
240       rembits := code and ($FF shr (7 - rembitcount));
241       inc(rembitcount);
242     end
243     else if rembitcount = 7 then
244     begin
245       tmpcode := (rembits shl 1) or copybyte;
246       putbyte(tmpcode);
247       inc(fwrote, 2);
248       putbyte(code);
249       rembits := empty;
250       rembitcount := 0;
251     end;
252   end
253   else
254   begin
255     tmpcode := (rembits shl (8 - rembitcount)) or (compbyte shl (7 - rembitcount)) 
256 or
257       (code shr (5 + rembitcount) and ($7F shr rembitcount));
258     putbyte(tmpcode);
259     inc(fwrote);
260     rembitcount := rembitcount + 5;
261     if rembitcount < 8 then
262       rembits := code and ($FF shr (8 - rembitcount));
263     if rembitcount >= 8 then
264     begin
265       rembits := (code shr (rembitcount - 8)) and $FF;
266       inc(fwrote);
267       putbyte(rembits);
268       rembitcount := rembitcount - 8;
269       rembits := code and ($FF shr (8 - rembitcount));
270     end;
271   end;
272   if lbyte and (rembitcount > 0) then
273   begin
274     tmpcode := ((rembits and ($FF shr (8 - rembitcount))) shl (8 - rembitcount));
275     putbyte(tmpcode);
276     inc(fwrote);
277   end;
278 end;
279 
280 function getcode: integer;
281 var
282   part1, part2: integer;
283   iscomp: integer;
284   c1, c2: integer;
285 begin
286   result := eofchar;
287   if (fread = fsize) and (rembitcount = 0) then
288   begin
289     result := eofchar;
290     exit;
291   end;
292   if rembitcount = 0 then
293   begin
294     part1 := getbyte;
295     part2 := getbyte;
296     iscomp := (part1 shr 7) and 1;
297     if iscomp = 1 then
298     begin
299       c1 := part1 and $7F;
300       c2 := (part2 shr 3) and $1F;
301       rembits := part2 and $7;
302       rembitcount := 3;
303       result := (c1 shl 5) or c2;
304     end
305     else if iscomp = 0 then
306     begin
307       c1 := part1 and $7F;
308       c2 := (part2 shr 7) and $1;
309       result := (c1 shl 1) or c2;
310       rembits := part2 and $7F;
311       rembitcount := 7;
312     end;
313   end
314   else if rembitcount = 1 then
315   begin
316     part1 := getbyte;
317     iscomp := rembits;
318     if iscomp = 1 then
319     begin
320       part2 := getbyte;
321       c1 := part1 and $FF;
322       c2 := (part2 shr 4) and $F;
323       rembits := part2 and $F;
324       rembitcount := 4;
325       result := (c1 shl 4) or c2;
326     end
327     else if iscomp = 0 then
328     begin
329       c1 := part1 and $FF;
330       result := c1;
331       rembits := empty;
332       rembitcount := 0;
333     end;
334   end
335   else if rembitcount = 2 then
336   begin
337     part1 := getbyte;
338     iscomp := (rembits shr 1) and 1;
339     if iscomp = 1 then
340     begin
341       part2 := getbyte;
342       c1 := ((rembits and 1) shl 7) or ((part1 shr 1) and $7F);
343       c2 := ((part1 and 1) shl 3) or ((part2 shr 5) and $7);
344       rembits := part2 and $1F;
345       rembitcount := 5;
346       result := (c1 shl 4) or (c2 and $F);
347     end
348     else if iscomp = 0 then
349     begin
350       c1 := ((rembits and 1) shl 7) or ((part1 shr 1) and $7F);
351       result := c1;
352       rembits := part1 and 1;
353       rembitcount := 1;
354     end;
355   end
356   else if rembitcount = 3 then
357   begin
358     part1 := getbyte;
359     iscomp := (rembits shr 2) and 1;
360     if iscomp = 1 then
361     begin
362       part2 := getbyte;
363       c1 := ((rembits and $3) shl 6) or ((part1 shr 2) and $3F);
364       c2 := ((part1 and $3) shl 2) or ((part2 shr 6) and $3);
365       rembits := part2 and $3F;
366       rembitcount := 6;
367       result := (c1 shl 4) or (c2 and $F);
368     end
369     else if iscomp = 0 then
370     begin
371       c1 := ((rembits and $3) shl 6) or ((part1 shr 2) and $3F);
372       result := c1;
373       rembits := part1 and $3;
374       rembitcount := 2;
375     end;
376   end
377   else if rembitcount = 4 then
378   begin
379     part1 := getbyte;
380     iscomp := (rembits shr 3) and 1;
381     if iscomp = 1 then
382     begin
383       part2 := getbyte;
384       c1 := ((rembits and $7) shl 5) or ((part1 shr 3) and $1F);
385       c2 := ((part1 and $7) shl 1) or ((part2 shr 7) and $1);
386       rembits := part2 and $7F;
387       rembitcount := 7;
388       result := (c1 shl 4) or (c2 and $F);
389     end
390     else if iscomp = 0 then
391     begin
392       c1 := ((rembits and $7) shl 5) or ((part1 shr 3) and $1F);
393       result := c1;
394       rembits := part1 and $7;
395       rembitcount := 3;
396     end;
397   end
398   else if rembitcount = 5 then
399   begin
400     part1 := getbyte;
401     iscomp := (rembits shr 4) and 1;
402     if iscomp = 1 then
403     begin
404       c1 := ((rembits and $F) shl 4) or ((part1 shr 4) and $F);
405       c2 := part1 and $F;
406       rembits := empty;
407       rembitcount := 0;
408       result := (c1 shl 4) or (c2 and $F);
409     end
410     else if iscomp = 0 then
411     begin
412       c1 := ((rembits and $F) shl 4) or ((part1 shr 4) and $F);
413       result := c1;
414       rembits := part1 and $F;
415       rembitcount := 4;
416     end;
417   end
418   else if rembitcount = 6 then
419   begin
420     part1 := getbyte;
421     iscomp := (rembits shr 5) and 1;
422     if iscomp = 1 then
423     begin
424       c1 := ((rembits and $1F) shl 3) or ((part1 shr 5) and $7);
425       c2 := (part1 shr 1) and $F;
426       rembits := part1 and 1;
427       rembitcount := 1;
428       result := (c1 shl 4) or (c2 and $F);
429     end
430     else if iscomp = 0 then
431     begin
432       c1 := ((rembits and $1F) shl 3) or ((part1 shr 5) and $7);
433       result := c1;
434       rembits := part1 and $1F;
435       rembitcount := 5;
436     end;
437   end
438   else if rembitcount = 7 then
439   begin
440     part1 := getbyte;
441     iscomp := (rembits shr 6) and 1;
442     if iscomp = 1 then
443     begin
444       c1 := ((rembits and $3F) shl 2) or ((part1 shr 6) and $3);
445       c2 := (part1 shr 2) and $F;
446       rembits := part1 and $3;
447       rembitcount := 2;
448       result := (c1 shl 4) or (c2 and $F);
449     end
450     else if iscomp = 0 then
451     begin
452       c1 := ((rembits and $3F) shl 2) or ((part1 shr 6) and $3);
453       result := c1;
454       rembits := part1 and $3F;
455       rembitcount := 6;
456     end;
457   end;
458 end;
459 
460 procedure compress;
461 var
462   c, wc, w: integer;
463 begin
464   initialize;
465   c := getbyte;
466   w := findstring(nochar, c);
467   c := getbyte;
468   while fread <= fsize - 1 do
469   begin
470     if lastbyte then
471     begin
472       putcode(w);
473       lastbyte := false;
474       InitializeStringtable;
475       c := getbyte;
476       w := findstring(nochar, c);
477       c := getbyte;
478     end;
479     wc := findstring(w, c);
480     if wc = endlist then
481     begin
482       lastbyte := not (MakeTableEntry(w, c));
483       putcode(w);
484       w := findstring(nochar, c);
485     end
486     else
487       w := wc;
488     if not lastbyte then
489       c := getbyte;
490   end;
491   putcode(w, true);
492 end;
493 
494 procedure decompress;
495 var
496   unknown: boolean;
497   finchar, lastchar: integer;
498   code, oldcode, incode: integer;
499   c, tempc: integer;
500 begin
501   initialize;
502   unknown := false;
503   lastchar := empty;
504   oldcode := getcode;
505   code := oldcode;
506   c := stringtable[code].nextchar;
507   putbyte(c);
508   finchar := c;
509   incode := getcode;
510   while incode <> eofchar do
511   begin
512     if lastbyte then
513     begin
514       lastbyte := false;
515       InitializeStringTable;
516       stackpointer := 0;
517       unknown := false;
518       lastchar := empty;
519       oldcode := getcode;
520       code := oldcode;
521       c := stringtable[code].nextchar;
522       putbyte(c);
523       finchar := c;
524       incode := getcode;
525     end;
526     code := incode;
527     if not stringtable[code].used then
528     begin
529       lastchar := finchar;
530       code := oldcode;
531       unknown := true;
532     end;
533     while (stringtable[code].prevchar <> nochar) do
534     begin
535       push(stringtable[code].nextchar);
536       if lzwerr = true then
537         break;
538       code := stringtable[code].prevchar;
539     end;
540     if lzwerr = true then
541       break;
542     finchar := stringtable[code].nextchar;
543     putbyte(finchar);
544     pop(tempc);
545     while (tempc <> empty) do
546     begin
547       putbyte(tempc);
548       pop(tempc);
549     end;
550     if unknown then
551     begin
552       finchar := lastchar;
553       putbyte(finchar);
554       unknown := false;
555     end;
556     lastbyte := not (maketableentry(oldcode, finchar));
557     if not lastbyte then
558     begin
559       oldcode := incode;
560       incode := getcode;
561     end
562   end;
563 end;
564 
565 procedure push(c: integer);
566 var
567   s: string;
568 begin
569   if stackpointer < 4096 then
570   begin
571     inc(stackpointer);
572     stack[stackpointer] := char(c);
573   end;
574   if stackpointer >= 4096 then
575   begin
576     s := 'Stack full at ' + inttostr(inbufpos);
577     lzwerr := true;
578     showmessage(s);
579   end;
580 end;
581 
582 procedure pop(var c: integer);
583 begin
584   if stackpointer > 0 then
585   begin
586     c := integer(stack[stackpointer]);
587     dec(stackpointer);
588   end
589   else
590     c := empty;
591 end;
592 
593 end.
594 
595 //To compress the file add the following code to a button 
596 
597 openinputfile('C:\cdidxtmp\myfile.exe');
598 openoutputfile('C:\cdidxtmp\myfile.bak');
599 initialize;
600 compress;
601 
602 //To Decompress 
603 
604 openinputfile('C:\cdidxtmp\myfile.bak');
605 openoutputfile('C:\cdidxtmp\myfile.exe');
606 initialize;
607 decompress;


			
Vote: How useful do you find this Article/Tip?
Bad Excellent
1 2 3 4 5 6 7 8 9 10

 

Advertisement
Share this page
Advertisement
Download from Google

Copyright © Mendozi Enterprises LLC