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

This commit is contained in:
admin_d committed 2026-10-06 12:08:28 +05:00
1 parent f71802c885
commit b8e2d0007d
6 files changed
+639 -39

No files matched your search

+125 -8
View File
@@ -6,7 +6,7 @@ uses
{$IFDEF FPC} Controls, {$ENDIF}
Classes,
Dialogs, SysUtils,
KM_CommonTypes, KM_Defaults, KM_RenderControl, KM_Video,
KM_CommonTypes, KM_Defaults, KM_Video,
KM_Campaigns, KM_Game, KM_InterfaceDefaults, KM_InterfaceMainMenu, KM_InterfaceTypes, KM_Resource,
KM_Music, KM_Maps, KM_MapTypes, KM_CampaignClasses, KM_Networking,
KM_GameSettings,
@@ -20,6 +20,11 @@ type
//Methods relevant to gameplay
TKMGameApp = class
private
fGraphicsGeneration: QWord;
fGraphicsGenerationAccepted: Boolean;
fGraphicsAttemptGeneration: QWord;
fApplicationGraphicsReadyGeneration: QWord;
fGlobalTickCount: Cardinal;
fIsExiting: Boolean;
fIsLoading: Boolean;
@@ -66,9 +71,14 @@ type
procedure InitMainMenu(aScreenX, aScreenY: Word);
function GetActiveInterface: TKMUserInterfaceCommon;
procedure GraphicsContextAvailabilityChanged(aAvailable: Boolean);
function IsCurrentGraphicsAttempt(aCandidateGeneration: QWord): Boolean;
procedure ReevaluateApplicationGraphicsReadiness(aCandidateGeneration: QWord);
function ApplicationGraphicsReadyForCurrentGeneration: Boolean;
procedure RenderPresentationFrame;
public
constructor Create(aRenderControl: TKMRenderControl; aScreenX, aScreenY: Word; aVSync: Boolean; aOnLoadingStep: TKMEvent;
constructor Create(aScreenX, aScreenY: Word; aVSync: Boolean; aOnLoadingStep: TKMEvent;
aOnLoadingText: TUnicodeStringEvent; aOnStatusBarUpdate: TProc<TKMStatusBarPanel, string>; NoMusic: Boolean = False);
destructor Destroy; override;
procedure AfterConstruction(aReturnToOptions: Boolean); reintroduce;
@@ -172,17 +182,22 @@ uses
KM_GameSavePoints,
KM_Cursor, KM_ResTexts, KM_ResKeys, KM_ResTypes,
KM_IoGraphicUtils, KM_Settings,
KM_Saves, KM_CommonUtils
KM_Saves, KM_CommonUtils, KM_GameApp_Mobile
{$IFDEF DBG_RNG_SPY}, KM_RandomChecks{$ENDIF};
{ TKMGameApp }
// Creating everything needed for MainMenu, game stuff is created on StartGame
constructor TKMGameApp.Create(aRenderControl: TKMRenderControl; aScreenX, aScreenY: Word; aVSync: Boolean; aOnLoadingStep: TKMEvent;
constructor TKMGameApp.Create(aScreenX, aScreenY: Word; aVSync: Boolean; aOnLoadingStep: TKMEvent;
aOnLoadingText: TUnicodeStringEvent; aOnStatusBarUpdate: TProc<TKMStatusBarPanel, string>; NoMusic: Boolean = False);
begin
inherited Create;
fGraphicsGeneration := 0;
fGraphicsGenerationAccepted := False;
fGraphicsAttemptGeneration := 0;
fApplicationGraphicsReadyGeneration := 0;
fCampaigns := TKMCampaignsCollection.Create;
fOnStatusBarUpdate := aOnStatusBarUpdate;
@@ -195,7 +210,8 @@ begin
// it makes sense to store its settings along with the game's in the shared folder
fServerSettings := TKMServerSettings.Create(slShared);
gRender := TKMRender.Create(aRenderControl, aScreenX, aScreenY, aVSync);
gRender := TKMRender.Create(aScreenX, aScreenY);
KMGameAppMobileAttach(GraphicsContextAvailabilityChanged);
fChat := TKMChat.Create;
@@ -238,6 +254,7 @@ begin
fOnGameStart := GameStarted;
fOnGameEnd := GameEnded;
KMGameAppMobileAttachPresentation(RenderPresentationFrame, Resize);
end;
@@ -250,12 +267,87 @@ begin
end;
procedure TKMGameApp.GraphicsContextAvailabilityChanged(aAvailable: Boolean);
var
candidateGeneration: QWord;
begin
if aAvailable then
begin
if fGraphicsGeneration = High(QWord) then
raise Exception.Create('Graphics generation exhausted');
Inc(fGraphicsGeneration);
fGraphicsAttemptGeneration := fGraphicsGeneration;
fGraphicsGenerationAccepted := True;
fApplicationGraphicsReadyGeneration := 0;
candidateGeneration := fGraphicsAttemptGeneration;
TKMRender.GraphicsContextChanged(True);
if not TKMRender.TextureBackendReady then
raise Exception.Create('Graphics texture backend is not ready after context restore');
if (gRes <> nil) and (gRes.DataState <> rlsNone) then
gRes.StartGameSpriteRecovery;
ReevaluateApplicationGraphicsReadiness(candidateGeneration);
end
else
begin
fGraphicsGenerationAccepted := False;
fGraphicsAttemptGeneration := 0;
fApplicationGraphicsReadyGeneration := 0;
TKMRender.GraphicsContextChanged(False);
end;
end;
procedure TKMGameApp.ReevaluateApplicationGraphicsReadiness(aCandidateGeneration: QWord);
begin
if not IsCurrentGraphicsAttempt(aCandidateGeneration) then
Exit;
fApplicationGraphicsReadyGeneration := 0;
if not TKMRender.TextureBackendReady then
Exit;
if gGame <> nil then
begin
if gRes = nil then
Exit;
if not gRes.GameResourcesReady then
Exit;
end;
if IsCurrentGraphicsAttempt(aCandidateGeneration) then
fApplicationGraphicsReadyGeneration := aCandidateGeneration;
end;
function TKMGameApp.ApplicationGraphicsReadyForCurrentGeneration: Boolean;
begin
Result := fGraphicsGenerationAccepted
and (fGraphicsGeneration <> 0)
and (fGraphicsAttemptGeneration = fGraphicsGeneration)
and (fApplicationGraphicsReadyGeneration = fGraphicsGeneration);
end;
function TKMGameApp.IsCurrentGraphicsAttempt(aCandidateGeneration: QWord): Boolean;
begin
Result := (aCandidateGeneration <> 0)
and fGraphicsGenerationAccepted
and (aCandidateGeneration = fGraphicsGeneration)
and (aCandidateGeneration = fGraphicsAttemptGeneration);
end;
{ Destroy what was created }
destructor TKMGameApp.Destroy;
begin
//Freeing network sockets and OpenAL can result in events like Resize/Paint occuring (seen in crash reports)
//Set fIsExiting so we know to skip them
fIsExiting := True;
KMGameAppMobileDetachPresentation;
KMGameAppMobileDetach;
//We might have crashed part way through .Create, so we can't assume ANYTHING exists here.
//Doing so causes a 2nd exception which overrides 1st. Hence check <> nil on everything except Free (TObject.Free does that already)
@@ -372,6 +464,12 @@ begin
end;
procedure TKMGameApp.RenderPresentationFrame;
begin
Render(False);
end;
// This event happens every ~33ms if the Key is Down and holded
procedure TKMGameApp.KeyDown(Key: Word; Shift: TShiftState; aIsFirst: Boolean);
var
@@ -540,6 +638,8 @@ end;
procedure TKMGameApp.CreateGame(aGameMode: TKMGameMode);
var
candidateGeneration: QWord;
begin
//Reset controls if MainForm exists (KMR could be run without main form)
if gMain <> nil then
@@ -550,6 +650,8 @@ begin
fBaseSaveWorkerThreadHolder,
fAutoSaveWorkerThreadHolder,
fSavePointWorkerThreadHolder);
candidateGeneration := fGraphicsAttemptGeneration;
ReevaluateApplicationGraphicsReadiness(candidateGeneration);
end;
@@ -624,6 +726,8 @@ end;
//5. Free the game object
//6. Switch to MainMenu
procedure TKMGameApp.StopGame(aMsg: TKMGameResultMsg; const aTextMsg: UnicodeString = '');
var
candidateGeneration: QWord;
begin
if gGame = nil then Exit;
@@ -655,6 +759,8 @@ begin
end;
FreeThenNil(gGame);
candidateGeneration := fGraphicsAttemptGeneration;
ReevaluateApplicationGraphicsReadiness(candidateGeneration);
gLog.AddTime('Gameplay ended - ' + GetEnumName(TypeInfo(TKMGameResultMsg), Integer(aMsg)) + ' /' + aTextMsg);
end;
@@ -677,6 +783,8 @@ end;
procedure TKMGameApp.StopGameReturnToLobby;
var
candidateGeneration: QWord;
begin
if gGame = nil then Exit;
@@ -692,6 +800,8 @@ begin
fOnGameEnd(gGame.Params.Mode);
FreeThenNil(gGame);
candidateGeneration := fGraphicsAttemptGeneration;
ReevaluateApplicationGraphicsReadiness(candidateGeneration);
fNetworking.ReturnToLobby; //Clears gGame event pointers from Networking
fMainMenuInterface.ReturnToLobby(RETURN_TO_LOBBY_SAVE); //Assigns Lobby event pointers to Networking and selects map
@@ -1224,7 +1334,7 @@ begin
if Self = nil then Exit;
if SKIP_RENDER then Exit;
if fIsExiting then Exit;
if gRender.Blind then Exit;
if not ApplicationGraphicsReadyForCurrentGeneration then Exit;
if fIsLoading then Exit; //Don't render while toggling locale
gRender.BeginFrame;
@@ -1239,7 +1349,6 @@ begin
gRender.RenderBrightness(gGameSettings.GFX.Brightness);
gRender.EndFrame;
gRender.Query.QueriesSwapBuffers;
if not aForPrintScreen
@@ -1393,12 +1502,20 @@ end;
// This is our real-time "thread", use it wisely
procedure TKMGameApp.UpdateStateIdle(aFrameTime: Cardinal);
var
candidateGeneration: QWord;
begin
if gGame <> nil then gGame.UpdateStateIdle(aFrameTime);
if gMusic <> nil then gMusic.UpdateStateIdle;
if gSoundPlayer <> nil then gSoundPlayer.UpdateStateIdle;
if fNetworking <> nil then fNetworking.UpdateStateIdle;
if gRes <> nil then gRes.UpdateStateIdle;
candidateGeneration := fGraphicsAttemptGeneration;
try
if gRes <> nil then
gRes.UpdateStateIdle;
finally
ReevaluateApplicationGraphicsReadiness(candidateGeneration);
end;
end;
@@ -5,7 +5,7 @@ uses
{$IFDEF WDC} Windows, {$ENDIF}
{$IFDEF Unix} LCLIntf, LCLType, OpenGLContext, {$ENDIF}
dglOpenGL,
KM_RenderControl, KM_RenderQuery, KM_RenderTypes, KM_CommonTypes;
KM_RenderQuery, KM_RenderTypes, KM_CommonTypes;
const
@@ -25,17 +25,15 @@ type
fFBO: Cardinal;
fRenderBuf: Cardinal;
fRenderControl: TKMRenderControl;
fOpenGL_Vendor, fOpenGL_Renderer, fOpenGL_Version: UnicodeString;
fScreenX, fScreenY: Word;
fBlind: Boolean;
fQuery: TKMRenderQuery;
procedure InitFBO;
procedure SaveBufferToFile(aUseFBOBuffer: Boolean; var aWidth, aHeight: Integer; var aPixelData: TKMCardinalArray);
function GetMaxFBOSize: Cardinal;
public
constructor Create(aRenderControl: TKMRenderControl; aScreenX, aScreenY: Integer; aVSync: Boolean);
constructor Create(aScreenX, aScreenY: Integer);
destructor Destroy; override;
procedure SetRenderMode(aRenderMode: TKMRenderMode); //Switch between 2D and 3D perspectives
@@ -64,13 +62,10 @@ type
property ScreenX: Word read fScreenX;
property ScreenY: Word read fScreenY;
property Blind: Boolean read fBlind;
property Query: TKMRenderQuery read fQuery;
procedure BeginFrame;
procedure RenderBrightness(aValue: Byte);
procedure EndFrame;
end;
var
@@ -91,22 +86,17 @@ const
MAX_FBO_BUFFER_SIZE = CELL_SIZE_PX * (MAX_MAP_SIZE - 1); // (10200 = CELL_SIZE=40px)*255
{ TKMRender }
constructor TKMRender.Create(aRenderControl: TKMRenderControl; aScreenX, aScreenY: Integer; aVSync: Boolean);
constructor TKMRender.Create(aScreenX, aScreenY: Integer);
begin
inherited Create;
gLog.AddTime('Init Render started');
fFBOInited := False;
fBlind := aRenderControl = nil;
fRenderControl := aRenderControl;
if not fBlind then
begin
fQuery := TKMRenderQuery.Create;
fRenderControl.CreateRenderContext;
fMaxViewportDim := GetMaxViewportDim;
gLog.AddTime('GL_MAX_VIEWPORT_DIM = ' + IntToStr(fMaxViewportDim));
@@ -129,10 +119,8 @@ begin
fOpenGL_Renderer := UnicodeString(glGetString(GL_RENDERER)); gLog.AddNoTime('OpenGL Renderer: ' + fOpenGL_Renderer);
fOpenGL_Version := UnicodeString(glGetString(GL_VERSION)); gLog.AddNoTime('OpenGL Version: ' + fOpenGL_Version);
SetupVSync(aVSync);
Resize(aScreenX, aScreenY);
end;
Resize(aScreenX, aScreenY);
gLog.AddTime('Init Render Done');
end;
@@ -141,7 +129,6 @@ destructor TKMRender.Destroy;
begin
if not fBlind then
begin
fRenderControl.DestroyRenderContext;
fQuery.Free;
if fFBOInited then
@@ -189,11 +176,8 @@ end;
procedure TKMRender.Resize(aWidth, aHeight: Integer);
begin
if fBlind then Exit;
fScreenX := max(aWidth, 1);
fScreenY := max(aHeight, 1);
glViewport(0, 0, fScreenX, fScreenY);
end;
@@ -383,13 +367,4 @@ begin
end;
procedure TKMRender.EndFrame;
begin
if fBlind then Exit;
glFinish;
fRenderControl.SwapBuffers;
end;
end.
@@ -0,0 +1,275 @@
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;
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);
implementation
function SetDCPixelFormat(h_DC: HDC; PixelFormat: Integer): Boolean;
var
nPixelFormat: Integer;
PixelDepth: Integer;
{$IFDEF MSWINDOWS}
pfd: TPixelFormatDescriptor;
{$ENDIF}
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
end;
function GetMultisamplePixelFormat(h_DC: HDC; AntiAliasing: Byte): Integer;
var
pixelFormat: Integer;
ValidFormat: Boolean;
NumFormats: GLUint;
iAttributes: array of GLint;
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);
end;
end.