source: branches/gbitmap/Packages/FastGraphics/UGGraphics.pas

unit UGGraphics;

{$mode delphi}{$H+}

interface

uses
  Classes, SysUtils, Graphics;

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;
      TGGetColor = function (Position: TPoint): TGColor of object;
  protected
    FData: PByte;
    FSize: TPoint;
    FCanvas: TGCanvas<TGColor>;
    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);
    procedure Fill(Color: TGColor); overload;
    procedure Fill(Func: TGGetColor); overload;
    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;


implementation

{ TGPixmap }

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

procedure TGPixmap<TGColor>.SetPixel(X, Y: Integer; AValue: TGColor);
begin
  CheckLimits(X, Y);
  Move(AValue, PByte(FData + (X + Y * FSize.X) * SizeOf(TGColor))^, 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;
    ReAllocMem(FData, FSize.X * FSize.Y * SizeOf(TGColor));
  end;
end;

constructor TGPixmap<TGColor>.Create;
begin
  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;

function TGPixmap<TGColor>.GetDataSize: Int64;
begin
  Result := FSize.X * FSize.Y * SizeOf(TGColor);
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.