纹理随鼠标不停变化,有点像水面。
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
BGRABitmap, BGRABitmapTypes, BGRAGradients;
type
{ TForm1 }
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure FormPaint(Sender: TObject);
private
{ private declarations }
phong: TPhongShading;
chocolate: TBGRABitmap;
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
function CreateStoneTexture(tx,ty: integer): TBGRABitmap;
const blurSize = 5;
var
temp: TBGRABitmap;
phong: TPhongShading;
begin
result := CreateCyclicPerlinNoiseMap(tx,ty,1,1,1.2);
temp:= result.GetPart(rect(-blurSize,-blurSize,tx+blurSize,ty+blurSize)) as TBGRABitmap;
BGRAReplace(temp,temp.FilterBlurRadial(blurSize,rbFast));
phong := TPhongShading.Create;
phong.LightSourceDistanceFactor := 0;
phong.LightDestFactor := 0;
phong.LightSourceIntensity := 150;
phong.LightPositionZ := 80;
phong.LightColor := BGRA(105,233,240);
phong.NegativeDiffusionFactor := 0.3;
phong.SpecularIndex := 20;
phong.AmbientFactor := 0.4;
phong.Draw(result,temp,20,-blurSize,-blurSize,BGRA(28,139,166));
phong.Free;
temp.Free;
end;
function CreateChocolateTexture(tx,ty: integer): TBGRABitmap;
var
square,map: TBGRABitmap;
phong: TPhongShading;
margin: integer;
begin
margin := tx div 20; //empty space around the square
square := CreateRectangleMap(tx-2*margin,ty-2*margin,tx div 8);
//create a map with the square at the middle
map := TBGRABitmap.Create(tx,ty,BGRABlack);
map.PutImage(margin,margin,square,dmDrawWithTransparency);
//apply blur to make it smoother
BGRAReplace(map,map.FilterBlurRadial(tx div 40,rbFast));
square.free;
//create resulting bitmap
result := TBGRABitmap.Create(tx,ty);
//use phong shading
phong := TPhongShading.Create;
phong.LightSourceDistanceFactor := 0;
phong.LightDestFactor := 0;
phong.LightSourceIntensity := 200;
phong.AmbientFactor := 0.5;
phong.LightPosition := Point(-50,-100);
phong.LightPositionZ := 80;
//draw the piece of chocolate with max altitude 20
phong.Draw(result,map,20,0,0,BGRA(86,41,38));
map.Free;
phong.Free;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
phong := TPhongShading.Create;
phong.LightPositionZ := 150;
phong.SpecularIndex := 20;
phong.AmbientFactor := 0.4;
phong.LightSourceIntensity := 250;
phong.LightSourceDistanceTerm := 200;
chocolate := CreateChocolateTexture(80,80);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
phong.Free;
chocolate.Free;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
phong.LightPosition := point(X,Y);
FormPaint(Sender);
end;
procedure TForm1.FormPaint(Sender: TObject);
var
image: TBGRABitmap;
stone: TBGRABitmap;
begin
image := TBGRABitmap.Create(ClientWidth,ClientHeight,ColorToBGRA(ColorToRGB(clBtnFace)));
stone := CreateStoneTexture(100,100);
image.FillEllipseAntialias(100,100,250,150,stone);
stone.free;
image.Draw(Canvas,0,0,True);
image.free;
end;
end.