kam-mobile/code/KM_RenderTerrain_Mobile.pas

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.