LCL canvas graphics demo.

bounce.lpr

program bounce;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Interfaces, // this includes the LCL widgetset
  Forms, lazcontrols, ubounce;

{$R *.res}

begin
  RequireDerivedFormResource:=True;
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

ubounce.lfm

object Form1: TForm1
  Left = 240
  Height = 300
  Top = 120
  Width = 600
  Caption = 'Bouncing Balls'
  ClientHeight = 300
  ClientWidth = 600
  Constraints.MinHeight = 100
  Constraints.MinWidth = 200
  KeyPreview = True
  OnCreate = FormCreate
  OnKeyDown = FormKeyDown
  OnKeyPress = FormKeyPress
  OnKeyUp = FormKeyUp
  OnPaint = FormPaint
  OnResize = FormResize
  LCLVersion = '1.6.0.4'
  Visible = False
  object Timer1: TTimer
    Interval = 20
    OnTimer = Timer1Timer
    left = 16
    top = 8
  end
end

ubounce.pas

unit ubounce;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Graphics, Controls, ExtCtrls;

type
  { TForm1 }
  TForm1 = class(TForm)
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormKeyPress(Sender: TObject; var Key: char);
    procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

type
  TBall = record
    bc: TColor;      // ball color
    br: integer;     // ball radius
    bx,by: integer;  // ball x,y
    dx,dy: integer;  // delta x,y
    mx,my: integer;  // max x,y
    nx,ny: integer;  // min x,y
    gl,gu: boolean;  // go left, go up
  end;
const
  BALL_COUNT = 10;      // all balls count
  BALL_COLORS: array[1..18] of TColor =
    (clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clGray, clSkyBlue,
     clMOneyGreen, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clSilver, clWhite);
var
  Balls: array[1..BALL_COUNT] of TBall;
  vi: boolean = false;  // view info
  sb: boolean = false;  // select ball
  bi: integer = 1;      // ball index
  k: integer;  // key pressed

{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
begin
  Randomize;
  DoubleBuffered := true;
  Canvas.Pen.Style := psClear;

  for i := 1 to BALL_COUNT do
  with Balls[i] do
  begin
    bc := BALL_COLORS[random(18)+1];
    gl := false;
    gu := false;
    br := random(30)+20;
    bx := random(width)-br;
    by := random(height)-br;
    dx := random(9)+1;
    dy := random(9)+1;
    nx := 0;
    ny := 0;
    mx := width-br;
    my := height-br;
  end;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key = 83 then sb := true; // s
  k := key;
end;

procedure TForm1.FormKeyPress(Sender: TObject; var Key: char);
begin
  if Key = #27 then Close;
  if UpCase(Key) = 'R' then FormCreate(self);
  if UpCase(Key) = 'V' then vi := not vi;
  if UpCase(Key) = 'N' then
  begin
    bi := bi + 1;
    if bi > BALL_COUNT then bi := 1;
  end;
  if UpCase(Key) = 'P' then
  begin
    bi := bi - 1;
    if bi < 1 then bi := BALL_COUNT;
  end;
end;

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key = 83 then sb := false;
  k := key;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  i: integer;
begin
  for i := 0 to BALL_COUNT do
  with Balls[i] do
  begin
    Canvas.Brush.Color := bc;
    //if si and (i = bi) then Canvas.Brush.Color := Color;
    Canvas.Ellipse(bx,by,bx+br,by+br);
  end;
  if sb then
  begin
    //if bi > BALL_COUNT then bi := BALL_COUNT;
    Canvas.Brush.Color := Color;
    Canvas.Ellipse(Balls[bi].bx+4,Balls[bi].by+4,
                   Balls[bi].bx+Balls[bi].br-4,
                   Balls[bi].by+Balls[bi].br-4);
  end;
  if vi then
  begin
    Canvas.Pen.Color := clBlack;
    Canvas.Pen.Style := psSolid;
    Canvas.Brush.Style := bsClear;
    Canvas.TextOut(10,10,'['+IntToStr(bi)+']');
    Canvas.TextOut(40,10,'Pos = '+IntToStr(Balls[bi].bx)+':'+IntToStr(Balls[bi].by));
    Canvas.TextOut(40,30,'Vel = '+IntToStr(Balls[bi].dx)+':'+IntToStr(Balls[bi].dy));
    Canvas.TextOut(40,50,'Rad = '+IntToStr(Balls[bi].br)+'px');
    Canvas.TextOut(40,70,'Col = '+ColorToString(Balls[bi].bc));
    //Canvas.TextOut(40,90,'Key = '+IntToStr(k));
    Canvas.Pen.Style := psClear;
    Canvas.Brush.Style := bsSolid;
  end;
end;

procedure TForm1.FormResize(Sender: TObject);
var
  i: integer;
begin
  for i := 1 to BALL_COUNT do
  with Balls[i] do
  begin
    mx := width-br;
    my := height-br;
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  i: integer;
begin
  for i := 0 to BALL_COUNT do
  with Balls[i] do
  begin
    if gl then bx := bx - dx else bx := bx + dx;
    if gu then by := by - dy else by := by + dy;

    if bx < nx then
    begin
      bx := nx;
      gl := false;
    end;
    if bx > mx then
    begin
      bx := mx;
      gl := true;
    end;
    if by < ny then
    begin
      by := ny;
      gu := false;
    end;
    if by > my then
    begin
      by := my;
      gu := true;
    end;
  end;

  //Canvas.Brush.Color := Color;
  //Canvas.Clear;
  //for i := 0 to BALL_COUNT do
  //with Balls[i] do
  //begin
  //  Canvas.Brush.Color := bc;
  //  Canvas.Ellipse(bx,by,bx+br,by+br);
  //end;
  //Paint;

  Invalidate;
end;

end.

z_ubounce.gif