BGRABitmap图像操作9b：巧克力纹理背景

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 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;
begin
image := TBGRABitmap.Create(ClientWidth,ClientHeight,ColorToBGRA(ColorToRGB(clBtnFace)));

image.FillRect(0,0,80*7,80*4,chocolate,dmSet);
phong.DrawSphere(image,rect(20,20,120,120),50,BGRA(255,0,0));

image.Draw(Canvas,0,0,True);
image.free;
end;

end.