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
/
CPM
/
TURBOPAS
/
SQZTURBO.LBR
/
SQZMAIN.INC
< prev
next >
Wrap
Text File
|
2000-06-30
|
15KB
|
390 lines
{ Initialize all nodes to single element
binary trees with zero weight and depth. }
Procedure ZeroTree;
var i: integer;
begin
For i := 0 to NumNodes do with Node[i] do
begin
Weight:=0.0; TDepth:=0; LChild:=NoChild; RChild:=NoChild;
end;
end; { Procedure ZeroTree }
Procedure PutWe(w: integer);
var b1, b2: char;
begin
b1 := chr(w and $FF); b2 := chr(w shr 8);
WriteOutFile(b1); WriteOutFile(b2);
end; { Procedure PutWe }
Function GetCNr: char;
Var return: char;
Function Alike: boolean;
begin
If EOFile then EOFlag:=true else NewChar:=GetC;
If EOFile then Alike:=false
else Alike:=( (NewChar=LastChar) and (LikeCt<255) );
end; { Function Alike }
Procedure NoHistory; {set up the state machine}
begin
State:=SentChar;
If not EOFile then LastChar:=GetC;
EoFlag:=EoFile; If EOFlag then State:=EndFile;
Return:=LastChar;
end; { Procedure NoHistory }
Procedure SentAChar; {LastChar is sent, need lookahead}
Procedure SentDLE;
begin
State:=NoHist; Return:=chr(0);
end; { Procedure SentDLE }
Procedure CheckAlike;
begin
LikeCt:=1; While alike do LikeCt:=succ(LikeCt);
Case LikeCt of
1: begin
LastChar:=NewChar; Return:=LastChar;
EoFlag:=EoFile;
end;
2: begin { just pass through }
State:=SendNewC; Return:=LastChar;
end;
else begin
State:=SendCnt; Return:=DLE;
end;
end;
end; { Procedure CheckAlike }
begin
If EOFlag then State := EndFile
{no return value, set to SPEOF in calling routine}
else
If LastChar=DLE then SentDLE
else CheckAlike;
end; { Procedure SentAChar }
Procedure SendNewChar; {Previous sequence complete, newchar set}
begin
EOFlag:=EOFile;
State:=SentChar; LastChar:=NewChar; Return:=LastChar;
end; { Procedure SendNewChar }
Procedure SendCount; {Sent DLE for repeat sequence, send count}
begin
State:=SendNewC; Return:=chr(LikeCt);
end; { Procedure SendCount }
begin
Case State of
NoHist: NoHistory;
SentChar: SentAChar;
SendNewC: SendNewChar;
SendCnt: SendCount;
else WriteLn('Program Bug - Bad State!');
end;
GetCnr:=Return;
end; { Function GetCNr }
Procedure WriteHeader;
Var i, k, l, r, NumNodes: integer; { NumNodes: nbr of nodes in
simplified tree }
begin
PutWe(Recognize); { identifies as compressed }
PutWe(Crc); { unsigned sum of original data }
{ Record the original file name w/o drive }
If (InFileName[2]=':') then
InFileName:=copy(InFileName,3,length(InFileName)-2);
InFileName:=InFileName+chr(0); {mark end of file name}
For i:=1 to Length(InFileName) do WriteOutFile(InFileName[i]);
{ Write out a simplified decoding tree. Only the interior nodes are
written. When a child is a leaf index (representing a data value)
it is recoded as -(index + 1) to distinguish it from interior
indexes which are recoded as positive indexes in the new tree.
Note that this tree will be empty for an empty file. }
If DcTreeHd<NumVals then NumNodes:=0
else NumNodes:=DcTreeHd-(pred(NumVals));
PutWe(NumNodes);
i:=DcTreeHd;
For k:=0 to pred(NumNodes) do
begin
l:=Node[i].LChild; r:=Node[i].RChild;
if l<NumVals then l:=-(succ(l)) else l:=DcTreeHd-l;
if r<NumVals then r:=-(succ(r)) else r:=DcTreeHd-r;
PutWe(l); { left child } PutWe(r); { right child }
i:=pred(i);
end;
end; { Procedure WriteHeader }
{$A-}
Procedure Adjust(Top, Bottom: integer; Var List: ValType);
Var k, Temp: integer;
{ Compare two trees, if a > b return true, else return false. }
Function CmpTrees(a, b: integer): boolean; {entry with root nodes}
begin
CmpTrees:=false;
If Node[a].Weight>Node[b].Weight then CmpTrees:=true
else
If Node[a].Weight=Node[b].Weight then
If Node[a].TDepth>Node[b].TDepth then CmpTrees:=true;
end; { Function CmpTrees }
begin
k:=succ(2*Top); { left child of top }
Temp:=List[Top]; { remember root node of top tree }
If (k<=Bottom) then
begin
If ( k<Bottom) and (CmpTrees(List[k],List[succ(k)]) ) then k:=succ(k);
{ k indexes "smaller" child (in heap of trees) of top
now make top index "smaller" of old top and smallest child }
If CmpTrees(Temp,List[k]) then
begin
List[Top]:=List[k]; List[k]:=Temp; Adjust(k,Bottom,List);
end;
end;
end; { Procedure Adjust }
{$A+}
{ The count of number of occurrances of each input value have already been
prevented from exceeding MAXCOUNT. Now we must scale them so that their
sum doesn't exceed ceiling and yet no non-zero count can become zero.
This scaling prevents errors in the weights of the interior nodes of the
Huffman tree and also ensures that the codes will fit in an unsigned integer.
Rescaling is used if necessary to limit the code length. }
Procedure Scale(Ceil: integer); { upper limit on total weight }
var i, c, ovflw, divisor: integer;
w, sum: real;
Increased: boolean;
begin
Repeat { Until not Increased }
Sum:=0; OvFlw:=0;
For i:=0 to pred(NumVals) do
begin
If Node[i].Weight>(Ceil-Sum) then OvFlw:=succ(OvFlw);
Sum:=Sum+Node[i].Weight;
end;
Divisor:=succ(Ovflw);
{ Ensure no non-zero values are lost }
Increased:=false;
For i:=0 to pred(NumVals) do
begin
w:=Node[i].Weight;
If (w<Divisor) and (w<>0) then
begin { Don't fail to provide a code if it's used at all }
Node[i].Weight:=Divisor; Increased:=true;
end;
end;
Until not Increased;
{ Scaling factor choosen, now scale }
If Divisor>1 then
For i:=0 to pred(NumVals) do with Node[i] do
Weight:=int((Weight/Divisor)+0.5);
end; { Procedure Scale }
{$A-}
{ Recursive routine to walk the indicated subtree and level
and maintain the current path code in bstree. When a leaf
is found the entire code string and length are put into
the encoding table entry for the leaf's data value.
Returns ERROR if codes are too long. }
Function BuildEnc(Level, Root: integer): integer; {returns error or null}
Var l, r, Return: integer;
begin
Return:=Null;
l:=Node[Root].LChild; r:=Node[Root].RChild;
If (l=NoChild) and (r=NoChild) then
begin {have a leaf}
CodeLen[Root]:=Level;
Code[Root]:=TCode and ($FFFF shr (16-Level));
If Level>16 then Return:=Error else Return:=Null;
end
else
begin
If l<>NoChild then
begin {Clear path bit and go deeper}
TCode:=TCode and not(1 shl Level);
If BuildEnc(succ(Level),l)=Error then Return:=Error;
end;
If r<>NoChild then
begin {Set path bit and go deeper}
TCode:=TCode or (1 shl Level);
If BuildEnc(succ(Level),r)=Error then Return:=Error;
end;
end;
BuildEnc:=Return;
end; { Function BuildEnc }
{$A+}
Procedure BuildTree(Var List: ValType; Len: integer); {Huffman algorithm}
Var FreeNode: integer; {next free node in tree}
LCh, RCh: integer; {temporaries for left, right children}
i: integer;
Function Maximum(a, b: integer): integer;
begin
If a>b then Maximum:=a else Maximum:=b;
end; { Function Maximum }
begin
{ Initialize index to next available (non-leaf) node.
Lower numbered nodes correspond to leaves (data values). }
FreeNode:=NumVals;
{ Take from list two btrees with least weight and build an
interior node pointing to them. This forms a new tree. }
While (Len>1) do
begin
LCh:=List[0]; { This one will be left child }
{ delete top (least) tree from the list of trees }
Len:=pred(Len);
List[0]:=List[Len];
Adjust(0,pred(Len),List);
{ Take new top (least) tree. Reuse list slot later }
RCh:=List[0]; { This one will be right child }
{ Form new tree from the two least trees using a free node as root.
Put the new tree in the list. }
With Node[FreeNode] do
begin
LChild:=LCh; RChild:=RCh;
Weight:=Node[LCh].Weight+Node[RCh].Weight;
TDepth:=succ(Maximum(Node[LCh].TDepth,Node[RCh].TDepth));
end;
List[0]:=FreeNode; {put at top for now}
FreeNode:=succ(FreeNode); {next free node}
{ reheap list to get least tree at top }
Adjust(0,pred(Len),List);
end;
DcTreeHd:=List[0]; { head of final tree }
end; { Procedure BuildTree }
{ Initialize the Huffman translation. This requires reading the input file
through any preceding translation functions to get the frequency
distribution of the various values. }
Procedure InitializeHuffman;
var c, i: integer;
BtList: ValType; { list of intermediate binary trees }
ListLen: integer; { length of btlist }
Ceiling: integer; { limit for scaling }
{ Heap and Adjust maintain a list of binary trees as a heap with the top
indexing the binary tree on the list which has the least weight or,
in case of equal weights, least depth in its longest path. The depth part
is not strictly necessary, but tends to avoid long codes which might
provoke rescaling. }
Procedure Heap(Var List: ValType; l: integer);
Var i, len: integer;
begin
Len:=(l-2) div 2;
For i:=Len DownTo 0 do Adjust(i,pred(l),List);
end; { Procedure Heap }
begin
Write('Pass 1: Analysis,');
Crc:=0; ZeroTree; State:=NoHist; EOFile:=false; EOFlag:=false;
Repeat { Until EOFlag } { Build frequency info in tree }
C:=ord(GetCnr);
If EOFlag then C:=SpEOF;
With Node[C] do
If Weight<MaxCount then Weight:=Weight+1.0;
If EOFlag then Write(' End of file found,');
until (EOFlag);
{ PrintFrequency; }
Ceiling:=MaxCount;
{ Try to build encoding table. Fail if any code is > 16 bits long. }
Repeat { Until BuildEnc(0,DcTreeHd) <> Error }
If (Ceiling<>MaxCount) then Write(' *** rescaling ***,');
Scale(Ceiling);
Ceiling:=Ceiling div 2; {in case we rescale again}
ListLen:=0; {find length of list and build single nodes}
For i:=0 to pred(NumVals) do
If Node[i].Weight>0.0 then
begin
Node[i].TDepth:=0; BtList[listlen]:=i; ListLen:=succ(ListLen);
end;
Heap(BtList,pred(ListLen));
Write(' Building tree');
BuildTree(BtList,ListLen);
For i:=0 to pred(NumVals) do CodeLen[i]:=0;
until (BuildEnc(0,DcTreeHd)<>Error);
{ PrintList;}
{ Initialize encoding variables }
CBitsRem:=0; CurIn:=0;
end; { Procedure InitializeHuffman }
{ Get an encoded byte or EOF. Reads from specified stream AS NEEDED.
There are two unsynchronized bit-byte relationships here:
The input stream bytes are converted to bit strings of various lengths
via the static variables named Cxxxxx. These bit strings are
concatenated without padding to become the stream of encoded result
bytes, which this function returns one at a time. The EOF (end of file)
is converted to SPEOF for convenience and encoded like any other input
value. True EOF is returned after that. }
Function GetHuff: char; {returns byte values except for EOF}
Var RByte: integer; {Result byte value}
Need, Take: integer; {numbers of bits}
Return: integer;
begin
RByte:=0;
Need:=8; {build one byte per call}
Return:=Error; {start off with an error}
{ Loop to build a byte of encoded data.
Initialization forces read the first time}
While Return=Error do
begin
If CBitsRem>=Need then
begin {Current code fullfills our needs}
If need = 0 then Return:=RByte and $00FF
else
begin
RByte:=RByte or (CCode shl (8-Need));
{take what we need}
CCode:=CCode shr Need;
{and leave the rest}
CBitsRem:=CBitsRem-Need;
Return:=RByte and $00FF;
end;
end
else
begin
If CBitsRem>0 then
begin {We need more than current code}
RByte:=RByte or (CCode shl (8-Need));
{take what there is}
Need:=Need-CBitsRem;
end;
If curin=SpEOF then
begin
CBitsRem:=0;
If Need=8 then
begin {end of file}
Done:=true;
Return:=0; {any valid char value}
end
else Return:=RByte and $00FF; {data first}
end
else
begin
CurIn:=ord(GetCnr);
If EOFlag then CurIn:=SpEOF;
CCode:=Code[CurIn];
CBitsRem:=CodeLen[CurIn];
end;
end;
end;
GetHuff:=chr(Return);
end; { Function GetHuff }