paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-22 07:09:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patches from Giulio BERNA

Browse Source 
- BMP Reader enhanced to full Microsoft specs:
    + support for 15,16 bit bitmaps. 
    + support for strange color masks at 16, 32 bpp
    + rle4 and rle8 decoding
    + top-down stored bitmaps.
    + Palette behaviour changed: use palette at 1,4,8 bits.
    + Support for OnProgress
  - BMP Writer support:
    + BitsPerPixel property.
    + Writing at all color depths.
    + RLE8 and RLE4 compression.
  - Functions to create standard palettes:
    CreateBlackAndWhitePalette
    CreateWebSafePalette 
    CreateGrayScalePalette
    CreateVGAPalette

git-svn-id: trunk@987 -
This commit is contained in:
michael 2005-08-30 19:26:31 +00:00
parent aa671b8819
commit 9fe7ee0b81
6 changed files with 1070 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
fcl/image/bmpcomn.pp
View File

@ -21,6 +21,15 @@ interface
const
{BMP magic word is always 19778 : 'BM'}
BMmagic=19778;
{ Values for Compression field }
BI_RGB = 0;
BI_RLE8 = 1;
BI_RLE4 = 2;
BI_BITFIELDS = 3;
BI_JPEG = 4;
BI_PNG = 5;
type
TBitMapFileHeader = packed record
@ -30,7 +39,7 @@ type
bfSize:longint;
{06+04 : Reserved}
bfReserved:longint;
{10+04 : Offset of image data : size if the file hieder + the info header}
{10+04 : Offset of image data : size if the file hieder + the info header + palette}
bfOffset:longint;
end;
PBitMapFileHeader = ^TBitMapFileHeader;
@ -44,17 +53,17 @@ type
Height:longint;
{26+02 : Number of image planes : should be 1 always}
Planes:word;
{28+02 : Color resolution : Number of bits per pixel (1,4,8,24)}
{28+02 : Color resolution : Number of bits per pixel (1,4,8,16,24,32)}
BitCount:word;
{30+04 : Compression Type}
Compression:longint;
{34+04 : Size of compressed image : should be 0 if no compression}
{34+04 : Size of image data (not headers nor palette): can be 0 if no compression}
SizeImage:longint;
{38+04 : Horizontal resolution in pixel/meter}
XPelsPerMeter:Longint;
{42+04 : Vertical resolution in pixel/meter}
YPelsPerMeter:Longint;
{46+04 : Number of coros used}
{46+04 : Number of colors used}
ClrUsed:longint;
{50+04 : Number of imprtant colors used : usefull for displaying on VGA256}
ClrImportant:longint;

5
fcl/image/fpimage.pp
View File

@ -332,6 +332,11 @@ const
GCM_Mathematical : TGrayConvMatrix = (red:0.334; green:0.333; blue:0.333);
GCM_Photoshop : TGrayConvMatrix = (red:0.213; green:0.715; blue:0.072);
function CreateBlackAndWhitePalette : TFPPalette;
function CreateWebSafePalette : TFPPalette;
function CreateGrayScalePalette : TFPPalette;
function CreateVGAPalette : TFPPalette;
implementation
procedure FPImgError (Fmt:TErrorTextIndices; data : array of const);

91
fcl/image/fppalette.inc
View File

@ -148,3 +148,94 @@ procedure TFPPalette.Clear;
begin
SetCount (0);
end;
{ Functions to create standard palettes, by Giulio Bernardi 2005 }
{ A simple 1 bit black and white palette }
function CreateBlackAndWhitePalette : TFPPalette;
var fppal : TFPPalette;
Col : TFPColor;
begin
fppal:=TFPPalette.Create(2);
Col.Alpha:=AlphaOpaque;
Col.Red:=$FFFF; Col.Green:=$FFFF; Col.Blue:=$FFFF;
fppal.Color[0]:=Col;
Col.Red:=$0000; Col.Green:=$0000; Col.Blue:=$0000;
fppal.Color[1]:=Col;
Result:=fppal;
end;
{ The "standard" netscape 216-color palette (aka: web safe palette) }
function CreateWebSafePalette : TFPPalette;
var Col : TFPColor;
i : integer;
fppal : TFPPalette;
begin
fppal:=TFPPalette.Create(216);
Col.Alpha:=AlphaOpaque;
i:=0;
Col.Red:=$FFFF;
while true do
begin
Col.Green:=$FFFF;
while true do
begin
Col.Blue:=$FFFF;
while true do
begin
fppal.Color[i]:=Col;
if Col.Blue=0 then break;
dec(Col.Blue,$3333);
end;
if Col.Green=0 then break;
dec(Col.Green,$3333);
end;
if Col.Red=0 then break;
dec(Col.Red,$3333);
end;
Result:=fppal;
end;
{ A grayscale palette. Not very useful. }
function CreateGrayScalePalette : TFPPalette;
var Col : TFPColor;
i : integer;
fppal : TFPPalette;
begin
fppal:=TFPPalette.Create(256);
Col.Alpha:=AlphaOpaque;
for i:=$FF downto 0 do
begin
Col.Red:=i;
Col.Red:=(Col.Red shl 8) + Col.Red;
Col.Green:=Col.Red;
Col.Blue:=Col.Red;
fppal.Color[i]:=Col;
end;
Result:=fppal;
end;
{ Standard VGA 16 color palette. }
function CreateVGAPalette : TFPPalette;
var fppal : TFPPalette;
begin
fppal:=TFPPalette.Create(16);
fppal.Color[0]:=colBlack;
fppal.Color[1]:=colNavy;
fppal.Color[2]:=colBlue;
fppal.Color[3]:=colMaroon;
fppal.Color[4]:=colPurple;
fppal.Color[5]:=colDkGreen;
fppal.Color[6]:=colRed;
fppal.Color[7]:=colTeal;
fppal.Color[8]:=colFuchsia;
fppal.Color[9]:=colOlive;
fppal.Color[10]:=colGray;
fppal.Color[11]:=colLime;
fppal.Color[12]:=colAqua;
fppal.Color[13]:=colSilver;
fppal.Color[14]:=colYellow;
fppal.Color[15]:=colWhite;
Result:=fppal;
end;

375
fcl/image/fpreadbmp.pp
View File

@ -3,7 +3,7 @@
This file is part of the Free Pascal's "Free Components Library".
Copyright (c) 2003 by Mazen NEIFER of the Free Pascal development team
BMP writer implementation.
BMP reader implementation.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -13,6 +13,12 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}
{*****************************************************************************}
{ 08/2005 by Giulio Bernardi:
- Added support for 16 and 15 bpp bitmaps.
- If we have bpp <= 8 make an indexed image instead of converting it to RGB
- Support for RLE4 and RLE8 decoding
- Support for top-down bitmaps
}
{$mode objfpc}
{$h+}
@ -27,14 +33,27 @@ type
TFPReaderBMP = class (TFPCustomImageReader)
Private
Procedure FreeBufs; // Free (and nil) buffers.
DeltaX, DeltaY : integer; // Used for the never-used delta option in RLE
TopDown : boolean; // If set, bitmap is stored top down instead of bottom up
continue : boolean; // needed for onprogress event
percent : byte;
percentinterval : longword;
percentacc : longword;
Rect : TRect;
protected
ReadSize : Integer; // Size (in bytes) of 1 scanline.
BFI : TBitMapInfoHeader; // The header as read from the stream.
FPalette : PFPcolor; // Buffer with Palette entries.
LineBuf : PByte; // Buffer for 1 scanline. Can be Byte, TColorRGB or TColorRGBA
FPalette : PFPcolor; // Buffer with Palette entries. (useless now)
LineBuf : PByte; // Buffer for 1 scanline. Can be Byte, Word, TColorRGB or TColorRGBA
RedMask, GreenMask, BlueMask : longword; //Used if Compression=bi_bitfields
RedShift, GreenShift, BlueShift : shortint;
// SetupRead will allocate the needed buffers, and read the colormap if needed.
procedure SetupRead(nPalette, nRowBits: Integer; Stream : TStream); virtual;
function CountBits(Value : byte) : shortint;
function ShiftCount(Mask : longword) : shortint;
function ExpandColor(value : longword) : TFPColor;
procedure ExpandRLE8ScanLine(Row : Integer; Stream : TStream);
procedure ExpandRLE4ScanLine(Row : Integer; Stream : TStream);
procedure ReadScanLine(Row : Integer; Stream : TStream); virtual;
procedure WriteScanLine(Row : Integer; Img : TFPCustomImage); virtual;
// required by TFPCustomImageReader
@ -101,6 +120,63 @@ begin
end;
end;
{ Counts how many bits are set }
function TFPReaderBMP.CountBits(Value : byte) : shortint;
var i,bits : shortint;
begin
bits:=0;
for i:=0 to 7 do
begin
if (value mod 2)<>0 then inc(bits);
value:=value shr 1;
end;
Result:=bits;
end;
{ If compression is bi_bitfields, there could be arbitrary masks for colors.
Although this is not compatible with windows9x it's better to know how to read these bitmaps
We must determine how to switch the value once masked
Example: 0000 0111 1110 0000, if we shr 5 we have 00XX XXXX for the color, but these bits must be the
highest in the color, so we must shr (5-(8-6))=3, and we have XXXX XX00.
A negative value means "shift left" }
function TFPReaderBMP.ShiftCount(Mask : longword) : shortint;
var tmp : shortint;
begin
tmp:=0;
if Mask=0 then
begin
Result:=0;
exit;
end;
while (Mask mod 2)=0 do { rightmost bit is 0 }
begin
inc(tmp);
Mask:= Mask shr 1;
end;
tmp:=tmp-(8-CountBits(Mask and $FF));
Result:=tmp;
end;
function TFPReaderBMP.ExpandColor(value : longword) : TFPColor;
var tmpr, tmpg, tmpb : longword;
col : TColorRGB;
begin
{$IFDEF ENDIAN_BIG}
value:=swap(value);
{$ENDIF}
tmpr:=value and RedMask;
tmpg:=value and GreenMask;
tmpb:=value and BlueMask;
if RedShift < 0 then col.R:=byte(tmpr shl (-RedShift))
else col.R:=byte(tmpr shr RedShift);
if GreenShift < 0 then col.G:=byte(tmpg shl (-GreenShift))
else col.G:=byte(tmpg shr GreenShift);
if BlueShift < 0 then col.B:=byte(tmpb shl (-BlueShift))
else col.B:=byte(tmpb shr BlueShift);
Result:=RGBToFPColor(col);
end;
procedure TFPReaderBMP.SetupRead(nPalette, nRowBits: Integer; Stream : TStream);
var
@ -108,7 +184,27 @@ var
i: Integer;
begin
if nPalette>0 then
if ((BFI.Compression=BI_RGB) and (BFI.BitCount=16)) then { 5 bits per channel, fixed mask }
begin
RedMask:=$7C00; RedShift:=7;
GreenMask:=$03E0; GreenShift:=2;
BlueMask:=$001F; BlueShift:=-3;
end
else if ((BFI.Compression=BI_BITFIELDS) and (BFI.BitCount in [16,32])) then { arbitrary mask }
begin
Stream.Read(RedMask,4);
Stream.Read(GreenMask,4);
Stream.Read(BlueMask,4);
{$IFDEF ENDIAN_BIG}
RedMask:=swap(RedMask);
GreenMask:=swap(GreenMask);
BlueMask:=swap(BlueMask);
{$ENDIF}
RedShift:=ShiftCount(RedMask);
GreenShift:=ShiftCount(GreenMask);
BlueShift:=ShiftCount(BlueMask);
end
else if nPalette>0 then
begin
GetMem(FPalette, nPalette*SizeOf(TFPColor));
SetLength(ColInfo, nPalette);
@ -128,9 +224,13 @@ end;
procedure TFPReaderBMP.InternalRead(Stream:TStream; Img:TFPCustomImage);
Var
Row : Integer;
Row, i, pallen : Integer;
BadCompression : boolean;
begin
Rect.Left:=0; Rect.Top:=0; Rect.Right:=0; Rect.Bottom:=0;
continue:=true;
Progress(psStarting,0,false,Rect,'',continue);
if not continue then exit;
Stream.Read(BFI,SizeOf(BFI));
{$IFDEF ENDIAN_BIG}
SwapBMPInfoHeader(BFI);
@ -138,44 +238,225 @@ begin
{ This will move past any junk after the BFI header }
Stream.Position:=Stream.Position-SizeOf(BFI)+BFI.Size;
with BFI do
begin
BadCompression:=false;
if ((Compression=BI_RLE4) and (BitCount<>4)) then BadCompression:=true;
if ((Compression=BI_RLE8) and (BitCount<>8)) then BadCompression:=true;
if ((Compression=BI_BITFIELDS) and (not (BitCount in [16,32]))) then BadCompression:=true;
if not (Compression in [BI_RGB..BI_BITFIELDS]) then BadCompression:=true;
if BadCompression then
raise FPImageException.Create('Bad BMP compression mode');
TopDown:=(Height<0);
Height:=abs(Height);
if (TopDown and (not (Compression in [BI_RGB,BI_BITFIELDS]))) then
raise FPImageException.Create('Top-down bitmaps cannot be compressed');
Img.SetSize(0,0);
if BitCount<=8 then
begin
if (Compression<>0) then
Raise FPImageException.Create('Compressed bitmaps not supported');
Img.Width:=Width;
Img.Height:=Height;
Img.UsePalette:=true;
Img.Palette.Clear;
end
else Img.UsePalette:=false;
Case BFI.BitCount of
1 : { Monochrome }
SetupRead(2,Width,Stream);
4 :
SetupRead(16,Width*4,Stream);
8 :
SetupRead(256,Width*8,Stream);
16 :
SetupRead(0,Width*8*2,Stream);
24:
SetupRead(0,Width*8*3,Stream);
32:
SetupRead(0,Width*8*4,Stream);
end;
Case BFI.BitCount of
1 : { Monochrome }
SetupRead(2,Img.Width,Stream);
4 :
SetupRead(16,Img.Width*4,Stream);
8 :
SetupRead(256,Img.Width*8,Stream);
16 :
Raise FPImageException.Create('16 bpp bitmaps not supported');
24:
SetupRead(0,Img.Width*8*3,Stream);
32:
SetupRead(0,Img.Width*8*4,Stream);
end;
Try
for Row:=Img.Height-1 downto 0 do
begin
ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize.
WriteScanLine(Row,Img);
end;
{ Note: it would be better to Fill the image palette in setupread instead of creating FPalette.
FPalette is indeed useless but we cannot remove it since it's not private :\ }
pallen:=0;
if BFI.BitCount<=8 then
if BFI.ClrUsed>0 then pallen:=BFI.ClrUsed
else pallen:=(1 shl BFI.BitCount);
if pallen>0 then
begin
Img.Palette.Count:=pallen;
for i:=0 to pallen-1 do
Img.Palette.Color[i]:=FPalette[i];
end;
Img.SetSize(BFI.Width,BFI.Height);
percent:=0;
percentinterval:=(Img.Height*4) div 100;
if percentinterval=0 then percentinterval:=$FFFFFFFF;
percentacc:=0;
DeltaX:=-1; DeltaY:=-1;
if TopDown then
for Row:=0 to Img.Height-1 do { A rare case of top-down bitmap! }
begin
ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize.
WriteScanLine(Row,Img);
if not continue then exit;
end
else
for Row:=Img.Height-1 downto 0 do
begin
ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize.
WriteScanLine(Row,Img);
if not continue then exit;
end;
Progress(psEnding,100,false,Rect,'',continue);
finally
FreeBufs;
end;
end;
procedure TFPReaderBMP.ReadScanLine(Row : Integer; Stream : TStream);
procedure TFPReaderBMP.ExpandRLE8ScanLine(Row : Integer; Stream : TStream);
var i,j : integer;
b0, b1 : byte;
begin
{
Add here support for compressed lines. The 'readsize' is the same in the end.
}
Stream.Read(LineBuf[0],ReadSize);
i:=0;
while true do
begin
{ let's see if we must skip pixels because of delta... }
if DeltaY<>-1 then
begin
if Row=DeltaY then j:=DeltaX { If we are on the same line, skip till DeltaX }
else j:=ReadSize; { else skip up to the end of this line }
while (i<j) do
begin
LineBuf[i]:=0;
inc(i);
end;
if Row=DeltaY then { we don't need delta anymore }
DeltaY:=-1
else break; { skipping must continue on the next line, we are finished here }
end;
Stream.Read(b0,1); Stream.Read(b1,1);
if b0<>0 then { number of repetitions }
begin
if b0+i>ReadSize then
raise FPImageException.Create('Bad BMP RLE chunk at row '+inttostr(row)+', col '+inttostr(i)+', file offset $'+inttohex(Stream.Position,16) );
j:=i+b0;
while (i<j) do
begin
LineBuf[i]:=b1;
inc(i);
end;
end
else
case b1 of
0: break; { end of line }
1: break; { end of file }
2: begin { Next pixel position. Skipped pixels should be left untouched, but we set them to zero }
Stream.Read(b0,1); Stream.Read(b1,1);
DeltaX:=i+b0; DeltaY:=Row+b1;
end
else begin { absolute mode }
if b1+i>ReadSize then
raise FPImageException.Create('Bad BMP RLE chunk at row '+inttostr(row)+', col '+inttostr(i)+', file offset $'+inttohex(Stream.Position,16) );
Stream.Read(LineBuf[i],b1);
inc(i,b1);
{ aligned on 2 bytes boundary: every group starts on a 2 bytes boundary, but absolute group
could end on odd address if there is a odd number of elements, so we pad it }
if (b1 mod 2)<>0 then Stream.Seek(1,soFromCurrent);
end;
end;
end;
end;
procedure TFPReaderBMP.ExpandRLE4ScanLine(Row : Integer; Stream : TStream);
var i,j,tmpsize : integer;
b0, b1 : byte;
nibline : pbyte; { temporary array of nibbles }
even : boolean;
begin
tmpsize:=ReadSize*2; { ReadSize is in bytes, while nibline is made of nibbles, so it's 2*readsize long }
getmem(nibline,tmpsize);
if nibline=nil then
raise FPImageException.Create('Out of memory');
try
i:=0;
while true do
begin
{ let's see if we must skip pixels because of delta... }
if DeltaY<>-1 then
begin
if Row=DeltaY then j:=DeltaX { If we are on the same line, skip till DeltaX }
else j:=tmpsize; { else skip up to the end of this line }
while (i<j) do
begin
NibLine[i]:=0;
inc(i);
end;
if Row=DeltaY then { we don't need delta anymore }
DeltaY:=-1
else break; { skipping must continue on the next line, we are finished here }
end;
Stream.Read(b0,1); Stream.Read(b1,1);
if b0<>0 then { number of repetitions }
begin
if b0+i>tmpsize then
raise FPImageException.Create('Bad BMP RLE chunk at row '+inttostr(row)+', col '+inttostr(i)+', file offset $'+inttohex(Stream.Position,16) );
even:=true;
j:=i+b0;
while (i<j) do
begin
if even then NibLine[i]:=(b1 and $F0) shr 4
else NibLine[i]:=b1 and $0F;
inc(i);
even:=not even;
end;
end
else
case b1 of
0: break; { end of line }
1: break; { end of file }
2: begin { Next pixel position. Skipped pixels should be left untouched, but we set them to zero }
Stream.Read(b0,1); Stream.Read(b1,1);
DeltaX:=i+b0; DeltaY:=Row+b1;
end
else begin { absolute mode }
if b1+i>tmpsize then
raise FPImageException.Create('Bad BMP RLE chunk at row '+inttostr(row)+', col '+inttostr(i)+', file offset $'+inttohex(Stream.Position,16) );
j:=i+b1;
even:=true;
while (i<j) do
begin
if even then
begin
Stream.Read(b0,1);
NibLine[i]:=(b0 and $F0) shr 4;
end
else NibLine[i]:=b0 and $0F;
inc(i);
even:=not even;
end;
{ aligned on 2 bytes boundary: see rle8 for details }
b1:=b1+(b1 mod 2);
if (b1 mod 4)<>0 then Stream.Seek(1,soFromCurrent);
end;
end;
end;
{ pack the nibline into the linebuf }
for i:=0 to ReadSize-1 do
LineBuf[i]:=(NibLine[i*2] shl 4) or NibLine[i*2+1];
finally
FreeMem(nibline)
end;
end;
procedure TFPReaderBMP.ReadScanLine(Row : Integer; Stream : TStream);
begin
if BFI.Compression=BI_RLE8 then ExpandRLE8ScanLine(Row,Stream)
else if BFI.Compression=BI_RLE4 then ExpandRLE4ScanLine(Row,Stream)
else Stream.Read(LineBuf[0],ReadSize);
end;
procedure TFPReaderBMP.WriteScanLine(Row : Integer; Img : TFPCustomImage);
@ -188,23 +469,35 @@ begin
1 :
for Column:=0 to Img.Width-1 do
if ((LineBuf[Column div 8] shr (7-(Column and 7)) ) and 1) <> 0 then
img.colors[Column,Row]:=FPalette[1]
img.Pixels[Column,Row]:=1
else
img.colors[Column,Row]:=FPalette[0];
img.Pixels[Column,Row]:=0;
4 :
for Column:=0 to img.Width-1 do
img.colors[Column,Row]:=FPalette[(LineBuf[Column div 2] shr (((Column+1) and 1)*4)) and $0f];
img.Pixels[Column,Row]:=(LineBuf[Column div 2] shr (((Column+1) and 1)*4)) and $0f;
8 :
for Column:=0 to img.Width-1 do
img.colors[Column,Row]:=FPalette[LineBuf[Column]];
img.Pixels[Column,Row]:=LineBuf[Column];
16 :
Raise FPImageException.Create('16 bpp bitmaps not supported');
for Column:=0 to img.Width-1 do
img.colors[Column,Row]:=ExpandColor(PWord(LineBuf)[Column]);
24 :
for Column:=0 to img.Width-1 do
img.colors[Column,Row]:=RGBToFPColor(PColorRGB(LineBuf)[Column]);
32 :
for Column:=0 to img.Width-1 do
img.colors[Column,Row]:=RGBAToFPColor(PColorRGBA(LineBuf)[Column]);
if BFI.Compression=BI_BITFIELDS then
img.colors[Column,Row]:=ExpandColor(PLongWord(LineBuf)[Column])
else
img.colors[Column,Row]:=RGBAToFPColor(PColorRGBA(LineBuf)[Column]);
end;
inc(percentacc,4);
if percentacc>=percentinterval then
begin
percent:=percent+(percentacc div percentinterval);
percentacc:=percentacc mod percentinterval;
Progress(psRunning,percent,false,Rect,'',continue);
end;
end;

671
fcl/image/fpwritebmp.pp
View File

@ -13,32 +13,53 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}
{*****************************************************************************}
{ 08/2005 by Giulio Bernardi:
- Removed FBytesPerPixel, BytesPerPixel property is now deprecated, use BitsPerPixel instead.
- Rewritten a large part of the file, so we can handle all bmp color depths
- Support for RLE4 and RLE8 encoding
}
{$mode objfpc}{$h+}
unit FPWriteBMP;
interface
uses FPImage, classes, sysutils;
uses FPImage, classes, sysutils, BMPComn;
type
TFPWriterBMP = class (TFPCustomImageWriter)
private
FBytesPerPixel : Byte;
StartPosition : int64; { save start of bitmap in the stream, if we must go back and fix something }
FBpp : byte;
FRLECompress : boolean;
BFH : TBitMapFileHeader;
BFI : TBitMapInfoHeader;
Colinfo : array of TColorRGBA;
procedure SetColorSize (AValue : Byte);
function GetColorSize : byte;
procedure SetBpp (const abpp : byte);
procedure FillColorMap(Img : TFPCustomImage);
procedure Setup16bpp;
function PackWord555(const col : TFPColor) : word;
function PackWord565(const col : TFPColor) : word;
function Pack4bpp(const img : TFPCustomImage; var Col : integer; const Row : integer) : byte;
function Pack1bpp(const img : TFPCustomImage; var Col : integer; const Row : integer) : byte;
procedure CompressScanLineRLE8(ALine : pbyte; const Row, Width : Integer; Stream : TStream);
procedure CompressScanLineRLE4(ALine : pbyte; const Row, Width : Integer; Stream : TStream);
protected
function SaveHeader(Stream:TStream; Img: TFPCustomImage):boolean; virtual;
procedure InternalWrite (Stream:TStream; Img: TFPCustomImage); override;
public
constructor Create; override;
Property BytesPerPixel : Byte Read FBytesPerPixel Write SetColorSize;
property BitsPerPixel : byte read FBpp write SetBpp;
property RLECompress : boolean read FRleCompress write FRleCompress;
Property BytesPerPixel : Byte Read GetColorSize Write SetColorSize; deprecated;
end;
implementation
uses BMPcomn;
Function FPColorToRGB(Const Color : TFPColor) : TColorRGB;
begin
@ -65,24 +86,157 @@ end;
constructor TFPWriterBMP.create;
begin
inherited create;
FBytesPerPixel:=3;
FBpp:=24;
FRleCompress:=false;
end;
{ Only for compatibility, BytesPerPixel should be removed }
{ ******************************************************* }
procedure TFPWriterBMP.SetColorSize (AValue : byte);
begin
if (AValue>4) then
AValue:=4;
if (AValue<1) then
AValue:=1;
FBytesPerPixel:=AValue;
SetBpp(AValue*8);
end;
function TFPWriterBMP.GetColorSize : byte;
begin
if FBpp<>15 then Result:=FBpp div 8
else Result:=2;
end;
{ ******************************************************* }
procedure TFPWriterBMP.SetBpp (const abpp : byte);
begin
if not (abpp in [1,4,8,15,16,24,32]) then
raise FPImageException.Create('Invalid color depth');
FBpp:=abpp;
end;
procedure TFPWriterBMP.FillColorMap(Img : TFPCustomImage);
var BadPalette : boolean;
i : integer;
begin
BadPalette:=false;
if not Img.UsePalette then BadPalette:=true
else if Img.Palette.Count>(1 shl FBpp) then BadPalette:=true;
if BadPalette then
raise FPImageException.Create('Image palette is too big or absent');
setlength(ColInfo,Img.Palette.Count);
BFI.ClrUsed:=Img.Palette.Count;
for i:=0 to BFI.ClrUsed-1 do
begin
ColInfo[i]:=FPColorToRGBA(Img.Palette.Color[i]);
ColInfo[i].A:=0;
end;
end;
{ True 16 bit color is 5 bits red, 6 bits green and 5 bits blue.
Compression must be set to BI_BITFIELDS and we must specify masks for red, green and blue.
16 bit without compression and masks is 5 bits per channel, so it's 15 bit even if in the header we
must write 16.
It's possible to provide custom masks but this is not compatible with windows9x, so we use 555 for 15 bit
and 565 for 16 bit.
Masks are longwords stored in the palette instead of palette entries (which are 4 bytes long too, with
components stored in following order: B G R A. Since we must write a low-endian longword, B is LSB and A
is the MSB).
We must write first red mask, then green and then blue.
This sounds terribly confusing, if you don't understand take a look at
http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdi/bitmaps_1rw2.asp
}
procedure TFPWriterBMP.Setup16bpp;
var col : TColorRGBA;
begin
BFI.Compression:=BI_BITFIELDS;
setlength(ColInfo,3);
{ A R G B
r := $0000F800
g := $000007E0
b := $0000001F
}
col.A:=0; Col.R:=0; { These are 0 for all the three masks}
{ Red Mask }
Col.G:=$F8; Col.B:=0;
ColInfo[0]:=Col;
{ Green Mask }
Col.G:=$07; Col.B:=$E0;
ColInfo[1]:=Col;
{ Blue Mask }
Col.G:=$00; Col.B:=$1F;
ColInfo[2]:=Col;
end;
{ 16 bit bpp with 555 packing (that is, 15 bit color)
This is bit dislocation:
0RRR RRGG GGGB BBBB }
function TFPWriterBMP.PackWord555(const col : TFPColor) : word;
var tmpcol : TColorRGB;
tmpr, tmpg, tmpb : word;
begin
tmpcol:=FPColorToRGB(col);
tmpb:=tmpcol.b shr 3;
tmpg:=tmpcol.g and $F8; tmpg:= tmpg shl 2;
tmpr:=tmpcol.r and $F8; tmpr:= tmpr shl 7;
tmpb:= tmpr or tmpg or tmpb;
{$IFDEF ENDIAN_BIG}
tmpb:=swap(tmpb);
{$ENDIF}
Result:=tmpb;
end;
{ 16 bit bpp with 565 packing )
This is bit dislocation:
RRRR RGGG GGGB BBBB }
function TFPWriterBMP.PackWord565(const col : TFPColor) : word;
var tmpcol : TColorRGB;
tmpr, tmpg, tmpb : word;
begin
tmpcol:=FPColorToRGB(col);
tmpb:=tmpcol.b shr 3;
tmpg:=tmpcol.g and $FC; tmpg:= tmpg shl 3;
tmpr:=tmpcol.r and $F8; tmpr:= tmpr shl 8;
tmpb:= tmpr or tmpg or tmpb;
{$IFDEF ENDIAN_BIG}
tmpb:=swap(tmpb);
{$ENDIF}
Result:=tmpb;
end;
{ First pixel in the most significant nibble, second one in LSN. If we are at the end of the line,
pad with zero }
function TFPWriterBMP.Pack4bpp(const img : TFPCustomImage; var Col : integer; const Row : integer) : byte;
var b : byte;
begin
b:=(img.Pixels[Col,Row] and $F) shl 4;
if Col<img.Width-1 then
begin
inc(Col);
b:=b + (img.Pixels[Col,Row] and $F);
end;
Result:=b;
inc(col);
end;
{ First pixel in the most significant bit, last one in LSN. If we are at the end of the line,
pad with zero }
function TFPWriterBMP.Pack1bpp(const img : TFPCustomImage; var Col : integer; const Row : integer) : byte;
var b : byte;
sh : shortint;
begin
b:=0;
sh:=7;
while ((Col<Img.Width) and (sh>=0)) do
begin
if img.Pixels[Col,Row]<>0 then { set this bit }
b:=b+(1 shl sh);
dec(sh);
inc(Col);
end;
Result:=b;
end;
function TFPWriterBMP.SaveHeader(Stream:TStream; Img : TFPCustomImage):boolean;
var
BFH:TBitMapFileHeader;
BFI:TBitMapInfoHeader;
begin
Result:=False;
with BFI do
@ -91,58 +245,485 @@ begin
Width:=Img.Width;
Height:=Img.Height;
Planes:=1;
BitCount:=BytesPerPixel SHL 3;
Compression:=0;
SizeImage:=Width*Height;
if FBpp=15 then BitCount:=16
else BitCount:=FBpp;
XPelsPerMeter:=100;
YPelsPerMeter:=100;
ClrUsed:=0; // No palette yet.
ClrImportant:=0;
end;
with BFH do
begin
bfType:=BMmagic;//'BM'
bfOffset:=sizeof(TBitMapFileHeader)+sizeof(TBitMapInfoHeader);
bfOffset:=sizeof(TBitMapFileHeader)+sizeof(TBitMapInfoHeader)+length(ColInfo)*4;
bfReserved:=0;
bfSize:=bfOffset+BFI.SizeImage*BytesPerPixel;
bfSize:=bfOffset+BFI.SizeImage;
end;
{$IFDEF ENDIAN_BIG}
SwapBMPFileHeader(BFH);
SwapBMPInfoHeader(BFI);
{$ENDIF}
Stream.seek(0,soFromBeginning);
StartPosition:=Stream.Position;
Stream.Write(bfh,sizeof(TBitMapFileHeader));
Stream.Write(bfi,sizeof(TBitMapInfoHeader));
{$IFDEF ENDIAN_BIG}
SwapBMPFileHeader(BFH);
SwapBMPInfoHeader(BFI);
{$ENDIF}
Result:=true;
end;
procedure TFPWriterBMP.InternalWrite (Stream:TStream; Img:TFPCustomImage);
var
Row,Col,nBpLine,WriteSize:Integer;
aLine: PByte;
S : Integer;
{ This code is rather ugly and difficult to read, but compresses better than gimp.
Brief explanation:
A repetition is good if it's made of 3 elements at least: we have 2 bytes instead of 1. Let's call this a
"repetition" or "true repetition".
So we start finding the first repetition from current position.
Once found, we must decide how to handle elements between current position (i) and the repetition position (j)
if j-i = 0 we are on the repetition, so we encode it
if j-i = 1 there is only one pixel. We can't do anything but encode it as a repetition of 1 element.
if j-i = 2 we have two pixels. These can be a couple (a repetition of 2 elements) or 2 singles
(2 repetitions of 1 element)
if j-i > 2 we have two choices. In fact, we must consider that absolute mode is 2 bytes + length of chunk.
A repetition is always 2 bytes, so for 1 element we leak 1 byte, while for 2 elements we don't leak
any byte.
So if we have at most 1 single this means that everything else is made up of couples: it's best to
use repetitions so that we leak 0 to 1 byte.
If we have 2 singles or more it's better to use absolute mode, since we leak 2 bytes always,
without regard to the size of chunk. }
procedure TFPWriterBMP.CompressScanLineRLE8(ALine : pbyte; const Row, Width : Integer; Stream : TStream);
var i, j, k, couples, singles : integer;
prev,tmp : byte;
begin
If Not (BytesPerPixel in [3,4]) then
Raise FPImageException.Create('Only 24 or 32 bit images are currently supported.');
SaveHeader(Stream,Img);
nBpLine:=Img.Width*BytesPerPixel;
WriteSize:=(nBpLine+3) AND $FFFFFFFC; //BMP needs evry line 4Bytes aligned
GetMem(aLine,(Img.Width+1)*BytesPerPixel);//3 extra byte for BMP 4Bytes alignement.
Try
for Row:=Img.Height-1 downto 0 do
i:=0;
while (i<Width) do
begin
{ let's see how bytes are disposed, so that we can choose the best way to compress }
couples:=0; singles:=1;
prev:=Aline[i];
j:=i+1;
while ((j<Width) and ((j-i)<255)) do
begin
if Aline[j]=prev then { this is a couple at least }
begin
Case BytesPerPixel of
3 : for Col:=0 to img.Width-1 do
PColorRGB(aLine)[Col]:=FPColorToRGB(img.colors[Col,Row]);
4 : for Col:=0 to img.Width-1 do
PColorRGBA(aLine)[Col]:=FPColorToRGBA(img.colors[Col,Row]);
dec(singles); { so the previous one wasn't a single }
if (((j+1)<Width) and (Aline[j+1]=prev)) then { at least three equal items, it's a repetition }
begin
dec(j); { repetition starts at j-1, since j is the middle pixel and j+1 is the third pixel }
break;
end
else inc(couples) { ok it's a couple }
end
else inc(singles); { this is a single if next isn't a couple }
prev:=Aline[j];
inc(j);
end;
{ ok, now that we know more about byte disposition we write data }
case (j-i) of
0 : begin { there is a repetition with count>=3 }
prev:=Aline[i];
j:=i+1;
while ((j<Width) and ((j-i)<255)) do
begin
if Aline[j]<>prev then break;
inc(j);
end;
tmp:=j-i;
Stream.Write(tmp,1);
Stream.Write(prev,1);
end;
1 : begin { single value: we write a repetition of 1 }
tmp:=1;
Stream.Write(tmp,1);
Stream.Write(Aline[i],1);
end;
2 : begin
if couples=1 then { a couple: we write a repetition of 2 }
begin
tmp:=2;
Stream.Write(tmp,1);
Stream.Write(Aline[i],1);
end
else { two singles: we write two repetitions of 1 each }
begin
tmp:=1;
Stream.Write(tmp,1);
Stream.Write(Aline[i],1);
Stream.Write(tmp,1);
Stream.Write(Aline[i+1],1);
end;
end;
else { here we have two choices }
begin
if singles>1 then { it's cheaper to use absolute mode }
begin
tmp:=0; Stream.Write(tmp,1); { escape }
tmp:=j-i; Stream.Write(tmp,1); { number of pixels in absolute mode }
Stream.Write(Aline[i],j-i); { write these pixels... }
if ((tmp mod 2)<>0) then { we must end on a 2-byte boundary }
begin
tmp:=0; Stream.Write(tmp,1); { so pad with an additional zero }
end;
end
else { they're nearly all couples, don't use absolute mode }
begin
k:=i;
while (k<j) do
begin
if ((k+1<j) and (Aline[k]=Aline[k+1])) then
begin
tmp:=2;
inc(k);
end
else tmp:=1;
Stream.Write(tmp,1);
Stream.Write(Aline[k],1);
inc(k);
end;
end;
end;
Stream.Write(aLine[0],WriteSize);
end;
i:=j;
end;
tmp:=0; Stream.Write(tmp,1); { escape }
if Row=0 then { last line, end of file }
tmp:=1;
Stream.Write(tmp,1);
end;
{ Ok, this is even uglier than the RLE8 version above, and this time gimp compresses better :\
Differences with RLE8: repetition count is pixel-relative, not byte-relative, but repetition data is made
of 2 pixels. So you have a repetition when you have pixels repeated in an alternate way, even if you can do
something like:
01E0 => E
0316 => 161.
A repetition is good if it's made of five elements at least (2 bytes instead of 3).
In rle4 we consider "single" either a single nibble or 2 (a byte), while a couple is a repetition of 3 or 4
elements. }
procedure TFPWriterBMP.CompressScanLineRLE4(ALine : pbyte; const Row, Width : Integer; Stream : TStream);
var i, j, k, couples, singles, lastsingle : integer;
prev1, prev2, prev : word;
tmp : byte;
nibline : pbyte; { temporary array of nibbles }
even : boolean;
begin
getmem(nibline,width);
try
k:=(Width div 2) + (Width mod 2);
i:=0;
while (i<k) do
begin
nibline[i*2]:=aline[i] shr 4;
nibline[i*2+1]:=aline[i] and $F;
inc(i);
end;
i:=0;
while (i<Width) do
begin
{ let's see how nibbles are disposed, so that we can choose the best way to compress }
couples:=0; singles:=1; lastsingle:=-10;
prev1:=nibline[i];
prev2:=nibline[i+1];
j:=i+2;
while ((j<Width) and ((j-i)<255)) do
begin
if nibline[j]=prev1 then { this is a half-couple at least (repetition of 3) }
begin
dec(singles); { so the previous one wasn't a single }
if (((j+1)<Width) and (nibline[j+1]=prev2)) then { at least a couple (repetition of 4) }
begin
if (((j+2)<Width) and (nibline[j+2]=prev1)) then { at least a repetition of 5, good }
begin
dec(j,2); { repetition starts at j-2: prev1 prev2 prev1* prev2 prev1, we are here * }
break;
end
else
begin { ok it's a couple }
inc(couples);
if (j-i)=254 then { in this rare case, j-i becomes 256. So, force a half-couple and exit }
begin
inc(j);
break;
end;
prev1:=256; { this is a couple, don't consider these positions in further scanning }
prev2:=256;
inc(j,2);
continue;
end
end
else
begin { ok it's a half-couple }
inc(couples);
prev:=256; //this is a half-couple, don't consider this position in further scanning.
end;
end
else
begin
if lastsingle<>(j-1) then
begin
inc(singles); { this is a single if next isn't a couple }
lastsingle:=j;
end;
prev:=nibline[j];
end;
prev1:=prev2;
prev2:=prev;
even:=not even;
inc(j);
end;
Finally
FreeMem(aLine);
if j>Width then j:=Width; { if j was Width-1 loop was skipped and j is Width+1, so we fix it }
{ ok, now that we know more about byte disposition we write data }
case (j-i) of
0 : begin { there is a repetition with count>=5 }
even:=true;
prev1:=nibline[i];
prev2:=nibline[i+1];
j:=i+2;
while ((j<Width) and ((j-i)<255)) do
begin
if even then if nibline[j]<>prev1 then break;
if not even then if nibline[j]<>prev2 then break;
even:=not even;
inc(j);
end;
tmp:=j-i;
Stream.Write(tmp,1);
prev:=(prev1 shl 4) + (prev2 and $F);
tmp:=prev;
Stream.Write(tmp,1);
end;
1 : begin { single value: we write a repetition of 1 }
tmp:=1;
Stream.Write(tmp,1);
tmp:=nibline[i] shl 4;
Stream.Write(tmp,1);
end;
2 : begin { 2 singles in the same byte: we write a repetition of 2 }
tmp:=2;
Stream.Write(tmp,1);
tmp:=(nibline[i] shl 4) + (nibline[i+1] and $F);
Stream.Write(tmp,1);
end;
3 : begin
if couples=1 then { a couple: we write a repetition of 3 }
begin
tmp:=3;
Stream.Write(tmp,1);
tmp:=(nibline[i] shl 4) + (nibline[i+1] and $F);
Stream.Write(tmp,1);
end
else
begin { 2 singles, 2 repetitions of 2 and 1 respectively }
tmp:=2;
Stream.Write(tmp,1);
tmp:=(nibline[i] shl 4) + (nibline[i+1] and $F);
Stream.Write(tmp,1);
tmp:=1;
Stream.Write(tmp,1);
tmp:=nibline[i+2] shl 4;
Stream.Write(tmp,1);
end;
end;
4 : begin
if singles=0 then { a couple: we write a repetition of 4 }
begin
tmp:=4;
Stream.Write(tmp,1);
tmp:=(nibline[i] shl 4) + (nibline[i+1] and $F);
Stream.Write(tmp,1);
end
else
begin { 2 singles, 2 repetitions of 2 each }
tmp:=2;
Stream.Write(tmp,1);
tmp:=(nibline[i] shl 4) + (nibline[i+1] and $F);
Stream.Write(tmp,1);
tmp:=2;
Stream.Write(tmp,1);
tmp:=(nibline[i+2] shl 4) + (nibline[i+3] and $F);
Stream.Write(tmp,1);
end;
end;
else { here we have two choices }
begin
if singles>1 then { it's cheaper to use absolute mode }
begin
tmp:=0; Stream.Write(tmp,1); { escape }
tmp:=j-i; Stream.Write(tmp,1); { number of pixels in absolute mode }
k:=i;
while (k<j) do { write these pixels... }
begin
tmp:=nibline[k] shl 4;
inc(k);
if k<j then
begin
tmp:=tmp+(nibline[k] and $F);
inc(k);
end;
Stream.Write(tmp,1);
end;
k:=j-i;
k:=k+(k mod 2);
if (k mod 4)<>0 then { we must end on a 2-byte boundary }
begin
tmp:=0; Stream.Write(tmp,1); { so pad with an additional zero }
end;
end
else { they're nearly all couples, don't use absolute mode }
begin
k:=i;
while (k<j) do
begin
if ((k+2<j) and (nibline[k]=nibline[k+2])) then
begin
if ((k+3<j) and (nibline[k+1]=nibline[k+3])) then tmp:=4
else tmp:=3;
end
else
begin
if (k+1>=j) then tmp:=1
else if ((k+3<j) and (nibline[k+1]=nibline[k+3])) then tmp:=1
else tmp:=2;
end;
Stream.Write(tmp,1);
prev:=tmp;
tmp:=nibline[k] shl 4;
if tmp<>1 then tmp:=tmp+(nibline[k+1] and $F);
Stream.Write(tmp,1);
inc(k,prev);
end;
end;
end;
end;
i:=j;
end;
tmp:=0; Stream.Write(tmp,1); { escape }
if Row=0 then { last line, end of file }
tmp:=1;
Stream.Write(tmp,1);
finally
FreeMem(nibline);
end;
end;
procedure TFPWriterBMP.InternalWrite (Stream:TStream; Img:TFPCustomImage);
var
Row,Col,RowSize:Integer;
PadCount : byte;
aLine: PByte;
i : Integer;
tmppos : int64;
continue : boolean;
percent : byte;
percentinterval : longword;
percentacc : longword;
Rect : TRect;
begin
Rect.Left:=0; Rect.Top:=0; Rect.Right:=0; Rect.Bottom:=0;
continue:=true;
percent:=0;
percentinterval:=(Img.Height*4) div 100;
if percentinterval=0 then percentinterval:=$FFFFFFFF;
percentacc:=0;
Progress(psStarting,0,false,Rect,'',continue);
if not continue then exit;
if (FRLECompress and (not (FBpp in [4,8]))) then
raise FPImageException.Create('Can''t use RLE compression with '+IntToStr(FBpp)+' bits per pixel');
if FRLECompress and (FBpp=4) then BFI.Compression:=BI_RLE4
else if FRLECompress and (FBpp=8) then BFI.Compression:=BI_RLE8
else BFI.Compression:=BI_RGB;
BFI.ClrUsed:=0;
try
if FBpp<=8 then FillColorMap(Img); { sets colormap and ClrUsed}
if FBpp=16 then Setup16bpp; { sets colormap with masks and Compression }
RowSize:=0; { just to keep the compiler quiet. }
case FBpp of
1 : begin
RowSize:=Img.Width div 8;
if (Img.Width mod 8)<>0 then
inc(RowSize);
end;
4 : begin
RowSize:=Img.Width div 2;
if (Img.Width mod 2)<>0 then
inc(RowSize);
end;
8 : RowSize:=Img.Width;
15 : RowSize:=Img.Width*2;
16 : RowSize:=Img.Width*2;
24 : RowSize:=Img.Width*3;
32 : RowSize:=Img.Width*4;
end;
PadCount:=(4-(RowSize mod 4)) mod 4; { every row must end on 4 byte boundary }
inc(RowSize,PadCount);
BFI.SizeImage:=RowSize*Img.Height;
SaveHeader(Stream,Img); { write the headers }
for i:=0 to length(ColInfo)-1 do { write the palette (or the masks in 16bpp case) }
Stream.Write(ColInfo[i],sizeof(TColorRGBA));
GetMem(aLine,RowSize);
try
for Row:=Img.Height-1 downto 0 do
begin
i:=0; Col:=0;
case FBpp of
1 : while(Col<img.Width) do
begin
PByte(aline)[i]:=Pack1bpp(img,Col,Row); { increases Col by 8 each time }
inc(i);
end;
4 : while(Col<img.Width) do
begin
PByte(aline)[i]:=Pack4bpp(img,Col,Row); { increases Col by 2 each time }
inc(i);
end;
8 : for Col:=0 to img.Width-1 do
PByte(aline)[Col]:=img.Pixels[Col,Row];
15 : for Col:=0 to img.Width-1 do
PWord(aline)[Col]:=PackWord555(img.colors[Col,Row]);
16 : for Col:=0 to img.Width-1 do
PWord(aline)[Col]:=PackWord565(img.colors[Col,Row]);
24 : for Col:=0 to img.Width-1 do
PColorRGB(aLine)[Col]:=FPColorToRGB(img.colors[Col,Row]);
32 : for Col:=0 to img.Width-1 do
PColorRGBA(aLine)[Col]:=FPColorToRGBA(img.colors[Col,Row]);
end;
{ pad the scanline with zeros }
for i:=RowSize-PadCount to RowSize-1 do
Pbyte(aline)[i]:=0;
if BFI.Compression=BI_RLE8 then CompressScanLineRLE8(aLine,Row,img.Width,Stream)
else if BFI.Compression=BI_RLE4 then CompressScanLineRLE4(aLine,Row,img.Width,Stream)
else Stream.Write(aLine[0],RowSize);
inc(percentacc,4);
if percentacc>=percentinterval then
begin
percent:=percent+(percentacc div percentinterval);
percentacc:=percentacc mod percentinterval;
Progress(psRunning,percent,false,Rect,'',continue);
if not continue then exit;
end;
end;
{ If image is compressed we must fix the headers since we now know the size of the image }
if BFI.Compression in [BI_RLE4,BI_RLE8] then
begin
tmppos:=Stream.Position-StartPosition-BFH.bfOffset;
BFI.SizeImage:=tmppos; { set size of the image }
tmppos:=Stream.Position; { remember where we are }
Stream.Position:=StartPosition; { rewind to the beginning }
SaveHeader(Stream,Img); { rewrite headers (this will update BFH.Size too) }
Stream.Position:=tmppos; { restore our position }
end;
Progress(psEnding,100,false,Rect,'',continue);
finally
FreeMem(aLine);
end;
finally
setlength(ColInfo,0);
end;
end;

2
fcl/image/imgconv.pp
View File

@ -69,7 +69,7 @@ begin
else if T = 'B' then
begin
Writer := TFPWriterBMP.Create;
TFPWriterBMP(Writer).BytesPerPixel:=4;
TFPWriterBMP(Writer).BitsPerPixel:=32;
end
else if T = 'J' then
Writer := TFPWriterJPEG.Create