unit MainFm;
(*
 * Copyright (c) 2015 - 2025 Dr. Yuriy Kotsarenko. All rights reserved.
 *
 * Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
 * compliance with the License. You may obtain a copy of the License at
 *   http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software distributed under the License is
 * distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and limitations under the License.
 *)

// This example illustrates the following features:
//  * Creating 3D meshes by performing an extrusion over a vector path.
//  * Two independent shadow-casting light sources, HDR rendering and bloom.
//  * HDR lighting, ambient occlusion and bloom effect.
//  * Third-person view camera with location-based zoom (zooms in or out where the mouse is pointing at).

interface

uses
  Winapi.Windows, System.Types, System.Classes, Vcl.Graphics, Vcl.Forms, Vcl.Dialogs, Vcl.Controls,
  PXT.Types, PXT.Graphics, PXT.Controls;

type
  TMainForm = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FRenderingControl: TRenderingControl;
    FDisplaySize: TPoint2i;
    FDisplayScale: Single;
    FMousePos: TPoint2i;

    FDevice: TDevice;
    FSwapChain: TSwapChain;
    FCanvas: TCanvas;
    FTextRenderer: TTextRenderer;

    FObjects: TObjectModels;
    FLights: TSceneLights;
    FTextureCabinet: TTextureCabinet;
    FShadowCastingAtlas: TShadowCastingAtlas;
    FShadowCasterViews: array[0..1] of TObjectModelView;

    FModelFloor: TMeshModel;
    FModelCircles: TMeshModel;
    FModelDiamonds: TMeshModel;

    FSceneDepthNormals: TScene;
    FSceneModeling: TScene;

    FCamera: TActorCamera;
    FProjection: TMatrix4f;
    FCircles: Boolean;
    FShadowMapsNeedUpdate: Boolean;

    procedure RenderingControlResize(Sender: TObject);
    procedure RenderingControlMouseDown(Sender: TObject; Button: Vcl.Controls.TMouseButton; 
      Shift: TShiftState; X, Y: Integer);
    procedure RenderingControlMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure RenderingControlMouseUp(Sender: TObject; Button: Vcl.Controls.TMouseButton; Shift: TShiftState;
      X, Y: Integer);
    procedure RenderingControlMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint;
      var Handled: Boolean);
    procedure RenderingControlMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint;
      var Handled: Boolean);
    procedure RenderingControlKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure RenderingControlPaint(Sender: TObject);
    procedure RenderModels(const AScene: TScene);
    procedure CreateRenderingControl;
  public
  end;

var
  MainForm: TMainForm;

implementation
{$R *.dfm}

uses
  System.SysUtils, System.Math, PXT.Headers, PXT.Graphics.Consts;

const
  VertexElements: array[0..1] of TVertexElement = (
    (Name: 'vertexPosition'; Format: TElementFormat.Float; Count: 3; Channel: 0; Offset: 0),
    (Name: 'vertexNormal'; Format: TElementFormat.Float; Count: 3; Channel: 0; Offset: 0));

procedure TMainForm.FormCreate(Sender: TObject);
var
  LDepthClipNegative: Boolean;
  LToneMappingBloom: TToneMappingBloom;
  LBuilder: TPathBuilder;
  LBuffer: TMeshBuffer;
  LLight: PSceneLight;
  I, J: Integer;
begin
  CreateRenderingControl;
  FDisplaySize := Point2i(FRenderingControl.Width, FRenderingControl.Height);
  FDisplayScale := PixelsPerInch / 96.0;
  LDepthClipNegative := FDevice.Behavior and TDeviceBehavior.DepthClipNegative <> 0;
  try
    FDevice := TDevice.Create;
    FSwapChain := TSwapChain.Create(FDevice, FRenderingControl.WindowHandle, FDisplaySize);
    FCanvas := TCanvas.Create(FDevice);
    FTextRenderer := TTextRenderer.Create(FCanvas, Point2i(256, 256), TPixelFormat.LA8);
    FLights := TSceneLights.Create(FDevice);
    FObjects := TObjectModels.Create(TSceneMeshes(NullObject));

    FTextureCabinet := TTextureCabinet.Create(FDevice, FDisplaySize, TTextureFidelity.High, 8);

    // Configure tone-mapping/bloom parameters.
    LToneMappingBloom := FTextureCabinet.ToneMappingBloom;
    LToneMappingBloom.ToneWhite := 2.0;
    FTextureCabinet.ToneMappingBloom := LToneMappingBloom;

    FShadowCastingAtlas := TShadowCastingAtlas.Create(FDevice, Point2i(512 + 2, 256),
      TTechniqueShadows.EVSM, 8);

    FSceneDepthNormals := TScene.CreateDepthNormals(FDevice);
    FSceneDepthNormals.SetVertexElements(0, VertexElements);
    FSceneDepthNormals.SetVertexElementsFromTextModeller(1);

    FSceneModeling := TScene.CreateModeling(FDevice);
    FSceneModeling.SetVertexElements(0, VertexElements);
    FSceneModeling.SetVertexElementsFromTextModeller(1);

    for I := 0 to 1 do
    begin
      LLight := FLights.Add;
      LLight.AmbientColor := TFloatColorRGB.White;
      LLight.AlbedoColor := TFloatColorRGB.White;
      LLight.SpecularColor := TFloatColorRGB.White;
      LLight.SpecularExponent := 4.0;
      LLight.Intensity := 1.0;
      LLight.ShadowCaster := I;
      LLight.Position := Vector3f(300.0, 800.0, -300.0);
      if I = 1 then
        LLight.Position := Vector3f(-300.0, 800.0, 300.0);

      FShadowCasterViews[I] := FObjects.CreateView;
      FShadowCasterViews[I].View := TMatrix4f.LookAt(LLight.Position, TVector3f.Zero, TVector3f.AxisY);
      FShadowCasterViews[I].SetProjection(TMatrix4f.PerspectiveFOVY(Pi * 0.3, 1.0, 200.0, 1400.0,
        LDepthClipNegative), LDepthClipNegative);

      FShadowCastingAtlas.Add(Point2i(256, 256));
    end;

    FCamera := TActorCamera.Create(TVector3f.Zero, Vector3f(Pi * 0.4, 0.0, 0.0), 400.0);
    FCamera.Constraints := TCameraConstraints.Create(
      Vector4f(-100.0, -50.0, -100.0, 200.0),
      Vector4f( 100.0,  50.0,  100.0, 500.0),
      Vector4f(Pi * 0.01, 0.0, 0.0, 0.0),
      Vector4f(Pi * 0.4, 0.0, 0.0, 0.0));

    LBuffer := TMeshBuffer.Create;
    try
      // Create floor model.
      LBuffer.Plane(1, 1, TVector3f.Zero, Vector3f(1200.0, 0.0, 0.0), Vector3f(0.0, 0.0, 1200.0),
        TVector3f.AxisY, TPoint2f.Zero, TPoint2f.Unity, TFloatColor.White);

      FModelFloor := LBuffer.Model(FDevice, VertexElements);

      // Create extruded meshes.
      LBuilder := TPathBuilder.Create;
      try
        // Construct a path with circular holes.
        LBuilder.Rectangle(FloatRect(0.0, 0.0, 600.0, 600.0), True);

        for J := 0 to 10 do
          for I := 0 to 9 do
          begin
            if (J mod 2 = 1) and (I = 9) then
              Break;

            LBuilder.Circle(Point2f(40.0 + I * 58.0 + (J mod 2) * 58.0 * 0.5, 40.0 + J * 58.0 /
              TCanvas.HexagonDelta), 28.0, False);
          end;

        LBuffer.Clear;
        LBuffer.Extrusion(LBuilder.Elements, 20.0, TPoint2f.Unity, TColorRect.White);
        LBuffer.Centralize;

        FModelCircles := LBuffer.Model(FDevice, VertexElements);

        // Construct a path with diamond holes.
        LBuilder.Clear;
        LBuilder.Rectangle(FloatRect(0.0, 0.0, 600.0, 600.0), True);

        for J := 0 to 10 do
          for I := 0 to 9 do
          begin
            if (J mod 2 = 1) and (I = 9) then
              Break;

            LBuilder.Diamond(Point2f(40.0 + I * 58.0 + (J mod 2) * 58.0 * 0.5, 40.0 + J * 58.0 /
              TCanvas.HexagonDelta), 28.0, False);
          end;

        LBuffer.Clear;
        LBuffer.Extrusion(LBuilder.Elements, 20.0, TPoint2f.Unity, TColorRect.White);
        LBuffer.Centralize;

        FModelDiamonds := LBuffer.Model(FDevice, VertexElements);
      finally
        LBuilder.Free;
      end;
    finally
      LBuffer.Free;
    end;
  except
    on E: EAfterwarpException do
    begin
      MessageDlg(E.Message, mtError, [mbOK], 0);
      Application.Terminate;
      Exit;
    end;
  end;
  FCircles := True;
  FShadowMapsNeedUpdate := True;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  FModelDiamonds.Free;
  FModelCircles.Free;
  FModelFloor.Free;
  FCamera.Free;
  FSceneModeling.Free;
  FSceneDepthNormals.Free;
  FShadowCastingAtlas.Free;
  FTextureCabinet.Free;
  FObjects.Free;
  FLights.Free;
  FTextRenderer.Free;
  FCanvas.Free;
  FSwapChain.Free;
  FDevice.Free;
end;

procedure TMainForm.RenderingControlResize(Sender: TObject);
begin
  if FSwapChain.Handle <> nil then
  begin
    FDisplaySize := Point2i(FRenderingControl.Width, FRenderingControl.Height);
    FSwapChain.Resize(FDisplaySize);
    FTextureCabinet.Size := FDisplaySize;
    FRenderingControl.Invalidate;
  end;
end;

procedure TMainForm.RenderingControlPaint(Sender: TObject);
var
  LCabinetAttributes: TTextureCabinetAttributes;
  LDepthClipNegative: Boolean;
  LFontParams: TFontParameters;
  LTechString: string;
  LAttributes: TSceneAttributes;
  LShadowCaster: TShadowCaster;
  I: Integer;
begin
  LDepthClipNegative := FDevice.Behavior and TDeviceBehavior.DepthClipNegative <> 0;
  FDisplayScale := PixelsPerInch / 96.0;

  FProjection := TMatrix4f.PerspectiveFOVY(Pi * 0.25, FDisplaySize.X / FDisplaySize.Y,
    10.0, 1200.0, LDepthClipNegative);

  // Perform light assignment for 3D scene.
  FLights.ViewSize := FDisplaySize;
  FLights.ClustersCullingMode := TClustersCullingMode.Performance;
  FLights.ClusterSize := 256;
  FLights.DepthSlices := 4;
  FLights.Execute(FCamera.View, FProjection);

  // Update texture cabinet's attributes.
  LCabinetAttributes := [TTextureCabinetAttribute.Bloom
    , TTextureCabinetAttribute.BloomCubic
    , TTextureCabinetAttribute.AmbientOcclusion
  ];

  if FDisplayScale >= 2.0 then
  begin // On 4K display, apply downscale for bloom and AO.
    LCabinetAttributes := LCabinetAttributes + [
      TTextureCabinetAttribute.BloomDownscale,
      TTextureCabinetAttribute.AmbientOcclusionDownscale];
  end;

  FTextureCabinet.Attributes := LCabinetAttributes;

  // Render shadow maps.
  if FShadowMapsNeedUpdate then
  begin
    FShadowCastingAtlas.BorderFill;

    for I := 0 to FShadowCastingAtlas.CasterCount - 1 do
    begin
      LShadowCaster := FShadowCastingAtlas.Casters[I];
      LShadowCaster.ViewProjection := FShadowCasterViews[I].ViewProjection;

      FShadowCasterViews[I].Update;
      LShadowCaster.Clear;
      LShadowCaster.BeginScene;
      try
        FSceneDepthNormals.Attributes := [];
        FSceneDepthNormals.View := FShadowCasterViews[I].View;
        FSceneDepthNormals.Projection := FShadowCasterViews[I].Projection;

        FSceneDepthNormals.BeginScene;
        try
          RenderModels(FSceneDepthNormals);
        finally
          FSceneDepthNormals.EndScene;
        end;
      finally
        LShadowCaster.EndScene;
      end;
      LShadowCaster.Filter;
    end;
    FShadowMapsNeedUpdate := False;
  end;

  // Prepare scene's attributes.
  LAttributes := [TSceneAttribute.Normals, TSceneAttribute.ShadowsCubic, TSceneAttribute.DepthPrePass];

  // Render depth pre-pass.
  FTextureCabinet.Clear(TTextureCabinetPass.Depth);
  FTextureCabinet.BeginScene(TTextureCabinetPass.Depth);
  try
    FSceneDepthNormals.Attributes := LAttributes;
    FSceneDepthNormals.View := FCamera.View;
    FSceneDepthNormals.Projection := FProjection;

    FSceneDepthNormals.BeginScene;
    try
      RenderModels(FSceneDepthNormals);
    finally
      FSceneDepthNormals.EndScene;
    end;
  finally
    FTextureCabinet.EndScene;
  end;
  FTextureCabinet.Filter(TTextureCabinetFilterType.Occlusion, FProjection);

  // Render main scene.
  FTextureCabinet.Clear(TTextureCabinetPass.Color, FloatColor(2.0, 2.0, 2.0, 0.0) * 0.75);
  FTextureCabinet.BeginScene(TTextureCabinetPass.Color);
  try
    FSceneModeling.Lights := FLights;
    FSceneModeling.ShadowCastingAtlas := FShadowCastingAtlas;
    FSceneModeling.TextureCabinet := FTextureCabinet;

    FSceneModeling.View := FCamera.View;
    FSceneModeling.Projection := FProjection;
    FSceneModeling.Attributes := LAttributes;

    FSceneModeling.Prepare;
    FSceneModeling.BeginScene;
    try
      RenderModels(FSceneModeling);
    finally
      FSceneModeling.EndScene;
    end;
  finally
    FTextureCabinet.EndScene;
  end;
  FTextureCabinet.Filter(TTextureCabinetFilterType.Bloom);

  // Render on the form.
  FSwapChain.BeginScene;
  try
    FDevice.Clear([TClearLayer.Color], FloatColor($FF404040));
    FTextureCabinet.Present;

    FCanvas.BeginScene;
    try
      FCanvas.Attributes := [];
      FCanvas.ContextState := TCanvasContextState.FlatText;
      FCanvas.SamplerState := TCanvasSamplerState.Default;

      LFontParams := TFontParameters.Create('Segoe UI', 16.0 * FDisplayScale, TFontWeight.SemiBold);
      LFontParams.Effect.BorderType := TFontBorder.SemiHeavy;
      LFontParams.Effect.BorderBrightness := 1.0;
      LFontParams.Effect.BorderOpacity := 0.75;
      LFontParams.Effect.FillBrightness := 0.0;
      LFontParams.Effect.ShadowBrightness := 0.85;
      LFontParams.Effect.ShadowOpacity := 0.4;
      FTextRenderer.FontParameters := LFontParams;

      FTextRenderer.DrawAligned(Point2f(
        FDisplaySize.X - 8.0 * FDisplayScale, FDisplaySize.Y - 4.0 * FDisplayScale),
        'Press Space to switch between circular and diamond holes.', ColorPair($FF4040FF, $FF40FFFF),
        TTextAlignment.Ending, TTextAlignment.Ending);

      LFontParams := TFontParameters.Create('Segoe UI', 16.0 * FDisplayScale, TFontWeight.SemiBold);
      LFontParams.Effect.BorderType := TFontBorder.SemiHeavy;
      LFontParams.Effect.BorderBrightness := 1.0;
      LFontParams.Effect.FillBrightness := 0.0;
      LFontParams.Effect.ShadowBrightness := 0.75;
      LFontParams.Effect.ShadowOpacity := 1.0;
      FTextRenderer.FontParameters := LFontParams;

      if FDevice.Technology = TDeviceTechnology.Direct3D then
        LTechString := 'Direct3D (' + IntToStr(FDevice.TechVersion shr 8) + '.' +
          IntToStr((FDevice.TechVersion shr 4) and $0F) + '), features: '
      else
        LTechString := 'OpenGL (' + IntToStr(FDevice.TechVersion shr 8) + '.' +
          IntToStr((FDevice.TechVersion shr 4) and $0F) + '+), features: ';

      LTechString := LTechString + IntToStr(FDevice.TechFeatureVersion shr 8) + '.' +
        IntToStr((FDevice.TechFeatureVersion shr 4) and $0F);

      FTextRenderer.Draw(Point2f(8.0 * FDisplayScale, 4.0 * FDisplayScale), Utf8String(LTechString),
        ColorPair($80FFFFFF));
    finally
      FCanvas.EndScene;
    end;
  finally
    FSwapChain.EndScene;
  end;
end;

procedure TMainForm.RenderingControlMouseDown(Sender: TObject; Button: Vcl.Controls.TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FMousePos := Point2i(X, Y);

  if Button = mbLeft then
    FCamera.Command(TCameraCommand.Rotation, Vector3f(FMousePos.X, FMousePos.Y, 0.0), FDisplaySize)
  else
    FCamera.Command(TCameraCommand.Dragging, Vector3f(FMousePos.X, FMousePos.Y, 0.0), FDisplaySize);
end;

procedure TMainForm.RenderingControlMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  FMousePos := Point2i(X, Y);

  if FCamera.Command(TCameraCommand.Update, Vector3f(FMousePos.X, FMousePos.Y, 0.0), FDisplaySize) then
    FRenderingControl.Invalidate;
end;

procedure TMainForm.RenderingControlMouseUp(Sender: TObject; Button: Vcl.Controls.TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FCamera.Command(TCameraCommand.Stop, Vector3f(FMousePos.X, FMousePos.Y, 0.0), FDisplaySize);
end;

procedure TMainForm.RenderingControlMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint;
  var Handled: Boolean);
begin
  FCamera.Zoom(FMousePos, FDisplaySize, FProjection, -16.0);
  FRenderingControl.Invalidate;
end;

procedure TMainForm.RenderingControlMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint;
  var Handled: Boolean);
begin
  FCamera.Zoom(FMousePos, FDisplaySize, FProjection, 16.0);
  FRenderingControl.Invalidate;
end;

procedure TMainForm.RenderingControlKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key = VK_SPACE then
  begin
    FCircles := not FCircles;
    FShadowMapsNeedUpdate := True;
    FRenderingControl.Invalidate;
  end
  else if Key = VK_ESCAPE then
    Close;
end;

procedure TMainForm.RenderModels(const AScene: TScene);
var
  LMaterial: TObjectMaterial;
begin
  if AScene.Handle = FSceneModeling.Handle then
  begin
    LMaterial := TObjectMaterial.Default;
    LMaterial.AmbientColor := FloatColorRGB(0.75, 0.75, 0.75);
    LMaterial.AlbedoColor := TFloatColor.TranslucentBlack;
    LMaterial.SpecularColor := TFloatColorRGB.Black;
    LMaterial.Shadows := 1.0;
    LMaterial.Occlusion := 1.0;
    AScene.Material := LMaterial;
  end;
  AScene.World := TMatrix4f.Identity;
  FModelFloor.Draw(AScene.SceneProgram);

  if AScene.Handle = FSceneModeling.Handle then
  begin
    LMaterial := TObjectMaterial.Default;
    LMaterial.AmbientColor := FloatColorRGB(0.25, 0.25, 0.25);
    LMaterial.AlbedoColor := FloatColor(0.75, 0.75, 0.75, 0.5);
    LMaterial.SpecularColor := FloatColorRGB(1.0, 1.0, 1.0);
    LMaterial.SpecularExponent := 4.0;
    LMaterial.Shadows := 1.0;
    LMaterial.Occlusion := 1.0;
    LMaterial.Technique := TTechniqueLighting.CookTorrance;
    LMaterial.Roughness := Vector3f(1.8, 1.2, 0.7);
    AScene.Material := LMaterial;
  end;
  AScene.World := TMatrix4f.Translate(0.0, 10.0, 0.0);

  if FCircles then
    FModelCircles.Draw(AScene.SceneProgram)
  else
    FModelDiamonds.Draw(AScene.SceneProgram);
end;

procedure TMainForm.CreateRenderingControl;
begin
  FRenderingControl := TRenderingControl.Create(nil);
  FRenderingControl.Parent := Self;
  FRenderingControl.Align := alClient;
  FRenderingControl.Width := 256;
  FRenderingControl.Height := 256;
  FRenderingControl.OnPaint := RenderingControlPaint;
  FRenderingControl.OnResize := RenderingControlResize;
  FRenderingControl.OnMouseDown := RenderingControlMouseDown;
  FRenderingControl.OnMouseMove := RenderingControlMouseMove;
  FRenderingControl.OnMouseUp := RenderingControlMouseUp;
  FRenderingControl.OnMouseWheelUp := RenderingControlMouseWheelUp;
  FRenderingControl.OnMouseWheelDown := RenderingControlMouseWheelDown;
  FRenderingControl.OnKeyDown := RenderingControlKeyDown;
end;

end.