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

2024-04-02 08:46:59 +03:00
parent fd57fffd3a
commit 3bb34d000b
5591 changed files with 3291734 additions and 0 deletions
--- a/bgrabitmap/test/testvirtualscreen/project1.ico
+++ b/bgrabitmap/test/testvirtualscreen/project1.ico
--- a/bgrabitmap/test/testvirtualscreen/project1.lpi
+++ b/bgrabitmap/test/testvirtualscreen/project1.lpi
@@ -0,0 +1,77 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="10"/>
+    <General>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="project1"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <Icon Value="0"/>
+    </General>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="2">
+      <Item1>
+        <PackageName Value="bgracontrols"/>
+      </Item1>
+      <Item2>
+        <PackageName Value="LCL"/>
+      </Item2>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="project1.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="unit1.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="Form1"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="Form"/>
+        <UnitName Value="Unit1"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="project1"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Linking>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>
--- a/bgrabitmap/test/testvirtualscreen/project1.lpr
+++ b/bgrabitmap/test/testvirtualscreen/project1.lpr
@@ -0,0 +1,21 @@
+program project1;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms, Unit1
+  { you can add units after this };
+
+{$R *.res}
+
+begin
+  RequireDerivedFormResource:=True;
+  Application.Initialize;
+  Application.CreateForm(TForm1, Form1);
+  Application.Run;
+end.
+
--- a/bgrabitmap/test/testvirtualscreen/unit1.lfm
+++ b/bgrabitmap/test/testvirtualscreen/unit1.lfm
@@ -0,0 +1,67 @@
+object Form1: TForm1
+  Left = 472
+  Height = 339
+  Top = 154
+  Width = 504
+  Caption = 'Test TBGRAVirtualScreen partial redraw'
+  ClientHeight = 339
+  ClientWidth = 504
+  OnCreate = FormCreate
+  OnDestroy = FormDestroy
+  LCLVersion = '1.8.2.0'
+  WindowState = wsMaximized
+  object VirtualScreen: TBGRAVirtualScreen
+    Left = 0
+    Height = 305
+    Top = 34
+    Width = 504
+    OnRedraw = VirtualScreenRedraw
+    Align = alClient
+    Alignment = taLeftJustify
+    Color = clWhite
+    ParentColor = False
+    TabOrder = 0
+  end
+  object Panel1: TPanel
+    Left = 0
+    Height = 34
+    Top = 0
+    Width = 504
+    Align = alTop
+    ClientHeight = 34
+    ClientWidth = 504
+    TabOrder = 1
+    object Label1: TLabel
+      Left = 6
+      Height = 17
+      Top = 8
+      Width = 30
+      Caption = 'Balls:'
+      ParentColor = False
+    end
+    object SpinEdit1: TSpinEdit
+      Left = 48
+      Height = 27
+      Top = 3
+      Width = 66
+      MinValue = 1
+      OnChange = SpinEdit1Change
+      TabOrder = 0
+      Value = 5
+    end
+    object CheckBox1: TCheckBox
+      Left = 128
+      Height = 22
+      Top = 5
+      Width = 86
+      Caption = 'Full redraw'
+      TabOrder = 1
+    end
+  end
+  object Timer1: TTimer
+    Interval = 10
+    OnTimer = Timer1Timer
+    left = 89
+    top = 75
+  end
+end
--- a/bgrabitmap/test/testvirtualscreen/unit1.pas
+++ b/bgrabitmap/test/testvirtualscreen/unit1.pas
@@ -0,0 +1,173 @@
+unit Unit1;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
+  StdCtrls, Spin, BGRAVirtualScreen, BGRABitmap, BGRABitmapTypes;
+
+type
+
+  { TForm1 }
+
+  TForm1 = class(TForm)
+    CheckBox1: TCheckBox;
+    Label1: TLabel;
+    Panel1: TPanel;
+    SpinEdit1: TSpinEdit;
+    VirtualScreen: TBGRAVirtualScreen;
+    Timer1: TTimer;
+    procedure FormDestroy(Sender: TObject);
+    procedure SpinEdit1Change(Sender: TObject);
+    procedure VirtualScreenRedraw(Sender: TObject; Bitmap: TBGRABitmap);
+    procedure FormCreate(Sender: TObject);
+    procedure Timer1Timer(Sender: TObject);
+  private
+    FInit: boolean;
+    procedure InitBalls(ACount: integer);
+    procedure Init;
+    function GetBallRect(AIndex: integer): TRect;
+  public
+    ballRadius: integer;
+    background: TBGRABitmap;
+    balls: array of record
+          ballPos: TPoint;
+          ballSpeed: TPoint;
+          ballColor: TBGRAPixel;
+      end;
+  end;
+
+var
+  Form1: TForm1;
+
+implementation
+
+{$R *.lfm}
+
+uses BGRAGradients;
+
+{ TForm1 }
+
+procedure TForm1.VirtualScreenRedraw(Sender: TObject; Bitmap: TBGRABitmap);
+var
+  i: Integer;
+begin
+  Init;
+  Bitmap.FillRect(rect(0,0,Bitmap.Width,Bitmap.Height), background, dmSet);
+  for i := 0 to high(balls) do
+    with balls[i] do
+      Bitmap.EllipseAntialias(ballPos.x,ballPos.y, ballRadius,ballRadius, BGRABlack, 1, ballColor);
+end;
+
+procedure TForm1.SpinEdit1Change(Sender: TObject);
+begin
+  initBalls(SpinEdit1.Value);
+end;
+
+procedure TForm1.FormDestroy(Sender: TObject);
+begin
+  background.Free;
+end;
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+  VirtualScreen.BitmapAutoScale:= false;
+end;
+
+procedure TForm1.Timer1Timer(Sender: TObject);
+var
+  i: Integer;
+  rects: array of TRect;
+  nbRects: integer;
+begin
+  if not FInit then exit;
+  Timer1.Enabled:= false;
+  setlength(rects, length(balls)*2);
+  nbRects := 0;
+
+  for i := 0 to high(balls) do
+  with balls[i] do
+  begin
+    //rect to clear
+    rects[nbRects] := GetBallRect(i);
+    inc(nbRects);
+
+    inc(ballSpeed.Y);
+    inc(ballPos.X, ballSpeed.x);
+    inc(ballPos.Y, ballSpeed.y);
+    if BallPos.Y >= VirtualScreen.BitmapHeight-ballRadius then
+    begin
+      ballPos.Y := VirtualScreen.BitmapHeight-ballRadius;
+      ballSpeed.Y := -abs(ballSpeed.Y);
+
+      if (BallPos.X < -ballRadius) or (BallPos.X > VirtualScreen.BitmapWidth+ballRadius) then
+      begin
+        ballPos := Point(random(VirtualScreen.BitmapWidth), - ballRadius);
+        ballSpeed.Y := 0;
+        Continue;
+      end;
+    end else
+    begin
+      if BallPos.X+ballRadius >= VirtualScreen.BitmapWidth then
+      begin
+        BallPos.X := VirtualScreen.BitmapWidth-ballRadius;
+        ballSpeed.X := -abs(ballSpeed.x);
+      end else
+      if BallPos.X <= ballRadius then
+      begin
+        BallPos.X := ballRadius;
+        ballSpeed.X := abs(ballSpeed.x);
+      end;
+    end;
+
+    //rect to redraw
+    rects[nbRects] := GetBallRect(i);
+    inc(nbRects);
+  end;
+  if CheckBox1.Checked then
+    VirtualScreen.RedrawBitmap
+  else
+    VirtualScreen.RedrawBitmap(slice(rects,nbRects));
+  Timer1.Enabled:= true;
+end;
+
+procedure TForm1.InitBalls(ACount: integer);
+var
+  i: Integer;
+begin
+  randomize;
+  VirtualScreen.DiscardBitmap;
+  setlength(balls, ACount);
+  for i := 0 to high(balls) do
+  with balls[i] do
+  begin
+    ballPos := Point(random(VirtualScreen.BitmapWidth), (i*VirtualScreen.BitmapHeight div length(balls)) - ballRadius);
+    ballSpeed := Point(random(5)-2, 0);
+    ballColor := BGRA(random(256),random(256),random(256));
+    if ballColor.Lightness > 48000 then ballColor.Lightness:= 48000;
+  end;
+end;
+
+procedure TForm1.Init;
+var
+  scale: Double;
+begin
+  if FInit then exit;
+  FInit := true;
+  scale := VirtualScreen.BitmapScale*Screen.PixelsPerInch/96;
+  ballRadius := round(20*scale);
+  initBalls(SpinEdit1.Value);
+  background := CreateCyclicPerlinNoiseMap(round(256*scale),round(256*scale));
+end;
+
+function TForm1.GetBallRect(AIndex: integer): TRect;
+begin
+  with balls[AIndex] do
+    result := Rect(ballPos.X-ballRadius, ballPos.Y-ballRadius,
+                   ballPos.X+ballRadius+1, ballPos.Y+ballRadius+1);
+end;
+
+end.
+