Changeset 521 for GraphicTest/Packages/bgrabitmap/bgraopengl.pas

Timestamp:

Apr 17, 2019, 12:58:41 AM (5 years ago)

Author:

chronos

Message:

• Modified: Propagate project build mode options to used packages.
• Added: Check memory leaks using heaptrc.
• Modified: Update BGRABitmap package.

Location:

GraphicTest

Files:

• . (modified) (1 prop)
• Packages/bgrabitmap/bgraopengl.pas (modified) (15 diffs)

GraphicTest

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc

GraphicTest/Packages/bgrabitmap/bgraopengl.pas

@@ -9 +9 @@
   Classes, SysUtils, FPimage, BGRAGraphics,
   BGRAOpenGLType, BGRASpriteGL, BGRACanvasGL, GL, GLext, GLU, BGRABitmapTypes,
-  BGRAFontGL, BGRASSE;
+  BGRAFontGL, BGRASSE, BGRAMatrix3D;
 
 type
@@ -43 +43 @@
     property Width: integer read GetWidth;
     property Height: integer read GetHeight;
+  end;
+
+  { TBGLFrameBuffer }
+
+  TBGLFrameBuffer = class(TBGLCustomFrameBuffer)
+  protected
+    FHeight: integer;
+    FMatrix: TAffineMatrix;
+    FProjectionMatrix: TMatrix4D;
+    FTexture: IBGLTexture;
+    FFrameBufferId, FRenderBufferId: GLuint;
+    FWidth: integer;
+    FSettingMatrices: boolean;
+    function GetTexture: IBGLTexture; override;
+    function GetHandle: pointer; override;
+    function GetHeight: integer; override;
+    function GetMatrix: TAffineMatrix; override;
+    function GetProjectionMatrix: TMatrix4D; override;
+    function GetWidth: integer; override;
+    procedure SetMatrix(AValue: TAffineMatrix); override;
+    procedure SetProjectionMatrix(AValue: TMatrix4D); override;
+  public
+    constructor Create(AWidth,AHeight: integer);
+    function MakeTextureAndFree: IBGLTexture; override;
+    destructor Destroy; override;
   end;
 
@@ -120 +145 @@
 implementation
 
-uses BGRATransform{$IFDEF BGRABITMAP_USE_LCL}, BGRAText, BGRATextFX{$ENDIF}
-    ,BGRAMatrix3D;
+uses BGRABlurGL, BGRATransform{$IFDEF BGRABITMAP_USE_LCL}, BGRAText, BGRATextFX{$ENDIF};
 
 type
@@ -210 +234 @@
     procedure ToggleFlipY; override;
     procedure Bind(ATextureNumber: integer); override;
+    function FilterBlurMotion(ARadius: single; ABlurType: TRadialBlurType; ADirection: TPointF): IBGLTexture; override;
+    function FilterBlurRadial(ARadius: single; ABlurType: TRadialBlurType): IBGLTexture; override;
 
   end;
@@ -247 +273 @@
     procedure InternalStartPolygon(const pt: TPointF); override;
     procedure InternalStartTriangleFan(const pt: TPointF); override;
-    procedure InternalContinueShape(const pt: TPointF); override;
-
-    procedure InternalContinueShape(const pt: TPoint3D); override;
-    procedure InternalContinueShape(const pt: TPoint3D_128); override;
-    procedure InternalContinueShape(const pt, normal: TPoint3D_128); override;
+    procedure InternalContinueShape(const pt: TPointF); overload; override;
+
+    procedure InternalContinueShape(const pt: TPoint3D); overload; override;
+    procedure InternalContinueShape(const pt: TPoint3D_128); overload; override;
+    procedure InternalContinueShape(const pt, normal: TPoint3D_128); overload; override;
 
     procedure InternalEndShape; override;
@@ -268 +294 @@
     function GetBlendMode: TOpenGLBlendMode; override;
     procedure SetBlendMode(AValue: TOpenGLBlendMode); override;
+
+    procedure SetActiveFrameBuffer(AValue: TBGLCustomFrameBuffer); override;
   public
     destructor Destroy; override;
@@ -274 +302 @@
     procedure EndZBuffer; override;
     procedure WaitForGPU(AOption: TWaitForGPUOption); override;
+    function GetImage(x, y, w, h: integer): TBGRACustomBitmap; override;
+    function CreateFrameBuffer(AWidth, AHeight: integer): TBGLCustomFrameBuffer; override;
   end;
 
@@ -307 +337 @@
     function GetUniformVariable(AProgram: DWord; AName: string): DWord; override;
     function GetAttribVariable(AProgram: DWord; AName: string): DWord; override;
-    procedure SetUniformSingle(AVariable: DWord; const AValue; ACount: integer); override;
-    procedure SetUniformInteger(AVariable: DWord; const AValue; ACount: integer); override;
+    procedure SetUniformSingle(AVariable: DWord; const AValue; AElementCount, AComponentCount: integer); override;
+    procedure SetUniformInteger(AVariable: DWord; const AValue; AElementCount, AComponentCount: integer); override;
     procedure BindAttribute(AAttribute: TAttributeVariable); override;
     procedure UnbindAttribute(AAttribute: TAttributeVariable); override;
   end;
+
+{ TBGLFrameBuffer }
+
+procedure TBGLFrameBuffer.SetMatrix(AValue: TAffineMatrix);
+begin
+  if FSettingMatrices then Exit;
+  FSettingMatrices := true;
+  FMatrix:=AValue;
+  if FCanvas <> nil then
+    TBGLCustomCanvas(FCanvas).Matrix := AValue;
+  FSettingMatrices := false;
+end;
+
+function TBGLFrameBuffer.GetMatrix: TAffineMatrix;
+begin
+  result := FMatrix;
+end;
+
+function TBGLFrameBuffer.GetTexture: IBGLTexture;
+begin
+  result := FTexture.FlipY;
+end;
+
+function TBGLFrameBuffer.GetHandle: pointer;
+begin
+  result := @FFrameBufferId;
+end;
+
+function TBGLFrameBuffer.GetHeight: integer;
+begin
+  result := FHeight;
+end;
+
+function TBGLFrameBuffer.GetProjectionMatrix: TMatrix4D;
+begin
+  result := FProjectionMatrix;
+end;
+
+function TBGLFrameBuffer.GetWidth: integer;
+begin
+  result := FWidth;
+end;
+
+procedure TBGLFrameBuffer.SetProjectionMatrix(AValue: TMatrix4D);
+begin
+  if FSettingMatrices then Exit;
+  FSettingMatrices := true;
+  FProjectionMatrix:= AValue;
+  if FCanvas <> nil then
+    TBGLCustomCanvas(FCanvas).ProjectionMatrix := AValue;
+  FSettingMatrices := false;
+end;
+
+constructor TBGLFrameBuffer.Create(AWidth, AHeight: integer);
+var frameBufferStatus: GLenum;
+begin
+  if not Load_GL_version_3_0 then
+      raise exception.Create('Cannot load OpenGL 3.0');
+
+  FWidth := AWidth;
+  FHeight := AHeight;
+
+  FTexture := BGLTextureFactory.Create(nil,AWidth,AHeight,AWidth,AHeight);
+
+  //depth and stencil
+  glGenRenderbuffers(1, @FRenderBufferId);
+  glBindRenderbuffer(GL_RENDERBUFFER, FRenderBufferId);
+  glRenderbufferStorage(GL_RENDERBUFFER, GL_DEPTH24_STENCIL8, AWidth,AHeight);
+  glBindRenderbuffer(GL_RENDERBUFFER, 0);
+
+  glGenFramebuffers(1, @FFrameBufferId);
+  glBindFramebuffer(GL_FRAMEBUFFER, FFrameBufferId);
+
+  glFramebufferTexture2D(GL_FRAMEBUFFER, GL_COLOR_ATTACHMENT0, GL_TEXTURE_2D, PGLuint(FTexture.Handle)^, 0);
+  glFramebufferRenderbuffer(GL_FRAMEBUFFER, GL_DEPTH_STENCIL_ATTACHMENT, GL_RENDERBUFFER, FFrameBufferId);
+
+  frameBufferStatus:= glCheckFramebufferStatus(GL_FRAMEBUFFER);
+  glBindFramebuffer(GL_FRAMEBUFFER, 0);
+
+  if frameBufferStatus <> GL_FRAMEBUFFER_COMPLETE then
+  begin
+    glDeleteFramebuffers(1, @FFrameBufferId);
+    glDeleteRenderbuffers(1, @FRenderBufferId);
+    FTexture := nil;
+    raise exception.Create('Error ' + inttostr(frameBufferStatus) + ' while initializing frame buffer');
+  end;
+
+  UseOrthoProjection;
+  Matrix := AffineMatrixIdentity;
+end;
+
+function TBGLFrameBuffer.MakeTextureAndFree: IBGLTexture;
+begin
+  result := FTexture;
+  FTexture := nil;
+  Free;
+end;
+
+destructor TBGLFrameBuffer.Destroy;
+begin
+  glDeleteFramebuffers(1, @FFrameBufferId);
+  glDeleteRenderbuffers(1, @FRenderBufferId);
+  FTexture := nil;
+
+  inherited Destroy;
+end;
 
 procedure ApplyBlendMode(ABlendMode: TOpenGLBlendMode);
@@ -776 +912 @@
 
 procedure TBGLLighting.SetUniformSingle(AVariable: DWord;
-  const AValue; ACount: integer);
+  const AValue; AElementCount, AComponentCount: integer);
 begin
   NeedOpenGL2_0;
-  glUniform1fv(AVariable, ACount, @AValue);
+  case AComponentCount of
+    1: glUniform1fv(AVariable, AElementCount, @AValue);
+    2: glUniform2fv(AVariable, AElementCount, @AValue);
+    3: glUniform3fv(AVariable, AElementCount, @AValue);
+    4: glUniform4fv(AVariable, AElementCount, @AValue);
+    9: glUniformMatrix3fv(AVariable, AElementCount, GL_FALSE, @AValue);
+    16: glUniformMatrix4fv(AVariable, AElementCount, GL_FALSE, @AValue);
+  else
+    raise exception.Create('Unexpected number of components');
+  end;
 end;
 
 procedure TBGLLighting.SetUniformInteger(AVariable: DWord;
-  const AValue; ACount: integer);
+  const AValue; AElementCount, AComponentCount: integer);
 begin
   NeedOpenGL2_0;
-  glUniform1iv(AVariable, ACount, @AValue);
+  case AComponentCount of
+    1: glUniform1iv(AVariable, AElementCount, @AValue);
+    2: glUniform2iv(AVariable, AElementCount, @AValue);
+    3: glUniform3iv(AVariable, AElementCount, @AValue);
+    4: glUniform4iv(AVariable, AElementCount, @AValue);
+  else
+    raise exception.Create('Unexpected number of components');
+  end;
 end;
 
@@ -849 +1001 @@
 function TBGLCanvas.GetMatrix: TAffineMatrix;
 begin
-  result := FMatrix;
+  if ActiveFrameBuffer <> nil then
+    result := ActiveFrameBuffer.Matrix
+  else
+    result := FMatrix;
 end;
 
@@ -858 +1013 @@
   m := AffineMatrixToMatrix4D(AValue);
   glLoadMatrixf(@m);
-  FMatrix := AValue;
+
+  if ActiveFrameBuffer <> nil then
+    ActiveFrameBuffer.Matrix := AValue
+  else
+    FMatrix := AValue;
 end;
 
 function TBGLCanvas.GetProjectionMatrix: TMatrix4D;
 begin
-  result := FProjectionMatrix;
+  if ActiveFrameBuffer <> nil then
+    result := ActiveFrameBuffer.ProjectionMatrix
+  else
+    result := FProjectionMatrix;
 end;
 
 procedure TBGLCanvas.SetProjectionMatrix(const AValue: TMatrix4D);
 begin
-  FProjectionMatrix := AValue;
   glMatrixMode(GL_PROJECTION);
   glLoadMatrixf(@AValue);
   glMatrixMode(GL_MODELVIEW);
+
+  if ActiveFrameBuffer <> nil then
+    ActiveFrameBuffer.ProjectionMatrix := AValue
+  else
+    FProjectionMatrix := AValue;
 end;
 
@@ -1015 +1181 @@
 end;
 
+function TBGLCanvas.GetImage(x, y, w, h: integer): TBGRACustomBitmap;
+begin
+  NeedOpenGL2_0;
+  result := BGRABitmapFactory.Create(w,h);
+  if TBGRAPixel_RGBAOrder then
+    glReadPixels(x,self.Height-y-h, w,h, GL_RGBA, GL_UNSIGNED_BYTE, result.Data)
+  else
+    glReadPixels(x,self.Height-y-h, w,h, GL_BGRA, GL_UNSIGNED_BYTE, result.Data);
+end;
+
+function TBGLCanvas.CreateFrameBuffer(AWidth, AHeight: integer): TBGLCustomFrameBuffer;
+begin
+  Result:= TBGLFrameBuffer.Create(AWidth,AHeight);
+end;
+
 procedure TBGLCanvas.EnableScissor(AValue: TRect);
 begin
@@ -1034 +1215 @@
 begin
   FBlendMode := AValue;
+end;
+
+procedure TBGLCanvas.SetActiveFrameBuffer(AValue: TBGLCustomFrameBuffer);
+var
+  m: TMatrix4D;
+begin
+  if AValue = ActiveFrameBuffer then exit;
+  inherited SetActiveFrameBuffer(AValue);
+  if AValue = nil then
+    glBindFramebuffer(GL_FRAMEBUFFER, 0)
+  else
+    glBindFramebuffer(GL_FRAMEBUFFER, PGLuint(AValue.Handle)^);
+
+  glViewPort(0,0,Width,Height);
+
+  glMatrixMode(GL_PROJECTION);
+  m := ProjectionMatrix;
+  glLoadMatrixf(@m);
+
+  glMatrixMode(GL_MODELVIEW);
+  m := AffineMatrixToMatrix4D(Matrix);
+  glLoadMatrixf(@m);
 end;
 
@@ -1377 +1580 @@
 procedure TBGLTexture.ToggleFlipY;
 begin
-  FFlipX := not FFlipY;
+  FFlipY := not FFlipY;
 end;
 
@@ -1395 +1598 @@
 end;
 
+function TBGLTexture.FilterBlurMotion(ARadius: single; ABlurType: TRadialBlurType; ADirection: TPointF): IBGLTexture;
+var shader: TBGLCustomShader;
+  blurName: string;
+begin
+  blurName := 'TBGLBlurShader(' + RadialBlurTypeToStr[ABlurType] + ')';
+  shader := BGLCanvas.Lighting.Shader[blurName];
+  if shader = nil then
+  begin
+    shader := TBGLBlurShader.Create(BGLCanvas, ABlurType);
+    BGLCanvas.Lighting.Shader[blurName] := shader;
+  end;
+  with (shader as TBGLBlurShader) do
+  begin
+    Radius := ARadius;
+    Direction := ADirection;
+    result := FilterBlurMotion(self);
+  end;
+end;
+
+function TBGLTexture.FilterBlurRadial(ARadius: single; ABlurType: TRadialBlurType): IBGLTexture;
+var shader: TBGLCustomShader;
+  blurName: String;
+begin
+  blurName := 'TBGLBlurShader(' + RadialBlurTypeToStr[ABlurType] + ')';
+  shader := BGLCanvas.Lighting.Shader[blurName];
+  if shader = nil then
+  begin
+    shader := TBGLBlurShader.Create(BGLCanvas, ABlurType);
+    BGLCanvas.Lighting.Shader[blurName] := shader;
+  end;
+  with (shader as TBGLBlurShader) do
+  begin
+    Radius := ARadius;
+    result := FilterBlurRadial(self);
+  end;
+end;
+
 procedure TBGLTexture.Init(ATexture: TBGLTextureHandle; AWidth,
   AHeight: integer; AOwned: boolean);

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc