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.