1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: 120: 121: 122: 123: 124: 125: 126: 127: 128: 129: 130: 131: 132: 133: 134: 135: 136: 137: 138: 139: 140: 141: 142: 143: 144: 145: 146: 147: 148: 149: 150: 151: 152: 153: 154: 155: 156: 157: 158: 159: 160: 161: 162: 163: 164: 165: 166: 167: 168: 169: 170: 171: 172: 173: 174: 175: 176: 177: 178: 179: 180: 181: 182: 183: 184: 185: 186: 187: 188: 189: 190: 191: 192: 193: 194: 195: 196: 197: 198: 199: 200: 201: 202: 203: 204: 205: 206: 207: 208: 209: 210: 211: 212: 213: 214: 215: 216: 217: 218: 219: 220: 221: 222: 223: 224: 225: 226: 227: 228: 229: 230: 231: 232: 233: 234: 235: 236: 237: 238: 239: 240: 241: 242: 243: 244: 245: 246: 247: 248: 249: 250: 251: 252: 253: 254: 255: 256: 257: 258: 259: 260: 261: 262: 263: 264: 265: 266: 267: 268: 269: 270: 271: 272: 273: 274: 275: 276: 277: 278: 279: 280: 281: 282: 283: 284: 285: 286: 287: 288: 289: 290: 291: 292: 293: 294: 295: 296: 297: 298: 299: 300: 301: 302: 303: 304: 305: 306: 307: 308: 309: 310: 311: 312: 313: 314: 315: 316: 317: 318: 319: 320: 321: 322: 323: 324: 325: 326: 327: 328: 329: 330: 331: 332: 333: 334: 335: 336: 337: 338: 339: 340: 341: 342: 343: 344: 345: 346: 347: 348: 349: 350: 351: 352: 353: 354: 355: 356: 357: 358: 359: 360: 361: 362: 363: 364: 365: 366: 367: 368: 369: 370: 371: 372: 373: 374: 375: 376: 377: 378: 379: 380: 381: 382: 383: 384: 385: 386: 387: 388: 389: 390: 391: 392: 393: 394: 395: 396: 397: 398: 399: 400: 401: 402: 403: 404: 405: 406: 407: 408: 409: 410: 411: 412: 413: 414: 415: 416: 417: 418: 419: 420: 421: 422: 423: 424: 425: 426: 427: 428: 429: 430: 431: 432: 433: 434: 435: 436: 437: 438: 439: 440: 441: 442: 443: 444: 445: 446: 447: 448: 449: 450: 451: 452: 453: 454: 455: 456: 457: 458: 459: 460: 461: 462: 463: 464: 465: 466: 467: 468: 469: 470: 471: 472: 473: 474: 475:
| unit HuffFuncs;
interface
uses classes,sysutils,windows;
type Phuffinfo=^Thuffinfo; THuffInfo=record left:phuffinfo; right:phuffinfo; code: array[0..255] of byte; codecount:integer; huff,char:byte; freq:integer; ticked:boolean; end; THuffcode=record char:byte; used:boolean; code:array[0..255] of byte; codelength:integer; end; PhuffCode=^THuffCode;
type EError=class(Exception); procedure Initialize; function SetInputfile(afilename:string):boolean; function SetOutputfile(afilename:string):boolean; procedure Compress(var usize,csize:integer); procedure Decompress; procedure Finalize;
var huffcodes: array[0..255] of Thuffcode; implementation
procedure GetDistribution;forward; procedure InitList;forward; procedure BuildTree;forward; procedure GetCodes;forward; procedure GetTable;forward; function GetCompressedSize:integer;forward; procedure RetrieveTable; forward; procedure ReconstructTree;forward; procedure WriteCompressedFile;forward; procedure WriteUncompressedFile;forward;
var Charlist:array[0..511] of THuffinfo; ifile,ofile:Tfilestream; infile,outfile:string; InBuffer,OutBuffer:array[0..32767] of byte; ufilesize,cfilesize:integer; rootnode:Phuffinfo; table: array[0..1495] of byte; tabsize:integer; endbits:byte;
procedure Initialize; begin zeromemory(@charlist,sizeof(charlist)); zeromemory(@table,sizeof(table)); zeromemory(@huffcodes,sizeof(huffcodes)); infile:=''; outfile:=''; endbits:=0; ufilesize:=0; cfilesize:=0; rootnode:=nil; end; procedure Finalize; begin freeandnil(ifile); freeandnil(ofile); end;
function SetInputfile(afilename:string):boolean; begin result:=fileexists(afilename); if result=true then begin ifile:=Tfilestream.create(afilename,fmOpenRead or fmShareDenyNone); infile:=afilename; ufilesize:=GetFileSize(ifile.Handle,nil); end else raise EError.Create('Invalid Filename');
end;
procedure InitList; var i:integer; begin zeromemory(@charlist,sizeof(charlist)); zeromemory(@huffcodes,sizeof(huffcodes)); for i:=0 to 255 do begin charlist[i].code[charlist[i].codecount]:=i; inc(charlist[i].codecount); end; end;
function SetOutputfile(afilename:string):boolean; begin ofile:=Tfilestream.create(afilename,fmCreate or fmShareDenyNone); outfile:=afilename; result:=true; end;
procedure GetDistribution; var i:integer; bufcount:integer; begin bufcount:=ifile.read(inbuffer,32768); repeat for i:=0 to bufcount-1 do charlist[inbuffer[i]].freq:=charlist[inbuffer[i]].freq+1; bufcount:=ifile.read(inbuffer,32768); until bufcount=0; end;
procedure BuildTree; var i,cnt,tmp:integer; pinfo1,pinfo2:Phuffinfo; begin pinfo1:=nil; pinfo2:=nil; cnt:=255; while true do begin tmp:=maxint; for i:=0 to cnt do begin if (charlist[i].freq<tmp) and (charlist[i].freq > 0) and(charlist[i].ticked=false) then begin pinfo1:=@charlist[i]; tmp:=pinfo1.freq; end; end; if pinfo1=nil then break; pinfo1.ticked:=true; tmp:=maxint; for i:=0 to cnt do begin if (charlist[i].freq<tmp) and (charlist[i].freq > 0) and (charlist[i].ticked=false) then begin pinfo2:=@charlist[i]; tmp:=pinfo2.freq; end; end; if pinfo2=nil then break; pinfo2.ticked:=true; inc(cnt); charlist[cnt].freq:=pinfo1.freq+pinfo2.freq; strcat(@charlist[cnt].code,@pinfo1.code); strcat(@charlist[cnt].code,@pinfo2.code); charlist[cnt].codecount:=pinfo1.codecount+pinfo2.codecount; charlist[cnt].left:=pinfo1; charlist[cnt].right:=pinfo2; pinfo1:=nil; pinfo2:=nil; end; rootnode:=@charlist[cnt]; end;
procedure GetCodes; var i,j:integer; tmpnode:phuffinfo; flag:integer; begin for i:=0 to 255 do begin flag:=-1; tmpnode:=rootnode; while tmpnode.left<>nil do begin for j:=0 to tmpnode.left.codecount-1 do if tmpnode.left.code[j]= i then begin flag:=0; tmpnode:=tmpnode.left; break; end; if flag=-1 then begin for j:=0 to tmpnode.right.codecount-1 do if tmpnode.right.code[j]= i then begin flag:=1; tmpnode:=tmpnode.right; break; end; end; if flag=-1 then break; huffcodes[i].used:=true; huffcodes[i].code[huffcodes[i].codelength]:=flag; huffcodes[i].codelength:=huffcodes[i].codelength+1; huffcodes[i].char:=i; flag:=-1; end; end; end;
procedure WriteCompressedFile; var i,j,k:integer; tmpcode:byte; bit:integer; bufcount:integer; begin k:=0; tmpcode:=0; bit:=0; ofile.seek(1,sofrombeginning); ofile.write(tabsize,sizeof(tabsize)); ofile.write(table,tabsize); ifile.seek(0,soFromBeginning); bufcount:=ifile.read(inbuffer,32768); repeat for i:=0 to bufcount-1 do begin for j:=0 to huffcodes[inbuffer[i]].codelength-1 do begin tmpcode:=(tmpcode shl 1) or huffcodes[inbuffer[i]].code[j]; inc(bit); if bit=8 then begin outbuffer[k]:=tmpcode; inc(k); bit:=0; tmpcode:=0; end; if k=32768 then begin ofile.write(outbuffer,32768); k:=0; end; end; end; bufcount:=ifile.read(inbuffer,32768); until bufcount=0; if bit>0 then begin tmpcode:=tmpcode shl (8-bit); outbuffer[k]:=tmpcode; k:=k+1; end; if k>0 then ofile.write(outbuffer,k); ofile.seek(0,sofrombeginning); ofile.write(bit,1); end;
procedure Compress(var usize,csize:integer); begin Initlist; GetDistribution; BuildTree; GetCodes; GetTable; WriteCompressedFile; usize:=ufilesize; csize:=GetCompressedsize; end;
function GetCompressedSize:integer; var i:integer; begin result:=0; for i:=0 to 255 do begin if huffcodes[i].used then result:=result+huffcodes[i].codelength*charlist[i].freq; end; cfilesize:=result div 8; if result mod 8>0 then cfilesize:=cfilesize+1; cfilesize:=cfilesize+tabsize+sizeof(tabsize)+1; result:=cfilesize; end;
procedure GetTable; var i,j,k:integer; tmpcode:byte; bit:integer; begin k:=0; bit:=0; tmpcode:=0; for i:=0 to 255 do begin if huffcodes[i].used=false then continue; table[k]:=i; table[k+1]:=huffcodes[i].codelength; k:=k+2; for j:=0 to huffcodes[i].codelength-1 do begin tmpcode:=tmpcode shl 1 or huffcodes[i].code[j]; bit:=bit+1; if bit=8 then begin table[k]:=tmpcode; k:=k+1; bit:=0; tmpcode:=0; end; end; if bit>0 then begin tmpcode:=tmpcode shl (8-bit); table[k]:=tmpcode; k:=k+1; bit:=0; tmpcode:=0; end; end; tabsize:=k; end;
procedure RetrieveTable; var j,k,l:integer; index:integer; length,cnt:integer; tmpcode:byte; begin ifile.seek(0,soFromBeginning); ifile.read(endbits,1); if endbits=0 then endbits:=8; ifile.Read(table,sizeof(table)); tabsize:=pinteger(@table[0])^; k:=sizeof(tabsize); while k<tabsize+sizeof(tabsize) do begin j:=0; index:=table[k]; k:=k+1; length:=table[k]; k:=k+1; huffcodes[index].used:=true; huffcodes[index].char:=index; huffcodes[index].codelength:=length; while j<=length-1 do begin tmpcode:=table[k]; k:=k+1; if (length-j)>8 then cnt:=8 else cnt:=length-j; for l:=1 to cnt do begin huffcodes[index].code[l+j-1]:=(tmpcode shr (8-l)) and 1; end; j:=j+cnt; end; end; end;
procedure ReconstructTree; var rinfo:phuffinfo; i,j,k:integer; begin k:=0; zeromemory(@charlist,sizeof(charlist)); for i:=0 to 255 do begin rinfo:=@charlist[511]; for j:=0 to huffcodes[i].codelength-1 do begin charlist[k].huff:=huffcodes[i].code[j]; if huffcodes[i].code[j]= 0 then begin if rinfo.left=nil then begin rinfo.left:=@charlist[k]; k:=k+1; end; rinfo:=rinfo.left; end else begin if rinfo.right=nil then begin rinfo.right:=@charlist[k]; k:=k+1; end; rinfo:=rinfo.right; end; if j=huffcodes[i].codelength-1 then rinfo.char:=huffcodes[i].char; end; end; end;
procedure WriteUncompressedFile; var bufcount,i,j,l:integer; tmpbit,tmpbyte:byte; tmpnode:phuffinfo; begin i:=0;j:=1;l:=0; tmpnode:=@charlist[511]; ifile.seek(tabsize+sizeof(tabsize)+1,soFromBeginning); ofile.seek(0,soFromBeginning); bufcount:=ifile.read(inbuffer,32768); tmpbyte:=inbuffer[0]; i:=i+1; repeat while true do begin while (tmpnode.left<>nil) do begin if j>8 then begin tmpbyte:=inbuffer[i]; i:=i+1; if i=bufcount then begin bufcount:=ifile.read(inbuffer,32768); i:=0; end; j:=1; end; tmpbit:=(tmpbyte shr (8-j)) and 1; if tmpnode.left.huff=tmpbit then begin tmpnode:=tmpnode.left; j:=j+1; end else begin tmpnode:=tmpnode.right; j:=j+1; end; end; OutBuffer[l]:=tmpnode.char; l:=l+1; tmpnode:=@charlist[511]; if l=32768 then begin ofile.write(outbuffer,32768); l:=0; end; if (bufcount=0) and (i=0) and (j>endbits) then break; end; until bufcount=0; if l>0 then ofile.write(outbuffer,l); end;
procedure Decompress; begin RetrieveTable; ReConstructTree; WriteUncompressedfile; end;
end. |