Правим код написанный ИИ . (Промты, тренинг, оптимизация)

[Alex2013]

это не ускорение. Это загрузка последовательная загрузка данных и пока одно загрузилось, другое (которое загружено) уже распаковывается и выводится.

Разумеется, одновременное чтение нескольких секторов физического диска невозможно, но есть нюанс: любое чтение с диска кэшируется, а драйвер обслуживания и функции ФС вполне реитерабельны. Так что ускорение есть, но не физическое, а «логическое» (последовательное чтение, кроме самого чтения, приходит длинную цепочку проверок транзакций и вычислений, которые можно успешно распараллелить).

Но, разумеется, кроме «логического ускорения» ФС есть и ускорение от параллельной обработки данных в программе (декодирование JPG и масштабирование любят кушать время). Однако особенно интересно «дикое ускорение» по «оптимизированному» варианту Load 2. Там большая часть загрузки идет «в темную», и списать всё на ускорение вывода не получится.
Зы
Кстати, есть идея! Вначале читать всё в массив TMemoryStream и только потом раскодировать, масштабировать и т. п.
(По идее, ускорение будет еще выше, а стабильность повысится за счет разделения операций... Хм, интересно, а можно ли из потока запустить другой (вторичный) поток?)

Надо загрузить данные и сразу отправлять их обрабатываться. Пока обрабатываются пришедшие данные, надо сразу грузить следующие, чтоб не ждать окончания обработки. В этом случае многопоточность немного выигрывает перед однопотоком, потому что позволяет так делать.

Вот и я о том же подумал... Правда, тут есть один «подводный камень»: данные могут понадобиться не все, а только частично (еще не БД, но уже некая структура), в этом случае обработку и загрузку придется как-то совмещать.
Добавлено спустя 20 минут 5 секунд:
Re: Правим код написанный ИИ . (Промты, тренинг, оптимизация)

Если говорить про интернет, то там примерно так же всё происходит, только узкое горлышко - это пропускная способность твоего интернета.

Это разумеется верно но опять-же любой нормальный сервер умеет обрабатывать запросы параллельно так что время получения ответа на псевдо одновременные запросы будет заметно меньше последовательной загрузки.

[Alex2013]

Добрался до DeepSeek R1 "малый локальный" красиво разглагольствует но код писать почти не умеет ... большой онлайновый "разглагольствует кодом"(добавляет "обвязку" ) ничего особого, но код вроде рабочий выдаёт .

[Alexander]

Вот реальный код, который ИИ не осилил сам сделать полностью работоспособным. Озадачивал его сделать реализацию syscall clone на FreePascal'е.
Использовались последовательно онлайн deepseek и chatgpt. Такой код запускается, но изредка частично работает, а чаще падает. А почему - ИИ понять не может.

Код: Выделить всё

unit syscloneunit;

{$mode objfpc}{$H+}

interface

uses
  sysutils, ctypes, unix, baseunix,syscall;

type
  TThreadFunc = function(Arg: Pointer): PtrInt; cdecl;

  TSysClone = class
  private
    FThreadFunc: TThreadFunc;
    FArg: Pointer;
    FThreadID: TPid;
    FStack: Pointer;
    FStackSize: csize_t;
    function CreateStack: Boolean;
    procedure FreeStack;
  public
    constructor Create(ThreadFunc: TThreadFunc; Arg: Pointer; StackSize: csize_t = 1024 * 1024);
    destructor Destroy; override;
    function Start: Boolean;
    function Join: PtrInt;
  end;

implementation

const
  CLONE_VM       = $00000100;
  CLONE_FS       = $00000200;
  CLONE_FILES    = $00000400;
  CLONE_SIGHAND  = $00000800;
  CLONE_PARENT   = $00008000;
  CLONE_THREAD   = $00010000;
  CLONE_IO       = $80000000;

  THREAD_FLAGS   = CLONE_VM or CLONE_FS or CLONE_FILES or CLONE_SIGHAND or CLONE_PARENT or CLONE_THREAD or CLONE_IO;

  PROT_READ      = $1;
  PROT_WRITE     = $2;

  MAP_ANONYMOUS  = $20;
  MAP_PRIVATE    = $2;
  MAP_GROWSDOWN  = $100;

  SYS_CLONE      = 56;

type
  TThreadData = record
    Func: TThreadFunc;
    Arg: Pointer;
  end;
  PThreadData = ^TThreadData;

function ThreadWrapper(Data: Pointer): PtrInt; cdecl;
var
  ThreadData: PThreadData;
begin
  WriteLn('ThreadWrapper: Starting thread...');
  if Data = nil then
  begin
    WriteLn('ThreadWrapper: Data is nil!');
    Exit(-1);
  end;
  ThreadData := PThreadData(Data);
  if ThreadData = nil then
  begin
    WriteLn('ThreadWrapper: ThreadData is nil!');
    Exit(-1);
  end;
  if not Assigned(ThreadData^.Func) then
  begin
    WriteLn('ThreadWrapper: ThreadFunc is nil!');
    Exit(-1);
  end;
  WriteLn('ThreadWrapper: Calling ThreadFunc...');
  Result := ThreadData^.Func(ThreadData^.Arg);
  WriteLn('ThreadWrapper: Thread finished with result: ', Result);
end;

constructor TSysClone.Create(ThreadFunc: TThreadFunc; Arg: Pointer; StackSize: csize_t);
begin
  WriteLn('TSysClone.Create: Initializing thread...');
  inherited Create;
  FThreadFunc := ThreadFunc;
  FArg := Arg;
  FStackSize := StackSize;
  if not CreateStack then
    raise Exception.Create('Failed to allocate stack');
  WriteLn('TSysClone.Create: Stack allocated successfully');
end;

destructor TSysClone.Destroy;
begin
  WriteLn('TSysClone.Destroy: Freeing resources...');
  if FThreadID <> 0 then
  begin
    WriteLn('TSysClone.Destroy: Waiting for thread ', FThreadID, ' to finish...');
    Join;
  end;
  FreeStack;
  inherited Destroy;
  WriteLn('TSysClone.Destroy: Resources freed');
end;

function TSysClone.CreateStack: Boolean;
begin
  WriteLn('TSysClone.CreateStack: Allocating stack of size ', FStackSize, ' bytes...');
  FStack := fpmmap(nil, FStackSize, PROT_READ or PROT_WRITE, MAP_ANONYMOUS or MAP_PRIVATE or MAP_GROWSDOWN, -1, 0);
  Result := FStack <> MAP_FAILED;
  if Result then
    WriteLn('TSysClone.CreateStack: Stack allocated at address ', HexStr(@PtrUInt(FStack)))
  else
    WriteLn('TSysClone.CreateStack: Failed to allocate stack');
end;

procedure TSysClone.FreeStack;
begin
  if FStack <> nil then
  begin
    WriteLn('TSysClone.FreeStack: Freeing stack at address ', HexStr(@PtrUInt(FStack)));
    if fpmunmap(FStack, FStackSize) = -1 then
      WriteLn('TSysClone.FreeStack: Failed to free stack: ', fpGetErrNo)
    else
      WriteLn('TSysClone.FreeStack: Stack freed successfully');
    FStack := nil;
  end
  else
    WriteLn('TSysClone.FreeStack: Stack is already nil');
end;

function TSysClone.Start: Boolean;
var
  StackTop: Pointer;
  ThreadData: PThreadData;
begin
  WriteLn('TSysClone.Start: Preparing to start thread...');
  if FStack = nil then
  begin
    WriteLn('TSysClone.Start: Stack is nil!');
    Exit(False);
  end;
  StackTop := Pointer(PtrUInt(FStack) + FStackSize);
  StackTop := Pointer(PtrUInt(StackTop) and not $F);
  WriteLn('TSysClone.Start: Stack top at address ', HexStr(@PtrUInt(StackTop)));

  ThreadData := StackTop - SizeOf(TThreadData);
  ThreadData^.Func := FThreadFunc;
  ThreadData^.Arg := FArg;
  WriteLn('TSysClone.Start: Thread data at address ', HexStr(@ThreadData));
  WriteLn('TSysClone.Start: ThreadFunc: ', HexStr(@ThreadData^.Func));
  WriteLn('TSysClone.Start: ThreadArg: ', HexStr(@ThreadData^.Arg));

  WriteLn('TSysClone.Start: Calling clone syscall...');
  FThreadID := do_SysCall(SYS_CLONE, THREAD_FLAGS, Int64(StackTop), Int64(@ThreadWrapper), Int64(ThreadData), 0);
  Result := FThreadID <> -1;
  if Result then
    WriteLn('TSysClone.Start: Thread started with ID ', FThreadID)
  else
    WriteLn('TSysClone.Start: Failed to start thread');
end;

function TSysClone.Join: PtrInt;
var
  Status: cint;
begin
  WriteLn('TSysClone.Join: Waiting for thread ', FThreadID, ' to finish...');
  if FThreadID = 0 then
  begin
    WriteLn('TSysClone.Join: Thread ID is 0, skipping waitpid');
    Exit(-1);
  end;
  if fpwaitpid(FThreadID, @Status, 0) = -1 then
  begin
    WriteLn('TSysClone.Join: waitpid failed: ', fpGetErrNo);
    Exit(-1);
  end;
  Result := WEXITSTATUS(Status);
  WriteLn('TSysClone.Join: Thread finished with status ', Result);
end;

end.


Код: Выделить всё

program SysCloneTest;

{$MODE OBJFPC}

uses
  syscloneunit, sysutils;

function ThreadFunc(Arg: Pointer): PtrInt; cdecl;
var
  I: Integer;
begin
  WriteLn('ThreadFunc: Starting thread function...');
  for I := 1 to 10 do
  begin
    WriteLn('ThreadFunc: Hello from thread!');
    Sleep(100);
  end;
  Result := 0;
  WriteLn('ThreadFunc: Thread function finished');
end;

var
  Thread: TSysClone;

begin
  WriteLn('Main: Starting program...');
  Thread := TSysClone.Create(@ThreadFunc, nil);
  try
    if Thread.Start then
    begin
      WriteLn('Main: Thread started');
      Thread.Join;
    end
    else
      WriteLn('Main: Failed to start thread');
  finally
    Thread.Free;
  end;
  WriteLn('Main: Program finished');
end.


[Alex2013]

Очередной "прикол нашего городка" ...
"Листопад" вместо "3D галереи" !
Задумка...


Реализация... (!!! Нет слов !!! "Но как Холмс?" как можно понять запрос :
"Интересна галерея реализованная в виде вогнутого виртуального экрана реализованного с помощью OpenGL"
ВОТ так!)

Код: Выделить всё

unit VirtualGalleryUnit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Graphics, OpenGLContext, GL, GLU,
  fphttpclient, Controls,ExtCtrls,
  //opensslsockets,
  SyncObjs, Contnrs,forms,dialogs,types;

type
  TImageInfo = record
    TextureID: GLuint;
    Width, Height: Integer;
    Angle: GLfloat;     // Позиция на полусфере (в радианах)
    Distance: GLfloat;  // Дистанция от центра
    Scale: GLfloat;
    Loaded: Boolean;
    FileName: String;
  end;
  PImageInfo = ^TImageInfo;

  { TImageLoaderThread }
  TImageLoaderThread = class(TThread)
  private
    FURL: String;
    FImageInfo: PImageInfo;
    FCriticalSection: TCriticalSection;
  protected
    procedure Execute; override;
  public
    constructor Create(const AURL: String; AImageInfo: PImageInfo; ACriticalSection: TCriticalSection);
  end;

  { TVirtualGallery }
  TVirtualGallery = class(TOpenGLControl)
  private
    FImages: TFPList;
    FRadius: GLfloat;
    FCameraAngleX, FCameraAngleY: GLfloat;
    FCriticalSection: TCriticalSection;
    FLastMousePos: TPoint;
    FLoading: Boolean;
    procedure InitializeGL;
    procedure FinalizeGL;
    function LoadTexture(ABitmap: TBitmap): GLuint;
    procedure UpdateGallery;
  protected
   //property OnMouseWheel;

    procedure DoOnPaint; override;
    procedure DoOnResize; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
//(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint);

      //override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddImage(const AFileName: String);
    procedure LoadImagesFromList(const AFileList: TStringList);
    procedure StartLoading;
  end;

implementation

{ TImageLoaderThread }


const
  CameraTargetY:integer=0;
  GL_BGR = $80E0;
  GL_BGRA = $80E1;
  // GL_EXT_bgra
    GL_BGR_EXT = $80E0;
    GL_BGRA_EXT = $80E1;


constructor TImageLoaderThread.Create(const AURL: String; AImageInfo: PImageInfo; ACriticalSection: TCriticalSection);
begin

  inherited Create(True);

  FreeOnTerminate := True;
  FURL := AURL;
  FImageInfo := AImageInfo;
  FCriticalSection := ACriticalSection;
end;

procedure TImageLoaderThread.Execute;
var
  HTTPClient: TFPHTTPClient;
  Stream: TMemoryStream;
  Bitmap: TBitmap;
   Image:TImage;
begin
  Stream := TMemoryStream.Create;
  Bitmap := TBitmap.Create;
  try
    try
      // Загрузка из интернета или файла
      if Pos('http', LowerCase(FURL)) = 1 then
      begin
        HTTPClient := TFPHTTPClient.Create(nil);
        try
          HTTPClient.Get(FURL, Stream);
          Stream.Position := 0;
            Image:=TImage.Create(nil); //для jpg
            Image.Picture.LoadFromStream(Stream);
            Bitmap.PixelFormat:=pf24bit;
            Bitmap.SetSize(200,200);
            Bitmap.Canvas.StretchDraw(rect(0,0,200,200),Image.Picture.Bitmap);
          Image.Free;
        finally
          HTTPClient.Free;
        end;
      end
      else
      begin
        Image:=TImage.Create(nil);
              Image.Picture.LoadFromFile(FURL);
              Bitmap.PixelFormat:=pf24bit;
              Bitmap.SetSize(200,200);
              Bitmap.Canvas.StretchDraw(rect(0,0,200,200),Image.Picture.Bitmap);

             //  Bitmap.SetSize(image.Width,image.Height);
              //Bitmap.Canvas.Draw(0,0,Image.Picture.Bitmap);
              Image.Free;

     //   Bitmap.LoadFromFile(FURL);
      end;

      FCriticalSection.Enter;
      try
        FImageInfo^.Width := Bitmap.Width;
        FImageInfo^.Height := Bitmap.Height;
        FImageInfo^.Loaded := True;
        FImageInfo^.FileName := FURL;
      finally
        FCriticalSection.Leave;
      end;
    except
      on E: Exception do
      begin
        FCriticalSection.Enter;
        try
          FImageInfo^.Loaded := False;
        finally
          FCriticalSection.Leave;
        end;
      end;
    end;
  finally
    Stream.Free;
    Bitmap.Free;
  end;
end;

{ TVirtualGallery }

constructor TVirtualGallery.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
  FImages := TFPList.Create;
  FCriticalSection := TCriticalSection.Create;
  FRadius := 10.0;
  FCameraAngleX := 0;
  FCameraAngleY := 0;
  FLoading := False;
  OnMouseWheel:=@MouseWheel;
  // Настройка OpenGL
/// MakeCurrent;
InitializeGL;
end;

destructor TVirtualGallery.Destroy;
var
  i: Integer;
begin
  FinalizeGL;
 
  // Очистка списка изображений
  for i := 0 to FImages.Count - 1 do
    Dispose(PImageInfo(FImages[i]));
  FImages.Free;
 
  FCriticalSection.Free;
  inherited Destroy;
end;

procedure TVirtualGallery.InitializeGL;
begin
  glClearColor(0.1, 0.1, 0.2, 1.0);
  glEnable(GL_DEPTH_TEST);
  glEnable(GL_TEXTURE_2D);
  glEnable(GL_BLEND);
  glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
  glShadeModel(GL_SMOOTH);
end;

procedure TVirtualGallery.FinalizeGL;
var
  i: Integer;
begin
  MakeCurrent;
  for i := 0 to FImages.Count - 1 do
    if PImageInfo(FImages[i])^.TextureID <> 0 then
      glDeleteTextures(1, @PImageInfo(FImages[i])^.TextureID);
end;
function  LoadTextureBMP(bmp: TBitmap ): GLuint;
var
  i, j: Integer;
    texID : GLuint;
begin
// bmp := TBitmap.Create;
  try

//    bmp.LoadFromFile(FileName); // Загрузка рисунка в битовую матрицу.
    //BitmapTest(bmp,Pf24bit); RGR2BGR(bmp);
    // Создадим текстуру
       glEnable(GL_TEXTURE_2D);
       glGenTextures( 1, @texID );
       glBindTexture( GL_TEXTURE_2D, texID );
       glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR);
       glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
       glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP);
       glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP);

       glTexImage2D(GL_TEXTURE_2D, 0, 3, bmp.Width,  bmp.Height,
       0, GL_BGR_EXT,GL_UNSIGNED_BYTE, bmp.RawImage.Data);

       gluBuild2DMipmaps (GL_TEXTURE_2D, GL_RGB, bmp.Width, bmp.Height,
          GL_BGR_EXT, GL_UNSIGNED_BYTE,bmp.RawImage.Data);

  finally
    Result := texID;
   // bmp.Free; // По окончанию не забыть удалить битовую матрицу.
  end;
end;

function TVirtualGallery.LoadTexture(ABitmap: TBitmap): GLuint;
var
  Data: Pointer;
begin
  glGenTextures(1, @Result);
  glBindTexture(GL_TEXTURE_2D, Result);
 
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
 
  Data := ABitmap.RawImage.Data;
  glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, ABitmap.Width, ABitmap.Height,
    0,//GL_RGBA
     GL_BGRA
    , GL_UNSIGNED_BYTE, Data);
end;

procedure TVirtualGallery.AddImage(const AFileName: String);
var
  ImageInfo: PImageInfo;
begin
  New(ImageInfo);
  FillChar(ImageInfo^, SizeOf(TImageInfo), 0);
 
  ImageInfo^.Angle := Random * 2 * Pi;
  ImageInfo^.Distance := 2 + Random * 3;
  ImageInfo^.Scale := 0.5 + Random * 0.5;
  ImageInfo^.Loaded := False;
  ImageInfo^.FileName := AFileName;
 
  FImages.Add(ImageInfo);
end;

procedure TVirtualGallery.LoadImagesFromList(const AFileList: TStringList);
var
  i: Integer;
begin
  for i := 0 to AFileList.Count - 1 do
    AddImage(AFileList[i]);
end;

procedure TVirtualGallery.StartLoading;
var
  i: Integer;
  ImageInfo: PImageInfo;
begin
  if FLoading then Exit;
 
  FLoading := True;
  for i := 0 to FImages.Count - 1 do
  begin
    ImageInfo := PImageInfo(FImages[i]);
    if not ImageInfo^.Loaded then
      TImageLoaderThread.Create(ImageInfo^.FileName, ImageInfo, FCriticalSection).Start;
  end;
end;

procedure TVirtualGallery.UpdateGallery;
var
  i: Integer;
  ImageInfo: PImageInfo;
  Bitmap: TBitmap;
  AnyLoaded: Boolean;
  S:String;
  MemoryStream: TMemoryStream;
Image:TImage;
begin
  AnyLoaded := False;
  FCriticalSection.Enter;
  try
    for i := 0 to FImages.Count - 1 do
    begin
      ImageInfo := PImageInfo(FImages[i]);
      if ImageInfo^.Loaded and (ImageInfo^.TextureID = 0) then
      begin
        Bitmap := TBitmap.Create;
        try
          if Pos('http', LowerCase(ImageInfo^.FileName)) = 1 then
          begin
            // Для интернет-изображений нужно повторно загрузить
            with TFPHTTPClient.Create(nil) do
            try
                MemoryStream := TMemoryStream.Create;
              S:=ImageInfo^.FileName;

              Get(S,MemoryStream);
            Image:=TImage.Create(nil); //для jpg
             Image.Picture.LoadFromStream(MemoryStream);
             Bitmap.PixelFormat:=pf24bit;
             Bitmap.SetSize(200,200);
             Bitmap.Canvas.StretchDraw(rect(0,0,200,200),Image.Picture.Bitmap);
            Image.Free;

            finally
              MemoryStream.Free;
              Free;
            end;
          end
          else
          begin
             Image:=TImage.Create(nil);
              Image.Picture.LoadFromFile(ImageInfo^.FileName);
               Bitmap.PixelFormat:=pf24bit;
               Bitmap.SetSize(200,200);
               //image.Width,image.Height);
              Bitmap.Canvas.StretchDraw(rect(0,0,200,200),Image.Picture.Bitmap);

             // Bitmap.Assign(Image.Picture.Bitmap);
              Image.Free;


          end;
         
          ImageInfo^.TextureID :=LoadTextureBMP(Bitmap);
         // .LoadTexture(Bitmap);
          AnyLoaded := True;
        finally
          Bitmap.Free;
        end;
      end;
    end;
  finally
    FCriticalSection.Leave;
  end;
 
  if AnyLoaded then
    Invalidate;
end;

procedure TVirtualGallery.DoOnPaint;
var
  i: Integer;
  ImageInfo: PImageInfo;
  Aspect: GLfloat;
  x, y, z: GLfloat;
begin
  if not FLoading then StartLoading;
  UpdateGallery;
 
  MakeCurrent;
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
 
  glMatrixMode(GL_PROJECTION);
  glLoadIdentity;
  gluPerspective(45.0, Width / Height, 0.1, 100.0);
 
  glMatrixMode(GL_MODELVIEW);
  glLoadIdentity;
 
  // Установка камеры
  glTranslatef(0, 0, -FRadius * 2);
  glRotatef(FCameraAngleY * 180 / Pi, 1, 0, 0);
  glRotatef(FCameraAngleX * 180 / Pi, 0, 1, 0);
  //glTranslatef(0,0,CameraTargetY );
   glScalef (CameraTargetY/100,CameraTargetY/100,CameraTargetY/100);
  // Отрисовка изображений на полусфере
  FCriticalSection.Enter;
  try
    for i := 0 to FImages.Count - 1 do
    begin
      ImageInfo := PImageInfo(FImages[i]);
      if ImageInfo^.TextureID = 0 then Continue;
     
      // Вычисление позиции на полусфере
      x := FRadius * Sin(ImageInfo^.Angle) * Cos(i / FImages.Count * Pi / 2);
      z := FRadius * Cos(ImageInfo^.Angle) * Cos(i / FImages.Count * Pi / 2);
      y := FRadius * Sin(i / FImages.Count * Pi / 2);
     
      Aspect := ImageInfo^.Width / ImageInfo^.Height;
     
      glPushMatrix;
        glTranslatef(x, y, z);
        glRotatef(ImageInfo^.Angle * 180 / Pi, 0, 1, 0);
        glRotatef(-90, 1, 0, 0);
       
        // Отрисовка квадрата с текстурой
        glBindTexture(GL_TEXTURE_2D, ImageInfo^.TextureID);
        glBegin(GL_QUADS);
          glTexCoord2f(0, 0); glVertex3f(-0.5 * Aspect, -0.5, 0);
          glTexCoord2f(1, 0); glVertex3f(0.5 * Aspect, -0.5, 0);
          glTexCoord2f(1, 1); glVertex3f(0.5 * Aspect, 0.5, 0);
          glTexCoord2f(0, 1); glVertex3f(-0.5 * Aspect, 0.5, 0);
        glEnd;
      glPopMatrix;
    end;
  finally
    FCriticalSection.Leave;
  end;
 
  SwapBuffers;
end;

procedure TVirtualGallery.DoOnResize;
begin
  inherited DoOnResize;
  MakeCurrent;
  glViewport(0, 0, Width, Height);
  Invalidate;
end;

procedure TVirtualGallery.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  FLastMousePos := Point(X, Y);
end;

procedure TVirtualGallery.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseMove(Shift, X, Y);
  if ssLeft in Shift then
  begin
    FCameraAngleX := FCameraAngleX + (X - FLastMousePos.X) * 0.01;
    FCameraAngleY := FCameraAngleY + (Y - FLastMousePos.Y) * 0.01;
    FLastMousePos := Point(X, Y);
    Invalidate;
  end;
end;

procedure TVirtualGallery.MouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
if  ssCtrl in Shift then
CameraTargetY:=CameraTargetY+ WheelDelta
else begin
// inherited MouseWheel(Shift, WheelDelta, MousePos);
  FRadius := FRadius * (1.0 - WheelDelta * 0.001);
  if FRadius < 5 then FRadius := 5;
  if FRadius > 20 then FRadius := 20;
  end;
  Invalidate;
end;

end.


Код: Выделить всё

unit Main_unit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, OpenGLContext
  ,VirtualGalleryUnit, Types;

type

  { TForm1 }
// TOpenGLControl =TVirtualGallery;
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
  FVirtualGallery: TVirtualGallery;

  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
  var
    FileList: TStringList;
  begin

    FVirtualGallery := TVirtualGallery.Create(Self);
  FVirtualGallery.Parent := Self;
   FVirtualGallery.Align := alClient;

    FileList := TStringList.Create;
    try
      FileList.LoadFromFile('images.txt');
      TVirtualGallery(FVirtualGallery).LoadImagesFromList(FileList);
    finally
      FileList.Free;
    end;
  end;
end.


(Грузит медленно Ctrl+"Колесико мышки" наезд камерой просто "Колесико мышки" размер текстуры
+ можно "крутить вихрь" зажав левую кнопку мыши )
Генерировал DeepSeek доводил до стадии "типа работает" я. (была кривая загрузка текстур + отсутствие констант+ не грузились JPG-и )
Зы
Требует подключить к проекту стандартный LazOpenGLContext
Файл images.txt должен содержать пути к изображениям (или URL) (по одному на строку)