Initial import
This commit is contained in:
admin_d committed
commit
dfcc43c72d
34 files changed
+3057
No files matched your search
Executable
+241
@@ -0,0 +1,241 @@
|
||||
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.
|
||||
Reference in new issue
Block a user