|
|
{Unit: Compressor.pas - bitmap compression procedures
}
//---------------------------------------------------------------------
{
Input bitmap shall be passed as parameter to Compr.AitoCompress(bm:TBitmap).
Input bitmap first is decoded, result is in Compr.InStream:TInOutStream
Then bitmap is compressed, result is in Compr.OutStream:TInOutStream
If compression ratio less than 1.1 then set Compr.Compressed=false, and set Compr.SizeOfBuffer=0
If compression ratio >=1.1 then set Compr.Compressed=trie, set/clear Compr.DoubleBuffer flag and specify Compr.SizeOfBuffer
}unit Compressor;
// *********************************************
interface
// *********************************************
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, Menus, ExtCtrls;//-----------------
type TInOutStream=object
Len:integer; // total number of bytes
HiNibble:boolean;
BytesPerRow:integer; // number of bytes per row
NoOfRows:integer; // number of rows in bitmap
Dat:TByteArray;
procedure Clear;
procedure CopyToBmp; //(var bm: TBitmap);
procedure AddByte(b:byte);
procedure AddNibble(nibble:byte);
procedure ReadBmp; //(Bmp:TBitmap);
function GetNibble(nPtr:integer):byte;
procedure InvertDat;
end;//-----------------
type TCompressor=object
Compressed:boolean;
DoubleBuffer:boolean;
SizeOfBuffer:integer;
CompressionRatio:real;
InStream:TInOutStream;
// TmpStream:TInOutStream;
OutStream:TInOutStream;
BmpWidth:integer;
BmpHeight:integer;
BufLen:integer;
Buf:TByteArray; // linear buffer
procedure Reset;
procedure ReadBmp; //(bm: TBitmap);
function NoOfNibblesForRLE(nPtr:integer):integer;
function NoOfNibblesForVOC(nPtr:integer; blen:integer):integer;
procedure CompressBmp(bufsize:integer);
procedure AutoCompress(invert:boolean);
end;//-----------------
function ByteToHexStr(b:byte):string;
//-----------------
var Compr:TCompressor;// *********************************************
implementation
// *********************************************
uses Main;
// *********************************************
function NibbleToHexChar(b:byte):char;
begin
if (b and $F)<10 then
result:=char($30+(b and $F))
else
result:=char(ord('A')+(b and $F)-10);
end;// ----------------------------------------------
function ByteToHexStr(b:byte):string;
begin
result:=''+NibbleToHexChar(b shr 4)+NibbleToHexChar(b);
end;
// *********************************************
// TInOutStream
// *********************************************
procedure TInOutStream.Clear;
begin
Len:=0; BytesPerRow:=0; NoOfRows:=0; HiNibble:=true;
end;// ----------------------------------------------
procedure TInOutStream.ReadBmp; //(Bmp: TBitmap);
var X,Y,i,resid:integer;
P : PByteArray;
fits:boolean;
b:byte;
begin
Clear;
with Form1.Image1.Picture do begin
if Bitmap.Width>0 then begin
if Bitmap.Height>0 then begin
if Bitmap.Monochrome then begin
BytesPerRow:=(Bitmap.width div 8);
resid:=0;
if 8*BytesPerRow<>Bitmap.width then begin
fits:=false;
inc(BytesPerRow);
resid:=8*BytesPerRow-Bitmap.width;
end else fits:=true;
NoOfRows:=Bitmap.Height;
for y:=0 to Bitmap.Height-1 do begin
P:= Bitmap.ScanLine[y];
for x:=0 to BytesPerRow-1 do begin
// b:=not p^[x];
b:= p^[x];
if not fits and (x=BytesPerRow-1) then begin
b:=b shr resid;
for i:=0 to resid-1 do begin
b :=b shl 1;
if (b and 2)<>0 then b:=b or 1;
end;
end;
dat[BytesPerRow*y+x]:=b;
inc(Len);
end;
end;
end;
end;
end;
end;
end;// ----------------------------------------------
procedure TInOutStream.InvertDat;
var i:integer;
begin
for i:=0 to Len do
dat[i]:=not dat[i];
end;
// ----------------------------------------------
procedure TInOutStream.CopyToBmp; //(var bm: TBitmap);
var i,x,y:integer;
P : PByteArray; // Points to variables of type ByteArray
begin
with Form1.Image1.Picture do begin
Bitmap.Monochrome:=true;
Bitmap.PixelFormat:=pf1bit;
Bitmap.Canvas.Pen.Color:=clBlack;
if BytesPerRow>0 then
Bitmap.Width:=BytesPerRow*8
else Bitmap.Width:=32;
if BytesPerRow>0 then begin
Bitmap.Height:= ((Len-1) div BytesPerRow)+1;
if Bitmap.Height>NoOfRows then Bitmap.Height:=NoOfRows;
end else Bitmap.Height:=10;
i:=0;
for y:=0 to Bitmap.Height-1 do begin
P:= Bitmap.ScanLine[y];
for x:=0 to (Bitmap.Width div 8)-1 do begin
P^[x]:=dat[i];
inc(i);
end;
end;
end;
end;// ----------------------------------------------
procedure TInOutStream.AddByte(b: byte);
begin
Dat[Len]:=b; inc(Len);
end;// ----------------------------------------------
procedure TInOutStream.AddNibble(nibble: byte); // hi nibble first
begin
if HiNibble then begin
Dat[Len]:=nibble shl 4;
end else begin
Dat[Len]:=(Dat[Len] and $F0) or (nibble and $0F);
inc(Len);
end;
HiNibble:=not HiNibble;
end;// ----------------------------------------------
function TInOutStream.GetNibble(nPtr: integer): byte;
begin
result:=0;
if nPtr<=2*Len-1 then begin
if (nPtr and 1)=0 then // hi nibble
result:=Dat[nPtr div 2] shr 4
else // lo nibble
result:=Dat[nPtr div 2] and $F;
end;
end;// *********************************************
{ TCompressor }
// *********************************************
procedure TCompressor.Reset;
begin
InStream.Clear; OutStream.Clear;
end;// ----------------------------------------------
procedure TCompressor.ReadBmp; //(bm: TBitmap);
begin
Reset;
InStream.ReadBmp; //(Form1.Image1.Picture.Bitmap);
BmpWidth:=Form1.Image1.Picture.Bitmap.Width;
BmpHeight:=Form1.Image1.Picture.Bitmap.Height;
end;// ----------------------------------------------
function TCompressor.NoOfNibblesForRLE(nPtr: integer): integer;
// number of equal nibbles in InStream starting from ponter nPtr
var val:byte;
cnt,i:integer;
begin
cnt:=1;
val:=InStream.GetNibble(nPtr);
for i:=1 to 256 do begin
if (nPtr+i)>2*(InStream.Len-1) then
break // BMP completed
else begin
if InStream.GetNibble(nPtr+i)=val then
inc(cnt)
else
break;
end;
end;
result:=cnt;
end;// ----------------------------------------------
function TCompressor.NoOfNibblesForVOC(nPtr: integer; blen:integer): integer;
// starting from ponter nPtr, number of nibbles in InStream that
// are equal to nibbles in previous row
var val:byte;
offset,cnt,i:integer;
begin
cnt:=0; offset:=2*blen;
if nPtr>=offset then begin // VOC exists
for i:=0 to 255 do begin
if (nPtr+i)>2*InStream.Len then
break // BMP completed
else begin
val:=InStream.GetNibble(nPtr+i);
if val=InStream.GetNibble(nPtr+i-offset) then begin
inc(cnt);
end else
break;
end;
end;
end;
if cnt=255 then
result:=-1 // 256 nibbles
else begin
if cnt>$7F then cnt:=$7F;
result:=cnt;
end;
end;// ----------------------------------------------
procedure TCompressor.CompressBmp(bufsize:integer);
var RLE,VOC:integer;
i,p:longint;
val,res,b:byte;
begin
OutStream.Clear;
// TmpStream.Clear;
OutStream.BytesPerRow:=InStream.BytesPerRow;
OutStream.NoOfRows:=InStream.NoOfRows;
i:=0;
while i<=2*InStream.Len-1 do begin // for each nibble
val:=InStream.GetNibble(i);
RLE:=NoOfNibblesForRLE(i);
VOC:=NoOfNibblesForVOC(i,bufsize);
if VOC=-1 then RLE:=-2; // full row, do not use RLE
if RLE>=VOC then begin // VOC is preferred
if VOC>16 then RLE:=0;
if (VOC in [8..15]) then RLE:=0;
end;
if RLE>=VOC then begin
if RLE>=16 then begin
res:=$80 or val; // counter=0, eg 16 nibbles
// for p:=i to i+15 do begin
// b:=InStream.GetNibble(p);
// end;
i:=i+16;
end else begin
if RLE>7 then RLE:=7; // range 1...7
res:=$80 or (RLE shl 4) or val;
// for p:=i to i+RLE-1 do begin
// b:=InStream.GetNibble(p);
// end;
i:=i+RLE;
end;
end else begin
if VOC=-1 then begin // 256 nibbles
res:=0;
// for p:=i to i+255 do begin
// b:=InStream.GetNibble(p);
// end;
i:=i+2*InStream.BytesPerRow;
end else begin
res:=VOC and $7F;
// for p:=i to i+VOC-1 do begin
// b:=InStream.GetNibble(p);
// end;
i:=i+res;
end;
end;
OutStream.AddByte(res);
// TmpStream.AddByte(res);
end;
end;
// ----------------------------------------------
// try to compress bitmap with double or single buffer
// if compression ratio less than 1.1 then mark as not Compressed, and set SizeOfBuffer=0
// if compression ratio >=1.1 then mark as Compressed, set/clear DoubleBuffer flag and specify SizeOfBuffer
procedure TCompressor.AutoCompress(invert:boolean);
var r:real;
bufsize,bufsize2:integer;
begin
ReadBmp;
if invert then InStream.InvertDat;
InStream.CopyToBmp;bufsize:=((Form1.Image1.Picture.Bitmap.Width +7) div 8);
bufsize2:=bufsize*2;
// -----------
// compress
// -----------
CompressBmp(bufsize);
r := InStream.Len/OutStream.Len;
// ----------------------------------
// try to compress with double buffer
// ----------------------------------
CompressBmp(bufsize2);
// ---------------
// select the best
// ---------------
if r >= InStream.Len/OutStream.Len then begin
DoubleBuffer:=false;
CompressBmp(bufsize); // restore
SizeOfBuffer:=bufsize;
end else begin
DoubleBuffer:=true;
SizeOfBuffer:=bufsize2;
end;
// -----------------------
// select most appropriate
// -----------------------
r := InStream.Len/OutStream.Len;
if r<1.05 then begin
Compressed:=false;
CompressionRatio := 1;
SizeOfBuffer:=0;
end else begin
Compressed:=true;
CompressionRatio := r;
end;
end;
end.
E-mail: 
info@telesys.ru
