Hi,
Is there a maintainer for fpImage ? And what is the development status of fp(read|write)bmp ? Is anyone working on adding other encodings than 32 bit ?
If not, than I'll have a try to add the missing encodings.
I am not the maintainer, but I have been tinkering with it. Attached is a patch containing my efforts so far
Colin
diff -uNr fpc/fcl/image/bmpcomn.pp fpc.w/fcl/image/bmpcomn.pp
--- fpc/fcl/image/bmpcomn.pp 2003-09-09 12:22:30.000000000 +0100
+++ fpc.w/fcl/image/bmpcomn.pp 2004-02-14 12:02:34.000000000 +0000
@@ -24,7 +24,7 @@
BMmagic=19778;
type
- TBitMapFileHeader = record
+ TBitMapFileHeader = packed record
{00+02 :File type}
bfType:word;
{02+04 :File size in bytes}
@@ -35,7 +35,7 @@
bfOffset:longint;
end;
- TBitMapInfoHeader = record
+ TBitMapInfoHeader = packed record
{14+04 : Size of the bitmap info header : sould be 40=$28}
Size:longint;
{18+04 : Image width in pixels}
@@ -64,9 +64,8 @@
B,G,R:Byte;
end;
TColorRGBA=packed record
- A:Byte;
case Boolean of
- False:(B,G,R:Byte);
+ False:(B,G,R,A:Byte);
True:(RGB:TColorRGB);
end;
{54+?? : Color map : Lenght of color map is 4 bytes + the rest until the beginning of image data fixed in BFH.bfOffset}
diff -uNr fpc/fcl/image/fpimage.pp fpc.w/fcl/image/fpimage.pp
--- fpc/fcl/image/fpimage.pp 2003-10-25 10:08:52.000000000 +0100
+++ fpc.w/fcl/image/fpimage.pp 2004-02-14 12:02:34.000000000 +0000
@@ -109,13 +109,13 @@
procedure SetPixel (x,y:integer; Value:integer);
function GetPixel (x,y:integer) : integer;
function GetUsePalette : boolean;
- procedure SetUsePalette (Value:boolean);virtual;
protected
// Procedures to store the data. Implemented in descendants
procedure SetInternalColor (x,y:integer; const Value:TFPColor); virtual;
function GetInternalColor (x,y:integer) : TFPColor; virtual;
procedure SetInternalPixel (x,y:integer; Value:integer); virtual; abstract;
function GetInternalPixel (x,y:integer) : integer; virtual; abstract;
+ procedure SetUsePalette (Value:boolean);virtual;
procedure Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
const Msg: AnsiString; var Continue: Boolean); Virtual;
diff -uNr fpc/fcl/image/fpreadbmp.pp fpc.w/fcl/image/fpreadbmp.pp
--- fpc/fcl/image/fpreadbmp.pp 2004-02-03 21:19:56.000000000 +0000
+++ fpc.w/fcl/image/fpreadbmp.pp 2004-02-14 12:02:34.000000000 +0000
@@ -50,55 +50,110 @@
procedure TFPReaderBMP.InternalRead(Stream:TStream; Img:TFPCustomImage);
var
BFI:TBitMapInfoHeader;
- var
- Row,Coulumn,nBpLine,ReadSize:Integer;
+ Row,Column,nBpLine,ReadSize:Integer;
aColor:TFPcolor;
-{$IFDEF UseDynArray}
+ palette: ARRAY OF TFPcolor;
aLine:ARRAY OF TColorRGB;
-{$ELSE UseDynArray}
- aLine:^TColorRGB;
-{$ENDIF UseDynArray}
+ bLine:ARRAY OF TColorRGBA;
+ mLine: array of Byte;
+ function MakeFpColor(RGBA: TColorRGBA):TFPcolor;
+ begin
+ with Result, RGBA do begin
+ Red := (R shl 8) or R;
+ Green := (G shl 8) or G;
+ Blue := (B shl 8) or B;
+ alpha := AlphaOpaque;
+ end;
+ end;
+ procedure SetupRead(nPalette, nRowBits: Integer);
+ var
+ ColInfo: ARRAY OF TColorRGBA;
+ i: Integer;
+ begin
+ if nPalette > 0 then begin
+ SetLength(palette, nPalette);
+ SetLength(ColInfo, nPalette);
+ if BFI.ClrUsed > 0 then
+ Stream.Read(ColInfo[0], BFI.ClrUsed*SizeOf(TColorRGBA))
+ else if nPalette > 0 then
+ Stream.Read(ColInfo[0], nPalette*SizeOf(TColorRGBA));
+ end else
+ if BFI.ClrUsed > 0 then { Skip palette }
+ Stream.Position := Stream.Position + BFI.ClrUsed*SizeOf(TColorRGBA);
+ for i := 0 to High(ColInfo) do
+ palette[i] := MakeFpColor(ColInfo[i]);
+ ReadSize := ((nRowBits + 31) div 32) shl 2;
+ end;
begin
Stream.Read(BFI,SizeOf(BFI));
+ { This will move past any junk after the BFI header }
+ Stream.Position := Stream.Position - SizeOf(BFI) + BFI.Size;
with BFI do
begin
Img.Width:=Width;
Img.Height:=Height;
- BytesPerPixel:=BitCount SHR 3;
end;
- if BytesPerPixel=1
- then
- begin
-// stream.read(Palet, bfh.bfOffset - 54);
- end
+ if BFI.BitCount = 1 then begin
+ { Monochrome }
+ SetupRead(2, Img.Width);
+ SetLength(mLine, ReadSize);
+ for Row:=Img.Height-1 downto 0 do begin
+ Stream.Read(mLine[0],ReadSize);
+ for Column:=0 to Img.Width-1 do
+ if ((mLine[Column div 8] shr (7-(Column and 7)) ) and 1) <> 0 then
+ img.colors[Column,Row] := Palette[1]
+ else
+ img.colors[Column,Row] := Palette[0];
+ end;
+ end else if BFI.BitCount = 4 then begin
+ SetupRead(16, Img.Width*4);
+ SetLength(mLine, ReadSize);
+ for Row:=img.Height-1 downto 0 do begin
+ Stream.Read(mLine[0],ReadSize);
+ for Column:=0 to img.Width-1 do
+ img.colors[Column,Row] := Palette[(mLine[Column div 2] shr (((Column+1) and 1)*4)) and $0f];
+ end;
+ end else if BFI.BitCount = 8 then begin
+ SetupRead(256, Img.Width*8);
+ SetLength(mLine, ReadSize);
+ for Row:=img.Height-1 downto 0 do begin
+ Stream.Read(mLine[0],ReadSize);
+ for Column:=0 to img.Width-1 do
+ img.colors[Column,Row] := Palette[mLine[Column]];
+ end;
+ end else if BFI.BitCount = 16 then begin
+ raise Exception.Create('16 bpp bitmaps not supported');
{Treating the 24bit BMP files}
- else
+ end else if BFI.BitCount=24 then
begin
- nBpLine:=Img.Width*SizeOf(TColorRGB);
- ReadSize:=(nBpLine+3)AND $FFFFFFFC;//BMP needs evry line 4Bytes aligned
-{$IFDEF UseDynArray}
- SetLength(aLine,Img.Width+1);//3 extra byte for BMP 4Bytes alignement.
-{$ELSE UseDynArray}
- GetMem(aLine,(Img.Width+1)*SizeOf(TColorRGB));//3 extra byte for BMP 4Bytes alignement.
-{$ENDIF UseDynArray}
+ SetupRead(0, Img.Width*8*3);
+ SetLength(aLine,ReadSize);//3 extra byte for BMP 4Bytes alignement.
for Row:=img.Height-1 downto 0 do
begin
- for Coulumn:=0 to img.Width-1 do
- with aLine[Coulumn],aColor do
+ Stream.Read(aLine[0],ReadSize);
+ for Column:=0 to img.Width-1 do
+ with aLine[Column],aColor do
begin
{Use only the high byte to convert the color}
Red := (R shl 8) + R;
Green := (G shl 8) + G;
Blue := (B shl 8) + B;
alpha := AlphaOpaque;
- img.colors[Coulumn,Row]:=aColor;
+ img.colors[Column,Row]:=aColor;
end;
- Stream.Read(aLine{$IFNDEF UseDynArray}^{$ENDIF UseDynArray},ReadSize);
+ end;
+ end
+ else if BFI.BitCount=32 then
+ begin
+ SetupRead(0, Img.Width*8*4);
+ SetLength(bLine,ReadSize);
+ for Row:=img.Height-1 downto 0 do
+ begin
+ Stream.Read(bLine[0],ReadSize);
+ for Column:=0 to img.Width-1 do
+ img.colors[Column,Row]:=MakeFpColor(bLine[Column])
end;
end;
-{$IFNDEF UseDynArray}
- FreeMem(aLine,(Img.Width+1)*SizeOf(TColorRGB));
-{$ENDIF UseDynArray}
end;
function TFPReaderBMP.InternalCheck (Stream:TStream) : boolean;
@@ -110,10 +165,7 @@
if bfType<>BMmagic
then
InternalCheck:=False
- else if Stream.Size<>bfSize
- then
- InternalCheck:=False
- else
+ else { Do not check size to allow multiple bitmaps per stream }
InternalCheck:=True;
end;
diff -uNr fpc/fcl/image/fpreadxpm.pp fpc.w/fcl/image/fpreadxpm.pp
--- fpc/fcl/image/fpreadxpm.pp 2004-01-21 22:45:41.000000000 +0000
+++ fpc.w/fcl/image/fpreadxpm.pp 2004-02-14 12:02:34.000000000 +0000
@@ -66,18 +66,20 @@
raise exception.CreateFmt ('Wrong character (%s) in hexadecimal number', [c]);
end;
function convert (n : string) : word;
- var t,r, shift : integer;
+ var t,r: integer;
begin
- shift := 0;
result := 0;
t := length(n);
if t > 4 then
- raise exception.CreateFmt ('To many bytes for color (%s)',[s]);
- for r := length(n) downto 1 do
- begin
- result := result + (CharConv(n[r]) shl shift);
- inc (shift,4);
- end;
+ raise exception.CreateFmt ('Too many bytes for color (%s)',[s]);
+ for r := 1 to length(n) do
+ result := (result shl 4) or CharConv(n[r]);
+ // fill missing bits
+ case t of
+ 1: result:=result or (result shl 4) or (result shl 8) or (result shl 12);
+ 2: result:=result or (result shl 8);
+ 3: result:=result or (result shl 12);
+ end;
end;
begin
s := uppercase (s);
