Mouse Input

We chose an easy way to get started by saving the code of UfrmMain in the supplied PingPong example then replacing it with the code of our demonstration shown below. We removed from the form all components except the TImage. (Select the compiler menu item Project > Project Options > Parsing to confirm that the syntax mode is Delphi). Type Ctrl+F9 to compile, then execute the resultant .exe file directly.

This example displays a red rectangle on a green background. You can use the mouse to drag, throw and spin the rectangle in zero gravity. Control by the mouse is similar to that of our online Smart Pascal image demonstration. Some of the Pascal code is taken from the test bed.

We used much of this code in our marionette demonstration, in which mouse input to the controller manipulates a rag-doll puppet via a distance joint.

Pascal Code

unit UfrmMain;

interface
{$I ..\..\Physics2D\Physics2D.inc}

uses
  SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls,
  UOpenGLCanvas in '..\..\OpenGL Canvas\UOpenGLCanvas.pas',
  UPhysics2D in '..\..\Physics2D\UPhysics2D.pas',
  UPhysics2DTypes in '..\..\Physics2D\UPhysics2DTypes.pas',
  UPhysics2DHelper in '..\..\Physics2D\UPhysics2DHelper.pas';

type
  TQueryCallback = class(Tb2QueryCallback)
  public
    m_point: TVector2;
    m_fixture: Tb2Fixture;
    procedure Initialize(const point: TVector2); {$IFDEF INLINE_AVAIL}inline;{$ENDIF}
    function ReportFixture(fixture: Tb2Fixture): Boolean; override;
  end;

  TWorldHandler = class(Tb2ContactListener)
  private
    const
      SCALE = 10;
      RESTITUTION = 0.3;
      FRICTION = 0.4;
      BODY_WIDTH = 6;
      BODY_HEIGHT = 3;
    var
      FWorld: Tb2World;
      FBody, FGroundBody: Tb2Body;
      FMouseJoint: Tb2MouseJoint;
      FMousePos: TVector2;
    procedure initializePhysics;
    procedure MouseDown;
    procedure MouseUp;
  end;

  TfrmMain = class(TForm)
    GLCanvas: TGLCanvas;
    imgDisplay: TImage;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure imgDisplayMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure imgDisplayMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure imgDisplayMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    private
    const
      RADTODEG = 180 / 3.142;
      FRAME_RATE = 1 / 60;
    var
      WorldHandler: TWorldHandler;
      FIsMouseDown: Boolean;
    procedure Display;
    procedure TimerProgress(const deltaTime, newTime: Double);
  end;

var
  frmMain: TfrmMain;
   _QueryCallback: TQueryCallback;

implementation

uses
  MSTimer;

{$R *.dfm}

procedure TQueryCallback.Initialize(const point: TVector2);
begin
  m_point := point;
  m_fixture := nil;
end;

function TQueryCallback.ReportFixture(fixture: Tb2Fixture): Boolean;
begin
  if fixture.GetBody.GetType = b2_dynamicBody then
    begin
      if fixture.TestPoint(m_point) then
        begin
          m_fixture := fixture;
          // We are done, terminate the query.
          Result := False;
          Exit;
        end;
   end;
  // Continue the query.
  Result := True;
end;

procedure TWorldHandler.MouseDown;
var
  aabb: Tb2AABB;
  d: TVector2;
  body: Tb2Body;
  md: Tb2MouseJointDef;
begin
  if Assigned(FmouseJoint) then
    Exit;
  // Make a small box.
  {$IFDEF OP_OVERLOAD}
  d.SetValue(0.001, 0.001);
  aabb.lowerBound := FMousePos - d;
  aabb.upperBound := FMousePos + d;
  {$ELSE}
  SetValue(d, 0.001, 0.001);
  aabb.lowerBound := Subtract(FMousePos, d);
  aabb.upperBound := Add(FMousePos, d);
  {$ENDIF}

  // Query the world for overlapping shapes.
  _QueryCallback.Initialize(FMousePos);
  Fworld.QueryAABB(_QueryCallback, aabb);
  if Assigned(_QueryCallback.m_fixture) then
    begin
      body := _QueryCallback.m_fixture.GetBody;
      md := Tb2MouseJointDef.Create;
      md.bodyA := FGroundBody;
      md.bodyB := body;
      md.target := FMousePos;
      md.maxForce := 1000.0 * body.GetMass;
      FmouseJoint := Tb2MouseJoint(Fworld.CreateJoint(md));
      body.SetAwake(True);
    end;
end;

procedure TWorldHandler.MouseUp;
begin
  if Assigned(FmouseJoint) then
    begin
      Fworld.DestroyJoint(FmouseJoint);
      FmouseJoint := nil;
    end;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  _QueryCallback := TQueryCallback.Create;
  WorldHandler := TWorldHandler.Create;
  MSCadencer := TMSTimer.Create;
  MSCadencer.OnProgress := TimerProgress;
  GLCanvas := TGLCanvas.Create(imgDisplay, True, True, False, True);
  WorldHandler.InitializePhysics;
  Display;
  MSCadencer.Enabled := True;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  if Assigned(WorldHandler) then
    WorldHandler.Free;
  MSCadencer.Free;
  GLCanvas.Free;
end;

procedure TfrmMain.imgDisplayMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  ActiveControl := nil;
  WorldHandler.FMousePos.x := X / WorldHandler.SCALE;
  WorldHandler.FMousePos.y := (imgDisplay.Height - Y) / WorldHandler.SCALE;
  WorldHandler.MouseDown;
  FIsMouseDown := True;
end;

procedure TfrmMain.imgDisplayMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  WorldHandler.FMousePos.x := X / WorldHandler.SCALE;
  WorldHandler.FMousePos.y := (imgDisplay.Height - Y) / WorldHandler.SCALE;
  WorldHandler.MouseDown;
end;

procedure TfrmMain.imgDisplayMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  WorldHandler.MouseUp;
  FIsMouseDown := False;
end;

procedure TWorldHandler.InitializePhysics;
var
  FixtureDef: Tb2FixtureDef;
  BodyDef: Tb2BodyDef;
begin
  FWorld := Tb2World.Create(MakeVector(0, 0)); // zero gravity
  // Create fixture definition (used to describe fixture objects)
  FixtureDef := Tb2FixtureDef.Create;
  FixtureDef.Density := 1.0;
  FixtureDef.Friction := FRICTION;
  FixtureDef.Restitution := RESTITUTION;
  FixtureDef.Shape := Tb2PolygonShape.Create;
  // Create body definition class (used to describe body objects)
  BodyDef := Tb2BodyDef.Create;
  FGroundBody := FWorld.CreateBody(BodyDef, False);
  // Create movable body
  BodyDef.BodyType := b2_DynamicBody;
  BodyDef.Position := MakeVector(0.5 * 400 / SCALE, 300 / SCALE - 5);
  Tb2PolygonShape(FixtureDef.Shape).SetAsBox(0.5 * BODY_WIDTH, 0.5 * BODY_HEIGHT);
  FBody := FWorld.CreateBody(BodyDef, False);
  FBody.CreateFixture(FixtureDef, False, False);
end;

procedure TfrmMain.Display;
const
  SCALE = WorldHandler.SCALE;
var
  Pos: TVector2;
  Theta: PhysicsFloat;
  i: integer;

  procedure DrawBody(Body: Tb2Body; Width, Length: PhysicsFloat);
  begin
    Pos := Body.GetPosition;
    Theta := Body.GetAngle;
    GLCanvas.SetTranslateX(GLCanvas.TranslateX + Pos.x * SCALE);
    GLCanvas.SetTranslateY(GLCanvas.TranslateY + Pos.y * SCALE);
    GLCanvas.SetRotation(GLCanvas.Rotation + Theta * RADTODEG);
    GLCanvas.FillRect((-0.5 * Width) * SCALE, - (0.5 * Length) * SCALE,
                      (0.5 * Width) * SCALE, (0.5 * Length) * SCALE);
    GLCanvas.SetRotation(GLCanvas.Rotation - Theta * RADTODEG);
    GLCanvas.SetTranslateY(GLCanvas.TranslateY - Pos.y * SCALE);
    GLCanvas.SetTranslateX(GLCanvas.TranslateX - Pos.x * SCALE);
  end;

begin
  GLCanvas.RenderingBegin(clGreen);
  GLCanvas.SetBrushColorWin(clRed, 255, False);
  DrawBody(WorldHandler.FBody, WorldHandler.BODY_WIDTH, WorldHandler.BODY_HEIGHT);
  GLCanvas.RenderingEnd;
  if Assigned(WorldHandler.FMouseJoint) then
    if FIsMouseDown then
      WorldHandler.FMouseJoint.SetTarget(WorldHandler.FMousePos)
    else
      begin
        WorldHandler.FWorld.DestroyJoint(WorldHandler.FMouseJoint);
        WorldHandler.FMouseJoint := nil;
      end;
end;

procedure TfrmMain.TimerProgress(const deltaTime, newTime: Double);
const
  FixedStep = FRAME_RATE;
var
  dt: Double;
begin
  if deltaTime < 1.2 * FixedStep then
    WorldHandler.FWorld.Step(deltaTime, 6, 2)
  else
    begin
      dt := deltaTime;
      while dt > 0 do
        begin
          WorldHandler.FWorld.Step(FixedStep, 6, 2);
          dt := dt - FixedStep;
        end;
      end;
  Display;
  Application.ProcessMessages;
end;

end.    

Code of Form

object frmMain: TfrmMain
  Left = 430
  Height = 317
  Top = 77
  Width = 418
  BorderIcons = [biSystemMenu, biMinimize]
  BorderStyle = bsSingle
  Caption = 'Mouse Input Demo'
  ClientHeight = 317
  ClientWidth = 418
  Color = clBtnFace
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  KeyPreview = True
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  Position = poDesktopCenter
  LCLVersion = '1.4.4.0'
  object imgDisplay: TImage
    Left = 8
    Height = 300
    Top = 8
    Width = 400
    OnMouseDown = imgDisplayMouseDown
    OnMouseMove = imgDisplayMouseMove
    OnMouseUp = imgDisplayMouseUp
  end
end    
Programming - a skill for life!

How to use the Box2D physics engine in Lazarus