Move terrain mobile graphics unit to application source root
Sync changed files to Google Drive / sync (push) Successful in 23s

This commit is contained in:
admin_d committed 2026-10-16 21:58:25 +05:00
1 parent 3cc1773975
commit 776fc59c9e
1 file changed
+540
View File
@@ -0,0 +1,540 @@
unit KM_RenderTerrain_Mobile;
{$I KaM_Remake.inc}
interface
uses
SysUtils, CastleGLShaders, CastleGLES, CastleRenderOptions;
type
ETerrainForeignGLError = class(Exception);
ETerrainOwnedGpuError = class(Exception);
ETerrainContextUnavailable = class(Exception);
TTerrainContextCheck = function: Boolean of object;
TTerrainMobileVertex = packed record
X, Y, Z: Single;
U, V: Single;
Opacity: Single;
GradientU: Single;
end;
TTerrainMobileQuad = array[0..3] of TTerrainMobileVertex;
TTerrainMobileSampleKind = (tmsAtlasUV, tmsGradientU);
TKMTerrainMobileGraphics = class
private
fProgram: TGLSLProgram;
fPendingProgram: TGLSLProgram;
fProgramReady: Boolean;
fContextCheck: TTerrainContextCheck;
fStreamVbo: CastleGLES.GLuint;
fStreamStorageReady: Boolean;
fRunVertices: array[0..6143] of TTerrainMobileVertex;
fRunTexID: Cardinal;
fRunVertexCount: Integer;
fPassActive: Boolean;
fPassSampleKind: TTerrainMobileSampleKind;
fPassSourceBlend: TBlendingSourceFactor;
fPassDestinationBlend: TBlendingDestinationFactor;
fStateApplied: Boolean;
fPassFailed: Boolean;
procedure AppendQuadVertices(const aQuad: TTerrainMobileQuad);
procedure ResetPendingRun;
procedure FlushPendingRun;
procedure ClosePassState;
function ContextCurrent: Boolean;
procedure DisposeClosedProgram;
public
constructor Create;
property ContextCheck: TTerrainContextCheck read fContextCheck write fContextCheck;
destructor Destroy; override;
procedure BeginPass(aSampleKind: TTerrainMobileSampleKind;
aSourceBlend: TBlendingSourceFactor;
aDestinationBlend: TBlendingDestinationFactor);
procedure SubmitQuad(aTextureId: Cardinal; const aQuad: TTerrainMobileQuad);
procedure FinishPass;
procedure AbortPass;
procedure DiscardPendingRunWithoutGL;
procedure CreateCurrentProgram;
procedure CreateCurrentStreamStorage;
procedure ReleaseCurrentGpuObjects;
procedure DiscardGpuWithoutGL;
procedure ConfirmPreviousProgramClosed;
function GpuObjectsComplete: Boolean;
end;
implementation
uses
CastleRenderContext, CastleApplicationProperties, KM_Render;
const
TerrainVertexShader =
'attribute vec3 aPosition;' + #10 +
'attribute vec2 aTexCoord;' + #10 +
'attribute float aOpacity;' + #10 +
'attribute float aGradientCoord;' + #10 +
'uniform mat4 uProjection;' + #10 +
'varying vec2 vTexCoord;' + #10 +
'varying float vOpacity;' + #10 +
'varying float vGradientCoord;' + #10 +
'void main() {' + #10 +
' gl_Position = uProjection * vec4(aPosition, 1.0);' + #10 +
' vTexCoord = aTexCoord;' + #10 +
' vOpacity = aOpacity;' + #10 +
' vGradientCoord = aGradientCoord;' + #10 +
'}';
TerrainFragmentShader =
'uniform sampler2D uTexture;' + #10 +
'uniform int uSampleKind;' + #10 +
'varying vec2 vTexCoord;' + #10 +
'varying float vOpacity;' + #10 +
'varying float vGradientCoord;' + #10 +
'void main() {' + #10 +
' vec2 chosenUV = uSampleKind == 0 ? vTexCoord : vec2(vGradientCoord, 0.5);' + #10 +
' gl_FragColor = texture2D(uTexture, chosenUV) * vec4(1.0, 1.0, 1.0, clamp(vOpacity, 0.0, 1.0));' + #10 +
'}';
function DrainTerrainGLErrors: string;
var
ErrorCode: CastleGLES.GLenum;
begin
Result := '';
if not Assigned(CastleGLES.glGetError) then
raise Exception.Create('Terrain GLES glGetError is unavailable');
repeat
ErrorCode := CastleGLES.glGetError();
if ErrorCode <> CastleGLES.GL_NO_ERROR then
begin
if Result <> '' then Result := Result + ', ';
Result := Result + '0x' + IntToHex(ErrorCode, 8);
end;
until ErrorCode = CastleGLES.GL_NO_ERROR;
end;
procedure RequireTerrainGLErrorFree(const aStage: string);
var
Errors: string;
begin
Errors := DrainTerrainGLErrors;
if Errors <> '' then
raise ETerrainOwnedGpuError.Create('Terrain GLES ' + aStage + ' failed with error(s) ' + Errors);
end;
constructor TKMTerrainMobileGraphics.Create;
begin
inherited Create;
fProgram := nil;
fStreamVbo := 0;
fStreamStorageReady := False;
fPassActive := False;
fStateApplied := False;
fPassFailed := False;
fRunTexID := 0;
fRunVertexCount := 0;
end;
procedure TKMTerrainMobileGraphics.ConfirmPreviousProgramClosed;
begin
fProgramReady := False;
FreeAndNil(fPendingProgram);
FreeAndNil(fProgram);
end;
procedure TKMTerrainMobileGraphics.DisposeClosedProgram;
begin
if not ApplicationProperties.IsGLContextOpen then
ConfirmPreviousProgramClosed;
end;
destructor TKMTerrainMobileGraphics.Destroy;
begin
if ContextCurrent then ReleaseCurrentGpuObjects;
DiscardGpuWithoutGL;
DisposeClosedProgram;
if (fProgram <> nil) or (fPendingProgram <> nil) then
raise ETerrainContextUnavailable.Create('Terrain shader disposal awaits completed Castle context close');
inherited;
end;
procedure TKMTerrainMobileGraphics.CreateCurrentProgram;
var
Candidate: TGLSLProgram;
PositionAttribute, TexCoordAttribute, OpacityAttribute, GradientAttribute: TGLSLAttribute;
ProjectionUniform, TextureUniform, SampleKindUniform: TGLSLUniform;
begin
if fProgramReady and (fProgram <> nil) then Exit;
DisposeClosedProgram;
if (fProgram <> nil) or (fPendingProgram <> nil) then
raise ETerrainContextUnavailable.Create('Terrain shader creation awaits disposal after Castle context close');
if not ContextCurrent then
raise ETerrainContextUnavailable.Create('Terrain shader creation requires the accepted current context');
Candidate := nil;
try
Candidate := TGLSLProgram.Create;
Candidate.FragmentShaderRequired := True;
Candidate.AttachVertexShader(TerrainVertexShader);
Candidate.AttachFragmentShader(TerrainFragmentShader);
Candidate.Link;
PositionAttribute := Candidate.Attribute('aPosition');
TexCoordAttribute := Candidate.Attribute('aTexCoord');
OpacityAttribute := Candidate.Attribute('aOpacity');
GradientAttribute := Candidate.Attribute('aGradientCoord');
ProjectionUniform := Candidate.Uniform('uProjection', umIgnore);
TextureUniform := Candidate.Uniform('uTexture', umIgnore);
SampleKindUniform := Candidate.Uniform('uSampleKind', umIgnore);
if (PositionAttribute.Location = -1) or (TexCoordAttribute.Location = -1)
or (OpacityAttribute.Location = -1) or (GradientAttribute.Location = -1)
or (ProjectionUniform.Location = -1) or (TextureUniform.Location = -1)
or (SampleKindUniform.Location = -1) then
raise Exception.Create('Terrain shader is missing a required attribute or uniform');
if not ContextCurrent then
raise ETerrainContextUnavailable.Create('Terrain context changed during shader creation');
fProgram := Candidate;
fProgramReady := True;
Candidate := nil;
finally
if Candidate <> nil then
begin
if ContextCurrent then FreeAndNil(Candidate)
else
begin
fPendingProgram := Candidate;
DisposeClosedProgram;
end;
end;
end;
end;
procedure TKMTerrainMobileGraphics.CreateCurrentStreamStorage;
var
Candidate: CastleGLES.GLuint;
OldErrors: string;
begin
if fStreamStorageReady then Exit;
OldErrors := DrainTerrainGLErrors;
if OldErrors <> '' then
raise ETerrainForeignGLError.Create('Terrain GLES encountered pre-existing error(s) before stream allocation: ' + OldErrors);
if fStreamVbo = 0 then
begin
Candidate := 0;
CastleGLES.glGenBuffers(1, @Candidate);
if Candidate = 0 then
raise Exception.Create('Terrain GLES failed to allocate a stream buffer name');
fStreamVbo := Candidate;
RequireTerrainGLErrorFree('stream buffer name allocation');
end;
fStreamStorageReady := False;
try
RenderContext.BindBuffer[btArray] := fStreamVbo;
CastleGLES.glBufferData(CastleGLES.GL_ARRAY_BUFFER,
6144 * SizeOf(TTerrainMobileVertex), nil, CastleGLES.GL_STREAM_DRAW);
if ContextCurrent then RenderContext.BindBuffer[btArray] := 0;
RequireTerrainGLErrorFree('stream storage allocation');
fStreamStorageReady := True;
except
try
if ContextCurrent then RenderContext.BindBuffer[btArray] := 0;
except
{ Preserve the allocation failure. }
end;
raise;
end;
end;
function TKMTerrainMobileGraphics.ContextCurrent: Boolean;
begin
Result := Assigned(fContextCheck) and fContextCheck();
end;
procedure TKMTerrainMobileGraphics.ReleaseCurrentGpuObjects;
var
FirstError: Exception;
procedure RememberError;
begin
if FirstError = nil then FirstError := Exception(AcquireExceptionObject);
end;
begin
FirstError := nil;
try
if ContextCurrent and fPassActive then AbortPass;
except
RememberError;
end;
try
if ContextCurrent and (fStreamVbo <> 0) then
begin
CastleGLES.glDeleteBuffers(1, @fStreamVbo);
fStreamVbo := 0;
end;
except
RememberError;
end;
try
if ContextCurrent then
begin
FreeAndNil(fPendingProgram);
if ContextCurrent then FreeAndNil(fProgram);
end;
except
RememberError;
end;
DiscardGpuWithoutGL;
if FirstError <> nil then raise FirstError;
end;
procedure TKMTerrainMobileGraphics.DiscardGpuWithoutGL;
begin
fProgramReady := False;
DisposeClosedProgram;
fStreamVbo := 0;
fStreamStorageReady := False;
ResetPendingRun;
fPassActive := False;
fStateApplied := False;
fPassFailed := False;
end;
function TKMTerrainMobileGraphics.GpuObjectsComplete: Boolean;
begin
Result := fProgramReady and (fProgram <> nil) and fStreamStorageReady and (fStreamVbo <> 0);
end;
procedure TKMTerrainMobileGraphics.ResetPendingRun;
begin
fRunTexID := 0;
fRunVertexCount := 0;
end;
procedure TKMTerrainMobileGraphics.AppendQuadVertices(const aQuad: TTerrainMobileQuad);
const
TriangleOrder: array[0..5] of Byte = (0, 1, 2, 0, 2, 3);
var
I: Integer;
begin
for I := 0 to High(TriangleOrder) do
fRunVertices[fRunVertexCount + I] := aQuad[TriangleOrder[I]];
Inc(fRunVertexCount, Length(TriangleOrder));
end;
procedure TKMTerrainMobileGraphics.BeginPass(aSampleKind: TTerrainMobileSampleKind;
aSourceBlend: TBlendingSourceFactor; aDestinationBlend: TBlendingDestinationFactor);
begin
if fPassActive then
raise Exception.Create('Terrain graphics pass is already active');
fPassSampleKind := aSampleKind;
fPassSourceBlend := aSourceBlend;
fPassDestinationBlend := aDestinationBlend;
fPassActive := True;
fStateApplied := False;
fPassFailed := False;
ResetPendingRun;
end;
procedure TKMTerrainMobileGraphics.SubmitQuad(aTextureId: Cardinal;
const aQuad: TTerrainMobileQuad);
begin
if not fPassActive then
raise Exception.Create('Terrain graphics SubmitQuad requires an active pass');
if fPassFailed then
raise Exception.Create('Terrain graphics pass has already failed');
if aTextureId = 0 then
begin
fPassFailed := True;
raise Exception.Create('Terrain graphics quad has an invalid texture identity');
end;
if not fProgramReady or (fProgram = nil) or (fStreamVbo = 0) then
begin
fPassFailed := True;
raise Exception.Create('Terrain graphics shader or stream buffer is unavailable');
end;
if fRunVertexCount = 0 then
fRunTexID := aTextureId
else if fRunTexID <> aTextureId then
begin
try
FlushPendingRun;
except
fPassFailed := True;
raise;
end;
fRunTexID := aTextureId;
end;
if fRunVertexCount + 6 > Length(fRunVertices) then
begin
try
FlushPendingRun;
except
fPassFailed := True;
raise;
end;
fRunTexID := aTextureId;
end;
AppendQuadVertices(aQuad);
end;
procedure TKMTerrainMobileGraphics.FlushPendingRun;
var
PositionAttribute, TexCoordAttribute, OpacityAttribute, GradientAttribute: TGLSLAttribute;
ProjectionUniform, TextureUniform, SampleKindUniform: TGLSLUniform;
PositionEnabled, TexCoordEnabled, OpacityEnabled, GradientEnabled: Boolean;
RunFailed: Boolean;
OldErrors: string;
procedure CleanupRun;
begin
try
if ContextCurrent and GradientEnabled then GradientAttribute.DisableArray;
finally
try
if ContextCurrent and OpacityEnabled then OpacityAttribute.DisableArray;
finally
try
if ContextCurrent and TexCoordEnabled then TexCoordAttribute.DisableArray;
finally
try
if ContextCurrent and PositionEnabled then PositionAttribute.DisableArray;
finally
if ContextCurrent then RenderContext.BindBuffer[btArray] := 0;
end;
end;
end;
end;
end;
begin
if fRunVertexCount = 0 then Exit;
if not fPassActive or fPassFailed then
raise Exception.Create('Terrain graphics cannot flush a failed or closed pass');
if not fProgramReady or (fProgram = nil) or (fStreamVbo = 0) then
raise Exception.Create('Terrain graphics shader or stream buffer is unavailable');
OldErrors := DrainTerrainGLErrors;
if OldErrors <> '' then
raise ETerrainForeignGLError.Create('Terrain GLES encountered pre-existing error(s) before flush: ' + OldErrors);
if not fStateApplied then
begin
RenderContext.BlendingEnable(fPassSourceBlend, fPassDestinationBlend);
fStateApplied := True;
end;
PositionEnabled := False;
TexCoordEnabled := False;
OpacityEnabled := False;
GradientEnabled := False;
RunFailed := True;
try
TKMRender.BindTexture(fRunTexID);
fProgram.Enable;
ProjectionUniform := fProgram.Uniform('uProjection', umIgnore);
TextureUniform := fProgram.Uniform('uTexture', umIgnore);
SampleKindUniform := fProgram.Uniform('uSampleKind', umIgnore);
if (ProjectionUniform.Location = -1) or (TextureUniform.Location = -1) or
(SampleKindUniform.Location = -1) then
raise Exception.Create('Terrain shader is missing a required draw uniform');
ProjectionUniform.SetValue(RenderContext.ProjectionMatrix);
TextureUniform.SetValue(0);
SampleKindUniform.SetValue(Ord(fPassSampleKind));
RenderContext.BindBuffer[btArray] := fStreamVbo;
PositionAttribute := fProgram.Attribute('aPosition');
TexCoordAttribute := fProgram.Attribute('aTexCoord');
OpacityAttribute := fProgram.Attribute('aOpacity');
GradientAttribute := fProgram.Attribute('aGradientCoord');
PositionAttribute.EnableArrayVector3(nil, 28, PtrUInt(0));
PositionEnabled := True;
TexCoordAttribute.EnableArrayVector2(nil, 28, PtrUInt(12));
TexCoordEnabled := True;
OpacityAttribute.EnableArraySingle(nil, 28, PtrUInt(20));
OpacityEnabled := True;
GradientAttribute.EnableArraySingle(nil, 28, PtrUInt(24));
GradientEnabled := True;
RequireTerrainGLErrorFree('shader/bind/attribute setup');
CastleGLES.glBufferData(CastleGLES.GL_ARRAY_BUFFER,
fRunVertexCount * SizeOf(TTerrainMobileVertex), @fRunVertices[0], CastleGLES.GL_STREAM_DRAW);
RequireTerrainGLErrorFree('stream upload');
CastleGLES.glDrawArrays(CastleGLES.GL_TRIANGLES, 0, CastleGLES.GLsizei(fRunVertexCount));
RequireTerrainGLErrorFree('triangle draw');
ResetPendingRun;
RunFailed := False;
finally
if RunFailed then
begin
try
CleanupRun;
except
{ Preserve the original flush error after attempting every cleanup. }
end;
end
else
CleanupRun;
end;
end;
procedure TKMTerrainMobileGraphics.ClosePassState;
begin
try
if ContextCurrent and fStateApplied and (fProgram <> nil) and (fStreamVbo <> 0) then
begin
try
if ContextCurrent then TGLSLProgram.Disable;
finally
try
if ContextCurrent then TKMRender.BindTexture(0);
finally
try
if ContextCurrent then RenderContext.BlendingEnable(bsSrcAlpha, bdOneMinusSrcAlpha);
finally
if ContextCurrent then RenderContext.BindBuffer[btArray] := 0;
end;
end;
end;
end;
finally
ResetPendingRun;
fPassActive := False;
fStateApplied := False;
fPassFailed := False;
end;
end;
procedure TKMTerrainMobileGraphics.FinishPass;
begin
if not fPassActive then
raise Exception.Create('Terrain graphics FinishPass requires an active pass');
try
if fPassFailed then
raise Exception.Create('Terrain graphics pass has already failed');
FlushPendingRun;
except
fPassFailed := True;
try
ClosePassState;
except
{ Keep the original submission error. }
end;
raise;
end;
ClosePassState;
end;
procedure TKMTerrainMobileGraphics.AbortPass;
begin
if not fPassActive then Exit;
ClosePassState;
end;
procedure TKMTerrainMobileGraphics.DiscardPendingRunWithoutGL;
begin
ResetPendingRun;
fPassActive := False;
fStateApplied := False;
fPassFailed := False;
end;
end.