diff --git a/code/GameInitialize.pas b/code/GameInitialize.pas index 3ebf9d2..785a0f8 100755 --- a/code/GameInitialize.pas +++ b/code/GameInitialize.pas @@ -3,7 +3,7 @@ unit GameInitialize; {$ifndef ANDROID}{$fatal Android-only KaM Remake Mobile application; there is no desktop target}{$endif} interface implementation -uses CastleWindow, GameDiagnosticsView; +uses CastleWindow, CastleApplicationProperties, CastleGLUtils, GameDiagnosticsView, KM_GameApp_Mobile; var Window: TCastleWindow; DiagnosticsView: TDiagnosticsView; @@ -11,9 +11,13 @@ procedure Initialize; begin DiagnosticsView := TDiagnosticsView.Create(Application); Window.Container.View := DiagnosticsView; + KMGameAppMobileInstallPresentation(Window.Container); end; initialization Application.OnInitialize := @Initialize; + ApplicationProperties.LimitFPS := 60; + TGLFeatures.RequestCapabilities := rcAutomatic; Window := TCastleWindow.Create(Application); + Window.AutoRedisplay := True; Application.MainWindow := Window; end. diff --git a/code/KM_GameApp_Mobile.pas b/code/KM_GameApp_Mobile.pas new file mode 100644 index 0000000..5059ea3 --- /dev/null +++ b/code/KM_GameApp_Mobile.pas @@ -0,0 +1,228 @@ +unit KM_GameApp_Mobile; + +interface + +uses + CastleUIControls; + +type + TKMGraphicsContextAvailabilityEvent = procedure(aAvailable: Boolean) of object; + TKMGamePresentationFrameEvent = procedure of object; + TKMGamePresentationResizeEvent = procedure(aWidth, aHeight: Integer) of object; + +procedure KMGameAppMobileAttach( + const aOnGraphicsContextAvailability: TKMGraphicsContextAvailabilityEvent); +procedure KMGameAppMobileDetach; +procedure KMGameAppMobileInstallPresentation(const aContainer: TCastleContainer); +procedure KMGameAppMobileAttachPresentation( + const aOnFrame: TKMGamePresentationFrameEvent; + const aOnResize: TKMGamePresentationResizeEvent); +procedure KMGameAppMobileDetachPresentation; + +implementation + +uses + SysUtils, CastleApplicationProperties, CastleGLVersion, + CastleGLUtils, CastleWindow; + +type + TKMGamePresentationControl = class(TCastleUserInterface) + public + procedure Render; override; + procedure Resize; override; + end; + +var + gOnGraphicsContextAvailability: TKMGraphicsContextAvailabilityEvent; + gRegistrationActive: Boolean; + gDeliveryKnown: Boolean; + gLastDelivered: Boolean; + gPresentationControl: TKMGamePresentationControl; + gPresentationOnFrame: TKMGamePresentationFrameEvent; + gPresentationOnResize: TKMGamePresentationResizeEvent; + + +procedure TKMGamePresentationControl.Render; +begin + if Assigned(gPresentationOnFrame) then + gPresentationOnFrame; +end; + + +procedure TKMGamePresentationControl.Resize; +begin + if not Assigned(gPresentationOnResize) then + Exit; + if Container = nil then + raise Exception.Create('Mobile presentation control has no container'); + gPresentationOnResize(Container.PixelsWidth, Container.PixelsHeight); +end; + + +procedure KMGameAppMobileInstallPresentation(const aContainer: TCastleContainer); +var + control: TKMGamePresentationControl; +begin + if aContainer = nil then + raise Exception.Create('Mobile presentation container is nil'); + if gPresentationControl <> nil then + raise Exception.Create('Mobile presentation control is already installed'); + + control := TKMGamePresentationControl.Create(aContainer); + try + control.FullSize := True; + aContainer.Controls.InsertBack(control); + gPresentationControl := control; + except + control.Free; + raise; + end; +end; + + +procedure KMGameAppMobileAttachPresentation( + const aOnFrame: TKMGamePresentationFrameEvent; + const aOnResize: TKMGamePresentationResizeEvent); +begin + if gPresentationControl = nil then + raise Exception.Create('Mobile presentation control is not installed'); + if not Assigned(aOnFrame) then + raise Exception.Create('Mobile presentation frame callback is nil'); + if not Assigned(aOnResize) then + raise Exception.Create('Mobile presentation resize callback is nil'); + if Assigned(gPresentationOnFrame) or Assigned(gPresentationOnResize) then + raise Exception.Create('Mobile presentation already has an owner'); + + gPresentationOnFrame := aOnFrame; + gPresentationOnResize := aOnResize; +end; + + +procedure KMGameAppMobileDetachPresentation; +begin + gPresentationOnFrame := nil; + gPresentationOnResize := nil; +end; + + +procedure DeliverAvailability(aAvailable: Boolean); +begin + if not Assigned(gOnGraphicsContextAvailability) then + raise Exception.Create('Mobile graphics lifecycle has no attached owner'); + if gDeliveryKnown and (gLastDelivered = aAvailable) then + Exit; + + gOnGraphicsContextAvailability(aAvailable); + gLastDelivered := aAvailable; + gDeliveryKnown := True; +end; + + +procedure TerminateForUnsupportedGraphics(const aMessage: string); +begin + try + if (Application <> nil) and (Application.MainWindow <> nil) then + Application.MainWindow.MessageOK(aMessage, mtError); + finally + Halt(1); + end; +end; + + +procedure AcceptOpenedContext; +begin + if (GLVersion = nil) or (GLFeatures = nil) then + TerminateForUnsupportedGraphics( + 'KaM Remake Mobile requires OpenGL ES 3.0 or newer.' + LineEnding + + 'Graphics capability information is unavailable.'); + + if not GLFeatures.VersionES_3_0 then + TerminateForUnsupportedGraphics( + 'KaM Remake Mobile requires OpenGL ES 3.0 or newer.' + LineEnding + + 'Detected graphics context: ' + GLVersion.VersionString + '.'); + + DeliverAvailability(True); +end; + + +procedure CastleContextOpen; +begin + AcceptOpenedContext; +end; + + +procedure CastleContextClose; +begin + DeliverAvailability(False); +end; + + +procedure KMGameAppMobileAttach( + const aOnGraphicsContextAvailability: TKMGraphicsContextAvailabilityEvent); +var + openAdded, closeAdded: Boolean; +begin + if not Assigned(aOnGraphicsContextAvailability) then + raise Exception.Create('Mobile graphics lifecycle owner callback is nil'); + if Assigned(gOnGraphicsContextAvailability) then + raise Exception.Create('Mobile graphics lifecycle already has an owner'); + + gOnGraphicsContextAvailability := aOnGraphicsContextAvailability; + openAdded := False; + closeAdded := False; + try + ApplicationProperties.OnGLContextOpen.Add(@CastleContextOpen); + openAdded := True; + ApplicationProperties.OnGLContextClose.Add(@CastleContextClose); + closeAdded := True; + gRegistrationActive := True; + + if ApplicationProperties.IsGLContextOpen then + AcceptOpenedContext; + except + try + if ApplicationProperties(False) <> nil then + begin + if openAdded then + try + ApplicationProperties(False).OnGLContextOpen.Remove(@CastleContextOpen); + except + { Continue rolling back the other registration. } + end; + if closeAdded then + try + ApplicationProperties(False).OnGLContextClose.Remove(@CastleContextClose); + except + { Preserve the exception that caused attachment rollback. } + end; + end; + except + { Preserve the exception that caused attachment rollback. } + end; + gRegistrationActive := False; + gOnGraphicsContextAvailability := nil; + gDeliveryKnown := False; + gLastDelivered := False; + raise; + end; +end; + + +procedure KMGameAppMobileDetach; +begin + try + if gRegistrationActive and (ApplicationProperties(False) <> nil) then + try + ApplicationProperties(False).OnGLContextOpen.Remove(@CastleContextOpen); + finally + ApplicationProperties(False).OnGLContextClose.Remove(@CastleContextClose); + end; + finally + gRegistrationActive := False; + gOnGraphicsContextAvailability := nil; + gDeliveryKnown := False; + gLastDelivered := False; + end; +end; + +end. diff --git a/config/extra-paths.json b/config/extra-paths.json index 7ef4edc..6fb38b3 100755 --- a/config/extra-paths.json +++ b/config/extra-paths.json @@ -24,7 +24,8 @@ "src/KM_Main.pas", "src/res/KM_Resource.pas", "src/common/KM_Defaults.pas", - "src/res/KM_ResTypes.pas" + "src/res/KM_ResTypes.pas", + "src/utils/KromOGLUtils.pas" ], "source_paths": [ "code/resource" diff --git a/port-source/kam_remake/src/KM_GameApp.pas b/port-source/kam_remake/src/KM_GameApp.pas index 92594cf..76ef538 100644 --- a/port-source/kam_remake/src/KM_GameApp.pas +++ b/port-source/kam_remake/src/KM_GameApp.pas @@ -6,7 +6,7 @@ uses {$IFDEF FPC} Controls, {$ENDIF} Classes, Dialogs, SysUtils, - KM_CommonTypes, KM_Defaults, KM_RenderControl, KM_Video, + KM_CommonTypes, KM_Defaults, KM_Video, KM_Campaigns, KM_Game, KM_InterfaceDefaults, KM_InterfaceMainMenu, KM_InterfaceTypes, KM_Resource, KM_Music, KM_Maps, KM_MapTypes, KM_CampaignClasses, KM_Networking, KM_GameSettings, @@ -20,6 +20,11 @@ type //Methods relevant to gameplay TKMGameApp = class private + fGraphicsGeneration: QWord; + fGraphicsGenerationAccepted: Boolean; + fGraphicsAttemptGeneration: QWord; + fApplicationGraphicsReadyGeneration: QWord; + fGlobalTickCount: Cardinal; fIsExiting: Boolean; fIsLoading: Boolean; @@ -66,9 +71,14 @@ type procedure InitMainMenu(aScreenX, aScreenY: Word); function GetActiveInterface: TKMUserInterfaceCommon; + procedure GraphicsContextAvailabilityChanged(aAvailable: Boolean); + function IsCurrentGraphicsAttempt(aCandidateGeneration: QWord): Boolean; + procedure ReevaluateApplicationGraphicsReadiness(aCandidateGeneration: QWord); + function ApplicationGraphicsReadyForCurrentGeneration: Boolean; + procedure RenderPresentationFrame; public - constructor Create(aRenderControl: TKMRenderControl; aScreenX, aScreenY: Word; aVSync: Boolean; aOnLoadingStep: TKMEvent; + constructor Create(aScreenX, aScreenY: Word; aVSync: Boolean; aOnLoadingStep: TKMEvent; aOnLoadingText: TUnicodeStringEvent; aOnStatusBarUpdate: TProc; NoMusic: Boolean = False); destructor Destroy; override; procedure AfterConstruction(aReturnToOptions: Boolean); reintroduce; @@ -172,17 +182,22 @@ uses KM_GameSavePoints, KM_Cursor, KM_ResTexts, KM_ResKeys, KM_ResTypes, KM_IoGraphicUtils, KM_Settings, - KM_Saves, KM_CommonUtils + KM_Saves, KM_CommonUtils, KM_GameApp_Mobile {$IFDEF DBG_RNG_SPY}, KM_RandomChecks{$ENDIF}; { TKMGameApp } // Creating everything needed for MainMenu, game stuff is created on StartGame -constructor TKMGameApp.Create(aRenderControl: TKMRenderControl; aScreenX, aScreenY: Word; aVSync: Boolean; aOnLoadingStep: TKMEvent; +constructor TKMGameApp.Create(aScreenX, aScreenY: Word; aVSync: Boolean; aOnLoadingStep: TKMEvent; aOnLoadingText: TUnicodeStringEvent; aOnStatusBarUpdate: TProc; NoMusic: Boolean = False); begin inherited Create; + fGraphicsGeneration := 0; + fGraphicsGenerationAccepted := False; + fGraphicsAttemptGeneration := 0; + fApplicationGraphicsReadyGeneration := 0; + fCampaigns := TKMCampaignsCollection.Create; fOnStatusBarUpdate := aOnStatusBarUpdate; @@ -195,7 +210,8 @@ begin // it makes sense to store its settings along with the game's in the shared folder fServerSettings := TKMServerSettings.Create(slShared); - gRender := TKMRender.Create(aRenderControl, aScreenX, aScreenY, aVSync); + gRender := TKMRender.Create(aScreenX, aScreenY); + KMGameAppMobileAttach(GraphicsContextAvailabilityChanged); fChat := TKMChat.Create; @@ -238,6 +254,7 @@ begin fOnGameStart := GameStarted; fOnGameEnd := GameEnded; + KMGameAppMobileAttachPresentation(RenderPresentationFrame, Resize); end; @@ -250,12 +267,87 @@ begin end; +procedure TKMGameApp.GraphicsContextAvailabilityChanged(aAvailable: Boolean); +var + candidateGeneration: QWord; +begin + if aAvailable then + begin + if fGraphicsGeneration = High(QWord) then + raise Exception.Create('Graphics generation exhausted'); + + Inc(fGraphicsGeneration); + fGraphicsAttemptGeneration := fGraphicsGeneration; + fGraphicsGenerationAccepted := True; + fApplicationGraphicsReadyGeneration := 0; + candidateGeneration := fGraphicsAttemptGeneration; + + TKMRender.GraphicsContextChanged(True); + if not TKMRender.TextureBackendReady then + raise Exception.Create('Graphics texture backend is not ready after context restore'); + + if (gRes <> nil) and (gRes.DataState <> rlsNone) then + gRes.StartGameSpriteRecovery; + + ReevaluateApplicationGraphicsReadiness(candidateGeneration); + end + else + begin + fGraphicsGenerationAccepted := False; + fGraphicsAttemptGeneration := 0; + fApplicationGraphicsReadyGeneration := 0; + + TKMRender.GraphicsContextChanged(False); + end; +end; + + +procedure TKMGameApp.ReevaluateApplicationGraphicsReadiness(aCandidateGeneration: QWord); +begin + if not IsCurrentGraphicsAttempt(aCandidateGeneration) then + Exit; + + fApplicationGraphicsReadyGeneration := 0; + if not TKMRender.TextureBackendReady then + Exit; + if gGame <> nil then + begin + if gRes = nil then + Exit; + if not gRes.GameResourcesReady then + Exit; + end; + if IsCurrentGraphicsAttempt(aCandidateGeneration) then + fApplicationGraphicsReadyGeneration := aCandidateGeneration; +end; + + +function TKMGameApp.ApplicationGraphicsReadyForCurrentGeneration: Boolean; +begin + Result := fGraphicsGenerationAccepted + and (fGraphicsGeneration <> 0) + and (fGraphicsAttemptGeneration = fGraphicsGeneration) + and (fApplicationGraphicsReadyGeneration = fGraphicsGeneration); +end; + + +function TKMGameApp.IsCurrentGraphicsAttempt(aCandidateGeneration: QWord): Boolean; +begin + Result := (aCandidateGeneration <> 0) + and fGraphicsGenerationAccepted + and (aCandidateGeneration = fGraphicsGeneration) + and (aCandidateGeneration = fGraphicsAttemptGeneration); +end; + + { Destroy what was created } destructor TKMGameApp.Destroy; begin //Freeing network sockets and OpenAL can result in events like Resize/Paint occuring (seen in crash reports) //Set fIsExiting so we know to skip them fIsExiting := True; + KMGameAppMobileDetachPresentation; + KMGameAppMobileDetach; //We might have crashed part way through .Create, so we can't assume ANYTHING exists here. //Doing so causes a 2nd exception which overrides 1st. Hence check <> nil on everything except Free (TObject.Free does that already) @@ -372,6 +464,12 @@ begin end; +procedure TKMGameApp.RenderPresentationFrame; +begin + Render(False); +end; + + // This event happens every ~33ms if the Key is Down and holded procedure TKMGameApp.KeyDown(Key: Word; Shift: TShiftState; aIsFirst: Boolean); var @@ -540,6 +638,8 @@ end; procedure TKMGameApp.CreateGame(aGameMode: TKMGameMode); +var + candidateGeneration: QWord; begin //Reset controls if MainForm exists (KMR could be run without main form) if gMain <> nil then @@ -550,6 +650,8 @@ begin fBaseSaveWorkerThreadHolder, fAutoSaveWorkerThreadHolder, fSavePointWorkerThreadHolder); + candidateGeneration := fGraphicsAttemptGeneration; + ReevaluateApplicationGraphicsReadiness(candidateGeneration); end; @@ -624,6 +726,8 @@ end; //5. Free the game object //6. Switch to MainMenu procedure TKMGameApp.StopGame(aMsg: TKMGameResultMsg; const aTextMsg: UnicodeString = ''); +var + candidateGeneration: QWord; begin if gGame = nil then Exit; @@ -655,6 +759,8 @@ begin end; FreeThenNil(gGame); + candidateGeneration := fGraphicsAttemptGeneration; + ReevaluateApplicationGraphicsReadiness(candidateGeneration); gLog.AddTime('Gameplay ended - ' + GetEnumName(TypeInfo(TKMGameResultMsg), Integer(aMsg)) + ' /' + aTextMsg); end; @@ -677,6 +783,8 @@ end; procedure TKMGameApp.StopGameReturnToLobby; +var + candidateGeneration: QWord; begin if gGame = nil then Exit; @@ -692,6 +800,8 @@ begin fOnGameEnd(gGame.Params.Mode); FreeThenNil(gGame); + candidateGeneration := fGraphicsAttemptGeneration; + ReevaluateApplicationGraphicsReadiness(candidateGeneration); fNetworking.ReturnToLobby; //Clears gGame event pointers from Networking fMainMenuInterface.ReturnToLobby(RETURN_TO_LOBBY_SAVE); //Assigns Lobby event pointers to Networking and selects map @@ -1224,7 +1334,7 @@ begin if Self = nil then Exit; if SKIP_RENDER then Exit; if fIsExiting then Exit; - if gRender.Blind then Exit; + if not ApplicationGraphicsReadyForCurrentGeneration then Exit; if fIsLoading then Exit; //Don't render while toggling locale gRender.BeginFrame; @@ -1239,7 +1349,6 @@ begin gRender.RenderBrightness(gGameSettings.GFX.Brightness); - gRender.EndFrame; gRender.Query.QueriesSwapBuffers; if not aForPrintScreen @@ -1393,12 +1502,20 @@ end; // This is our real-time "thread", use it wisely procedure TKMGameApp.UpdateStateIdle(aFrameTime: Cardinal); +var + candidateGeneration: QWord; begin if gGame <> nil then gGame.UpdateStateIdle(aFrameTime); if gMusic <> nil then gMusic.UpdateStateIdle; if gSoundPlayer <> nil then gSoundPlayer.UpdateStateIdle; if fNetworking <> nil then fNetworking.UpdateStateIdle; - if gRes <> nil then gRes.UpdateStateIdle; + candidateGeneration := fGraphicsAttemptGeneration; + try + if gRes <> nil then + gRes.UpdateStateIdle; + finally + ReevaluateApplicationGraphicsReadiness(candidateGeneration); + end; end; diff --git a/port-source/kam_remake/src/render/KM_Render.pas b/port-source/kam_remake/src/render/KM_Render.pas index 27c1be8..163595a 100644 --- a/port-source/kam_remake/src/render/KM_Render.pas +++ b/port-source/kam_remake/src/render/KM_Render.pas @@ -5,7 +5,7 @@ uses {$IFDEF WDC} Windows, {$ENDIF} {$IFDEF Unix} LCLIntf, LCLType, OpenGLContext, {$ENDIF} dglOpenGL, - KM_RenderControl, KM_RenderQuery, KM_RenderTypes, KM_CommonTypes; + KM_RenderQuery, KM_RenderTypes, KM_CommonTypes; const @@ -25,17 +25,15 @@ type fFBO: Cardinal; fRenderBuf: Cardinal; - fRenderControl: TKMRenderControl; fOpenGL_Vendor, fOpenGL_Renderer, fOpenGL_Version: UnicodeString; fScreenX, fScreenY: Word; - fBlind: Boolean; fQuery: TKMRenderQuery; procedure InitFBO; procedure SaveBufferToFile(aUseFBOBuffer: Boolean; var aWidth, aHeight: Integer; var aPixelData: TKMCardinalArray); function GetMaxFBOSize: Cardinal; public - constructor Create(aRenderControl: TKMRenderControl; aScreenX, aScreenY: Integer; aVSync: Boolean); + constructor Create(aScreenX, aScreenY: Integer); destructor Destroy; override; procedure SetRenderMode(aRenderMode: TKMRenderMode); //Switch between 2D and 3D perspectives @@ -64,13 +62,10 @@ type property ScreenX: Word read fScreenX; property ScreenY: Word read fScreenY; - property Blind: Boolean read fBlind; - property Query: TKMRenderQuery read fQuery; procedure BeginFrame; procedure RenderBrightness(aValue: Byte); - procedure EndFrame; end; var @@ -91,22 +86,17 @@ const MAX_FBO_BUFFER_SIZE = CELL_SIZE_PX * (MAX_MAP_SIZE - 1); // (10200 = CELL_SIZE=40px)*255 { TKMRender } -constructor TKMRender.Create(aRenderControl: TKMRenderControl; aScreenX, aScreenY: Integer; aVSync: Boolean); +constructor TKMRender.Create(aScreenX, aScreenY: Integer); begin inherited Create; gLog.AddTime('Init Render started'); fFBOInited := False; - fBlind := aRenderControl = nil; - fRenderControl := aRenderControl; - if not fBlind then begin fQuery := TKMRenderQuery.Create; - fRenderControl.CreateRenderContext; - fMaxViewportDim := GetMaxViewportDim; gLog.AddTime('GL_MAX_VIEWPORT_DIM = ' + IntToStr(fMaxViewportDim)); @@ -129,10 +119,8 @@ begin fOpenGL_Renderer := UnicodeString(glGetString(GL_RENDERER)); gLog.AddNoTime('OpenGL Renderer: ' + fOpenGL_Renderer); fOpenGL_Version := UnicodeString(glGetString(GL_VERSION)); gLog.AddNoTime('OpenGL Version: ' + fOpenGL_Version); - SetupVSync(aVSync); - - Resize(aScreenX, aScreenY); end; + Resize(aScreenX, aScreenY); gLog.AddTime('Init Render Done'); end; @@ -141,7 +129,6 @@ destructor TKMRender.Destroy; begin if not fBlind then begin - fRenderControl.DestroyRenderContext; fQuery.Free; if fFBOInited then @@ -189,11 +176,8 @@ end; procedure TKMRender.Resize(aWidth, aHeight: Integer); begin - if fBlind then Exit; - fScreenX := max(aWidth, 1); fScreenY := max(aHeight, 1); - glViewport(0, 0, fScreenX, fScreenY); end; @@ -383,13 +367,4 @@ begin end; -procedure TKMRender.EndFrame; -begin - if fBlind then Exit; - - glFinish; - fRenderControl.SwapBuffers; -end; - - end. diff --git a/port-source/kam_remake/src/utils/KromOGLUtils.pas b/port-source/kam_remake/src/utils/KromOGLUtils.pas new file mode 100644 index 0000000..7f91b11 --- /dev/null +++ b/port-source/kam_remake/src/utils/KromOGLUtils.pas @@ -0,0 +1,275 @@ +unit KromOGLUtils; +{$I KaM_Remake.inc} +interface +uses + dglOpenGL, + {$IFDEF FPC} GL, LCLIntf, {$ENDIF} + {$IFDEF MSWindows} Windows {$ENDIF} + {$IFDEF Unix} LCLType, glx, x, xlib, xutil {$ENDIF} + ; + +{$IFDEF Unix} +type HGLRC = Integer; +type PFD_DRAW_TO_WINDOW = Integer; +type PFD_SUPPORT_OPENGL = Integer; +type PFD_DOUBLEBUFFER = Integer; +type PFD_TYPE_RGBA = Integer; +type PFD_MAIN_PLANE = Integer; +{$ENDIF} + +type + TColor4 = Cardinal; + TTexture = record Tex: Cardinal; U, V: Single; end; + + procedure SetRenderFrame(RenderFrame: HWND; out h_DC: HDC; out h_RC: HGLRC); + procedure SetRenderFrameAA(DummyFrame, RenderFrame: HWND; AntiAliasing: Byte; out h_DC: HDC; out h_RC: HGLRC); + + procedure BuildFont(h_DC: HDC; FontSize: Integer; FontWeight: Word = FW_NORMAL); + procedure glPrint(const text: AnsiString); + procedure glkScale(x: Single); + procedure glkQuad(Ax, Ay, Bx, By, Cx, Cy, Dx, Dy: Single); + procedure glkRect(Ax, Ay, Bx, By: Single); + + +implementation + + +function SetDCPixelFormat(h_DC: HDC; PixelFormat: Integer): Boolean; +var + nPixelFormat: Integer; + PixelDepth: Integer; + {$IFDEF MSWINDOWS} + pfd: TPixelFormatDescriptor; + {$ENDIF} +begin + PixelDepth := 32; //32bpp is common + {$IFDEF MSWINDOWS} + with pfd do begin + nSize := SizeOf(TPIXELFORMATDESCRIPTOR); // Size Of This Pixel Format Descriptor + nVersion := 1; // The version of this data structure + dwFlags := PFD_DRAW_TO_WINDOW // Buffer supports drawing to window + or PFD_SUPPORT_OPENGL // Buffer supports OpenGL drawing + or PFD_DOUBLEBUFFER; // Supports double buffering + iPixelType := PFD_TYPE_RGBA; // RGBA color format + cColorBits := PixelDepth; // OpenGL color depth + cRedBits := 0; // Number of red bitplanes + cRedShift := 0; // Shift count for red bitplanes + cGreenBits := 0; // Number of green bitplanes + cGreenShift := 0; // Shift count for green bitplanes + cBlueBits := 0; // Number of blue bitplanes + cBlueShift := 0; // Shift count for blue bitplanes + cAlphaBits := 0; // Not supported + cAlphaShift := 0; // Not supported + cAccumBits := 0; // No accumulation buffer + cAccumRedBits := 0; // Number of red bits in a-buffer + cAccumGreenBits := 0; // Number of green bits in a-buffer + cAccumBlueBits := 0; // Number of blue bits in a-buffer + cAccumAlphaBits := 0; // Number of alpha bits in a-buffer + cDepthBits := 16; // Specifies the depth of the depth buffer + cStencilBits := 8; // Turn off stencil buffer + cAuxBuffers := 0; // Not supported + iLayerType := PFD_MAIN_PLANE; // Ignored + bReserved := 0; // Number of overlay and underlay planes + dwLayerMask := 0; // Ignored + dwVisibleMask := 0; // Transparent color of underlay plane + dwDamageMask := 0; // Ignored + end; + + if PixelFormat = 0 then + nPixelFormat := ChoosePixelFormat(h_DC, @pfd) + else + nPixelFormat := PixelFormat; + + if nPixelFormat = 0 then begin + MessageBox(0, 'Unable to find a suitable pixel format', 'Error', MB_OK or MB_ICONERROR); + Result := False; + Exit; + end; + + //Even with known pixel format we still need to supply some PFD structure + if not SetPixelFormat(h_DC, nPixelFormat, @pfd) then begin + MessageBox(0, 'Unable to set the pixel format', 'Error', MB_OK or MB_ICONERROR); + Result := False; + Exit; + end; + + Result := True; + {$ENDIF} + //glXChooseVisual() should be on Uni insted of ChoosePixelFormatx +end; + + +function GetMultisamplePixelFormat(h_DC: HDC; AntiAliasing: Byte): Integer; +var + pixelFormat: Integer; + ValidFormat: Boolean; + NumFormats: GLUint; + iAttributes: array of GLint; +begin + Result := 0; + {$IFDEF MSWINDOWS} + if not WGL_ARB_multisample or not Assigned(wglChoosePixelFormatARB) then + Exit; + {$ENDIF} + SetLength(iAttributes,21); + iAttributes[0] := WGL_DRAW_TO_WINDOW_ARB; + iAttributes[1] := 1; + iAttributes[2] := WGL_SUPPORT_OPENGL_ARB; + iAttributes[3] := 1; + iAttributes[4] := WGL_ACCELERATION_ARB; + iAttributes[5] := WGL_FULL_ACCELERATION_ARB; + iAttributes[6] := WGL_COLOR_BITS_ARB; + iAttributes[7] := 24; + iAttributes[8] := WGL_ALPHA_BITS_ARB; + iAttributes[9] := 8; + iAttributes[10] := WGL_DEPTH_BITS_ARB; + iAttributes[11] := 16; + iAttributes[12] := WGL_STENCIL_BITS_ARB; + iAttributes[13] := 0; + iAttributes[14] := WGL_DOUBLE_BUFFER_ARB; + iAttributes[15] := 1; + iAttributes[16] := WGL_SAMPLE_BUFFERS_ARB; + iAttributes[17] := 1; + iAttributes[18] := WGL_SAMPLES_ARB; + iAttributes[19] := AntiAliasing; + iAttributes[20] := 0; + + //Try to find mode with slightly worse AA before giving up + repeat + iAttributes[19] := AntiAliasing; + {$IFDEF MSWINDOWS} + ValidFormat := wglChoosePixelFormatARB(h_dc, @iAttributes[0], nil, 1, @pixelFormat, @NumFormats); + {$ENDIF} + if ValidFormat and (NumFormats >= 1) then + begin + Result := pixelFormat; + Exit; + end; + AntiAliasing := AntiAliasing div 2; + until(AntiAliasing < 2); +end; + + +procedure SetContexts(RenderFrame: HWND; PixelFormat: Integer; out h_DC: HDC; out h_RC: HGLRC); +begin + {$IFDEF MSWINDOWS} + h_DC := GetDC(RenderFrame); + + if h_DC = 0 then + begin + MessageBox(HWND(nil), 'Unable to get a device context', 'Error', MB_OK or MB_ICONERROR); + Exit; + end; + + if not SetDCPixelFormat(h_DC, PixelFormat) then + Exit; + + h_RC := wglCreateContext(h_DC); + if h_RC = 0 then + begin + MessageBox(HWND(nil), 'Unable to create an OpenGL rendering context', 'Error', MB_OK or MB_ICONERROR); + Exit; + end; + + if not wglMakeCurrent(h_DC, h_RC) then + + begin + MessageBox(HWND(nil), 'Unable to activate OpenGL rendering context', 'Error', MB_OK or MB_ICONERROR); + Exit; + end; + {$ENDIF} +end; + + +procedure SetRenderFrame(RenderFrame: HWND; out h_DC: HDC; out h_RC: HGLRC); +begin + InitOpenGL; + SetContexts(RenderFrame, 0, h_DC, h_RC); + ReadExtensions; + ReadImplementationProperties; +end; + + +{The key problem is this: the function we use to get WGL extensions is, itself, an OpenGL extension. +Thus like any OpenGL function, it requires an OpenGL context to call it. So in order to get the +functions we need to create a context, we have to... create a context. + +Fortunately, this context does not need to be our final context. All we need to do is create a dummy +context to get function pointers, then use those functions directly. Unfortunately, Windows does not +allow recreation of a rendering context within a single HWND. We must destroy previous HWND context +and create final HWND context after we are finished with the dummy context.} +procedure SetRenderFrameAA(DummyFrame, RenderFrame: HWND; AntiAliasing: Byte; out h_DC: HDC; out h_RC: HGLRC); +var + PixelFormat: Integer; +begin + InitOpenGL; + SetContexts(DummyFrame, 0, h_DC, h_RC); + ReadExtensions; + ReadImplementationProperties; + + PixelFormat := GetMultisamplePixelFormat(h_DC, AntiAliasing); + {$IFDEF MSWINDOWS} + wglMakeCurrent(h_DC, 0); + wglDeleteContext(h_RC); + {$ENDIF} + SetContexts(RenderFrame, PixelFormat, h_DC, h_RC); + ReadExtensions; + ReadImplementationProperties; +end; + + +procedure BuildFont(h_DC: HDC; FontSize: Integer; FontWeight: Word = FW_NORMAL); +var + Font: HFONT; +begin +//New parameter FontSize=16 + font:=CreateFont(-abs(FontSize),0,0,0,FontWeight,0,0,0,ANSI_CHARSET, + OUT_TT_PRECIS,CLIP_DEFAULT_PRECIS, + ANTIALIASED_QUALITY,FF_DONTCARE or DEFAULT_PITCH, + 'Terminal'); + SelectObject(h_dc,font); + {$IFDEF MSWindows} + wglUseFontBitmaps(h_dc,0,128,20000); + {$ENDIF} + {$IFDEF Unix} + // Emulate these functions (with freetype we should be able to code a multi platform solution) + {$ENDIF} +end; + + +procedure glPrint(const text: AnsiString); +begin + if text = '' then Exit; + glPushAttrib(GL_LIST_BIT); + glListBase(20000); + glCallLists(length(text),GL_UNSIGNED_BYTE,Pchar(@text[1])); + glPopAttrib; +end; + + +procedure glkScale(x: Single); +begin + glScalef(x, x, x); +end; + + +procedure glkQuad(Ax, Ay, Bx, By, Cx, Cy, Dx, Dy: Single); +begin + glvertex2f(Ax, Ay); + glvertex2f(Bx, By); + glvertex2f(Cx, Cy); + glvertex2f(Dx, Dy); +end; + + +//Same as glkQuad, but requires on TopLeft and BottomRight coords +procedure glkRect(Ax, Ay, Bx, By: Single); +begin + glvertex2f(Ax, Ay); + glvertex2f(Bx, Ay); + glvertex2f(Bx, By); + glvertex2f(Ax, By); +end; + + +end.