Sordie.co.uk
libsassy/libSassy.Bitmaps.pas
Raw
{(
)) libSassy.Bitmaps
(( 2D Bitmap library
))
(( Copyright © Sordie Aranka Solomon-Smith 2015-2017
))
(( This work is made available under the terms of the Creative Commons
)) Attribution-NonCommercial-ShareAlike 3.0 Unported license
(( http://creativecommons.org/licenses/by-nc-sa/3.0/
)}
unit libSassy.Bitmaps;
{$DEFINE BitmapRangeCheck}
interface
uses
Winapi.Windows,
libSassy.Interfaces,
libSassy.Streams,
libSassy.Integers,
libSassy.Maths;
const
PixelFormat = 2498570;
type
{$REGION 'TCustomBitmap'}
TBitmapLockMode = (lmRead, lmWrite, lmUserBuf);
TBitmapLockModes = set of TBitmapLockMode;
TBitmapData = packed record
Width: Cardinal;
Height: Cardinal;
Stride: Integer;
PixelFormat: Integer;
Scan0: Pointer;
Reserved: PInteger;
Size: Cardinal;
LockMode: TBitmapLockModes;
LockX: Cardinal;
LockY: Cardinal;
end;
TBlkRender = procedure(const Colour: Cardinal; const Dest: Pointer; const Count, Stride: Integer);
TBltRender = procedure(const Source, Dest: Pointer; const Count, SourceStride: Integer);
TSubBitmap = class;
TCustomBitmap = class abstract(TInterface)
private
fBlkRender: TBlkRender;
fBltRender: TBltRender;
fFrames: array of array of TSubBitmap;
fFrameX: Integer;
fFrameY: Integer;
protected
procedure SetWidth (Value: Cardinal); virtual;
procedure SetHeight(Value: Cardinal); virtual;
public
BitmapData: TBitmapData;
Scanlines: array of Pointer;
constructor Create(const AWidth: Integer = 0; const AHeight: Integer = 0);
destructor Destroy; override;
function Resize(const AWidth, AHeight: Cardinal): Boolean; virtual;
function Lock (var ABitmapData: TBitmapData; const x, y, w, h: Integer; const LockMode: TBitmapLockModes): Boolean; virtual;
function Unlock(var ABitmapData: TBitmapData): Boolean; virtual;
procedure SetFrames(const x: Integer; const y: Integer = 1);
function Frames (const x: Integer; const y: Integer = 0): TSubBitmap; inline;
procedure Clear(const Colour: Cardinal = $FF000000);
function GetPixel(x, y: Integer): Cardinal;
procedure SetPixel(x, y: Integer; const Colour: Cardinal);
procedure DrawPixel(x, y: Single; const Colour: Cardinal);
procedure HLine(x, y, l: Integer; const Colour: Cardinal);
procedure VLine(x, y, l: Integer; const Colour: Cardinal);
procedure Line(x1, y1, x2, y2: Integer; const Colour: Cardinal);
procedure Bezier(x1, y1, x2, y2, x3, y3, x4, y4: Integer; const Colour: Cardinal; const Count: Integer = 0);
procedure Box (x, y, w, h: Integer; const Colour: Cardinal; const Fill: Boolean = False);
procedure Ellipse (x, y, w, h: Integer; const Colour: Cardinal; const Fill: Boolean = False);
procedure Triangle(x1, y1, x2, y2, x3, y3: Integer; const Colour: Cardinal; const Fill: Boolean = False);
procedure Polygon(x, y: Integer; const Points: array of TPoint; const Colour: Cardinal; const Fill: Boolean = False; const Close: Boolean = True);
procedure Geom(x, y, w, h: Integer; const Sides: Integer; const Angle: Single; const Colour: Cardinal; const Fill: Boolean = False);
procedure Star(x, y, w1, w2, h1, h2: Integer; const Points: Integer; const Angle: Single; const Colour: Cardinal; const Fill: Boolean = False);
procedure TiltedEllipse(x, y, w, h: Integer; const Tilt: Single; const Colour: Cardinal; const Fill: Boolean = False);
procedure TiltedGeom (x, y, w, h: Integer; const Sides: Integer; const Angle, Tilt: Single; const Colour: Cardinal; const Fill: Boolean = False);
procedure Render (const Bitmap: TCustomBitmap; const x, y: Integer; const FlipX: Boolean = False; const FlipY: Boolean = False);
procedure RenderAffine(const Bitmap: TCustomBitmap; const x1, y1, x2, y2, x3, y3, x4, y4: Integer);
procedure RenderAngle (const Bitmap: TCustomBitmap; const x, y: Integer; const Angle: Single);
procedure SwapRB;
procedure SetTransparentColour(const Colour: Cardinal = 0);
// TODO: Filters etc
function LoadFromStream(Stream: TStream): Boolean;
function SaveToStream (Stream: TStream; const Mime: String = ''; Quality: Integer = -1): Boolean;
function LoadFromFile(const FileName: String): Boolean;
function SaveToFile (const FileName: String; const Mime: String = ''; const Quality: Integer = -1): Boolean;
// TODO: function LoadFromResource(Module: THandle; ResourceID: Integer): Boolean;
property Width: Cardinal read BitmapData.Width write SetWidth;
property Height: Cardinal read BitmapData.Height write SetHeight;
property Stride: Integer read BitmapData.Stride;
property Bits: Pointer read BitmapData.Scan0;
property Size: Cardinal read BitmapData.Size;
property BlkRender: TBlkRender read fBlkRender write fBlkRender;
property BltRender: TBltRender read fBltRender write fBltRender;
property FrameCount: Integer read fFrameX;
property FrameCountX: Integer read fFrameX;
property FrameCountY: Integer read fFrameY;
end;
{$ENDREGION}
{$REGION 'TSubBitmap'}
TSubBitmap = class(TCustomBitmap)
private
fParent: TCustomBitmap;
public
constructor Create(const AParent: TCustomBitmap; const x, y, w, h: Integer);
destructor Destroy; override;
property Parent: TCustomBitmap read fParent;
end;
{$ENDREGION}
{$REGION 'TBitmap'}
TBitmap = class(TCustomBitmap)
public
function Resize(const AWidth, AHeight: Cardinal): Boolean; override;
end;
{$ENDREGION}
{$REGION 'TDIB'}
TDIB = class(TCustomBitmap)
private
fHandle: HBITMAP;
fInfo: BITMAPINFO;
fHeader: BITMAPINFOHEADER;
fDC: HDC;
function GetDC: HDC;
public
function Resize(const AWidth, AHeight: Cardinal): Boolean; override;
procedure BltToDC(const DC: HDC; const x: Integer = 0; const y: Integer = 0; const w: Integer = 0; const h: Integer = 0);
procedure CreateDC;
procedure ReleaseDC;
property Handle: HBITMAP read fHandle;
property DC: HDC read GetDC;
end;
{$ENDREGION}
{$REGION 'Render'}
procedure BltCopy(const Source, Dest: Pointer; const Count, SourceStride: Integer);
procedure BlkCopy(const Colour: Cardinal; const Dest: Pointer; const Count, Stride: Integer);
const
AlphaBias = $00800080;
procedure BltAlpha(const Source, Dest: Pointer; const Count, SourceStride: Integer);
procedure BlkAlpha(const Colour: Cardinal; const Dest: Pointer; const Count, Stride: Integer);
procedure BltAlphaMMX(const Source, Dest: Pointer; const Count, SourceStride: Integer);
procedure BlkAlphaMMX(const Colour: Cardinal; const Dest: Pointer; const Count, Stride: Integer);
{$ENDREGION}
{$REGION 'GDI+'}
type
TBox = record
x, y: Integer;
w, h: Integer;
end;
TEncoderParameter = packed record
GUID: TGUID;
NumberOfValues: Cardinal;
ParamType: Cardinal;
Value: Pointer;
end;
PEncoderParameters = ^TEncoderParameters;
TEncoderParameters = packed record
Count: Cardinal;
Param: array of TEncoderParameter;
end;
TImageCodecInfo = packed record
CLSID: TGUID;
FormatID: TGUID;
CodecName: PWideChar;
DllName: PWideChar;
FormatDescription: PWideChar;
FilenameExtension: PWideChar;
MimeType: PWideChar;
Flags: Cardinal;
Version: Cardinal;
SigCount: Cardinal;
SigSize: Cardinal;
SigPattern: PByte;
SigMask: PByte;
end;
PImageCodecInfos = ^TImageCodecInfos;
TImageCodecInfos = array[0..255] of TImageCodecInfo;
TGDIPlusStartupInput = packed record
Version: Cardinal;
DebugCallback: Pointer;
SuppressBackgroundThread: LongBool;
SuppressExternalCodecs: LongBool;
end;
PGDIPlusStartupOutput = ^TGDIPlusStartupOutput;
TGDIPlusStartupOutput = packed record
NotificationHook: Pointer;
NotificationUnhook: Pointer;
end;
TGDIPlusObject = Pointer;
const
GDIPlus = 'GDIPlus.dll';
function GdiplusStartup(out Token: LongWord; const Input: TGDIPlusStartupInput; Output: PGDIPlusStartupOutput): Integer; stdcall; external GDIPlus;
procedure GdiplusShutdown(Token: LongWord); stdcall; external GDIPlus;
function GdipCreateBitmapFromScan0(Width, Height, Stride: Integer; Format: Integer; Scan0: Pointer; var Bitmap: TGDIPlusObject): Integer; stdcall; external GDIPlus;
function GdipLoadImageFromStream(Stream: IStream; var Image: TGDIPlusObject): Integer; stdcall; external GDIPlus;
function GdipSaveImageToStream(Image: TGDIPlusObject; Stream: IStream; const CLSIDEncoder: TGUID; const Params: PEncoderParameters): Integer; stdcall; external GDIPlus;
function GdipLoadImageFromFile(const FileName: PWideChar; var Image: TGDIPlusObject): Integer; stdcall; external GDIPlus;
function GdipSaveImageToFile(Image: TGDIPlusObject; const FileName: PWideChar; const CLSIDEncoder: TGUID; const Params: PEncoderParameters): Integer; stdcall; external GDIPlus;
function GdipGetImageEncodersSize(var NumEncoders, Size: LongWord): Integer; stdcall; external GDIPlus;
function GdipGetImageEncoders(NumEncoders, Size: LongWord; Encoders: PImageCodecInfos): Integer; stdcall; external GDIPlus;
function GdipDisposeImage(Image: TGDIPlusObject): Integer; stdcall; external GDIPlus;
function GdipGetImageWidth(Image: TGDIPlusObject; var Width: Cardinal): Integer; stdcall; external GDIPlus;
function GdipGetImageHeight(Image: TGDIPlusObject; var Height: Cardinal): Integer; stdcall; external GDIPlus;
function GdipBitmapLockBits(Bitmap: TGDIPlusObject; const Box: TBox; Flags: Cardinal; Format: Integer; var BitmapData: TBitmapData): Integer; stdcall; external GDIPlus;
function GdipBitmapUnlockBits(Bitmap: TGDIPlusObject; var BitmapData: TBitmapData): Integer; stdcall; external GDIPlus;
function InitializeGDIPlus: Boolean;
{$ENDREGION}
implementation
{$REGION 'Render'}
procedure BltCopy;
begin
Move(Source^, Dest^, Count shl 2);
end;
procedure BlkCopy;
var
i: Integer;
P: ^Cardinal;
begin
P := Dest;
for i := 1 to Count do
begin
P^ := Colour;
inc(P);
end;
end;
procedure BltAlpha;
asm
test ecx, ecx
js @4
push ebx
push esi
push edi
mov esi, eax
mov edi, edx
@1:
mov eax, [esi]
test eax, $FF000000
jz @3
push ecx
mov ecx, eax
shr ecx, 24
cmp ecx, $FF
jz @2
mov ebx, eax
and eax, $00FF00FF
and ebx, $FF00FF00
imul eax, ecx
shr ebx, 8
imul ebx, ecx
add eax, AlphaBias
and eax, $FF00FF00
shr eax, 8
add ebx, AlphaBias
and ebx, $FF00FF00
or eax, ebx
mov edx, [edi]
xor ecx, $000000FF
mov ebx, edx
and edx, $00FF00FF
and ebx, $FF00FF00
imul edx, ecx
shr ebx, 8
imul ebx, ecx
add edx, AlphaBias
and edx, $FF00FF00
shr edx, 8
add ebx, AlphaBias
and ebx, $FF00FF00
or ebx, edx
add eax, ebx
@2:
mov [edi], eax
pop ecx
@3:
add esi, SourceStride
add edi, 4
dec ecx
jnz @1
pop edi
pop esi
pop ebx
@4:
end;
procedure BlkAlpha;
var
c1, c2: Cardinal;
begin
if Count = 0 then Exit;
asm
push ebx
push edi
mov edi, Dest
mov eax, Colour
mov ecx, eax
shr ecx, 24
mov ebx, eax
and eax, $00FF00FF
and ebx, $FF00FF00
imul eax, ecx
shr ebx, 8
imul ebx, ecx
add eax, AlphaBias
and eax, $FF00FF00
shr eax, 8
add ebx, AlphaBias
and ebx, $FF00FF00
or eax, ebx
mov c1, ecx
mov c2, eax
mov ecx, Count
@1:
push ecx
mov ecx, c1
mov eax, c2
mov edx, [edi]
xor ecx, $000000FF
mov ebx, edx
and edx, $00FF00FF
and ebx, $FF00FF00
imul edx, ecx
shr ebx, 8
imul ebx, ecx
add edx, AlphaBias
and edx, $FF00FF00
shr edx, 8
add ebx, AlphaBias
and ebx, $FF00FF00
or ebx, edx
add eax, ebx
mov [edi], eax
pop ecx
add edi, Stride
dec ecx
jnz @1
pop edi
pop ebx
end;
end;
{$ENDREGION}
{$REGION 'GDI+'}
var
GDIPlusToken: LongWord = 0;
function InitializeGDIPlus;
const
StartupInput: TGDIPlusStartupInput = (Version: 1;
DebugCallback: nil;
SuppressBackgroundThread: False;
SuppressExternalCodecs: False);
begin
if GDIPlusToken <> 0 then exit(True);
Result := GDIPlusStartup(GDIPlusToken, StartupInput, nil) = 0;
end;
{$ENDREGION}
{$REGION 'TCustomBitmap'}
procedure TCustomBitmap.SetWidth;
begin
Resize(Value, Height);
end;
procedure TCustomBitmap.SetHeight;
begin
Resize(Width, Value);
end;
constructor TCustomBitmap.Create;
begin
inherited Create;
fFrameX := 0;
fFrameY := 0;
SetFrames(0, 0);
fBlkRender := BlkCopy;
fBltRender := BltCopy;
if (AWidth <> 0) and (AHeight <> 0) then
Resize(AWidth, AHeight);
end;
destructor TCustomBitmap.Destroy;
begin
Resize(0, 0);
inherited;
end;
function TCustomBitmap.Resize;
var
i: Integer;
begin
Result := True;
SetFrames(0, 0);
BitmapData.Width := AWidth;
BitmapData.Height := AHeight;
BitmapData.PixelFormat := PixelFormat;
BitmapData.Size := Cardinal(BitmapData.Stride) * AHeight;
SetLength(Scanlines, AHeight + 1);
if (AWidth = 0) or (AHeight = 0) then exit;
for i := 0 to AHeight do
Scanlines[i] := Pointer(Cardinal(BitmapData.Scan0) + Cardinal(BitmapData.Stride * i));
end;
function TCustomBitmap.Lock;
var
i: Integer;
xx, yy: Integer;
ww, hh: Integer;
p1, p2: PByte;
begin
FillChar(ABitmapData, 0, sizeof(ABitmapData));
if (x >= Integer(BitmapData.Width)) or (y >= Integer(BitmapData.Height)) then exit(False);
xx := x; yy := y;
ww := w; hh := h;
AdjustClamp(xx, ww, 0, BitmapData.Width);
AdjustClamp(yy, hh, 0, BitmapData.Height);
ABitmapData.Width := ww;
ABitmapData.Height := hh;
ABitmapData.LockMode := LockMode;
ABitmapData.LockX := xx;
ABitmapData.LockY := yy;
ABitmapData.Reserved := BitmapData.Scan0;
if lmUserBuf in LockMode then
begin
if (BitmapData.PixelFormat <> PixelFormat) or (Integer(ABitmapData.Width) <> ww) or (Integer(ABitmapData.Height) <> hh) then exit(False);
if lmRead in LockMode then
begin
p1 := Pointer(Integer(Scanlines[yy]) + (xx shl 2));
p2 := BitmapData.Scan0;
for i := 0 to hh - 1 do
begin
Move(p1^, p2^, ww shl 2);
inc(p1, BitmapData.Stride);
inc(p2, ABitmapData.Stride);
end;
end;
end
else
begin
ABitmapData.Stride := BitmapData.Stride;
ABitmapData.Scan0 := Pointer(Integer(Scanlines[yy]) + (xx shl 2));
ABitmapData.PixelFormat := BitmapData.PixelFormat;
end;
Result := True;
end;
function TCustomBitmap.Unlock;
var
i: Integer;
p1, p2: PByte;
begin
Result := ABitmapData.Reserved = BitmapData.Scan0;
if not Result then exit;
if (lmUserBuf in ABitmapData.LockMode) and (lmWrite in ABitmapData.LockMode) then
begin
p1 := Pointer(Integer(Scanlines[ABitmapData.LockX]) + Integer(ABitmapData.LockY shl 2));
p2 := ABitmapData.Scan0;
for i := 0 to ABitmapData.Height - 1 do
begin
Move(p2^, p1^, ABitmapData.Width shl 2);
inc(p1, BitmapData.Stride);
inc(p2, ABitmapData.Stride);
end;
end;
FillChar(ABitmapData, 0, sizeof(ABitmapData));
end;
procedure TCustomBitmap.SetFrames;
var
xx, yy: Integer;
ww, hh: Integer;
begin
for yy := 0 to fFrameY - 1 do
for xx := 0 to fFrameX - 1 do
fFrames[yy, xx].Free;
if (y <= 0) or (x <= 0) then
begin
fFrameX := 0;
fFrameY := 0;
SetLength(fFrames, 0, 0);
exit;
end;
fFrameX := x;
fFrameY := y;
SetLength(fFrames, y, x);
ww := Integer(Width) div x;
hh := Integer(Height) div y;
for yy := 0 to fFrameY - 1 do
for xx := 0 to fFrameX - 1 do
fFrames[yy, xx] := TSubBitmap.Create(Self, ww * xx, hh * yy, ww, hh);
end;
function TCustomBitmap.Frames;
begin
Result := fFrames[y, x];
end;
procedure TCustomBitmap.Clear;
var
i: Integer;
p: Pointer;
begin
for i := 0 to Height - 1 do
begin
p := Scanlines[i];
fBlkRender(Colour, p, Width, BitmapData.Stride);
end;
end;
function TCustomBitmap.GetPixel;
begin
{$IFDEF BitmapRangeCheck}
if (x < 0) or (x > Integer(BitmapData.Width - 1)) or (y < 0) or (y > Integer(BitmapData.Height - 1)) then Exit(0);
{$ENDIF BitmapRangeCheck}
Result := Cardinal(Pointer(Integer(Scanlines[y]) + (x shl 2))^);
end;
procedure TCustomBitmap.SetPixel;
var
p: Pointer;
begin
{$IFDEF BitmapRangeCheck}
if (x < 0) or (x > Integer(BitmapData.Width - 1)) or (y < 0) or (y > Integer(BitmapData.Height - 1)) then Exit;
{$ENDIF BitmapRangeCheck}
p := Pointer(Integer(Scanlines[y]) + (x shl 2));
if @fBlkRender = nil then
Cardinal(p^) := Colour
else
BlkRender(Colour, p, 1, 1);
end;
procedure TCustomBitmap.DrawPixel;
const
Lightness = 0.25;
procedure BlendPixel(xx, yy: Integer; a: Single);
var
cc: LongWord;
aa: LongWord;
begin
cc := Colour and $FFFFFF;
aa := (Colour shr 24) and $FF;
aa := Clamp(round(aa * (a + Lightness)));
cc := cc or (aa shl 24);
SetPixel(xx, yy, cc);
end;
var
ix, iy: Integer;
ex, ey: Single;
a1, a2,
a3, a4: Single;
begin
if ((Colour {and $FF00000}) shr 24) = 0 then exit;
ix := trunc(x); ex := x - ix;
iy := trunc(y); ey := y - iy;
a1 := (1 - ex) * (1 - ey);
a2 := ex * (1 - ey);
a3 := (1 - ex) * ey ;
a4 := ex * ey ;
BlendPixel(ix, iy, a1);
BlendPixel(ix + 1, iy, a2);
BlendPixel(ix, iy + 1, a3);
BlendPixel(ix + 1, iy + 1, a4);
end;
procedure TCustomBitmap.HLine;
var
p: Pointer;
begin
{$IFDEF BitmapRangeCheck}
if (y < 0) or (y > Integer(BitmapData.Height - 1)) then exit;
if x > Integer(BitmapData.Width - 1) then exit;
if x < 0 then
begin
l := l + x;
x := 0;
end;
if l <= 0 then exit;
if (x + l) > Integer(BitmapData.Width - 1) then l := Integer(BitmapData.Width) - x;
{$ENDIF BitmapRangeCheck}
p := Pointer(Integer(Scanlines[y]) + (x shl 2));
fBlkRender(Colour, p, l, 4);
end;
procedure TCustomBitmap.VLine;
var
p: Pointer;
s: Integer;
begin
{$IFDEF BitmapRangeCheck}
if (x < 0) or (x > Integer(BitmapData.Width - 1)) then exit;
if y > Integer(BitmapData.Height - 1) then exit;
if y < 0 then
begin
l := l + y;
y := 0;
end;
if l <= 0 then exit;
if (y + l) > Integer(BitmapData.Height - 1) then l := Integer(BitmapData.Height) - y;
{$ENDIF BitmapRangeCheck}
p := Pointer(Integer(Scanlines[y]) + (x shl 2));
s := BitmapData.Stride;
fBlkRender(Colour, p, l, s);
end;
procedure TCustomBitmap.Line;
var
dx, dy, iy: Integer;
f1, f2, f3: Integer;
i: Integer;
begin
dx := x2 - x1;
dy := y2 - y1;
if dx < 0 then
begin
dx := -dx; x1 := x2;
dy := -dy; y1 := y2;
end;
if dy < 0 then
begin
dy := -dy;
iy := -1;
end
else iy := 1;
if dx > dy then
begin
f1 := dy shl 1;
f2 := f1 - dx;
f3 := f2 - dx;
for i := 0 to dx do
begin
SetPixel(x1, y1, Colour);
inc(x1);
if f2 < f1 then
inc(f2, f1)
else
begin
inc(f2, f3);
inc(y1, iy);
end;
end;
end
else
begin
f1 := dx shl 1;
f2 := f1 - dy;
f3 := f2 - dy;
for i := 0 to dy do
begin
SetPixel(x1, y1, Colour);
inc(y1, iy);
if f2 < f1 then
inc(f2, f1)
else
begin
inc(f2, f3);
inc(x1);
end;
end;
end;
end;
procedure TCustomBitmap.Bezier;
procedure CalcBezier(t: Real; var x, y: Integer);
begin
x := round(Power(1 - t, 3) * x1 + 3 * t * Power(1 - t, 2) * x2 + 3 * t * t * (1 - t) * x3 + Power(t, 3) * x4);
y := round(Power(1 - t, 3) * y1 + 3 * t * Power(1 - t, 2) * y2 + 3 * t * t * (1 - t) * y3 + Power(t, 3) * y4);
end;
var
Resolution, t: Real;
xc, yc, sx, sy: Integer;
c: Integer;
begin
if Count = 0 then c := 50 else c := Count;
Resolution := 1 / c;
sx := x1; sy := y1;
t := 0;
while t < 1 do
begin
CalcBezier(t, xc, yc);
Line(sx, sy, xc, yc, Colour); sx := xc; sy := yc;
t := t + Resolution;
end;
Line(sx, sy, x4, y4, Colour);
end;
procedure TCustomBitmap.Box;
var
i: Integer;
begin
if not fill then
begin
HLine(x, y, w, Colour);
HLine(x, y + h - 1, w, Colour);
VLine(x, y, h, Colour);
VLine(x + w - 1, y, h, Colour)
end
else
for i := y to y + h - 1 do
HLine(x, i, w, Colour);
end;
procedure TCustomBitmap.Ellipse;
var
xx, yy: Integer;
x2, j: Integer;
begin
if (w = 0) or (h = 0) then exit;
if h = 1 then
begin
HLine(x, y, w, Colour);
exit;
end;
if w = 1 then
begin
VLine(x, y, h, Colour);
exit;
end;
xx := 0;
if Fill then
begin
HLine(x - w, y, (w * 2), Colour);
for yy := 1 to (h - 1) do
begin
xx := round(w / (h - 1) * Sqrt((Sqr(Integer(h - 1))) - Sqr(yy - 0.5)));
HLine(x - xx, y + yy, (xx * 2), Colour);
HLine(x - xx, y - yy, (xx * 2), Colour);
end;
end
else
begin
x2 := w;
for yy := 0 to (h - 1) do
begin
xx := round(w / (h - 1) * Sqrt(Sqr(h - 1) - Sqr(yy - 0.5)));
for j := xx to x2 do
begin
SetPixel(x + j, y + yy, Colour);
SetPixel(x - j, y + yy, Colour);
SetPixel(x + j, y - yy, Colour);
SetPixel(x - j, y - yy, Colour);
end;
x2 := xx;
end;
for j := 0 to xx - 1 do
begin
SetPixel(x + j, y + h, Colour);
SetPixel(x - j, y + h, Colour);
SetPixel(x + j, y - h, Colour);
SetPixel(x - j, y - h, Colour);
end;
end;
end;
procedure TCustomBitmap.Triangle;
var
x, MinY, MaxY: Integer;
ax, bx, yy: Integer;
p1, q1, p2, q2, p3, q3: Integer;
begin
if not Fill then
begin
Line(x1, y1, x2, y2, Colour);
Line(x2, y2, x3, y3, Colour);
Line(x3, y3, x1, y1, Colour);
Exit;
end;
MinY := y1; MaxY := y1;
if y2 < MinY then MinY := y2;
if y2 > MaxY then MaxY := y2;
if y3 < MinY then MinY := y3;
if y3 > MaxY then MaxY := y3;
p1 := x1 - x3; q1 := y1 - y3;
p2 := x2 - x1; q2 := y2 - y1;
p3 := x3 - x2; q3 := y3 - y2;
for yy := MinY to MaxY do
begin
ax := Width;
bx := -1;
if (y3 >= yy) or (y1 >= yy) then
if (y3 <= yy) or (y1 <= yy) then
if not (y3 = y1) then
begin
x := (yy - y3) * p1 div q1 + x3;
if x < ax then ax := x;
if x > bx then bx := x;
end;
if (y1 >= yy) or (y2 >= yy) then
if (y1 <= yy) or (y2 <= yy) then
if not (y1 = y2) then
begin
x := (yy - y1) * p2 div q2 + x1;
if x < ax then ax := x;
if x > bx then bx := x;
end;
if (y2 >= yy) or (y3 >= yy) then
if (y2 <= yy) or (y3 <= yy) then
if not (y2 = y3) then
begin
x := (yy - y2) * p3 div q3 + x2;
if x < ax then ax := x;
if x > bx then bx := x;
end;
if ax <= bx then HLine(ax, yy, bx - ax, Colour);
end;
end;
procedure TCustomBitmap.Polygon;
var
xx, i, MinY, MaxY: Integer;
b, ax, bx, yy: Integer;
p, q: Integer;
begin
if not Fill then
begin
for i := (low(Points) + 1) to high(Points) do
Line(x + Points[i - 1].x, y + Points[i - 1].y, x + Points[i].x, y + Points[i].y, Colour);
if Close then Line(x + Points[high(Points)].x, y + Points[high(Points)].y, x + Points[low(Points)].x, y + Points[low(Points)].y, Colour);
Exit;
end;
MinY := Points[low(Points)].y;
MaxY := Points[low(Points)].y;
for i := (low(Points) + 1) to high(Points) do
begin
if Points[i].y < MinY then MinY := Points[i].y;
if Points[i].y > MaxY then MaxY := Points[i].y;
end;
for yy := MinY to MaxY do
begin
ax := Width;
bx := -1;
for i := low(Points) + 1 to high(Points) do
begin
b := i - 1; if b < low(Points) then b := high(Points);
p := Points[i].x - Points[b].x;
q := Points[i].y - Points[b].y;
if (Points[b].y >= yy) or (Points[i].y >= yy) then
if (Points[b].y <= yy) or (Points[i].y <= yy) then
if not (Points[b].y = Points[i].y) then
begin
xx := (yy - Points[b].y) * p div q + Points[b].x;
if xx < ax then ax := xx;
if xx > bx then bx := xx;
end;
end;
if ax <= bx then HLine(x + ax, y + yy, bx - ax, Colour);
end;
end;
procedure TCustomBitmap.Geom;
var
i: Integer;
s: Single;
Poly: array of TPoint;
begin
SetLength(Poly, Sides);
s := (PI * 2) / Sides;
for i := 0 to Sides do
begin
Poly[i].x := round(sin((s * i) + Angle) * w);
Poly[i].y := round(cos((s * i) + Angle) * h);
end;
Polygon(x, y, Poly, Colour, Fill, True);
end;
procedure TCustomBitmap.Star;
var
i: Integer;
s: Single;
w, h: Integer;
Poly: array of TPoint;
begin
SetLength(Poly, Points * 2);
s := PI / Points;
for i := 0 to Points * 2 do
begin
if (i mod 2) = 1 then
begin
w := w1;
h := h1;
end
else
begin
w := w2;
h := h2;
end;
Poly[i].X := round(sin((s * i) + Angle) * w);
Poly[i].Y := round(cos((s * i) + Angle) * h);
end;
Polygon(x, y, Poly, Colour, Fill, True);
end;
procedure TCustomBitmap.TiltedEllipse;
begin
TiltedGeom(x, y, w, h, w + h, 0, Tilt, Colour, Fill);
end;
procedure TCustomBitmap.TiltedGeom;
var
i: Integer;
theta: Single;
xx, yy: Integer;
Points: array of TPoint;
begin
SetLength(Points, Sides);
for i := 0 to Sides do
begin
theta := 360 * (i / Sides) * (PI / 180);
xx := x + round(sin(theta + Angle) * w);
yy := y + round(cos(theta + Angle) * h);
Points[i].x := round(x + (xx - x) * cos(Tilt) - (yy - y) * sin(Tilt));
Points[i].Y := round(x + (xx - x) * sin(Tilt) + (yy - y) * cos(Tilt));
end;
Polygon(0, 0, Points, Colour, Fill, True);
end;
procedure TCustomBitmap.Render;
var
Scan: Integer;
xx, yy: Integer;
ww, hh: Integer;
dx, dy: Integer;
DestData: TBitmapData;
SourceData: TBitmapData;
PDest: PByte;
PSource: PByte;
begin
ww := Bitmap.Width; xx := x;
hh := Bitmap.Height; yy := y;
AdjustClampDelta(xx, ww, 0, Width, dx);
AdjustClampDelta(yy, hh, 0, Height, dy);
if not Lock(DestData, xx, yy, ww, hh, [lmRead, lmWrite]) then exit;
try
if not Bitmap.Lock(SourceData, dx, dy, ww, hh, [lmRead]) then exit;
try
PDest := DestData.Scan0;
if FlipY then
PSource := Pointer(Cardinal(SourceData.Scan0) + (Cardinal(Bitmap.BitmapData.Stride) * Cardinal(Bitmap.Height - 1)))
else
PSource := SourceData.Scan0;
for Scan := 0 to hh - 1 do
begin
if FlipX then
fBltRender(Pointer(Cardinal(PSource) + (Cardinal(SourceData.Width - 1) * 4)), PDest, ww, -4)
else
fBltRender(PSource, PDest, ww, 4);
inc(PDest, DestData.Stride);
if FlipY then
dec(PSource, SourceData.Stride)
else
inc(PSource, SourceData.Stride);
end;
except
end;
Bitmap.Unlock(SourceData);
finally
Unlock(DestData);
end;
end;
procedure TCustomBitmap.RenderAffine;
var
VLDx, VRDx, HDx: Extended;
VLDy, VRDy, HDy: Extended;
TX1, TY1, TX2, TY2: Extended;
tx, ty: Extended;
x, y: Integer;
begin
VLDx := (x3 - x1) / Bitmap.Width;
VRDx := (x4 - x2) / Bitmap.Width;
VLDy := (y3 - y1) / Bitmap.Height;
VRDy := (y4 - y2) / Bitmap.Height;
tx1 := x1; ty1 := y1;
tx2 := x2; ty2 := y2;
for y := 0 to Bitmap.Height - 1 do
begin
HDx := (tx2 - tx1) / Bitmap.Width;
HDy := (ty2 - ty1) / Bitmap.Height;
tx := TX1;
ty := TY1;
for x := 0 to Bitmap.Width - 1 do
begin
DrawPixel(tx, ty, Bitmap.GetPixel(x, y));
tx := tx + HDx;
ty := ty + HDy;
end;
TX1 := TX1 + VLDx; TY1 := TY1 + VLDy;
TX2 := TX2 + VRDx; TY2 := TY2 + VRDy;
end;
end;
procedure TCustomBitmap.RenderAngle;
var
x1, y1: Integer;
x2, y2: Integer;
x3, y3: Integer;
x4, y4: Integer;
cx, cy: Single;
dx, dy: Single;
s, c: Single;
begin
s := sin(Angle - PI);
c := cos(Angle - PI);
cx := x + (Integer(Bitmap.Width) shr 1);
cy := y + (Integer(Bitmap.Height) shr 1);
dx := cx - x;
dy := cy - y;
x1 := x + round(dx * c - dy * s);
y1 := y + round(dx * s + dy * c);
dx := cx - (x + Integer(Bitmap.Width));
dy := cy - y;
x2 := x + round(dx * c - dy * s);
y2 := y + round(dx * s + dy * c);
dx := cx - x;
dy := cy - (y + Integer(Bitmap.Height));
x3 := x + round(dx * c - dy * s);
y3 := y + round(dx * s + dy * c);
dx := cx - (x + Integer(Bitmap.Width));
dy := cy - (y + Integer(Bitmap.Height));
x4 := x + round(dx * c - dy * s);
y4 := y + round(dx * s + dy * c);
RenderAffine(Bitmap, x1, y1, x2, y2, x3, y3, x4, y4);
end;
procedure TCustomBitmap.SwapRB;
type
TARGB = array[0..3] of Byte;
var
x, y: Integer;
p: ^TARGB;
t: Byte;
begin
for y := 0 to Height - 1 do
begin
p := Scanlines[y];
for x := 0 to Width - 1 do
begin
t := p^[0];
p^[0] := p^[2];
p^[2] := t;
p := Pointer(Cardinal(p) + 4);
end;
end;
end;
procedure TCustomBitmap.SetTransparentColour;
var
x, y: Integer;
c: Cardinal;
p: ^Cardinal;
begin
c := Colour and $FFFFFF;
for y := 0 to Height - 1 do
begin
p := Scanlines[y];
for x := 0 to Width - 1 do
begin
if (p^ and $FFFFFF) = c then
p^ := c
else
p^ := $FF000000 or p^;
inc(p);
end;
end;
end;
function TCustomBitmap.LoadFromStream;
var
SavePos: Int64;
Image: TGDIPlusObject;
w, h: Cardinal;
ABitmapData: TBitmapData;
Box: TBox;
begin
Result := False;
if not InitializeGDIPlus then exit;
SavePos := Stream.Position;
Image := nil;
try
if GdipLoadImageFromStream(Stream as IStream, Image) <> 0 then exit(False);
try
GdipGetImageWidth (Image, w);
GdipGetImageHeight(Image, h);
if not Resize(w, h) then exit(False);
Box.x := 0; Box.y := 0;
Box.w := w; Box.h := h;
ABitmapData.Width := w;
ABitmapData.Height := h;
ABitmapData.Stride := BitmapData.Stride;
ABitmapData.Scan0 := BitmapData.Scan0;
ABitmapData.PixelFormat := PixelFormat;
if GdipBitmapLockBits(Image, Box, 5, PixelFormat, ABitmapData) <> 0then exit(False);
GdipBitmapUnlockBits(Image, ABitmapData);
finally
GdipDisposeImage(Image);
end;
Result := True;
finally
if not Result then Stream.Position := SavePos;
end;
end;
function TCustomBitmap.SaveToStream;
var
SavePos: Int64;
Image: TGDIPlusObject;
Encoder: TGUID;
Params: TEncoderParameters;
Num: LongWord;
Size: LongWord;
i: Integer;
Codec: TImageCodecInfos;
QParam: LongWord;
begin
Result := False;
if not InitializeGDIPlus then exit;
GdipGetImageEncodersSize(Num, Size);
if GDIPGetImageEncoders(Num, Size, @Codec) <> 0 then exit(False);
// Search the encoders for a mime match
QParam := $FFFFFFFF;
for i := 0 to Num - 1 do
if String(Codec[i].MimeType) = Mime then
begin
Encoder := Codec[i].CLSID;
QParam := i;
break;
end;
if QParam = $FFFFFFFF then exit(False);
SetLength(Params.Param, 1);
if Quality <> -1 then
begin
QParam := Clamp(Quality, 0, 100);
SetLength(Params.Param, 1);
with Params, Param[0] do
begin
Count := 1;
NumberOfValues := 1;
ParamType := 4;
Value := @QParam;
end;
end;
SavePos := Stream.Position;
try
if GdipCreateBitmapFromScan0(Width, Height, BitmapData.Stride, PixelFormat, BitmapData.Scan0, Image) <> 0 then exit(False);
try
if Quality <> -1 then
Result := GdipSaveImageToStream(Image, Stream as IStream, Encoder, @Params) = 0
else
Result := GdipSaveImageToStream(Image, Stream as IStream, Encoder, nil) = 0;
finally
GdipDisposeImage(Image);
end;
finally
if not Result then Stream.Position := SavePos;
end;
end;
function TCustomBitmap.LoadFromFile;
var
Image: TGDIPlusObject;
w, h: Cardinal;
ABitmapData: TBitmapData;
Box: TBox;
begin
Result := False;
if not InitializeGDIPlus then exit;
Image := nil;
if GdipLoadImageFromFile(@FileName[1], Image) <> 0 then exit(False);
try
GdipGetImageWidth (Image, w);
GdipGetImageHeight(Image, h);
if not Resize(w, h) then exit(False);
Box.x := 0; Box.y := 0;
Box.w := w; Box.h := h;
ABitmapData.Width := w;
ABitmapData.Height := h;
ABitmapData.Stride := BitmapData.Stride;
ABitmapData.Scan0 := BitmapData.Scan0;
ABitmapData.PixelFormat := PixelFormat;
if GdipBitmapLockBits(Image, Box, 5, PixelFormat, ABitmapData) <> 0then exit(False);
GdipBitmapUnlockBits(Image, ABitmapData);
finally
GdipDisposeImage(Image);
end;
Result := True;
end;
function TCustomBitmap.SaveToFile;
var
Image: TGDIPlusObject;
Encoder: TGUID;
Params: TEncoderParameters;
Num: LongWord;
Size: LongWord;
i: Integer;
Codec: TImageCodecInfos;
QParam: LongWord;
begin
Result := False;
if not InitializeGDIPlus then exit;
GdipGetImageEncodersSize(Num, Size);
if GDIPGetImageEncoders(Num, Size, @Codec) <> 0 then exit(False);
// Search the encoders for a mime match
QParam := $FFFFFFFF;
for i := 0 to Num - 1 do
if String(Codec[i].MimeType) = Mime then
begin
Encoder := Codec[i].CLSID;
QParam := i;
break;
end;
if QParam = $FFFFFFFF then exit(False);
SetLength(Params.Param, 1);
if Quality <> -1 then
begin
QParam := Clamp(Quality, 0, 100);
SetLength(Params.Param, 1);
with Params, Param[0] do
begin
Count := 1;
NumberOfValues := 1;
ParamType := 4;
Value := @QParam;
end;
end;
if GdipCreateBitmapFromScan0(Width, Height, BitmapData.Stride, PixelFormat, BitmapData.Scan0, Image) <> 0 then exit(False);
try
if Quality <> -1 then
Result := GdipSaveImageToFile(Image, @FileName[1], Encoder, @Params) = 0
else
Result := GdipSaveImageToFile(Image, @FileName[1], Encoder, nil) = 0;
finally
GdipDisposeImage(Image);
end;
end;
{$ENDREGION}
{$REGION 'TSubBitmap'}
constructor TSubBitmap.Create;
begin
inherited Create;
FillChar(BitmapData, sizeof(BitmapData), 0);
if AParent.Lock(BitmapData, x, y, w, h, [lmRead, lmWrite]) then
begin
fParent := AParent;
Resize(BitmapData.Width, BitmapData.Height);
end
else fParent := nil;
end;
destructor TSubBitmap.Destroy;
begin
if fParent <> nil then Parent.Unlock(BitmapData);
inherited;
end;
{$ENDREGION}
{$REGION 'TBitmap'}
function TBitmap.Resize;
begin
if BitmapData.Scan0 <> nil then FreeMem(BitmapData.Scan0);
FillChar(BitmapData, sizeof(BitmapData), 0);
if (AWidth <> 0) and (AHeight <> 0) then
begin
GetMem(BitmapData.Scan0, (AWidth * 4) * AHeight);
if BitmapData.Scan0 = nil then
begin
inherited Resize(0, 0);
exit(False);
end;
BitmapData.Stride := AWidth * 4;
BitmapData.LockMode := [lmRead, lmWrite];
end;
Result := inherited Resize(AWidth, AHeight);
end;
{$ENDREGION}
{$REGION 'TDIB'}
function TDIB.GetDC;
begin
if fDC = 0 then CreateDC;
Result := fDC;
end;
function TDIB.Resize;
begin
if fHandle <> 0 then DeleteObject(fHandle);
fHandle := 0;
FillChar(BitmapData, sizeof(BitmapData), 0);
if (AWidth <> 0) and (AHeight <> 0) then
begin
with fHeader do
begin
biSize := sizeof(fHeader);
biWidth := AWidth;
biHeight := -AHeight;
biPlanes := 1;
biBitCount := 32;
biCompression := BI_RGB;
end;
fInfo.bmiHeader := fHeader;
fHandle := CreateDIBSection(0, fInfo, DIB_RGB_COLORS, BitmapData.Scan0, 0, 0);
if fHandle = 0 then
begin
inherited Resize(0, 0);
exit(False);
end;
BitmapData.Stride := AWidth * 4;
BitmapData.LockMode := [lmRead, lmWrite];
end;
Result := inherited Resize(AWidth, AHeight);
end;
procedure TDIB.BltToDC;
begin
if (w = 0) or (h = 0) then
SetDIBitsToDevice(DC, x, y, BitmapData.Width, BitmapData.Height, 0, 0, 0, BitmapData.Height, BitmapData.Scan0, fInfo, DIB_RGB_COLORS)
else
StretchDIBits(DC, x, y, w, h, 0, 0, BitmapData.Width, BitmapData.Height, BitmapData.Scan0, fInfo, DIB_RGB_COLORS, SRCCOPY);
end;
procedure TDIB.CreateDC;
var
ScreenDC: HDC;
begin
if fDC <> 0 then Exit;
ScreenDC := Winapi.Windows.GetDC(0);
fDC := CreateCompatibleDC(ScreenDC);
SelectObject(fDC, fHandle);
Winapi.Windows.ReleaseDC(0, ScreenDC);
end;
procedure TDIB.ReleaseDC;
begin
if fDC = 0 then Exit;
Winapi.Windows.ReleaseDC(0, fDC);
fDC := 0;
end;
{$ENDREGION}
{$REGION 'MMX'}
var
_MMXAlphaTable: Pointer = nil;
_MMXBiasPtr: Pointer = nil;
_MMXAlphaPtr: Pointer = nil;
procedure InitMMX;
var
I: Integer;
L: LongWord;
P: ^LongWord;
begin
GetMem(_MMXAlphaTable, 257 * 8);
_MMXAlphaPtr := Pointer(Cardinal(_MMXAlphaTable) and $FFFFFFF8);
if Cardinal(_MMXAlphaPtr) < Cardinal(_MMXAlphaTable) then _MMXAlphaPtr := Pointer(Cardinal(_MMXAlphaPtr) + 8);
P := _MMXAlphaPtr;
for i := 0 to 255 do
begin
l := i + i shl 16;
p^ := l; inc(p);
p^ := l; inc(p);
end;
_MMXBiasPtr := Pointer(Cardinal(_MMXAlphaPtr) + $80 * 8);
end;
procedure DoneMMX;
begin
FreeMem(_MMXAlphaTable);
end;
procedure BltAlphaMMX;
asm
test ecx, ecx
js @4
push esi
push edi
mov esi, eax
mov edi, edx
mov edx, _MMXBiasPtr
@1:
mov eax, [esi]
test eax, $FF000000
jz @3
cmp eax, $FF000000
jnc @2
pxor mm3, mm3
movd mm0, eax
movd mm2, [edi]
punpcklbw mm0, mm3
punpcklbw mm2, mm3
movq mm1, mm0
punpckhwd mm1, mm1
psubw mm0, mm2
punpckhdq mm1, mm1
psllw mm2, 8
pmullw mm0, mm1
paddw mm2, [edx]
paddw mm2, mm0
psrlw mm2, 8
packuswb mm2, mm3
movd eax, mm2
@2:
mov [edi], eax
@3:
add esi, SourceStride
add edi, 4
dec ecx
jnz @1
pop edi
pop esi
@4:
end;
procedure BlkAlphaMMX;
begin
// TODO: MMX BlkAlpha
BlkAlpha(Colour, Dest, Count, Stride);
end;
{$ENDREGION}
initialization
//InitMMX;
finalization
//DoneMMX;
end.
