From 29df541ea19f6dbc0fac1325e68886ba34002abb Mon Sep 17 00:00:00 2001 From: admin_d Date: Sat, 10 Oct 2026 01:02:27 +0500 Subject: [PATCH] Complete BigTask --- code/GameDiagnosticsGraphics_Mobile.pas | 1383 +++++++++++++++++++++++ code/GameDiagnosticsReport.pas | 498 ++++++-- code/GameDiagnosticsView.pas | 581 +++++++++- 3 files changed, 2344 insertions(+), 118 deletions(-) create mode 100644 code/GameDiagnosticsGraphics_Mobile.pas diff --git a/code/GameDiagnosticsGraphics_Mobile.pas b/code/GameDiagnosticsGraphics_Mobile.pas new file mode 100644 index 0000000..1e5653a --- /dev/null +++ b/code/GameDiagnosticsGraphics_Mobile.pas @@ -0,0 +1,1383 @@ +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); + + 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; + +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; + Stage: 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; + 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. diff --git a/code/GameDiagnosticsReport.pas b/code/GameDiagnosticsReport.pas index 84a1e64..75748c2 100644 --- a/code/GameDiagnosticsReport.pas +++ b/code/GameDiagnosticsReport.pas @@ -22,6 +22,20 @@ type trsiTileRecords ); + TGraphicsReadinessDiagnosticStageId = ( + grsiContextReady, grsiPhysicalSurface, grsiRendererSizeMatch, + grsiTextureBackend, grsiSampledProgram, grsiMaxTextureSize + ); + TGraphicsTextureDiagnosticStageId = ( + gtsiInitialCreate, gtsiNonZeroTextureId, gtsiFirstBind, + gtsiReplacementUpdate, gtsiSecondBind, gtsiTextureDelete, + gtsiResourceCleanup + ); + TGraphicsVisibleDrawDiagnosticStageId = ( + gvsiPreparation, gvsiSampledRgbaPhase, gvsiBrightnessPhase, + gvsiTextureDelete, gvsiResourceCleanup + ); + TOptionalString = record HasValue: Boolean; Value: string; @@ -47,6 +61,21 @@ type Value: TTerrainReadinessDiagnosticStageId; end; + TOptionalGraphicsReadinessDiagnosticStageId = record + HasValue: Boolean; + Value: TGraphicsReadinessDiagnosticStageId; + end; + + TOptionalGraphicsTextureDiagnosticStageId = record + HasValue: Boolean; + Value: TGraphicsTextureDiagnosticStageId; + end; + + TOptionalGraphicsVisibleDrawDiagnosticStageId = record + HasValue: Boolean; + Value: TGraphicsVisibleDrawDiagnosticStageId; + end; + TDiagnosticError = record Present: Boolean; ClassName: TOptionalString; @@ -92,6 +121,58 @@ type Evidence: TTerrainReadinessDiagnosticEvidence; end; + TGraphicsReadinessDiagnosticEvidence = record + ContextAvailable, RendererContextSynced, PhysicalSizeKnown, + TextureBackendReady, SampledProgramReady: TOptionalBoolean; + PhysicalWidth, PhysicalHeight, RendererWidth, RendererHeight, + MaxTextureSize: TOptionalInt64; + end; + + TGraphicsTextureDiagnosticEvidence = record + InitialWidth, InitialHeight, ReplacementWidth, ReplacementHeight: TOptionalInt64; + InitialFormat, ReplacementFormat, MinFilter, MagFilter: TOptionalString; + GenTextureCompleted, NonZeroTextureId, FirstBindCompleted, + ReplacementUpdateCompleted, SecondBindCompleted, DeleteAttempted, + DeleteCompleted, CleanupCompleted, ContextLost, + CleanupBlockedByContext: TOptionalBoolean; + SecondaryCleanupError: TDiagnosticError; + end; + + TGraphicsVisibleDrawDiagnosticEvidence = record + TextureWidth, TextureHeight, BaseFramesCompleted, + BrightnessFramesCompleted, BrightnessAmount: TOptionalInt64; + TextureFormat, MinFilter, MagFilter: TOptionalString; + TextureCreated, NonZeroTextureId, BaseTripleRgbaDrawsCompleted, + BrightnessTripleRgbaDrawsCompleted, BrightnessOverlayAppliedAfterDraws, + ContextLost, DeleteAttempted, DeleteCompleted, CleanupCompleted, + CleanupBlockedByContext: TOptionalBoolean; + SecondaryCleanupError: TDiagnosticError; + end; + + TGraphicsReadinessDiagnosticResult = record + Status: TDiagnosticStatus; + FailureStage: TOptionalGraphicsReadinessDiagnosticStageId; + Error: TDiagnosticError; + Stages: array[TGraphicsReadinessDiagnosticStageId] of TDiagnosticStatus; + Evidence: TGraphicsReadinessDiagnosticEvidence; + end; + + TGraphicsTextureDiagnosticResult = record + Status: TDiagnosticStatus; + FailureStage: TOptionalGraphicsTextureDiagnosticStageId; + Error: TDiagnosticError; + Stages: array[TGraphicsTextureDiagnosticStageId] of TDiagnosticStatus; + Evidence: TGraphicsTextureDiagnosticEvidence; + end; + + TGraphicsVisibleDrawDiagnosticResult = record + Status: TDiagnosticStatus; + FailureStage: TOptionalGraphicsVisibleDrawDiagnosticStageId; + Error: TDiagnosticError; + Stages: array[TGraphicsVisibleDrawDiagnosticStageId] of TDiagnosticStatus; + Evidence: TGraphicsVisibleDrawDiagnosticEvidence; + end; + TDiagnosticApplicationMetadata = record Name: string; PackageName: string; @@ -119,16 +200,31 @@ type OverallStatus: TDiagnosticStatus; FileIO: TFileIODiagnosticResult; TerrainReadiness: TTerrainReadinessDiagnosticResult; + GraphicsReadiness: TGraphicsReadinessDiagnosticResult; + GraphicsTexture: TGraphicsTextureDiagnosticResult; + GraphicsVisibleDraw: TGraphicsVisibleDrawDiagnosticResult; end; function CurrentDiagnosticReport: TDiagnosticReportState; procedure ReplaceFileIODiagnosticResult(const AResult: TFileIODiagnosticResult); procedure ReplaceTerrainReadinessDiagnosticResult( const AResult: TTerrainReadinessDiagnosticResult); +procedure ReplaceGraphicsReadinessDiagnosticResult( + const AResult: TGraphicsReadinessDiagnosticResult); +procedure ReplaceGraphicsTextureDiagnosticResult( + const AResult: TGraphicsTextureDiagnosticResult); +procedure ReplaceGraphicsVisibleDrawDiagnosticResult( + const AResult: TGraphicsVisibleDrawDiagnosticResult); function DiagnosticStatusToken(const AStatus: TDiagnosticStatus): string; function DiagnosticStageIdToken(const AStage: TDiagnosticStageId): string; function TerrainReadinessDiagnosticStageIdToken( const AStage: TTerrainReadinessDiagnosticStageId): string; +function GraphicsReadinessDiagnosticStageIdToken( + const AStage: TGraphicsReadinessDiagnosticStageId): string; +function GraphicsTextureDiagnosticStageIdToken( + const AStage: TGraphicsTextureDiagnosticStageId): string; +function GraphicsVisibleDrawDiagnosticStageIdToken( + const AStage: TGraphicsVisibleDrawDiagnosticStageId): string; function DiagnosticReportJsonSnapshot: string; implementation @@ -139,6 +235,9 @@ uses var CurrentFileIO: TFileIODiagnosticResult; CurrentTerrainReadiness: TTerrainReadinessDiagnosticResult; + CurrentGraphicsReadiness: TGraphicsReadinessDiagnosticResult; + CurrentGraphicsTexture: TGraphicsTextureDiagnosticResult; + CurrentGraphicsVisibleDraw: TGraphicsVisibleDrawDiagnosticResult; function DiagnosticStatusToken(const AStatus: TDiagnosticStatus): string; begin @@ -149,6 +248,45 @@ begin end; end; +function GraphicsReadinessDiagnosticStageIdToken( + const AStage: TGraphicsReadinessDiagnosticStageId): string; +begin + case AStage of + grsiContextReady: Result := 'context_ready'; + grsiPhysicalSurface: Result := 'physical_surface'; + grsiRendererSizeMatch: Result := 'renderer_size_match'; + grsiTextureBackend: Result := 'texture_backend'; + grsiSampledProgram: Result := 'sampled_program'; + grsiMaxTextureSize: Result := 'max_texture_size'; + end; +end; + +function GraphicsTextureDiagnosticStageIdToken( + const AStage: TGraphicsTextureDiagnosticStageId): string; +begin + case AStage of + gtsiInitialCreate: Result := 'initial_create'; + gtsiNonZeroTextureId: Result := 'non_zero_texture_id'; + gtsiFirstBind: Result := 'first_bind'; + gtsiReplacementUpdate: Result := 'replacement_update'; + gtsiSecondBind: Result := 'second_bind'; + gtsiTextureDelete: Result := 'texture_delete'; + gtsiResourceCleanup: Result := 'resource_cleanup'; + end; +end; + +function GraphicsVisibleDrawDiagnosticStageIdToken( + const AStage: TGraphicsVisibleDrawDiagnosticStageId): string; +begin + case AStage of + gvsiPreparation: Result := 'preparation'; + gvsiSampledRgbaPhase: Result := 'sampled_rgba_phase'; + gvsiBrightnessPhase: Result := 'brightness_phase'; + gvsiTextureDelete: Result := 'texture_delete'; + gvsiResourceCleanup: Result := 'resource_cleanup'; + end; +end; + function DiagnosticStageIdToken(const AStage: TDiagnosticStageId): string; begin case AStage of @@ -186,11 +324,20 @@ begin Result.SelectedMap.Url := SelectedMapUrl; Result.FileIO := CurrentFileIO; Result.TerrainReadiness := CurrentTerrainReadiness; + Result.GraphicsReadiness := CurrentGraphicsReadiness; + Result.GraphicsTexture := CurrentGraphicsTexture; + Result.GraphicsVisibleDraw := CurrentGraphicsVisibleDraw; if (Result.FileIO.Status = dsFail) - or (Result.TerrainReadiness.Status = dsFail) then + or (Result.TerrainReadiness.Status = dsFail) + or (Result.GraphicsReadiness.Status = dsFail) + or (Result.GraphicsTexture.Status = dsFail) + or (Result.GraphicsVisibleDraw.Status = dsFail) then Result.OverallStatus := dsFail else if (Result.FileIO.Status = dsPass) - and (Result.TerrainReadiness.Status = dsPass) then + and (Result.TerrainReadiness.Status = dsPass) + and (Result.GraphicsReadiness.Status = dsPass) + and (Result.GraphicsTexture.Status = dsPass) + and (Result.GraphicsVisibleDraw.Status = dsPass) then Result.OverallStatus := dsPass else Result.OverallStatus := dsNotRun; @@ -207,6 +354,24 @@ begin CurrentTerrainReadiness := AResult; end; +procedure ReplaceGraphicsReadinessDiagnosticResult( + const AResult: TGraphicsReadinessDiagnosticResult); +begin + CurrentGraphicsReadiness := AResult; +end; + +procedure ReplaceGraphicsTextureDiagnosticResult( + const AResult: TGraphicsTextureDiagnosticResult); +begin + CurrentGraphicsTexture := AResult; +end; + +procedure ReplaceGraphicsVisibleDrawDiagnosticResult( + const AResult: TGraphicsVisibleDrawDiagnosticResult); +begin + CurrentGraphicsVisibleDraw := AResult; +end; + function OptionalStringJson(const AValue: TOptionalString): TJSONData; begin if AValue.HasValue then @@ -231,14 +396,246 @@ begin Result := TJSONNull.Create; end; +function DiagnosticErrorJson(const AError: TDiagnosticError): TJSONData; +var + ObjectValue: TJSONObject; +begin + if not AError.Present then + Exit(TJSONNull.Create); + ObjectValue := TJSONObject.Create; + ObjectValue.Add('class', OptionalStringJson(AError.ClassName)); + ObjectValue.Add('message', OptionalStringJson(AError.MessageText)); + Result := ObjectValue; +end; + +procedure AppendFileIOJson(AActions: TJSONArray; const AResult: TFileIODiagnosticResult); +var + Action, Stage, Stream: TJSONObject; + Stages: TJSONArray; + StageId: TDiagnosticStageId; +begin + Action := TJSONObject.Create; + Action.Add('id', 'file_io'); + Action.Add('status', DiagnosticStatusToken(AResult.Status)); + if AResult.FailureStage.HasValue then + Action.Add('failure_stage', DiagnosticStageIdToken(AResult.FailureStage.Value)) + else + Action.Add('failure_stage', TJSONNull.Create); + Action.Add('error', DiagnosticErrorJson(AResult.Error)); + Stages := TJSONArray.Create; + for StageId := Low(TDiagnosticStageId) to High(TDiagnosticStageId) do + begin + Stage := TJSONObject.Create; + Stage.Add('id', DiagnosticStageIdToken(StageId)); + Stage.Add('status', DiagnosticStatusToken(AResult.Stages[StageId])); + Stages.Add(Stage); + end; + Action.Add('stages', Stages); + Stream := TJSONObject.Create; + Stream.Add('size', OptionalInt64Json(AResult.Stream.Size)); + Stream.Add('position_after_load', OptionalInt64Json(AResult.Stream.PositionAfterLoad)); + Stream.Add('read_offset', OptionalInt64Json(AResult.Stream.ReadOffset)); + Stream.Add('requested_read_count', OptionalInt64Json(AResult.Stream.RequestedReadCount)); + Stream.Add('first_read_count', OptionalInt64Json(AResult.Stream.FirstReadCount)); + Stream.Add('position_after_first_read', OptionalInt64Json(AResult.Stream.PositionAfterFirstRead)); + Stream.Add('seek_back_position', OptionalInt64Json(AResult.Stream.SeekBackPosition)); + Stream.Add('second_read_count', OptionalInt64Json(AResult.Stream.SecondReadCount)); + Stream.Add('position_after_second_read', OptionalInt64Json(AResult.Stream.PositionAfterSecondRead)); + Stream.Add('repeat_equal', OptionalBooleanJson(AResult.Stream.RepeatEqual)); + Action.Add('stream', Stream); + AActions.Add(Action); +end; + +procedure AppendTerrainReadinessJson(AActions: TJSONArray; const AResult: TTerrainReadinessDiagnosticResult); +var + Action, Stage, Evidence: TJSONObject; + Stages: TJSONArray; + TerrainStageId: TTerrainReadinessDiagnosticStageId; +begin + Action := TJSONObject.Create; + Action.Add('id', 'terrain_readiness'); + Action.Add('status', DiagnosticStatusToken(AResult.Status)); + if AResult.FailureStage.HasValue then + Action.Add('failure_stage', TerrainReadinessDiagnosticStageIdToken( + AResult.FailureStage.Value)) + else + Action.Add('failure_stage', TJSONNull.Create); + Action.Add('error', DiagnosticErrorJson(AResult.Error)); + Stages := TJSONArray.Create; + for TerrainStageId := Low(TTerrainReadinessDiagnosticStageId) + to High(TTerrainReadinessDiagnosticStageId) do + begin + Stage := TJSONObject.Create; + Stage.Add('id', TerrainReadinessDiagnosticStageIdToken(TerrainStageId)); + Stage.Add('status', DiagnosticStatusToken( + AResult.Stages[TerrainStageId])); + Stages.Add(Stage); + end; + Action.Add('stages', Stages); + Evidence := TJSONObject.Create; + Evidence.Add('rx_tiles_loaded', OptionalBooleanJson( + AResult.Evidence.RxTilesLoaded)); + Evidence.Add('generated_transitions_ready', OptionalBooleanJson( + AResult.Evidence.GeneratedTransitionsReady)); + Evidence.Add('map_x', OptionalInt64Json(AResult.Evidence.MapX)); + Evidence.Add('map_y', OptionalInt64Json(AResult.Evidence.MapY)); + Evidence.Add('game_rev', OptionalInt64Json(AResult.Evidence.GameRev)); + Evidence.Add('expected_tile_count', OptionalInt64Json( + AResult.Evidence.ExpectedTileCount)); + Evidence.Add('completed_tile_count', OptionalInt64Json( + AResult.Evidence.CompletedTileCount)); + Action.Add('evidence', Evidence); + AActions.Add(Action); +end; + +procedure AppendGraphicsReadinessJson(AActions: TJSONArray; const AResult: TGraphicsReadinessDiagnosticResult); +var + Action, Stage, Evidence: TJSONObject; + Stages: TJSONArray; + GraphicsReadinessStageId: TGraphicsReadinessDiagnosticStageId; +begin + Action := TJSONObject.Create; + Action.Add('id', 'graphics_readiness'); + Action.Add('status', DiagnosticStatusToken(AResult.Status)); + if AResult.FailureStage.HasValue then + Action.Add('failure_stage', GraphicsReadinessDiagnosticStageIdToken( + AResult.FailureStage.Value)) + else + Action.Add('failure_stage', TJSONNull.Create); + Action.Add('error', DiagnosticErrorJson(AResult.Error)); + Stages := TJSONArray.Create; + for GraphicsReadinessStageId := Low(TGraphicsReadinessDiagnosticStageId) + to High(TGraphicsReadinessDiagnosticStageId) do + begin + Stage := TJSONObject.Create; + Stage.Add('id', GraphicsReadinessDiagnosticStageIdToken(GraphicsReadinessStageId)); + Stage.Add('status', DiagnosticStatusToken( + AResult.Stages[GraphicsReadinessStageId])); + Stages.Add(Stage); + end; + Action.Add('stages', Stages); + Evidence := TJSONObject.Create; + Evidence.Add('context_available', OptionalBooleanJson(AResult.Evidence.ContextAvailable)); + Evidence.Add('renderer_context_synced', OptionalBooleanJson(AResult.Evidence.RendererContextSynced)); + Evidence.Add('physical_size_known', OptionalBooleanJson(AResult.Evidence.PhysicalSizeKnown)); + Evidence.Add('texture_backend_ready', OptionalBooleanJson(AResult.Evidence.TextureBackendReady)); + Evidence.Add('sampled_program_ready', OptionalBooleanJson(AResult.Evidence.SampledProgramReady)); + Evidence.Add('physical_width', OptionalInt64Json(AResult.Evidence.PhysicalWidth)); + Evidence.Add('physical_height', OptionalInt64Json(AResult.Evidence.PhysicalHeight)); + Evidence.Add('renderer_width', OptionalInt64Json(AResult.Evidence.RendererWidth)); + Evidence.Add('renderer_height', OptionalInt64Json(AResult.Evidence.RendererHeight)); + Evidence.Add('max_texture_size', OptionalInt64Json(AResult.Evidence.MaxTextureSize)); + Action.Add('evidence', Evidence); + AActions.Add(Action); +end; + +procedure AppendGraphicsTextureJson(AActions: TJSONArray; const AResult: TGraphicsTextureDiagnosticResult); +var + Action, Stage, Evidence: TJSONObject; + Stages: TJSONArray; + GraphicsTextureStageId: TGraphicsTextureDiagnosticStageId; +begin + Action := TJSONObject.Create; + Action.Add('id', 'graphics_texture'); + Action.Add('status', DiagnosticStatusToken(AResult.Status)); + if AResult.FailureStage.HasValue then + Action.Add('failure_stage', GraphicsTextureDiagnosticStageIdToken( + AResult.FailureStage.Value)) + else + Action.Add('failure_stage', TJSONNull.Create); + Action.Add('error', DiagnosticErrorJson(AResult.Error)); + Stages := TJSONArray.Create; + for GraphicsTextureStageId := Low(TGraphicsTextureDiagnosticStageId) + to High(TGraphicsTextureDiagnosticStageId) do + begin + Stage := TJSONObject.Create; + Stage.Add('id', GraphicsTextureDiagnosticStageIdToken(GraphicsTextureStageId)); + Stage.Add('status', DiagnosticStatusToken( + AResult.Stages[GraphicsTextureStageId])); + Stages.Add(Stage); + end; + Action.Add('stages', Stages); + Evidence := TJSONObject.Create; + Evidence.Add('initial_width', OptionalInt64Json(AResult.Evidence.InitialWidth)); + Evidence.Add('initial_height', OptionalInt64Json(AResult.Evidence.InitialHeight)); + Evidence.Add('replacement_width', OptionalInt64Json(AResult.Evidence.ReplacementWidth)); + Evidence.Add('replacement_height', OptionalInt64Json(AResult.Evidence.ReplacementHeight)); + Evidence.Add('initial_format', OptionalStringJson(AResult.Evidence.InitialFormat)); + Evidence.Add('replacement_format', OptionalStringJson(AResult.Evidence.ReplacementFormat)); + Evidence.Add('min_filter', OptionalStringJson(AResult.Evidence.MinFilter)); + Evidence.Add('mag_filter', OptionalStringJson(AResult.Evidence.MagFilter)); + Evidence.Add('gen_texture_completed', OptionalBooleanJson(AResult.Evidence.GenTextureCompleted)); + Evidence.Add('non_zero_texture_id', OptionalBooleanJson(AResult.Evidence.NonZeroTextureId)); + Evidence.Add('first_bind_completed', OptionalBooleanJson(AResult.Evidence.FirstBindCompleted)); + Evidence.Add('replacement_update_completed', OptionalBooleanJson(AResult.Evidence.ReplacementUpdateCompleted)); + Evidence.Add('second_bind_completed', OptionalBooleanJson(AResult.Evidence.SecondBindCompleted)); + Evidence.Add('delete_attempted', OptionalBooleanJson(AResult.Evidence.DeleteAttempted)); + Evidence.Add('delete_completed', OptionalBooleanJson(AResult.Evidence.DeleteCompleted)); + Evidence.Add('cleanup_completed', OptionalBooleanJson(AResult.Evidence.CleanupCompleted)); + Evidence.Add('context_lost', OptionalBooleanJson(AResult.Evidence.ContextLost)); + Evidence.Add('cleanup_blocked_by_context', OptionalBooleanJson(AResult.Evidence.CleanupBlockedByContext)); + Evidence.Add('secondary_cleanup_error', + DiagnosticErrorJson(AResult.Evidence.SecondaryCleanupError)); + Action.Add('evidence', Evidence); + AActions.Add(Action); +end; + +procedure AppendGraphicsVisibleDrawJson(AActions: TJSONArray; const AResult: TGraphicsVisibleDrawDiagnosticResult); +var + Action, Stage, Evidence: TJSONObject; + Stages: TJSONArray; + GraphicsVisibleDrawStageId: TGraphicsVisibleDrawDiagnosticStageId; +begin + Action := TJSONObject.Create; + Action.Add('id', 'graphics_visible_draw'); + Action.Add('status', DiagnosticStatusToken(AResult.Status)); + if AResult.FailureStage.HasValue then + Action.Add('failure_stage', GraphicsVisibleDrawDiagnosticStageIdToken( + AResult.FailureStage.Value)) + else + Action.Add('failure_stage', TJSONNull.Create); + Action.Add('error', DiagnosticErrorJson(AResult.Error)); + Stages := TJSONArray.Create; + for GraphicsVisibleDrawStageId := Low(TGraphicsVisibleDrawDiagnosticStageId) + to High(TGraphicsVisibleDrawDiagnosticStageId) do + begin + Stage := TJSONObject.Create; + Stage.Add('id', GraphicsVisibleDrawDiagnosticStageIdToken(GraphicsVisibleDrawStageId)); + Stage.Add('status', DiagnosticStatusToken( + AResult.Stages[GraphicsVisibleDrawStageId])); + Stages.Add(Stage); + end; + Action.Add('stages', Stages); + Evidence := TJSONObject.Create; + Evidence.Add('texture_width', OptionalInt64Json(AResult.Evidence.TextureWidth)); + Evidence.Add('texture_height', OptionalInt64Json(AResult.Evidence.TextureHeight)); + Evidence.Add('base_frames_completed', OptionalInt64Json(AResult.Evidence.BaseFramesCompleted)); + Evidence.Add('brightness_frames_completed', OptionalInt64Json(AResult.Evidence.BrightnessFramesCompleted)); + Evidence.Add('brightness_amount', OptionalInt64Json(AResult.Evidence.BrightnessAmount)); + Evidence.Add('texture_format', OptionalStringJson(AResult.Evidence.TextureFormat)); + Evidence.Add('min_filter', OptionalStringJson(AResult.Evidence.MinFilter)); + Evidence.Add('mag_filter', OptionalStringJson(AResult.Evidence.MagFilter)); + Evidence.Add('texture_created', OptionalBooleanJson(AResult.Evidence.TextureCreated)); + Evidence.Add('non_zero_texture_id', OptionalBooleanJson(AResult.Evidence.NonZeroTextureId)); + Evidence.Add('base_triple_rgba_draws_completed', OptionalBooleanJson(AResult.Evidence.BaseTripleRgbaDrawsCompleted)); + Evidence.Add('brightness_triple_rgba_draws_completed', OptionalBooleanJson(AResult.Evidence.BrightnessTripleRgbaDrawsCompleted)); + Evidence.Add('brightness_overlay_applied_after_draws', OptionalBooleanJson(AResult.Evidence.BrightnessOverlayAppliedAfterDraws)); + Evidence.Add('context_lost', OptionalBooleanJson(AResult.Evidence.ContextLost)); + Evidence.Add('delete_attempted', OptionalBooleanJson(AResult.Evidence.DeleteAttempted)); + Evidence.Add('delete_completed', OptionalBooleanJson(AResult.Evidence.DeleteCompleted)); + Evidence.Add('cleanup_completed', OptionalBooleanJson(AResult.Evidence.CleanupCompleted)); + Evidence.Add('cleanup_blocked_by_context', OptionalBooleanJson(AResult.Evidence.CleanupBlockedByContext)); + Evidence.Add('secondary_cleanup_error', + DiagnosticErrorJson(AResult.Evidence.SecondaryCleanupError)); + Action.Add('evidence', Evidence); + AActions.Add(Action); +end; + function DiagnosticReportJsonSnapshot: string; var State: TDiagnosticReportState; - Root, ObjectValue, Action, Stage, Stream: TJSONObject; - Actions, Stages: TJSONArray; - StageId: TDiagnosticStageId; - TerrainStageId: TTerrainReadinessDiagnosticStageId; - Evidence: TJSONObject; + Root, ObjectValue: TJSONObject; + Actions: TJSONArray; begin State := CurrentDiagnosticReport; Root := TJSONObject.Create; @@ -263,86 +660,13 @@ begin Root.Add('selected_map', ObjectValue); Root.Add('overall_status', DiagnosticStatusToken(State.OverallStatus)); Actions := TJSONArray.Create; - Action := TJSONObject.Create; - Action.Add('id', 'file_io'); - Action.Add('status', DiagnosticStatusToken(State.FileIO.Status)); - if State.FileIO.FailureStage.HasValue then - Action.Add('failure_stage', DiagnosticStageIdToken(State.FileIO.FailureStage.Value)) - else - Action.Add('failure_stage', TJSONNull.Create); - if State.FileIO.Error.Present then - begin - ObjectValue := TJSONObject.Create; - ObjectValue.Add('class', OptionalStringJson(State.FileIO.Error.ClassName)); - ObjectValue.Add('message', OptionalStringJson(State.FileIO.Error.MessageText)); - Action.Add('error', ObjectValue); - end else - Action.Add('error', TJSONNull.Create); - Stages := TJSONArray.Create; - for StageId := Low(TDiagnosticStageId) to High(TDiagnosticStageId) do - begin - Stage := TJSONObject.Create; - Stage.Add('id', DiagnosticStageIdToken(StageId)); - Stage.Add('status', DiagnosticStatusToken(State.FileIO.Stages[StageId])); - Stages.Add(Stage); - end; - Action.Add('stages', Stages); - Stream := TJSONObject.Create; - Stream.Add('size', OptionalInt64Json(State.FileIO.Stream.Size)); - Stream.Add('position_after_load', OptionalInt64Json(State.FileIO.Stream.PositionAfterLoad)); - Stream.Add('read_offset', OptionalInt64Json(State.FileIO.Stream.ReadOffset)); - Stream.Add('requested_read_count', OptionalInt64Json(State.FileIO.Stream.RequestedReadCount)); - Stream.Add('first_read_count', OptionalInt64Json(State.FileIO.Stream.FirstReadCount)); - Stream.Add('position_after_first_read', OptionalInt64Json(State.FileIO.Stream.PositionAfterFirstRead)); - Stream.Add('seek_back_position', OptionalInt64Json(State.FileIO.Stream.SeekBackPosition)); - Stream.Add('second_read_count', OptionalInt64Json(State.FileIO.Stream.SecondReadCount)); - Stream.Add('position_after_second_read', OptionalInt64Json(State.FileIO.Stream.PositionAfterSecondRead)); - Stream.Add('repeat_equal', OptionalBooleanJson(State.FileIO.Stream.RepeatEqual)); - Action.Add('stream', Stream); - Actions.Add(Action); - Action := TJSONObject.Create; - Action.Add('id', 'terrain_readiness'); - Action.Add('status', DiagnosticStatusToken(State.TerrainReadiness.Status)); - if State.TerrainReadiness.FailureStage.HasValue then - Action.Add('failure_stage', TerrainReadinessDiagnosticStageIdToken( - State.TerrainReadiness.FailureStage.Value)) - else - Action.Add('failure_stage', TJSONNull.Create); - if State.TerrainReadiness.Error.Present then - begin - ObjectValue := TJSONObject.Create; - ObjectValue.Add('class', OptionalStringJson( - State.TerrainReadiness.Error.ClassName)); - ObjectValue.Add('message', OptionalStringJson( - State.TerrainReadiness.Error.MessageText)); - Action.Add('error', ObjectValue); - end else - Action.Add('error', TJSONNull.Create); - Stages := TJSONArray.Create; - for TerrainStageId := Low(TTerrainReadinessDiagnosticStageId) - to High(TTerrainReadinessDiagnosticStageId) do - begin - Stage := TJSONObject.Create; - Stage.Add('id', TerrainReadinessDiagnosticStageIdToken(TerrainStageId)); - Stage.Add('status', DiagnosticStatusToken( - State.TerrainReadiness.Stages[TerrainStageId])); - Stages.Add(Stage); - end; - Action.Add('stages', Stages); - Evidence := TJSONObject.Create; - Evidence.Add('rx_tiles_loaded', OptionalBooleanJson( - State.TerrainReadiness.Evidence.RxTilesLoaded)); - Evidence.Add('generated_transitions_ready', OptionalBooleanJson( - State.TerrainReadiness.Evidence.GeneratedTransitionsReady)); - Evidence.Add('map_x', OptionalInt64Json(State.TerrainReadiness.Evidence.MapX)); - Evidence.Add('map_y', OptionalInt64Json(State.TerrainReadiness.Evidence.MapY)); - Evidence.Add('game_rev', OptionalInt64Json(State.TerrainReadiness.Evidence.GameRev)); - Evidence.Add('expected_tile_count', OptionalInt64Json( - State.TerrainReadiness.Evidence.ExpectedTileCount)); - Evidence.Add('completed_tile_count', OptionalInt64Json( - State.TerrainReadiness.Evidence.CompletedTileCount)); - Action.Add('evidence', Evidence); - Actions.Add(Action); + AppendFileIOJson(Actions, State.FileIO); + AppendTerrainReadinessJson(Actions, State.TerrainReadiness); + AppendGraphicsReadinessJson(Actions, State.GraphicsReadiness); + + AppendGraphicsTextureJson(Actions, State.GraphicsTexture); + + AppendGraphicsVisibleDrawJson(Actions, State.GraphicsVisibleDraw); Root.Add('actions', Actions); Result := Root.AsJSON; finally diff --git a/code/GameDiagnosticsView.pas b/code/GameDiagnosticsView.pas index 4bf6134..7953e9e 100644 --- a/code/GameDiagnosticsView.pas +++ b/code/GameDiagnosticsView.pas @@ -6,29 +6,48 @@ interface uses Classes, - CastleUIControls, CastleControls, GameDiagnosticsExport; + CastleUIControls, CastleControls, GameDiagnosticsExport, + GameDiagnosticsGraphics_Mobile; type TDiagnosticsView = class(TCastleView) private + type + TGraphicsRequest = (grReadiness, grTextureLifecycle, grVisibleDraw); + + FActionRegion: TCastleUserInterface; FScroll: TCastleScrollView; FContent: TCastleVerticalGroup; FFileIOButton: TCastleButton; FStatusLabel, FDetailsLabel, FExportFeedbackLabel: TCastleLabel; + FTitleLabel, FGraphicsFeedbackLabel: TCastleLabel; FExportButton: TCastleButton; + FGraphicsReadinessButton, FTextureButton, FVisible2DButton: TCastleButton; FTerrainReadinessButton: TCastleButton; FTerrainReadinessStatusLabel: TCastleLabel; FTerrainReadinessDetailsLabel: TCastleLabel; + FGraphicsReadinessStatusLabel, FGraphicsReadinessDetailsLabel: TCastleLabel; + FTextureStatusLabel, FTextureDetailsLabel: TCastleLabel; + FVisible2DStatusLabel, FVisible2DDetailsLabel: TCastleLabel; FFileIOInProgress, FExportInProgress: Boolean; FTerrainReadinessInProgress: Boolean; + FGraphicsSession: TGraphicsDiagnosticSession; + FGraphicsCompletionNotifiedDuringDispatch: Boolean; procedure RefreshReport; procedure UpdateWrapWidth; + procedure UpdateGraphicsFeedback(const AText: string); + procedure DispatchGraphicsRequest(const ARequest: TGraphicsRequest); + procedure GraphicsReadinessClick(Sender: TObject); + procedure GraphicsTextureClick(Sender: TObject); + procedure GraphicsVisible2DClick(Sender: TObject); + procedure GraphicsResultPublished(Sender: TObject); procedure FileIOClick(Sender: TObject); procedure TerrainReadinessClick(Sender: TObject); procedure ExportClick(Sender: TObject); procedure ExportComplete(const AOutcome: TDiagnosticExportOutcome); public constructor Create(AOwner: TComponent); override; + destructor Destroy; override; procedure Start; override; procedure Resize; override; end; @@ -36,7 +55,7 @@ type implementation uses - SysUtils, GameDiagnosticsFileIO, GameDiagnosticsReport, + SysUtils, Math, GameDiagnosticsFileIO, GameDiagnosticsReport, GameDiagnosticsTerrainReadiness; const @@ -59,15 +78,19 @@ begin end; constructor TDiagnosticsView.Create(AOwner: TComponent); -var - TitleLabel: TCastleLabel; begin inherited; + FGraphicsSession := nil; + FGraphicsCompletionNotifiedDuringDispatch := False; FScroll := TCastleScrollView.Create(Self); - FScroll.FullSize := True; + FScroll.FullSize := False; FScroll.EnableDragging := True; InsertFront(FScroll); + FActionRegion := TCastleUserInterface.Create(Self); + FActionRegion.FullSize := False; + InsertFront(FActionRegion); + FContent := TCastleVerticalGroup.Create(Self); FContent.Padding := LayoutMargin; FContent.Spacing := 8; @@ -76,51 +99,311 @@ begin FStatusLabel := TCastleLabel.Create(Self); FDetailsLabel := TCastleLabel.Create(Self); FExportFeedbackLabel := TCastleLabel.Create(Self); + FGraphicsFeedbackLabel := TCastleLabel.Create(Self); FFileIOButton := TCastleButton.Create(Self); + FFileIOButton.AutoSize := False; FExportButton := TCastleButton.Create(Self); + FExportButton.AutoSize := False; + FGraphicsReadinessButton := TCastleButton.Create(Self); + FGraphicsReadinessButton.AutoSize := False; + FGraphicsReadinessButton.Enabled := True; + FGraphicsReadinessButton.OnClick := @GraphicsReadinessClick; + FTextureButton := TCastleButton.Create(Self); + FTextureButton.AutoSize := False; + FTextureButton.Enabled := True; + FTextureButton.OnClick := @GraphicsTextureClick; + FVisible2DButton := TCastleButton.Create(Self); + FVisible2DButton.AutoSize := False; + FVisible2DButton.Enabled := True; + FVisible2DButton.OnClick := @GraphicsVisible2DClick; FTerrainReadinessButton := TCastleButton.Create(Self); + FTerrainReadinessButton.AutoSize := False; FTerrainReadinessStatusLabel := TCastleLabel.Create(Self); FTerrainReadinessDetailsLabel := TCastleLabel.Create(Self); + FGraphicsReadinessStatusLabel := TCastleLabel.Create(Self); + FGraphicsReadinessDetailsLabel := TCastleLabel.Create(Self); + FTextureStatusLabel := TCastleLabel.Create(Self); + FTextureDetailsLabel := TCastleLabel.Create(Self); + FVisible2DStatusLabel := TCastleLabel.Create(Self); + FVisible2DDetailsLabel := TCastleLabel.Create(Self); - FContent.InsertFront(FExportFeedbackLabel); + FContent.InsertFront(FStatusLabel); + FContent.InsertFront(FDetailsLabel); + FContent.InsertFront(FTerrainReadinessStatusLabel); + FContent.InsertFront(FTerrainReadinessDetailsLabel); + FContent.InsertFront(FGraphicsReadinessStatusLabel); + FContent.InsertFront(FGraphicsReadinessDetailsLabel); + FContent.InsertFront(FTextureStatusLabel); + FContent.InsertFront(FTextureDetailsLabel); + FContent.InsertFront(FVisible2DStatusLabel); + FContent.InsertFront(FVisible2DDetailsLabel); + + FTitleLabel := TCastleLabel.Create(Self); + FTitleLabel.Caption := 'Tests / Diagnostics'; + FActionRegion.InsertFront(FTitleLabel); + FGraphicsFeedbackLabel.Caption := ''; + FActionRegion.InsertFront(FGraphicsFeedbackLabel); + FActionRegion.InsertFront(FExportFeedbackLabel); FExportButton.Caption := 'Export Report'; FExportButton.OnClick := @ExportClick; - FContent.InsertFront(FExportButton); - FContent.InsertFront(FTerrainReadinessDetailsLabel); - FContent.InsertFront(FTerrainReadinessStatusLabel); + FActionRegion.InsertFront(FExportButton); + FGraphicsReadinessButton.Caption := 'Test Graphics Readiness' + LineEnding + 'Current Surface'; + FActionRegion.InsertFront(FGraphicsReadinessButton); + FTextureButton.Caption := 'Test GPU Texture' + LineEnding + 'Lifecycle / Selection'; + FActionRegion.InsertFront(FTextureButton); + FVisible2DButton.Caption := 'Test Visible 2D' + LineEnding + 'RGBA / Brightness'; + FActionRegion.InsertFront(FVisible2DButton); FTerrainReadinessButton.Caption := 'Test MAP/RXX Terrain Readiness'; FTerrainReadinessButton.OnClick := @TerrainReadinessClick; - FContent.InsertFront(FTerrainReadinessButton); - FContent.InsertFront(FDetailsLabel); - FContent.InsertFront(FStatusLabel); + FActionRegion.InsertFront(FTerrainReadinessButton); FFileIOButton.Caption := 'Test File I/O'; FFileIOButton.OnClick := @FileIOClick; - FContent.InsertFront(FFileIOButton); - TitleLabel := TCastleLabel.Create(Self); - TitleLabel.Caption := 'Tests / Diagnostics'; - FContent.InsertFront(TitleLabel); + FActionRegion.InsertFront(FFileIOButton); +end; + +destructor TDiagnosticsView.Destroy; +begin + if FGraphicsSession <> nil then + begin + FGraphicsSession.OnResultPublished := nil; + FreeAndNil(FGraphicsSession); + end; + inherited; +end; + +procedure TDiagnosticsView.UpdateGraphicsFeedback(const AText: string); +begin + if FGraphicsFeedbackLabel.Caption = AText then Exit; + FGraphicsFeedbackLabel.Caption := AText; + UpdateWrapWidth; +end; + +procedure TDiagnosticsView.GraphicsReadinessClick(Sender: TObject); +begin + DispatchGraphicsRequest(grReadiness); +end; + +procedure TDiagnosticsView.GraphicsTextureClick(Sender: TObject); +begin + DispatchGraphicsRequest(grTextureLifecycle); +end; + +procedure TDiagnosticsView.GraphicsVisible2DClick(Sender: TObject); +begin + DispatchGraphicsRequest(grVisibleDraw); +end; + +procedure TDiagnosticsView.DispatchGraphicsRequest(const ARequest: TGraphicsRequest); +var + Accepted: Boolean; + Container: TCastleContainer; +begin + if (FGraphicsSession <> nil) and FGraphicsSession.Busy then + begin + FGraphicsReadinessButton.Enabled := False; + FTextureButton.Enabled := False; + FVisible2DButton.Enabled := False; + UpdateGraphicsFeedback('Graphics diagnostic in progress…'); + Exit; + end; + + if FGraphicsSession = nil then + begin + Container := Self.Container; + if Container = nil then + begin + FGraphicsReadinessButton.Enabled := True; + FTextureButton.Enabled := True; + FVisible2DButton.Enabled := True; + UpdateGraphicsFeedback('Graphics diagnostic unavailable.'); + Exit; + end; + try + FGraphicsSession := TGraphicsDiagnosticSession.Create(Container); + FGraphicsSession.OnResultPublished := @GraphicsResultPublished; + except + if FGraphicsSession <> nil then + begin + FGraphicsSession.OnResultPublished := nil; + FreeAndNil(FGraphicsSession); + end; + FGraphicsReadinessButton.Enabled := True; + FTextureButton.Enabled := True; + FVisible2DButton.Enabled := True; + UpdateGraphicsFeedback('Graphics diagnostic unavailable.'); + Exit; + end; + end; + + FGraphicsCompletionNotifiedDuringDispatch := False; + FGraphicsReadinessButton.Enabled := False; + FTextureButton.Enabled := False; + FVisible2DButton.Enabled := False; + UpdateGraphicsFeedback('Starting graphics diagnostic…'); + try + case ARequest of + grReadiness: Accepted := FGraphicsSession.RequestReadiness; + grTextureLifecycle: Accepted := FGraphicsSession.RequestTextureLifecycle; + grVisibleDraw: Accepted := FGraphicsSession.RequestVisibleDraw; + end; + except + if FGraphicsCompletionNotifiedDuringDispatch then Exit; + if FGraphicsSession.Busy then + begin + FGraphicsReadinessButton.Enabled := False; + FTextureButton.Enabled := False; + FVisible2DButton.Enabled := False; + UpdateGraphicsFeedback('Graphics diagnostic in progress…'); + end else + begin + FGraphicsReadinessButton.Enabled := True; + FTextureButton.Enabled := True; + FVisible2DButton.Enabled := True; + UpdateGraphicsFeedback('Graphics request could not be submitted.'); + end; + Exit; + end; + + if Accepted and FGraphicsCompletionNotifiedDuringDispatch then Exit; + if FGraphicsSession.Busy then + begin + FGraphicsReadinessButton.Enabled := False; + FTextureButton.Enabled := False; + FVisible2DButton.Enabled := False; + UpdateGraphicsFeedback('Graphics diagnostic in progress…'); + end else + begin + FGraphicsReadinessButton.Enabled := True; + FTextureButton.Enabled := True; + FVisible2DButton.Enabled := True; + if not Accepted then + UpdateGraphicsFeedback('Graphics diagnostic request unavailable.') + else + UpdateGraphicsFeedback('Graphics request ended; result update unavailable.'); + end; +end; + +procedure TDiagnosticsView.GraphicsResultPublished(Sender: TObject); +begin + if (FGraphicsSession = nil) or (Sender <> FGraphicsSession) then Exit; + FGraphicsCompletionNotifiedDuringDispatch := True; + FGraphicsReadinessButton.Enabled := True; + FTextureButton.Enabled := True; + FVisible2DButton.Enabled := True; + try + RefreshReport; + except + UpdateGraphicsFeedback('Graphics result published; display refresh unavailable.'); + Exit; + end; + UpdateGraphicsFeedback('Graphics result updated.'); end; procedure TDiagnosticsView.UpdateWrapWidth; var - WrapWidth: Single; + ViewWidth, ViewHeight, AvailableWidth, ActionWidth, Inset, CellWidth: Single; + TitleHeight, GraphicsFeedbackRowHeight, ExportFeedbackRowHeight: Single; + FreeHeight: Single; + Columns, Rows, Index, Column, Row: Integer; + Buttons: array[0..5] of TCastleButton; + StatusLabels: array[0..4] of TCastleLabel; + DetailsLabels: array[0..4] of TCastleLabel; begin - WrapWidth := Width - 2 * LayoutMargin; - if WrapWidth < 1 then WrapWidth := 1; - FDetailsLabel.MaxWidth := WrapWidth; - FTerrainReadinessDetailsLabel.MaxWidth := WrapWidth; - FExportFeedbackLabel.MaxWidth := WrapWidth; + ViewWidth := EffectiveWidth; + ViewHeight := EffectiveHeight; + if (ViewWidth <= 0) or (ViewHeight <= 0) then Exit; + + AvailableWidth := Max(1, ViewWidth - 2 * LayoutMargin); + if AvailableWidth >= 916 then Columns := 3 + else if AvailableWidth >= 614 then Columns := 2 + else Columns := 1; + ActionWidth := Min(AvailableWidth, Columns * 296 + (Columns - 1) * 6 + 16); + Inset := Min(8, Max(0, (ActionWidth - 1) / 2)); + CellWidth := Max(1, (ActionWidth - 2 * Inset - (Columns - 1) * 6) / Columns); + Rows := (6 + Columns - 1) div Columns; + + FActionRegion.Width := ActionWidth; + FActionRegion.Anchor(hpMiddle); + FActionRegion.Anchor(vpTop, -LayoutMargin); + FTitleLabel.MaxWidth := Max(1, ActionWidth - 2 * Inset); + FTitleLabel.Alignment := hpMiddle; + FTitleLabel.AutoSize := True; + FGraphicsFeedbackLabel.MaxWidth := Max(1, ActionWidth - 2 * Inset); + FGraphicsFeedbackLabel.Alignment := hpMiddle; + FGraphicsFeedbackLabel.AutoSize := True; + FExportFeedbackLabel.MaxWidth := Max(1, ActionWidth - 2 * Inset); + FExportFeedbackLabel.Alignment := hpMiddle; + FExportFeedbackLabel.AutoSize := True; + TitleHeight := FTitleLabel.EffectiveHeight; + FTitleLabel.Anchor(hpMiddle); + FTitleLabel.Anchor(vpTop, -Inset); + + Buttons[0] := FFileIOButton; + Buttons[1] := FTerrainReadinessButton; + Buttons[2] := FGraphicsReadinessButton; + Buttons[3] := FTextureButton; + Buttons[4] := FVisible2DButton; + Buttons[5] := FExportButton; + for Index := 0 to High(Buttons) do + begin + Column := Index mod Columns; + Row := Index div Columns; + Buttons[Index].Width := CellWidth; + Buttons[Index].Height := 48; + Buttons[Index].Anchor(hpLeft, Inset + Column * (CellWidth + 6)); + Buttons[Index].Anchor(vpTop, -(Inset + TitleHeight + 8 + Row * (48 + 6))); + end; + + GraphicsFeedbackRowHeight := Max(18, FGraphicsFeedbackLabel.EffectiveHeight); + ExportFeedbackRowHeight := Max(18, FExportFeedbackLabel.EffectiveHeight); + FGraphicsFeedbackLabel.Anchor(hpMiddle); + FGraphicsFeedbackLabel.Anchor(vpTop, + -(Inset + TitleHeight + 8 + Rows * 48 + (Rows - 1) * 6 + 8)); + FExportFeedbackLabel.Anchor(hpMiddle); + FExportFeedbackLabel.Anchor(vpTop, + -(Inset + TitleHeight + 8 + Rows * 48 + (Rows - 1) * 6 + 8 + + GraphicsFeedbackRowHeight + 8)); + FActionRegion.Height := Inset + TitleHeight + 8 + Rows * 48 + + (Rows - 1) * 6 + 8 + GraphicsFeedbackRowHeight + 8 + + ExportFeedbackRowHeight + Inset; + + FScroll.FullSize := False; + FScroll.Width := Max(1, ViewWidth - 2 * LayoutMargin); + FScroll.Anchor(hpMiddle); + FScroll.Anchor(vpBottom, LayoutMargin); + FreeHeight := ViewHeight - 2 * LayoutMargin - FActionRegion.Height - 8; + if FreeHeight > 0 then + begin + FScroll.Exists := True; + FScroll.Height := FreeHeight; + end else + begin + FScroll.Exists := False; + FScroll.Height := 1; + end; + + StatusLabels[0] := FStatusLabel; + DetailsLabels[0] := FDetailsLabel; + StatusLabels[1] := FTerrainReadinessStatusLabel; + DetailsLabels[1] := FTerrainReadinessDetailsLabel; + StatusLabels[2] := FGraphicsReadinessStatusLabel; + DetailsLabels[2] := FGraphicsReadinessDetailsLabel; + StatusLabels[3] := FTextureStatusLabel; + DetailsLabels[3] := FTextureDetailsLabel; + StatusLabels[4] := FVisible2DStatusLabel; + DetailsLabels[4] := FVisible2DDetailsLabel; + for Index := 0 to High(StatusLabels) do + begin + StatusLabels[Index].MaxWidth := Max(1, FScroll.Width - 2 * LayoutMargin - 16); + DetailsLabels[Index].MaxWidth := Max(1, FScroll.Width - 2 * LayoutMargin - 16); + end; end; -procedure TDiagnosticsView.RefreshReport; +function FileIODetails(const State: TDiagnosticReportState): string; var - State: TDiagnosticReportState; Stage: TDiagnosticStageId; - TerrainStage: TTerrainReadinessDiagnosticStageId; Details: string; begin - State := CurrentDiagnosticReport; - FStatusLabel.Caption := 'File I/O: ' + DiagnosticStatusToken(State.FileIO.Status); Details := 'selected map relative_path: ' + State.SelectedMap.RelativePath + LineEnding + 'selected map url: ' + State.SelectedMap.Url; for Stage := Low(TDiagnosticStageId) to High(TDiagnosticStageId) do @@ -147,10 +430,14 @@ begin if PositionAfterSecondRead.HasValue then Details := Details + LineEnding + 'position_after_second_read: ' + OptionalInt64Text(PositionAfterSecondRead); if RepeatEqual.HasValue then Details := Details + LineEnding + 'repeat_equal: ' + OptionalBooleanText(RepeatEqual); end; - FDetailsLabel.Caption := Details; + Result := Details; +end; - FTerrainReadinessStatusLabel.Caption := 'MAP/RXX terrain readiness: ' + - DiagnosticStatusToken(State.TerrainReadiness.Status); +function TerrainReadinessDetails(const State: TDiagnosticReportState): string; +var + TerrainStage: TTerrainReadinessDiagnosticStageId; + Details: string; +begin Details := ''; for TerrainStage := Low(TTerrainReadinessDiagnosticStageId) to High(TTerrainReadinessDiagnosticStageId) do @@ -186,12 +473,242 @@ begin if CompletedTileCount.HasValue then Details := Details + LineEnding + 'completed_tile_count: ' + OptionalInt64Text(CompletedTileCount); end; - FTerrainReadinessDetailsLabel.Caption := Details; + Result := Details; +end; + +function GraphicsReadinessDetails(const State: TDiagnosticReportState): string; +var + ReadinessStage: TGraphicsReadinessDiagnosticStageId; + Details: string; +begin + Details := ''; + for ReadinessStage := Low(TGraphicsReadinessDiagnosticStageId) + to High(TGraphicsReadinessDiagnosticStageId) do + begin + if Details <> '' then Details := Details + LineEnding; + Details := Details + GraphicsReadinessDiagnosticStageIdToken(ReadinessStage) + ': '; + Details := Details + DiagnosticStatusToken( + State.GraphicsReadiness.Stages[ReadinessStage]); + end; + if State.GraphicsReadiness.FailureStage.HasValue then + Details := Details + LineEnding + 'failure_stage: ' + + GraphicsReadinessDiagnosticStageIdToken( + State.GraphicsReadiness.FailureStage.Value); + if State.GraphicsReadiness.Error.Present then + begin + Details := Details + LineEnding + 'error class: ' + + OptionalStringText(State.GraphicsReadiness.Error.ClassName); + Details := Details + LineEnding + 'error message: ' + + OptionalStringText(State.GraphicsReadiness.Error.MessageText); + end; + with State.GraphicsReadiness.Evidence do + begin + if ContextAvailable.HasValue then + Details := Details + LineEnding + 'context_available: ' + + OptionalBooleanText(ContextAvailable); + if RendererContextSynced.HasValue then + Details := Details + LineEnding + 'renderer_context_synced: ' + + OptionalBooleanText(RendererContextSynced); + if PhysicalSizeKnown.HasValue then + Details := Details + LineEnding + 'physical_size_known: ' + + OptionalBooleanText(PhysicalSizeKnown); + if TextureBackendReady.HasValue then + Details := Details + LineEnding + 'texture_backend_ready: ' + + OptionalBooleanText(TextureBackendReady); + if SampledProgramReady.HasValue then + Details := Details + LineEnding + 'sampled_program_ready: ' + + OptionalBooleanText(SampledProgramReady); + if PhysicalWidth.HasValue then + Details := Details + LineEnding + 'physical_width: ' + + OptionalInt64Text(PhysicalWidth); + if PhysicalHeight.HasValue then + Details := Details + LineEnding + 'physical_height: ' + + OptionalInt64Text(PhysicalHeight); + if RendererWidth.HasValue then + Details := Details + LineEnding + 'renderer_width: ' + + OptionalInt64Text(RendererWidth); + if RendererHeight.HasValue then + Details := Details + LineEnding + 'renderer_height: ' + + OptionalInt64Text(RendererHeight); + if MaxTextureSize.HasValue then + Details := Details + LineEnding + 'max_texture_size: ' + + OptionalInt64Text(MaxTextureSize); + end; + Result := Details; +end; + +function GraphicsTextureDetails(const State: TDiagnosticReportState): string; +var + TextureStage: TGraphicsTextureDiagnosticStageId; + Details: string; +begin + Details := ''; + for TextureStage := Low(TGraphicsTextureDiagnosticStageId) + to High(TGraphicsTextureDiagnosticStageId) do + begin + if Details <> '' then Details := Details + LineEnding; + Details := Details + GraphicsTextureDiagnosticStageIdToken(TextureStage) + ': ' + + DiagnosticStatusToken(State.GraphicsTexture.Stages[TextureStage]); + end; + if State.GraphicsTexture.FailureStage.HasValue then + Details := Details + LineEnding + 'failure_stage: ' + + GraphicsTextureDiagnosticStageIdToken( + State.GraphicsTexture.FailureStage.Value); + if State.GraphicsTexture.Error.Present then + begin + Details := Details + LineEnding + 'error class: ' + + OptionalStringText(State.GraphicsTexture.Error.ClassName); + Details := Details + LineEnding + 'error message: ' + + OptionalStringText(State.GraphicsTexture.Error.MessageText); + end; + with State.GraphicsTexture.Evidence do + begin + if InitialWidth.HasValue then + Details := Details + LineEnding + 'initial_width: ' + OptionalInt64Text(InitialWidth); + if InitialHeight.HasValue then + Details := Details + LineEnding + 'initial_height: ' + OptionalInt64Text(InitialHeight); + if ReplacementWidth.HasValue then + Details := Details + LineEnding + 'replacement_width: ' + OptionalInt64Text(ReplacementWidth); + if ReplacementHeight.HasValue then + Details := Details + LineEnding + 'replacement_height: ' + OptionalInt64Text(ReplacementHeight); + if InitialFormat.HasValue then + Details := Details + LineEnding + 'initial_format: ' + OptionalStringText(InitialFormat); + if ReplacementFormat.HasValue then + Details := Details + LineEnding + 'replacement_format: ' + OptionalStringText(ReplacementFormat); + if MinFilter.HasValue then + Details := Details + LineEnding + 'min_filter: ' + OptionalStringText(MinFilter); + if MagFilter.HasValue then + Details := Details + LineEnding + 'mag_filter: ' + OptionalStringText(MagFilter); + if GenTextureCompleted.HasValue then + Details := Details + LineEnding + 'gen_texture_completed: ' + OptionalBooleanText(GenTextureCompleted); + if NonZeroTextureId.HasValue then + Details := Details + LineEnding + 'non_zero_texture_id: ' + OptionalBooleanText(NonZeroTextureId); + if FirstBindCompleted.HasValue then + Details := Details + LineEnding + 'first_bind_completed: ' + OptionalBooleanText(FirstBindCompleted); + if ReplacementUpdateCompleted.HasValue then + Details := Details + LineEnding + 'replacement_update_completed: ' + OptionalBooleanText(ReplacementUpdateCompleted); + if SecondBindCompleted.HasValue then + Details := Details + LineEnding + 'second_bind_completed: ' + OptionalBooleanText(SecondBindCompleted); + if DeleteAttempted.HasValue then + Details := Details + LineEnding + 'delete_attempted: ' + OptionalBooleanText(DeleteAttempted); + if DeleteCompleted.HasValue then + Details := Details + LineEnding + 'delete_completed: ' + OptionalBooleanText(DeleteCompleted); + if CleanupCompleted.HasValue then + Details := Details + LineEnding + 'cleanup_completed: ' + OptionalBooleanText(CleanupCompleted); + if ContextLost.HasValue then + Details := Details + LineEnding + 'context_lost: ' + OptionalBooleanText(ContextLost); + if CleanupBlockedByContext.HasValue then + Details := Details + LineEnding + 'cleanup_blocked_by_context: ' + OptionalBooleanText(CleanupBlockedByContext); + if SecondaryCleanupError.Present then + begin + Details := Details + LineEnding + 'secondary_cleanup_error class: ' + + OptionalStringText(SecondaryCleanupError.ClassName); + Details := Details + LineEnding + 'secondary_cleanup_error message: ' + + OptionalStringText(SecondaryCleanupError.MessageText); + end; + end; + Result := Details; +end; + +function GraphicsVisibleDrawDetails(const State: TDiagnosticReportState): string; +var + VisibleStage: TGraphicsVisibleDrawDiagnosticStageId; + Details: string; +begin + Details := 'Renderer execution only; pixels are not automatically verified.' + + LineEnding + 'Inspect the on-screen pattern while the action runs.'; + for VisibleStage := Low(TGraphicsVisibleDrawDiagnosticStageId) + to High(TGraphicsVisibleDrawDiagnosticStageId) do + begin + Details := Details + LineEnding + + GraphicsVisibleDrawDiagnosticStageIdToken(VisibleStage) + ': ' + + DiagnosticStatusToken(State.GraphicsVisibleDraw.Stages[VisibleStage]); + end; + if State.GraphicsVisibleDraw.FailureStage.HasValue then + Details := Details + LineEnding + 'failure_stage: ' + + GraphicsVisibleDrawDiagnosticStageIdToken( + State.GraphicsVisibleDraw.FailureStage.Value); + if State.GraphicsVisibleDraw.Error.Present then + begin + Details := Details + LineEnding + 'error class: ' + + OptionalStringText(State.GraphicsVisibleDraw.Error.ClassName); + Details := Details + LineEnding + 'error message: ' + + OptionalStringText(State.GraphicsVisibleDraw.Error.MessageText); + end; + with State.GraphicsVisibleDraw.Evidence do + begin + if TextureWidth.HasValue then + Details := Details + LineEnding + 'texture_width: ' + OptionalInt64Text(TextureWidth); + if TextureHeight.HasValue then + Details := Details + LineEnding + 'texture_height: ' + OptionalInt64Text(TextureHeight); + if BaseFramesCompleted.HasValue then + Details := Details + LineEnding + 'base_frames_completed: ' + OptionalInt64Text(BaseFramesCompleted); + if BrightnessFramesCompleted.HasValue then + Details := Details + LineEnding + 'brightness_frames_completed: ' + OptionalInt64Text(BrightnessFramesCompleted); + if BrightnessAmount.HasValue then + Details := Details + LineEnding + 'brightness_amount: ' + OptionalInt64Text(BrightnessAmount); + if TextureFormat.HasValue then + Details := Details + LineEnding + 'texture_format: ' + OptionalStringText(TextureFormat); + if MinFilter.HasValue then + Details := Details + LineEnding + 'min_filter: ' + OptionalStringText(MinFilter); + if MagFilter.HasValue then + Details := Details + LineEnding + 'mag_filter: ' + OptionalStringText(MagFilter); + if TextureCreated.HasValue then + Details := Details + LineEnding + 'texture_created: ' + OptionalBooleanText(TextureCreated); + if NonZeroTextureId.HasValue then + Details := Details + LineEnding + 'non_zero_texture_id: ' + OptionalBooleanText(NonZeroTextureId); + if BaseTripleRgbaDrawsCompleted.HasValue then + Details := Details + LineEnding + 'base_triple_rgba_draws_completed: ' + OptionalBooleanText(BaseTripleRgbaDrawsCompleted); + if BrightnessTripleRgbaDrawsCompleted.HasValue then + Details := Details + LineEnding + 'brightness_triple_rgba_draws_completed: ' + OptionalBooleanText(BrightnessTripleRgbaDrawsCompleted); + if BrightnessOverlayAppliedAfterDraws.HasValue then + Details := Details + LineEnding + 'brightness_overlay_applied_after_draws: ' + OptionalBooleanText(BrightnessOverlayAppliedAfterDraws); + if ContextLost.HasValue then + Details := Details + LineEnding + 'context_lost: ' + OptionalBooleanText(ContextLost); + if DeleteAttempted.HasValue then + Details := Details + LineEnding + 'delete_attempted: ' + OptionalBooleanText(DeleteAttempted); + if DeleteCompleted.HasValue then + Details := Details + LineEnding + 'delete_completed: ' + OptionalBooleanText(DeleteCompleted); + if CleanupCompleted.HasValue then + Details := Details + LineEnding + 'cleanup_completed: ' + OptionalBooleanText(CleanupCompleted); + if CleanupBlockedByContext.HasValue then + Details := Details + LineEnding + 'cleanup_blocked_by_context: ' + OptionalBooleanText(CleanupBlockedByContext); + if SecondaryCleanupError.Present then + begin + Details := Details + LineEnding + 'secondary_cleanup_error class: ' + + OptionalStringText(SecondaryCleanupError.ClassName); + Details := Details + LineEnding + 'secondary_cleanup_error message: ' + + OptionalStringText(SecondaryCleanupError.MessageText); + end; + end; + Result := Details; +end; + +procedure TDiagnosticsView.RefreshReport; +var + State: TDiagnosticReportState; +begin + State := CurrentDiagnosticReport; + FStatusLabel.Caption := 'File I/O: ' + DiagnosticStatusToken(State.FileIO.Status); + FDetailsLabel.Caption := FileIODetails(State); + FTerrainReadinessStatusLabel.Caption := 'MAP/RXX terrain readiness: ' + + DiagnosticStatusToken(State.TerrainReadiness.Status); + FTerrainReadinessDetailsLabel.Caption := TerrainReadinessDetails(State); + FGraphicsReadinessStatusLabel.Caption := 'Graphics readiness/current surface: ' + + DiagnosticStatusToken(State.GraphicsReadiness.Status); + FGraphicsReadinessDetailsLabel.Caption := GraphicsReadinessDetails(State); + FTextureStatusLabel.Caption := 'GPU texture lifecycle/selection: ' + + DiagnosticStatusToken(State.GraphicsTexture.Status); + FTextureDetailsLabel.Caption := GraphicsTextureDetails(State); + FVisible2DStatusLabel.Caption := 'Visible 2D renderer execution: ' + + DiagnosticStatusToken(State.GraphicsVisibleDraw.Status); + FVisible2DDetailsLabel.Caption := GraphicsVisibleDrawDetails(State); end; procedure TDiagnosticsView.Start; begin inherited; + UpdateWrapWidth; RefreshReport; end; @@ -235,6 +752,7 @@ begin FExportInProgress := True; FExportButton.Enabled := False; FExportFeedbackLabel.Caption := 'Exporting report…'; + UpdateWrapWidth; ExportDiagnosticReport(DiagnosticReportJsonSnapshot, @ExportComplete); end; @@ -250,6 +768,7 @@ begin else FExportFeedbackLabel.Caption := 'Export error.'; end; + UpdateWrapWidth; end; end.