home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / ENTERPRS / CPM / UTILS / A / ARC20.ARC / ARCLZW.INC < prev    next >
Text File  |  1989-11-10  |  6KB  |  202 lines
  1. (* ARCLZW.INC  TR 101189 *)
  2.  
  3. const hsize      = 5003;
  4.       firstfree  = 257;
  5.       clearcode  = 256;
  6.       initbits   = 9;
  7.       maxbits    = 12;
  8.       maxmax     = 4096;    (* = 1 shl maxbits *)
  9.       check_gap  = 10000.0;
  10.  
  11. type  entry      = record
  12.                      case byte of
  13.                        0 : (neucod:byte; lastcod:integer; buf:byte);
  14.                        1 : (dum,lzwcod : integer);
  15.                      end;
  16.       lzwtab     = array[0..hsize] of entry;
  17.  
  18. var   buf                      : array[0..maxbits] of byte;
  19.       tab                      : ^lzwtab;
  20.       scod,lzwlen              : longword;
  21.       bytpos,codzahl           : byte;
  22.       actbits,nextfree,maxcode : integer;
  23.       ratio,nextcheck          : real;
  24.  
  25. (* Codebreite (9 bis 12 Bit) neu einstellen *)
  26.  
  27. procedure setbits(n:byte);
  28. begin
  29.   actbits:=n;
  30.   if n=maxbits then maxcode:=maxmax else maxcode:=rmask[n];
  31.   bitpos:=0; bytpos:=0; codzahl:=0;
  32.   end;
  33.  
  34. (* Einzelnen 9/12-Bit-Code an LZW-Datei ausgeben *)
  35.  
  36. procedure putcode(var f:binfile; code:integer);
  37.  
  38.   procedure boost(n:byte);
  39.   var i : byte;
  40.   begin
  41.     for i:=0 to pred(n) do fputc(f,buf[i]);
  42.     add_long_int(lzwlen,n);
  43.     bitpos:=0; bytpos:=0;
  44.     end;
  45.  
  46.   procedure setbits_put(n:byte);
  47.   begin
  48.     if bytpos>0 then boost(actbits);
  49.     setbits(n);
  50.     end;
  51.  
  52. begin
  53.   if code>=0 then begin
  54.     inline($2A/CODE/$1E/$00/$3A/BITPOS/$B7/$28/$06/$47/$29/$CB/$13/$10/$FB/
  55.     $4F/$06/$00/$DD/$21/RMASK/$DD/$09/$DD/$09/$DD/$7E/$00/$ED/$4B/BYTPOS/
  56.     $06/$00/$DD/$21/BUF/$DD/$09/$DD/$A6/$00/$B5/$DD/$77/$00/$DD/$74/$01/
  57.     $2A/ACTBITS/$3A/BITPOS/$85/$D6/$08/$0C/$FE/$08/$38/$06/$D6/$08/$0C/
  58.     $DD/$73/$02/$32/BITPOS/$79/$32/BYTPOS);
  59.     if bytpos>=actbits then boost(actbits);
  60.     if code=clearcode then setbits_put(initbits)
  61.     else if nextfree>maxcode then setbits_put(succ(actbits));
  62.     end
  63.   else boost(bytpos+byte(bitpos>0));
  64.   end;
  65.  
  66. (* gesamte Datei komprimierend in Archiv uebernehmen *)
  67.  
  68. procedure crunch_lzw(var source,dest:binfile);
  69. var inbytes         : longword;
  70.     last,neu,i,disp : integer;
  71.     fnd             : boolean;
  72.  
  73.   procedure checkratio;
  74.   var rat : real;
  75.   begin
  76.     nextcheck:=nextcheck+check_gap;
  77.     rat:=long_to_real(inbytes)/long_to_real(lzwlen);
  78.     if ratio<rat then ratio:=rat else begin
  79.       ratio:=0.0;
  80.       fillchar(tab^,sizeof(lzwtab),$FF);
  81.       nextfree:=firstfree;
  82.       putcode(dest,clearcode);
  83.       end;
  84.     end;
  85.  
  86. begin
  87.   ratio:=0.0; nextcheck:=check_gap;
  88.   setbits(initbits);
  89.   nextfree:=firstfree;
  90.   new(tab); fillchar(tab^,sizeof(lzwtab),$FF);
  91.   fputc(dest,maxbits); lzwlen:=long_eins;
  92.   last:=getc_ncr(source); inbytes:=long_eins;
  93.   while not ncrend do begin
  94.     neu:=getc_ncr(source);
  95.     inc_long(inbytes);
  96.     inline($2A/NEU/$26/$00/$29/$29/$29/$29/$ED/$5B/LAST/$7C/$AA/$67/
  97.     $7D/$AB/$6F/$22/I/$B4/$21/$01/$00/$28/$09/$21/$8B/$13/$ED/$5B/I/
  98.     $ED/$52/$22/DISP/$2A/I/$29/$29/$ED/$5B/TAB/$19/$E5/$3A/NEU/$BE/$20/$2B/
  99.     $ED/$4B/LAST/$23/$79/$BE/$20/$22/$23/$7E/$E6/$0F/$B8/$20/$1B/$7E/
  100.     $23/$66/$CB/$3C/$1F/$CB/$3C/$1F/$CB/$3C/$1F/$CB/$3C/$1F/$6F/$22/LAST/
  101.     $E1/$3E/$01/$32/FND/$18/$24/$AF/$32/FND/$E1/$7E/$23/$A6/$23/$A6/
  102.     $23/$A6/$3C/$28/$15/$2A/I/$ED/$5B/DISP/$B7/$ED/$52/$30/$04/$11/$8B/$13/
  103.     $19/$22/I/$18/$A0);
  104.     if not fnd then begin
  105.       putcode(dest,last);
  106.       if nextfree<maxmax then begin
  107.         tab^[i].neucod:=neu;
  108.         tab^[i].lastcod:=last;
  109.         tab^[i].lzwcod:=tab^[i].lzwcod and $F + (nextfree shl 4);
  110.         nextfree:=succ(nextfree);
  111.         end
  112.       else if long_to_real(inbytes)>=nextcheck then checkratio;
  113.       last:=neu;
  114.       end;
  115.     end;
  116.   putcode(dest,last);
  117.   putcode(dest,-1);
  118.   dispose(tab);
  119.   end;
  120.  
  121. (* Einzelnen 9/12-Bit-Code aus LZW-Datei holen *)
  122.  
  123. function getcode(var f:binfile):integer;
  124. begin
  125.   if codzahl=0 then begin
  126.     bytpos:=0; bitpos:=0;
  127.     while (siz.hi>=0) and (codzahl<actbits) do begin
  128.       buf[codzahl]:=crypt(getc_decsiz(f));
  129.       codzahl:=succ(codzahl);
  130.       end;
  131.     if codzahl<2 then begin getcode:=-1; exit; end;
  132.     codzahl:=(codzahl shl 3) div actbits;
  133.     end;
  134.   scod.b0:=buf[bytpos];
  135.   bytpos:=succ(bytpos);
  136.   scod.b1:=buf[bytpos];
  137.   scod.b2:=buf[succ(bytpos)];
  138.   shift_long(scod,-bitpos);
  139.   getcode:=scod.lo and rmask[actbits];
  140.   bitpos:=bitpos+actbits-8;
  141.   if bitpos>7 then begin bitpos:=bitpos-8; bytpos:=succ(bytpos); end;
  142.   codzahl:=pred(codzahl);
  143.   end;
  144.  
  145. (* komplette LZW-Datei dekomprimieren *)
  146.  
  147. procedure uncrunch_lzw(var source,dest:binfile);
  148. var code,last,sp,c : integer;
  149.  
  150.   procedure put_tab(x:byte);
  151.   begin
  152.     putc_ncr(dest,x);
  153.     if nextfree<maxmax then begin
  154.       tab^[nextfree].lastcod:=last;
  155.       tab^[nextfree].neucod:=x;
  156.       nextfree:=succ(nextfree);
  157.       end;
  158.     end;
  159.  
  160. begin
  161.   code:=crypt(getc_decsiz(source));
  162.   if code<>maxbits then begin
  163.     writeln('File packed with ',code,' bits, I can only handle ',maxbits);
  164.     halt; end;
  165.   setbits(initbits); nextfree:=firstfree;
  166.   last:=getcode(source); if last=-1 then exit;
  167.   new(tab);
  168.   putc_ncr(dest,last);
  169.   repeat
  170.     if nextfree>maxcode then setbits(succ(actbits));
  171.     code:=getcode(source);
  172.     if code>=0 then begin
  173.       if code=clearcode then begin
  174.         setbits(initbits);
  175.         nextfree:=firstfree;
  176.         end
  177.       else begin
  178.         if code<firstfree then put_tab(code) else begin
  179.           sp:=0;
  180.           if code<nextfree then c:=code else begin
  181.             tab^[sp].buf:=c;     (* letzter Anfangscode! *)
  182.             sp:=succ(sp);
  183.             c:=last;
  184.             end;
  185.           while c>=firstfree do begin
  186.             tab^[sp].buf:=tab^[c].neucod;
  187.             c:=tab^[c].lastcod;
  188.             sp:=succ(sp);
  189.             end;
  190.           put_tab(c);
  191.           while sp>0 do begin
  192.             sp:=pred(sp);
  193.             putc_ncr(dest,tab^[sp].buf);
  194.             end;
  195.           end;
  196.         last:=code;
  197.         end;
  198.       end;
  199.   until code<0;
  200.   dispose(tab);
  201.   end;
  202.