dxtccompression.pas

Well known and usefull component for delphi 7

      Low:=2*Low;
      High:=2*High+1;
   until 0<>0;
end;

procedure DoneEncoding;
begin
   Inc(BitsToFollow);
   if (Low<FIrstQrtr) then
      BitPlusFollow(0)
   else
      BitPlusFollow(1);
end;

procedure DoneOutputingBits;
begin
   BitBuffer:=BitBuffer shr BitsToGo;
   StoreByte(BitBuffer);
   ByteCnt:=ByteCnt+1;
end;

procedure Compress(F:string);
const
   HdrLen=32;
   Blanks='                        ';
var
   OName:string;
   FSize:string;
   Header:string;
   I:Byte;
begin
   Assign(IFile, F);
   Reset(IFile, 1);
   if Pos('.', F)>0 then
      OName:=Copy(F, 1, Pos('.', F))+'TCC'
   else
      OName:=F+'.TCC';
   Assign(OFile, OName);
   Rewrite(OFile, 1);
   FillInputBuf;
   OutBufPos:=1;
   StoreByte(Ord('A'));
   Write('Compressing: ', F);
   StartOutPutingBits;
   StartEncoding;
   Str(FileSize(IFile), FSize);
   Header:=F+'|'+FSize;
   Header:=Header+Copy(Blanks, 1, HdrLen-Length(Header));
   for I:=1 to Length(Header) do begin
      Symbol:=CharToIndex[Ord(Header[I])];
      EncodeSymbol(Symbol);
      UpdateModel(Symbol);
   end;
   repeat
      Bite:=GetByte;
      OrigFileSize:=OrigFileSize+1;
      if not EOFile then begin
         Symbol:=CharToIndex[Bite];
         EncodeSymbol(Symbol);
         UpdateModel(Symbol);
      end;
   until EOFile;
   EncodeSymbol(EOFSymbol);
   Inc(BitsToFollow);
   if (Low<FIrstQrtr) then
      BitPlusFollow(0)
   else
      BitPlusFollow(1);
   BitBuffer:=BitBuffer shr BitsToGo;
   StoreByte(BitBuffer);
   ByteCnt:=ByteCnt+1;
   WriteOutBuf;
   Close(IFile);
   Close(OFile);
   Writeln(' (', ((ByteCnt/OrigFileSize)*100):4:2, '%) done.');
end;

function DecodeSymbol:Word;
var
   Range:Longint;
   Cum:Word;
   Sym:Word;
   Done:Boolean;
begin
   Range:=Longint((High-Low)+1);
   Cum:=(((Value-Low)+1)*CumFreq[0]-1)div Range;
   Sym:=1;
   Done:=False;
   while CumFreq[Sym]>Cum do
      Inc(Sym);
   High:=Low+(Range*CumFreq[Sym-1])div CumFreq[0]-1;
   Low:=Low+(Range*CumFreq[Sym])div CumFreq[0];
   repeat
      if High<Half then
      else if (Low>=Half) then begin
         Value:=Value-Half;
         Low:=Low-Half;
         High:=High-Half;
      end
      else if (Low>=FirstQrtr)and(High<ThirdQrtr) then begin
         Value:=Value-FirstQrtr;
         Low:=Low-FirstQrtr;
         High:=High-FirstQrtr;
      end
      else
         Done:=True;
      if not Done then begin
         Low:=2*Low;
         High:=2*High+1;
         Value:=2*Value+InputBit;
      end;
   until Done;
   DecodeSymbol:=Sym;
end;

procedure Decompress(F:string);
begin
   Assign(IFile, F);
   Reset(IFile, 1);
   FillInputBuf;
   HdrCnt:=1;
   BitsToGo:=0;
   GarbageBits:=0;
   ByteCnt:=0;
   StartDecoding;
   repeat
      Symbol:=DecodeSymbol;
      if Symbol<>EOFSymbol then begin
         Ch:=IndexToChar[Symbol];
         if HdrCnt<HdrLen then begin
            Header[HdrCnt]:=Chr(Ch);
            Inc(HdrCnt);
         end
         else if HdrCnt=HdrLen then begin
            Header[0]:=Chr(HdrLen);
            OutFileName:=Copy(Header, 1, Pos('|', Header)-1);
            Assign(OFile, OutFileName);
            Rewrite(OFile, 1);
            Writeln('Decompressing: ', OutFileName);
            Inc(HdrCnt);
         end
         else
            StoreByte(Ch);
         UpdateModel(Symbol);
      end;
   until EOFile;
   WriteOutBuf;
   Close(OFile);
   Close(IFile);
end;

{$IFDEF OBJECTS_ONLY}

constructor TDXTCCompression.Create;
{$ELSE}

constructor TDXTCCompression.Create(AOwner:TComponent); override;
{$ENDIF}
begin
end;

destructor TDXTCCompression.Destroy; override;
begin
end;

procedure Compress(inPtr, OutPtr:Pointer);
const
   HdrLen=32;
   Blanks='                        ';

var
   TopValue, FirstQrtr, Half, ThirdQrtr:Longint;

   function Initialize:Boolean;
   var
      I:Integer;

   begin
      Result:=True;
      for I:=0 to NumOfChars-1 do begin
         CharToIndex[I]:=I+1;
         IndexToChar[I+1]:=I;
      end;
      if not Adaptive then begin
         CumFreq[NumOfSyms]:=0;
         for I:=NumOfSyms downto 1 do
            CumFreq[I-1]:=CumFreq[I]+FreqTable[I];
         if CumFreq[0]>MaxFreq then begin
            Result:=False;
            Exit;
         end;
      end
      else begin
         for I:=0 to NumOfSyms do begin
            FreqTable[I]:=1;
            CumFreq[I]:=NumOfSyms-I;
         end;
         FreqTable[0]:=0;
      end;
   end;

begin
   TopValue:=$FFFE;
   FirstQrtr:=(TopValue div 4)+1;
   Half:=2*FirstQrtr;
   ThirdQrtr:=3*FirstQrtr;
   Adaptive:=True;
   New(InBufPtr);
   New(OutBufPtr);
   EOFile:=False;
   if not Initialize then begin
      Adapative:=False;
      Initialize;
   end;
   OutBufPos:=1;
   StoreByte(Ord('A'));
   StartOutPutingBits;
   StartEncoding;
   Str(FileSize(IFile), FSize);
   Header:=F+'|'+FSize;
   Header:=Header+Copy(Blanks, 1, HdrLen-Length(Header));
   for I:=1 to Length(Header) do begin
      Symbol:=CharToIndex[Ord(Header[I])];
      EncodeSymbol(Symbol);
      UpdateModel(Symbol);
   end;
   repeat
      Bite:=GetByte;
      OrigFileSize:=OrigFileSize+1;
      if not EOFile then begin
         Symbol:=CharToIndex[Bite];
         EncodeSymbol(Symbol);
         UpdateModel(Symbol);
      end;
   until EOFile;
   EncodeSymbol(EOFSymbol);
   Inc(BitsToFollow);
   if (Low<FIrstQrtr) then
      BitPlusFollow(0)
   else
      BitPlusFollow(1);
   BitBuffer:=BitBuffer shr BitsToGo;
   StoreByte(BitBuffer);
   ByteCnt:=ByteCnt+1;
end;

procedure TDXTCCompression.CompressStreams(inStream, OutStream:TStream);
begin
end;

procedure TDXTCCompression.DecompressStreams(inStream, OutStream:TStream);
begin
end;

procedure TDXTCCompression.CompressString(var inStr, OutStr:string);
begin
end;

procedure TDXTCCompression.DecompressString(var inStr, OutStr:string);
begin
end;

procedure TDXTCCompression.CompressWindowsFileToFile(var infile,
   outfile:Integer);
begin
end;

procedure TDXTCCompression.DecompressWindowsFileToFile(var infile,
   outfile:Integer);
begin
end;

procedure TDXTCCompression.CompressBorlandFileToFile(var infile, outfile:file);
begin
end;

procedure TDXTCCompression.DecompressBorlandFileToFile(var infile,
   outfile:file);
begin
end;

begin
   if not Decompression then begin
      LoadFiles;
      FP:=FileListHead;
      repeat
         SetCompressor;
         Compress(FP^.Name);
         FP:=FP^.Next;
      until FP=nil;
   end
   else begin
      LoadFiles;
      FP:=FileListHead;
      repeat
         SetDecompressor;
         Decompress(FP^.Name);
         FP:=FP^.Next;
      until FP=nil;
   end;
end.