source: trunk/Packages/FastGraphics/UGGraphics.pas

unit UGGraphics;

{$mode delphi}{$H+}

interface

uses
  Classes, SysUtils, Graphics, GraphType;

type
  // Possible fixed color types:
  //   0..1, 0..3, 0..15, Byte, Word, Cardinal, Int64, record RGB, record RGBA, class
  // Bit level addressing -> bit addressable memory -> slowdown
  // Color with dynamic size
  // Color with dynamic number of channels
  // Representing pallete

  { TGBrush }

  TGBrush<TGColor> = class
    Color: TGColor;
    Canvas: TObject; // TGCanvas<TGColor>;
  end;

  { TGPen }

  TGPen<TGColor> = class
    Position: TPoint;
    Color: TGColor;
    Canvas: TObject; // TGCanvas<TGColor>;
    procedure MoveTo(Pos: TPoint);
    procedure LineTo(Pos: TPoint);
  end;

  { TGCanvas }

  TGCanvas<TGColor> = class
    Bitmap: TObject; // TGPixmap<TGColor>;
    Pen: TGPen<TGColor>;
    Brush: TGBrush<TGColor>;
    constructor Create;
    destructor Destroy; override;
  end;

  { TGPixmap }

  TGPixmap<TGColor> = class
  public
    type
      TGConvertColor = function (Color: TGColor): TColor of object;
      TGConvertFromColor = function (Color: TColor): TGColor of object;
      TGGetColor = function (Position: TPoint): TGColor of object;
      PGColor = ^TGColor;
  protected
    FData: PByte;
    FSize: TPoint;
    FCanvas: TGCanvas<TGColor>;
    FBytesPerLine: Integer;
    FBytesPerPixel: Integer;
    function GetPixel(X, Y: Integer): TGColor; virtual;
    function GetSize: TPoint; virtual;
    procedure SetPixel(X, Y: Integer; AValue: TGColor); virtual;
    procedure SetSize(AValue: TPoint); virtual;
  private
    procedure CheckLimits(X, Y: Integer);
  public
    constructor Create;
    destructor Destroy; override;
    procedure PaintToCanvas(Canvas: TCanvas; ColorConvertFunc: TGConvertColor); overload;
    procedure PaintToCanvas(Canvas: TCanvas; Rect: TRect; ColorConvertFunc: TGConvertColor); overload;
    procedure PaintToBitmap(Bitmap: TBitmap; Pos: TPoint; ColorConvertFunc: TGConvertColor); overload;
    procedure PaintToBitmap(Bitmap: TBitmap; Rect: TRect; ColorConvertFunc: TGConvertColor); overload;
    procedure LoadFromCanvas(Canvas: TCanvas; ColorConvertFunc: TGConvertFromColor); overload;
    procedure LoadFromBitmap(Bitmap: TBitmap; ColorConvertFunc: TGConvertFromColor);
    procedure Fill(Color: TGColor); overload;
    procedure Fill(Func: TGGetColor); overload;
    procedure Mirror;
    procedure Flip;
    function GetDataSize: Int64; virtual;
    property Canvas: TGCanvas<TGColor> read FCanvas;
    property Pixels[X, Y: Integer]: TGColor read GetPixel write SetPixel;
    property Size: TPoint read GetSize write SetSize;
  end;

{ TGPixmapBit }

  TGPixmapBit<TGColor> = class(TGPixmap<TGColor>)
  protected
    function GetPixel(X, Y: Integer): TGColor; override;
    procedure SetPixel(X, Y: Integer; AValue: TGColor); override;
  private
    FBitsPerPixel: Integer;
    procedure BitMove(SourceBase: PByte; SourceOffset: Integer;
      DestBase: PByte; DestOffset: Integer; Size: Integer);
    function GetByteSize(BitSize: Integer): Integer;
    procedure SetBitsPerPixel(AValue: Integer);
  public
    property BitsPerPixel: Integer read FBitsPerPixel write SetBitsPerPixel;
    function GetDataSize: Int64; override;
  end;

  { TPixelPointer }

  TPixelPointer = record
    Base: Pointer;
    Pixel: Pointer;
    Line: Pointer;
    BytesPerPixel: Integer;
    BytesPerLine: Integer;
    procedure NextLine; inline; // Move pointer to start of new base line
    procedure NextPixel; inline; // Move pointer to next pixel
    procedure SetXY(X, Y: Integer); inline; // Set pixel position relative to base
    procedure SetX(X: Integer); inline; // Set horizontal pixel position relative to base
    procedure Init(Bitmap: TRasterImage; BaseX: Integer = 0; BaseY: Integer = 0); inline; overload;
    procedure Init(Base: Pointer; BytesPerLine, BytesPerPixel: Integer; BaseX: Integer = 0; BaseY: Integer = 0); inline; overload;
 end;


implementation

{ TPixelPointer }

procedure TPixelPointer.NextLine; inline;
begin
  Line := Pointer(Line) + BytesPerLine;
  Pixel := Line;
end;

procedure TPixelPointer.NextPixel; inline;
begin
  Pixel := Pointer(Pixel) + BytesPerPixel;
end;

procedure TPixelPointer.SetXY(X, Y: integer); inline;
begin
  Line := Pointer(Base) + Y * BytesPerLine;
  SetX(X);
end;

procedure TPixelPointer.SetX(X: Integer); inline;
begin
  Pixel := Pointer(Line) + X * BytesPerPixel;
end;

procedure TPixelPointer.Init(Bitmap: TRasterImage; BaseX: Integer = 0;
  BaseY: Integer = 0); inline;
begin
  Init(Bitmap.RawImage.Data, Bitmap.RawImage.Description.BytesPerLine, Bitmap.RawImage.Description.BitsPerPixel shr 3, BaseX, BaseY);
end;

procedure TPixelPointer.Init(Base: Pointer; BytesPerLine, BytesPerPixel: Integer; BaseX: Integer = 0; BaseY: Integer = 0); inline; overload;
begin
  Self.BytesPerLine := BytesPerLine;
  Self.BytesPerPixel := BytesPerPixel;
  Self.Base := Pointer(Base + BaseX * BytesPerPixel + BaseY * BytesPerLine);
  SetXY(0, 0);
end;

{ TGPixmap }

function TGPixmap<TGColor>.GetPixel(X, Y: Integer): TGColor;
begin
  CheckLimits(X, Y);
  Move(PByte(FData + X * FBytesPerPixel + Y * FBytesPerLine)^, Result, SizeOf(TGColor));
end;

procedure TGPixmap<TGColor>.SetPixel(X, Y: Integer; AValue: TGColor);
begin
  CheckLimits(X, Y);
  Move(AValue, PByte(FData + X * FBytesPerPixel + Y * FBytesPerLine)^, SizeOf(TGColor));
end;

function TGPixmap<TGColor>.GetSize: TPoint;
begin
  Result := FSize;
end;

procedure TGPixmap<TGColor>.SetSize(AValue: TPoint);
begin
  if (FSize.X <> AValue.X) and (FSize.Y <> AValue.Y) then begin
    FSize := AValue;
    FBytesPerPixel := SizeOf(TGColor);
    FBytesPerLine := AValue.X * FBytesPerPixel;
    ReAllocMem(FData, FSize.X * FBytesPerLine);
  end;
end;

constructor TGPixmap<TGColor>.Create;
begin
  Size := Point(0, 0);
  FCanvas := TGCanvas<TGColor>.Create;
  FCanvas.Bitmap := Self;
end;

destructor TGPixmap<TGColor>.Destroy;
begin
  Size := Point(0, 0);
  FreeAndNil(FCanvas);
end;

procedure TGPixmap<TGColor>.CheckLimits(X, Y: Integer);
begin
  if (X < 0) or (X >= FSize.X) or (Y < 0) or (Y >= FSize.Y) then
    raise Exception.Create('Position out of range');
end;

procedure TGPixmap<TGColor>.Fill(Color: TGColor);
var
  X, Y: Integer;
begin
  for Y := 0 to FSize.Y - 1 do
    for X := 0 to FSize.X - 1 do
      Pixels[X, Y] := Color;
end;

procedure TGPixmap<TGColor>.Fill(Func: TGGetColor);
var
  X, Y: Integer;
begin
  for Y := 0 to FSize.Y - 1 do
    for X := 0 to FSize.X - 1 do
      Pixels[X, Y] := Func(Point(X, Y));
end;

procedure TGPixmap<TGColor>.PaintToCanvas(Canvas: TCanvas;
  ColorConvertFunc: TGConvertColor);
var
  X, Y: Integer;
begin
  try
  Canvas.Lock;
  for Y := 0 to FSize.Y - 1 do
    for X := 0 to FSize.X - 1 do begin
      Canvas.Pixels[X, Y] := ColorConvertFunc(Pixels[X, Y]);
    end;
  finally
    Canvas.Unlock;
  end;
end;

procedure TGPixmap<TGColor>.PaintToCanvas(Canvas: TCanvas; Rect: TRect;
  ColorConvertFunc: TGConvertColor);
var
  X, Y: Integer;
begin
  try
  Canvas.Lock;
  for Y := Rect.Top to Rect.Bottom - 1 do
    for X := Rect.Left to Rect.Right - 1 do
    if (X >= 0) and (X < FSize.X) and (Y >= 0) and (Y < FSize.Y) then begin
      Canvas.Pixels[X - Rect.Left, Y - Rect.Top] := ColorConvertFunc(Pixels[X, Y]);
    end;
  finally
    Canvas.Unlock;
  end;
end;

procedure TGPixmap<TGColor>.PaintToBitmap(Bitmap: TBitmap; Pos: TPoint;
  ColorConvertFunc: TGConvertColor);
var
  X, Y: Integer;
  DstPtr: TPixelPointer;
  SrcPtr: TPixelPointer;
begin
  try
    Bitmap.BeginUpdate(False);
    DstPtr.Init(Bitmap);
    SrcPtr.Init(FData, FBytesPerLine, FBytesPerPixel, Pos.X, Pos.Y);
    for Y := 0 to Bitmap.Height - 1 do begin
      for X := 0 to Bitmap.Width - 1 do begin
        if ((X + Pos.X) >= 0) and ((X + Pos.X) < FSize.X) and
        ((Y + Pos.Y) >= 0) and ((Y + Pos.Y) < FSize.Y) then begin
          PInteger(DstPtr.Pixel)^ := ColorConvertFunc(PGColor(SrcPtr.Pixel)^);
        end;
        DstPtr.NextPixel;
        SrcPtr.NextPixel;
      end;
      DstPtr.NextLine;
      SrcPtr.NextLine;
    end;
  finally
    Bitmap.EndUpdate(False);
  end;
end;

procedure TGPixmap<TGColor>.PaintToBitmap(Bitmap: TBitmap; Rect: TRect;
  ColorConvertFunc: TGConvertColor);
var
  X, Y: Integer;
  DstPtr: TPixelPointer;
  ZoomX: Single;
  ZoomY: Single;
  SrcX: Integer;
  SrcY: Integer;
begin
  try
    Bitmap.BeginUpdate(False);
    DstPtr.Init(Bitmap);
    ZoomX := Bitmap.Width / (Rect.Right - Rect.Left);
    ZoomY := Bitmap.Height / (Rect.Bottom - Rect.Top);
    for Y := 0 to Bitmap.Height - 1 do begin
      SrcY := Trunc(Y / ZoomY + Rect.Top);
      for X := 0 to Bitmap.Width - 1 do begin
        SrcX := Trunc(X / ZoomX + Rect.Left);
        if (SrcX >= 0) and (SrcX < FSize.X) and
        (SrcY >= 0) and (SrcY < FSize.Y) then begin
          PInteger(DstPtr.Pixel)^ := ColorConvertFunc(Pixels[SrcX, SrcY]);
        end;
        DstPtr.NextPixel;
      end;
      DstPtr.NextLine;
    end;
  finally
    Bitmap.EndUpdate(False);
  end;
end;

procedure TGPixmap<TGColor>.LoadFromCanvas(Canvas: TCanvas; ColorConvertFunc: TGConvertFromColor);
var
  X, Y: Integer;
begin
  try
  Canvas.Lock;
  for Y := 0 to FSize.Y - 1 do
    for X := 0 to FSize.X - 1 do begin
      Pixels[X, Y] := ColorConvertFunc(Canvas.Pixels[X, Y]);
    end;
  finally
    Canvas.Unlock;
  end;
end;

procedure TGPixmap<TGColor>.LoadFromBitmap(Bitmap: TBitmap; ColorConvertFunc: TGConvertFromColor);
var
  X, Y: Integer;
  SrcPtr: TPixelPointer;
  DstPtr: TPixelPointer;
begin
  try
    Bitmap.BeginUpdate(False);
    SrcPtr.Init(Bitmap);
    DstPtr.Init(FData, FBytesPerLine, FBytesPerPixel);
    for Y := 0 to FSize.Y - 1 do begin
      for X := 0 to FSize.X - 1 do begin
        if (X >= 0) and (X < FSize.X) and (Y >= 0) and (Y < FSize.Y) then
          PGColor(DstPtr.Pixel)^ := ColorConvertFunc(PInteger(SrcPtr.Pixel)^);
        SrcPtr.NextPixel;
        DstPtr.NextPixel;
      end;
      SrcPtr.NextLine;
      DstPtr.NextLine;
    end;
  finally
    Bitmap.EndUpdate(False);
  end;
end;

function TGPixmap<TGColor>.GetDataSize: Int64;
begin
  Result := FSize.Y * FBytesPerLine;
end;

procedure TGPixmap<TGColor>.Mirror;
var
  X, Y: Integer;
  Color: TGColor;
begin
  for Y := 0 to FSize.Y - 1 do
    for X := 0 to FSize.X div 2 - 1 do begin
      Color := Pixels[X, Y];
      Pixels[X, Y] := Pixels[Size.X - 1 - X, Y];
      Pixels[Size.X - 1 - X, Y] := Color;
    end;
end;

procedure TGPixmap<TGColor>.Flip;
var
  X, Y: Integer;
  Color: TGColor;
begin
  for Y := 0 to FSize.Y div 2 - 1 do
    for X := 0 to FSize.X - 1 do begin
      Color := Pixels[X, Y];
      Pixels[X, Y] := Pixels[X, Size.Y - 1 - Y];
      Pixels[X, Size.Y - 1 - Y] := Color;
    end;
end;

{ TGPen }

procedure TGPen<TGColor>.MoveTo(Pos: TPoint);
begin
  Position := Pos;
end;

procedure TGPen<TGColor>.LineTo(Pos: TPoint);
var
  I: Integer;
  Len: Integer;
begin
  Len := Trunc(Sqrt(Sqr(Position.X - Pos.X) + Sqr(Position.Y - Pos.Y)));
  for I := 0 to Len - 1 do
    ((Canvas as TGCanvas<TGColor>).Bitmap as TGPixmap<TGColor>).Pixels[Trunc(Position.X + I * (Pos.X - Position.X) / Len),
      Trunc(Position.Y + I * (Pos.Y - Position.Y) / Len)] := Color;
  Position := Pos;
end;

{ TGCanvas }

constructor TGCanvas<TGCanvas>.Create;
begin
  Pen := TGPen<TGColor>.Create;
  Pen.Canvas := Self;
  Brush := TGBrush<TGColor>.Create;
  Brush.Canvas := Self;
end;

destructor TGCanvas<TGCanvas>.Destroy;
begin
  FreeAndNil(Pen);
  FreeAndNil(Brush);
  inherited Destroy;
end;

{ TGPixmapBit }

procedure TGPixmapBit<TGColor>.BitMove(SourceBase: PByte; SourceOffset: Integer;
  DestBase: PByte; DestOffset: Integer; Size: Integer);
var
  Value: Byte;
  Mask: Word;
begin
  if ((SourceOffset + Size) > 8) or ((DestOffset + Size) > 8) then
    raise Exception.Create('Max. supported size for bit move is 8 bits.');
  Mask := ((1 shl Size) - 1);
  Value := (PByte(SourceBase)^ shr SourceOffset) and Mask;
  DestBase^ := (DestBase^ and ($ff xor (Mask shl DestOffset))) or (Value shl DestOffset);
end;

function TGPixmapBit<TGColor>.GetPixel(X, Y: Integer): TGColor;
var
  Offset: Integer;
begin
  CheckLimits(X, Y);
  Offset := (X + Y * FSize.X) * BitsPerPixel;
  BitMove(FData + (Offset shr 3), Offset and 7, @Result, 0, BitsPerPixel);
end;

procedure TGPixmapBit<TGColor>.SetPixel(X, Y: Integer; AValue: TGColor);
var
  Offset: Integer;
begin
  CheckLimits(X, Y);
  Offset := (X + Y * FSize.X) * BitsPerPixel;
  BitMove(@AValue, 0, FData + (Offset shr 3), Offset and 7, BitsPerPixel);
end;

function TGPixmapBit<TGColor>.GetDataSize: Int64;
begin
  Result := GetByteSize(FSize.X * FSize.Y * BitsPerPixel);
end;

function TGPixmapBit<TGColor>.GetByteSize(BitSize: Integer): Integer;
begin
  Result := (((BitSize - 1) or 7) + 1) shr 3;
end;

procedure TGPixmapBit<TGColor>.SetBitsPerPixel(AValue: Integer);
begin
  if FBitsPerPixel <> AValue then begin
    FBitsPerPixel := AValue;
  end;
end;

end.