unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
Spin, BGRAOpenGL, BGRABitmapTypes, BGRAOpenGL3D, BGLVirtualScreen;
type
{ TForm1 }
TForm1 = class(TForm)
ega_btn: TButton;
gboy_btn: TButton;
cpc_btn: TButton;
shader_on: TButton;
ShaderScreen1: TBGLVirtualScreen;
FragMemo: TMemo;
SpinEdit1: TSpinEdit;
Timer1: TTimer;
VertexMemo: TMemo;
procedure cpc_btnClick(Sender: TObject);
procedure ega_btnClick(Sender: TObject);
procedure gboy_btnClick(Sender: TObject);
procedure ShaderScreen1LoadTextures(Sender: TObject; BGLContext: TBGLContext);
procedure ShaderScreen1Redraw(Sender: TObject; BGLContext: TBGLContext);
procedure ShaderScreen1UnloadTextures(Sender: TObject; BGLContext: TBGLContext);
procedure FormCreate(Sender: TObject);
procedure shader_onClick(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure ResetUniforms;
procedure UpdateUniforms;
procedure RunShader;
private
public
gl_surface : IBGLTexture; shader3 : TBGLShader3D;
ctx : TBGLContext;
cpc,ega,gboy,normal_img : boolean ;
fshader : string ; vshader : string; // fragment and vertex
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
cpc := false;
ega := false;
gboy := false;
normal_img := false;
fshader := FragMemo.text;
vshader := VertexMemo.Text;
end;
procedure TForm1.ShaderScreen1Redraw(Sender: TObject; BGLContext: TBGLContext);
begin
if gl_surface <> nil then
BGLContext.Canvas.StretchPutImage(0, 0, ShaderScreen1.Width, ShaderScreen1.Height, gl_surface);
if shader3 <> nil then
begin
BGLContext.Canvas.Lighting.ActiveShader := shader3;
end;
end;
procedure TForm1.ShaderScreen1LoadTextures(Sender: TObject; BGLContext: TBGLContext);
begin
try
gl_surface := BGLTexture(ResourceFile('hybris.png'));
// Create shader
shader3 := TBGLShader3D.Create(
BGLContext.Canvas,
vshader, // Vertex shader
fshader, // Fragment shader
'varying vec2 texCoord;',
'130'); // Version GLSL
ctx := BGLContext;
except
on E: Exception do
raise exception.Create('Shader Error : ' + E.Message);
end;
end;
procedure TForm1.RunShader;
begin
try
fshader := FragMemo.Text;
vshader := VertexMemo.Text;
if Assigned(shader3) then
begin
ctx.Canvas.Lighting.ActiveShader := nil;
FreeAndNil(shader3);
end;
shader3 := TBGLShader3D.Create(ctx.Canvas, vshader, fshader, 'varying vec2 texCoord;', '130');
// if shader error, exception raised by BGRAOpenGLD3 nice :);
Timer1.Enabled := True; // timer1
except
on E: Exception do
ShowMessage('Shader Error : ' + E.Message);
end;
end;
procedure TForm1.ShaderScreen1UnloadTextures(Sender: TObject;
BGLContext: TBGLContext);
begin
gl_surface := nil;
FreeAndNil(shader3);
BGLContext.Canvas.Lighting.ActiveShader := nil;
end;
procedure TForm1.cpc_btnClick(Sender: TObject);
begin
ResetUniforms;
RunShader;
cpc := true;
end;
procedure TForm1.ega_btnClick(Sender: TObject);
begin
ResetUniforms;
RunShader;
ega := true;
end;
procedure TForm1.gboy_btnClick(Sender: TObject);
begin
ResetUniforms;
RunShader;
gboy := true;
end;
procedure TForm1.shader_onClick(Sender: TObject);
begin
ResetUniforms;
RunShader;
normal_img := true;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if shader3 <> nil then
begin
shader3.UniformPointF['resolution'].Value := Pointf(Round(ShaderScreen1.Width),Round(ShaderScreen1.Height));
// shader3.UniformSingle['NORMAL_IMAGE'].Value := 1.0;
shader3.UniformSingle['rez'].Value := SpinEdit1.Value;
UpdateUniforms;
ShaderScreen1.Invalidate;
end;
end;
procedure TForm1.ResetUniforms;
begin
if shader3 <> nil then
begin
normal_img := false;
cpc := false;
ega := false;
gboy := false;
end;
end;
procedure TForm1.UpdateUniforms;
begin
if shader3 <> nil then
begin
if ega then shader3.UniformSingle['EGA'].Value := 1.0;
if cpc then shader3.UniformSingle['CPC'].Value := 1.0;
if gboy then shader3.UniformSingle['GAMEBOY'].Value := 1.0;
if normal_img then shader3.UniformSingle['NORMAL_IMAGE'].Value := 1.0;
end;
end;
end.
Recent
