paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-06 04:57:59 +02:00
Code Issues Packages Projects Releases Wiki Activity
e9c9548826
lazarus/lcl/intfgraphics.pas
marc ccbcdd833d * Changed typing fixes to casting 
git-svn-id: trunk@6193 -
2004-11-04 00:52:23 +00:00

3340 lines
94 KiB
ObjectPascal
Raw Blame History

{ $Id$ }
{
/***************************************************************************
intfgraphics.pp
---------------
***************************************************************************/
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.LCL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Author: Mattias Gaertner
Abstract:
Classes and functions for easy handling of raw images (interface images).
}
unit IntfGraphics;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpImage, FPReadBMP, BMPComn, FPCAdds, AvgLvlTree, LCLType,
LCLProc, GraphType, LCLIntf;
type
{ TLazIntfImage }
{ This descendent of TFPCustomImage stores its image data as raw images and
is therefore able to directly interchange images with the LCL interfaces.
Usage examples:
1. Loading a .xpm file into a TBitmap:
var
BmpHnd,MaskHnd: HBitmap;
Bitmap1: TBitmap;
IntfImg1: TLazIntfImage;
Reader: TLazReaderXPM;
begin
// create a bitmap (or use an existing one)
Bitmap1:=TBitmap.Create;
// create the raw image
IntfImg1:=TLazIntfImage.Create(0,0);
// get the description for the current screen (bitsperpixel, depth, ...)
IntfImg1.GetDescriptionFromDevice(0);
// create the XPM reader
Reader:=TLazReaderXPM.Create;
// load the image
IntfImg1.LoadFromFile('filename.xpm',Reader);
// create the bitmap handles
IntfImg1.CreateBitmap(BmpHnd,MaskHnd);
// apply handles to the Bitmap1
Bitmap1.Handle:=BmpHnd;
Bitmap1.MaskHandle:=MaskHnd;
// clean up
Reader.Free;
IntfImg1.Free;
// do something with the Bitmap1
...
end;
2. Saving a TBitmap to a .xpm file:
var
BmpHnd,MaskHnd: HBitmap;
Bitmap1: TBitmap;
IntfImg1: TLazIntfImage;
Writer: TLazWriterXPM;
begin
...
// create the raw image
IntfImg1:=TLazIntfImage.Create(0,0);
// load the raw image from the bitmap handles
IntfImg1.LoadFromBitmap(Bitmap1.Handle,Bitmap1.MaskHandle);
// create the XPM writer
Writer:=TLazWriterXPM.Create;
// save image to file
IntfImg1.SaveToFile('filename.xpm',Writer);
// clean up
Writer.Free;
IntfImg1.Free;
...
end;
}
TOnGetLazIntfImagePixel = procedure(x, y: integer; var Color: TFPColor)
of object;
TOnSetLazIntfImagePixel = procedure(x, y: integer; const Color: TFPColor)
of object;
TOnReadRawImageBits = procedure(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal; var Bits: word);
TOnWriteRawImageBits = procedure(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal; Bits: word);
TLazIntfImage = class(TFPCustomImage)
private
FAutoCreateMask: boolean;
FDataDescription: TRawImageDescription;
FPixelData: PByte;
FPixelDataSize: cardinal;
FMaskData: PByte;
FMaskDataSize: cardinal;
FLineStarts: PRawImagePosition;
FMaskLineStarts: PRawImagePosition;
FUpdateCount: integer;
fCreateAllDataNeeded: boolean;
FGetSetColorFunctionsUpdateNeeded: boolean;
FReadRawImageBits: TOnReadRawImageBits;
FWriteRawImageBits: TOnWriteRawImageBits;
FAlphaReadRawImageBits: TOnReadRawImageBits;
FAlphaWriteRawImageBits: TOnWriteRawImageBits;
function GetTColors(x, y: integer): TGraphicsColor;
procedure SetAutoCreateMask(const AValue: boolean);
procedure SetTColors(x, y: integer; const AValue: TGraphicsColor);
protected
OnGetInternalColor: TOnGetLazIntfImagePixel;
OnSetInternalColor: TOnSetLazIntfImagePixel;
procedure SetUsePalette (Value: boolean); override;
procedure SetInternalColor(x, y: integer; const Value: TFPColor); override;
function GetInternalColor(x, y: integer): TFPColor; override;
procedure SetInternalPixel (x,y:integer; Value:integer); override;
function GetInternalPixel (x,y:integer) : integer; override;
procedure FreeAllData; virtual;
procedure FreePixelData; virtual;
procedure FreeMaskData; virtual;
procedure CreateAllData; virtual;
procedure CreatePixelData; virtual;
procedure CreateMaskData; virtual;
procedure CreateDataAndLineStarts(var Data: Pointer; var DataSize: cardinal;
var TheLineStarts: PRawImagePosition;
TheBitsPerPixel: cardinal;
TheLineEnd: TRawImageLineEnd); virtual;
procedure SetDataDescription(const NewDescription: TRawImageDescription); virtual;
procedure ChooseGetSetColorFunctions; virtual;
procedure ChooseRawBitsProc(BitsPerPixel: cardinal;
ByteOrder: TRawImageByteOrder;
BitOrder: TRawImageBitOrder;
var ProcReadRawImageBits: TOnReadRawImageBits;
var ProcWriteRawImageBits: TOnWriteRawImageBits);
// get color functions
procedure GenericGetColor(x, y: integer; var Value: TFPColor);
procedure GetColor_NoPalette_RGBA_Alpha_Sep_Mask(x, y: integer; var Value: TFPColor);
procedure GetColor_NoPalette_RGBA_Alpha_Sep_NoMask(x, y: integer; var Value: TFPColor);
procedure GetColor_NoPalette_RGBA_Alpha_NoSep(x, y: integer; var Value: TFPColor);
procedure GetColor_NoPalette_RGBA_NoAlpha(x, y: integer; var Value: TFPColor);
procedure GetColor_NoPalette_Gray(x, y: integer; var Value: TFPColor);
procedure GetColor_NULL(x, y: integer; var Value: TFPColor);
// set color functions
procedure GenericSetColor(x, y: integer; const Value: TFPColor);
procedure SetColor_NoPalette_RGBA_Alpha_Sep_Mask(x, y: integer; const Value: TFPColor);
procedure SetColor_NoPalette_RGBA_Alpha_NoSep(x, y: integer; const Value: TFPColor);
procedure SetColor_NoPalette_RGBA_NoAlpha(x, y: integer; const Value: TFPColor);
procedure SetColor_NoPalette_Gray(x, y: integer; const Value: TFPColor);
procedure SetColor_NULL(x, y: integer; const Value: TFPColor);
procedure SetColor_BPP32_R8G8B8_A1_BIO_TTB(x, y: integer; const Value: TFPColor);
procedure SetColor_BPP32_R8G8B8_A1_BIO_TTB_RBO(x, y: integer; const Value: TFPColor);
public
constructor Create(AWidth, AHeight: integer); override;
destructor Destroy; override;
procedure BeginUpdate;
procedure EndUpdate;
procedure SetSize(AWidth, AHeight: integer); override;
function CheckDescription(const ADescription: TRawImageDescription;
ExceptionOnError: boolean): boolean; virtual;
procedure GetDescriptionFromDevice(DC: HDC); virtual;
procedure GetDescriptionFromBitmap(Bitmap: HBitmap); virtual;
procedure LoadFromDevice(DC: HDC); virtual;
procedure LoadFromBitmap(Bitmap, MaskBitmap: HBitmap); virtual;
procedure CreateBitmap(var Bitmap, MaskBitmap: HBitmap;
AlwaysCreateMask: boolean); virtual;
procedure SetRawImage(const RawImage: TRawImage); virtual;
procedure GetRawImage(var RawImage: TRawImage); virtual;
procedure FillPixels(const Color: TFPColor); virtual;
procedure GetXYDataPostion(x, y: integer; var Position: TRawImagePosition);
procedure GetXYMaskPostion(x, y: integer; var Position: TRawImagePosition);
public
property PixelData: PByte read FPixelData;
property MaskData: PByte read FMaskData;
property DataDescription: TRawImageDescription read FDataDescription
write SetDataDescription;
property AutoCreateMask: boolean read FAutoCreateMask write SetAutoCreateMask;
property TColors[x,y: integer]: TGraphicsColor read GetTColors write SetTColors;
end;
{ TLazIntfImageMask }
TLazIntfImageMask = class(TFPCustomImage)
private
FImage: TLazIntfImage;
protected
procedure SetInternalColor(x, y: integer; const Value: TFPColor); override;
function GetInternalColor(x, y: integer): TFPColor; override;
procedure SetInternalPixel (x,y:integer; Value:integer); override;
function GetInternalPixel (x,y:integer) : integer; override;
public
constructor CreateWithImage(TheImage: TLazIntfImage); virtual;
property Image: TLazIntfImage read FImage;
end;
{ TLazAVLPalette }
{ This descendent of TFPPalette uses a AVL tree for speed up. }
TLazAVLPalette = class(TFPPalette)
protected
FAVLPalette: TAvgLvlTree; // tree of PLazAVLPaletteEntry 'color to index'
FAVLNodes: PAvgLvlTreeNode;// 'index to node' array
procedure SetCount(NewCount: integer); override;
procedure SetColor(Index: integer; const NewColor: TFPColor); override;
function CompareEntries(Index1, Index2: integer): integer;
function CompareColorWithEntries(const AColor: TFPColor;
Index: integer): integer;
procedure EnlargeData; override;
public
destructor Destroy; override;
function IndexOf(const AColor: TFPColor): integer; override;
function Add(const NewColor: TFPColor): integer; override;
procedure CheckConsistency; virtual;
end;
{ TArrayNodesTree }
PArrayNode = ^TArrayNode;
TArrayNode = class
public
Parent: TArrayNode;
Value: integer;
Childs: PArrayNode;
StartValue: integer;
Capacity: integer;
Data: Pointer;
constructor Create;
destructor Destroy; override;
procedure DeleteChilds;
procedure UnbindFromParent;
procedure CreateChildNode(ChildValue: integer);
function GetChildNode(ChildValue: integer;
CreateIfNotExists: boolean): TArrayNode;
procedure Expand(ValueToInclude: integer);
function FindPrevSibling: TArrayNode;
function FindNextSibling: TArrayNode;
function FindNext: TArrayNode;
function FindPrev: TArrayNode;
function FindFirstChild: TArrayNode;
function FindLastChild: TArrayNode;
function FindLastSubChild: TArrayNode;
function FindFirstSibling: TArrayNode;
function FindLastSibling: TArrayNode;
procedure ConsistencyCheck;
end;
TArrayNodesTree = class
public
Root: TArrayNode;
function FindNode(IntArray: PInteger; Count: integer): TArrayNode;
function FindData(IntArray: PInteger; Count: integer): Pointer;
function SetNode(IntArray: PInteger; Count: integer;
Data: Pointer): TArrayNode;
procedure Delete(Node: TArrayNode);
procedure Clear;
constructor Create;
destructor Destroy; override;
procedure ConsistencyCheck;
end;
{ TLazReaderXPM }
{ This is a FPImage reader for xpm images. }
TLazReaderXPM = class(TFPCustomImageReader)
private
FWidth: Integer;
FHeight: Integer;
FColorCount: Integer;
FCharsPerPixel: Integer;
fXHot: Integer;
fYHot: Integer;
FPixelToColorTree: TArrayNodesTree;
protected
procedure ClearPixelToColorTree;
procedure InternalRead(Str: TStream; Img: TFPCustomImage); override;
function InternalCheck(Str: TStream): boolean; override;
public
constructor Create; override;
destructor Destroy; override;
end;
{ TLazWriterXPM }
{ This is a FPImage writer for xpm images. }
TLazWriterXPM = class(TFPCustomImageWriter)
private
FNibblesPerSample: word;
FRightShiftSample: cardinal;
procedure SetNibblesPerSample(const AValue: word);
protected
procedure InternalWrite(Str: TStream; Img: TFPCustomImage); override;
public
constructor Create; override;
property NibblesPerSample: word read FNibblesPerSample
write SetNibblesPerSample;
end;
{ TLazReaderBMP }
{ This is an imroved FPImage writer for bmp images. }
TLazReaderBMP = class (TFPCustomImageReader)
Private
Procedure FreeBufs; // Free (and nil) buffers.
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, Word, TColorRGB or TColorRGBA
// SetupRead will allocate the needed buffers, and read the colormap if needed.
procedure SetupRead(nPalette, nRowBits: Integer; Stream: TStream;
ReadPalette: Boolean); virtual;
procedure ReadScanLine(Row: Integer; Stream: TStream); virtual;
procedure WriteScanLine(Row: Integer; Img: TFPCustomImage); virtual;
function BmpRGBAToFPColor(Const RGBA: TColorRGBA): TFPcolor; virtual;
// required by TFPCustomImageReader
procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
procedure InternalReadBody(Stream: TStream; Img: TFPCustomImage);
function InternalCheck(Stream: TStream) : boolean; override;
public
constructor Create; override;
destructor Destroy; override;
end;
{ TLazReaderPartIcon }
{ This is a FPImage writer for a single icon from an icon file }
TLazReaderPartIcon = class (TLazReaderBMP)
protected
// required by TFPCustomImageReader
procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
function InternalCheck(Stream: TStream) : boolean; override;
function BmpRGBAToFPColor(Const RGBA: TColorRGBA): TFPcolor; override;
end;
{ TLazReaderIcon }
{ This is a FPImage writer for icon images. }
TLazReaderIcon = class (TLazReaderPartIcon)
private
FIcon: TObject; { Actually TIcon, but this would give rise to a circular reference }
FnIcons: Integer;
FnStartPos: TStreamSeekType;
procedure SetIcon(const AValue: TObject);
protected
// required by TFPCustomImageReader
procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
function InternalCheck(Stream: TStream) : boolean; override;
public
property Icon: TObject read FIcon write SetIcon;
end;
function ReadCompleteStreamToString(Str: TStream; StartSize: integer): string;
procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream;
StartSize: integer);
implementation
uses Graphics;
var
IsSpaceChar, IsNumberChar, IsHexNumberChar: array[char] of Boolean;
function ReadCompleteStreamToString(Str: TStream; StartSize: integer): string;
var
NewLength: Integer;
ReadLen: Integer;
begin
if (Str is TMemoryStream) or (Str is TFileStream) or (Str is TStringStream)
then begin
// read as one block
SetLength(Result,Str.Size-Str.Position);
if Result<>'' then
Str.Read(Result[1],length(Result));
end else begin
// read exponential
if StartSize=0 then StartSize:=1024;
SetLength(Result,StartSize);
NewLength:=0;
repeat
ReadLen:=Str.Read(Result[NewLength+1],length(Result)-NewLength);
inc(NewLength,ReadLen);
if NewLength<length(Result) then break;
SetLength(Result,length(Result)*2);
until false;
SetLength(Result,NewLength);
end;
end;
procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream;
StartSize: integer);
var
NewLength: Integer;
ReadLen: Integer;
Buffer: string;
begin
if (SrcStream is TMemoryStream) or (SrcStream is TFileStream)
or (SrcStream is TStringStream)
then begin
// read as one block
DestStream.CopyFrom(SrcStream,SrcStream.Size-SrcStream.Position);
end else begin
// read exponential
if StartSize<=0 then StartSize:=1024;
SetLength(Buffer,StartSize);
NewLength:=0;
repeat
ReadLen:=SrcStream.Read(Buffer[NewLength+1],length(Buffer)-NewLength);
inc(NewLength,ReadLen);
if NewLength<length(Buffer) then break;
SetLength(Buffer,length(Buffer)*2);
until false;
if NewLength>0 then
DestStream.Write(Buffer[1],NewLength);
end;
end;
procedure ReadRawImageBits_1_2_4_BIO(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal;
var Bits: word);
var
P: PByte;
PrecMask: Cardinal;
OneByte: Byte;
begin
PrecMask:=(Cardinal(1) shl Prec)-1;
P:=@(TheData[Position.Byte]);
OneByte:=P^;
Bits:=Word(cardinal(OneByte shr (Shift+Position.Bit)) and PrecMask);
if Prec<16 then begin
// add missing bits
Bits:=(Bits shl (16-Prec));
Bits:=Bits or MissingBits[Prec,Bits shr 13];
end;
end;
procedure ReadRawImageBits_1_2_4_BNIO(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal;
var Bits: word);
var
P: PByte;
PrecMask: Cardinal;
OneByte: Byte;
begin
PrecMask:=(Cardinal(1) shl Prec)-1;
P:=@(TheData[Position.Byte]);
OneByte:=P^;
Bits:=Word(cardinal(OneByte shr (Shift+7-Position.Bit)) and PrecMask);
if Prec<16 then begin
// add missing bits
Bits:=(Bits shl (16-Prec));
Bits:=Bits or MissingBits[Prec,Bits shr 13];
end;
end;
procedure ReadRawImageBits_8(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal;
var Bits: word);
var
P: PByte;
PrecMask: Cardinal;
OneByte: Byte;
begin
PrecMask:=(Cardinal(1) shl Prec)-1;
P:=@(TheData[Position.Byte]);
OneByte:=P^;
Bits:=Word(cardinal(OneByte shr Shift) and PrecMask);
if Prec<16 then begin
// add missing bits
Bits:=(Bits shl (16-Prec));
Bits:=Bits or MissingBits[Prec,Bits shr 13];
end;
end;
procedure ReadRawImageBits_16(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal;
var Bits: word);
var
P: PByte;
PrecMask: Cardinal;
TwoBytes: Word;
begin
PrecMask:=(Cardinal(1) shl Prec)-1;
P:=@(TheData[Position.Byte]);
TwoBytes:=PWord(P)^;
Bits:=Word(cardinal(TwoBytes shr Shift) and PrecMask);
if Prec<16 then begin
// add missing bits
Bits:=(Bits shl (16-Prec));
Bits:=Bits or MissingBits[Prec,Bits shr 13];
end;
end;
procedure ReadRawImageBits_ReversedBytes_16(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal;
var Bits: word);
var
P: PByte;
PrecMask: Cardinal;
TwoBytes: Word;
begin
PrecMask:=(Cardinal(1) shl Prec)-1;
P:=@(TheData[Position.Byte]);
TwoBytes:=PWord(P)^;
TwoBytes:=(TwoBytes shr 8) or ((TwoBytes and $ff) shl 8); // switch byte order
Bits:=Word(cardinal(TwoBytes shr Shift) and PrecMask);
if Prec<16 then begin
// add missing bits
Bits:=(Bits shl (16-Prec));
Bits:=Bits or MissingBits[Prec,Bits shr 13];
end;
end;
procedure ReadRawImageBits_24(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal;
var Bits: word);
var
P: PByte;
PrecMask: Cardinal;
FourBytes: Cardinal;
begin
PrecMask:=(Cardinal(1) shl Prec)-1;
P:=@(TheData[Position.Byte]);
{$ifdef Endian_Little}
FourBytes:=DWord(PWord(P)^) or (DWord((P+2)^) shl 16);
{$else}
FourBytes:=(DWord(PWord(P)^) shl 8) or DWord(P^);
{$endif}
Bits:=Word(cardinal(FourBytes shr Shift) and PrecMask);
if Prec<16 then begin
// add missing bits
Bits:=(Bits shl (16-Prec));
Bits:=Bits or MissingBits[Prec,Bits shr 13];
end;
end;
procedure ReadRawImageBits_ReversedBytes_24(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal;
var Bits: word);
var
P: PByte;
PrecMask: Cardinal;
FourBytes: Cardinal;
begin
PrecMask:=(Cardinal(1) shl Prec)-1;
P:=@(TheData[Position.Byte]);
{$ifdef Endian_Little}
FourBytes:=(DWord(PWord(P)^) shl 8) or DWord(P^);
{$else}
FourBytes:=DWord(PWord(P)^) or (DWord((P+2)^) shl 16);
{$endif}
Bits:=Word(cardinal(FourBytes shr Shift) and PrecMask);
if Prec<16 then begin
// add missing bits
Bits:=(Bits shl (16-Prec));
Bits:=Bits or MissingBits[Prec,Bits shr 13];
end;
end;
procedure ReadRawImageBits_32(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal;
var Bits: word);
var
P: PByte;
PrecMask: Cardinal;
FourBytes: Cardinal;
begin
PrecMask:=(Cardinal(1) shl Prec)-1;
P:=@(TheData[Position.Byte]);
FourBytes:=PDWord(P)^;
Bits:=Word(cardinal(FourBytes shr Shift) and PrecMask);
if Prec<16 then begin
// add missing bits
Bits:=(Bits shl (16-Prec));
Bits:=Bits or MissingBits[Prec,Bits shr 13];
end;
end;
procedure ReadRawImageBits_ReversedBytes_32(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal;
var Bits: word);
var
P: PByte;
PrecMask: Cardinal;
FourBytes: Cardinal;
begin
PrecMask:=(Cardinal(1) shl Prec)-1;
P:=@(TheData[Position.Byte]);
FourBytes:=PDWord(P)^;
// switch byte order
FourBytes:=(FourBytes shr 24) or ((FourBytes shr 8) and $FF00)
or ((FourBytes and $ff00) shl 8) or ((FourBytes and $ff) shl 24);
Bits:=Word(cardinal(FourBytes shr Shift) and PrecMask);
if Prec<16 then begin
// add missing bits
Bits:=(Bits shl (16-Prec));
Bits:=Bits or MissingBits[Prec,Bits shr 13];
end;
end;
procedure WriteRawImageBits_1_2_4_BIO(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal; Bits: word);
var
P: PByte;
PrecMask: Cardinal;
OneByte: Byte;
ShiftLeft: Integer;
begin
P:=@(TheData[Position.Byte]);
PrecMask:=(Cardinal(1) shl Prec)-1;
Bits:=Bits shr (16-Prec);
OneByte:=P^;
ShiftLeft:=Shift+Position.Bit;
PrecMask:=not (PrecMask shl ShiftLeft);
OneByte:=OneByte and PrecMask; // clear old
OneByte:=OneByte or (Bits shl ShiftLeft); // set new
P^:=OneByte;
end;
procedure WriteRawImageBits_1_2_4_BNIO(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal; Bits: word);
var
P: PByte;
PrecMask: Cardinal;
OneByte: Byte;
ShiftLeft: Integer;
begin
P:=@(TheData[Position.Byte]);
PrecMask:=(Cardinal(1) shl Prec)-1;
Bits:=Bits shr (16-Prec);
OneByte:=P^;
ShiftLeft:=Shift+7-Position.Bit;
PrecMask:=not (PrecMask shl ShiftLeft);
OneByte:=OneByte and PrecMask; // clear old
OneByte:=OneByte or (Bits shl ShiftLeft); // set new
P^:=OneByte;
end;
procedure WriteRawImageBits_8(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal; Bits: word);
var
P: PByte;
PrecMask: Cardinal;
OneByte: Byte;
begin
P:=@(TheData[Position.Byte]);
PrecMask:=(Cardinal(1) shl Prec)-1;
Bits:=Bits shr (16-Prec);
OneByte:=P^;
PrecMask:=not (PrecMask shl Shift);
OneByte:=OneByte and PrecMask; // clear old
OneByte:=OneByte or (Bits shl Shift); // set new
P^:=OneByte;
end;
procedure WriteRawImageBits_16(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal; Bits: word);
var
P: PByte;
PrecMask: Cardinal;
TwoBytes: Word;
begin
P:=@(TheData[Position.Byte]);
PrecMask:=(Cardinal(1) shl Prec)-1;
Bits:=Bits shr (16-Prec);
TwoBytes:=PWord(P)^;
PrecMask:=not (PrecMask shl Shift);
TwoBytes:=TwoBytes and PrecMask; // clear old
TwoBytes:=TwoBytes or (Bits shl Shift); // set new
PWord(P)^:=TwoBytes;
end;
procedure WriteRawImageBits_ReversedBytes_16(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal; Bits: word);
var
P: PByte;
PrecMask: Cardinal;
TwoBytes: Word;
begin
P:=@(TheData[Position.Byte]);
PrecMask:=(Cardinal(1) shl Prec)-1;
Bits:=Bits shr (16-Prec);
TwoBytes:=PWord(P)^;
TwoBytes:=(TwoBytes shr 8) or ((TwoBytes and $ff) shl 8); // switch byte order
PrecMask:=not (PrecMask shl Shift);
TwoBytes:=TwoBytes and PrecMask; // clear old
TwoBytes:=TwoBytes or (Bits shl Shift); // set new
TwoBytes:=(TwoBytes shr 8) or ((TwoBytes and $ff) shl 8); // switch byte order
PWord(P)^:=TwoBytes;
end;
procedure WriteRawImageBits_24(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal; Bits: word);
var
P: PByte;
PrecMask: Cardinal;
FourBytes: Cardinal;
begin
P:=@(TheData[Position.Byte]);
PrecMask:=(Cardinal(1) shl Prec)-1;
Bits:=Bits shr (16-Prec);
{$ifdef Endian_Little}
FourBytes:=DWord(PWord(P)^) or (DWord((P+2)^) shl 16);
{$else}
FourBytes:=(DWord(PWord(P)^) shl 8) or DWord(P^);
{$endif}
PrecMask:=not (PrecMask shl Shift);
FourBytes:=FourBytes and PrecMask; // clear old
FourBytes:=FourBytes or cardinal(Bits shl Shift); // set new
{$ifdef Endian_little}
PWord(P)^ := Word(FourBytes);
(P+2)^ := Byte(FourBytes shr 16);
{$else}
PWord(P)^ := Word(FourBytes shr 8);
P^ := Byte(FourBytes);
{$endif}
end;
procedure WriteRawImageBits_ReversedBytes_24(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal; Bits: word);
var
P: PByte;
PrecMask: Cardinal;
FourBytes: Cardinal;
begin
P:=@(TheData[Position.Byte]);
PrecMask:=(Cardinal(1) shl Prec)-1;
Bits:=Bits shr (16-Prec);
{$ifdef Endian_Little}
FourBytes:=(DWord(PWord(P)^) shl 8) or DWord(P^);
{$else}
FourBytes:=DWord(PWord(P)^) or (DWord((P+2)^) shl 16);
{$endif}
PrecMask:=not (PrecMask shl Shift);
FourBytes:=FourBytes and PrecMask; // clear old
FourBytes:=FourBytes or cardinal(Bits shl Shift); // set new
{$ifdef Endian_little}
PWord(P)^ := Word(FourBytes shr 8);
P^ := Byte(FourBytes);
{$else}
PWord(P)^ := Word(FourBytes);
(P+2)^ := Byte(FourBytes shr 16);
{$endif}
end;
procedure WriteRawImageBits_32(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal; Bits: word);
var
P: PByte;
PrecMask: Cardinal;
FourBytes: Cardinal;
begin
P:=@(TheData[Position.Byte]);
PrecMask:=(Cardinal(1) shl Prec)-1;
Bits:=Bits shr (16-Prec);
FourBytes:=PDWord(P)^;
PrecMask:=not (PrecMask shl Shift);
FourBytes:=FourBytes and PrecMask; // clear old
FourBytes:=FourBytes or cardinal(Bits shl Shift); // set new
PDWord(P)^:=FourBytes;
end;
procedure WriteRawImageBits_ReversedBytes_32(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal; Bits: word);
var
P: PByte;
PrecMask: Cardinal;
FourBytes: Cardinal;
begin
P:=@(TheData[Position.Byte]);
PrecMask:=(Cardinal(1) shl Prec)-1;
Bits:=Bits shr (16-Prec);
FourBytes:=PDWord(P)^;
// switch byte order
FourBytes:=(FourBytes shr 24) or ((FourBytes shr 8) and $FF00)
or ((FourBytes and $ff00) shl 8) or ((FourBytes and $ff) shl 24);
PrecMask:=not (PrecMask shl Shift);
FourBytes:=FourBytes and PrecMask; // clear old
FourBytes:=FourBytes or cardinal(Bits shl Shift); // set new
// switch byte order
FourBytes:=(FourBytes shr 24) or ((FourBytes shr 8) and $FF00)
or ((FourBytes and $ff00) shl 8) or ((FourBytes and $ff) shl 24);
PDWord(P)^:=FourBytes;
end;
procedure ReadRawImageBits_NULL(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal;
var Bits: word);
begin
Bits:=0;
if Prec<16 then begin
// add missing bits
Bits:=(Bits shl (16-Prec));
Bits:=Bits or MissingBits[Prec,Bits shr 13];
end;
end;
procedure WriteRawImageBits_NULL(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal; Bits: word);
begin
end;
{ TLazIntfImage }
procedure TLazIntfImage.SetDataDescription(
const NewDescription: TRawImageDescription);
begin
if CompareMem(@FDataDescription,@NewDescription,SizeOf(TRawImageDescription))
then
exit;
CheckDescription(NewDescription,true);
BeginUpdate;
try
FreeAllData;
fDataDescription:=NewDescription;
ChooseGetSetColorFunctions;
SetSize(0,0);
fCreateAllDataNeeded:=false;
finally
EndUpdate;
end;
end;
procedure TLazIntfImage.ChooseRawBitsProc(BitsPerPixel: cardinal;
ByteOrder: TRawImageByteOrder; BitOrder: TRawImageBitOrder;
var ProcReadRawImageBits: TOnReadRawImageBits;
var ProcWriteRawImageBits: TOnWriteRawImageBits);
begin
case BitsPerPixel of
1,2,4:
begin
if BitOrder = riboBitsInOrder then
begin
ProcReadRawImageBits := @ReadRawImageBits_1_2_4_BIO;
ProcWriteRawImageBits := @WriteRawImageBits_1_2_4_BIO;
end else begin
ProcReadRawImageBits := @ReadRawImageBits_1_2_4_BNIO;
ProcWriteRawImageBits := @WriteRawImageBits_1_2_4_BNIO;
end;
end;
8:
begin
ProcReadRawImageBits := @ReadRawImageBits_8;
ProcWriteRawImageBits := @WriteRawImageBits_8;
end;
16:
begin
if DefaultByteOrder=ByteOrder then begin
ProcReadRawImageBits := @ReadRawImageBits_16;
ProcWriteRawImageBits := @WriteRawImageBits_16;
end else begin
ProcReadRawImageBits := @ReadRawImageBits_ReversedBytes_16;
ProcWriteRawImageBits := @WriteRawImageBits_ReversedBytes_16;
end;
end;
24:
begin
if DefaultByteOrder=ByteOrder then begin
ProcReadRawImageBits := @ReadRawImageBits_24;
ProcWriteRawImageBits := @WriteRawImageBits_24;
end else begin
ProcReadRawImageBits := @ReadRawImageBits_ReversedBytes_24;
ProcWriteRawImageBits := @WriteRawImageBits_ReversedBytes_24;
end;
end;
32:
begin
if DefaultByteOrder=ByteOrder then begin
ProcReadRawImageBits := @ReadRawImageBits_32;
ProcWriteRawImageBits := @WriteRawImageBits_32;
end else begin
ProcReadRawImageBits := @ReadRawImageBits_ReversedBytes_32;
ProcWriteRawImageBits := @WriteRawImageBits_ReversedBytes_32;
end;
end;
else
DebugLn('WARNING: TLazIntfImage.ChooseRawBitsProc Unsupported BitsPerPixel=',dbgs(BitsPerPixel));
ProcReadRawImageBits := @ReadRawImageBits_NULL;
ProcWriteRawImageBits := @WriteRawImageBits_NULL;
end;
end;
procedure TLazIntfImage.ChooseGetSetColorFunctions;
procedure ChooseRGBAFunctions;
begin
//DebugLn('ChooseRGBAFunctions ',RawImageDescriptionAsString(@FDataDescription));
ChooseRawBitsProc(FDataDescription.BitsPerPixel,
FDataDescription.ByteOrder,
FDataDescription.BitOrder,
FReadRawImageBits, FWriteRawImageBits);
if FDataDescription.AlphaPrec>0 then
begin
if FDataDescription.AlphaSeparate then
begin
if (FMaskData<>nil) then
begin
OnGetInternalColor:=@GetColor_NoPalette_RGBA_Alpha_Sep_Mask;
OnSetInternalColor:=@SetColor_NoPalette_RGBA_Alpha_Sep_Mask;
with FDataDescription do begin
if (BitsPerPixel=32) and (Depth=24) and (BitOrder=riboBitsInOrder)
and (ByteOrder=DefaultByteOrder) and (LineOrder=riloTopToBottom)
and (LineEnd=rileDWordBoundary)
and (RedPrec=8) and (RedShift=16)
and (GreenPrec=8) and (GreenShift=8)
and (BluePrec=8) and (BlueShift=0)
then begin
if ByteOrder=DefaultByteOrder then
OnSetInternalColor:=@SetColor_BPP32_R8G8B8_A1_BIO_TTB
else
OnSetInternalColor:=@SetColor_BPP32_R8G8B8_A1_BIO_TTB_RBO;
end;
end;
end else begin
OnGetInternalColor:=@GetColor_NoPalette_RGBA_Alpha_Sep_NoMask;
OnSetInternalColor:=@SetColor_NoPalette_RGBA_NoAlpha;
end;
ChooseRawBitsProc(FDataDescription.AlphaBitsPerPixel,
FDataDescription.AlphaByteOrder,
FDataDescription.AlphaBitOrder,
FAlphaReadRawImageBits, FAlphaWriteRawImageBits);
end else begin
OnGetInternalColor:=@GetColor_NoPalette_RGBA_Alpha_NoSep;
OnSetInternalColor:=@SetColor_NoPalette_RGBA_Alpha_NoSep;
ChooseRawBitsProc(FDataDescription.BitsPerPixel,
FDataDescription.AlphaByteOrder, FDataDescription.AlphaBitOrder,
FAlphaReadRawImageBits, FAlphaWriteRawImageBits);
end;
end else begin
OnGetInternalColor:=@GetColor_NoPalette_RGBA_NoAlpha;
OnSetInternalColor:=@SetColor_NoPalette_RGBA_NoAlpha;
end;
end;
begin
// Default: use the generic functions, that can handle all kinds of RawImages
OnGetInternalColor:=@GenericGetColor;
OnSetInternalColor:=@GenericSetColor;
if FUpdateCount>0 then begin
FGetSetColorFunctionsUpdateNeeded:=true;
exit;
end;
FGetSetColorFunctionsUpdateNeeded:=false;
if not FDataDescription.HasPalette then
begin
case FDataDescription.Format of
ricfRGBA:
ChooseRGBAFunctions;
ricfGray:
begin
ChooseRawBitsProc(FDataDescription.BitsPerPixel,
FDataDescription.ByteOrder,
FDataDescription.BitOrder,
FReadRawImageBits, FWriteRawImageBits);
OnGetInternalColor:=@GetColor_NoPalette_Gray;
OnSetInternalColor:=@SetColor_NoPalette_Gray;
end;
end;
end else begin
// palette
// ToDo
DebugLn('WARNING: TLazIntfImage.ChooseGetSetColorFunctions Palette is unsupported');
end;
end;
procedure TLazIntfImage.GenericGetColor(x, y: integer; var Value: TFPColor);
var
Position: TRawImagePosition;
MaskPosition: TRawImagePosition;
begin
GetXYDataPostion(x,y,Position);
if not FDataDescription.HasPalette then begin
case FDataDescription.Format of
ricfRGBA:
begin
ReadRawImageBits(FPixelData,Position,FDataDescription.BitsPerPixel,
FDataDescription.RedPrec,FDataDescription.RedShift,
FDataDescription.BitOrder,Value.Red);
ReadRawImageBits(FPixelData,Position,FDataDescription.BitsPerPixel,
FDataDescription.GreenPrec,FDataDescription.GreenShift,
FDataDescription.BitOrder,Value.Green);
ReadRawImageBits(FPixelData,Position,FDataDescription.BitsPerPixel,
FDataDescription.BluePrec,FDataDescription.BlueShift,
FDataDescription.BitOrder,Value.Blue);
if FDataDescription.AlphaPrec>0 then begin
if FDataDescription.AlphaSeparate then begin
if (FMaskData<>nil) then begin
GetXYMaskPostion(x,y,MaskPosition);
ReadRawImageBits(FMaskData,MaskPosition,
FDataDescription.AlphaBitsPerPixel,
FDataDescription.AlphaPrec,
FDataDescription.AlphaShift,
FDataDescription.AlphaBitOrder,Value.Alpha);
end else begin
// no alpha mask -> set opaque
Value.Alpha:=high(Value.Alpha);
end;
end else
ReadRawImageBits(FPixelData,Position,FDataDescription.BitsPerPixel,
FDataDescription.AlphaPrec,FDataDescription.AlphaShift,
FDataDescription.AlphaBitOrder,Value.Alpha)
end else begin
// no alpha -> set opaque
Value.Alpha:=high(Value.Alpha);
end;
end;
ricfGray:
begin
ReadRawImageBits(FPixelData,Position,FDataDescription.BitsPerPixel,
FDataDescription.RedPrec,FDataDescription.RedShift,
FDataDescription.BitOrder,Value.Red);
Value.Green:=Value.Red;
Value.Blue:=Value.Red;
end;
else
Value.Red:=0;
Value.Green:=0;
Value.Blue:=0;
Value.Alpha:=0;
end;
end else begin
// ToDo: read index, then palette
Value.Red:=0;
Value.Green:=0;
Value.Blue:=0;
Value.Alpha:=0;
end;
end;
procedure TLazIntfImage.GenericSetColor(x, y: integer; const Value: TFPColor);
var
Position: TRawImagePosition;
MaskPosition: TRawImagePosition;
begin
GetXYDataPostion(x,y,Position);
if not FDataDescription.HasPalette then begin
case FDataDescription.Format of
ricfRGBA:
begin
WriteRawImageBits(FPixelData,Position,FDataDescription.BitsPerPixel,
FDataDescription.RedPrec,FDataDescription.RedShift,
FDataDescription.BitOrder,Value.Red);
WriteRawImageBits(FPixelData,Position,FDataDescription.BitsPerPixel,
FDataDescription.GreenPrec,FDataDescription.GreenShift,
FDataDescription.BitOrder,Value.Green);
WriteRawImageBits(FPixelData,Position,FDataDescription.BitsPerPixel,
FDataDescription.BluePrec,FDataDescription.BlueShift,
FDataDescription.BitOrder,Value.Blue);
if FDataDescription.AlphaPrec>0 then begin
if FDataDescription.AlphaSeparate then begin
if (FMaskData<>nil) then begin
GetXYMaskPostion(x,y,MaskPosition);
WriteRawImageBits(FMaskData,MaskPosition,
FDataDescription.AlphaBitsPerPixel,
FDataDescription.AlphaPrec,
FDataDescription.AlphaShift,
FDataDescription.AlphaBitOrder,Value.Alpha);
end else begin
// no alpha mask
end;
end else
WriteRawImageBits(FPixelData,Position,FDataDescription.BitsPerPixel,
FDataDescription.AlphaPrec,
FDataDescription.AlphaShift,
FDataDescription.AlphaBitOrder,Value.Alpha)
end else begin
// no alpha
end;
end;
ricfGray:
begin
WriteRawImageBits(FPixelData,Position,FDataDescription.BitsPerPixel,
FDataDescription.RedPrec,FDataDescription.RedShift,
FDataDescription.BitOrder,Value.Red);
end;
else
end;
end else begin
// ToDo: Palette
end;
end;
procedure TLazIntfImage.GetColor_NoPalette_RGBA_Alpha_Sep_Mask(x, y: integer;
var Value: TFPColor);
var
Position: TRawImagePosition;
MaskPosition: TRawImagePosition;
begin
GetXYDataPostion(x,y,Position);
FReadRawImageBits(FPixelData,Position,
FDataDescription.RedPrec,FDataDescription.RedShift,
Value.Red);
FReadRawImageBits(FPixelData,Position,
FDataDescription.GreenPrec,FDataDescription.GreenShift,
Value.Green);
FReadRawImageBits(FPixelData,Position,
FDataDescription.BluePrec,FDataDescription.BlueShift,
Value.Blue);
GetXYMaskPostion(x,y,MaskPosition);
FAlphaReadRawImageBits(FMaskData,MaskPosition,
FDataDescription.AlphaPrec,
FDataDescription.AlphaShift,
Value.Alpha);
end;
procedure TLazIntfImage.GetColor_NoPalette_RGBA_Alpha_Sep_NoMask(x, y: integer; var Value: TFPColor);
var
Position: TRawImagePosition;
begin
GetXYDataPostion(x,y,Position);
FReadRawImageBits(FPixelData,Position,
FDataDescription.RedPrec,FDataDescription.RedShift,
Value.Red);
FReadRawImageBits(FPixelData,Position,
FDataDescription.GreenPrec,FDataDescription.GreenShift,
Value.Green);
FReadRawImageBits(FPixelData,Position,
FDataDescription.BluePrec,FDataDescription.BlueShift,
Value.Blue);
// no alpha mask -> set opaque
Value.Alpha:=high(Value.Alpha);
end;
procedure TLazIntfImage.GetColor_NoPalette_RGBA_Alpha_NoSep(x, y: integer; var Value: TFPColor);
var
Position: TRawImagePosition;
begin
GetXYDataPostion(x,y,Position);
FReadRawImageBits(FPixelData,Position,
FDataDescription.RedPrec,FDataDescription.RedShift,
Value.Red);
FReadRawImageBits(FPixelData,Position,
FDataDescription.GreenPrec,FDataDescription.GreenShift,
Value.Green);
FReadRawImageBits(FPixelData,Position,
FDataDescription.BluePrec,FDataDescription.BlueShift,
Value.Blue);
FAlphaReadRawImageBits(FPixelData,Position,
FDataDescription.AlphaPrec,FDataDescription.AlphaShift,
Value.Alpha)
end;
procedure TLazIntfImage.GetColor_NoPalette_RGBA_NoAlpha(x, y: integer; var Value: TFPColor);
var
Position: TRawImagePosition;
begin
GetXYDataPostion(x,y,Position);
FReadRawImageBits(FPixelData,Position,
FDataDescription.RedPrec,FDataDescription.RedShift,
Value.Red);
FReadRawImageBits(FPixelData,Position,
FDataDescription.GreenPrec,FDataDescription.GreenShift,
Value.Green);
FReadRawImageBits(FPixelData,Position,
FDataDescription.BluePrec,FDataDescription.BlueShift,
Value.Blue);
// no alpha -> set opaque
Value.Alpha:=high(Value.Alpha);
end;
procedure TLazIntfImage.GetColor_NoPalette_Gray(x, y: integer; var Value: TFPColor);
var
Position: TRawImagePosition;
begin
GetXYDataPostion(x,y,Position);
FReadRawImageBits(FPixelData,Position,
FDataDescription.RedPrec,FDataDescription.RedShift,
Value.Red);
Value.Green:=Value.Red;
Value.Blue:=Value.Red;
end;
procedure TLazIntfImage.GetColor_NULL(x, y: integer; var Value: TFPColor);
var
Position: TRawImagePosition;
begin
GetXYDataPostion(x,y,Position);
Value.Red:=0;
Value.Green:=0;
Value.Blue:=0;
Value.Alpha:=0;
end;
procedure TLazIntfImage.SetColor_NoPalette_RGBA_Alpha_Sep_Mask(x, y: integer;
const Value: TFPColor);
var
Position: TRawImagePosition;
MaskPosition: TRawImagePosition;
begin
GetXYDataPostion(x,y,Position);
FWriteRawImageBits(FPixelData,Position,
FDataDescription.RedPrec,FDataDescription.RedShift,
Value.Red);
FWriteRawImageBits(FPixelData,Position,
FDataDescription.GreenPrec,FDataDescription.GreenShift,
Value.Green);
FWriteRawImageBits(FPixelData,Position,
FDataDescription.BluePrec,FDataDescription.BlueShift,
Value.Blue);
GetXYMaskPostion(x,y,MaskPosition);
FAlphaWriteRawImageBits(FMaskData,MaskPosition,
FDataDescription.AlphaPrec,
FDataDescription.AlphaShift,
Value.Alpha);
end;
procedure TLazIntfImage.SetColor_NoPalette_RGBA_Alpha_NoSep(x, y: integer;
const Value: TFPColor);
var
Position: TRawImagePosition;
begin
GetXYDataPostion(x,y,Position);
FWriteRawImageBits(FPixelData,Position,
FDataDescription.RedPrec,FDataDescription.RedShift,
Value.Red);
FWriteRawImageBits(FPixelData,Position,
FDataDescription.GreenPrec,FDataDescription.GreenShift,
Value.Green);
FWriteRawImageBits(FPixelData,Position,
FDataDescription.BluePrec,FDataDescription.BlueShift,
Value.Blue);
FAlphaWriteRawImageBits(FPixelData,Position,
FDataDescription.AlphaPrec,
FDataDescription.AlphaShift,
Value.Alpha)
end;
procedure TLazIntfImage.SetColor_NoPalette_RGBA_NoAlpha(x, y: integer; const Value: TFPColor);
var
Position: TRawImagePosition;
begin
GetXYDataPostion(x,y,Position);
FWriteRawImageBits(FPixelData,Position,
FDataDescription.RedPrec,FDataDescription.RedShift,
Value.Red);
FWriteRawImageBits(FPixelData,Position,
FDataDescription.GreenPrec,FDataDescription.GreenShift,
Value.Green);
FWriteRawImageBits(FPixelData,Position,
FDataDescription.BluePrec,FDataDescription.BlueShift,
Value.Blue);
// no alpha -> ignore
end;
procedure TLazIntfImage.SetColor_NoPalette_Gray(x, y: integer;
const Value: TFPColor);
var
Position: TRawImagePosition;
begin
GetXYDataPostion(x,y,Position);
FWriteRawImageBits(FPixelData,Position,
FDataDescription.RedPrec,FDataDescription.RedShift,
Value.Red);
end;
procedure TLazIntfImage.SetColor_NULL(x, y: integer; const Value: TFPColor);
begin
// NULL, not implemented
end;
procedure TLazIntfImage.SetColor_BPP32_R8G8B8_A1_BIO_TTB(x, y: integer;
const Value: TFPColor);
// Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0
// BitOrder=riboBitsInOrder ByteOrder=DefaultByteOrder
// LineOrder=riloTopToBottom
// BitsPerPixel=32 LineEnd=rileDWordBoundary
// RedPrec=8 RedShift=16 GreenPrec=8 GreenShift=8 BluePrec=8 BlueShift=0
// AlphaSeparate=true
var
Position: PCardinal;
Pixel: Cardinal;
AlphaPosition: Integer;
AlphaBitPosition: Integer;
AlphaByte: Byte;
begin
Position:=PCardinal(FPixelData+FLineStarts[y].Byte+(x shl 2));
Pixel:=((Value.Red shr 8) shl 16)
+((Value.Green shr 8) shl 8)
+(Value.Blue shr 8);
Position^:=Pixel;
AlphaPosition:=FMaskLineStarts[y].Byte+(cardinal(x) shr 3);
AlphaBitPosition:=(x and 7);
AlphaByte:=FMaskData[AlphaPosition];
if Value.Alpha>=$8000 then
AlphaByte:=AlphaByte or (1 shl AlphaBitPosition)
else
AlphaByte:=AlphaByte and not (1 shl AlphaBitPosition);
FMaskData[AlphaPosition]:=AlphaByte;
end;
procedure TLazIntfImage.SetColor_BPP32_R8G8B8_A1_BIO_TTB_RBO(x, y: integer;
const Value: TFPColor);
// Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0
// BitOrder=riboBitsInOrder ByteOrder=not DefaultByteOrder
// LineOrder=riloTopToBottom
// BitsPerPixel=32 LineEnd=rileDWordBoundary
// RedPrec=8 RedShift=16 GreenPrec=8 GreenShift=8 BluePrec=8 BlueShift=0
// AlphaSeparate=true
var
Position: PCardinal;
Pixel: Cardinal;
AlphaPosition: Integer;
AlphaBitPosition: Integer;
AlphaByte: Byte;
begin
Position:=PCardinal(FPixelData+FLineStarts[y].Byte+(x shl 2));
Pixel:=(Value.Red shr 8)
+((Value.Green shr 8) shl 8)
+((Value.Blue shr 8) shl 16);
Position^:=Pixel;
AlphaPosition:=FMaskLineStarts[y].Byte+(cardinal(x) shr 3);
AlphaBitPosition:=(x and 7);
AlphaByte:=FMaskData[AlphaPosition];
if Value.Alpha>=$8000 then
AlphaByte:=AlphaByte or (1 shl AlphaBitPosition)
else
AlphaByte:=AlphaByte and not (1 shl AlphaBitPosition);
FMaskData[AlphaPosition]:=AlphaByte;
end;
procedure TLazIntfImage.SetAutoCreateMask(const AValue: boolean);
begin
if FAutoCreateMask=AValue then exit;
FAutoCreateMask:=AValue;
if AutoCreateMask then
CreateMaskData
else
FreeMaskData;
end;
function TLazIntfImage.GetTColors(x, y: integer): TGraphicsColor;
begin
Result:=FPColorToTColor(Colors[x,y]);
end;
procedure TLazIntfImage.SetTColors(x, y: integer; const AValue: TGraphicsColor);
begin
Colors[x,y]:=TColorToFPColor(AValue);
end;
procedure TLazIntfImage.SetUsePalette(Value: boolean);
begin
inherited SetUsePalette(False); // Can't handle palettes at the moment
end;
procedure TLazIntfImage.SetInternalColor(x, y: integer; const Value: TFPColor);
begin
{if (x=0) and (y=0) then begin
// a common bug in the readers is that Alpha is reversed
DebugLn('TLazIntfImage.SetInternalColor ',x,',',y,' ',Value.Red,',',Value.Green,',',Value.Blue,',',Value.Alpha);
if Value.Alpha<>alphaOpaque then
RaiseGDBException('');
end;}
OnSetInternalColor(x,y,Value);
end;
function TLazIntfImage.GetInternalColor(x, y: integer): TFPColor;
begin
OnGetInternalColor(x,y,Result);
end;
procedure TLazIntfImage.SetInternalPixel(x, y: integer; Value: integer);
begin
end;
function TLazIntfImage.GetInternalPixel(x, y: integer): integer;
begin
Result:=0;
end;
procedure TLazIntfImage.FreeAllData;
begin
FreePixelData;
FreeMaskData;
end;
procedure TLazIntfImage.FreePixelData;
begin
ReallocMem(FPixelData,0);
FPixelDataSize:=0;
ReallocMem(FLineStarts,0);
end;
procedure TLazIntfImage.FreeMaskData;
begin
ReallocMem(FMaskData,0);
FMaskDataSize:=0;
ReallocMem(FMaskLineStarts,0);
end;
procedure TLazIntfImage.CreateAllData;
begin
if FUpdateCount>0 then begin
fCreateAllDataNeeded:=true;
exit;
end;
fCreateAllDataNeeded:=false;
CreatePixelData;
if AutoCreateMask then
CreateMaskData
else
FreeMaskData;
end;
procedure TLazIntfImage.CreatePixelData;
begin
FreePixelData;
CreateDataAndLineStarts(FPixelData,FPixelDataSize,
FLineStarts,FDataDescription.BitsPerPixel,
FDataDescription.LineEnd);
end;
procedure TLazIntfImage.CreateMaskData;
var
MaskDataExisted: boolean;
begin
MaskDataExisted:=FMaskData<>nil;
FreeMaskData;
if (FDataDescription.AlphaBitsPerPixel>0)
and FDataDescription.AlphaSeparate then begin
CreateDataAndLineStarts(FMaskData,FMaskDataSize,FMaskLineStarts,
FDataDescription.AlphaBitsPerPixel,
FDataDescription.AlphaLineEnd);
end;
if MaskDataExisted xor (FMaskData<>nil) then
ChooseGetSetColorFunctions;
end;
procedure TLazIntfImage.CreateDataAndLineStarts(var Data: Pointer;
var DataSize: cardinal; var TheLineStarts: PRawImagePosition;
TheBitsPerPixel: cardinal; TheLineEnd: TRawImageLineEnd);
begin
CreateRawImageLineStarts(Width,Height,TheBitsPerPixel,TheLineEnd,
TheLineStarts);
CreateRawImageData(Width,Height,TheBitsPerPixel,TheLineEnd,Data,DataSize);
end;
constructor TLazIntfImage.Create(AWidth, AHeight: integer);
begin
FAutoCreateMask:=true;
OnGetInternalColor:=@GetColor_NULL;
OnSetInternalColor:=@SetColor_NULL;
inherited Create(AWidth, AHeight);
end;
destructor TLazIntfImage.Destroy;
begin
FreeAllData;
inherited Destroy;
end;
procedure TLazIntfImage.BeginUpdate;
begin
inc(FUpdateCount);
end;
procedure TLazIntfImage.EndUpdate;
begin
dec(FUpdateCount);
if (FUpdateCount=0) then begin
if fCreateAllDataNeeded then
CreateAllData;
if FGetSetColorFunctionsUpdateNeeded then
ChooseGetSetColorFunctions;
end;
end;
procedure TLazIntfImage.SetSize(AWidth, AHeight: integer);
begin
if (AWidth=Width) and (AHeight=Height) then exit;
if (AWidth<0) or (AHeight<0) then
Raise FPImageException.Create('Invalid Size');
inherited SetSize(AWidth, AHeight);
FDataDescription.Width:=Width;
FDataDescription.Height:=Height;
CreateAllData;
end;
function TLazIntfImage.CheckDescription(
const ADescription: TRawImageDescription; ExceptionOnError: boolean
): boolean;
procedure DoError(const Msg: string);
begin
if ExceptionOnError then Raise FPImageException.Create(Msg);
DebugLn('TLazIntfImage.CheckDescription: ',Msg);
end;
begin
Result:=false;
// check format
if (not (ADescription.Format
in [low(TRawImageColorFormat)..high(TRawImageColorFormat)]))
then begin
DoError('Invalid Raw Image Description Format'); exit;
end;
Result:=true;
end;
procedure TLazIntfImage.GetXYDataPostion(x, y: integer;
var Position: TRawImagePosition);
var
BitOffset: cardinal;
begin
if FDataDescription.LineOrder=riloBottomToTop then
y:=Height-y;
Position:=FLineStarts[y];
BitOffset:=FDataDescription.BitsPerPixel*cardinal(x)+Position.Bit;
Position.Bit:=(BitOffset and 7);
inc(Position.Byte,BitOffset shr 3);
end;
procedure TLazIntfImage.GetXYMaskPostion(x, y: integer;
var Position: TRawImagePosition);
var
BitOffset: cardinal;
begin
if FDataDescription.LineOrder=riloBottomToTop then
y:=Height-y;
Position:=FMaskLineStarts[y];
BitOffset:=FDataDescription.AlphaBitsPerPixel*cardinal(x)+Position.Bit;
Position.Bit:=(BitOffset and 7);
inc(Position.Byte,BitOffset shr 3);
end;
procedure TLazIntfImage.LoadFromDevice(DC: HDC);
var
ARect: TRect;
ARawImage: TRawImage;
DeviceSize: TPoint;
begin
GetDeviceSize(DC,DeviceSize);
ARect:=Rect(0,0,DeviceSize.X,DeviceSize.Y);
if not GetRawImageFromDevice(DC,ARect,ARawImage) then
raise FPImageException.Create('Failed to get raw image from device');
SetRawImage(ARawImage);
end;
procedure TLazIntfImage.LoadFromBitmap(Bitmap, MaskBitmap: HBitmap);
var
ARect: TRect;
ARawImage: TRawImage;
NewDataDescription: TRawImageDescription;
begin
if not GetBitmapRawImageDescription(Bitmap,@NewDataDescription) then
raise FPImageException.Create('Failed to get raw image description from bitmap');
ARect:=Rect(0,0,NewDataDescription.Width,NewDataDescription.Height);
if not GetRawImageFromBitmap(Bitmap,MaskBitmap,ARect,ARawImage) then
raise FPImageException.Create('Failed to get raw image from bitmap');
SetRawImage(ARawImage);
end;
procedure TLazIntfImage.CreateBitmap(var Bitmap, MaskBitmap: HBitmap;
AlwaysCreateMask: boolean);
var
ARawImage: TRawImage;
begin
GetRawImage(ARawImage);
if not CreateBitmapFromRawImage(ARawImage,Bitmap,MaskBitmap,AlwaysCreateMask)
then
raise FPImageException.Create('Failed to create bitmaps');
end;
procedure TLazIntfImage.SetRawImage(const RawImage: TRawImage);
var
OldRawImage: TRawImage;
begin
GetRawImage(OldRawImage);
if CompareMem(@OldRawImage,@RawImage,SizeOf(TRawImage)) then exit;
BeginUpdate;
try
FreeAllData;
fDataDescription:=RawImage.Description;
FPixelData:=RawImage.Data;
FPixelDataSize:=RawImage.DataSize;
FMaskData:=RawImage.Mask;
FMaskDataSize:=RawImage.MaskSize;
SetSize(FDataDescription.Width,FDataDescription.Height);
fCreateAllDataNeeded:=false;
CreateRawImageLineStarts(Width,Height,FDataDescription.BitsPerPixel,
FDataDescription.LineEnd,FLineStarts);
if (FMaskData<>nil) then
CreateRawImageLineStarts(Width,Height,FDataDescription.AlphaBitsPerPixel,
FDataDescription.AlphaLineEnd,FMaskLineStarts);
ChooseGetSetColorFunctions;
finally
EndUpdate;
end;
end;
procedure TLazIntfImage.GetRawImage(var RawImage: TRawImage);
begin
FillChar(RawImage,SizeOf(TRawImage),0);
RawImage.Description:=FDataDescription;
RawImage.Data:=FPixelData;
RawImage.DataSize:=FPixelDataSize;
RawImage.Mask:=FMaskData;
RawImage.MaskSize:=FMaskDataSize;
end;
procedure TLazIntfImage.GetDescriptionFromDevice(DC: HDC);
var
NewDataDescription: TRawImageDescription;
begin
if DC=0 then begin
DC:=GetDC(0);
try
if not GetDeviceRawImageDescription(DC,@NewDataDescription) then
raise FPImageException.Create('Failed to get raw image description from device');
finally
ReleaseDC(0,DC);
end;
end else begin
if not GetDeviceRawImageDescription(DC,@NewDataDescription) then
raise FPImageException.Create('Failed to get raw image description from device');
end;
DataDescription:=NewDataDescription;
end;
procedure TLazIntfImage.GetDescriptionFromBitmap(Bitmap: HBitmap);
var
NewDataDescription: TRawImageDescription;
begin
if not GetBitmapRawImageDescription(Bitmap,@NewDataDescription) then
raise FPImageException.Create('Failed to get raw image description from bitmap');
DataDescription:=NewDataDescription;
end;
procedure TLazIntfImage.FillPixels(const Color: TFPColor);
var
ColorChar: char;
ColorWord: Word;
Cnt: Integer;
i: Integer;
ColorDWord: Cardinal;
y: Integer;
x: Integer;
begin
if (Width=0) or (Height=0) or (FPixelData=nil) then exit;
case FDataDescription.BitsPerPixel of
8:
begin
SetInternalColor(0,0,Color);
ColorChar:=Char(FPixelData[0]);
FillChar(FPixelData^,FPixelDataSize,ColorChar);
end;
16:
begin
SetInternalColor(0,0,Color);
ColorWord:=PWord(FPixelData)[0];
Cnt:=FPixelDataSize div 2;
for i:=0 to Cnt-1 do
PWord(FPixelData)[i]:=ColorWord;
end;
32:
begin
SetInternalColor(0,0,Color);
ColorDWord:=PDWord(FPixelData)[0];
Cnt:=FPixelDataSize div 4;
for i:=0 to Cnt-1 do
PDWord(FPixelData)[i]:=ColorDWord;
end;
else
for y:=0 to Height-1 do
for x:=0 to Width-1 do
SetInternalColor(x,y,Color);
end;
// ToDo: mask
end;
{ TLazReaderXPM }
type
TXPMPixelToColorEntry = record
Color: TFPColor;
end;
PXPMPixelToColorEntry = ^TXPMPixelToColorEntry;
procedure TLazReaderXPM.ClearPixelToColorTree;
var
Entry: PXPMPixelToColorEntry;
ArrNode: TArrayNode;
begin
if FPixelToColorTree<>nil then begin
ArrNode:=FPixelToColorTree.Root;
while ArrNode<>nil do begin
Entry:=PXPMPixelToColorEntry(ArrNode.Data);
if Entry<>nil then begin
//DebugLn('TLazReaderXPM.ClearPixelToColorTree A ',HexStr(Cardinal(ArrNode),8),' ',HexStr(Cardinal(Entry),8));
Dispose(Entry);
end;
ArrNode:=ArrNode.FindNext;
end;
FPixelToColorTree.Free;
FPixelToColorTree:=nil;
end;
end;
procedure TLazReaderXPM.InternalRead(Str: TStream; Img: TFPCustomImage);
type
TSrcLine = record
StartPos: integer;
EndPos: integer;
end;
var
SrcPos: integer;
Src: String;
SrcLen: Integer;
CurLineNumber, LastLineStart: integer;
procedure RaiseXPMReadError(const Msg: string; ReadPos: integer);
var
CurColumn: Integer;
begin
CurColumn:=ReadPos-LastLineStart+1;
raise Exception.Create(Msg
+' in xpm stream at line '+IntToStr(CurLineNumber)
+' column '+IntToStr(CurColumn));
end;
// read next string constant "" and skip comments
function ReadNextLine(var Line: TSrcLine;
ExceptionOnNotFound: Boolean): boolean;
begin
while SrcPos<=SrcLen do begin
case Src[SrcPos] of
#10,#13:
begin
// count linenumbers for nicer error output
inc(SrcPos);
inc(CurLineNumber);
if (SrcPos<=SrcLen) and (Src[SrcPos] in [#10,#13])
and (Src[SrcPos]<>Src[SrcPos-1]) then
inc(SrcPos);
LastLineStart:=SrcPos;
end;
'/':
begin
if (SrcPos<SrcLen) and (Src[SrcPos+1]='*') then begin
// this is a C comment
// -> skip comment
inc(SrcPos,2);
while (SrcPos<SrcLen) do begin
if (Src[SrcPos]='*') and (Src[SrcPos+1]='/') then begin
// comment end found
inc(SrcPos,2);
break;
end;
inc(SrcPos);
end;
end else
RaiseXPMReadError('syntax error',SrcPos);
end;
'"':
begin
// start of a string constant
inc(SrcPos);
Line.StartPos:=SrcPos;
while (SrcPos<SrcLen) do begin
if (Src[SrcPos]='"') and (Src[SrcPos-1]<>'\') then begin
// string end found
Line.EndPos:=SrcPos;
//DebugLn(' "',copy(Src,Line.StartPos,SrcPos-Line.StartPos),'"');
inc(SrcPos);
Result:=true;
exit;
end;
inc(SrcPos);
end;
end;
else
inc(SrcPos);
end;
end;
Result:=false;
if ExceptionOnNotFound then
Raise Exception.Create('Unexpected end of xpm stream');
end;
function ReadNumber(var ReadPos: integer;
ExceptionOnNotFound: Boolean): integer;
begin
// skip spaces
while IsSpaceChar[Src[ReadPos]] do inc(ReadPos);
// read number
Result:=0;
if IsNumberChar[Src[ReadPos]] then begin
repeat
Result:=Result*10+ord(Src[ReadPos])-Ord('0');
inc(ReadPos);
until not IsNumberChar[Src[ReadPos]];
end else if ExceptionOnNotFound then
RaiseXPMReadError('number expected',ReadPos);
end;
procedure ReadHeader;
var
FirstLine: TSrcLine;
begin
ReadNextLine(FirstLine,true);
FWidth:=ReadNumber(FirstLine.StartPos,true);
FHeight:=ReadNumber(FirstLine.StartPos,true);
FColorCount:=ReadNumber(FirstLine.StartPos,true);
FCharsPerPixel:=ReadNumber(FirstLine.StartPos,true);
fXHot:=ReadNumber(FirstLine.StartPos,false);
fYHot:=ReadNumber(FirstLine.StartPos,fXHot<>0);
//DebugLn('ReadHeader A Width=',FWidth,' Height=',FHeight,' ColorCount=',FColorCount,' CharsPerPixel=',FCharsPerPixel);
// ToDo: parse XPMExt tag
end;
function HexToColor(HexStart, HexEnd: integer): TFPColor;
procedure ReadHexNumber(var StartPos: integer; Len: integer;
var Number: word);
var
c: Char;
i: Integer;
begin
Number:=0;
for i:=1 to 4 do begin
Number:=Number shl 4;
if i<=Len then begin
c:=Src[StartPos];
case c of
'0'..'9': inc(Number,ord(c)-ord('0'));
'A'..'F': inc(Number,ord(c)-ord('A')+10);
'a'..'f': inc(Number,ord(c)-ord('a')+10);
end;
inc(StartPos);
end;
end;
// fill missing bits
case Len of
1: Number:=Number or (Number shr 4) or (Number shr 8) or (Number shr 12);
2: Number:=Number or (Number shr 8);
3: Number:=Number or (Number shr 12);
end;
end;
var
HexLen: Integer;
SampleLen: Integer;
SampleStart: Integer;
begin
HexLen:=HexEnd-HexStart;
case HexLen of
3: SampleLen:=1;
6: SampleLen:=2;
9: SampleLen:=3;
12:SampleLen:=4;
else
RaiseXPMReadError('hexnumber expected',HexStart);
end;
SampleStart:=HexStart;
ReadHexNumber(SampleStart,SampleLen,Result.Red);
ReadHexNumber(SampleStart,SampleLen,Result.Green);
ReadHexNumber(SampleStart,SampleLen,Result.Blue);
Result.Alpha:=alphaOpaque;
end;
function TextToColor(TextStart, TextEnd: integer): TFPColor;
var
s: String;
begin
s := lowercase(copy(Src,TextStart,TextEnd-TextStart));
if s = 'transparent' then
Result := FPImage.colTransparent
else if s = 'none' then
Result := FPImage.colTransparent
else if s = 'black' then
result := FPImage.colBlack
else if s = 'blue' then
Result := FPImage.colBlue
else if s = 'green' then
Result := FPImage.colGreen
else if s = 'cyan' then
Result := FPImage.colCyan
else if s = 'red' then
Result := FPImage.colRed
else if s = 'magenta' then
Result := FPImage.colMagenta
else if s = 'yellow' then
Result := FPImage.colYellow
else if s = 'white' then
Result := FPImage.colWhite
else if s = 'gray' then
Result := FPImage.colGray
else if s = 'lightgray' then
Result := FPImage.colLtGray
else if (s = 'darkgray') or (s='grey') then
Result := FPImage.colDKGray
else if s = 'darkblue' then
Result := FPImage.colDkBlue
else if s = 'darkgreen' then
Result := FPImage.colDkGreen
else if s = 'darkcyan' then
Result := FPImage.colDkCyan
else if s = 'darkred' then
Result := FPImage.colDkRed
else if s = 'darkmagenta' then
Result := FPImage.colDkMagenta
else if s = 'darkyellow' then
Result := FPImage.colDkYellow
else if s = 'maroon' then
Result := FPImage.colMaroon
else if s = 'lightgreen' then
Result := FPImage.colLtGreen
else if s = 'olive' then
Result := FPImage.colOlive
else if s = 'navy' then
Result := FPImage.colNavy
else if s = 'purple' then
Result := FPImage.colPurple
else if s = 'teal' then
Result := FPImage.colTeal
else if s = 'silver' then
Result := FPImage.colSilver
else if s = 'lime' then
Result := FPImage.colLime
else if s = 'fuchsia' then
Result := FPImage.colFuchsia
else if s = 'aqua' then
Result := FPImage.colAqua
else
Result := FPImage.colTransparent;
end;
procedure AddColor(PixelStart: integer; const AColor: TFPColor;
IntArray: PInteger);
var
NewEntry: PXPMPixelToColorEntry;
i: Integer;
begin
{DebugLn('TLazReaderXPM.InternalRead.AddColor A "',PixelString,'"=',
HexStr(Cardinal(AColor.Red),4),',',
HexStr(Cardinal(AColor.Green),4),',',
HexStr(Cardinal(AColor.Blue),4),',',
HexStr(Cardinal(AColor.Alpha),4));}
New(NewEntry);
NewEntry^.Color:=AColor;
// add entry to Array Tree
if FPixelToColorTree=nil then
FPixelToColorTree:=TArrayNodesTree.Create;
for i:=0 to FCharsPerPixel-1 do
IntArray[i]:=ord(Src[PixelStart+i]);
FPixelToColorTree.SetNode(IntArray,FCharsPerPixel,NewEntry);
end;
procedure ReadPalette(IntArray: PInteger);
var
i: Integer;
Line: TSrcLine;
ReadPos: Integer;
ColorStart: Integer;
ColorEnd: Integer;
NewColor: TFPColor;
PixelStart: Integer;
begin
for i:=1 to FColorCount do begin
ReadNextLine(Line,true);
ReadPos:=Line.StartPos;
// read pixel string
PixelStart:=ReadPos;
inc(ReadPos,FCharsPerPixel);
// skip spaces
while IsSpaceChar[Src[ReadPos]] do inc(ReadPos);
// read 'c' (sometimes the 'c' is a 's')
if not (Src[ReadPos] in ['c','s']) then
RaiseXPMReadError('"c" expected',ReadPos);
inc(ReadPos);
// skip spaces
while IsSpaceChar[Src[ReadPos]] do inc(ReadPos);
// read color string
ColorStart:=ReadPos;
if Src[ReadPos]='#' then begin
inc(ColorStart);
// read as hexnumber
repeat
inc(ReadPos);
until not (IsHexNumberChar[Src[ReadPos]]);
ColorEnd:=ReadPos;
NewColor:=HexToColor(ColorStart,ColorEnd);
end else begin
// read as text
repeat
inc(ReadPos);
until not (Src[ReadPos] in ['A'..'Z','a'..'z']);
ColorEnd:=ReadPos;
NewColor:=TextToColor(ColorStart,ColorEnd);
end;
AddColor(PixelStart,NewColor,IntArray);
end;
end;
procedure ReadPixels(IntArray: PInteger);
var
y: Integer;
Line: TSrcLine;
ReadPos: Integer;
x: Integer;
i: Integer;
CurColor: TFPColor;
ProgressCount: Integer;
ContinueReading: Boolean;
CurEntry: PXPMPixelToColorEntry;
begin
Img.SetSize(FWidth,fHeight);
ProgressCount:=10000;
for y:=0 to fHeight-1 do begin
ReadNextLine(Line,true);
ReadPos:=Line.StartPos;
if Line.EndPos-Line.StartPos<FCharsPerPixel*FWidth then
RaiseXPMReadError('line too short',ReadPos);
for x:=0 to FWidth-1 do begin
for i:=0 to FCharsPerPixel-1 do begin
IntArray[i]:=ord(Src[ReadPos]);
inc(ReadPos);
end;
CurEntry:=PXPMPixelToColorEntry(
FPixelToColorTree.FindData(IntArray,FCharsPerPixel));
CurColor:=CurEntry^.Color;
{if CurEntry2<>CurEntry then begin
DebugLn('x=',x,' y=',y,' Pixel=',Entry^.Pixel,
' RefPixel=',CurEntry^.Pixel,
' Color=',
HexStr(Cardinal(CurColor.Red),4),',',
HexStr(Cardinal(CurColor.Green),4),',',
HexStr(Cardinal(CurColor.Blue),4),',',
HexStr(Cardinal(CurColor.Alpha),4));
DebugLn('Entry2: Pixel=',CurEntry2^.Pixel,
' RefPixel=',CurEntry2^.Pixel,
' Color=',
HexStr(Cardinal(CurEntry2^.Color.Red),4),',',
HexStr(Cardinal(CurEntry2^.Color.Green),4),',',
HexStr(Cardinal(CurEntry2^.Color.Blue),4),',',
HexStr(Cardinal(CurEntry2^.Color.Alpha),4));
end;}
{DebugLn('x=',x,' y=',y,' Pixel=',Entry^.Pixel,
' RefPixel=',PXPMPixelToColorEntry(Node.Data)^.Pixel,
' Color=',
HexStr(Cardinal(CurColor.Red),4),',',
HexStr(Cardinal(CurColor.Green),4),',',
HexStr(Cardinal(CurColor.Blue),4),',',
HexStr(Cardinal(CurColor.Alpha),4));}
Img.Colors[x,y]:=CurColor;
end;
if ProgressCount>0 then begin
dec(ProgressCount,FWidth);
end else begin
if Assigned(Img.OnProgress) then begin
ContinueReading:=true;
Img.OnProgress(Self,FPImage.psRunning,Byte((y*100) div FHeight),
true,Rect(0,0,FWidth,y),'reading XPM pixels',ContinueReading);
if not ContinueReading then exit;
end;
ProgressCount:=10000;
end;
end;
end;
var
IntArray: PInteger;
begin
ClearPixelToColorTree;
Src:=ReadCompleteStreamToString(Str,1024);
SrcLen:=length(Src);
SrcPos:=1;
CurLineNumber:=1;
LastLineStart:=1;
ReadHeader;
GetMem(IntArray,SizeOf(Integer)*(FCharsPerPixel+1));
try
ReadPalette(IntArray);
//FPixelToColorTree.ConsistencyCheck;
ReadPixels(IntArray);
finally
FreeMem(IntArray);
end;
end;
function TLazReaderXPM.InternalCheck(Str: TStream): boolean;
var s : string[9];
l : integer;
begin
try
l := str.Read (s[1],9);
s[0] := char(l);
if l <> 9 then
result := False
else
result := (s = '/* XPM */');
except
result := false;
end;
end;
constructor TLazReaderXPM.Create;
begin
inherited Create;
end;
destructor TLazReaderXPM.Destroy;
begin
ClearPixelToColorTree;
inherited Destroy;
end;
{ TLazAVLPalette }
type
TLazAVLPaletteEntry = record
Palette: TLazAVLPalette;
Index: integer;
end;
PLazAVLPaletteEntry = ^TLazAVLPaletteEntry;
function CompareLazAVLPaletteEntries(Entry1, Entry2: PLazAVLPaletteEntry): integer;
begin
Result := Entry1^.Palette.CompareEntries(Entry1^.Index, Entry2^.Index);
end;
function ComparePFPColorAndLazAVLPalEntry(PColor: PFPColor; Entry: PLazAVLPaletteEntry): integer;
begin
Result := Entry^.Palette.CompareColorWithEntries(PColor^, Entry^.Index);
end;
procedure TLazAVLPalette.SetCount(NewCount: integer);
var
NewAVLPalEntry: PLazAVLPaletteEntry;
AVLNode: TAvgLvlTreeNode;
CurAVLPalEntry: PLazAVLPaletteEntry;
Index: Integer;
begin
if FCount=NewCount then exit;
// remove unused colors from 'color to index' tree
if FAVLPalette<>nil then begin
for Index:=FCount-1 downto NewCount do begin
AVLNode:=FAVLNodes[Index];
CurAVLPalEntry:=PLazAVLPaletteEntry(AVLNode.Data);
FAVLPalette.Delete(AVLNode);
FAVLNodes[Index]:=nil;
Dispose(CurAVLPalEntry);
end;
end;
inherited SetCount(NewCount);
// create tree if not already done
if (FAVLPalette=nil) and (FCount>0) then
FAVLPalette:=TAvgLvlTree.Create(TListSortCompare(@CompareLazAVLPaletteEntries));
if FAVLPalette=nil then exit;
// add new colors to 'color to index' tree and 'index to node' array
while FAVLPalette.Count<FCount do begin
Index:=FAVLPalette.Count;
New(NewAVLPalEntry);
NewAVLPalEntry^.Palette:=Self;
NewAVLPalEntry^.Index:=Index;
FAVLNodes[Index]:=FAVLPalette.Add(NewAVLPalEntry);
end;
end;
procedure TLazAVLPalette.SetColor(Index: integer; const NewColor: TFPColor);
var
Node: TAvgLvlTreeNode;
Entry: PLazAVLPaletteEntry;
begin
if Index=FCount then
Add(NewColor)
else begin
CheckIndex(Index);
if FData^[Index]=NewColor then exit;
// remove node from tree
Node:=FAVLNodes[Index];
Entry:=PLazAVLPaletteEntry(Node.Data);
FAVLPalette.Delete(Node);
// change color
FData^[index] := NewColor;
// add node
FAVLNodes[Index]:=FAVLPalette.Add(Entry);
end;
end;
destructor TLazAVLPalette.Destroy;
begin
SetCount(0);
FAVLPalette.Free;
FAVLPalette:=nil;
inherited Destroy;
end;
function TLazAVLPalette.IndexOf(const AColor: TFPColor): integer;
var
Node: TAvgLvlTreeNode;
begin
if FAVLPalette<>nil then
Node:=FAVLPalette.FindKey(@AColor,TListSortCompare(@ComparePFPColorAndLazAVLPalEntry))
else
Node:=nil;
if Node<>nil then
Result:=PLazAVLPaletteEntry(Node.Data)^.Index
else
Result:=Add(AColor);
end;
function TLazAVLPalette.Add(const NewColor: TFPColor): integer;
begin
Result:=FCount;
if FCount=FCapacity then EnlargeData;
SetCount(FCount+1);
SetColor(Result,NewColor);
end;
function TLazAVLPalette.CompareEntries(Index1, Index2: integer): integer;
begin
Result:=CompareColors(FData^[Index1],FData^[Index2]);
end;
function TLazAVLPalette.CompareColorWithEntries(const AColor: TFPColor;
Index: integer): integer;
begin
Result:=CompareColors(AColor,FData^[Index]);
end;
procedure TLazAVLPalette.EnlargeData;
var
NewCapacity: Integer;
begin
if FCapacity<16 then
NewCapacity:=32
else if FCapacity<64 then
NewCapacity:=128
else
NewCapacity:=FCapacity*2;
ReallocMem(FData,SizeOf(TFPColor)*NewCapacity);
ReallocMem(FAVLNodes,SizeOf(Pointer)*NewCapacity);
FCapacity:=NewCapacity;
end;
procedure TLazAVLPalette.CheckConsistency;
var
Node: TAvgLvlTreeNode;
Entry: PLazAVLPaletteEntry;
i: Integer;
begin
if FAVLPalette<>nil then begin
if FAVLPalette.ConsistencyCheck<>0 then
RaiseGDBException('TLazAVLPalette.ConsistencyCheck');
if FAVLPalette.Count<>FCount then
RaiseGDBException('TLazAVLPalette.ConsistencyCheck');
end;
if FAVLNodes<>nil then begin
for i:=0 to FCapacity-1 do begin
Node:=FAVLNodes[i];
if i>=FCount then begin
continue;
end;
if Node=nil then
RaiseGDBException('TLazAVLPalette.ConsistencyCheck');
Entry:=PLazAVLPaletteEntry(Node.Data);
if Entry=nil then
RaiseGDBException('TLazAVLPalette.ConsistencyCheck');
if Entry^.Index<>i then
RaiseGDBException('TLazAVLPalette.ConsistencyCheck');
if Entry^.Palette<>Self then
RaiseGDBException('TLazAVLPalette.ConsistencyCheck');
end;
end;
end;
{ TLazWriterXPM }
const
DefXPMPalChars = '.,-*abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'
+'0123456789@#;:=+%$()[]';
procedure TLazWriterXPM.SetNibblesPerSample(const AValue: word);
begin
if FNibblesPerSample=AValue then exit;
FNibblesPerSample:=AValue;
if FNibblesPerSample>4 then FNibblesPerSample:=4;
FRightShiftSample:=(4-FNibblesPerSample)*4;
end;
procedure TLazWriterXPM.InternalWrite(Str: TStream; Img: TFPCustomImage);
var
Palette: TLazAVLPalette;
PixelStrings: ^AnsiString;
ColorStrings: ^AnsiString;
CharsPerPixel: Integer;
LineEnd: string;
function GetColor(x,y: integer): TFPColor;
begin
Result:=Img.Colors[x,y];
if (Result.Alpha>=(alphaOpaque shr 1)) then
Result.Alpha:=alphaOpaque
else
Result:=colTransparent;
Result.Red:=Result.Red shr FRightShiftSample;
Result.Green:=Result.Green shr FRightShiftSample;
Result.Blue:=Result.Blue shr FRightShiftSample;
end;
function SampleToHex(Sample: word): string;
begin
Result:=HexStr(Sample,FNibblesPerSample);
end;
procedure BuildPalette;
var
x: Integer;
y: Integer;
PixelStringsSize: Integer;
i: Integer;
Rest: Integer;
c: char;
CharPos: Integer;
ColorStringsSize: Integer;
Color: TFPColor;
begin
// create Palette
Palette:=TLazAVLPalette.Create(0);
for y:=0 to Img.Height-1 do
for x:=0 to Img.Width-1 do
Palette.IndexOf(GetColor(x,y));
// calclulate CharsPerPixel
CharsPerPixel:=0;
i:=Palette.Count;
while i>0 do begin
i:=i div length(DefXPMPalChars);
inc(CharsPerPixel);
end;
// create pixel strings
PixelStringsSize:=SizeOf(Pointer)*Palette.Count;
ReAllocMem(PixelStrings,PixelStringsSize);
FillChar(PixelStrings^,PixelStringsSize,0);
for i:=0 to Palette.Count-1 do begin
SetLength(PixelStrings[i],CharsPerPixel);
Rest:=i;
for CharPos:=CharsPerPixel downto 1 do begin
c:=DefXPMPalChars[(Rest mod length(DefXPMPalChars))+1];
PixelStrings[i][CharPos]:=c;
Rest:=Rest div length(DefXPMPalChars);
end;
end;
// create color strings
ColorStringsSize:=SizeOf(Pointer)*Palette.Count;
ReAllocMem(ColorStrings,ColorStringsSize);
FillChar(ColorStrings^,ColorStringsSize,0);
for i:=0 to Palette.Count-1 do begin
Color:=Palette[i];
if Color.Alpha=0 then begin
ColorStrings[i]:='None';
end else begin
ColorStrings[i]:='#'+SampleToHex(Color.Red)+SampleToHex(Color.Green)
+SampleToHex(Color.Blue);
end;
end;
end;
procedure WriteString(const s: string);
begin
Str.Write(s[1],length(s));
end;
procedure WriteHeader;
var
s: String;
begin
s:='/* XPM */'+LineEnd;
s:=s+'static char *graphic[] = {'+LineEnd;
s:=s+'"'+IntToStr(Img.Width)+' '+IntToStr(Img.Height)
+' '+IntToStr(Palette.Count)+' '+IntToStr(CharsPerPixel)+'"';
if Palette.Count>0 then s:=s+',';
s:=s+LineEnd;
WriteString(s);
end;
procedure WritePalette;
var
s: string;
SrcPos: Integer;
procedure WriteToSrc(const AddString: string);
var
i: Integer;
begin
for i:=1 to length(AddString) do begin
s[SrcPos]:=AddString[i];
inc(SrcPos);
end;
end;
var
PaletteLineLen: Integer;
i: Integer;
SrcLen: Integer;
begin
// calculate needed memory
PaletteLineLen:=length('"')+CharsPerPixel+length(' c ')+length('",'+LineEnd);
SrcLen:=0;
for i:=0 to Palette.Count-1 do begin
inc(SrcLen,PaletteLineLen);
inc(SrcLen,length(ColorStrings[i]));
end;
// build palette source
SetLength(s,SrcLen);
SrcPos:=1;
for i:=0 to Palette.Count-1 do begin
WriteToSrc('"');
WriteToSrc(PixelStrings[i]);
WriteToSrc(' c ');
WriteToSrc(ColorStrings[i]);
WriteToSrc('",');
WriteToSrc(LineEnd);
end;
if SrcPos<>length(s)+1 then
RaiseGDBException('TLazWriterXPM.InternalWrite consistency ERROR SrcPos<>length(s)');
WriteString(s);
end;
procedure WritePixels;
var
s: string;
SrcPos: Integer;
procedure WriteToSrc(const AddString: string);
var
i: Integer;
begin
for i:=1 to length(AddString) do begin
s[SrcPos]:=AddString[i];
inc(SrcPos);
end;
end;
var
y: Integer;
x: Integer;
i: Integer;
SrcLenPerLine: Integer;
SrcLen: Integer;
begin
// calculate needed memory
SrcLenPerLine:=length('"')+CharsPerPixel*Img.Width+length('",')+length(LineEnd);
SrcLen:=Img.Height*SrcLenPerLine;
// build palette source
SetLength(s,SrcLen);
SrcPos:=1;
for y:=0 to Img.Height-1 do begin
WriteToSrc('"');
for x:=0 to Img.Width-1 do begin
i:=Palette.IndexOf(GetColor(x,y));
WriteToSrc(PixelStrings[i]);
end;
if y<Img.Height-1 then
WriteToSrc('",'+LineEnd)
else
WriteToSrc('"}'+LineEnd);
end;
if SrcPos<>length(s)+1 then
RaiseGDBException('TLazWriterXPM.InternalWrite consistency ERROR SrcPos<>length(s)');
WriteString(s);
end;
var
i: Integer;
begin
Palette:=nil;
PixelStrings:=nil;
ColorStrings:=nil;
LineEnd:=#10;
try
BuildPalette;
WriteHeader;
WritePalette;
WritePixels;
finally
if PixelStrings<>nil then begin
for i:=0 to Palette.Count-1 do begin
PixelStrings[i]:='';
ColorStrings[i]:='';
end;
ReAllocMem(PixelStrings,0);
ReAllocMem(ColorStrings,0);
end;
Palette.Free;
end;
end;
constructor TLazWriterXPM.Create;
begin
inherited Create;
FNibblesPerSample:=2;
FRightShiftSample:=8;
end;
{ TArrayNode }
constructor TArrayNode.Create;
begin
//DebugLn('TArrayNode.Create ',Capacity,' Self=',HexStr(Cardinal(Self),8));
end;
destructor TArrayNode.Destroy;
begin
DeleteChilds;
UnbindFromParent;
inherited Destroy;
end;
procedure TArrayNode.DeleteChilds;
var
i: Integer;
begin
if Childs<>nil then begin
for i:=0 to Capacity-1 do
Childs[i].Free;
FreeMem(Childs);
Childs:=nil;
Capacity:=0;
end;
end;
procedure TArrayNode.UnbindFromParent;
begin
if Parent<>nil then begin
Parent.Childs[Value-Parent.StartValue]:=nil;
Parent:=nil;
end;
end;
procedure TArrayNode.CreateChildNode(ChildValue: integer);
var
NewNode: TArrayNode;
Index: Integer;
begin
NewNode:=TArrayNode.Create;
NewNode.Value:=ChildValue;
NewNode.Parent:=Self;
Index:=ChildValue-StartValue;
Childs[Index]:=NewNode;
end;
function TArrayNode.GetChildNode(ChildValue: integer; CreateIfNotExists: boolean
): TArrayNode;
var
Index: Integer;
begin
Result:=nil;
Index:=ChildValue-StartValue;
if (Index<0) or (Index>=Capacity) then begin
// out of range
if not CreateIfNotExists then exit;
Expand(ChildValue);
Index:=ChildValue-StartValue;
end;
Result:=Childs[Index];
if (Result=nil) and CreateIfNotExists then begin
CreateChildNode(ChildValue);
Result:=Childs[Index];
end;
end;
procedure TArrayNode.Expand(ValueToInclude: integer);
var
Index: Integer;
NewChilds: PArrayNode;
NewSize: Integer;
i: Integer;
NewStartValue: Integer;
NewCapacity: Integer;
OldSize: Integer;
begin
//DebugLn('TArrayNode.Expand A ',ValueToInclude,' Capacity=',Capacity,' StartValue=',StartValue);
if Childs=nil then begin
NewStartValue:=ValueToInclude;
NewCapacity:=4;
end else begin
Index:=ValueToInclude-StartValue;
if (Index>=0) and (Index<Capacity) then exit;
NewStartValue:=StartValue;
NewCapacity:=Capacity;
if NewStartValue>ValueToInclude then begin
inc(NewCapacity,NewStartValue-ValueToInclude);
NewStartValue:=ValueToInclude;
end else begin
Index:=ValueToInclude-NewStartValue;
if Index>=NewCapacity then
NewCapacity:=Index+1;
end;
// make NewCapacity a power of 2
for i:=1 to 30 do begin
if (1 shl i)>=NewCapacity then begin
NewCapacity:=1 shl i;
break;
end;
end;
end;
NewSize:=SizeOf(Pointer)*NewCapacity;
GetMem(NewChilds,NewSize);
FillChar(NewChilds^,NewSize,0);
if Childs<>nil then begin
OldSize:=SizeOf(Pointer)*Capacity;
System.Move(Childs^,NewChilds[StartValue-NewStartValue],OldSize);
FreeMem(Childs);
end;
Childs:=NewChilds;
StartValue:=NewStartValue;
Capacity:=NewCapacity;
end;
function TArrayNode.FindPrevSibling: TArrayNode;
var
i: Integer;
begin
Result:=nil;
if Parent=nil then exit;
i:=Value-Parent.StartValue-1;
while (i>=0) do begin
if Parent.Childs[i]<>nil then begin
Result:=Parent.Childs[i];
exit;
end;
dec(i);
end;
end;
function TArrayNode.FindNextSibling: TArrayNode;
var
i: Integer;
begin
Result:=nil;
if Parent=nil then exit;
i:=Value-Parent.StartValue+1;
while (i<Parent.Capacity) do begin
if Parent.Childs[i]<>nil then begin
Result:=Parent.Childs[i];
exit;
end;
inc(i);
end;
end;
function TArrayNode.FindNext: TArrayNode;
var
SiblingNode: TArrayNode;
begin
Result:=FindFirstChild;
if Result<>nil then exit;
SiblingNode:=Self;
while SiblingNode<>nil do begin
Result:=SiblingNode.FindNextSibling;
if Result<>nil then exit;
SiblingNode:=SiblingNode.Parent;
end;
end;
function TArrayNode.FindPrev: TArrayNode;
begin
Result:=FindPrevSibling;
if Result=nil then begin
Result:=Parent;
exit;
end;
Result:=Result.FindLastSubChild;
end;
function TArrayNode.FindFirstChild: TArrayNode;
var
i: Integer;
begin
Result:=nil;
if Capacity=0 then exit;
i:=0;
while i<Capacity do begin
if Childs[i]<>nil then begin
Result:=Childs[i];
exit;
end;
inc(i);
end;
end;
function TArrayNode.FindLastChild: TArrayNode;
var
i: Integer;
begin
Result:=nil;
if Capacity=0 then exit;
i:=Capacity-1;
while i>=0 do begin
if Childs[i]<>nil then begin
Result:=Childs[i];
exit;
end;
dec(i);
end;
end;
function TArrayNode.FindLastSubChild: TArrayNode;
var
ANode: TArrayNode;
begin
ANode:=Self;
while ANode<>nil do begin
Result:=ANode;
ANode:=ANode.FindLastChild;
end;
end;
function TArrayNode.FindFirstSibling: TArrayNode;
begin
if Parent=nil then
Result:=nil
else
Result:=Parent.FindFirstChild;
end;
function TArrayNode.FindLastSibling: TArrayNode;
begin
if Parent=nil then
Result:=nil
else
Result:=Parent.FindLastChild;
end;
procedure TArrayNode.ConsistencyCheck;
procedure R(const Msg: string);
begin
RaiseGDBException(Msg);
end;
var
i: Integer;
ChildNode: TArrayNode;
begin
if Childs<>nil then begin
if Capacity<=0 then R('Capacity too small');
for i:=0 to Capacity-1 do begin
ChildNode:=Childs[i];
if ChildNode<>nil then begin
if ChildNode.Value<>i+StartValue then
R('Value wrong');
if ChildNode.Parent<>Self then
R('Parent wrong');
ChildNode.ConsistencyCheck;
end;
end;
end else begin
if Capacity<>0 then R('Capacity wrong');
end;
end;
{ TArrayNodesTree }
function TArrayNodesTree.FindNode(IntArray: PInteger; Count: integer
): TArrayNode;
var
i: Integer;
begin
Result:=Root;
i:=0;
while (Result<>nil) and (i<Count) do begin
Result:=Result.GetChildNode(IntArray[i],false);
inc(i);
end;
end;
function TArrayNodesTree.FindData(IntArray: PInteger; Count: integer): Pointer;
var
ANode: TArrayNode;
begin
ANode:=FindNode(IntArray,Count);
if ANode<>nil then
Result:=ANode.Data
else
Result:=nil;
end;
function TArrayNodesTree.SetNode(IntArray: PInteger; Count: integer;
Data: Pointer): TArrayNode;
var
i: Integer;
begin
if Root=nil then
Root:=TArrayNode.Create;
Result:=Root;
for i:=0 to Count-1 do begin
//DebugLn('TArrayNodesTree.SetNode A ',HexStr(Cardinal(Result),8));
Result:=Result.GetChildNode(IntArray[i],true);
end;
Result.Data:=Data;
end;
procedure TArrayNodesTree.Delete(Node: TArrayNode);
begin
if Node=nil then exit;
if Node=Root then Root:=nil;
Node.Free;
end;
procedure TArrayNodesTree.Clear;
begin
Delete(Root);
end;
constructor TArrayNodesTree.Create;
begin
end;
destructor TArrayNodesTree.Destroy;
begin
Clear;
inherited Destroy;
end;
procedure TArrayNodesTree.ConsistencyCheck;
begin
if Root<>nil then
Root.ConsistencyCheck;
end;
{ TLazReaderBMP }
function TLazReaderBMP.BmpRGBAToFPColor(Const 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;
// Specification for bitmap files has these bits always zero - unused
alpha := alphaOpaque;
end;
end;
Function BmpRGBToFPColor(Const RGB: TColorRGB) : TFPColor;
begin
with Result,RGB do
begin
Red := (R shl 8) + R;
Green := (G shl 8) + G;
Blue := (B shl 8) + B;
Alpha := AlphaOpaque;
end;
end;
Function Bmp16BitToFPColor(Const RGB: Word): TFPColor;
begin
// 5 bit for red -> 16 bit for TFPColor
Result.Red:=(RGB shr 11) and $1f;
Result.Red:=(Result.Red shl 11) or MissingBits[5,Result.Red shr 2];
// 6 bit for green -> 16 bit for TFPColor
Result.Green:=(RGB shr 5) and $3f;
Result.Green:=(Result.Green shl 10) or MissingBits[6,Result.Green shr 3];
// 5 bit for blue -> 16 bit for TFPColor
Result.Blue:=RGB and $1f;
Result.Blue:=(Result.Red shl 11) or MissingBits[5,Result.Blue shr 2];
// opaque, no mask
Result.Alpha:=alphaOpaque;
end;
procedure TLazReaderBMP.FreeBufs;
begin
If (LineBuf<>Nil) then
begin
FreeMem(LineBuf);
LineBuf:=Nil;
end;
If (FPalette<>Nil) then
begin
FreeMem(FPalette);
FPalette:=Nil;
end;
end;
procedure TLazReaderBMP.SetupRead(nPalette, nRowBits: Integer; Stream: TStream;
ReadPalette: Boolean);
{$ifdef VER1_0}
type
tcolinfo = ARRAY [0..0] OF TColorRGBA;
pcolinfo = ^tcolinfo;
var
ColInfo: pcolinfo;
{$else}
var
ColInfo: ARRAY OF TColorRGBA;
{$endif}
i: Integer;
FPcolor: TFPcolor;
begin
if nPalette>0 then
begin
GetMem(FPalette, nPalette*SizeOf(TFPColor));
{$ifdef VER1_0}
GetMem(ColInfo, nPalette*Sizeof(TColorRGBA));
if ReadPalette then begin
if BFI.biClrUsed>0 then
Stream.Read(ColInfo^[0],BFI.biClrUsed*SizeOf(TColorRGBA))
else // Seems to me that this is dangerous.
Stream.Read(ColInfo^[0],nPalette*SizeOf(TColorRGBA));
for i := 0 to nPalette-1 do begin
FPcolor := BmpRGBAToFPColor(ColInfo^[i]);
FPcolor.alpha := alphaOpaque; { No transparency info in palette }
FPalette[i] := FPcolor;
end;
end;
{$else}
SetLength(ColInfo, nPalette);
if ReadPalette then begin
if BFI.biClrUsed>0 then
Stream.Read(ColInfo[0],BFI.biClrUsed*SizeOf(TColorRGBA))
else // Seems to me that this is dangerous.
Stream.Read(ColInfo[0],nPalette*SizeOf(TColorRGBA));
for i := 0 to nPalette-1 do begin
FPcolor := BmpRGBAToFPColor(ColInfo[i]);
FPcolor.alpha := alphaOpaque; { No transparency info in palette }
FPalette[i] := FPcolor;
end;
end;
{$endif}
end
else if BFI.biClrUsed>0 then { Skip palette }
Stream.Position := Stream.Position
+ TStreamSeekType(BFI.biClrUsed*SizeOf(TColorRGBA));
ReadSize:=((nRowBits + 31) div 32) shl 2;
GetMem(LineBuf,ReadSize);
{$ifdef VER1_0}
FreeMem(ColInfo, nPalette*Sizeof(TColorRGBA));
{$endif}
end;
procedure TLazReaderBMP.ReadScanLine(Row: Integer; Stream: TStream);
begin
{
Add here support for compressed lines. The 'readsize' is the same in the end.
}
Stream.Read(LineBuf[0],ReadSize);
end;
procedure TLazReaderBMP.WriteScanLine(Row: Integer; Img: TFPCustomImage);
Var
Column : Integer;
begin
Case BFI.biBitCount of
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]
else
img.colors[Column,Row]:=FPalette[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];
8 :
for Column:=0 to img.Width-1 do
img.colors[Column,Row]:=FPalette[LineBuf[Column]];
16 :
for Column:=0 to img.Width-1 do
img.colors[Column,Row]:=Bmp16BitToFPColor(PWord(LineBuf)[Column]);
24 :
for Column:=0 to img.Width-1 do
img.colors[Column,Row]:=BmpRGBToFPColor(PColorRGB(LineBuf)[Column]);
32 :
for Column:=0 to img.Width-1 do
img.colors[Column,Row]:=BmpRGBAToFPColor(PColorRGBA(LineBuf)[Column]);
end;
end;
procedure TLazReaderBMP.InternalRead(Stream: TStream; Img: TFPCustomImage);
begin
Stream.Read(BFI,SizeOf(BFI));
InternalReadBody(Stream, Img);
end;
procedure TLazReaderBMP.InternalReadBody(Stream: TStream; Img: TFPCustomImage);
Var
Row : Integer;
begin
{ This will move past any junk after the BFI header }
Stream.Position:=Stream.Position+TStreamSeekType(BFI.biSize-SizeOf(BFI));
with BFI do
begin
if (biCompression<>0) then
Raise FPImageException.Create('Compressed bitmaps not supported');
Img.Width:=biWidth;
Img.Height:=biHeight;
end;
Case BFI.biBitCount of
1 : { Monochrome }
SetupRead(2,Img.Width,Stream,true);
4 :
SetupRead(16,Img.Width*4,Stream,true);
8 :
SetupRead(256,Img.Width*8,Stream,true);
16 :
SetupRead(0,Img.Width*8*2,Stream,true);
24:
SetupRead(0,Img.Width*8*3,Stream,true);
32:
SetupRead(0,Img.Width*8*4,Stream,true);
end;
Try
for Row:=Img.Height-1 downto 0 do
begin
ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize.
WriteScanLine(Row,Img);
end;
finally
FreeBufs;
end;
end;
function TLazReaderBMP.InternalCheck(Stream: TStream): boolean;
var
BFH:TBitMapFileHeader;
begin
stream.Read(BFH,SizeOf(BFH));
With BFH do
Result:=(bfType=BMmagic); // Just check magic number
end;
constructor TLazReaderBMP.Create;
begin
inherited Create;
end;
destructor TLazReaderBMP.Destroy;
begin
FreeBufs;
inherited Destroy;
end;
{ TLazIntfImageMask }
procedure TLazIntfImageMask.SetInternalColor(x, y: integer;
const Value: TFPColor);
var
MaskValue: TFPColor;
begin
MaskValue:=FImage.GetInternalColor(x,y);
MaskValue.Alpha:=$FFFF-Value.Red;
FImage.SetInternalColor(x, y, MaskValue);
end;
function TLazIntfImageMask.GetInternalColor(x, y: integer): TFPColor;
var
MaskValue: TFPColor;
begin
MaskValue:=FImage.GetInternalColor(x,y);
Result:=FPImage.colBlack;
Result.Red:=MaskValue.Alpha;
Result.Green:=MaskValue.Alpha;
Result.Blue:=MaskValue.Alpha;
end;
procedure TLazIntfImageMask.SetInternalPixel(x, y: integer; Value: integer);
begin
end;
function TLazIntfImageMask.GetInternalPixel(x, y: integer): integer;
begin
Result:=0;
end;
constructor TLazIntfImageMask.CreateWithImage(TheImage: TLazIntfImage);
begin
FImage:=TheImage;
inherited Create(FImage.Width,FImage.Height);
end;
{ TLazReaderPartIcon }
procedure TLazReaderPartIcon.InternalRead(Stream: TStream; Img: TFPCustomImage);
var
Row, Column: Integer;
begin
Stream.Read(BFI,SizeOf(BFI));
BFI.biHeight := BFI.biHeight div 2; { Height field is doubled, to (sort of) accomodate mask }
InternalReadBody(Stream, Img); { Now read standard bitmap }
{ Mask immediately follows unless bitmap was 32 bit - monchrome bitmap with no header }
if BFI.biBitCount < 32 then begin
ReadSize:=((Img.Width + 31) div 32) shl 2;
SetupRead(2,Img.Width,Stream,False);
try
for Row:=Img.Height-1 downto 0 do begin
ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize.
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]:=colTransparent
end;
finally
FreeBufs;
end;
end;
end;
function TLazReaderPartIcon.InternalCheck(Stream: TStream): boolean;
begin
Result:=True; { Assumes stream in the correct place }
end;
function TLazReaderPartIcon.BmpRGBAToFPColor(const RGBA: TColorRGBA): TFPcolor;
begin
Result:=inherited BmpRGBAToFPColor(RGBA);
Result.alpha := (RGBA.A shl 8) or RGBA.A; { For icon files (only) upper byte is used for transparency }
end;
{ TLazReaderIcon }
type
TIconHeader = packed record
idReserved: Word; {0}
idType: Word; {1}
idCount: Word; {number of icons in file}
end;
TIconDirEntry = packed record
bWidth: Byte; {ie: 16 or 32}
bHeight: Byte; {ie: 16 or 32}
bColorCount: Byte; {number of entires in pallette table below}
bReserved: Byte; { not used = 0}
wPlanes: Word; { not used = 0}
wBitCount: Word; { not used = 0}
dwBytesInRes: Longint; {total number bytes in images including pallette data
XOR, AND and bitmap info header}
dwImageOffset: Longint; {pos of image as offset from the beginning of file}
end;
PIconDirEntry = ^TIconDirEntry;
procedure TLazReaderIcon.SetIcon(const AValue: TObject);
begin
if AValue is TIcon then
FIcon:=AValue;
end;
procedure TLazReaderIcon.InternalRead(Stream: TStream; Img: TFPCustomImage);
var
CurrentDirEntry, BestDirEntry, IconDir: PIconDirEntry;
i: Integer;
Bitmap: TBitmap;
begin
GetMem(IconDir, FnIcons*Sizeof(TIconDirEntry));
try
Stream.Read(IconDir^, FnIcons*Sizeof(TIconDirEntry));
BestDirEntry := IconDir;
CurrentDirEntry := IconDir+1;
{ First locate largest and/or most colourful icon as the default image }
for i := 2 to FnIcons do begin
if ((CurrentDirEntry^.bWidth > BestDirEntry^.bWidth)
and (CurrentDirEntry^.bHeight > BestDirEntry^.bHeight))
or ((CurrentDirEntry^.bWidth = BestDirEntry^.bWidth)
and (CurrentDirEntry^.bHeight = BestDirEntry^.bHeight)
and (CurrentDirEntry^.dwBytesInRes > BestDirEntry^.dwBytesInRes)) then
BestDirEntry := CurrentDirEntry;
Inc(CurrentDirEntry);
end;
if Assigned(Icon) then begin
CurrentDirEntry := IconDir;
for i := 1 to FnIcons do begin
Stream.Position := FnStartPos + CurrentDirEntry^.dwImageOffset;
if CurrentDirEntry = BestDirEntry then
inherited InternalRead(Stream, Img)
else begin
Bitmap := TBitmap.Create;
try
Bitmap.ReadStreamWithFPImage(Stream, False, 0, TLazReaderPartIcon);
except
Bitmap.Free;
raise;
end;
TIcon(Icon).AddBitmap(Bitmap);
end;
Inc(CurrentDirEntry);
end;
end else begin
Stream.Position := FnStartPos + BestDirEntry^.dwImageOffset;
inherited InternalRead(Stream, Img);
{ Finally skip remaining icons }
Stream.Position := FnStartPos + CurrentDirEntry^.dwImageOffset + CurrentDirEntry^.dwBytesInRes;
end;
finally
FreeMem(IconDir);
end;
end;
function TLazReaderIcon.InternalCheck(Stream: TStream): boolean;
var
IconHeader: TIconHeader;
begin
FnStartPos := Stream.Position;
Stream.Read(IconHeader,SizeOf(IconHeader));
With IconHeader do
Result := (idReserved=0) and (idType=1);
FnIcons := IconHeader.idCount;
end;
//------------------------------------------------------------------------------
procedure InternalInit;
var
c: Char;
begin
for c:=Low(char) to High(char) do begin
IsSpaceChar[c]:=c in [' ',#9,#10,#13];
IsNumberChar[c]:=c in ['0'..'9'];
IsHexNumberChar[c]:=c in ['0'..'9','A'..'F','a'..'f'];
end;
end;
initialization
InternalInit;
end.
Reference in New Issue View Git Blame Copy Permalink