TViewport3D上に球の完全弾性反射を3D表示する(FMX) ～Delphiソースコード集

• ホーム
• Delphiでお手軽プログラミング
• TViewport3D上に球の完全弾性反射を3D表示する(FMX) ～Delphiソースコード集

TViewport3D上に球の完全弾性反射を3D表示する(FMX) ～Delphiソースコード集

Delphiを起動して新規作成を行い、必要なコンポーネントをドラッグ&ドロップする

ソースコードを記述する

unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Types3D,
  System.Math.Vectors, FMX.Controls3D, FMX.MaterialSources, FMX.Viewport3D,
  FMX.Objects3D;

type
  TForm1 = class(TForm)
    Viewport3D1: TViewport3D;
    LightMaterialSource1: TLightMaterialSource;
    Light1: TLight;
    Camera1: TCamera;
    Sphere1: TSphere;
    Timer1: TTimer;
    Plane1: TPlane;
    Disk1: TDisk;
    LightMaterialSource2: TLightMaterialSource;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { private 宣言 }
  public
    { public 宣言 }
    p:TPointF;
    acc:TPointF;
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

procedure TForm1.FormCreate(Sender: TObject);
begin
  p.X:=0;
  p.Y:=-14;

  acc.X:=0.20;
  acc.Y:=0.00;

  Sphere1.Width:=2;
  Sphere1.Height:=2;
  Sphere1.Depth:=2;
  Sphere1.Position.X:=p.X;
  Sphere1.Position.Y:=p.Y;
  Sphere1.Position.Z:=0;

  LightMaterialSource2.Diffuse:=TAlphaColor($FFAAAAAA);
  disk1.Width:=2;
  disk1.Height:=2;
  disk1.Position.X:=p.X;
  disk1.Position.Y:=-0.001;
  disk1.Position.Z:=0;
  disk1.MaterialSource:=LightMaterialSource2;

  Plane1.Position.X:=0;
  Plane1.Position.Y:=0;
  Plane1.Position.Z:=0;
  Plane1.Width:=20;
  Plane1.Height:=20;
  Plane1.RotationAngle.X:=90;

  //ライトの設定
  Light1.Position.X:=10;
  Light1.Position.Y:=-10;
  Light1.Position.Z:=-10;
  Light1.RotationAngle.X:=-45;//下45度
  Light1.RotationAngle.Y:=-30;//左30度
  Light1.RotationAngle.Z:=0;

  //カメラの設定
  Viewport3D1.UsingDesignCamera:=False;
  Viewport3D1.Camera:=Camera1;
  Camera1.Position.X:=0;
  Camera1.Position.Y:=-15;
  Camera1.Position.Z:=-24;
  Camera1.RotationAngle.X:=-20;
  //カメラを球に追従させる場合
  Camera1.Target:=Sphere1;

  Timer1.Interval:=30;
  Timer1.Enabled:=True;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  if ((p.X+acc.X)>8) or ((p.X+acc.X)<-8) then
    acc.X:=-acc.X
  else
    p.X:=p.X+acc.X;
  acc.Y:=acc.Y+0.02;
  if ((p.Y+acc.Y)>(-Sphere1.Height/2)) then
    acc.Y:=-acc.Y
  else
    p.Y:=p.Y+acc.Y;

  Sphere1.Position.X:=p.X;
  Sphere1.Position.Y:=p.Y;
  disk1.Position.X:=p.X;
end;

end.

実行する

実行中画面