Simple Implementation of LZW Compression/Decompression Algorithm (Views: 2141)
Problem/Question/Abstract: 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. 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[i] 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[i].nextchar := i; stringtable[i].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[code].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; |