path: root/examples/corelib/canvastest/fpgcanvas.lpr

program fpgcanvas;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes, SysUtils,
  fpg_base,
  fpg_main,
  fpg_form,
  fpg_imgfmt_bmp;


type

  TMainForm = class(TfpgForm)
  private
    {@VFD_HEAD_BEGIN: MainForm}
    {@VFD_HEAD_END: MainForm}
    bmp: TfpgImage;
    dst: TfpgImage;
    procedure   FormPaint(Sender: TObject);
    procedure   CustomPaintJob;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure   AfterCreate; override;
  end;

{ TMainForm }

procedure TMainForm.FormPaint(Sender: TObject);
begin
  CustomPaintJob;
end;

// We can now call all the paint methods from HandlePaint or
// the OnPaint event.fpgcanvas
procedure TMainForm.CustomPaintJob;
var
  r: TfpgRect;
  fnt: TfpgFont;
  y: integer;
  c: TfpgColor;
  lImage: TfpgImage;
begin
  // Testing Rectangles
  Canvas.SetColor(clBlack);
  r.SetRect(0, 0, 1, 1);     // 1x1  (this is really a dot)
  Canvas.DrawRectangle(r);
  Canvas.SetColor(clRed);
  r.SetRect(0, 1, 1, 5);    // 1x5  (this is really a vertical line)
  Canvas.DrawRectangle(r);
  Canvas.SetColor(clMagenta);
  r.SetRect(1, 0, 5, 1);    // 5x1  (this is really a horizontal line)
  Canvas.DrawRectangle(r);

  Canvas.SetColor(clBlack);
  r.Top       := 5;
  r.Left      := 60;
  r.Width     := 50;
  r.Height    := 50;
  Canvas.DrawRectangle(r);

  r.Left      := 120;
  Canvas.SetLineStyle(2, lsDash);
  Canvas.DrawRectangle(r);

  r.Left      := 180;
  Canvas.SetColor(clGreen);
  Canvas.SetLineStyle(1, lsDot);
  Canvas.DrawRectangle(r);

  r.Left      := 240;
  Canvas.SetColor(clBlue);
  Canvas.SetLineStyle(1, lsSolid);
  Canvas.FillRectangle(r);


  // Testing line drawing
  Canvas.DrawLine(5, 5, 54, 54);
  Canvas.SetColor(clBlue);
  Canvas.DrawLine(54, 5, 5, 54);
  Canvas.SetColor(clRed);
  { Diagonal line }
  r.SetRect(60, 5, 50, 50);
  Canvas.DrawLine(r.Left, r.Top, r.Right, r.Bottom);
  { Horizontal line }
  Canvas.DrawLine(r.Left, r.Top-2, r.Right, r.Top-2);
  { Vertical line }
  Canvas.DrawLine(r.Left-2, r.Top, r.Left-2, r.Bottom);


  // Testing Text and Fonts
  y := 60;
  Canvas.SetTextColor(clBlack);
  Canvas.DrawString(5, y, 'This text must be black and default font (' + fpgApplication.DefaultFont.FontDesc + ')');

  // red dot indicates top/left corner of where previous text was started
  Canvas.Pixels[5,y] := clRed;
//  Canvas.DrawLine(5,y-4, 5,y+5);
//  Canvas.DrawLine(1,y, 10, y);

  Canvas.SetTextColor(clRed);
  y := y + Canvas.Font.Height;  // fonts are different sizes on differet OS's
  Canvas.DrawString(5, y, 'This text must be red.');
  Canvas.SetTextColor(clBlack);
  y := y + Canvas.Font.Height;
  Canvas.DrawString(5, y, 'Russian (UTF-8) text -> Òåñò');
  y := y + Canvas.Font.Height;
  fnt := fpgApplication.GetFont('Times-14:bold');
  Canvas.Font := fnt;
  Canvas.DrawString(5, y, 'Font used is ' + Canvas.Font.FontDesc);
  y := y + Canvas.Font.Height;


  // Testing basic style drawings
  Canvas.Font := fpgApplication.DefaultFont;
  Canvas.DrawString(320, 3, 'DrawButtonFace():');

  r.SetRect(300, 20, 75, 25);
  Canvas.DrawButtonFace(r, []);
  Canvas.DrawString(385, 20, '= []');
  r.Top := 50;
  Canvas.DrawButtonFace(r, [btfIsDefault]);
  Canvas.DrawString(385, 50, '= [btnIsDefault]');
  r.Top := 80;
  Canvas.DrawButtonFace(r, [btfIsPressed]);
  Canvas.DrawString(385, 80, '= [btnIsPressed]');
  r.Top := 110;
  Canvas.DrawButtonFace(r, [btfIsEmbedded, btfIsPressed]);
  Canvas.DrawString(385, 110, '= [embed & press]');
  r.Top := 140;
  Canvas.DrawButtonFace(r, [btfIsEmbedded]);
  Canvas.DrawString(385, 140, '= [btnIsEmbedded]');

  Canvas.DrawString(45, y, 'DrawControlFrame():');
  y := y + Canvas.Font.Height;
  Canvas.DrawControlFrame(5, y, 200, 23);


  // Testing Bitmap painting
  Canvas.DrawString(5, 180, 'Single BMP file:');
  Canvas.DrawString(310, 210, '(mask enabled for all images)');
  Canvas.DrawImage(150, 180, bmp);
  Canvas.DrawString(5, 210, 'Parts of BMP file:');
  Canvas.DrawImagePart(150, 210, bmp, 0, 0, 32, 21);
  Canvas.DrawImagePart(190, 210, bmp, 32, 0, 32, 21);
  Canvas.DrawImagePart(230, 210, bmp, 64, 0, 32, 21);
  // create image from an image
  r.SetRect(32, 0, 32, 21); // second button in image
  lImage := bmp.ImageFromRect(r);
  try
    lImage.CreateMaskFromSample(0, 0);
    lImage.UpdateImage;
    Canvas.DrawImage(270, 215, lImage);
  finally
    lImage.Free;
  end;


  // Testing Bitmap strechdraw
  Canvas.StretchDraw(150, 240, 300, 50, bmp);
  Canvas.DrawImage(150, 300, dst);
  Canvas.StretchDraw(180, 300, 70, 70, dst);
  Canvas.StretchDraw(265, 300, 230, 25, bmp);


  // testing accuracy of line/rectangle drawing
  Canvas.SetColor(clBlack);
  Canvas.SetLineStyle(1, lsSolid);
  r.SetRect(182, 302, 66, 66);
  Canvas.DrawRectangle(r);

  Canvas.SetColor(clBlue);
  Canvas.DrawLine(183, 303, 247, 303);


  // Testing Canvas.Pixels[]
  // two pixels should have changed color in the top left of the form
  Canvas.Pixels[7,5] := clBlue;   // This tests consistant bit order handling (RGB)
  Canvas.Pixels[8,5] := clRed;
  c := Canvas.Pixels[192, 227];   // should be orange like color
  Canvas.Pixels[9,5] := c;
  c := Canvas.Pixels[150 + (32*4) + 3, 199];   // should be lightblue like color
  Canvas.Pixels[10,5] := c;


  // Arc drawing tests
  Canvas.SetColor(clBlack);
  Canvas.DrawRectangle(5, 235, 50, 50);
  Canvas.SetColor(clRed);
  Canvas.DrawArc(5, 235, 50, 50, 0, 270);  // should overlap rectangle pixels
  Canvas.SetColor(clBlack);
  Canvas.DrawRectangle(5, 290, 50, 50);
  Canvas.SetColor(clRed);
  Canvas.FillArc(5, 290, 50, 50, 0, 270);  // should overlap rectangle pixels


  // Gradient testing
  r.SetRect(265, 340, 185, 35);
  Canvas.GradientFill(r, clBlue, clMagenta, gdHorizontal);
end;

constructor TMainForm.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  bmp := LoadImage_BMP('button.bmp');
  if not Assigned(bmp) then
    raise Exception.Create('Failed to load button.bmp');
  bmp.CreateMaskFromSample(0,0);
  bmp.UpdateImage;

  dst := LoadImage_BMP('gears2.bmp');
  dst.CreateMaskFromSample(0,0);
  dst.UpdateImage;
end;

destructor TMainForm.Destroy;
begin
  dst.Free;
  bmp.Free;
  inherited Destroy;
end;

procedure TMainForm.AfterCreate;
begin
  {%region 'Auto-generated GUI code' -fold}
  {@VFD_BODY_BEGIN: MainForm}
  Name := 'MainForm';
  SetPosition(357, 214, 500, 400);
  WindowTitle := 'fpGUI Canvas Test';
  Hint := '';
  WindowPosition := wpOneThirdDown;
  OnPaint := @FormPaint;

  {@VFD_BODY_END: MainForm}
  {%endregion}
end;


procedure MainProc;
var
  frm: TMainForm;
begin
  fpgApplication.Initialize;
  frm := TMainForm.Create(nil);
  frm.Show;
  fpgApplication.Run;
  frm.Free;
end;


begin
  MainProc;
end.