Using Multiple Coded Forms

All of the Smart Pascal contributions to date have been canvas projects. Here we show that motion graphics can perform well in form-based projects. The starting point in the development of the demo Compendium was the supplied Mega Demo in the Forms & Components section, and a little of the original code remains unaltered. We reuse much of the code of contributions by Felix Thompson (Ball Trajectory and MaxCircles), Alex Karet (BlendingEllipses) and George Wright (ObjectMovingBalls).

The visual graphics become slow when they are being computed simultaneously, so we allow the user to view each one then free it and remove that option from the menu.

If the program does not work, try another browser such as Chrome. If you see no display at school, the security system might have blocked it. You can try instead this direct link to the program running on its own page.

Code of Unit1

unit Unit1;

{
    Motion Graphics copyright (c) 2014 Alex Karet (BlendingEllipses), Felix Thompson
    (MaxCircles and BallTrajectory) and George Wright (ObjectMovingBalls)

    Licensed under the Apache License, Version 2.0 (the "License"); you may not
    use this file except in compliance with the License, as described at
    http://www.apache.org/licenses/ and http://www.pp4s.co.uk/licenses/

    Motion Graphics included in Compendium by PPS, 2016
}

interface

uses
  System.Types, System.Colors, System.Lists, SmartCL.System, SmartCL.Controls,
  SmartCL.Components, SmartCL.Forms, SmartCL.Graphics, SmartCL.Application,
  SmartCL.Effects, SmartCL.Time;

type
  THeaderForm = class(TW3CustomForm)
  private
    FHeader: TW3HeaderControl;
  protected
    procedure Resize; override;
    procedure InitializeObject; override;
    procedure FinalizeObject; override;
  public
    property Header: TW3HeaderControl read FHeader;
  end;

  TBaseView = class(TW3GraphicControl) // Base view for four motion graphics views
  public
    FTimer: TW3EventRepeater;
    FFrameCount: integer;
  protected
    procedure FinalizeObject; override;
  end;

  TBaseForm = class(THeaderForm)  // Base form for four motion graphics forms
  public
    FView: TBaseView;
  protected
    procedure InitializeObject; override;
  end;

  TMainForm = class(THeaderForm)
  private
    FMenu: TW3ListMenu;
    FBallTrajectory, FMaxCircles, FBlendingEllipses, FObjectMovingBalls: TW3ListItem;
    procedure HandleMenuItemClicked(Sender: TObject);
  protected
    procedure Resize; override;
    procedure InitializeObject; override;
    procedure FinalizeObject; override;
  end;

  // BallTrajectory

  TBallTrajectoryView = class(TBaseView)
  private
    t: Integer;
    mX, mY, vX, vY : Real;
  protected
    procedure Paint; override;
    procedure InitializeObject; override;
  end;

  TBallTrajectoryForm = class(TBaseForm)
  public
    FBallTrajectoryView: TBallTrajectoryView;
  protected
    procedure InitializeObject; override;
  end;

  // Max Circles

  TMaxCirclesView = class(TBaseView)
  private
    PastX, PastY, PastR : Array [1..100000] of Integer;
    Colour1, Colour2, Colour3, CircleCount, W, HW, CurX, CurY, CurR,
      MaxX, MaxY, MaxR : Integer;
  protected
    procedure Paint; override;
    procedure InitializeObject; override;
  end;

  TMaxCirclesForm = class(TBaseForm)
  public
    FMaxCirclesView: TMaxCirclesView;
  protected
    procedure InitializeObject; override;
  end;

  // BlendingEllipses

  TBlendingEllipsesView = class(TBaseView)
  private
    first: boolean = true;
  protected
    procedure Paint; override;
    procedure InitializeObject; override;
  end;

  TBlendingEllipsesForm = class(TBaseForm)
  public
    FBlendingEllipsesView: TBlendingEllipsesView;
  protected
    procedure InitializeObject; override;
  end;

  // ObjectMovingBalls

  TBall = class(TObject)
  private
     x, y, width, height : float;
     colour : string;
     Speed : integer;
  public
    constructor create(newX, newY, newHeight, newWidth: float; newColour: string; newSpeed : integer);
    procedure move;
  end;

  TObjectMovingBallsView = class(TBaseView)
  private
    const DELAY = 50;
    Ball : array [0..6] of  TBall;
    Timer : integer;
  protected
    procedure Paint; override;
    procedure InitializeObject; override;
  end;

  TObjectMovingBallsForm = class(TBaseForm)
  public
    FObjectMovingBallsView: TObjectMovingBallsView;
  protected
    procedure InitializeObject; override;
  end;

implementation

procedure TBaseView.FinalizeObject;
begin
  if Assigned(FTimer) then
    FTimer.Free;
  inherited;
end;

// BallTrajectory

procedure TBallTrajectoryView.InitializeObject;
begin
  inherited;
  mX := 150;                               // The ball starts in the centre of the
  mY := 150;                               // screen after each refresh.
  vX := (100 - RandomInt(200));            // A random vertical and
  vY := 20* (10 - RandomInt(20));
  w3_setStyle(Handle, 'backgroundColor', '#FFFFFF');
end;

procedure TBallTrajectoryView.Paint;
begin
  inc(FFrameCount);
  if FFrameCount < 30 then
    exit;
  Canvas.FillStyle := 'white';
  Canvas.FillRectF(0, 0, 600, 600); //The screen in drawn with edges.

  Canvas.FillStyle := 'Black';
  Canvas.FillRectF(0, 299 , 300, 1);
  Canvas.FillStyle := 'Black';
  Canvas.FillRectF(299, 0, 1, 300);
  Canvas.FillStyle := 'Black';
  Canvas.FillRectF(0, 0 , 300, 1);
  Canvas.FillStyle := 'Black';
  Canvas.FillRectF(0, 0, 1, 300);

  t += 1;
  vY := vY - 0.2 * t;           //Vertical velocity always increases downwards - gravity.
  mY -= 0.1 * vY;               //The speeds are added to the current location
  mX -= 0.1 * vX;               //to give the new position.

  if mY + 10 >= 300 then        //This stops the ball from going underground,
    begin                       //it reverses its direction on collision and
      vy := -vY * 0.9;          //loses a factor of its speed - restitution.
      mY := 290;
    end;
  if mY - 10 <= 0 then
    begin
      vy := -vY * 0.9;
      mY := 10;
    end;
  if (mX + 10 >= 300) AND (Abs(vX) > 0.01) then
    begin
      vX := -vX * 0.9;
      mX := 290;
    end;                        // The same happens here but for the walls.
  if (mX - 10 <= 0) AND (Abs(vX) > 0.01) then
    begin
      vX := -vX * 0.9;
      mX := 10;
    end;                        //If the ball is on the ground it loses
  if (mY = 290) then            //horizontal speed - friction.
    begin
      vX := vX * 0.95;
    end;

  Canvas.FillStyle := 'Black';  //The ball is drawn
  Canvas.BeginPath;
  Canvas.Ellipse(Round(mX) + 10, Round(mY) + 10, Round(mX) -10, Round(mY) - 10);
  Canvas.Fill;
end;

procedure TBallTrajectoryForm.InitializeObject;
begin
  inherited;
  Header.Title.Caption := 'BallTrajectory by Felix Thompson';
  FView := TBallTrajectoryView.Create(Self);
  FView.SetBounds(10, 50, 300, 300);
end;

// MaxCircles

procedure TMaxCirclesView.InitializeObject;
begin
  inherited;
  Randomize;
  W := 300;      // The width is set and the half-width is calculated
  HW := W DIV 2; // as they are both used repeatedly
  w3_setStyle(Handle, 'backgroundColor', '#000000');
end;

procedure TMaxCirclesView.Paint;
var
  Count, Count2, Count3 : Integer;
begin
  inc(FFrameCount);
  if FFrameCount < 50 then
    exit;
  if CircleCount = 0 then
    begin                            //The screen is drawn a specific
      Canvas.FillStyle := 'Black';   //colour when the program starts.
      Canvas.FillRect(0, 0, W, W);
    end;

  Colour1 := RandomInt(175);
  Colour2 := RandomInt(100) + 156;   //The colours are biased to be
  Colour3 := RandomInt(100) + 100;   //certain hues.

  CurX := RandomInt(W + 1);            //The first circle is plotted
  CurY := RandomInt(W + 1);            //randomly.

  CurR := HW - ABS(HW - CurX);
  if CurR > (HW - ABS(HW - CurY)) then   //This makes the radius such that
    CurR := HW - ABS(HW - CurY);         //it touches the closest edge.

  MaxR := 0;

  if CircleCount <> 0 then
    begin
      for Count := 1 to W do
        begin
          CurX := Count;
          for Count2 := 1 to W do
            begin                       //This scans through each pixel
              CurY := Count2;           //and determines the maximum size
                                        //of a circle plotted at that point
              CurR := HW - ABS(HW - CurX);
              if CurR > (HW - ABS(HW - CurY)) then
                CurR := HW - ABS(HW - CurY);
                                                  //Here it finds the radius that makes
              for Count3 := 1 to CircleCount do  //it touch the edge of another circle.
                begin
                  if CurR > (Sqrt(Sqr(CurX - PastX[Count3]) + Sqr(CurY - PastY[Count3])) - PastR[Count3]) then
                    CurR := Round(Sqrt(Sqr(CurX - PastX[Count3]) + Sqr(CurY - PastY[Count3])) - PastR[Count3]);
                  if CurR <= 0 then
                    Break;                   //If the pixel is inside a circle it is
                end;                         //discounted

              if CurR > MaxR then
                begin                //It checks if it is the largest possible
                  MaxX := CurX;      //circle drawable. If it is it saves the point
                  MaxY := CurY;
                  MaxR := CurR;
                end;
            end;
        end;
      CurX := MaxX;             //The centre and radius of the largest
      CurY := MaxY;             //circle is loaded for use.
      CurR := MaxR;
    end;

  if CurR <> 0 then              //Checks that the circle has size.
    begin
      Canvas.FillStyle := 'rgb('+IntToStr(Colour1)+ ',' + IntToStr(Colour2) + ','
                                + IntToStr(Colour3) + ')';
      Canvas.BeginPath; //Draw the circle.
      Canvas.Ellipse(CurX - CurR, CurY - CurR, CurX + CurR, CurY + CurR);
      Canvas.Fill;

      Inc(CircleCount);            //The location and size is saved
      PastX[CircleCount] := CurX;  //so the circles will not overlap.
      PastY[CircleCount] := CurY;
      PastR[CircleCount] := CurR;
    end;
end;

procedure TMaxCirclesForm.InitializeObject;
begin
  inherited;
  Header.Title.Caption := 'MaxCircles by Felix Thompson';
  FView := TMaxCirclesView.Create(Self);
  FView.SetBounds(10, 50, 300, 300);
end;

// BlendingEllipses

procedure TBlendingEllipsesView.InitializeObject;
begin
  inherited;
  Randomize;
  AlphaBlend := True;
  w3_setStyle(Handle, 'backgroundColor', '#000000');
end;

procedure TBlendingEllipsesView.Paint;
var
  Draw: array [1..4] of integer;
  color: integer;
begin
  inc(FFrameCount);
  if FFrameCount < 30 then
    exit;
    // Clear background
  if first then begin
     Canvas.FillStyle := 'black';
     Canvas.FillRectF(0, 0, 600, 400);
     first := False;
  end;
  draw[1] := RandomInt(600);
  draw[2] := RandomInt(400);
  draw[3] := draw[1] + RandomInt(100);
  draw[4] := draw[2] + RandomInt(100);
  color := round((random * 10) / 2);
  Canvas.FillStyle := 'rgba(' + inttostr(randomint(255)) + ',' + inttostr(randomint(255)) +
                            ',' + inttostr(randomint(255)) + ',' + floattostr(random / 2) + ')';
  Canvas.BeginPath;
  Canvas.Ellipse(draw[1], draw[2], draw[3], draw[4]);
  Canvas.Fill;
end;

procedure TBlendingEllipsesForm.InitializeObject;
begin
  inherited;
  Header.Title.Caption := 'BlendingEllipses by Alex Karet';
  FView := TBlendingEllipsesView.Create(Self);
  FView.SetBounds(10, 50, 600, 400);
end;

// ObjectMovingBalls

constructor TBall.create(newX, newY, newHeight, newWidth : float; newColour : string; newSpeed : integer);
begin
  x := newX;
  y := newY;
  height := newHeight;
  width := newWidth;
  colour := newColour;
  speed := newSpeed;
end;

procedure TBall.move;
begin
  if (x < 300 - width) and (y <= 0) then
    x += speed;

  if (x >= 300 - width) and (y < 300 - height) then
    y += speed;

  if (x > 0) and (y >= 300 - height) then
    x -= speed;

  if (y > 0) and (x <= 0) then
    y -= speed;

  if x > 300 - width then
    x := 300 - width;
  if x < 0 then
    x := 0;
  if y < 0 then
    y := 0;
  if y > 300 - height then
    y := 300 - height;
end;

procedure TObjectMovingBallsView.InitializeObject;
begin
  inherited;
  Randomize;
  Timer := 0;
                         //newX, newY, newHeight, newWidth, newColour, newSpeed
  Ball[0] := TBall.create(- DELAY, 0, DELAY - 10, DELAY - 10, 'red', 1);
  Ball[1] := TBall.create(- DELAY * 2, 0, DELAY - 10, DELAY - 10, 'orange', 2);
  Ball[2] := TBall.create(- DELAY * 3, 0, DELAY - 10, DELAY - 10, 'yellow', 3);
  Ball[3] := TBall.create(- DELAY * 4, 0, DELAY - 10, DELAY - 10, 'green', 4);
  Ball[4] := TBall.create(- DELAY * 5, 0, DELAY - 10, DELAY - 10, 'blue', 5);
  Ball[5] := TBall.create(- DELAY * 6, 0, DELAY - 10, DELAY - 10, 'purple', 6);
  Ball[6] := TBall.create(- DELAY * 7, 0, DELAY - 10, DELAY - 10, 'rgb(153, 50, 204)', 7);

  w3_setStyle(Handle, 'backgroundColor', '#FFFFFF');
end;

procedure TObjectMovingBallsView.Paint;
var
  i: integer;
begin
  inc(FFrameCount);
  if FFrameCount < 30 then
    exit;
  if Timer = 0 then
    begin
      // Clear background
      Canvas.FillStyle := 'white';
      Canvas.FillRectF(0, 0, 400, 400);
    end;
  while i <= 6 do
    begin
      Canvas.FillStyle := (Ball[i].colour);
      Canvas.BeginPath;
      Canvas.Ellipse(Ball[i].x, Ball[i].y, Ball[i].x + Ball[i].width, Ball[i].y + Ball[i].height);
      Canvas.ClosePath;
      Canvas.Fill;
      Ball[i].move;
      inc(i);
    end;
  i := 0;
  Timer += 1;
end;

procedure TObjectMovingBallsForm.InitializeObject;
begin
  inherited;
  Header.Title.Caption := 'ObjectMovingBalls by George Wright';
  FView := TObjectMovingBallsView.Create(Self);
  FView.SetBounds(10, 50, 600, 400);
end;

procedure TMainForm.InitializeObject;
begin
  inherited;
  Header.BackButton.Visible := False;
  Header.Title.Caption := Application.Name;

  FMenu := TW3ListMenu.Create(Self);
  FMenu.Enabled := True;

  FBallTrajectory := FMenu.Items.Add;
  FBallTrajectory.Text := 'BallTrajectory by Felix Thompson';
  FBallTrajectory.TagValue := 1;
  FBallTrajectory.OnClick := HandleMenuItemClicked;

  FMaxCircles := FMenu.Items.Add;
  FMaxCircles.Text := 'MaxCircles by Felix Thompson';
  FMaxCircles.TagValue := 2;
  FMaxCircles.OnClick := HandleMenuItemClicked;

  FBlendingEllipses := FMenu.Items.Add;
  FBlendingEllipses.Text := 'BlendingEllipses by Alex Karet';
  FBlendingEllipses.TagValue := 3;
  FBlendingEllipses.OnClick := HandleMenuItemClicked;

  FObjectMovingBalls := FMenu.Items.Add;
  FObjectMovingBalls.Text := 'ObjectMovingBalls by GeorgeWright';
  FObjectMovingBalls.TagValue := 4;
  FObjectMovingBalls.OnClick := HandleMenuItemClicked;

  var Quit := FMenu.Items.Add;
  Quit.Text := 'Quit';
  Quit.TagValue := 5;
  Quit.OnClick := HandleMenuItemClicked;
end;

procedure TMainForm.FinalizeObject;
begin
  FMenu.Free;
  inherited;
end;

procedure TMainForm.HandleMenuItemClicked(Sender: TObject);
begin
   if TW3ListItem(Sender).TagValue = 5 then
     begin
       Application.Terminate;
       exit;
     end;
   var TargetForm := Application.Forms[TW3ListItem(Sender).TagValue];
   Application.GotoFormByRef(TargetForm, feFromRight);
   case TW3ListItem(Sender).TagValue of
     1: begin
          var View :=  TBallTrajectoryForm(TargetForm).FView;
          View.FTimer := TW3EventRepeater.Create(lambda View.Paint end, 20);
          FMenu.Items.RemoveByRef(FBallTrajectory);
        end;

     2: begin
          var View :=  TMaxCirclesForm(TargetForm).FView;
          View.FTimer := TW3EventRepeater.Create(lambda View.Paint end, 10);
          FMenu.Items.RemoveByRef(FMaxCircles);
        end;

     3: begin
          var View :=  TBlendingEllipsesForm(TargetForm).FView;
          View.FTimer := TW3EventRepeater.Create(lambda View.Paint end, 1);
          FMenu.Items.RemoveByRef(FBlendingEllipses);
        end;

     4: begin
          var View :=  TObjectMovingBallsForm(TargetForm).FView;
          View.FTimer := TW3EventRepeater.Create(lambda View.Paint end, 20);
          FMenu.Items.RemoveByRef(FObjectMovingBalls);
        end;
     end;
end;

procedure TMainForm.Resize;
var
  DeltaY: Integer;
begin
  inherited;
  if Assigned(FMenu) then
    begin
      DeltaY := 108;
      FMenu.SetBounds(10, DeltaY, Width - 20, Height - 20);
    end;
end;

procedure TBaseForm.InitializeObject;
begin
  inherited;
  Header.BackButton.OnClick := lambda
                                 FView.Free;
                                 Application.GotoFormByRef(Application.Forms[0], feToLeft);
                               end;
end;

procedure THeaderForm.InitializeObject;
begin
  inherited;
  FHeader := TW3HeaderControl.Create(Self);
  FHeader.Height := 44;
  FHeader.BackButton.Visible := True;
  FHeader.Title.AlignText := taLeft;
end;

procedure THeaderForm.FinalizeObject;
begin
  FHeader.Free;
  inherited;
end;

procedure THeaderForm.Resize;
begin
  inherited Resize;
  FHeader.SetBounds(0, 0, ClientWidth, 44);
end;

end.
    

Code of Compendium.spr

uses
  SmartCL.System, SmartCL.Application, Unit1;

{$IFDEF SMART_INTERNAL_HANDLE_EXCEPTIONS}
try
{$ENDIF}

  var Application := TW3CustomApplication.Create;
  Application.CreateForm(TMainForm, True);
  Application.CreateForm(TBallTrajectoryForm);
  Application.CreateForm(TMaxCirclesForm);
  Application.CreateForm(TBlendingEllipsesForm);
  Application.CreateForm(TObjectMovingBallsForm);
  Application.RunApp;

{$IFDEF SMART_INTERNAL_HANDLE_EXCEPTIONS}
except
  on e: Exception do
    ShowMessage(e.Message);
end;
{$ENDIF}