kam-mobile/code/GameDiagnosticsGraphics_Mobile.pas

unit GameDiagnosticsGraphics_Mobile;
{$mode objfpc}{$H+}

interface

uses
  Classes, CastleUIControls, GameDiagnosticsReport, KM_Render, KM_RenderTypes;

type
  TGraphicsDiagnosticSession = class
  private
    type
      TGraphicsDiagnosticActionKind = (
        gakNone, gakReadiness, gakTextureLifecycle, gakVisibleDraw);
      TGraphicsDiagnosticExecutionState = (gesIdle, gesPending, gesActive);
      TVisibleDrawPhase = (vdpNotStarted, vdpBase, vdpBrightness);

  private
    FContainer: TCastleContainer;
    FRenderer: TKMRender;
    FPhysicalWidth, FPhysicalHeight: Integer;
    FPhysicalSizeKnown: Boolean;
    FContextReportedAvailable, FRendererContextSynced: Boolean;
    FPresentationAttached, FLifecycleAttached, FClosing: Boolean;
    FContextTransitionErrorPresent: Boolean;
    FContextTransitionErrorClass, FContextTransitionErrorMessage: string;
    FActionKind: TGraphicsDiagnosticActionKind;
    FExecutionState: TGraphicsDiagnosticExecutionState;
    FAttachInProgress: Boolean;
    FTextureTestId: Cardinal;
    FVisiblePhase: TVisibleDrawPhase;
    FVisiblePhaseStarted: Boolean;
    FVisibleFramesCompletedInPhase: Integer;
    FVisibleTextureId: Cardinal;
    FOnResultPublished: TNotifyEvent;
    FReadinessResult: TGraphicsReadinessDiagnosticResult;
    FTextureResult: TGraphicsTextureDiagnosticResult;
    FVisibleDrawResult: TGraphicsVisibleDrawDiagnosticResult;
    function GetBusy: Boolean;
    function AcceptGraphicsRequest(const AKind: TGraphicsDiagnosticActionKind): Boolean;
    procedure HandleFrame;
    procedure DispatchFrame;
    procedure ObserveReadiness;
    procedure ObserveTextureLifecycle;
    procedure ObserveVisibleDraw;
    procedure InvalidateTextureOnContextLoss;
    procedure MarkInterruptedVisiblePhase;
    procedure SetReadinessSnapshot;
    procedure SetActionError(const AClassName, AMessage: string);
    procedure FinalizeAction;
    procedure HandleResize(aWidth, aHeight: Integer);
    procedure HandleContextAvailability(aAvailable: Boolean);
    procedure EnsureAttached;
  public
    constructor Create(const AContainer: TCastleContainer);
    destructor Destroy; override;
    function RequestReadiness: Boolean;
    function RequestTextureLifecycle: Boolean;
    function RequestVisibleDraw: Boolean;
    property Busy: Boolean read GetBusy;
    property OnResultPublished: TNotifyEvent read FOnResultPublished write FOnResultPublished;
  end;

implementation

uses
  SysUtils, KM_GameApp_Mobile, KM_CommonTypes;

constructor TGraphicsDiagnosticSession.Create(const AContainer: TCastleContainer);
begin
  inherited Create;
  if AContainer = nil then
    raise Exception.Create('Graphics diagnostic container is nil');
  FContainer := AContainer;
  FRenderer := nil;
  FPhysicalWidth := 0;
  FPhysicalHeight := 0;
  FPhysicalSizeKnown := False;
  FContextReportedAvailable := False;
  FRendererContextSynced := False;
  FPresentationAttached := False;
  FLifecycleAttached := False;
  FClosing := False;
  FContextTransitionErrorPresent := False;
  FContextTransitionErrorClass := '';
  FContextTransitionErrorMessage := '';
  FActionKind := gakNone;
  FExecutionState := gesIdle;
  FAttachInProgress := False;
  FTextureTestId := 0;
  FVisiblePhase := vdpNotStarted;
  FVisiblePhaseStarted := False;
  FVisibleFramesCompletedInPhase := 0;
  FVisibleTextureId := 0;
  FOnResultPublished := nil;
  FReadinessResult := Default(TGraphicsReadinessDiagnosticResult);
  FTextureResult := Default(TGraphicsTextureDiagnosticResult);
  FVisibleDrawResult := Default(TGraphicsVisibleDrawDiagnosticResult);
end;

function TGraphicsDiagnosticSession.GetBusy: Boolean;
begin
  Result := FExecutionState <> gesIdle;
end;

function TGraphicsDiagnosticSession.RequestReadiness: Boolean;
begin
  Result := AcceptGraphicsRequest(gakReadiness);
end;

function TGraphicsDiagnosticSession.RequestTextureLifecycle: Boolean;
begin
  Result := AcceptGraphicsRequest(gakTextureLifecycle);
end;

function TGraphicsDiagnosticSession.RequestVisibleDraw: Boolean;
begin
  Result := AcceptGraphicsRequest(gakVisibleDraw);
end;

function TGraphicsDiagnosticSession.AcceptGraphicsRequest(
  const AKind: TGraphicsDiagnosticActionKind): Boolean;
var
  AttachErrorClass, AttachErrorMessage: string;
begin
  if FClosing or GetBusy then
    Exit(False);

  case AKind of
    gakReadiness: FReadinessResult := Default(TGraphicsReadinessDiagnosticResult);
    gakTextureLifecycle:
      begin
        FTextureTestId := 0;
        FTextureResult := Default(TGraphicsTextureDiagnosticResult);
      end;
    gakVisibleDraw:
      begin
        FVisibleDrawResult := Default(TGraphicsVisibleDrawDiagnosticResult);
        FVisiblePhase := vdpNotStarted;
        FVisiblePhaseStarted := False;
        FVisibleFramesCompletedInPhase := 0;
        FVisibleTextureId := 0;
      end;
  else
    Exit(False);
  end;
  FActionKind := AKind;
  FExecutionState := gesPending;
  AttachErrorClass := '';
  AttachErrorMessage := '';
  FAttachInProgress := True;
  try
    try
      EnsureAttached;
    except
      on E: Exception do
      begin
        AttachErrorClass := E.ClassName;
        AttachErrorMessage := E.Message;
      end;
    end;
  finally
    FAttachInProgress := False;
  end;

  if AttachErrorClass <> '' then
  begin
    SetActionError(AttachErrorClass, AttachErrorMessage);
    FinalizeAction;
    Exit(True);
  end;
  if FContextTransitionErrorPresent or not FContextReportedAvailable or
     not FRendererContextSynced then
  begin
    if AKind = gakReadiness then
      SetReadinessSnapshot;
    if FContextTransitionErrorPresent then
      SetActionError(FContextTransitionErrorClass, FContextTransitionErrorMessage)
    else if not FContextReportedAvailable then
      SetActionError('', 'Graphics context is unavailable')
    else
      SetActionError('', 'Graphics renderer context is not synchronized');
    FinalizeAction;
  end;
  Result := True;
end;

procedure TGraphicsDiagnosticSession.SetActionError(
  const AClassName, AMessage: string);
var
  ErrorValue: TDiagnosticError;
begin
  ErrorValue := Default(TDiagnosticError);
  ErrorValue.Present := True;
  if AClassName <> '' then
  begin
    ErrorValue.ClassName.HasValue := True;
    ErrorValue.ClassName.Value := AClassName;
  end;
  ErrorValue.MessageText.HasValue := True;
  ErrorValue.MessageText.Value := AMessage;
  case FActionKind of
    gakReadiness: begin FReadinessResult.Status := dsFail; FReadinessResult.Error := ErrorValue; end;
    gakTextureLifecycle: begin FTextureResult.Status := dsFail; FTextureResult.Error := ErrorValue; end;
    gakVisibleDraw: begin FVisibleDrawResult.Status := dsFail; FVisibleDrawResult.Error := ErrorValue; end;
  end;
end;

procedure TGraphicsDiagnosticSession.MarkInterruptedVisiblePhase;
var
  Stage: TGraphicsVisibleDrawDiagnosticStageId;
begin
  if not FVisiblePhaseStarted or (FVisiblePhase = vdpNotStarted) then
    Exit;
  if FVisiblePhase = vdpBrightness then
    Stage := gvsiBrightnessPhase
  else
    Stage := gvsiSampledRgbaPhase;
  if FVisibleDrawResult.Stages[Stage] = dsPass then
    Exit;
  FVisibleDrawResult.Stages[Stage] := dsFail;
  if not FVisibleDrawResult.Error.Present then
  begin
    FVisibleDrawResult.FailureStage.HasValue := True;
    FVisibleDrawResult.FailureStage.Value := Stage;
  end;
end;

procedure TGraphicsDiagnosticSession.InvalidateTextureOnContextLoss;
begin
  if (FActionKind = gakVisibleDraw) and GetBusy then
  begin
    MarkInterruptedVisiblePhase;
    FVisibleDrawResult.Evidence.ContextLost.HasValue := True;
    FVisibleDrawResult.Evidence.ContextLost.Value := True;
  end;
  if (FActionKind = gakTextureLifecycle) and GetBusy then
  begin
    FTextureResult.Evidence.ContextLost.HasValue := True;
    FTextureResult.Evidence.ContextLost.Value := True;
  end;
  if FTextureTestId <> 0 then
  begin
    FTextureTestId := 0;
    if FActionKind = gakTextureLifecycle then
    begin
      FTextureResult.Evidence.CleanupBlockedByContext.HasValue := True;
      FTextureResult.Evidence.CleanupBlockedByContext.Value := True;
    end;
  end;
  if FVisibleTextureId <> 0 then
  begin
    FVisibleTextureId := 0;
    if FActionKind = gakVisibleDraw then
    begin
      FVisibleDrawResult.Evidence.CleanupBlockedByContext.HasValue := True;
      FVisibleDrawResult.Evidence.CleanupBlockedByContext.Value := True;
    end;
  end;
  FVisiblePhase := vdpNotStarted;
  FVisiblePhaseStarted := False;
  FVisibleFramesCompletedInPhase := 0;
end;

procedure TGraphicsDiagnosticSession.SetReadinessSnapshot;
begin
  FReadinessResult.Evidence.ContextAvailable.HasValue := True;
  FReadinessResult.Evidence.ContextAvailable.Value := FContextReportedAvailable;
  FReadinessResult.Evidence.RendererContextSynced.HasValue := True;
  FReadinessResult.Evidence.RendererContextSynced.Value := FRendererContextSynced;
  FReadinessResult.Evidence.PhysicalSizeKnown.HasValue := True;
  FReadinessResult.Evidence.PhysicalSizeKnown.Value := FPhysicalSizeKnown;
  if FPhysicalSizeKnown then
  begin
    FReadinessResult.Evidence.PhysicalWidth.HasValue := True;
    FReadinessResult.Evidence.PhysicalWidth.Value := FPhysicalWidth;
    FReadinessResult.Evidence.PhysicalHeight.HasValue := True;
    FReadinessResult.Evidence.PhysicalHeight.Value := FPhysicalHeight;
  end;
end;

procedure TGraphicsDiagnosticSession.FinalizeAction;
var
  CompletedKind: TGraphicsDiagnosticActionKind;
  ReadinessValue: TGraphicsReadinessDiagnosticResult;
  TextureValue: TGraphicsTextureDiagnosticResult;
  VisibleDrawValue: TGraphicsVisibleDrawDiagnosticResult;
begin
  if (FExecutionState = gesIdle) or (FActionKind = gakNone) then
    Exit;
  CompletedKind := FActionKind;
  case CompletedKind of
    gakReadiness:
      begin
        ReadinessValue := FReadinessResult;
        FReadinessResult := Default(TGraphicsReadinessDiagnosticResult);
      end;
    gakTextureLifecycle:
      begin
        TextureValue := FTextureResult;
        FTextureResult := Default(TGraphicsTextureDiagnosticResult);
      end;
    gakVisibleDraw:
      begin
        VisibleDrawValue := FVisibleDrawResult;
        FVisibleDrawResult := Default(TGraphicsVisibleDrawDiagnosticResult);
        FVisiblePhase := vdpNotStarted;
        FVisiblePhaseStarted := False;
        FVisibleFramesCompletedInPhase := 0;
        FVisibleTextureId := 0;
      end;
  end;
  FActionKind := gakNone;
  FExecutionState := gesIdle;
  try
    case CompletedKind of
      gakReadiness: ReplaceGraphicsReadinessDiagnosticResult(ReadinessValue);
      gakTextureLifecycle: ReplaceGraphicsTextureDiagnosticResult(TextureValue);
      gakVisibleDraw: ReplaceGraphicsVisibleDrawDiagnosticResult(VisibleDrawValue);
    end;
  except
    Exit;
  end;
  if not FClosing and Assigned(FOnResultPublished) then
    try
      FOnResultPublished(Self);
    except
    end;
end;

procedure TGraphicsDiagnosticSession.ObserveVisibleDraw;
var
  Pixels: array[0..15] of Byte;
  V1, V2, V3: array[0..5] of TKMSampledVertex;
  W, H: Single;
  AttemptedStage: TGraphicsVisibleDrawDiagnosticStageId;
  ErrorValue: TDiagnosticError;
  Ready: Boolean;
  AllStagesPass: Boolean;

  procedure SetPrimaryError(const AClassName, AMessage: string;
    const AHasStage: Boolean);
  begin
    if FVisibleDrawResult.Error.Present then
      Exit;
    ErrorValue := Default(TDiagnosticError);
    ErrorValue.Present := True;
    if AClassName <> '' then
    begin
      ErrorValue.ClassName.HasValue := True;
      ErrorValue.ClassName.Value := AClassName;
    end;
    ErrorValue.MessageText.HasValue := True;
    ErrorValue.MessageText.Value := AMessage;
    FVisibleDrawResult.Status := dsFail;
    FVisibleDrawResult.Error := ErrorValue;
    if AHasStage then
    begin
      FVisibleDrawResult.FailureStage.HasValue := True;
      FVisibleDrawResult.FailureStage.Value := AttemptedStage;
    end;
  end;

  procedure DrawRect(var AVertices: array of TKMSampledVertex;
    const X0, X1: Single; const AColor: TKMColor4f);
  begin
    AVertices[0] := Default(TKMSampledVertex);
    AVertices[0].X := X0; AVertices[0].Y := 0.30 * H; AVertices[0].U := 0; AVertices[0].V := 0;
    AVertices[1] := Default(TKMSampledVertex);
    AVertices[1].X := X1; AVertices[1].Y := 0.30 * H; AVertices[1].U := 1; AVertices[1].V := 0;
    AVertices[2] := Default(TKMSampledVertex);
    AVertices[2].X := X0; AVertices[2].Y := 0.70 * H; AVertices[2].U := 0; AVertices[2].V := 1;
    AVertices[3] := AVertices[1];
    AVertices[4] := Default(TKMSampledVertex);
    AVertices[4].X := X1; AVertices[4].Y := 0.70 * H; AVertices[4].U := 1; AVertices[4].V := 1;
    AVertices[5] := AVertices[2];
    TKMRender.DrawSampledTriangles(AVertices, AColor);
  end;

  procedure DrawTriple;
  begin
    W := FRenderer.ScreenX;
    H := FRenderer.ScreenY;
    FRenderer.BeginFrame;
    TKMRender.BindTexture(FVisibleTextureId);
    DrawRect(V1, 0.08 * W, 0.32 * W, TKMColor4f.New(1, 1, 1, 1));
    DrawRect(V2, 0.38 * W, 0.62 * W, TKMColor4f.New(1, 0.45, 0.45, 1));
    DrawRect(V3, 0.68 * W, 0.92 * W, TKMColor4f.New(0.5, 0.8, 1, 0.65));
  end;

  procedure CleanupVisibleTexture;
  var
    CleanupError: TDiagnosticError;
  begin
    if FVisibleTextureId = 0 then
      Exit;
    Ready := (FRenderer <> nil) and FContextReportedAvailable and
      FRendererContextSynced;
    if Ready then
      try
        Ready := TKMRender.TextureBackendReady;
      except
        on E: Exception do
        begin
          Ready := False;
          if FVisibleDrawResult.Error.Present then
          begin
            CleanupError := Default(TDiagnosticError);
            CleanupError.Present := True;
            CleanupError.ClassName.HasValue := True;
            CleanupError.ClassName.Value := E.ClassName;
            CleanupError.MessageText.HasValue := True;
            CleanupError.MessageText.Value := E.Message;
            FVisibleDrawResult.Evidence.SecondaryCleanupError := CleanupError;
          end
          else
            SetPrimaryError(E.ClassName, E.Message, False);
        end;
      end;
    if not Ready then
    begin
      FVisibleDrawResult.Evidence.CleanupBlockedByContext.HasValue := True;
      FVisibleDrawResult.Evidence.CleanupBlockedByContext.Value := True;
      if not FVisibleDrawResult.Error.Present then
        SetPrimaryError('', 'Visible texture cleanup is unavailable', False);
      Exit;
    end;
    FVisibleDrawResult.Evidence.DeleteAttempted.HasValue := True;
    FVisibleDrawResult.Evidence.DeleteAttempted.Value := True;
    try
      TKMRender.DeleteTexture(FVisibleTextureId);
      FVisibleDrawResult.Stages[gvsiTextureDelete] := dsPass;
      FVisibleDrawResult.Evidence.DeleteCompleted.HasValue := True;
      FVisibleDrawResult.Evidence.DeleteCompleted.Value := True;
      FVisibleTextureId := 0;
      FVisiblePhase := vdpNotStarted;
      FVisiblePhaseStarted := False;
      FVisibleFramesCompletedInPhase := 0;
      FVisibleDrawResult.Stages[gvsiResourceCleanup] := dsPass;
      FVisibleDrawResult.Evidence.CleanupCompleted.HasValue := True;
      FVisibleDrawResult.Evidence.CleanupCompleted.Value := True;
    except
      on E: Exception do
      begin
      FVisibleDrawResult.Stages[gvsiTextureDelete] := dsFail;
      FVisibleDrawResult.Stages[gvsiResourceCleanup] := dsFail;
      FVisibleDrawResult.Evidence.DeleteCompleted.HasValue := True;
      FVisibleDrawResult.Evidence.DeleteCompleted.Value := False;
        AttemptedStage := gvsiTextureDelete;
        if FVisibleDrawResult.Error.Present then
        begin
          CleanupError := Default(TDiagnosticError);
          CleanupError.Present := True;
          CleanupError.ClassName.HasValue := True;
          CleanupError.ClassName.Value := E.ClassName;
          CleanupError.MessageText.HasValue := True;
          CleanupError.MessageText.Value := E.Message;
          FVisibleDrawResult.Evidence.SecondaryCleanupError := CleanupError;
        end
        else
          SetPrimaryError(E.ClassName, E.Message, True);
      end;
    end;
  end;

  procedure FailCurrentStage(const AClassName, AMessage: string);
  begin
    if FVisibleTextureId = 0 then
      AttemptedStage := gvsiPreparation
    else if FVisiblePhase = vdpBrightness then
      AttemptedStage := gvsiBrightnessPhase
    else
      AttemptedStage := gvsiSampledRgbaPhase;
    FVisibleDrawResult.Stages[AttemptedStage] := dsFail;
    SetPrimaryError(AClassName, AMessage, True);
    if FVisibleTextureId <> 0 then
      CleanupVisibleTexture;
    FinalizeAction;
  end;

  function CheckVisiblePreflight: Boolean;
  begin
    if not ((FRenderer <> nil) and FPresentationAttached and FLifecycleAttached and
        FContextReportedAvailable and FRendererContextSynced and not FClosing and
        FPhysicalSizeKnown and (FPhysicalWidth > 0) and (FPhysicalHeight > 0)) then
    begin
      if FVisibleTextureId <> 0 then
      begin
        FailCurrentStage('', 'Visible draw preflight is unavailable');
        Exit(False);
      end;
      AttemptedStage := gvsiPreparation;
      FVisibleDrawResult.Stages[gvsiPreparation] := dsFail;
      SetPrimaryError('', 'Visible draw preflight is unavailable', True);
      FinalizeAction;
      Exit(False);
    end;
    try
      Ready := TKMRender.TextureBackendReady and TKMRender.SampledProgramReady;
    except
      on E: Exception do
      begin
        FailCurrentStage(E.ClassName, E.Message);
        Exit(False);
      end;
    end;
    if not Ready then
    begin
      FailCurrentStage('', 'Visible draw texture or sampled program is not ready');
      Exit(False);
    end;
    Result := True;
  end;

  function PrepareVisibleTexture: Boolean;
  begin
    if FVisiblePhase = vdpNotStarted then
    begin
      if FVisibleTextureId <> 0 then
      begin
        AttemptedStage := gvsiPreparation;
        FVisibleDrawResult.Stages[gvsiPreparation] := dsFail;
        SetPrimaryError('', 'Visible draw texture state is inconsistent', True);
        FinalizeAction;
        Exit(False);
      end;
      Pixels[0] := 255; Pixels[1] := 215; Pixels[2] := 175; Pixels[3] := 255;
      Pixels[4] := 175; Pixels[5] := 255; Pixels[6] := 215; Pixels[7] := 255;
      Pixels[8] := 205; Pixels[9] := 205; Pixels[10] := 255; Pixels[11] := 255;
      Pixels[12] := 255; Pixels[13] := 255; Pixels[14] := 255; Pixels[15] := 255;
      try
        FVisibleTextureId := TKMRender.GenTexture(2, 2, @Pixels[0],
          tfRGBA8, ftNearest, ftNearest);
      except
        on E: Exception do
        begin
          AttemptedStage := gvsiPreparation;
          FVisibleDrawResult.Stages[gvsiPreparation] := dsFail;
          SetPrimaryError(E.ClassName, E.Message, True);
          FinalizeAction;
          Exit(False);
        end;
      end;
      FVisibleDrawResult.Evidence.TextureCreated.HasValue := True;
      FVisibleDrawResult.Evidence.TextureCreated.Value := FVisibleTextureId <> 0;
      FVisibleDrawResult.Evidence.NonZeroTextureId.HasValue := True;
      FVisibleDrawResult.Evidence.NonZeroTextureId.Value := FVisibleTextureId <> 0;
      FVisibleDrawResult.Evidence.TextureWidth.HasValue := True;
      FVisibleDrawResult.Evidence.TextureWidth.Value := 2;
      FVisibleDrawResult.Evidence.TextureHeight.HasValue := True;
      FVisibleDrawResult.Evidence.TextureHeight.Value := 2;
      FVisibleDrawResult.Evidence.TextureFormat.HasValue := True;
      FVisibleDrawResult.Evidence.TextureFormat.Value := 'tfRGBA8';
      FVisibleDrawResult.Evidence.MinFilter.HasValue := True;
      FVisibleDrawResult.Evidence.MinFilter.Value := 'ftNearest';
      FVisibleDrawResult.Evidence.MagFilter.HasValue := True;
      FVisibleDrawResult.Evidence.MagFilter.Value := 'ftNearest';
      if FVisibleTextureId = 0 then
      begin
        AttemptedStage := gvsiPreparation;
        FVisibleDrawResult.Stages[gvsiPreparation] := dsFail;
        SetPrimaryError('', 'GenTexture returned texture ID 0', True);
        FinalizeAction;
        Exit(False);
      end;
      FVisibleDrawResult.Stages[gvsiPreparation] := dsPass;
      FVisiblePhase := vdpBase;
      FVisiblePhaseStarted := False;
      FVisibleFramesCompletedInPhase := 0;
    end;
    Result := True;
  end;

  function DrawVisibleFrame: Boolean;
  begin
    if FVisiblePhase = vdpBase then
      AttemptedStage := gvsiSampledRgbaPhase
    else
      AttemptedStage := gvsiBrightnessPhase;
    try
      FVisiblePhaseStarted := True;
      DrawTriple;
      if FVisiblePhase = vdpBrightness then
      begin
        FVisibleDrawResult.Evidence.BrightnessTripleRgbaDrawsCompleted.HasValue := True;
        FVisibleDrawResult.Evidence.BrightnessTripleRgbaDrawsCompleted.Value := True;
        FRenderer.RenderBrightness(5);
        FVisibleDrawResult.Evidence.BrightnessOverlayAppliedAfterDraws.HasValue := True;
        FVisibleDrawResult.Evidence.BrightnessOverlayAppliedAfterDraws.Value := True;
        FVisibleDrawResult.Evidence.BrightnessAmount.HasValue := True;
        FVisibleDrawResult.Evidence.BrightnessAmount.Value := 5;
      end
      else
      begin
        FVisibleDrawResult.Evidence.BaseTripleRgbaDrawsCompleted.HasValue := True;
        FVisibleDrawResult.Evidence.BaseTripleRgbaDrawsCompleted.Value := True;
      end;
    except
      on E: Exception do
      begin
        FVisibleDrawResult.Stages[AttemptedStage] := dsFail;
        if AttemptedStage = gvsiSampledRgbaPhase then
        begin
          if not FVisibleDrawResult.Evidence.BaseTripleRgbaDrawsCompleted.HasValue then
          begin
            FVisibleDrawResult.Evidence.BaseTripleRgbaDrawsCompleted.HasValue := True;
            FVisibleDrawResult.Evidence.BaseTripleRgbaDrawsCompleted.Value := False;
          end;
        end
        else if FVisibleDrawResult.Evidence.BrightnessTripleRgbaDrawsCompleted.HasValue = False then
        begin
          FVisibleDrawResult.Evidence.BrightnessTripleRgbaDrawsCompleted.HasValue := True;
          FVisibleDrawResult.Evidence.BrightnessTripleRgbaDrawsCompleted.Value := False;
        end;
        SetPrimaryError(E.ClassName, E.Message, True);
        CleanupVisibleTexture;
        FinalizeAction;
        Exit(False);
      end;
    end;
    Result := True;
  end;

  procedure AdvanceVisiblePhase;
  var
    Stage: TGraphicsVisibleDrawDiagnosticStageId;
  begin
    Inc(FVisibleFramesCompletedInPhase);
    if FVisiblePhase = vdpBase then
    begin
      FVisibleDrawResult.Evidence.BaseFramesCompleted.HasValue := True;
      FVisibleDrawResult.Evidence.BaseFramesCompleted.Value := FVisibleFramesCompletedInPhase;
      if FVisibleFramesCompletedInPhase = 60 then
      begin
        FVisibleDrawResult.Stages[gvsiSampledRgbaPhase] := dsPass;
        FVisiblePhase := vdpBrightness;
        FVisiblePhaseStarted := False;
        FVisibleFramesCompletedInPhase := 0;
      end;
    end
    else
    begin
      FVisibleDrawResult.Evidence.BrightnessFramesCompleted.HasValue := True;
      FVisibleDrawResult.Evidence.BrightnessFramesCompleted.Value := FVisibleFramesCompletedInPhase;
      if FVisibleFramesCompletedInPhase = 60 then
      begin
        FVisibleDrawResult.Stages[gvsiBrightnessPhase] := dsPass;
        CleanupVisibleTexture;
        AllStagesPass := True;
        for Stage := Low(TGraphicsVisibleDrawDiagnosticStageId) to
          High(TGraphicsVisibleDrawDiagnosticStageId) do
          if FVisibleDrawResult.Stages[Stage] <> dsPass then
            AllStagesPass := False;
        if FVisibleDrawResult.Error.Present or
           FVisibleDrawResult.Evidence.SecondaryCleanupError.Present or
           not AllStagesPass then
          FVisibleDrawResult.Status := dsFail
        else
          FVisibleDrawResult.Status := dsPass;
        FinalizeAction;
      end;
    end;
  end;

begin
  if not CheckVisiblePreflight then Exit;
  if not PrepareVisibleTexture then Exit;
  if not DrawVisibleFrame then Exit;
  AdvanceVisiblePhase;
end;

procedure TGraphicsDiagnosticSession.ObserveReadiness;
var
  AttemptedStage: TGraphicsReadinessDiagnosticStageId;
  Attempted: Boolean;
  BackendReady: Boolean;
  RendererWidth, RendererHeight: Word;
  MaxTextureSize: Cardinal;
  FirstFailure: TOptionalGraphicsReadinessDiagnosticStageId;
  FirstFailureMessage, ExceptionClass, ExceptionMessage: string;
  HasException: Boolean;
begin
  SetReadinessSnapshot;
  FirstFailure := Default(TOptionalGraphicsReadinessDiagnosticStageId);
  FirstFailureMessage := '';
  HasException := False;
  Attempted := False;
  try
    AttemptedStage := grsiContextReady;
    Attempted := True;
    if FContextReportedAvailable and FRendererContextSynced then
      FReadinessResult.Stages[grsiContextReady] := dsPass
    else
    begin
      FReadinessResult.Stages[grsiContextReady] := dsFail;
      FirstFailure.HasValue := True;
      FirstFailure.Value := grsiContextReady;
      if not FContextReportedAvailable then
        FirstFailureMessage := 'Graphics context is unavailable'
      else
        FirstFailureMessage := 'Graphics renderer context is not synchronized';
    end;

    AttemptedStage := grsiPhysicalSurface;
    if FPhysicalSizeKnown and (FPhysicalWidth > 0) and (FPhysicalHeight > 0) then
      FReadinessResult.Stages[grsiPhysicalSurface] := dsPass
    else
    begin
      FReadinessResult.Stages[grsiPhysicalSurface] := dsFail;
      if not FirstFailure.HasValue then
      begin
        FirstFailure.HasValue := True;
        FirstFailure.Value := grsiPhysicalSurface;
        if not FPhysicalSizeKnown then
          FirstFailureMessage := 'Physical surface dimensions are unknown'
        else
          FirstFailureMessage := 'Physical surface dimensions must be positive';
      end;
    end;

    AttemptedStage := grsiRendererSizeMatch;
    Attempted := True;
    RendererWidth := FRenderer.ScreenX;
    FReadinessResult.Evidence.RendererWidth.Value := RendererWidth;
    FReadinessResult.Evidence.RendererWidth.HasValue := True;
    RendererHeight := FRenderer.ScreenY;
    FReadinessResult.Evidence.RendererHeight.Value := RendererHeight;
    FReadinessResult.Evidence.RendererHeight.HasValue := True;
    if FPhysicalSizeKnown then
    begin
      if (RendererWidth = FPhysicalWidth) and
         (RendererHeight = FPhysicalHeight) then
        FReadinessResult.Stages[grsiRendererSizeMatch] := dsPass
      else
      begin
        FReadinessResult.Stages[grsiRendererSizeMatch] := dsFail;
        if not FirstFailure.HasValue then
        begin
          FirstFailure.HasValue := True;
          FirstFailure.Value := grsiRendererSizeMatch;
          FirstFailureMessage := 'Renderer size does not match the physical surface';
        end;
      end;
    end;

    AttemptedStage := grsiTextureBackend;
    Attempted := True;
    BackendReady := TKMRender.TextureBackendReady;
    FReadinessResult.Evidence.TextureBackendReady.Value := BackendReady;
    FReadinessResult.Evidence.TextureBackendReady.HasValue := True;
    if BackendReady then
      FReadinessResult.Stages[grsiTextureBackend] := dsPass
    else
    begin
      FReadinessResult.Stages[grsiTextureBackend] := dsFail;
      if not FirstFailure.HasValue then
      begin
        FirstFailure.HasValue := True;
        FirstFailure.Value := grsiTextureBackend;
        FirstFailureMessage := 'Texture backend is not ready';
      end;
    end;

    AttemptedStage := grsiSampledProgram;
    Attempted := True;
    FReadinessResult.Evidence.SampledProgramReady.Value := TKMRender.SampledProgramReady;
    FReadinessResult.Evidence.SampledProgramReady.HasValue := True;
    if FReadinessResult.Evidence.SampledProgramReady.Value then
      FReadinessResult.Stages[grsiSampledProgram] := dsPass
    else
    begin
      FReadinessResult.Stages[grsiSampledProgram] := dsFail;
      if not FirstFailure.HasValue then
      begin
        FirstFailure.HasValue := True;
        FirstFailure.Value := grsiSampledProgram;
        FirstFailureMessage := 'Sampled program is not ready';
      end;
    end;

    if BackendReady then
    begin
      AttemptedStage := grsiMaxTextureSize;
      Attempted := True;
      MaxTextureSize := TKMRender.MaxTextureSize;
      FReadinessResult.Evidence.MaxTextureSize.Value := MaxTextureSize;
      FReadinessResult.Evidence.MaxTextureSize.HasValue := True;
      if FReadinessResult.Evidence.MaxTextureSize.Value > 0 then
        FReadinessResult.Stages[grsiMaxTextureSize] := dsPass
      else
      begin
        FReadinessResult.Stages[grsiMaxTextureSize] := dsFail;
        if not FirstFailure.HasValue then
        begin
          FirstFailure.HasValue := True;
          FirstFailure.Value := grsiMaxTextureSize;
          FirstFailureMessage := 'Maximum texture size is zero';
        end;
      end;
    end;
  except
    on E: Exception do
    begin
      HasException := True;
      ExceptionClass := E.ClassName;
      ExceptionMessage := E.Message;
      if Attempted then
      begin
        FReadinessResult.Stages[AttemptedStage] := dsFail;
        FReadinessResult.FailureStage.HasValue := True;
        FReadinessResult.FailureStage.Value := AttemptedStage;
      end;
    end;
  end;

  if HasException then
  begin
    FReadinessResult.Status := dsFail;
    SetActionError(ExceptionClass, ExceptionMessage);
    FReadinessResult.FailureStage.HasValue := True;
    FReadinessResult.FailureStage.Value := AttemptedStage;
  end
  else if not FirstFailure.HasValue then
    FReadinessResult.Status := dsPass
  else
  begin
    FReadinessResult.Status := dsFail;
    FReadinessResult.FailureStage := FirstFailure;
    SetActionError('', FirstFailureMessage);
  end;
  FinalizeAction;
end;

procedure TGraphicsDiagnosticSession.ObserveTextureLifecycle;
var
  InitialPixels, ReplacementPixels: array[0..15] of Byte;
  Stage: TGraphicsTextureDiagnosticStageId;
  Ready, ReadinessError: Boolean;
  ErrorValue: TDiagnosticError;

  procedure RecordFailure(const AHasStage: Boolean;
    const AStage: TGraphicsTextureDiagnosticStageId;
    const AClassName, AMessage: string; const ASecondary: Boolean = False);
  begin
    ErrorValue := Default(TDiagnosticError);
    ErrorValue.Present := True;
    if AClassName <> '' then
    begin
      ErrorValue.ClassName.HasValue := True;
      ErrorValue.ClassName.Value := AClassName;
    end;
    ErrorValue.MessageText.HasValue := True;
    ErrorValue.MessageText.Value := AMessage;
    if ASecondary then
      FTextureResult.Evidence.SecondaryCleanupError := ErrorValue
    else if FTextureResult.Status <> dsFail then
    begin
      FTextureResult.Status := dsFail;
      FTextureResult.Error := ErrorValue;
      if AHasStage then
      begin
        FTextureResult.FailureStage.HasValue := True;
        FTextureResult.FailureStage.Value := AStage;
      end;
    end;
  end;

  function GpuReady(const ACleanup: Boolean = False): Boolean;
  begin
    ReadinessError := False;
    Result := (FRenderer <> nil) and FContextReportedAvailable and
      FRendererContextSynced;
    if Result then
      try
        Result := TKMRender.TextureBackendReady;
      except
        on E: Exception do
        begin
          ReadinessError := True;
          RecordFailure(False, gtsiInitialCreate, E.ClassName, E.Message,
            ACleanup and (FTextureResult.Status = dsFail));
          Result := False;
        end;
      end;
  end;

  procedure NeedGpuForStage(const AStage: TGraphicsTextureDiagnosticStageId);
  begin
    if FExecutionState = gesIdle then
      Exit;
    if not GpuReady then
    begin
      if (FTextureResult.Status <> dsFail) then
      begin
        RecordFailure(False, AStage, '', 'Texture operation is unavailable');
      end;
    end;
  end;

  procedure PrepareTexturePixels;
  begin
    FillChar(InitialPixels, SizeOf(InitialPixels), 0);
    FillChar(ReplacementPixels, SizeOf(ReplacementPixels), 0);
    InitialPixels[0] := 255; InitialPixels[3] := 255;
    InitialPixels[5] := 255; InitialPixels[7] := 255;
    InitialPixels[10] := 255; InitialPixels[11] := 255;
    InitialPixels[12] := 255; InitialPixels[13] := 255;
    InitialPixels[14] := 255; InitialPixels[15] := 255;
    ReplacementPixels[1] := 255; ReplacementPixels[2] := 255;
    ReplacementPixels[3] := 255; ReplacementPixels[4] := 255;
    ReplacementPixels[6] := 255; ReplacementPixels[7] := 255;
    ReplacementPixels[8] := 255; ReplacementPixels[9] := 255;
    ReplacementPixels[11] := 255; ReplacementPixels[15] := 255;
  end;

  function CreateTestTexture: Boolean;
  begin
    FTextureResult.Evidence.InitialWidth.HasValue := True;
    FTextureResult.Evidence.InitialWidth.Value := 2;
    FTextureResult.Evidence.InitialHeight.HasValue := True;
    FTextureResult.Evidence.InitialHeight.Value := 2;
    FTextureResult.Evidence.InitialFormat.HasValue := True;
    FTextureResult.Evidence.InitialFormat.Value := 'tfRGBA8';
    FTextureResult.Evidence.MinFilter.HasValue := True;
    FTextureResult.Evidence.MinFilter.Value := 'ftNearest';
    FTextureResult.Evidence.MagFilter.HasValue := True;
    FTextureResult.Evidence.MagFilter.Value := 'ftNearest';
    try
      FTextureTestId := TKMRender.GenTexture(2, 2, @InitialPixels[0],
        tfRGBA8, ftNearest, ftNearest);
      FTextureResult.Stages[gtsiInitialCreate] := dsPass;
      FTextureResult.Evidence.GenTextureCompleted.HasValue := True;
      FTextureResult.Evidence.GenTextureCompleted.Value := True;
    except
      on E: Exception do
      begin
        FTextureTestId := 0;
        FTextureResult.Stages[gtsiInitialCreate] := dsFail;
        FTextureResult.Evidence.GenTextureCompleted.HasValue := True;
        FTextureResult.Evidence.GenTextureCompleted.Value := False;
        RecordFailure(True, gtsiInitialCreate, E.ClassName, E.Message);
        FinalizeAction;
        Exit(False);
      end;
    end;
  
    FTextureResult.Evidence.NonZeroTextureId.HasValue := True;
    FTextureResult.Evidence.NonZeroTextureId.Value := FTextureTestId <> 0;
    if FTextureTestId <> 0 then
      FTextureResult.Stages[gtsiNonZeroTextureId] := dsPass
    else
    begin
      FTextureResult.Stages[gtsiNonZeroTextureId] := dsFail;
      RecordFailure(True, gtsiNonZeroTextureId, '', 'GenTexture returned texture ID 0');
    end;
    Result := True;
  end;

  procedure ExerciseTestTexture;
  begin
    if FTextureTestId <> 0 then
    begin
      NeedGpuForStage(gtsiFirstBind);
      if GetBusy and (FTextureResult.Status <> dsFail) then
        try
          TKMRender.BindTexture(FTextureTestId);
          FTextureResult.Stages[gtsiFirstBind] := dsPass;
          FTextureResult.Evidence.FirstBindCompleted.HasValue := True;
          FTextureResult.Evidence.FirstBindCompleted.Value := True;
        except
          on E: Exception do
          begin
            FTextureResult.Stages[gtsiFirstBind] := dsFail;
            FTextureResult.Evidence.FirstBindCompleted.HasValue := True;
            FTextureResult.Evidence.FirstBindCompleted.Value := False;
            RecordFailure(True, gtsiFirstBind, E.ClassName, E.Message);
          end;
        end;
  
      if GetBusy and (FTextureResult.Status <> dsFail) then
      begin
        NeedGpuForStage(gtsiReplacementUpdate);
        if GetBusy and (FTextureResult.Status <> dsFail) then
        begin
          FTextureResult.Evidence.ReplacementWidth.HasValue := True;
          FTextureResult.Evidence.ReplacementWidth.Value := 2;
          FTextureResult.Evidence.ReplacementHeight.HasValue := True;
          FTextureResult.Evidence.ReplacementHeight.Value := 2;
          FTextureResult.Evidence.ReplacementFormat.HasValue := True;
          FTextureResult.Evidence.ReplacementFormat.Value := 'tfRGBA8';
          try
            TKMRender.UpdateTexture(FTextureTestId, 2, 2, tfRGBA8,
              @ReplacementPixels[0]);
            FTextureResult.Stages[gtsiReplacementUpdate] := dsPass;
            FTextureResult.Evidence.ReplacementUpdateCompleted.HasValue := True;
            FTextureResult.Evidence.ReplacementUpdateCompleted.Value := True;
          except
            on E: Exception do
            begin
              FTextureResult.Stages[gtsiReplacementUpdate] := dsFail;
              FTextureResult.Evidence.ReplacementUpdateCompleted.HasValue := True;
              FTextureResult.Evidence.ReplacementUpdateCompleted.Value := False;
              RecordFailure(True, gtsiReplacementUpdate, E.ClassName, E.Message);
            end;
          end;
        end;
      end;
  
      if GetBusy and (FTextureResult.Status <> dsFail) then
      begin
        NeedGpuForStage(gtsiSecondBind);
        if GetBusy and (FTextureResult.Status <> dsFail) then
          try
            TKMRender.BindTexture(FTextureTestId);
            FTextureResult.Stages[gtsiSecondBind] := dsPass;
            FTextureResult.Evidence.SecondBindCompleted.HasValue := True;
            FTextureResult.Evidence.SecondBindCompleted.Value := True;
          except
            on E: Exception do
            begin
              FTextureResult.Stages[gtsiSecondBind] := dsFail;
              FTextureResult.Evidence.SecondBindCompleted.HasValue := True;
              FTextureResult.Evidence.SecondBindCompleted.Value := False;
              RecordFailure(True, gtsiSecondBind, E.ClassName, E.Message);
            end;
          end;
      end;
    end;
  end;

  procedure CleanupTestTexture;
  begin
    if not GetBusy then
      Exit;
    if FTextureTestId <> 0 then
    begin
      Ready := GpuReady(True);
      if Ready then
      begin
        FTextureResult.Evidence.DeleteAttempted.HasValue := True;
        FTextureResult.Evidence.DeleteAttempted.Value := True;
        try
          TKMRender.DeleteTexture(FTextureTestId);
          FTextureResult.Stages[gtsiTextureDelete] := dsPass;
          FTextureResult.Evidence.DeleteCompleted.HasValue := True;
          FTextureResult.Evidence.DeleteCompleted.Value := True;
          FTextureTestId := 0;
          FTextureResult.Stages[gtsiResourceCleanup] := dsPass;
          FTextureResult.Evidence.CleanupCompleted.HasValue := True;
          FTextureResult.Evidence.CleanupCompleted.Value := True;
        except
          on E: Exception do
          begin
            FTextureResult.Stages[gtsiTextureDelete] := dsFail;
            FTextureResult.Stages[gtsiResourceCleanup] := dsFail;
            FTextureResult.Evidence.DeleteCompleted.HasValue := True;
            FTextureResult.Evidence.DeleteCompleted.Value := False;
            if FTextureResult.Status = dsFail then
              RecordFailure(False, gtsiTextureDelete, E.ClassName, E.Message, True)
            else
              RecordFailure(True, gtsiTextureDelete, E.ClassName, E.Message);
            FTextureTestId := 0;
          end;
        end;
      end
      else if FExecutionState <> gesIdle then
      begin
        if not ReadinessError then
          if FTextureResult.Status = dsFail then
            RecordFailure(False, gtsiTextureDelete, '',
              'Texture deletion is unavailable', True)
          else
            RecordFailure(False, gtsiTextureDelete, '',
              'Texture deletion is unavailable');
        FTextureTestId := 0;
      end;
    end;
  end;

begin
  PrepareTexturePixels;
  if not GpuReady then
  begin
    if FTextureResult.Status <> dsFail then
      RecordFailure(False, gtsiInitialCreate, '', 'Texture backend is not ready');
    FinalizeAction;
    Exit;
  end;

  if not CreateTestTexture then Exit;
  ExerciseTestTexture;
  CleanupTestTexture;
  if not GetBusy then
    Exit;
  if FTextureResult.Status <> dsFail then
  begin
    FTextureResult.Status := dsPass;
    for Stage := Low(TGraphicsTextureDiagnosticStageId) to
      High(TGraphicsTextureDiagnosticStageId) do
      if FTextureResult.Stages[Stage] <> dsPass then
        FTextureResult.Status := dsFail;
  end;
  FinalizeAction;
end;

procedure TGraphicsDiagnosticSession.DispatchFrame;
begin
  if (FExecutionState = gesIdle) and (FActionKind = gakNone) then
    Exit;
  if FContextTransitionErrorPresent or not FContextReportedAvailable or
     not FRendererContextSynced then
  begin
    if FActionKind = gakReadiness then
      SetReadinessSnapshot;
    if FActionKind = gakVisibleDraw then
    begin
      if FVisibleTextureId <> 0 then
      begin
        MarkInterruptedVisiblePhase;
        if not FContextReportedAvailable then
          InvalidateTextureOnContextLoss
        else
        begin
          FVisibleDrawResult.Evidence.CleanupBlockedByContext.HasValue := True;
          FVisibleDrawResult.Evidence.CleanupBlockedByContext.Value := True;
          FVisibleTextureId := 0;
          FVisiblePhase := vdpNotStarted;
          FVisiblePhaseStarted := False;
          FVisibleFramesCompletedInPhase := 0;
        end;
      end;
      if not FVisibleDrawResult.Error.Present then
      begin
        if FContextTransitionErrorPresent then
          SetActionError(FContextTransitionErrorClass, FContextTransitionErrorMessage)
        else if not FContextReportedAvailable then
          SetActionError('', 'Graphics context is unavailable')
        else
          SetActionError('', 'Graphics renderer context is not synchronized');
      end;
    end
    else if FContextTransitionErrorPresent then
      SetActionError(FContextTransitionErrorClass, FContextTransitionErrorMessage)
    else if not FContextReportedAvailable then
      SetActionError('', 'Graphics context is unavailable')
    else
      SetActionError('', 'Graphics renderer context is not synchronized');
    FinalizeAction;
    Exit;
  end;
  if FExecutionState = gesPending then
    FExecutionState := gesActive;
  try
    case FActionKind of
      gakReadiness: ObserveReadiness;
      gakTextureLifecycle: ObserveTextureLifecycle;
      gakVisibleDraw: ObserveVisibleDraw;
    end;
  except
    on E: Exception do
      if GetBusy then
      begin
        SetActionError(E.ClassName, E.Message);
        FinalizeAction;
      end;
  end;
end;

procedure TGraphicsDiagnosticSession.EnsureAttached;
begin
  if FClosing then
    raise Exception.Create('Graphics diagnostic session is closing');
  if FPresentationAttached and FLifecycleAttached then
    Exit;

  try
    KMGameAppMobileAttachPresentation(@HandleFrame, @HandleResize);
    FPresentationAttached := True;
    FPhysicalWidth := FContainer.PixelsWidth;
    FPhysicalHeight := FContainer.PixelsHeight;
    FPhysicalSizeKnown := True;
    KMGameAppMobileAttach(@HandleContextAvailability);
    FLifecycleAttached := True;
    FRenderer := TKMRender.Create(FPhysicalWidth, FPhysicalHeight);
  except
    if FLifecycleAttached then
      try
        KMGameAppMobileDetach;
      except
      end;
    if FPresentationAttached then
      try
        KMGameAppMobileDetachPresentation;
      except
      end;
    if FContextReportedAvailable then
      try
        TKMRender.GraphicsContextChanged(False);
      except
      end;
    try
      FreeAndNil(FRenderer);
    except
    end;
    FPresentationAttached := False;
    FLifecycleAttached := False;
    FPhysicalWidth := 0;
    FPhysicalHeight := 0;
    FPhysicalSizeKnown := False;
    FContextReportedAvailable := False;
    FRendererContextSynced := False;
    FContextTransitionErrorPresent := False;
    FContextTransitionErrorClass := '';
    FContextTransitionErrorMessage := '';
    raise;
  end;
end;

procedure TGraphicsDiagnosticSession.HandleResize(aWidth, aHeight: Integer);
begin
  if FClosing then
    Exit;
  FPhysicalWidth := aWidth;
  FPhysicalHeight := aHeight;
  FPhysicalSizeKnown := True;
  if FRenderer <> nil then
    FRenderer.Resize(aWidth, aHeight);
end;

procedure TGraphicsDiagnosticSession.HandleContextAvailability(aAvailable: Boolean);
begin
  if FClosing then
    Exit;
  if aAvailable then
  begin
    FContextReportedAvailable := True;
    FRendererContextSynced := False;
    try
      TKMRender.GraphicsContextChanged(True);
      FRendererContextSynced := True;
      FContextTransitionErrorPresent := False;
      FContextTransitionErrorClass := '';
      FContextTransitionErrorMessage := '';
    except
      on E: Exception do
      begin
        FContextTransitionErrorPresent := True;
        FContextTransitionErrorClass := E.ClassName;
        FContextTransitionErrorMessage := E.Message;
        try
          TKMRender.GraphicsContextChanged(False);
        except
          on RollbackError: Exception do
            FContextTransitionErrorMessage := FContextTransitionErrorMessage + LineEnding +
              RollbackError.ClassName + ': ' + RollbackError.Message;
        end;
      end;
    end;
    if FContextTransitionErrorPresent and not FAttachInProgress and GetBusy then
    begin
      if FActionKind = gakReadiness then
        SetReadinessSnapshot;
      SetActionError(FContextTransitionErrorClass, FContextTransitionErrorMessage);
      FinalizeAction;
    end;
  end
  else
  begin
    InvalidateTextureOnContextLoss;
    FContextReportedAvailable := False;
    FRendererContextSynced := False;
    if not FAttachInProgress and GetBusy then
    begin
      if FActionKind = gakReadiness then
        SetReadinessSnapshot;
      if FActionKind = gakTextureLifecycle then
      begin
        FTextureResult.Status := dsFail;
        if not FTextureResult.Error.Present then
          SetActionError('', 'Graphics context became unavailable');
      end
      else if (FActionKind <> gakVisibleDraw) or
              not FVisibleDrawResult.Error.Present then
        SetActionError('', 'Graphics context became unavailable');
      FinalizeAction;
    end;
    try
      TKMRender.GraphicsContextChanged(False);
      FContextTransitionErrorPresent := False;
      FContextTransitionErrorClass := '';
      FContextTransitionErrorMessage := '';
    except
      on E: Exception do
      begin
        FContextTransitionErrorPresent := True;
        FContextTransitionErrorClass := E.ClassName;
        FContextTransitionErrorMessage := E.Message;
      end;
    end;
  end;
end;

procedure TGraphicsDiagnosticSession.HandleFrame;
begin
  if FClosing or not FPresentationAttached or not FLifecycleAttached or
     (FRenderer = nil) then
    Exit;
  DispatchFrame;
end;

destructor TGraphicsDiagnosticSession.Destroy;
begin
  FClosing := True;
  if FPresentationAttached then
  begin
    try
      KMGameAppMobileDetachPresentation;
    except
    end;
    FPresentationAttached := False;
  end;
  if FTextureTestId <> 0 then
  begin
    FTextureTestId := 0;
    if FActionKind = gakTextureLifecycle then
    begin
      FTextureResult.Evidence.CleanupBlockedByContext.HasValue := True;
      FTextureResult.Evidence.CleanupBlockedByContext.Value := True;
    end;
  end;
  if FVisibleTextureId <> 0 then
  begin
    MarkInterruptedVisiblePhase;
    FVisibleDrawResult.Evidence.CleanupBlockedByContext.HasValue := True;
    FVisibleDrawResult.Evidence.CleanupBlockedByContext.Value := True;
    FVisibleTextureId := 0;
  end;
  FVisiblePhase := vdpNotStarted;
  FVisiblePhaseStarted := False;
  FVisibleFramesCompletedInPhase := 0;
  if GetBusy then
  begin
    if FActionKind = gakReadiness then
      SetReadinessSnapshot;
    if FActionKind = gakVisibleDraw then
    begin
      if not FVisibleDrawResult.Error.Present then
        SetActionError('', 'Graphics diagnostic session was closed');
    end
    else if (FActionKind <> gakTextureLifecycle) or not FTextureResult.Error.Present then
      SetActionError('', 'Graphics diagnostic session was closed')
    else
      FTextureResult.Status := dsFail;
    FinalizeAction;
  end;
  if FLifecycleAttached then
  begin
    try
      KMGameAppMobileDetach;
    except
    end;
    FLifecycleAttached := False;
  end;
  if FRendererContextSynced then
    try
      TKMRender.GraphicsContextChanged(False);
    except
    end;
  try
    FreeAndNil(FRenderer);
  except
  end;
  FPhysicalWidth := 0;
  FPhysicalHeight := 0;
  FPhysicalSizeKnown := False;
  FContextReportedAvailable := False;
  FRendererContextSynced := False;
  FContextTransitionErrorPresent := False;
  FContextTransitionErrorClass := '';
  FContextTransitionErrorMessage := '';
  FContainer := nil;
  inherited Destroy;
end;

end.