source: trunk/Packages/FastGraphics/UFGraphics.pas

unit UFGraphics;

{$mode delphi}

interface

uses
  Classes, SysUtils, Graphics, UGGraphics, UPixmapSpecialized, Fgl;

type
  TColorName = (cnBlack, cnWhite, cnBlue, cnRed, cnGreen, cnGray, cnSilver);

  IBColor = interface
    procedure SetColorName(ColorName: TColorName);
    procedure SetColor(Color: TColor);
    procedure SetRandom;
  end;

  { TBColor }

  TBColor = class(TInterfacedObject, IBColor)
    procedure SetColorName(ColorName: TColorName); virtual;
    procedure SetColor(Color: TColor); virtual;
    procedure SetRandom; virtual;
  end;

  IBColorClass = class of TBColor;

  { TBPixmap }

  TBPixmap = class
  public
    type
      TGetColorPos = function (Position: TPoint): IBColor of object;
  private
    FSize: TPoint;
  protected
    function GetPixel(X, Y: Integer): IBColor;  virtual;
    procedure SetPixel(X, Y: Integer; AValue: IBColor); virtual;
    procedure SetSize(AValue: TPoint); virtual;
  public
    procedure Mirror; virtual;
    procedure Flip; virtual;
    procedure Negative; virtual;
    procedure Fill(Color: IBColor); virtual; overload;
    procedure Fill(Func: TGetColorPos); virtual; overload;
    procedure Line(P1, P2: TPoint; Color: IBColor); virtual;
    procedure PaintToCanvas(Canvas: TCanvas); virtual; overload;
    procedure PaintToCanvas(Canvas: TCanvas; Rect: TRect); virtual; overload;
    procedure PaintToBitmap(Bitmap: TBitmap; Rect: TRect); virtual;
    procedure LoadFromCanvas(Canvas: TCanvas); virtual;
    procedure LoadFromBitmap(Bitmap: TBitmap); virtual;
    function GetDataSize: Integer; virtual;
    constructor Create; virtual;
    property Size: TPoint read FSize write SetSize;
    property Pixels[X, Y: Integer]: IBColor read GetPixel write SetPixel;
  end;

  TBPixmapClass = class of TBPixmap;

  { TColorFormatChannel }

  TColorFormatChannel = record
    Name: string;
    Position: Integer;
    BitWidth: Integer;
  end;

  { TColorFormat }

  TColorFormat = class
    Name: string;
    BitDepth: Integer;
    Channels: array of TColorFormatChannel;
    BackendColorClass: IBColorClass;
    BackendPixmapClass: TBPixmapClass;
    procedure AddChannel(Name: string; Position, BitWidth: Integer);
    function GetBackendColor: IBColor;
    function GetBackendImage: TBPixmap;
    constructor Create; virtual;
    function GetChannelStateCount(Channel: Integer): Integer;
  end;

  TColorFormats  = class(TFPGObjectList<TColorFormat>)
  end;

  TColorFormatClass = class of TColorFormat;

  { TColorFormatManager }

  TColorFormatManager = class
  private
    FFormats: TColorFormats;
    function GetFormat(Index: Integer): TColorFormat;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    function FindByName(Name: string): Integer;
    procedure RegisterFormat(Format: TColorFormatClass);
    function FormatCount: Integer;
    property Formats: TColorFormats read FFormats;
  end;

  IFColor = interface
  end;

  { TFColor }

  TFColor = class(TInterfacedObject, IFColor)
  private
    FBackend: IBColor;
    FColorFormat: TColorFormat;
    procedure SetColorFormat(AValue: TColorFormat);
  public
    property Backend: IBColor read FBackend;
    property ColorFormat: TColorFormat read FColorFormat write SetColorFormat;
    procedure SetColorName(ColorName: TColorName);
    procedure SetRandom;
    procedure SetColor(Color: TColor);
    constructor Create; overload;
    constructor Create(ColorFormat: TColorFormat; ColorName: TColorName); overload;
    constructor Create(ColorFormat: TColorFormat; Color: TColor); overload;
    destructor Destroy; override;
  end;

  TFCanvas = class;
  TFPixmap = class;

  { TFBrush }

  TFBrush = class
    Color: IFColor;
    Canvas: TFCanvas;
  end;

  { TFPen }

  TFPen = class
    Position: TPoint;
    Color: IFColor;
    Canvas: TFCanvas;
    procedure MoveTo(Pos: TPoint);
    procedure LineTo(Pos: TPoint);
  end;

  { TFCanvas }

  TFCanvas = class
    Pixmap: TFPixmap;
    Pen: TFPen;
    Brush: TFBrush;
    constructor Create;
    destructor Destroy; override;
  end;


  { TFPixmap }

  TFPixmap = class(TComponent)
  public
    type
      TGetColorPos = function (Position: TPoint; ColorFormat: TColorFormat): IFColor of object;
  private
    FBackend: TBPixmap;
    FCanvas: TFCanvas;
    FColorFormat: TColorFormat;
    FSize: TPoint;
    FillCallBack: TGetColorPos;
    function FillGetColor(Position: TPoint): IBColor;
    function GetPixel(X, Y: Integer): IFColor;
    procedure SetColorFormat(AValue: TColorFormat);
    procedure SetPixel(X, Y: Integer; AValue: IFColor);
    procedure SetSize(AValue: TPoint);
    function ColorRandom(Position: TPoint; ColorFormat: TColorFormat): IFColor;
  public
    procedure Clear;
    procedure Flip;
    procedure Mirror;
    procedure Gradient;
    procedure Negative;
    procedure Random;
    procedure Fill(Color: IFColor); overload;
    procedure Fill(Func: TGetColorPos); overload;
    procedure PaintToCanvas(Canvas: TCanvas); overload;
    procedure PaintToCanvas(Canvas: TCanvas; Rect: TRect); overload;
    procedure PaintToBitmap(Bitmap: TBitmap; Rect: TRect); overload;
    procedure LoadFromCanvas(Canvas: TCanvas);
    procedure LoadFromBitmap(Bitmap: TBitmap);
    function GetDataSize: Integer;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas: TFCanvas read FCanvas;
    property Backend: TBPixmap read FBackend;
    property ColorFormat: TColorFormat read FColorFormat write SetColorFormat;
    property Size: TPoint read FSize write SetSize;
    property Pixels[X, Y: Integer]: IFColor read GetPixel write SetPixel;
  end;

procedure Register;

var
  ColorFormatManager: TColorFormatManager;


implementation

uses
  UColorGray1, UColorGray2,UColorGray4, UColorGray8, UColorRGB8, UColorRGBA8,
  UColorRGB565, UColorRGB16;

procedure Register;
begin
  RegisterComponents('FastGraphics', [TFPixmap]);
end;

{ TFPen }

procedure TFPen.MoveTo(Pos: TPoint);
begin
  Position := Pos;
end;

procedure TFPen.LineTo(Pos: TPoint);
begin
  Canvas.Pixmap.Backend.Line(Position, Pos, (Color as TFColor).Backend);
  Position := Pos;
end;

{ TFCanvas }

constructor TFCanvas.Create;
begin
  Pen := TFPen.Create;
  Pen.Canvas := Self;
  Brush := TFBrush.Create;
  Brush.Canvas := Self;
end;

destructor TFCanvas.Destroy;
begin
  FreeAndNil(Pen);
  FreeAndNil(Brush);
  inherited Destroy;
end;

{ TBColor }

procedure TBColor.SetColorName(ColorName: TColorName);
begin
end;

procedure TBColor.SetColor(Color: TColor);
begin
end;

procedure TBColor.SetRandom;
begin
end;

{ TColorFormatManager }

function TColorFormatManager.GetFormat(Index: Integer): TColorFormat;
begin
  Result := TColorFormat(FFormats[Index]);
end;

constructor TColorFormatManager.Create;
begin
  FFormats := TColorFormats.Create;
end;

destructor TColorFormatManager.Destroy;
begin
  FreeAndNil(FFormats);
  inherited Destroy;
end;

function TColorFormatManager.FindByName(Name: string): Integer;
var
  I: Integer;
begin
  Result := -1;
  for I := 0 to FFormats.Count - 1 do begin
    if FFormats[I].Name = Name then begin
      Result := I;
      Break;
    end;
  end;
end;

procedure TColorFormatManager.RegisterFormat(Format: TColorFormatClass);
begin
  FFormats.Add(Format.Create);
end;

function TColorFormatManager.FormatCount: Integer;
begin
  Result := FFormats.Count;
end;

{ TColorFormat }

procedure TColorFormat.AddChannel(Name: string; Position, BitWidth: Integer);
begin
  SetLength(Channels, Length(Channels) + 1);
  Channels[Length(Channels) - 1].Name := Name;
  Channels[Length(Channels) - 1].Position := Position;
  Channels[Length(Channels) - 1].BitWidth := BitWidth;
end;

function TColorFormat.GetBackendColor: IBColor;
begin
  Result := BackendColorClass.Create;
end;

function TColorFormat.GetBackendImage: TBPixmap;
begin
  Result := BackendPixmapClass.Create;
end;

constructor TColorFormat.Create;
begin
  Name := 'None';
  BitDepth := 0;
  BackendColorClass := TBColor;
  BackendPixmapClass := TBPixmap;
end;

function TColorFormat.GetChannelStateCount(Channel: Integer): Integer;
begin
  Result := 1 shl Channels[Channel].BitWidth;
end;

{ TFColor }

procedure TFColor.SetColorFormat(AValue: TColorFormat);
begin
  if FColorFormat = AValue then Exit;
  FBackend := AValue.GetBackendColor;
  FColorFormat := AValue;
end;

procedure TFColor.SetColorName(ColorName: TColorName);
begin
  FBackend.SetColorName(ColorName);
end;

procedure TFColor.SetRandom;
begin
  FBackend.SetRandom;
end;

procedure TFColor.SetColor(Color: TColor);
begin
  Backend.SetColor(Color);
end;

constructor TFColor.Create;
begin
  ColorFormat := ColorFormatManager.GetFormat(0);
end;

constructor TFColor.Create(ColorFormat: TColorFormat; ColorName: TColorName);
begin
  Self.ColorFormat := ColorFormat;
  Backend.SetColorName(ColorName);
end;

constructor TFColor.Create(ColorFormat: TColorFormat; Color: TColor);
begin
  Self.ColorFormat := ColorFormat;
  Backend.SetColor(Color);
end;

destructor TFColor.Destroy;
begin
  FColorFormat := nil;
  inherited Destroy;
end;

{ TBPixmap }

function TBPixmap.GetPixel(X, Y: Integer): IBColor;
begin
  Result := TBColor.Create;
end;

procedure TBPixmap.SetPixel(X, Y: Integer; AValue: IBColor);
begin
end;

procedure TBPixmap.SetSize(AValue: TPoint);
begin
  if (FSize.X = AValue.X) and (FSize.Y = AValue.Y) then Exit;
  FSize := AValue;
end;

procedure TBPixmap.Mirror;
begin
end;

procedure TBPixmap.Flip;
begin
end;

procedure TBPixmap.Negative;
begin
end;

procedure TBPixmap.Fill(Color: IBColor);
begin
end;

procedure TBPixmap.Fill(Func: TGetColorPos);
begin
end;

procedure TBPixmap.Line(P1, P2: TPoint; Color: IBColor);
begin
end;

procedure TBPixmap.PaintToCanvas(Canvas: TCanvas);
begin
end;

procedure TBPixmap.PaintToCanvas(Canvas: TCanvas; Rect: TRect);
begin
end;

procedure TBPixmap.PaintToBitmap(Bitmap: TBitmap; Rect: TRect);
begin
end;

procedure TBPixmap.LoadFromCanvas(Canvas: TCanvas);
begin
end;

procedure TBPixmap.LoadFromBitmap(Bitmap: TBitmap);
begin
end;

function TBPixmap.GetDataSize: Integer;
begin
  Result := 0;
end;

constructor TBPixmap.Create;
begin
  Size := Point(0, 0);
end;

{ TFPixmap }

procedure TFPixmap.SetColorFormat(AValue: TColorFormat);
begin
  if FColorFormat = AValue then Exit;
  FBackend.Free;
  FBackend := AValue.GetBackendImage;
  FBackend.Size := FSize;
  FColorFormat := AValue;
end;

function TFPixmap.FillGetColor(Position: TPoint): IBColor;
begin
  Result := (FillCallBack(Position, ColorFormat) as TFColor).Backend;
end;

function TFPixmap.GetPixel(X, Y: Integer): IFColor;
begin
  Result := TFColor.Create;
  (Result as TFColor).ColorFormat := ColorFormat;
  (Result as TFColor).FBackend := FBackend.Pixels[X, Y];
end;

procedure TFPixmap.SetPixel(X, Y: Integer; AValue: IFColor);
begin
  FBackend.Pixels[X, Y] := (AValue as TFColor).FBackend;
end;

procedure TFPixmap.SetSize(AValue: TPoint);
begin
  if (FSize.X = AValue.X) and (FSize.Y = AValue.Y) then Exit;
  FSize := AValue;
  FBackend.Size := AValue;
end;

function TFPixmap.ColorRandom(Position: TPoint; ColorFormat: TColorFormat
  ): IFColor;
begin
  Result := TFColor.Create;
  (Result as TFColor).ColorFormat := ColorFormat;
  (Result as TFColor).SetRandom;
end;

procedure TFPixmap.Clear;
begin

end;

procedure TFPixmap.Flip;
begin
  FBackend.Flip;
end;

procedure TFPixmap.Mirror;
begin
  FBackend.Mirror;
end;

procedure TFPixmap.Gradient;
var
  X, Y: Integer;
  Color: IFColor;
begin
  Color := TFColor.Create;
  (Color as TFColor).ColorFormat := ColorFormat;
  for Y := 0 to Size.Y div 4 - 1 do
    for X := 0 to Size.X - 1 do begin
      (Color as TFColor).SetColor(RGBToColor(
        Trunc(X / Size.X * 256),
        0,
        0
      ));
      Pixels[X, Y] := Color;
    end;
  for Y := Size.Y div 4 to 2 * Size.Y div 4 - 1 do
    for X := 0 to Size.X - 1 do begin
      (Color as TFColor).SetColor(RGBToColor(
        0,
        Trunc(X / Size.X * 256),
        0
      ));
      Pixels[X, Y] := Color;
    end;
  for Y := 2 * Size.Y div 4 to 3 * Size.Y div 4 - 1 do
    for X := 0 to Size.X - 1 do begin
      (Color as TFColor).SetColor(RGBToColor(
        0,
        0,
        Trunc(X / Size.X * 256)
      ));
      Pixels[X, Y] := Color;
    end;
  for Y := 3 * Size.Y div 4 to Size.Y - 1 do
    for X := 0 to Size.X - 1 do begin
      (Color as TFColor).SetColor(RGBToColor(
        Trunc(X / Size.X * 256),
        Trunc(X / Size.X * 256),
        Trunc(X / Size.X * 256)
      ));
      Pixels[X, Y] := Color;
    end;
end;

procedure TFPixmap.Negative;
begin
  FBackend.Negative;
end;

procedure TFPixmap.Random;
begin
  Fill(ColorRandom);
end;

procedure TFPixmap.Fill(Color: IFColor);
begin
  FBackend.Fill((Color as TFColor).Backend);
end;

procedure TFPixmap.Fill(Func: TGetColorPos);
begin
  FillCallBack := Func;
  FBackend.Fill(FillGetColor);
end;

procedure TFPixmap.PaintToCanvas(Canvas: TCanvas);
begin
  FBackend.PaintToCanvas(Canvas);
end;

procedure TFPixmap.PaintToCanvas(Canvas: TCanvas; Rect: TRect);
begin
  FBackend.PaintToCanvas(Canvas, Rect);
end;

procedure TFPixmap.PaintToBitmap(Bitmap: TBitmap; Rect: TRect);
begin
  FBackend.PaintToBitmap(Bitmap, Rect);
end;

procedure TFPixmap.LoadFromCanvas(Canvas: TCanvas);
begin
  Backend.LoadFromCanvas(Canvas);
end;

procedure TFPixmap.LoadFromBitmap(Bitmap: TBitmap);
begin
  Backend.LoadFromBitmap(Bitmap);
end;

function TFPixmap.GetDataSize: Integer;
begin
  Result := FBackend.GetDataSize;
end;

constructor TFPixmap.Create(AOwner: TComponent);
begin
  inherited;
  FBackend := TBPixmap.Create;
  FCanvas := TFCanvas.Create;
  FCanvas.Pixmap := Self;
  ColorFormat := ColorFormatManager.GetFormat(0);
end;

destructor TFPixmap.Destroy;
begin
  FreeAndNil(FCanvas);
  FreeAndNil(FBackend);
  inherited Destroy;
end;


initialization

ColorFormatManager := TColorFormatManager.Create;
with ColorFormatManager do begin
  RegisterFormat(TColorFormat);
  RegisterFormat(TColorFormatGray1);
  RegisterFormat(TColorFormatGray2);
  RegisterFormat(TColorFormatGray4);
  RegisterFormat(TColorFormatGray8);
  RegisterFormat(TColorFormatRGB8);
  RegisterFormat(TColorFormatRGBA8);
  RegisterFormat(TColorFormatRGB565);
  RegisterFormat(TColorFormatRGB16);
end;


finalization

FreeAndNil(ColorFormatManager);


end.