Стартовый пул

2024-04-02 08:46:59 +03:00
parent fd57fffd3a
commit 3bb34d000b
5591 changed files with 3291734 additions and 0 deletions
--- a/bgrabitmap/bglcontrols/bglcontrols.lpk
+++ b/bgrabitmap/bglcontrols/bglcontrols.lpk
@@ -0,0 +1,70 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <Package Version="4">
+    <PathDelim Value="\"/>
+    <Name Value="BGLControls"/>
+    <Type Value="RunAndDesignTime"/>
+    <Author Value="Circular"/>
+    <CompilerOptions>
+      <Version Value="11"/>
+      <PathDelim Value="\"/>
+      <SearchPaths>
+        <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\$(FPCVer)"/>
+      </SearchPaths>
+      <Parsing>
+        <SyntaxOptions>
+          <UseAnsiStrings Value="False"/>
+        </SyntaxOptions>
+      </Parsing>
+      <CodeGeneration>
+        <Optimizations>
+          <OptimizationLevel Value="3"/>
+          <VariablesInRegisters Value="True"/>
+        </Optimizations>
+      </CodeGeneration>
+      <Linking>
+        <Debugging>
+          <GenerateDebugInfo Value="False"/>
+        </Debugging>
+      </Linking>
+    </CompilerOptions>
+    <Description Value="Drawing routines with alpha blending and antialiasing"/>
+    <License Value="modified LGPL"/>
+    <Version Major="1" Minor="2"/>
+    <Files Count="2">
+      <Item1>
+        <Filename Value="bglvirtualscreen_icon.lrs"/>
+        <Type Value="LRS"/>
+      </Item1>
+      <Item2>
+        <Filename Value="bglvirtualscreen.pas"/>
+        <HasRegisterProc Value="True"/>
+        <UnitName Value="BGLVirtualScreen"/>
+      </Item2>
+    </Files>
+    <RequiredPkgs Count="4">
+      <Item1>
+        <PackageName Value="BGRABitmapPack"/>
+      </Item1>
+      <Item2>
+        <PackageName Value="lazopenglcontext"/>
+      </Item2>
+      <Item3>
+        <PackageName Value="LCL"/>
+      </Item3>
+      <Item4>
+        <PackageName Value="FCL"/>
+        <MinVersion Major="1" Valid="True"/>
+      </Item4>
+    </RequiredPkgs>
+    <UsageOptions>
+      <UnitPath Value="$(PkgOutDir)"/>
+    </UsageOptions>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <CustomOptions Items="ExternHelp" Version="2">
+      <_ExternHelp Items="Count"/>
+    </CustomOptions>
+  </Package>
+</CONFIG>
--- a/bgrabitmap/bglcontrols/bglcontrols.pas
+++ b/bgrabitmap/bglcontrols/bglcontrols.pas
@@ -0,0 +1,21 @@
+{ This file was automatically created by Lazarus. Do not edit!
+  This source is only used to compile and install the package.
+ }
+
+unit BGLControls;
+
+interface
+
+uses
+  BGLVirtualScreen, LazarusPackageIntf;
+
+implementation
+
+procedure Register;
+begin
+  RegisterUnit('BGLVirtualScreen', @BGLVirtualScreen.Register);
+end;
+
+initialization
+  RegisterPackage('BGLControls', @Register);
+end.
--- a/bgrabitmap/bglcontrols/bglvirtualscreen.pas
+++ b/bgrabitmap/bglcontrols/bglvirtualscreen.pas
@@ -0,0 +1,435 @@
+// SPDX-License-Identifier: LGPL-3.0-linking-exception
+unit BGLVirtualScreen;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, BGRAClasses, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
+  ExtCtrls, BGRABitmapTypes, BGRAOpenGL, OpenGLContext, BGRACanvasGL,
+  BGRASpriteGL;
+
+type
+  TCustomBGLVirtualScreen = class;
+  TBGLRedrawEvent = procedure (Sender: TObject; BGLContext: TBGLContext) of object;
+  TBGLLoadTexturesEvent = procedure (Sender: TObject; BGLContext: TBGLContext) of object;
+  TBGLElapseEvent = procedure (Sender: TObject; BGLContext: TBGLContext; ElapsedMs: integer) of object;
+  TBGLFramesPerSecondEvent = procedure (Sender: TObject; BGLContext: TBGLContext; FramesPerSecond: integer) of object;
+  TBGLUseContextCallback = procedure (Sender: TObject; BGLContext: TBGLContext; Data: Pointer) of object;
+
+  { TCustomBGLVirtualScreen }
+
+  TCustomBGLVirtualScreen = class(TCustomOpenGLControl)
+  private
+    { Private declarations }
+    FOnRedraw: TBGLRedrawEvent;
+    FOnLoadTextures: TBGLLoadTexturesEvent;
+    FOnUnloadTextures: TBGLLoadTexturesEvent;
+    FOnElapse: TBGLElapseEvent;
+    FOnFramesPerSecond: TBGLFramesPerSecondEvent;
+    FSmoothedElapse: boolean;
+    FTexturesLoaded: boolean;
+    FBevelInner, FBevelOuter: TPanelBevel;
+    FBevelWidth:  TBevelWidth;
+    FBorderWidth: TBorderWidth;
+    FRedrawOnIdle: boolean;
+    FSprites: TBGLCustomSpriteEngine;
+    FElapseAccumulator, FElapseCount, FStoredFPS: integer;
+    FSmoothedElapseAccumulator: single;
+    FContextPrepared: boolean;
+    FOldSprites: TBGLCustomSpriteEngine;
+    FShaderList,FOldShaderList: TStringList;
+    function GetCanvas: TBGLCustomCanvas;
+    procedure SetBevelInner(const AValue: TPanelBevel);
+    procedure SetBevelOuter(const AValue: TPanelBevel);
+    procedure SetBevelWidth(const AValue: TBevelWidth);
+    procedure SetBorderWidth(const AValue: TBorderWidth);
+    procedure SetRedrawOnIdle(AValue: Boolean);
+    procedure SetSmoothedElapse(AValue: boolean);
+  protected
+    class var FToRedrawOnIdle: array of TCustomBGLVirtualScreen;
+    { Protected declarations }
+    procedure RedrawContent(ctx: TBGLContext); virtual;
+    procedure SetEnabled(Value: boolean); override;
+    procedure OnAppIdle(Sender: TObject; var Done: Boolean);
+    procedure LoadTextures; virtual;
+    function PrepareBGLContext: TBGLContext;
+    procedure ReleaseBGLContext(ctx: TBGLContext);
+  public
+    { Public declarations }
+    procedure DoOnPaint; override;
+    procedure QueryLoadTextures; virtual;
+    procedure UnloadTextures; virtual;
+    procedure UseContext(ACallback: TBGLUseContextCallback; AData: Pointer = nil);
+    constructor Create(TheOwner: TComponent); override;
+    destructor Destroy; override;
+  public
+    property Canvas: TBGLCustomCanvas read GetCanvas;
+    property Sprites: TBGLCustomSpriteEngine read FSprites;
+    property OnLoadTextures: TBGLLoadTexturesEvent Read FOnLoadTextures Write FOnLoadTextures;
+    property OnUnloadTextures: TBGLLoadTexturesEvent Read FOnUnloadTextures Write FOnUnloadTextures;
+    property OnRedraw: TBGLRedrawEvent Read FOnRedraw Write FOnRedraw;
+    property OnElapse: TBGLElapseEvent Read FOnElapse Write FOnElapse;
+    property OnFramesPerSecond: TBGLFramesPerSecondEvent Read FOnFramesPerSecond Write FOnFramesPerSecond;
+    property RedrawOnIdle: Boolean read FRedrawOnIdle write SetRedrawOnIdle default False;
+    property BorderWidth: TBorderWidth Read FBorderWidth Write SetBorderWidth default 0;
+    property BevelInner: TPanelBevel Read FBevelInner Write SetBevelInner default bvNone;
+    property BevelOuter: TPanelBevel Read FBevelOuter Write SetBevelOuter default bvNone;
+    property BevelWidth: TBevelWidth Read FBevelWidth Write SetBevelWidth default 1;
+    property SmoothedElapse: boolean read FSmoothedElapse write SetSmoothedElapse default False;
+  end;
+
+  TBGLVirtualScreen = class(TCustomBGLVirtualScreen)
+  published
+    property OnRedraw;
+    property Align;
+    property Anchors;
+    property AutoSize;
+    property BorderSpacing;
+    property BevelInner;
+    property BevelOuter;
+    property BevelWidth;
+    property BidiMode;
+    property BorderWidth;
+    property BorderStyle;
+    property Caption;
+    property ChildSizing;
+    property ClientHeight;
+    property ClientWidth;
+    property Color;
+    property Constraints;
+    property DockSite;
+    property DragCursor;
+    property DragKind;
+    property DragMode;
+    property Enabled;
+    property Font;
+    property ParentBidiMode;
+    property ParentColor;
+    property ParentFont;
+    property ParentShowHint;
+    property PopupMenu;
+    property RedrawOnIdle;
+    property ShowHint;
+    property TabOrder;
+    property TabStop;
+    property UseDockManager default True;
+    property Visible;
+    property OnClick;
+    property OnContextPopup;
+    property OnDockDrop;
+    property OnDockOver;
+    property OnDblClick;
+    property OnDragDrop;
+    property OnDragOver;
+    property OnElapse;
+    property OnEndDock;
+    property OnEndDrag;
+    property OnEnter;
+    property OnExit;
+    property OnFramesPerSecond;
+    property OnGetSiteInfo;
+    property OnGetDockCaption;
+    property OnLoadTextures;
+    property OnUnloadTextures;
+    property OnMouseDown;
+    property OnMouseEnter;
+    property OnMouseLeave;
+    property OnMouseMove;
+    property OnMouseUp;
+    property OnMouseWheel;
+    property OnMouseWheelDown;
+    property OnMouseWheelUp;
+    property OnResize;
+    property OnStartDock;
+    property OnStartDrag;
+    property OnUnDock;
+    property SmoothedElapse;
+  end;
+
+procedure Register;
+
+implementation
+
+procedure Register;
+begin
+  {$I bglvirtualscreen_icon.lrs}
+  RegisterComponents('OpenGL', [TBGLVirtualScreen]);
+end;
+
+{ TCustomBGLVirtualScreen }
+
+procedure TCustomBGLVirtualScreen.SetBevelInner(const AValue: TPanelBevel);
+begin
+  if FBevelInner = AValue then
+    exit;
+  FBevelInner := AValue;
+  Invalidate;
+end;
+
+function TCustomBGLVirtualScreen.GetCanvas: TBGLCustomCanvas;
+begin
+  result := BGLCanvas;
+end;
+
+procedure TCustomBGLVirtualScreen.SetBevelOuter(const AValue: TPanelBevel);
+begin
+  if FBevelOuter = AValue then
+    exit;
+  FBevelOuter := AValue;
+  Invalidate;
+end;
+
+procedure TCustomBGLVirtualScreen.SetBevelWidth(const AValue: TBevelWidth);
+begin
+  if FBevelWidth = AValue then
+    exit;
+  FBevelWidth := AValue;
+  Invalidate;
+end;
+
+procedure TCustomBGLVirtualScreen.SetBorderWidth(const AValue: TBorderWidth);
+begin
+  if FBorderWidth = AValue then
+    exit;
+  FBorderWidth := AValue;
+  Invalidate;
+end;
+
+procedure TCustomBGLVirtualScreen.SetRedrawOnIdle(AValue: Boolean);
+var
+  i: Integer;
+  j: Integer;
+begin
+  if FRedrawOnIdle=AValue then Exit;
+  FRedrawOnIdle:=AValue;
+
+  if FRedrawOnIdle then
+  begin
+    if length(FToRedrawOnIdle)= 0 then
+      Application.AddOnIdleHandler(@OnAppIdle);
+    setlength(FToRedrawOnIdle, length(FToRedrawOnIdle)+1);
+    FToRedrawOnIdle[high(FToRedrawOnIdle)] := self;
+  end
+  else
+  if length(FToRedrawOnIdle)> 0 then
+  begin
+    for i := 0 to high(FToRedrawOnIdle) do
+    begin
+      if FToRedrawOnIdle[i]=self then
+      begin
+        for j := i to high(FToRedrawOnIdle)-1 do
+          FToRedrawOnIdle[j] := FToRedrawOnIdle[j+1];
+        setlength(FToRedrawOnIdle, length(FToRedrawOnIdle)-1);
+        break;
+      end;
+    end;
+    if length(FToRedrawOnIdle) = 0 then
+       Application.RemoveOnIdleHandler(@OnAppIdle);
+  end;
+end;
+
+procedure TCustomBGLVirtualScreen.SetSmoothedElapse(AValue: boolean);
+begin
+  if FSmoothedElapse=AValue then Exit;
+  FSmoothedElapse:=AValue;
+end;
+
+procedure TCustomBGLVirtualScreen.DoOnPaint;
+var
+  ctx: TBGLContext;
+  knownFPS: Integer;
+begin
+  if not FTexturesLoaded then LoadTextures;
+
+  ctx := PrepareBGLContext;
+  if Color = clNone then
+    BGLViewPort(ClientWidth,ClientHeight)
+  else
+  if Color = clDefault then
+    BGLViewPort(ClientWidth,ClientHeight,ColorToBGRA(clWindow))
+  else
+    BGLViewPort(ClientWidth,ClientHeight,ColorToBGRA(Color));
+
+  RedrawContent(ctx);
+  inherited DoOnPaint;
+  SwapBuffers;
+
+  inc(FElapseAccumulator, FrameDiffTimeInMSecs);
+  Inc(FElapseCount);
+  if FElapseAccumulator >= 2000 then
+  begin
+    FStoredFPS := 1000*FElapseCount div FElapseAccumulator;
+    if Assigned(FOnFramesPerSecond) then
+      FOnFramesPerSecond(self, ctx, FStoredFPS);
+    FElapseAccumulator := 0;
+    FElapseCount := 0;
+  end;
+
+  If Assigned(FOnElapse) then
+  begin
+    if SmoothedElapse then
+    begin
+      If FStoredFPS <> 0 then
+        knownFPS:= FStoredFPS
+      else
+      if FElapseAccumulator >= 500 then
+        knownFPS := 1000*FElapseCount div FElapseAccumulator
+      else
+        knownFPS := 0;
+
+      if knownFPS > 0 then
+      begin
+        IncF(FSmoothedElapseAccumulator, 1000/knownFPS);
+      end else
+        IncF(FSmoothedElapseAccumulator, FrameDiffTimeInMSecs);
+
+      FOnElapse(self, ctx, Trunc(FSmoothedElapseAccumulator));
+      DecF(FSmoothedElapseAccumulator, Trunc(FSmoothedElapseAccumulator));
+    end else
+      FOnElapse(self, ctx, FrameDiffTimeInMSecs);
+  end;
+
+  ReleaseBGLContext(ctx);
+end;
+
+procedure TCustomBGLVirtualScreen.QueryLoadTextures;
+begin
+  FTexturesLoaded := false;
+end;
+
+procedure TCustomBGLVirtualScreen.LoadTextures;
+var ctx: TBGLContext;
+begin
+  if MakeCurrent then
+  begin
+    if Assigned(FOnLoadTextures) then
+    begin
+      ctx := PrepareBGLContext;
+      FOnLoadTextures(self, ctx);
+      ReleaseBGLContext(ctx);
+    end;
+    FTexturesLoaded:= true;
+  end;
+end;
+
+function TCustomBGLVirtualScreen.PrepareBGLContext: TBGLContext;
+begin
+  if FContextPrepared then
+    raise exception.Create('Context already prepared');
+  FOldSprites := BGRASpriteGL.BGLSpriteEngine;
+  BGRASpriteGL.BGLSpriteEngine := FSprites;
+  FOldShaderList := BGLCanvas.Lighting.ShaderList;
+  BGLCanvas.Lighting.ShaderList := FShaderList;
+  result.Canvas := BGLCanvas;
+  result.Sprites := FSprites;
+  FContextPrepared := true;
+end;
+
+procedure TCustomBGLVirtualScreen.ReleaseBGLContext(ctx: TBGLContext);
+begin
+  if not FContextPrepared then
+    raise exception.Create('Context not prepared');
+  ctx.Canvas.Lighting.ShaderList := FOldShaderList;
+  BGRASpriteGL.BGLSpriteEngine := FOldSprites;
+  FContextPrepared := false;
+end;
+
+procedure TCustomBGLVirtualScreen.UnloadTextures;
+var ctx: TBGLContext;
+begin
+  if MakeCurrent then
+  begin
+    ctx := PrepareBGLContext;
+    if Assigned(FOnUnloadTextures) then FOnUnloadTextures(self, ctx);
+    FSprites.Clear;
+    ctx.Canvas.Lighting.FreeShaders;
+    ReleaseBGLContext(ctx);
+    FTexturesLoaded := false;
+  end;
+end;
+
+procedure TCustomBGLVirtualScreen.UseContext(ACallback: TBGLUseContextCallback; AData: Pointer);
+var
+  ctx: TBGLContext;
+begin
+  if not MakeCurrent then
+    raise exception.Create('Unable to switch to the OpenGL context');
+  ctx := PrepareBGLContext;
+  try
+    ACallback(self, ctx, AData);
+  finally
+    ReleaseBGLContext(ctx);
+  end;
+end;
+
+procedure TCustomBGLVirtualScreen.RedrawContent(ctx: TBGLContext);
+var
+  ARect: TRect;
+  w: integer;
+begin
+  ARect := rect(0,0,ctx.Canvas.Width,ctx.Canvas.Height);
+  w := BevelWidth;
+  if w = 0 then w := 1;
+
+  // if BevelOuter is set then draw a frame with BevelWidth
+  if (BevelOuter <> bvNone) and (w > 0) then
+    ctx.Canvas.Frame3d(ARect, w, BevelOuter); // Note: Frame3D inflates ARect
+
+  ARect.Inflate(-BorderWidth, -BorderWidth);
+
+  // if BevelInner is set then skip the BorderWidth and draw a frame with BevelWidth
+  if (BevelInner <> bvNone) and (w > 0) then
+    ctx.Canvas.Frame3d(ARect, w, BevelInner); // Note: Frame3D inflates ARect
+
+  if Assigned(FOnRedraw) then
+    FOnRedraw(self, ctx);
+end;
+
+procedure TCustomBGLVirtualScreen.SetEnabled(Value: boolean);
+begin
+  if Value <> Enabled then Invalidate;
+  inherited SetEnabled(Value);
+end;
+
+procedure TCustomBGLVirtualScreen.OnAppIdle(Sender: TObject; var Done: Boolean);
+var
+  i: Integer;
+begin
+  if length(FToRedrawOnIdle) > 0 then
+  begin
+    for i := 0 to high(FToRedrawOnIdle) do
+      if not (csDesigning in FToRedrawOnIdle[i].ComponentState) then
+        FToRedrawOnIdle[i].Invalidate;
+    Done:=false;
+  end;
+end;
+
+constructor TCustomBGLVirtualScreen.Create(TheOwner: TComponent);
+begin
+  inherited Create(TheOwner);
+  FTexturesLoaded:= False;
+  AutoResizeViewport := true;
+  FSprites := TBGLDefaultSpriteEngine.Create;
+  FShaderList:= TStringList.Create;
+  FStoredFPS := 0;
+  FElapseAccumulator := 0;
+  FElapseCount := 0;
+  FSmoothedElapseAccumulator := 0;
+end;
+
+destructor TCustomBGLVirtualScreen.Destroy;
+var
+  i: Integer;
+begin
+  for i := 0 to FShaderList.Count-1 do
+    FShaderList.Objects[i].Free;
+  FShaderList.Free;
+  RedrawOnIdle := false;
+  FSprites.Free;
+  inherited Destroy;
+end;
+
+end.
+