babaev-an/lasarus_compotents
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Александр Бабаев
2024-04-02 08:46:59 +03:00
parent fd57fffd3a
commit 3bb34d000b
5591 changed files with 3291734 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
bgrabitmap/test/test4lcl_opengl/opengltest0/ptestvirtualscreen.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 3.6 KiB

79
bgrabitmap/test/test4lcl_opengl/opengltest0/ptestvirtualscreen.lpi Normal file
View File

@@ -0,0 +1,79 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="10"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="ptestvirtualscreen"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<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="BGLControls"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="ptestvirtualscreen.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="ptestvirtualscreen"/>
</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>

21
bgrabitmap/test/test4lcl_opengl/opengltest0/ptestvirtualscreen.lpr Normal file
View File

@@ -0,0 +1,21 @@
program ptestvirtualscreen;
{$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.

22
bgrabitmap/test/test4lcl_opengl/opengltest0/unit1.lfm Normal file
View File

@@ -0,0 +1,22 @@
object Form1: TForm1
Left = 598
Height = 240
Top = 229
Width = 320
Caption = 'Form1'
ClientHeight = 240
ClientWidth = 320
LCLVersion = '1.8.2.0'
object BGLVirtualScreen1: TBGLVirtualScreen
Left = 0
Height = 240
Top = 0
Width = 320
OnRedraw = BGLVirtualScreen1Redraw
Align = alClient
BevelWidth = 0
TabOrder = 0
UseDockManager = False
OnDblClick = BGLVirtualScreen1DblClick
end
end

69
bgrabitmap/test/test4lcl_opengl/opengltest0/unit1.pas Normal file
View File

@@ -0,0 +1,69 @@
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
BGLVirtualScreen, BGRAOpenGL;
type
{ TForm1 }
TForm1 = class(TForm)
BGLVirtualScreen1: TBGLVirtualScreen;
procedure BGLVirtualScreen1DblClick(Sender: TObject);
procedure BGLVirtualScreen1Redraw(Sender: TObject; BGLContext: TBGLContext);
private
OriginalBounds: TRect;
OriginalWindowState: TWindowState;
procedure SwitchFullScreen;
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
uses BGRABitmapTypes;
{ TForm1 }
procedure TForm1.SwitchFullScreen;
begin
if BorderStyle <> bsNone then begin
// To full screen
OriginalWindowState := WindowState;
OriginalBounds := BoundsRect;
BorderStyle := bsNone;
BoundsRect := Screen.MonitorFromWindow(Handle).BoundsRect;
end else begin
// From full screen
BorderStyle := bsSizeable;
if OriginalWindowState = wsMaximized then
WindowState := wsMaximized
else
BoundsRect := OriginalBounds;
end;
end;
procedure TForm1.BGLVirtualScreen1Redraw(Sender: TObject;
BGLContext: TBGLContext);
begin
BGLContext.Canvas.FillRect(10,10,100,100, CSSRed);
end;
// double-clic to switch to fullscreen
procedure TForm1.BGLVirtualScreen1DblClick(Sender: TObject);
begin
SwitchFullScreen;
end;
end.

BIN
bgrabitmap/test/test4lcl_opengl/opengltest1/opengltest1.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 3.6 KiB

88
bgrabitmap/test/test4lcl_opengl/opengltest1/opengltest1.lpi Normal file
View File

@@ -0,0 +1,88 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="opengltest1"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="3">
<Item1>
<PackageName Value="BGRABitmapPack"/>
</Item1>
<Item2>
<PackageName Value="lazopenglcontext"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="opengltest1.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"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="opengltest1"/>
</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>

21
bgrabitmap/test/test4lcl_opengl/opengltest1/opengltest1.lpr Normal file
View File

@@ -0,0 +1,21 @@
program opengltest1;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, lazopenglcontext, Unit1
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

10
bgrabitmap/test/test4lcl_opengl/opengltest1/unit1.lfm Normal file
View File

@@ -0,0 +1,10 @@
object Form1: TForm1
Left = 230
Height = 240
Top = 121
Width = 320
Caption = 'Ground test'
OnCreate = FormCreate
OnDestroy = FormDestroy
LCLVersion = '1.4.0.4'
end

156
bgrabitmap/test/test4lcl_opengl/opengltest1/unit1.pas Normal file
View File

@@ -0,0 +1,156 @@
unit Unit1;
{
-For using OpenGl with BGRABitmap and LCl:
-Add two packages (take a look at project inspector!)
-Then you need a TOpenGLControl and do create stuff and setting events
-If you want OpenGl speed you should use a texture again and again, dont make it each time unless it is necceray so here we will load them once
-For making texture you can use TBGLBitmap or IBGLTexture
-TBGLBitmap is like a TBGRABitmap with OpenGl stuff and a texture property, you can draw, load and whatever here and then use its texture and if you dont need it later free it.
-IBGLTexture is an interface so you dont need to free it,just use it and note that it will use less memory
-After loading you need to draw background with BGLViewPort
-After that draw your textures with BGLCanvas. for more info just take a look at it's class
-In the end do SwapBuffers so all you paint goes to buffer and will draw
-For more info you should check other demos, classes, Wiki or ask on the forum
http://forum.lazarus.freepascal.org/index.php?board=46.0
}
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
OpenGLContext, BGRABitmap, BGRABitmapTypes, BGRAOpenGL;
type
{ TForm1 }
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ private declarations }
OriginalBounds: TRect;
OriginalWindowState: TWindowState;
procedure SwitchFullScreen;
public
bmp: TBGLBitmap;
Tex: IBGLTexture;
OpenGLControl: TOpenGLControl;
DataLoaded: boolean;
procedure Load;
procedure Unload;
procedure OpenGLControlDblClick(Sender: TObject);
procedure OpenGLControlPaint(Sender: TObject);
procedure OpenGLControlMouseMove(Sender: TObject; {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: integer);
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.SwitchFullScreen;
begin
if BorderStyle <> bsNone then begin
// To full screen
OriginalWindowState := WindowState;
OriginalBounds := BoundsRect;
BorderStyle := bsNone;
BoundsRect := Screen.MonitorFromWindow(Handle).BoundsRect;
end else begin
// From full screen
BorderStyle := bsSizeable;
if OriginalWindowState = wsMaximized then
WindowState := wsMaximized
else
BoundsRect := OriginalBounds;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
OpenGLControl := TOpenGLControl.Create(Self);
with OpenGLControl do
begin
Align := alClient;
Parent := Self;
OnPaint := @OpenGLControlPaint;
OnMouseMove := @OpenGLControlMouseMove;
OnDblClick := @OpenGLControlDblClick;
//If you dont do it,you will have some problems
AutoResizeViewport := True;
end;
DataLoaded := False;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
OpenGLControl.Free;
end;
procedure TForm1.Load;
var path: string;
begin
if not DataLoaded then
begin
path := ExtractFilePath(Application.ExeName) + '..' + PathDelim + 'tux_game' + PathDelim + 'ground.png';
//Do this :
//Way1
//Tex := BGLTexture(path);
//Or this for more editing options
//Way2
bmp := TBGLBitmap.Create(path);
bmp.Rectangle(0,0,bmp.Width,bmp.Height,BGRABlack,dmSet);
Tex:=bmp.MakeTextureAndFree;
//Or whatever you want!
DataLoaded := True;
end;
end;
procedure TForm1.Unload;
begin
if DataLoaded then
begin
Tex := nil;
DataLoaded := False;
end;
end;
// double-click to switch to full screen
procedure TForm1.OpenGLControlDblClick(Sender: TObject);
begin
Unload; //context may change when switching to full-screen
SwitchFullScreen;
end;
procedure TForm1.OpenGLControlPaint(Sender: TObject);
var
mousePos: TPoint;
begin
{ Load data }
Load;
{ Draw Background }
BGLViewPort(OpenGLControl.Width, OpenGLControl.Height, BGRAWhite);
{ Draw Texture }
mousePos := ScreenToClient(Mouse.CursorPos);
BGLCanvas.PutImage(mousePos.x - Tex.Width div 2, mousePos.y - Tex.Height div 2, Tex);
{ Update }
OpenGLControl.SwapBuffers;
end;
procedure TForm1.OpenGLControlMouseMove(Sender: TObject; Shift: TShiftState; X, Y: integer);
begin
OpenGLControl.DoOnPaint;
end;
end.

BIN
bgrabitmap/test/test4lcl_opengl/opengltest2/earth.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 668 KiB

BIN
bgrabitmap/test/test4lcl_opengl/opengltest2/opengltest2.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 3.6 KiB

88
bgrabitmap/test/test4lcl_opengl/opengltest2/opengltest2.lpi Normal file
View File

@@ -0,0 +1,88 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="opengltest2"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="3">
<Item1>
<PackageName Value="BGRABitmapPack"/>
</Item1>
<Item2>
<PackageName Value="lazopenglcontext"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="opengltest2.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"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="opengltest2"/>
</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>

21
bgrabitmap/test/test4lcl_opengl/opengltest2/opengltest2.lpr Normal file
View File

@@ -0,0 +1,21 @@
program opengltest2;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, lazopenglcontext, Unit1
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

15
bgrabitmap/test/test4lcl_opengl/opengltest2/unit1.lfm Normal file
View File

@@ -0,0 +1,15 @@
object Form1: TForm1
Left = 231
Height = 240
Top = 114
Width = 320
Caption = 'Rotate and zoom'
OnCreate = FormCreate
LCLVersion = '1.4.0.4'
object Timer1: TTimer
Interval = 15
OnTimer = Timer1Timer
left = 19
top = 16
end
end

115
bgrabitmap/test/test4lcl_opengl/opengltest2/unit1.pas Normal file
View File

@@ -0,0 +1,115 @@
unit Unit1;
{
-If you didnt saw opengltest1, go see it first then come back
-OpenGL is fast, so we want to test it a bit
-Here you will see that you can update your painting much fast without any particular cpu using or whatever
}
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
OpenGLContext, BGRABitmap, BGRABitmapTypes, BGRAOpenGL;
type
{ TForm1 }
TForm1 = class(TForm)
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ private declarations }
public
TexBig,TexSmall: IBGLTexture;
OpenGLControl: TOpenGLControl;
DataLoaded: boolean;
angle: single;
GoBack: boolean;
procedure Load;
procedure OpenGLControlPaint(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
OpenGLControl := TOpenGLControl.Create(Self);
with OpenGLControl do
begin
Align := alClient;
Parent := Self;
OnPaint := @OpenGLControlPaint;
AutoResizeViewport := True;
end;
DataLoaded := False;
GoBack := False;
angle := 0;
WindowState := wsMaximized;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if not GoBack then
begin
if angle = 360 then
GoBack := True;
angle += 1;
end
else
begin
if angle = 0 then
GoBack := False;
angle -= 1;
end;
OpenGLControl.DoOnPaint;
end;
procedure TForm1.Load;
var bmp, bmpSmall : TBGLBitmap;
begin
if not DataLoaded then
begin
bmp := TBGLBitmap.Create(ExtractFilePath(Application.ExeName) + 'earth.png');
bmp.ResampleFilter := rfBestQuality;
bmpSmall := bmp.Resample(bmp.Width div 2,bmp.Height div 2) as TBGLBitmap;
TexBig := bmp.MakeTextureAndFree;
TexSmall := bmpSmall.MakeTextureAndFree;
DataLoaded := True;
end;
end;
procedure TForm1.OpenGLControlPaint(Sender: TObject);
var
x, y, w: single;
tex: IBGLTexture;
begin
Load;
BGLViewPort(OpenGLControl.Width, OpenGLControl.Height, BGRABlack);
x := OpenGLControl.Width / 2;
y := OpenGLControl.Height / 2;
w := (angle / 360) * OpenGLControl.Width;
if w < TexSmall.Width then
tex := TexSmall
else
tex := TexBig;
tex.StretchDrawAngle(x, y, w, w/tex.Width*tex.Height, angle, PointF(tex.Width/2,tex.Height/2), False);
OpenGLControl.SwapBuffers;
end;
end.

BIN
bgrabitmap/test/test4lcl_opengl/opengltest3/Background.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 172 KiB

BIN
bgrabitmap/test/test4lcl_opengl/opengltest3/opengltest3.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 3.6 KiB

88
bgrabitmap/test/test4lcl_opengl/opengltest3/opengltest3.lpi Normal file
View File

@@ -0,0 +1,88 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="opengltest3"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="3">
<Item1>
<PackageName Value="BGRABitmapPack"/>
</Item1>
<Item2>
<PackageName Value="lazopenglcontext"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="opengltest3.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"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="opengltest3"/>
</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>

21
bgrabitmap/test/test4lcl_opengl/opengltest3/opengltest3.lpr Normal file
View File

@@ -0,0 +1,21 @@
program opengltest3;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, lazopenglcontext, Unit1
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

101
bgrabitmap/test/test4lcl_opengl/opengltest3/unit1.lfm Normal file
View File

@@ -0,0 +1,101 @@
object Form1: TForm1
Left = 230
Height = 705
Top = 119
Width = 1223
Caption = 'Masking'
ClientHeight = 705
ClientWidth = 1223
OnCreate = FormCreate
OnShow = FormShow
LCLVersion = '1.6.0.4'
object Panel1: TPanel
Left = 0
Height = 705
Top = 0
Width = 144
Align = alLeft
ClientHeight = 705
ClientWidth = 144
TabOrder = 0
object RadioGroup1: TRadioGroup
Left = 1
Height = 79
Top = 1
Width = 142
Align = alTop
AutoFill = True
Caption = 'Mode'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 59
ClientWidth = 138
Items.Strings = (
'Texture'
'Mask'
'Texture+Mask'
)
TabOrder = 0
end
object GroupBox1: TGroupBox
Left = 1
Height = 64
Top = 80
Width = 142
Align = alTop
Caption = 'Masking'
ClientHeight = 44
ClientWidth = 138
TabOrder = 1
object TrackBar1: TTrackBar
Left = 5
Height = 25
Top = -1
Width = 130
Frequency = 15
Max = 255
Min = 1
Position = 128
Anchors = [akTop, akLeft, akRight]
TabOrder = 0
end
object Label1: TLabel
Left = 7
Height = 15
Top = 25
Width = 22
Caption = 'Add'
ParentColor = False
end
object Label2: TLabel
Left = 87
Height = 15
Top = 25
Width = 44
Anchors = [akTop, akRight]
Caption = 'Multiply'
ParentColor = False
end
end
end
object Panel2: TPanel
Left = 144
Height = 705
Top = 0
Width = 1079
Align = alClient
TabOrder = 1
end
object Timer1: TTimer
Enabled = False
Interval = 15
OnTimer = Timer1Timer
left = 40
top = 192
end
end

170
bgrabitmap/test/test4lcl_opengl/opengltest3/unit1.pas Normal file
View File

@@ -0,0 +1,170 @@
unit Unit1;
{
-So lets put things together and play with masks
-Just read the code, it should be clear
-As you can see this demo will uses more cpu because it create mask every time it paints but still it is very fast
}
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
ComCtrls, StdCtrls, OpenGLContext, BGRABitmap, BGRABitmapTypes, BGRAOpenGL;
type
{ TForm1 }
TForm1 = class(TForm)
GroupBox1: TGroupBox;
Label1: TLabel;
Label2: TLabel;
Panel1: TPanel;
Panel2: TPanel;
RadioGroup1: TRadioGroup;
Timer1: TTimer;
TrackBar1: TTrackBar;
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
OpenGLControl: TOpenGLControl;
public
Tex, Mask: IBGLTexture;
rectMask: TRect;
MainFont: IBGLFont;
r: single;
GoBack: boolean;
procedure OpenGLControlPaint(Sender: TObject);
procedure UpdateMask;
end;
var
Form1: TForm1;
implementation
uses Types,Math;
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
OpenGLControl := TOpenGLControl.Create(Self);
with OpenGLControl do
begin
Align := alClient;
Parent := Panel2;
OnPaint := @OpenGLControlPaint;
AutoResizeViewport := True;
end;
RadioGroup1.ItemIndex := 0;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
//You can not make textures before form show
Tex := BGLTexture('Background.jpg');
MainFont := BGLFont('Arial',20);
Timer1.Enabled := True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if not GoBack then
begin
if r = 200 then
GoBack := True;
r += 1;
end
else
begin
if r = 50 then
GoBack := False;
r -= 1;
end;
OpenGLControl.Invalidate;
end;
procedure TForm1.OpenGLControlPaint(Sender: TObject);
begin
//Dont forget this
BGLViewPort(OpenGLControl.Width, OpenGLControl.Height, BGRABlack);
case RadioGroup1.ItemIndex of
0:
begin
//Draw just texture
//StretchPutImage will resample image to prefered size
BGLCanvas.StretchPutImage(0, 0, OpenGLControl.Width, OpenGLControl.Height, Tex);
end;
1:
begin
UpdateMask;
//See how mask looks
if Assigned(Mask) then
begin
Mask.BlendMode := obmNormal;
BGLCanvas.PutImage(rectMask.Left, rectMask.Top, Mask);
end;
end;
2:
begin
UpdateMask;
//Now see them together
if Assigned(Mask) then
begin
//draw only the part of the image that overlaps with the mask
BGLCanvas.ClipRect := rectMask;
BGLCanvas.StretchPutImage(0, 0, OpenGLControl.Width, OpenGLControl.Height, Tex);
BGLCanvas.NoClip;
//apply the mask
Mask.BlendMode := obmMultiply;
BGLCanvas.PutImage(rectMask.Left, rectMask.Top, Mask);
end;
//draw the whole picture without mask
BGLCanvas.StretchPutImage(0, 0, OpenGLControl.Width, OpenGLControl.Height, Tex, 255-TrackBar1.Position);
if Assigned(Mask) then
begin
//draw the mask
Mask.BlendMode := obmAdd;
BGLCanvas.PutImage(rectMask.Left, rectMask.Top, Mask, (255-TrackBar1.Position) div 4);
end;
end;
end;
MainFont.TextOut(0,0, inttostr(OpenGLControl.FrameDiffTimeInMSecs) + ' ms');
//And dont forget this
OpenGLControl.SwapBuffers;
end;
procedure TForm1.UpdateMask;
var rectEllipse: TRect;
mousePos: TPoint;
bmp: TBGLBitmap;
begin
mousePos := Panel2.ScreenToControl(Mouse.CursorPos);
//determine area of the ellipse
rectEllipse := Rect(mousePos.x - ceil(r), mousePos.y - ceil(r),
mousePos.x + ceil(r) + 1, mousePos.y + ceil(r) + 1);
rectMask := EmptyRect;
if IntersectRect(rectMask, rect(0,0, BGLCanvas.Width, BGLCanvas.Height), rectEllipse) then
begin
//render the ellipse
bmp := TBGLBitmap.Create(rectMask.Right-rectMask.Left, rectMask.Bottom-rectMask.Top, BGRABlack);
bmp.FillEllipseAntialias(mousePos.x-rectMask.Left, mousePos.y-rectMask.Top, r, r, BGRAWhite);
Mask := bmp.MakeTextureAndFree;
end else
Mask := nil;
end;
end.

BIN
bgrabitmap/test/test4lcl_opengl/tux_game/ground.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 6.2 KiB

104
bgrabitmap/test/test4lcl_opengl/tux_game/mainunit.lfm Normal file
View File

@@ -0,0 +1,104 @@
object Form1: TForm1
Left = 388
Height = 600
Top = 110
Width = 800
HorzScrollBar.Page = 399
VertScrollBar.Page = 299
Caption = 'BGRABitmapPack + LCL + OpenGL'
ClientHeight = 600
ClientWidth = 800
OnClose = FormClose
OnCreate = FormCreate
OnKeyDown = FormKeyDown
OnKeyUp = FormKeyUp
OnResize = FormResize
LCLVersion = '1.4.0.4'
object Panel1: TPanel
Left = 0
Height = 29
Top = 0
Width = 800
Align = alTop
ClientHeight = 29
ClientWidth = 800
TabOrder = 2
object Label1: TLabel
Left = 8
Height = 15
Top = 4
Width = 39
Caption = 'Games:'
ParentColor = False
end
object Button1: TButton
Left = 56
Height = 25
Top = 0
Width = 32
Caption = '1'
Enabled = False
OnClick = Button1Click
TabOrder = 1
TabStop = False
end
object Button2: TButton
Left = 90
Height = 25
Top = 0
Width = 32
Caption = '2'
OnClick = Button2Click
TabOrder = 0
TabStop = False
end
object Label2: TLabel
Left = 140
Height = 15
Top = 4
Width = 265
Caption = 'Use arrow keys to move parent tux in game 1 (top)'
ParentColor = False
end
end
object BGLVirtualScreen1: TBGLVirtualScreen
Left = 0
Height = 563
Top = 29
Width = 800
OnRedraw = BGLVirtualScreen1Redraw
Align = alClient
BevelWidth = 0
Color = clNone
ParentColor = False
RedrawOnIdle = True
TabOrder = 0
UseDockManager = False
OnElapse = BGLVirtualScreen1Elapse
OnFramesPerSecond = BGLVirtualScreen1FramesPerSecond
OnLoadTextures = BGLVirtualScreen1LoadTextures
OnUnloadTextures = BGLVirtualScreen1UnloadTextures
OnMouseDown = BGLVirtualScreen1MouseDown
OnMouseMove = BGLVirtualScreen1MouseMove
OnMouseUp = BGLVirtualScreen1MouseUp
end
object BGLVirtualScreen2: TBGLVirtualScreen
Left = 0
Height = 8
Top = 592
Width = 800
OnRedraw = BGLVirtualScreen2Redraw
Align = alBottom
BevelWidth = 0
Color = clNone
ParentColor = False
RedrawOnIdle = True
TabOrder = 1
UseDockManager = False
OnClick = BGLVirtualScreen2Click
OnElapse = BGLVirtualScreen2Elapse
OnFramesPerSecond = BGLVirtualScreen2FramesPerSecond
OnLoadTextures = BGLVirtualScreen2LoadTextures
OnUnloadTextures = BGLVirtualScreen2UnloadTextures
end
end

272
bgrabitmap/test/test4lcl_opengl/tux_game/mainunit.pas Normal file
View File

@@ -0,0 +1,272 @@
unit MainUnit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LCLProc, LResources, Forms, Controls, Graphics, Dialogs,
ExtCtrls, StdCtrls, OpenGLContext, BGRAOpenGL, BGLVirtualScreen, UGame;
type
{ TForm1 }
TForm1 = class(TForm)
BGLVirtualScreen1: TBGLVirtualScreen;
BGLVirtualScreen2: TBGLVirtualScreen;
Button1: TButton;
Button2: TButton;
Label1: TLabel;
Label2: TLabel;
Panel1: TPanel;
procedure BGLVirtualScreen2Click(Sender: TObject);
procedure FormClose(Sender: TObject; var {%H-}CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
{ HANDLE MOUSE AND KEY STROKES }
procedure FormKeyDown(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState);
procedure FormKeyUp(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState);
procedure BGLVirtualScreen1MouseDown(Sender: TObject; Button: TMouseButton;
{%H-}Shift: TShiftState; X, Y: Integer);
procedure BGLVirtualScreen1MouseMove(Sender: TObject; {%H-}Shift: TShiftState;
X, Y: Integer);
procedure BGLVirtualScreen1MouseUp(Sender: TObject; Button: TMouseButton;
{%H-}Shift: TShiftState; X, Y: Integer);
{ VIRTUAL SCREEN 1 }
procedure BGLVirtualScreen1LoadTextures(Sender: TObject; BGLContext: TBGLContext);
procedure BGLVirtualScreen1Redraw(Sender: TObject; BGLContext: TBGLContext);
procedure BGLVirtualScreen1Elapse(Sender: TObject; BGLContext: TBGLContext; ElapsedMs: integer);
procedure BGLVirtualScreen1FramesPerSecond(Sender: TObject; {%H-}BGLContext: TBGLContext; FramesPerSecond: integer);
procedure BGLVirtualScreen1UnloadTextures(Sender: TObject; BGLContext: TBGLContext);
{ VIRTUAL SCREEN 2 }
procedure BGLVirtualScreen2LoadTextures(Sender: TObject; BGLContext: TBGLContext);
procedure BGLVirtualScreen2Redraw(Sender: TObject; BGLContext: TBGLContext);
procedure BGLVirtualScreen2Elapse(Sender: TObject; BGLContext: TBGLContext; ElapsedMs: integer);
procedure BGLVirtualScreen2FramesPerSecond(Sender: TObject; {%H-}BGLContext: TBGLContext; FramesPerSecond: integer);
procedure BGLVirtualScreen2UnloadTextures(Sender: TObject; BGLContext: TBGLContext);
protected
procedure AdjustHeight;
public
GameContext1: TGameContext;
GameContext2: TGameContext;
end;
var
Form1: TForm1;
implementation
uses LCLType, BGRABitmapTypes;
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
Position := poScreenCenter;
ClientWidth := 800;
ClientHeight := 600;
Constraints.MaxWidth := Width;
ResourceDir := {$IFDEF DARWIN}ExtractFilePath(Application.ExeName)+'../../../../'{$ELSE}
'..'+PathDelim{$ENDIF};
GameContext1 := TGameContext.Create(False);
GameContext2 := nil;
{ Textures are loaded in the LoadTextures event }
AdjustHeight;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
{ Textures must be freed while the virtual screens exist }
if Assigned(GameContext1) then
begin
BGLVirtualScreen1.UnloadTextures;
FreeAndNil(GameContext1);
end;
if Assigned(GameContext2) then
begin
BGLVirtualScreen2.UnloadTextures;
FreeAndNil(GameContext2);
end;
end;
procedure TForm1.BGLVirtualScreen2Click(Sender: TObject);
begin
if not Assigned(GameContext2) then
Button2Click(Sender);
end;
procedure TForm1.FormResize(Sender: TObject);
begin
AdjustHeight;
end;
procedure TForm1.AdjustHeight;
begin
if Assigned(GameContext2) then
begin
BGLVirtualScreen2.Height := (ClientHeight-Panel1.Height) div 2;
BGLVirtualScreen2.Cursor := crDefault;
end
else
begin
BGLVirtualScreen2.Height := 8;
BGLVirtualScreen2.Cursor := crHandPoint;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Button1.Enabled := false;
Button2.Enabled := true;
if Assigned(GameContext2) then
begin
BGLVirtualScreen2.UnloadTextures;
FreeAndNil(GameContext2);
AdjustHeight;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Button1.Enabled := true;
Button2.Enabled := false;
if not Assigned(GameContext2) then
begin
GameContext2 := TGameContext.Create(True);
BGLVirtualScreen2.QueryLoadTextures; //query the event LoadTextures
AdjustHeight;
end;
end;
{---------------- HANDLE MOUSE AND KEY STROKES --------------}
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
GameContext1.KeyDown(Key,Shift);
end;
procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
GameContext1.KeyUp(Key,Shift);
end;
procedure TForm1.BGLVirtualScreen1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
GameContext1.MouseDown(Button,X,Y);
end;
procedure TForm1.BGLVirtualScreen1MouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
GameContext1.MouseMove(X,Y);
end;
procedure TForm1.BGLVirtualScreen1MouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
GameContext1.MouseMove(X,Y);
GameContext1.MouseUp(Button);
end;
{------------------ VIRTUAL SCREEN 1 ----------------}
procedure TForm1.BGLVirtualScreen1LoadTextures(Sender: TObject;
BGLContext: TBGLContext);
begin
if Assigned(GameContext1) then
GameContext1.LoadTextures(BGLContext);
end;
procedure TForm1.BGLVirtualScreen1Redraw(Sender: TObject;
BGLContext: TBGLContext);
begin
if Assigned(GameContext1) then
GameContext1.Render(BGLContext);
end;
procedure TForm1.BGLVirtualScreen1Elapse(Sender: TObject; BGLContext: TBGLContext; ElapsedMs: integer);
begin
if Assigned(GameContext1) then
GameContext1.Elapse(BGLContext, ElapsedMs);
end;
procedure TForm1.BGLVirtualScreen1FramesPerSecond(Sender: TObject;
BGLContext: TBGLContext; FramesPerSecond: integer);
begin
if Assigned(GameContext1) then
GameContext1.FPS := FramesPerSecond;
end;
procedure TForm1.BGLVirtualScreen1UnloadTextures(Sender: TObject;
BGLContext: TBGLContext);
begin
if Assigned(GameContext1) then
GameContext1.UnloadTextures(BGLContext);
end;
{-------------------- VIRTUAL SCREEN 2 -----------------}
procedure TForm1.BGLVirtualScreen2LoadTextures(Sender: TObject;
BGLContext: TBGLContext);
begin
if Assigned(GameContext2) then
GameContext2.LoadTextures(BGLContext);
end;
procedure TForm1.BGLVirtualScreen2Redraw(Sender: TObject;
BGLContext: TBGLContext);
begin
if Assigned(GameContext2) then
begin
//draw an horizontal line to seperate visually from the other game
BGLContext.Canvas.Line(0,0,BGLContext.Width-1,0,BGRABlack,True);
BGLContext.Canvas.Translate(0,1);
GameContext2.Render(BGLContext);
end else
begin
//draw a handle to indicate it is reduced
BGLContext.Canvas.Fill(ColorToBGRA(clBtnFace));
BGLContext.Canvas.Line(1,3,BGLContext.Width-2,3, ColorToBGRA(clBtnHighlight));
BGLContext.Canvas.Line(1,4,BGLContext.Width-2,4, ColorToBGRA(clBtnShadow));
end;
end;
procedure TForm1.BGLVirtualScreen2Elapse(Sender: TObject;
BGLContext: TBGLContext; ElapsedMs: integer);
begin
if Assigned(GameContext2) then
GameContext2.Elapse(BGLContext, ElapsedMs);
end;
procedure TForm1.BGLVirtualScreen2FramesPerSecond(Sender: TObject;
BGLContext: TBGLContext; FramesPerSecond: integer);
begin
if Assigned(GameContext2) then
GameContext2.FPS := FramesPerSecond;
end;
procedure TForm1.BGLVirtualScreen2UnloadTextures(Sender: TObject;
BGLContext: TBGLContext);
begin
if Assigned(GameContext2) then
GameContext2.UnloadTextures(BGLContext);
end;
end.

BIN
bgrabitmap/test/test4lcl_opengl/tux_game/tux_game.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 3.6 KiB

78
bgrabitmap/test/test4lcl_opengl/tux_game/tux_game.lpi Normal file
View File

@@ -0,0 +1,78 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<Flags>
<LRSInOutputDirectory Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="tux_game"/>
<ResourceType Value="res"/>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="3">
<Item1>
<PackageName Value="BGLControls"/>
</Item1>
<Item2>
<PackageName Value="BGRABitmapPack"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
</RequiredPackages>
<Units Count="3">
<Unit0>
<Filename Value="tux_game.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="mainunit.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
<Unit2>
<Filename Value="ugame.pas"/>
<IsPartOfProject Value="True"/>
</Unit2>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<SearchPaths>
<UnitOutputDirectory Value="lib"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
</CONFIG>

17
bgrabitmap/test/test4lcl_opengl/tux_game/tux_game.lpr Normal file
View File

@@ -0,0 +1,17 @@
program tux_game;
{$mode objfpc}{$H+}
uses
Interfaces, // this includes the LCL widgetset
Forms
{ add your units here }, MainUnit, UGame;
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

BIN
bgrabitmap/test/test4lcl_opengl/tux_game/tux_walking.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 12 KiB

549
bgrabitmap/test/test4lcl_opengl/tux_game/ugame.pas Normal file
View File

@@ -0,0 +1,549 @@
unit UGame;
{$mode objfpc}{$H+}
interface
uses
Classes, sysutils, BGRAGraphics, BGRABitmap, BGRABitmapTypes,
BGRAOpenGL, Controls;
const
FrameDurationMs = 15;
type
TTux = class;
{ TGameContext }
TGameContext = class
protected
TexturesLoaded: boolean;
LeftKey,RightKey,UpKey: boolean;
texWalking,texGround: IBGLTexture;
tux,smallTux: TTux;
elapsedMs: single;
sun: IBGLTexture;
font, bubbleFont: IBGLRenderedFont;
CenterOnSmallTux: boolean;
infoTextAnimTime: single;
procedure AddGround(x,y,w: single);
function FindGround(x: single; var y: single): boolean;
public
FPS: integer;
constructor Create(ACenterOnSmallTux: boolean);
destructor Destroy; override;
procedure LoadTextures({%H-}ctx: TBGLContext);
procedure UnloadTextures({%H-}ctx: TBGLContext);
procedure Render(ctx: TBGLContext);
procedure Elapse(ctx: TBGLContext; ms: single);
procedure MouseDown({%H-}Button: TMouseButton; {%H-}X,{%H-}Y: integer);
procedure MouseMove({%H-}X,{%H-}Y: integer);
procedure MouseUp({%H-}Button: TMouseButton);
procedure KeyDown(var Key: Word; {%H-}Shift: TShiftState);
procedure KeyUp(var Key: Word; {%H-}Shift: TShiftState);
end;
{ TTextBubble }
TTextBubble = class
protected
FText: string;
FFont: IBGLFont;
public
constructor Create(AText: string; AFont: IBGLFont);
procedure Draw(AXCenter, AYBottom: single);
end;
{ TTux }
TTux = class(TBGLSprite)
Speed: TPointF;
LookingLeft: boolean;
Context: TGameContext;
Autoplay: boolean;
Parent: TTux;
OnTheGround: boolean;
Bubble,BubbleTooFar: TTextBubble;
BubbleTime: integer;
ShowBubbleTooFar: boolean;
goRight,goLeft,goUp: boolean;
waiting: integer;
JumpStrength: single;
procedure OnInit; override;
procedure OnDraw; override;
procedure OnTimer; override;
constructor Create(ATexture: IBGLTexture; AContext: TGameContext);
destructor Destroy; override;
end;
{ TSmallTux }
TSmallTux = class(TTux)
procedure OnInit; override;
procedure OnTimer; override;
end;
{ TGround }
TGround = class(TBGLSprite)
constructor Create(ATexture: IBGLTexture; AX,AY: Single; AFrame: integer);
procedure OnInit; override;
end;
var
ResourceDir : string;
implementation
uses LCLType;
{ TTextBubble }
constructor TTextBubble.Create(AText: string; AFont: IBGLFont);
begin
FText := AText;
FFont := AFont;
end;
procedure TTextBubble.Draw(AXCenter, AYBottom: single);
const horizMargin = 6; vertMargin = 4;
var tw,x,y,tx,ty: integer;
begin
tw := round(FFont.TextWidth(FText));
tx := tw+horizMargin*2;
ty := round(FFont.TextHeight(FText))+2*vertMargin;
x := round(AXCenter)-tx div 2;
y := round(AYBottom)-ty;
BGLCanvas.RoundRect(x,y,x+tx,y+ty,12,12,BGRABlack, BGRA(255,255,250));
FFont.SetGradientColors(CSSBlack,CSSBlack,CSSDodgerBlue,CSSDodgerBlue);
FFont.TextOut(x+horizMargin,y+vertMargin,FText, taLeftJustify, tlTop, BGRABlack);
FFont.GradientColors := false;
end;
{ TSmallTux }
procedure TSmallTux.OnInit;
begin
inherited OnInit;
Autoplay:= true;
H := H*0.75;
W := W*0.75;
LookingLeft := true;
Bubble := TTextBubble.Create('Where are my parents?',Context.bubbleFont);
BubbleTooFar := TTextBubble.Create('Please stay close to me!',Context.bubbleFont);
//JumpStrength := 4;
end;
procedure TSmallTux.OnTimer;
begin
inherited OnTimer;
if Parent = nil then
begin
if sqr(X-Context.tux.X)+sqr(Y-Context.tux.Y) < sqr(50) then
begin
Parent := Context.tux;
FreeAndNil(Bubble);
Bubble := TTextBubble.Create('Hey my parent!',Context.bubbleFont);
BubbleTime := 400;
end;
end;
end;
{ TGameContext }
constructor TGameContext.Create(ACenterOnSmallTux: boolean);
begin
LeftKey := false;
RightKey := false;
UpKey := false;
TexturesLoaded:= false;
CenterOnSmallTux:= ACenterOnSmallTux;
infoTextAnimTime := 0;
end;
destructor TGameContext.Destroy;
begin
inherited Destroy;
end;
procedure TGameContext.LoadTextures({%H-}ctx: TBGLContext);
var sunBmp: TBGLBitmap;
begin
if TexturesLoaded then exit;
Randomize;
texWalking := BGLTexture(ResourceDir+'tux_walking.png');
texWalking.SetFrameSize(64,64);
texGround := BGLTexture(ResourceDir+'ground.png');
texGround.SetFrameSize(32,32);
font := BGLFont('Arial', 20, CSSLightYellow,CSSBlack, [fsBold]);
bubbleFont := BGLFont('Arial', 16);
bubbleFont.HorizontalAlign := taCenter;
bubbleFont.Justify:= true;
bubbleFont.Padding := RectF(10,10,10,10);
AddGround(32,128,200);
AddGround(400,128,200);
AddGround(200,250,200);
AddGround(-32,250,150);
AddGround(400,380,200);
AddGround(300,500,150);
AddGround(-32,600-32,800+64);
tux := TTux.Create(texWalking,self);
tux.Location := PointF(128,128);
smallTux := TSmallTux.Create(texWalking,self);
smallTux.Location := PointF(450,128);
sunBmp := TBGLBitmap.Create(100,100);
sunBmp.FillEllipseLinearColorAntialias(50,50,49,49,BGRA(255,255,random(100)),BGRA(255,random(200),0));
sun := sunBmp.MakeTextureAndFree;
TBGLSprite.Create(sun,-2).Location := PointF(random(200),0);
TexturesLoaded:= true;
end;
procedure TGameContext.Render(ctx: TBGLContext);
const infoText = 'Welcome to this demo showing how to use BGRABitmap with OpenGL';
var ofsX,ofsY,h: single;
r:TRectF;
alpha: byte;
begin
ctx.Canvas.FillRectLinearColor(Rect(0,0,ctx.Width,ctx.Height),
CSSSkyBlue,CSSSkyBlue,MergeBGRA(CSSSkyBlue,CSSBlue),MergeBGRA(CSSSkyBlue,CSSBlue));
if CenterOnSmallTux then
begin
ofsX := smallTux.X;
ofsY := smallTux.Y;
end else
begin
ofsX := tux.X;
ofsY := tux.Y;
end;
ofsX -= ctx.Width div 2;
ofsY -= ctx.Height div 2;
if ofsX > 800-ctx.Width then ofsX := 800-ctx.Width;
if ofsY > 600-ctx.Height then ofsY := 600-ctx.Height;
if ofsX < 0 then ofsX := 0;
if ofsY < 0 then ofsY := 0;
ctx.Canvas.Translate(-ofsX,-ofsY);
ctx.Sprites.OnDraw;
ctx.Canvas.Translate(ofsX,ofsY);
if infoTextAnimTime <= 500 then
alpha := round(infoTextAnimTime*255/500)
else if infoTextAnimTime <= 3500 then
alpha := 255
else if infoTextAnimTime <= 4000 then
alpha := round((4000-infoTextAnimTime)*255/500)
else
alpha := 0;
if alpha <> 0 then
begin
h := bubbleFont.TextHeight(infoText, 300)+bubbleFont.Padding.Top+bubbleFont.Padding.Bottom+4;
if infoTextAnimTime <= 500 then
h := h*infoTextAnimTime/500;
r.Left := ctx.Width/2-150;
r.Right := r.Left + 300;
r.Top := ctx.Height/2-h/2;
r.Bottom := r.Top + h;
ctx.Canvas.FillRect(r, BGRA(0,0,0,alpha div 2));
bubbleFont.Clipped:= true;
bubbleFont.TextRect(r, infoText, BGRA(255,255,255,alpha));
bubbleFont.Clipped:= false;
end;
if FPS <> 0 then
font.TextOut(ctx.Width-5,0,inttostr(FPS)+' FPS',taRightJustify);
end;
procedure TGameContext.UnloadTextures(ctx: TBGLContext);
begin
if TexturesLoaded then
begin
ctx.Sprites.Clear;
TexturesLoaded := false;
end;
end;
procedure TGameContext.AddGround(x, y, w: single);
begin
TGround.Create(texGround,x,y,1);
x += 32;
w -= 32;
while w > 32 do
begin
TGround.Create(texGround,x,y,2);
x += 32;
w -= 32;
end;
TGround.Create(texGround,x,y,3);
end;
procedure TGameContext.Elapse(ctx: TBGLContext; ms: single);
begin
infoTextAnimTime += ms;
elapsedMs += ms;
while elapsedMs > FrameDurationMs do
begin
ctx.Sprites.OnTimer;
elapsedMs -= FrameDurationMs;
end;
end;
function TGameContext.FindGround(x: single; var y: single): boolean;
var
i: Integer;
s: TBGLSprite;
g: TGround;
begin
for i := 0 to BGLSpriteEngine.Count-1 do
begin
s := BGLSpriteEngine.Sprite[i] as TBGLSprite;
if s is TGround then
begin
g := TGround(s);
if (x >= g.X-g.W/2) and (x <= g.X+g.W/2) then
begin
if (y >= g.Y-4) and (Y <= g.Y-4+16) then
begin
result := true;
y := g.Y-4;
exit;
end;
end;
end;
end;
result := false;
end;
procedure TGameContext.MouseDown(Button: TMouseButton; X, Y: integer);
begin
end;
procedure TGameContext.MouseMove(X, Y: integer);
begin
end;
procedure TGameContext.MouseUp(Button: TMouseButton);
begin
end;
procedure TGameContext.KeyDown(var Key: Word; Shift: TShiftState);
begin
If Key = VK_LEFT then begin LeftKey := true; Key := 0; end;
If Key = VK_RIGHT then begin RightKey := true; Key := 0; end;
If Key = VK_UP then begin UpKey := true; Key := 0; end;
end;
procedure TGameContext.KeyUp(var Key: Word; Shift: TShiftState);
begin
If Key = VK_LEFT then begin LeftKey := false; Key := 0; end;
If Key = VK_RIGHT then begin RightKey := false; Key := 0; end;
If Key = VK_UP then begin UpKey := false; Key := 0; end;
end;
{ TGround }
constructor TGround.Create(ATexture: IBGLTexture; AX, AY: Single;
AFrame: integer);
begin
inherited Create(ATexture, -1);
Location := PointF(AX,AY+4);
Frame := AFrame;
end;
procedure TGround.OnInit;
begin
HorizontalAlign := taCenter;
VerticalAlign := tlCenter;
end;
{ TTux }
procedure TTux.OnInit;
begin
HorizontalAlign := taCenter;
VerticalAlign := tlBottom;
Frame := 1;
Speed := PointF(0,0);
FrameLoopStart := 1;
FrameLoopEnd := 10;
LookingLeft:= false;
goRight:= false;
goLeft:= false;
goUp := false;
waiting := 0;
JumpStrength:= 5;
Parent := nil;
Autoplay:= false;
end;
procedure TTux.OnDraw;
begin
if lookingLeft then Texture.ToggleFlipX;
inherited OnDraw;
if lookingLeft then Texture.ToggleFlipX;
if Bubble <> nil then
begin
if BubbleTime mod 500 > 400 then
begin
if ShowBubbleTooFar then
BubbleTooFar.Draw(x,y-H)
else
Bubble.Draw(x,y-H);
end;
end;
end;
procedure TTux.OnTimer;
var curY: single;
nearParent: boolean;
begin
if not OnTheGround then
begin
//jumping
end else
begin
nearParent:= false;
if Autoplay then
begin
if waiting > 0 then
dec(waiting)
else
begin
goRight:= false;
goLeft:= false;
goUp := false;
if Parent<> nil then
nearParent := (abs(X-Parent.X) < 100) and (abs(Y-Parent.Y) < 150);
ShowBubbleTooFar := (Parent <> nil) and not nearParent;
if (Parent<> nil) and (abs(X-Parent.X) < 200) and (abs(Y-Parent.Y) < 200) then
begin
if BubbleTime > 500 then
begin
if not nearParent then
BubbleTime := 0
else
BubbleTime := 500;
end;
if (abs(X-Parent.X) > 40) then
begin
waiting := random(150);
if X > Parent.X then goLeft := true
else goRight := true;
end else
if (Parent.Y < Y-40) and (Parent.Y > Y-200) then
begin
waiting := random(150);
goUp := true;
waiting := 0;
end;
end else
begin
waiting := random(300);
case random(10) of
0..2: goLeft:= true;
3..5: goRight:= true;
9: begin goUp:= true; waiting := 0; end;
end;
end;
end;
curY := Y+5;
if goLeft and (X < 1) then
begin
goLeft := false;
waiting:= 0;
end;
if goRight and (X > 799) then
begin
goRight := false;
waiting:= 0;
end;
if not nearParent then
begin
if goLeft and not Context.FindGround(X-20,curY) then
begin
goLeft:= false;
waiting:= 0;
end;
if goRight and not Context.FindGround(X+20,curY) then
begin
goRight:= false;
waiting := 0;
end;
end else
if (Parent <> nil) and (abs(X-Parent.X) < 5) then
begin
goLeft:= false;
goRight:= false;
end;
end else
begin
goRight:= Context.RightKey;
goLeft:= Context.LeftKey;
goUp := Context.UpKey;
end;
if not goRight and not goLeft and not goUp then
begin
speed.X := speed.X*0.9;
if abs(speed.X)<0.1 then speed.X := 0;
end else
begin
//on the ground and can move
if goRight then Speed.X += 0.1;
if Speed.X > 1.3 then Speed.X := 1.3;
if goLeft then Speed.X -= 0.1;
if Speed.X < -1.3 then Speed.X := -1.3;
if goUp then Speed.Y := -JumpStrength;
if (Speed.X < 0) and not LookingLeft and (round(Frame) = 1) then
lookingLeft:= true;
if (Speed.X > 0) and LookingLeft and (round(Frame) = 1) then
lookingLeft := false;
end;
if LookingLeft xor (Speed.X < 0) then
Frame := Frame-Speed.X*0.5
else
Frame := Frame+Speed.X*0.5;
end;
Speed.Y += 0.1;
Location := Location+Speed;
curY := Y;
OnTheGround:= Context.FindGround(X,curY);
if OnTheGround then Speed.Y := 0;
Y := curY;
if X < 0 then X := 0;
if X > 800 then X := 800;
inc(BubbleTime);
end;
constructor TTux.Create(ATexture: IBGLTexture; AContext: TGameContext);
begin
Context := AContext;
inherited Create(ATexture, 0);
end;
destructor TTux.Destroy;
begin
FreeAndNil(Bubble);
FreeAndNil(BubbleTooFar);
inherited Destroy;
end;
end.