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 / ARCSQU.INC < prev    next >
Text File  |  1989-11-10  |  6KB  |  214 lines
  1. (* ARCSQU.INC  TR 071189 *)
  2.  
  3. const listsexist  : boolean = false;
  4.       speof       = 256;
  5.       notspeof    = $FEFF;
  6.       numvals     = 257;
  7.       maxnumnodes = 513;
  8.       nochild     = -1;
  9.  
  10. type  listtyp     = array[0..maxnumnodes] of integer;
  11.       listptr     = ^listtyp;
  12.  
  13. var   weight,lchild,rchild,tdepth,
  14.       codlen,scode,idxtree         : listptr;
  15.       numnodes,treehead,tcode      : integer;
  16.       tables_ok                    : boolean;
  17.       squlen                       : longword;
  18.       bitpos                       : byte;     (* LZW too *)
  19.  
  20. (* Compare 2 (sub)trees after weight and depth.           *)
  21. (* Result is true when first tree is greater than second. *)
  22.  
  23. function cmptrees(x,y:integer):boolean;
  24. begin
  25.   inline($ED/$5B/WEIGHT/$2A/X/$29/$19/$4E/$23/$46/$2A/Y/$29/$19/$7E/
  26.   $23/$66/$6F/$ED/$42/$21/$01/$00/$D8/$2E/$00/$C0/$ED/$5B/TDEPTH/$2A/X/
  27.   $29/$19/$4E/$23/$46/$2A/Y/$29/$19/$7E/$23/$66/$6F/$ED/$42/$21/$01/$00/
  28.   $D8/$2E/$00/$C9);
  29.   end;
  30.  
  31. (* HeapSort the IDXTREE in ascending order of weight and depth *)
  32.  
  33. {$a-}
  34. procedure adjust(top,bottom:integer);
  35. var k,temp : integer;
  36. begin
  37.   k:=succ(top shl 1);
  38.   temp:=idxtree^[top];
  39.   if k<=bottom then begin
  40.     if (k<bottom) and cmptrees(idxtree^[k],idxtree^[succ(k)]) then k:=succ(k);
  41.     if cmptrees(temp,idxtree^[k]) then begin
  42.       idxtree^[top]:=idxtree^[k];
  43.       idxtree^[k]:=temp;
  44.       adjust(k,bottom);
  45.       end;
  46.     end;
  47.   end;
  48. {$a+}
  49.  
  50. (* Build a Huffman Tree in IDXTREE using weight and depth. *)
  51. (* Result: Tree stored in upper half of RCHILD/LCHILD, TREEHEAD is top *)
  52.  
  53. procedure bld_tree(len:integer);
  54. var lch,rch : integer;
  55.  
  56.   function max(a,b:byte):byte;
  57.   begin
  58.     if a>b then max:=a else max:=b;
  59.     end;
  60.  
  61. begin
  62.   treehead:=speof;
  63.   for lch:=pred(len shr 1) downto 1 do adjust(lch,pred(len));
  64.   while len>1 do begin
  65.     adjust(0,pred(len));
  66.     lch:=idxtree^[0]; rch:=idxtree^[1];
  67.     len:=pred(len); idxtree^[1]:=idxtree^[len];
  68.     adjust(1,pred(len));
  69.     treehead:=succ(treehead); idxtree^[0]:=treehead;
  70.     lchild^[treehead]:=lch; rchild^[treehead]:=rch;
  71.     weight^[treehead]:=weight^[lch]+weight^[rch];
  72.     tdepth^[treehead]:=succ(max(tdepth^[lch],tdepth^[rch]));
  73.     end;
  74.   end;
  75.  
  76. (* Build encoding table (SCODE,CODLEN) out of the tree *)
  77.  
  78. {$a-}
  79. procedure buildenc(level,root:integer);
  80. begin
  81.   tcode:=tcode and rmask[level];
  82.   if root<=speof then begin
  83.     codlen^[root]:=level; scode^[root]:=tcode;
  84.     if level>16 then tables_ok:=false;
  85.     end
  86.   else begin
  87.     buildenc(succ(level),lchild^[root]);
  88.     tcode:=tcode or succ(rmask[level]);
  89.     buildenc(succ(level),rchild^[root]);
  90.     end;
  91.   end;
  92. {$a+}
  93.  
  94. (* Predict size of squeezed file (into global var SQULEN) *)
  95.  
  96. procedure predict_squ;
  97. var listlen,ceiling,divi,dum : integer;
  98.     w                        : ^integer absolute dum;
  99. begin
  100.   valcount[speof]:=long_eins;
  101.   new(scode); new(codlen); new(lchild); new(rchild);
  102.   new(weight); new(tdepth); new(idxtree); listsexist:=true;
  103.   for gi:=0 to speof do weight^[gi]:=long_to_integer(valcount[gi]);
  104.   ceiling:=maxint;
  105.   repeat
  106.     squlen:=long_null;
  107.     for gi:=0 to speof do add_long_int(squlen,weight^[gi]);
  108.     divi:=succ(trunc(long_to_real(squlen)/ceiling));
  109.     ceiling:=ceiling shr 1; listlen:=0;
  110.     for gi:=0 to speof do begin
  111.       dum:=addr(weight^[gi]);
  112.       if w^<>0 then begin
  113.         if divi>1 then if w^<=divi then w^:=1 else w^:=w^ div divi;
  114.         tdepth^[gi]:=0;
  115.         idxtree^[listlen]:=gi; listlen:=succ(listlen);
  116.         end;
  117.       end;
  118.     bld_tree(listlen);
  119.     tables_ok:=true; buildenc(0,treehead);
  120.   until tables_ok;
  121.   dispose(idxtree); dispose(tdepth); dispose(weight);
  122.   squlen:=long_null;
  123.   for gi:=0 to speof do
  124.     add_long_mult(squlen,valcount[gi],codlen^[gi]);
  125.   add_long_int(squlen,23); shift_long(squlen,-3);
  126.   if treehead>speof then numnodes:=treehead-speof else numnodes:=0;
  127.   add_long_int(squlen,numnodes shl 2);
  128.   end;
  129.  
  130. (* SQUEEZE entire file using heaped tables CODE and CODELEN *)
  131.  
  132. procedure squeeze(var source,dest:binfile);
  133. var i : integer;
  134.  
  135.   procedure putint(i:integer);
  136.   begin
  137.     fputc(dest,crypt(lo(i)));
  138.     fputc(dest,crypt(hi(i)));
  139.     end;
  140.  
  141.   procedure putnode(n:integer);
  142.   begin
  143.     if n<=speof then n:=not n else n:=treehead-n;
  144.     putint(n);
  145.     end;
  146.  
  147.   procedure outcode(cod,len:integer);
  148.     procedure putcod;
  149.     begin
  150.       fputc(dest,crypt(tcode));
  151.       end;
  152.   begin
  153.     inline($3A/LEN/$B7/$C8/$47/$21/TCODE/$ED/$5B/COD/$3A/BITPOS/$CB/$3A/
  154.     $CB/$1B/$CB/$1E/$3C/$E6/$07/$20/$0B/$F5/$C5/$D5/$E5/$CD/PUTCOD/$E1/
  155.     $D1/$C1/$F1/$10/$E8/$32/BITPOS);
  156.     end;
  157.  
  158. begin  { squeeze }
  159.   putint(numnodes);
  160.   for i:=treehead downto numvals do begin
  161.     putnode(lchild^[i]); putnode(rchild^[i]); end;
  162.   init_ncr; ncrend:=source.feof;
  163.   bitpos:=0;
  164.   while not ncrend do begin
  165.     i:=getc_ncr(source);
  166.     outcode(scode^[i],codlen^[i]);
  167.     end;
  168.   outcode(scode^[speof],codlen^[speof]);
  169.   outcode(0,7);   (* write TCODE if necessary *)
  170.   end;
  171.  
  172. (* Nach Kompression Listen loeschen *)
  173.  
  174. procedure deinit_squ;
  175. begin
  176.   if listsexist then begin
  177.     dispose(rchild); dispose(lchild); dispose(codlen); dispose(scode);
  178.     listsexist:=false;
  179.     end;
  180.   end;
  181.  
  182. (* Gesamte Datei dekomprimieren *)
  183.  
  184. procedure unsqueeze(var source,dest:binfile);
  185. type nodetyp = array[0..speof,0..1] of integer;
  186. var  node    : ^nodetyp;
  187.      i,curin : integer;
  188.  
  189.   procedure getint(var int:integer);
  190.   begin
  191.     int:=crypt(getc_decsiz(source)) + crypt(getc_decsiz(source)) shl 8;
  192.     end;
  193.  
  194. begin
  195.   new(node);
  196.   getint(curin);
  197.   if curin=0 then begin
  198.     node^[0,0]:=notspeof;
  199.     node^[0,1]:=notspeof;
  200.     end
  201.   else for i:=0 to pred(curin) do begin
  202.     getint(node^[i,0]);
  203.     getint(node^[i,1]);
  204.     end;
  205.   inline($DD/$21/SIZ/$AF/$DD/$CB/$03/$7E/$20/$5F/$11/$00/$00/$B7/$20/$15/
  206.   $F5/$D5/$DD/$E5/$ED/$5B/SOURCE/$D5/$CD/GETC_DECSIZ/$E5/$CD/CRYPT/
  207.   $4D/$DD/$E1/$D1/$F1/$2A/NODE/$CB/$39/$30/$02/$23/$23/$19/$19/$19/
  208.   $19/$5E/$23/$56/$3C/$E6/$07/$CB/$7A/$28/$D1/$21/NOTSPEOF/$ED/$52/
  209.   $28/$17/$F5/$C5/$DD/$E5/$2A/DEST/$E5/$7B/$2F/$5F/$16/$00/$D5/$CD/PUTC_NCR/
  210.   $DD/$E1/$C1/$F1/$18/$AA/$DD/$CB/$03/$7E/$20/$09/$2A/SOURCE/$E5/$CD/
  211.   GETC_DECSIZ/$18/$F1);
  212.   dispose(node);
  213.   end;
  214.