unit GameViewMain; {$mode objfpc}{$H+}{$codepage utf8}{$pointermath on} interface uses Classes, SysUtils, CastleUIControls, CastleControls, CastleKeysMouse, CastleVectors, CastleSoundEngine, ProbeReport, ProbeCamera, ProbeScheduling; type TProbeView = class(TCastleView) private FStatus,FHelp:TCastleLabel; FImage:TCastleImageControl; FSound:TCastleSound; FReport:TProbeReport; FDir,FCell:string; FCamera:TProbeCamera; FDown:array[0..9] of Boolean; FPos,FStart:array[0..9] of TVector2; FMoved,FMulti,FStarted,FListeners:Boolean; FTaps,FPans,FPinches,FFrames,FUpdates,FPauses,FResumes,FGLCloses,FGLOpens:Integer; FElapsed:Single; FSchedule:TDecisionSchedule; procedure MakeImage; procedure PlaceImage; procedure SaveReport; procedure SaveClicked(Sender:TObject); procedure SoundClicked(Sender:TObject); procedure Paused(Sender:TObject); procedure Resumed(Sender:TObject); procedure ContextOpened(Sender:TObject); procedure ContextClosed(Sender:TObject); function Fingers(out A,B:Integer):Integer; public procedure Start; override; procedure Stop; override; procedure Render; override; procedure Update(const SecondsPassed:Single;var HandleInput:Boolean); override; function Press(const Event:TInputPressRelease):Boolean; override; function Release(const Event:TInputPressRelease):Boolean; override; function Motion(const Event:TInputMotion):Boolean; override; end; implementation uses Math, cwstring, fpjson, CastleImages, CastleUriUtils, CastleApplicationProperties, CastleLog, ProbePlatform, ProbeAssets, ProbeDecision, ProbeTextProvider, ProbeImports, ProbeBuild; procedure TProbeView.Start; var B:TCastleButton; DataDir:string; begin inherited; FImage:=TCastleImageControl.Create(FreeAtStop);FImage.Stretch:=True;InsertFront(FImage); FStatus:=TCastleLabel.Create(FreeAtStop);FStatus.FontSize:=16; FStatus.Anchor(hpLeft,12);FStatus.Anchor(vpTop,-10);InsertFront(FStatus); FHelp:=TCastleLabel.Create(FreeAtStop);FHelp.FontSize:=14; FHelp.Anchor(hpLeft,12);FHelp.Anchor(vpBottom,10);InsertFront(FHelp); B:=TCastleButton.Create(FreeAtStop);B.Caption:='Save report'; B.Anchor(hpLeft,12);B.Anchor(vpTop,-90);B.OnClick:=@SaveClicked;InsertFront(B); B:=TCastleButton.Create(FreeAtStop);B.Caption:='Test sound'; B.Anchor(hpLeft,175);B.Anchor(vpTop,-90);B.OnClick:=@SoundClicked;InsertFront(B); FSound:=TCastleSound.Create(FreeAtStop); FReport:=TProbeReport.Create; try FDir:=ProbeDirectory; FReport.Root.Add('report_directory',FDir); FReport.Add('android.startup','PASS','CGE application initialized; library and unit initializers reached UI'); RunPlatformChecks(FReport,FDir); RunDecisionChecks(FReport,FDir); FReport.Add('decision.text.cwstring_unit','PASS','cwstring unit linked and initialized in the common Android runtime APK'); RunTextProviderChecks(FReport); RunUpstreamChecks(FReport); FSchedule:=TDecisionSchedule.Create(FReport); try DataDir:=PrepareOptionalAssets(FReport,FDir); FReport.Root.Add('native_asset_directory',DataDir); except on E:Exception do FReport.Add('assets.native_adapter','FAIL',E.ClassName+': '+E.Message);end; MakeImage; FCamera.Reset; FCamera.PixelsPerCell:=Max(4.0,Min((Container.UnscaledWidth-40)/32, (Container.UnscaledHeight-180)/32)); FCamera.OffsetY:=40;PlaceImage; FReport.Add('render.visual_correctness','NOT_RUN','Procedural checker only; inspect on device. Not KaM terrain.'); FReport.Add('audio.audible','NOT_RUN','Press Test sound and listen; API success does not prove audible output'); ApplicationProperties.OnPause.Add(@Paused); ApplicationProperties.OnResume.Add(@Resumed); ApplicationProperties.OnGLContextOpenObject.Add(@ContextOpened); ApplicationProperties.OnGLContextCloseObject.Add(@ContextClosed); FListeners:=True; FReport.Add('render.context','NOT_RUN','Awaiting the first render callback'); FStarted:=True; FStatus.Caption:='Android / '+ProbeProfile+' / '+ProbeCpu+LineEnding+ 'Automatic smoke: '+FReport.Status+'; device observations separate'+LineEnding+ 'Architecture probe only. No KaM world or simulation.'; SaveReport; except on E:Exception do begin FReport.Add('android.startup','FAIL',E.ClassName+': '+E.Message); FStatus.Caption:='STARTUP FAILED: '+E.Message; if FDir<>'' then SaveReport; end;end; end; procedure TProbeView.MakeImage; var Image:TRGBAlphaImage;Row:PByte;X,Y:Integer;V:Byte; begin Image:=TRGBAlphaImage.Create(256,256); try for Y:=0 to 255 do begin Row:=PByte(Image.RowPtr(Y)); for X:=0 to 255 do begin if ((X div 8)+(Y div 8)) mod 2=0 then V:=90 else V:=150; Row[X*4]:=V;Row[X*4+1]:=V;Row[X*4+2]:=V;Row[X*4+3]:=255; end; end; FImage.Image:=Image;Image:=nil; finally Image.Free;end; end; procedure TProbeView.PlaceImage; begin FImage.Left:=FCamera.OffsetX;FImage.Bottom:=FCamera.OffsetY; FImage.Width:=32*FCamera.PixelsPerCell;FImage.Height:=32*FCamera.PixelsPerCell; FHelp.Caption:=Format('Synthetic grid | tap %d | pan %d | pinch %d | cell %s', [FTaps,FPans,FPinches,FCell]); end; procedure TProbeView.SaveReport; var J:TJSONObject; begin if (FReport=nil) or (FDir='') then Exit; try FReport.Root.Delete('session');J:=TJSONObject.Create; J.Add('frames',FFrames);J.Add('updates',FUpdates); J.Add('taps',FTaps);J.Add('pan_events',FPans);J.Add('pinch_events',FPinches); J.Add('pauses',FPauses);J.Add('resumes',FResumes); J.Add('gl_open_events',FGLOpens);J.Add('gl_close_events',FGLCloses); J.Add('last_cell',FCell);J.Add('width',Container.UnscaledWidth); J.Add('height',Container.UnscaledHeight); FReport.Root.Add('session',J); if FFrames>0 then FReport.Check('render.context',ApplicationProperties.IsGLContextOpen,'CGE GL context during render/update'); if FFrames>=30 then FReport.Add('render.frame_callbacks','PASS','At least 30 render callbacks; visual output still requires observation'); FReport.Save(FDir+'runtime.json'); WritelnLog('KaMProbe','KAM_PROBE_REPORT '+FDir+'runtime.json'); except on E:Exception do begin WritelnLog('KaMProbe','REPORT_SAVE_FAILED '+E.Message); FStatus.Caption:='REPORT SAVE FAILED: '+E.Message; end;end; end; procedure TProbeView.SaveClicked(Sender:TObject); begin SaveReport;FHelp.Caption:='Report: '+FDir+'runtime.json';end; procedure TProbeView.SoundClicked(Sender:TObject); begin try WriteTestTone(FDir+'generated-test-tone.wav'); FSound.Url:=FilenameToUriSafe(FDir+'generated-test-tone.wav'); SoundEngine.Play(FSound); FReport.Add('audio.api','OBSERVED','CGE Play returned without exception; confirm audibility manually'); except on E:Exception do FReport.Add('audio.api','FAIL',E.ClassName+': '+E.Message);end; SaveReport; end; procedure TProbeView.Paused(Sender:TObject); begin Inc(FPauses);if FSchedule<>nil then FSchedule.Paused;FillChar(FDown,SizeOf(FDown),0);FMoved:=True;SaveReport;end; procedure TProbeView.Resumed(Sender:TObject); begin Inc(FResumes);if FSchedule<>nil then FSchedule.Resumed;SaveReport;end; procedure TProbeView.ContextOpened(Sender:TObject); begin Inc(FGLOpens);end; procedure TProbeView.ContextClosed(Sender:TObject); begin Inc(FGLCloses);SaveReport;end; procedure TProbeView.Stop; begin if FListeners then begin ApplicationProperties.OnPause.Remove(@Paused); ApplicationProperties.OnResume.Remove(@Resumed); ApplicationProperties.OnGLContextOpenObject.Remove(@ContextOpened); ApplicationProperties.OnGLContextCloseObject.Remove(@ContextClosed); FListeners:=False; end; SaveReport;FStarted:=False; FreeAndNil(FSchedule); FillChar(FDown,SizeOf(FDown),0);FreeAndNil(FReport); inherited; end; procedure TProbeView.Render; begin inherited;Inc(FFrames);end; procedure TProbeView.Update(const SecondsPassed:Single;var HandleInput:Boolean); begin inherited;Inc(FUpdates); if FSchedule<>nil then FSchedule.Tick; FElapsed:=FElapsed+SecondsPassed; if FStarted and (FElapsed>=2) then begin SaveReport;FElapsed:=0;end; end; function TProbeView.Fingers(out A,B:Integer):Integer; var I:Integer; begin Result:=0;A:=-1;B:=-1; for I:=0 to High(FDown) do if FDown[I] then begin Inc(Result);if A<0 then A:=I else if B<0 then B:=I; end; end; function TProbeView.Press(const Event:TInputPressRelease):Boolean; var A,B,I:Integer; begin Result:=inherited;if Result or not FStarted then Exit; if not Event.IsMouseButton(buttonLeft) then Exit; I:=Event.FingerIndex;if (I<0) or (I>High(FDown)) then Exit; if Fingers(A,B)=0 then begin FMoved:=False;FMulti:=False;end; FDown[I]:=True;FPos[I]:=Event.Position;FStart[I]:=Event.Position; if Fingers(A,B)>1 then FMulti:=True; Result:=True; end; function TProbeView.Motion(const Event:TInputMotion):Boolean; var I,N,A,B:Integer;OldDistance,NewDistance:Single;OldMid,NewMid:TVector2; begin Result:=inherited; I:=Event.FingerIndex;if (I<0) or (I>High(FDown)) or not FDown[I] then Exit; N:=Fingers(A,B); if N>=2 then begin OldDistance:=Sqrt(Sqr(FPos[A].X-FPos[B].X)+Sqr(FPos[A].Y-FPos[B].Y)); OldMid:=(FPos[A]+FPos[B])*0.5; end; if Sqr(Event.Position.X-FStart[I].X)+Sqr(Event.Position.Y-FStart[I].Y)>64 then FMoved:=True; if N=1 then begin { Do not pan before the movement threshold: a tap must not shift the grid. } if FMoved then begin FCamera.Pan(Event.Position.X-FPos[I].X,Event.Position.Y-FPos[I].Y);Inc(FPans); end; end; FPos[I]:=Event.Position; if N>=2 then begin NewDistance:=Sqrt(Sqr(FPos[A].X-FPos[B].X)+Sqr(FPos[A].Y-FPos[B].Y)); NewMid:=(FPos[A]+FPos[B])*0.5; if (OldDistance>1) and (NewDistance>1) then FCamera.ZoomAt(NewDistance/OldDistance,OldMid.X,OldMid.Y); FCamera.Pan(NewMid.X-OldMid.X,NewMid.Y-OldMid.Y);Inc(FPinches); end; PlaceImage;Result:=True; end; function TProbeView.Release(const Event:TInputPressRelease):Boolean; var I,N,A,B,X,Y:Integer; begin Result:=inherited; if not Event.IsMouseButton(buttonLeft) then Exit; I:=Event.FingerIndex;if (I<0) or (I>High(FDown)) or not FDown[I] then Exit; N:=Fingers(A,B);FDown[I]:=False; if (N=1) and not FMoved and not FMulti then begin Inc(FTaps); if FCamera.CellAt(Event.Position.X,Event.Position.Y,32,32,X,Y) then FCell:=IntToStr(X)+','+IntToStr(Y) else FCell:='outside'; end; PlaceImage;SaveReport;Result:=True; end; end.