Sordie.co.uk

{(
 )) 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.