dima/kam-mobile
1
0 Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Complete BigTask
Sync changed files to Google Drive / sync (push) Successful in 1m28s
Details

Browse Source
This commit is contained in:
admin_d committed 2026-10-19 11:20:23 +05:00
1 parent 776fc59c9e
commit eb5b82783b
9 files changed
+2094 -266
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

port-source/kam_remake/src/utils/KromOGLUtils.pas
+13 -255
View File
@@ -1,274 +1,32 @@
unit KromOGLUtils;
{$I KaM_Remake.inc}
interface
uses
dglOpenGL,
{$IFDEF FPC} GL, LCLIntf, {$ENDIF}
{$IFDEF MSWindows} Windows {$ENDIF}
{$IFDEF Unix} LCLType, glx, x, xlib, xutil {$ENDIF}
;
{$IFDEF Unix}
type HGLRC = Integer;
type PFD_DRAW_TO_WINDOW = Integer;
type PFD_SUPPORT_OPENGL = Integer;
type PFD_DOUBLEBUFFER = Integer;
type PFD_TYPE_RGBA = Integer;
type PFD_MAIN_PLANE = Integer;
{$ENDIF}
type
TColor4 = Cardinal;
TTexture = record Tex: Cardinal; U, V: Single; end;
TKromPoint2 = record
X, Y: Single;
end;
TKromQuadCoords = array[0..3] of TKromPoint2;
procedure SetRenderFrame(RenderFrame: HWND; out h_DC: HDC; out h_RC: HGLRC);
procedure SetRenderFrameAA(DummyFrame, RenderFrame: HWND; AntiAliasing: Byte; out h_DC: HDC; out h_RC: HGLRC);
procedure BuildFont(h_DC: HDC; FontSize: Integer; FontWeight: Word = FW_NORMAL);
procedure glPrint(const text: AnsiString);
procedure glkScale(x: Single);
procedure glkQuad(Ax, Ay, Bx, By, Cx, Cy, Dx, Dy: Single);
procedure glkRect(Ax, Ay, Bx, By: Single);
function KromQuadCoords(Ax, Ay, Bx, By, Cx, Cy, Dx, Dy: Single): TKromQuadCoords;
function KromRectCoords(Ax, Ay, Bx, By: Single): TKromQuadCoords;
implementation
function SetDCPixelFormat(h_DC: HDC; PixelFormat: Integer): Boolean;
var
nPixelFormat: Integer;
PixelDepth: Integer;
{$IFDEF MSWINDOWS}
pfd: TPixelFormatDescriptor;
{$ENDIF}
function KromQuadCoords(Ax, Ay, Bx, By, Cx, Cy, Dx, Dy: Single): TKromQuadCoords;
begin
PixelDepth := 32; //32bpp is common
{$IFDEF MSWINDOWS}
with pfd do begin
nSize := SizeOf(TPIXELFORMATDESCRIPTOR); // Size Of This Pixel Format Descriptor
nVersion := 1; // The version of this data structure
dwFlags := PFD_DRAW_TO_WINDOW // Buffer supports drawing to window
or PFD_SUPPORT_OPENGL // Buffer supports OpenGL drawing
or PFD_DOUBLEBUFFER; // Supports double buffering
iPixelType := PFD_TYPE_RGBA; // RGBA color format
cColorBits := PixelDepth; // OpenGL color depth
cRedBits := 0; // Number of red bitplanes
cRedShift := 0; // Shift count for red bitplanes
cGreenBits := 0; // Number of green bitplanes
cGreenShift := 0; // Shift count for green bitplanes
cBlueBits := 0; // Number of blue bitplanes
cBlueShift := 0; // Shift count for blue bitplanes
cAlphaBits := 0; // Not supported
cAlphaShift := 0; // Not supported
cAccumBits := 0; // No accumulation buffer
cAccumRedBits := 0; // Number of red bits in a-buffer
cAccumGreenBits := 0; // Number of green bits in a-buffer
cAccumBlueBits := 0; // Number of blue bits in a-buffer
cAccumAlphaBits := 0; // Number of alpha bits in a-buffer
cDepthBits := 16; // Specifies the depth of the depth buffer
cStencilBits := 8; // Turn off stencil buffer
cAuxBuffers := 0; // Not supported
iLayerType := PFD_MAIN_PLANE; // Ignored
bReserved := 0; // Number of overlay and underlay planes
dwLayerMask := 0; // Ignored
dwVisibleMask := 0; // Transparent color of underlay plane
dwDamageMask := 0; // Ignored
end;
if PixelFormat = 0 then
nPixelFormat := ChoosePixelFormat(h_DC, @pfd)
else
nPixelFormat := PixelFormat;
if nPixelFormat = 0 then begin
MessageBox(0, 'Unable to find a suitable pixel format', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
//Even with known pixel format we still need to supply some PFD structure
if not SetPixelFormat(h_DC, nPixelFormat, @pfd) then begin
MessageBox(0, 'Unable to set the pixel format', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
Result := True;
{$ENDIF}
//glXChooseVisual() should be on Uni insted of ChoosePixelFormatx
Result[0].X := Ax; Result[0].Y := Ay;
Result[1].X := Bx; Result[1].Y := By;
Result[2].X := Cx; Result[2].Y := Cy;
Result[3].X := Dx; Result[3].Y := Dy;
end;
function GetMultisamplePixelFormat(h_DC: HDC; AntiAliasing: Byte): Integer;
var
pixelFormat: Integer;
ValidFormat: Boolean;
NumFormats: GLUint;
iAttributes: array of GLint;
function KromRectCoords(Ax, Ay, Bx, By: Single): TKromQuadCoords;
begin
Result := 0;
{$IFDEF MSWINDOWS}
if not WGL_ARB_multisample or not Assigned(wglChoosePixelFormatARB) then
Exit;
{$ENDIF}
SetLength(iAttributes,21);
iAttributes[0] := WGL_DRAW_TO_WINDOW_ARB;
iAttributes[1] := 1;
iAttributes[2] := WGL_SUPPORT_OPENGL_ARB;
iAttributes[3] := 1;
iAttributes[4] := WGL_ACCELERATION_ARB;
iAttributes[5] := WGL_FULL_ACCELERATION_ARB;
iAttributes[6] := WGL_COLOR_BITS_ARB;
iAttributes[7] := 24;
iAttributes[8] := WGL_ALPHA_BITS_ARB;
iAttributes[9] := 8;
iAttributes[10] := WGL_DEPTH_BITS_ARB;
iAttributes[11] := 16;
iAttributes[12] := WGL_STENCIL_BITS_ARB;
iAttributes[13] := 0;
iAttributes[14] := WGL_DOUBLE_BUFFER_ARB;
iAttributes[15] := 1;
iAttributes[16] := WGL_SAMPLE_BUFFERS_ARB;
iAttributes[17] := 1;
iAttributes[18] := WGL_SAMPLES_ARB;
iAttributes[19] := AntiAliasing;
iAttributes[20] := 0;
//Try to find mode with slightly worse AA before giving up
repeat
iAttributes[19] := AntiAliasing;
{$IFDEF MSWINDOWS}
ValidFormat := wglChoosePixelFormatARB(h_dc, @iAttributes[0], nil, 1, @pixelFormat, @NumFormats);
{$ENDIF}
if ValidFormat and (NumFormats >= 1) then
begin
Result := pixelFormat;
Exit;
end;
AntiAliasing := AntiAliasing div 2;
until(AntiAliasing < 2);
end;
procedure SetContexts(RenderFrame: HWND; PixelFormat: Integer; out h_DC: HDC; out h_RC: HGLRC);
begin
{$IFDEF MSWINDOWS}
h_DC := GetDC(RenderFrame);
if h_DC = 0 then
begin
MessageBox(HWND(nil), 'Unable to get a device context', 'Error', MB_OK or MB_ICONERROR);
Exit;
end;
if not SetDCPixelFormat(h_DC, PixelFormat) then
Exit;
h_RC := wglCreateContext(h_DC);
if h_RC = 0 then
begin
MessageBox(HWND(nil), 'Unable to create an OpenGL rendering context', 'Error', MB_OK or MB_ICONERROR);
Exit;
end;
if not wglMakeCurrent(h_DC, h_RC) then
begin
MessageBox(HWND(nil), 'Unable to activate OpenGL rendering context', 'Error', MB_OK or MB_ICONERROR);
Exit;
end;
{$ENDIF}
end;
procedure SetRenderFrame(RenderFrame: HWND; out h_DC: HDC; out h_RC: HGLRC);
begin
InitOpenGL;
SetContexts(RenderFrame, 0, h_DC, h_RC);
ReadExtensions;
ReadImplementationProperties;
end;
{The key problem is this: the function we use to get WGL extensions is, itself, an OpenGL extension.
Thus like any OpenGL function, it requires an OpenGL context to call it. So in order to get the
functions we need to create a context, we have to... create a context.
Fortunately, this context does not need to be our final context. All we need to do is create a dummy
context to get function pointers, then use those functions directly. Unfortunately, Windows does not
allow recreation of a rendering context within a single HWND. We must destroy previous HWND context
and create final HWND context after we are finished with the dummy context.}
procedure SetRenderFrameAA(DummyFrame, RenderFrame: HWND; AntiAliasing: Byte; out h_DC: HDC; out h_RC: HGLRC);
var
PixelFormat: Integer;
begin
InitOpenGL;
SetContexts(DummyFrame, 0, h_DC, h_RC);
ReadExtensions;
ReadImplementationProperties;
PixelFormat := GetMultisamplePixelFormat(h_DC, AntiAliasing);
{$IFDEF MSWINDOWS}
wglMakeCurrent(h_DC, 0);
wglDeleteContext(h_RC);
{$ENDIF}
SetContexts(RenderFrame, PixelFormat, h_DC, h_RC);
ReadExtensions;
ReadImplementationProperties;
end;
procedure BuildFont(h_DC: HDC; FontSize: Integer; FontWeight: Word = FW_NORMAL);
var
Font: HFONT;
begin
//New parameter FontSize=16
font:=CreateFont(-abs(FontSize),0,0,0,FontWeight,0,0,0,ANSI_CHARSET,
OUT_TT_PRECIS,CLIP_DEFAULT_PRECIS,
ANTIALIASED_QUALITY,FF_DONTCARE or DEFAULT_PITCH,
'Terminal');
SelectObject(h_dc,font);
{$IFDEF MSWindows}
wglUseFontBitmaps(h_dc,0,128,20000);
{$ENDIF}
{$IFDEF Unix}
// Emulate these functions (with freetype we should be able to code a multi platform solution)
{$ENDIF}
end;
procedure glPrint(const text: AnsiString);
begin
if text = '' then Exit;
glPushAttrib(GL_LIST_BIT);
glListBase(20000);
glCallLists(length(text),GL_UNSIGNED_BYTE,Pchar(@text[1]));
glPopAttrib;
end;
procedure glkScale(x: Single);
begin
glScalef(x, x, x);
end;
procedure glkQuad(Ax, Ay, Bx, By, Cx, Cy, Dx, Dy: Single);
begin
glvertex2f(Ax, Ay);
glvertex2f(Bx, By);
glvertex2f(Cx, Cy);
glvertex2f(Dx, Dy);
end;
//Same as glkQuad, but requires on TopLeft and BottomRight coords
procedure glkRect(Ax, Ay, Bx, By: Single);
begin
glvertex2f(Ax, Ay);
glvertex2f(Bx, Ay);
glvertex2f(Bx, By);
glvertex2f(Ax, By);
Result := KromQuadCoords(Ax, Ay, Bx, Ay, Bx, By, Ax, By);
end;