From 9fe7ee0b815e549f2232b8112815bebe24b886a5 Mon Sep 17 00:00:00 2001 From: michael Date: Tue, 30 Aug 2005 19:26:31 +0000 Subject: [PATCH] * Patches from Giulio BERNA - 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 - --- fcl/image/bmpcomn.pp | 17 +- fcl/image/fpimage.pp | 5 + fcl/image/fppalette.inc | 91 ++++++ fcl/image/fpreadbmp.pp | 375 +++++++++++++++++++--- fcl/image/fpwritebmp.pp | 671 +++++++++++++++++++++++++++++++++++++--- fcl/image/imgconv.pp | 2 +- 6 files changed, 1070 insertions(+), 91 deletions(-) diff --git a/fcl/image/bmpcomn.pp b/fcl/image/bmpcomn.pp index e4d45913b4..ced42b8bcf 100644 --- a/fcl/image/bmpcomn.pp +++ b/fcl/image/bmpcomn.pp @@ -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; diff --git a/fcl/image/fpimage.pp b/fcl/image/fpimage.pp index 73d1391a73..b195916c7c 100644 --- a/fcl/image/fpimage.pp +++ b/fcl/image/fpimage.pp @@ -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); diff --git a/fcl/image/fppalette.inc b/fcl/image/fppalette.inc index 2e1dbf5ea9..003260bb05 100644 --- a/fcl/image/fppalette.inc +++ b/fcl/image/fppalette.inc @@ -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; diff --git a/fcl/image/fpreadbmp.pp b/fcl/image/fpreadbmp.pp index 4265420f13..d52e0e300b 100644 --- a/fcl/image/fpreadbmp.pp +++ b/fcl/image/fpreadbmp.pp @@ -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 (i0 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 (iReadSize 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 (i0 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 (itmpsize 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 (i0 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; diff --git a/fcl/image/fpwritebmp.pp b/fcl/image/fpwritebmp.pp index a608de0d98..d9eca54dcc 100644 --- a/fcl/image/fpwritebmp.pp +++ b/fcl/image/fpwritebmp.pp @@ -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=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=3 } + prev:=Aline[i]; + j:=i+1; + while ((jprev 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 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(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 ((jprev1 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 (k0 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) then tmp:=1 + else if ((k+31 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=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; diff --git a/fcl/image/imgconv.pp b/fcl/image/imgconv.pp index 60cdffca4f..743acb2379 100644 --- a/fcl/image/imgconv.pp +++ b/fcl/image/imgconv.pp @@ -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