Очередной "прикол нашего городка" ...
Задумка...
Реализация... (!!! Нет слов !!! "Но как Холмс?" как можно понять запрос :
"Интересна галерея реализованная в виде вогнутого виртуального экрана реализованного с помощью 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.
(Грузит медленно Ctrl+"Колесико мышки" наезд камерой просто "Колесико мышки" размер текстуры
Генерировал DeepSeek доводил до стадии "типа работает" я. (была кривая загрузка текстур + отсутствие констант+ не грузились JPG-и )
Файл images.txt должен содержать пути к изображениям (или URL) (по одному на строку)
Вначале читать всё в массив TMemoryStream и только потом раскодировать, масштабировать и т. п. 
