Vulkan/projects/triangle/uMainForm.pas

unit uMainForm;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
  Vulkan, uvkuAllocationHandler,
  uvkuInstance, uvkuInstanceFactory,
  uvkuPhysicalDevice, uvkuPhysicalDeviceFactory,
  uvkuSurface, uvkuSurfaceFactory,
  uvkuDevice, uvkuDeviceFactory,
  uvkuSwapChain, uvkuSwapChainFactory;

type
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TCustomAllocHandler = class(TvkuAllocationHandler)
  protected
    function AllocateMemory(const aSize: VkSize; const aAlignment: VkSize; const aScope: TVkSystemAllocationScope): PVkVoid; override;
    function ReallocateMemory(const aOriginal: PVkVoid; const aSize: VkSize; const aAlignment: VkSize; const aScope: TVkSystemAllocationScope): PVkVoid; override;
    procedure FreeMemory(const aMemory: PVkVoid); override;
  end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TMainForm = class(TForm)
    RenderPanel: TPanel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    fAllocHandler: TCustomAllocHandler;
    fInstance: TvkuInstance;
    fPhyDevice: TvkuPhysicalDevice;
    fDevice: TvkuDevice;
    fSurface: TvkuSurface;
    fSwapChain: TvkuSwapChain;
  public
    { public declarations }
  end;

var
  MainForm: TMainForm;

implementation

{$R *.lfm}
{$I Vulkan.inc}

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TCustomAllocHandler////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TCustomAllocHandler.AllocateMemory(const aSize: VkSize; const aAlignment: VkSize; const aScope: TVkSystemAllocationScope): PVkVoid;
begin
  result := inherited AllocateMemory(aSize, aAlignment, aScope);
  WriteLn(Format('%d bytes of memory allocated at %p', [ aSize, result ]));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TCustomAllocHandler.ReallocateMemory(const aOriginal: PVkVoid; const aSize: VkSize; const aAlignment: VkSize; const aScope: TVkSystemAllocationScope): PVkVoid;
var p: PVkVoid;
begin
  p := aOriginal;
  result := inherited ReallocateMemory(aOriginal, aSize, aAlignment, aScope);
  WriteLn(Format('%d bytes of memory (from %p) reallocated at %p', [ aSize, p, result ]));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TCustomAllocHandler.FreeMemory(const aMemory: PVkVoid);
begin
  WriteLn(Format('free memory at %p', [ aMemory ]));
  inherited FreeMemory(aMemory);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TMainForm//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TMainForm.FormCreate(Sender: TObject);
var
  PhyDevices: TvkuPhysicalDeviceArr;
  iFactory: TvkuInstanceFactory;
  pdFactory: TvkuPhysicalDeviceFactory;
  dFactory: TvkuDeviceFactory;
  sFactory: TvkuSurfaceFactory;
  scFactory: TvkuSwapChainFactory;

  qci: TvkuQueueCreateInfo;
  SrfFormats: TvkuSurfaceFormatArr;
  SurfaceCapabilities: TVkSurfaceCapabilitiesKHR;
  PresentModes: TvkuPresentModeArr;
  pm: TVkPresentModeKHR;
begin
  fAllocHandler := TCustomAllocHandler.Create;


  WriteLn('create vulkan instance');
  iFactory := TvkuInstanceFactory.Create;
  try
    iFactory.Extensions.Add(VK_KHR_SURFACE_EXTENSION_NAME);
    iFactory.Extensions.Add(TvkuSurface.GetPlatformSurfaceExtensionName);
    fInstance := iFactory.CreateInstance(fAllocHandler, false);
  finally
    FreeAndNil(iFactory);
  end;


  WriteLn('check physical devices');
  PhyDevices := fInstance.GetPhysicalDevices;
  if (Length(PhyDevices) <= 0) then
    raise Exception.Create('unable to get physical device');
  pdFactory := TvkuPhysicalDeviceFactory.Create(fInstance);
  try
    fPhyDevice := pdFactory.CreatePhysicalDevice(PhyDevices[0]);
  finally
    FreeAndNil(pdFactory);
  end;


  WriteLn('create vulkan surface');
  sFactory := TvkuSurfaceFactory.Create(fInstance);
  try
    sFactory.WinControl := RenderPanel;
    fSurface := sFactory.CreateSurface(fAllocHandler, false);
  finally
    FreeAndNil(sFactory);
  end;


  WriteLn('create vulkan device');
  dFactory := TvkuDeviceFactory.Create(fInstance);
  try
    SetLength(qci.Priorities, 1);
    qci.Priorities[0] := 1.0;
    qci.FamilyIndex   := 0;
    qci.Flags         := 0;

    dFactory.QueueCreateInfoCount := 1;
    dFactory.QueueCreateInfo[0]   := qci;

    fDevice := dFactory.CreateDevice(fPhyDevice.Handle, fAllocHandler, false);
  finally
    FreeAndNil(dFactory);
  end;

  WriteLn('create swap chain');
  scFactory := TvkuSwapChainFactory.Create(fDevice);
  try
    scFactory.Surface           := fSurface.Handle;
    scFactory.ImageUsage        := [ VK_IMAGE_USAGE_COLOR_ATTACHMENT_BIT ];
    scFactory.ImageArrayLayers  := 1;
    scFactory.ImageSharingMode  := VK_SHARING_MODE_EXCLUSIVE;
    scFactory.Clipped           := true;
    scFactory.ComposideAlpha    := [ VK_COMPOSITE_ALPHA_OPAQUE_BIT_KHR ];

    WriteLn('  get surface capabilities');
    SurfaceCapabilities := fPhyDevice.GetSurfaceCapabilities(fSurface.Handle);
    if (SurfaceCapabilities.currentExtent.width = High(VkUint32)) then begin
      SurfaceCapabilities.currentExtent.width  := ClientWidth;
      SurfaceCapabilities.currentExtent.height := ClientHeight;
    end else begin
      ClientWidth  := SurfaceCapabilities.currentExtent.width;
      ClientHeight := SurfaceCapabilities.currentExtent.height;
    end;
    scFactory.ImageExtent := SurfaceCapabilities.currentExtent;

    WriteLn('  set min image count');
    scFactory.MinImageCount := SurfaceCapabilities.minImageCount + 1;
    if (SurfaceCapabilities.maxImageCount > 0) and
       (scFactory.MinImageCount > SurfaceCapabilities.maxImageCount) then
      scFactory.MinImageCount := SurfaceCapabilities.maxImageCount;

    WriteLn('  find suitable image format');
    SrfFormats := fPhyDevice.GetSurfaceFormats(fSurface.Handle);
    if (Length(SrfFormats) = 0) then begin
      WriteLn('no suitable formats found');
      halt;
    end;
    if (Length(SrfFormats) = 1) and (SrfFormats[0].format = VK_FORMAT_UNDEFINED) then begin
      scFactory.ImageFormat     := VK_FORMAT_R8G8B8A8_UNORM;
      scFactory.ImageColorSpace := VK_COLORSPACE_SRGB_NONLINEAR_KHR;
    end else begin
      scFactory.ImageFormat     := SrfFormats[0].format;
      scFactory.ImageColorSpace := SrfFormats[0].colorSpace;
    end;

    WriteLn('  set pre transform');
    scFactory.PreTransform := SurfaceCapabilities.currentTransform;
    if (VK_SURFACE_TRANSFORM_IDENTITY_BIT_KHR in SurfaceCapabilities.supportedTransforms) then
      scFactory.PreTransform := scFactory.PreTransform + [ VK_SURFACE_TRANSFORM_IDENTITY_BIT_KHR ];

    WriteLn('  find suitable present mode');
    PresentModes := fPhyDevice.GetSurfacePresentModes(fSurface.Handle);
    if (Length(PresentModes) = 0) then begin
      WriteLn('unable to get present modes');
      halt;
    end;
    for pm in PresentModes do begin
      if (pm = VK_PRESENT_MODE_MAILBOX_KHR) then begin
        scFactory.PresentMode := pm;
        break;
      end;
    end;

    fSwapChain := scFactory.CreateSwapchain(fAllocHandler, false);
  finally
    FreeAndNil(scFactory);
  end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TMainForm.FormDestroy(Sender: TObject);
begin
  FreeAndNil(fSwapChain);
  FreeAndNil(fDevice);
  FreeAndNil(fSurface);
  FreeAndNil(fPhyDevice);
  FreeAndNil(fInstance);
  FreeAndNil(fAllocHandler);
end;

end.