1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit BGRAGradients;
3
4 {$mode objfpc}{$H+}
5 {$i bgrabitmap.inc}
6 {$i bgrasse.inc}
7
8 interface
9
10 { Here are various functions that draw gradients, shadow and lighting }
11
12 uses
13 BGRAClasses, BGRAGraphics, BGRABitmapTypes, BGRABitmap, BGRABlend, BGRAPhongTypes,
14 BGRASSE, BGRAGrayscaleMask;
15
16 {$IFDEF BGRABITMAP_USE_LCL}{ Creates a bitmap with the specified text horizontally centered and with a shadow }
TextShadownull17 function TextShadow(AWidth,AHeight: Integer; AText: String; AFontHeight: Integer; ATextColor,AShadowColor: TBGRAPixel;
18 AOffSetX,AOffSetY: Integer; ARadius: Integer = 0; AFontStyle: TFontStyles = []; AFontName: String = 'Default'; AShowText: Boolean = True): TBGRABitmap;
19 {$ENDIF}
20
21 {----------------------------------------------------------------------}
22 { Functions to draw multiple gradients.
23 See : http://wiki.lazarus.freepascal.org/Double_Gradient#nGradient }
24 type
25 TnGradientInfo = record
26 StartColor,StopColor: TBGRAPixel;
27 Direction: TGradientDirection;
28 EndPercent : single; // Position from 0 to 1
29 end;
30
nGradientInfonull31 function nGradientInfo(StartColor, StopColor: TBGRAPixel; Direction: TGradientDirection; EndPercent: Single): TnGradientInfo;
32
nGradientAlphaFillnull33 function nGradientAlphaFill(ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo): TBGRABitmap; overload;
nGradientAlphaFillnull34 function nGradientAlphaFill(AWidth, AHeight: Integer; ADir: TGradientDirection; const AGradient: array of TnGradientInfo): TBGRABitmap; overload;
35 procedure nGradientAlphaFill(ACanvas: TCanvas; ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo); overload;
36 procedure nGradientAlphaFill(ABitmap: TBGRABitmap; ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo); overload;
37
DoubleGradientAlphaFillnull38 function DoubleGradientAlphaFill(ARect: TRect; AStart1,AStop1,AStart2,AStop2: TBGRAPixel;
39 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single): TBGRABitmap; overload;
DoubleGradientAlphaFillnull40 function DoubleGradientAlphaFill(AWidth,AHeight: Integer; AStart1,AStop1,AStart2,AStop2: TBGRAPixel;
41 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single): TBGRABitmap; overload;
42 procedure DoubleGradientAlphaFill(ACanvas: TCanvas; ARect: TRect; AStart1,AStop1,AStart2,AStop2: TBGRAPixel;
43 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single); overload;
44 procedure DoubleGradientAlphaFill(ABitmap: TBGRABitmap; ARect: TRect; AStart1,AStop1,AStart2,AStop2: TBGRAPixel;
45 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single); overload;
46
47 {----------------------------------------------------------------------}
48 { Phong shading functions. Use a height map (grayscale image or a precise map filled with MapHeightToBGRA)
49 to determine orientation and position of the surface.
50
51 Phong shading consist in adding an ambiant light, a diffuse light (angle between light and object),
52 and a specular light (angle between light, object and observer, i.e. reflected light) }
53
54 type
55 TRectangleMapOption = (rmoNoLeftBorder,rmoNoTopBorder,rmoNoRightBorder,rmoNoBottomBorder,rmoLinearBorder);
56 TRectangleMapOptions = set of TRectangleMapOption;
57
58 { TPhongShading }
59
60 TPhongShading = class(TCustomPhongShading)
61 public
62 LightSourceIntensity : Single; //global intensity of the light
63
64 LightSourceDistanceTerm, //minimum distance always added (positive value)
65 LightSourceDistanceFactor, //how much actual distance is taken into account (usually 0 or 1)
66 LightDestFactor : Single; //how much the location of the lightened pixel is taken into account (usually 0 or 1)
67
68 LightColor: TBGRAPixel; //color of the light reflection
69
70 SpecularFactor, //how much light is reflected (0..1)
71 SpecularIndex : Single; //how concentrated reflected light is (positive value)
72
73 AmbientFactor, //ambiant lighting whereever the point is (0..1)
74 DiffusionFactor, //diffusion, i.e. how much pixels are lightened by light source (0..1)
75 NegativeDiffusionFactor : Single; //how much hidden surface are darkened (0..1)
76 DiffuseSaturation: Boolean; //when diffusion saturates, use light color to show it
77
78 constructor Create;
79
80 { Render the specified map on the destination bitmap with one solid color. Map altitude
81 indicate the global height of the map. }
82 procedure Draw(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: single; ofsX,ofsY: integer;
83 Color : TBGRAPixel); override;
84
85 { Render with a color map of the same size as the height map. Map altitude
86 indicate the global height of the map. }
87 procedure Draw(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: single; ofsX,ofsY: integer;
88 ColorMap : TBGRACustomBitmap); override;
89
90 { Render with a color scanner. Map altitude
91 indicate the global height of the map. }
92 procedure DrawScan(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: single; ofsX,ofsY: integer;
93 ColorScan : IBGRAScanner); override;
94
95 { Draw a cone of the specified color }
96 procedure DrawCone(dest: TBGRACustomBitmap; X,Y,Size: Integer; Altitude: Single; Color: TBGRAPixel); overload;
97 procedure DrawCone(dest: TBGRACustomBitmap; bounds: TRect; Altitude: Single; Color: TBGRAPixel); overload;
98
99 { Draw a vertical cone of the specified color }
100 procedure DrawVerticalCone(dest: TBGRACustomBitmap; bounds: TRect; Altitude: Single; Color: TBGRAPixel);
101
102 { Draw an horizontal cylinder of the specified color }
103 procedure DrawHorizontalCylinder(dest: TBGRACustomBitmap; bounds: TRect; Altitude: Single; Color: TBGRAPixel);
104
105 { Draw a vertical cylinder of the specified color }
106 procedure DrawVerticalCylinder(dest: TBGRACustomBitmap; bounds: TRect; Altitude: Single; Color: TBGRAPixel);
107
108 { Draw a hemisphere of the specified color }
109 procedure DrawSphere(dest: TBGRACustomBitmap; bounds: TRect; Altitude: Single; Color: TBGRAPixel);
110
111 { Draw a rectangle of the specified color }
112 procedure DrawRectangle(dest: TBGRACustomBitmap; bounds: TRect; Border: Integer; Altitude: Single; Color: TBGRAPixel; RoundCorners: Boolean; Options: TRectangleMapOptions);
113
114 protected
115
116 procedure DrawMapNormal(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: single; ofsX,ofsY: integer;
117 ColorMap : TBGRACustomBitmap);
118 procedure DrawScannerNormal(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: single; ofsX,ofsY: integer;
119 ColorScan : IBGRAScanner);
120 procedure DrawColorNormal(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: single; ofsX,ofsY: integer;
121 Color : TBGRAPixel);
122
123 {$ifdef BGRASSE_AVAILABLE}
124 procedure DrawMapSSE(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: single; ofsX,ofsY: integer;
125 ColorMap : TBGRACustomBitmap);
126 procedure DrawScannerSSE(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: single; ofsX,ofsY: integer;
127 ColorScan : IBGRAScanner);
128 procedure DrawColorSSE(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: single; ofsX,ofsY: integer;
129 Color : TBGRAPixel);
130 {$endif}
131 end;
132
133 { Create a grayscale height map for a cone (may not be precise enough) }
CreateConeMapnull134 function CreateConeMap(size: integer): TBGRABitmap;
135
136 { Create a precise height map for a cone (not grayscale anymore but more precise) }
CreateConePreciseMapnull137 function CreateConePreciseMap(width,height: integer): TBGRABitmap;
138
139 { Create a precise height map for a vertical cone (not grayscale anymore but more precise) }
CreateVerticalConePreciseMapnull140 function CreateVerticalConePreciseMap(width,height: integer): TBGRABitmap;
141
142 { Create a precise height map for a vertical cylinder (not grayscale anymore but more precise) }
CreateVerticalCylinderPreciseMapnull143 function CreateVerticalCylinderPreciseMap(width,height: integer): TBGRABitmap;
144
145 { Create a precise height map for an horizontal cylinder (not grayscale anymore but more precise) }
CreateHorizontalCylinderPreciseMapnull146 function CreateHorizontalCylinderPreciseMap(width,height: integer): TBGRABitmap;
147
148 { Create a grayscale height map for a sphere (may not be precise enough) }
CreateSphereMapnull149 function CreateSphereMap(width,height: integer): TBGRABitmap;
150
151 { Create a precise height map for a sphere (not grayscale anymore but more precise) }
CreateSpherePreciseMapnull152 function CreateSpherePreciseMap(width,height: integer): TBGRABitmap;
153
154 { Create a rectangle height map with a border }
CreateRectangleMapnull155 function CreateRectangleMap(width,height,border: integer; options: TRectangleMapOptions = []): TBGRABitmap;
156
157 { Create a precise height map for a rectangle height map with a border (not grayscale anymore but more precise) }
CreateRectanglePreciseMapnull158 function CreateRectanglePreciseMap(width,height,border: integer; options: TRectangleMapOptions = []): TBGRABitmap;
CreateRectanglePreciseMapnull159 function CreateRectanglePreciseMap(width, height, borderWidth, borderHeight: integer; options: TRectangleMapOptions): TBGRABitmap;
160
161 { Create a round rectangle height map with a border }
CreateRoundRectangleMapnull162 function CreateRoundRectangleMap(width,height,border: integer; options: TRectangleMapOptions = []): TBGRABitmap;
163
164 { Create a precise height map for a round rectangle height map with a border (not grayscale anymore but more precise) }
CreateRoundRectanglePreciseMapnull165 function CreateRoundRectanglePreciseMap(width,height,border: integer; options: TRectangleMapOptions = []): TBGRABitmap;
CreateRoundRectanglePreciseMapnull166 function CreateRoundRectanglePreciseMap(width,height,borderWidth,borderHeight: integer; options: TRectangleMapOptions = []): TBGRABitmap;
167
168 {---------- Perlin Noise -------------}
169 { Random image using a superposition of interpolated random values.
170 See : http://wiki.lazarus.freepascal.org/Perlin_Noise
171 http://freespace.virgin.net/hugo.elias/models/m_perlin.htm }
172
173 { Creates a non-tilable random grayscale image }
CreatePerlinNoiseMapnull174 function CreatePerlinNoiseMap(AWidth, AHeight: integer; HorizontalPeriod: Single = 1;
175 VerticalPeriod: Single = 1; Exponent: Double = 1; ResampleFilter: TResampleFilter = rfCosine): TBGRABitmap;
176
177 { Creates a tilable random grayscale image }
CreateCyclicPerlinNoiseMapnull178 function CreateCyclicPerlinNoiseMap(AWidth, AHeight: integer; HorizontalPeriod: Single = 1;
179 VerticalPeriod: Single = 1; Exponent: Double = 1; ResampleFilter: TResampleFilter = rfCosine): TBGRABitmap;
180
181 implementation
182
183 uses Math, SysUtils{$IFDEF BGRABITMAP_USE_LCL}, BGRATextFX{$ENDIF}; {GraphType unit used by phongdraw.inc}
184
TextShadownull185 {$IFDEF BGRABITMAP_USE_LCL}function TextShadow(AWidth, AHeight: Integer; AText: String;
186 AFontHeight: Integer; ATextColor, AShadowColor: TBGRAPixel; AOffSetX,
187 AOffSetY: Integer; ARadius: Integer; AFontStyle: TFontStyles;
188 AFontName: String; AShowText: Boolean): TBGRABitmap;
189 begin
190 result := BGRATextFX.TextShadow(AWidth,AHeight,AText,AFontHeight,ATextColor,AShadowColor,AOffsetX,AOffsetY,ARadius,AFontStyle,AFontName,AShowText) as TBGRABitmap;
191 end;{$ENDIF}
192
nGradientInfonull193 function nGradientInfo(StartColor, StopColor: TBGRAPixel;
194 Direction: TGradientDirection; EndPercent: Single): TnGradientInfo;
195 begin
196 result.StartColor := StartColor;
197 result.StopColor := StopColor;
198 result.Direction := Direction;
199 result.EndPercent := EndPercent;
200 end;
201
DoubleGradientAlphaFillnull202 function DoubleGradientAlphaFill(ARect: TRect; AStart1,AStop1,AStart2,AStop2: TBGRAPixel;
203 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single): TBGRABitmap;
204 var
205 ABitmap: TBGRABitmap;
206 ARect1,ARect2: TRect;
207 APoint1,APoint2,APoint3,APoint4: TPointF;
208 begin
209 Dec(ARect.Right, ARect.Left);
210 ARect.Left := 0;
211 Dec(ARect.Bottom,ARect.Top);
212 ARect.Top := 0;
213
214 ABitmap := TBGRABitmap.Create(ARect.Right,ARect.Bottom);
215
216 if AValue <> 0 then ARect1:=ARect;
217 if AValue <> 1 then ARect2:=ARect;
218
219 if ADir = gdVertical then begin
220 ARect1.Bottom:=Round(ARect1.Bottom * AValue);
221 ARect2.Top:=ARect1.Bottom;
222 end
223 else if ADir = gdHorizontal then begin
224 ARect1.Right:=Round(ARect1.Right * AValue);
225 ARect2.Left:=ARect1.Right;
226 end;
227 if ADirection1 = gdVertical then begin
228 APoint1:=PointF(ARect1.Left,ARect1.Top);
229 APoint2:=PointF(ARect1.Left,ARect1.Bottom);
230 end
231 else if ADirection1 = gdHorizontal then begin
232 APoint1:=PointF(ARect1.Left,ARect1.Top);
233 APoint2:=PointF(ARect1.Right,ARect1.Top);
234 end;
235 if ADirection2 = gdVertical then begin
236 APoint3:=PointF(ARect2.Left,ARect2.Top);
237 APoint4:=PointF(ARect2.Left,ARect2.Bottom);
238 end
239 else if ADirection2 = gdHorizontal then begin
240 APoint3:=PointF(ARect2.Left,ARect2.Top);
241 APoint4:=PointF(ARect2.Right,ARect2.Top);
242 end;
243
244 if AValue <> 0 then
245 ABitmap.GradientFill(ARect1.Left,ARect1.Top,ARect1.Right,ARect1.Bottom,
246 AStart1,AStop1,gtLinear,APoint1,APoint2,dmSet,True);
247 if AValue <> 1 then
248 ABitmap.GradientFill( ARect2.Left,ARect2.Top,ARect2.Right,ARect2.Bottom,
249 AStart2,AStop2,gtLinear,APoint3,APoint4,dmSet,True);
250
251 Result:=ABitmap;
252 end;
253
DoubleGradientAlphaFillnull254 function DoubleGradientAlphaFill(AWidth, AHeight: Integer; AStart1, AStop1,
255 AStart2, AStop2: TBGRAPixel; ADirection1, ADirection2,
256 ADir: TGradientDirection; AValue: Single): TBGRABitmap;
257 begin
258 result := DoubleGradientAlphaFill(Rect(0,0,AWidth,AHeight),
259 AStart1,AStop1,AStart2,AStop2,
260 ADirection1,ADirection2, ADir, AValue);
261 end;
262
263 procedure DoubleGradientAlphaFill(ACanvas: TCanvas; ARect: TRect; AStart1,
264 AStop1, AStart2, AStop2: TBGRAPixel; ADirection1, ADirection2,
265 ADir: TGradientDirection; AValue: Single);
266 var
267 bmp: TBGRABitmap;
268 begin
269 bmp := DoubleGradientAlphaFill(ARect,AStart1,AStop1,AStart2,AStop2,ADirection1,ADirection2,ADir,AValue);
270 bmp.Draw(ACanvas,ARect.Left,ARect.Top,not bmp.HasTransparentPixels);
271 bmp.Free;
272 end;
273
274 procedure DoubleGradientAlphaFill(ABitmap: TBGRABitmap; ARect: TRect; AStart1,
275 AStop1, AStart2, AStop2: TBGRAPixel; ADirection1, ADirection2,
276 ADir: TGradientDirection; AValue: Single);
277 var
278 bmp: TBGRABitmap;
279 begin
280 bmp := DoubleGradientAlphaFill(ARect,AStart1,AStop1,AStart2,AStop2,ADirection1,ADirection2,ADir,AValue);
281 ABitmap.PutImage(ARect.Left,ARect.Top,bmp,dmDrawWithTransparency);
282 bmp.Free;
283 end;
284
nGradientAlphaFillnull285 function nGradientAlphaFill(ARect: TRect; ADir: TGradientDirection;
286 const AGradient: array of TnGradientInfo): TBGRABitmap;
287 var
288 i:integer;
289 AnRect, OldRect: TRect;
290 Point1, Point2: TPointF;
291 begin
292 Result := TBGRABitmap.Create(ARect.Right-ARect.Left,ARect.Bottom-ARect.Top);
293 Dec(ARect.Right, ARect.Left);
294 ARect.Left := 0;
295 Dec(ARect.Bottom,ARect.Top);
296 ARect.Top := 0;
297
298 OldRect := ARect;
299
300 if ADir = gdVertical then
301 OldRect.Bottom := ARect.Top
302 else
303 OldRect.Right := ARect.Left;
304
305 for i := 0 to high(AGradient) do
306 begin
307 AnRect:=OldRect;
308 if ADir = gdVertical then
309 begin
310 AnRect.Bottom:=Round((ARect.Bottom-ARect.Top) * AGradient[i].endPercent + ARect.Top);
311 AnRect.Top:=OldRect.Bottom;
312 Point1:=PointF(AnRect.Left,AnRect.Top);
313 Point2:=PointF(AnRect.Left,AnRect.Bottom);
314 end
315 else
316 begin
317 AnRect.Right:=Round((ARect.Right-ARect.Left) * AGradient[i].endPercent + ARect.Left);
318 AnRect.Left:=OldRect.Right;
319 Point1:=PointF(AnRect.Left,AnRect.Top);
320 Point2:=PointF(AnRect.Right,AnRect.Top);
321 end;
322 Result.GradientFill(AnRect.Left,AnRect.Top,AnRect.Right,AnRect.Bottom,
323 AGradient[i].StartColor,AGradient[i].StopColor,gtLinear,Point1,Point2,dmSet,True);
324 OldRect := AnRect;
325 end;
326 end;
327
nGradientAlphaFillnull328 function nGradientAlphaFill(AWidth, AHeight: Integer; ADir: TGradientDirection;
329 const AGradient: array of TnGradientInfo): TBGRABitmap;
330 begin
331 result := nGradientAlphaFill(Rect(0,0,AWidth,AHeight),ADir,AGradient);
332 end;
333
334 procedure nGradientAlphaFill(ACanvas: TCanvas; ARect: TRect;
335 ADir: TGradientDirection; const AGradient: array of TnGradientInfo);
336 var
337 bmp: TBGRABitmap;
338 begin
339 bmp := nGradientAlphaFill(ARect, ADir, AGradient);
340 bmp.Draw(ACanvas,ARect.Left,ARect.Top,not bmp.HasTransparentPixels);
341 bmp.Free;
342 end;
343
344 procedure nGradientAlphaFill(ABitmap: TBGRABitmap; ARect: TRect;
345 ADir: TGradientDirection; const AGradient: array of TnGradientInfo);
346 var
347 bmp: TBGRABitmap;
348 begin
349 bmp := nGradientAlphaFill(ARect, ADir, AGradient);
350 ABitmap.PutImage(ARect.Left,ARect.Top,bmp,dmDrawWithTransparency);
351 bmp.Free;
352 end;
353
354 { TPhongShading }
355
356 constructor TPhongShading.Create;
357 begin
358 //set default values
359 LightSourceIntensity := 500;
360 LightSourceDistanceTerm := 150;
361 LightSourceDistanceFactor := 1;
362 LightDestFactor := 1;
363 LightColor := BGRAWhite;
364 AmbientFactor := 0.3;
365 DiffusionFactor := 0.9;
366 DiffuseSaturation:= False;
367 NegativeDiffusionFactor := 0.1;
368 SpecularFactor := 0.6;
369 SpecularIndex := 10;
370 LightPosition3D := Point3D(-100,-100,100);
371 end;
372
373 Const
374 PhongLightPrecisionSh = 12;
375 PhongLightPrecision = 1 shl PhongLightPrecisionSh;
376 PhongLightPrecisionDiv2 = PhongLightPrecision shr 1;
377
378 {------------------ Phong drawing ----------------}
379 { Look for the fastest method available }
380 procedure TPhongShading.Draw(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: single; ofsX,ofsY: integer;
381 Color : TBGRAPixel);
382 begin
383 {$ifdef BGRASSE_AVAILABLE}
384 if UseSSE then
385 DrawColorSSE(dest,map,mapAltitude,ofsX,ofsY,Color)
386 else
387 {$endif}
388 DrawColorNormal(dest,map,mapAltitude,ofsX,ofsY,Color);
389 end;
390
391 procedure TPhongShading.Draw(dest: TBGRACustomBitmap; map: TBGRACustomBitmap;
392 mapAltitude: single; ofsX, ofsY: integer; ColorMap: TBGRACustomBitmap);
393 begin
394 {$ifdef BGRASSE_AVAILABLE}
395 if UseSSE then
396 DrawMapSSE(dest,map,mapAltitude,ofsX,ofsY,ColorMap)
397 else
398 {$endif}
399 DrawMapNormal(dest,map,mapAltitude,ofsX,ofsY,ColorMap);
400 end;
401
402 procedure TPhongShading.DrawScan(dest: TBGRACustomBitmap; map: TBGRACustomBitmap;
403 mapAltitude: single; ofsX, ofsY: integer; ColorScan: IBGRAScanner);
404 begin
405 {$ifdef BGRASSE_AVAILABLE}
406 if UseSSE then
407 DrawScannerSSE(dest,map,mapAltitude,ofsX,ofsY,ColorScan)
408 else
409 {$endif}
410 DrawScannerNormal(dest,map,mapAltitude,ofsX,ofsY,ColorScan);
411 end;
412
413 {------------------ End of phong drawing ----------------}
414
415 procedure TPhongShading.DrawCone(dest: TBGRACustomBitmap; X, Y, Size: Integer;
416 Altitude: Single; Color: TBGRAPixel);
417 var map: TBGRABitmap;
418 begin
419 map := CreateConePreciseMap(Size,Size);
420 Draw(dest,map,Altitude,X,Y,Color);
421 map.Free;
422 end;
423
424 procedure TPhongShading.DrawCone(dest: TBGRACustomBitmap; bounds: TRect;
425 Altitude: Single; Color: TBGRAPixel);
426 var map: TBGRABitmap;
427 temp: integer;
428 begin
429 if Bounds.Right < Bounds.Left then
430 begin
431 temp := Bounds.Left;
432 bounds.Left := bounds.Right;
433 Bounds.Right := temp;
434 end;
435 if Bounds.Bottom < Bounds.Top then
436 begin
437 temp := Bounds.Bottom;
438 bounds.Bottom := bounds.Top;
439 Bounds.Top := temp;
440 end;
441 map := CreateConePreciseMap(Bounds.Right-Bounds.Left,Bounds.Bottom-Bounds.Top);
442 Draw(dest,map,Altitude,bounds.Left,bounds.Top,Color);
443 map.Free;
444 end;
445
446 procedure TPhongShading.DrawVerticalCone(dest: TBGRACustomBitmap;
447 bounds: TRect; Altitude: Single; Color: TBGRAPixel);
448 var map: TBGRABitmap;
449 temp: integer;
450 begin
451 if Bounds.Right < Bounds.Left then
452 begin
453 temp := Bounds.Left;
454 bounds.Left := bounds.Right;
455 Bounds.Right := temp;
456 end;
457 if Bounds.Bottom < Bounds.Top then
458 begin
459 temp := Bounds.Bottom;
460 bounds.Bottom := bounds.Top;
461 Bounds.Top := temp;
462 end;
463 map := CreateVerticalConePreciseMap(Bounds.Right-Bounds.Left,Bounds.Bottom-Bounds.Top);
464 Draw(dest,map,Altitude,bounds.Left,bounds.Top,Color);
465 map.Free;
466 end;
467
468 procedure TPhongShading.DrawHorizontalCylinder(dest: TBGRACustomBitmap;
469 bounds: TRect; Altitude: Single; Color: TBGRAPixel);
470 var map: TBGRABitmap;
471 temp: integer;
472 begin
473 if Bounds.Right < Bounds.Left then
474 begin
475 temp := Bounds.Left;
476 bounds.Left := bounds.Right;
477 Bounds.Right := temp;
478 end;
479 if Bounds.Bottom < Bounds.Top then
480 begin
481 temp := Bounds.Bottom;
482 bounds.Bottom := bounds.Top;
483 Bounds.Top := temp;
484 end;
485 map := CreateHorizontalCylinderPreciseMap(Bounds.Right-Bounds.Left,Bounds.Bottom-Bounds.Top);
486 Draw(dest,map,Altitude,bounds.Left,bounds.Top,Color);
487 map.Free;
488 end;
489
490 procedure TPhongShading.DrawVerticalCylinder(dest: TBGRACustomBitmap;
491 bounds: TRect; Altitude: Single; Color: TBGRAPixel);
492 var map: TBGRABitmap;
493 temp: integer;
494 begin
495 if Bounds.Right < Bounds.Left then
496 begin
497 temp := Bounds.Left;
498 bounds.Left := bounds.Right;
499 Bounds.Right := temp;
500 end;
501 if Bounds.Bottom < Bounds.Top then
502 begin
503 temp := Bounds.Bottom;
504 bounds.Bottom := bounds.Top;
505 Bounds.Top := temp;
506 end;
507 map := CreateVerticalCylinderPreciseMap(Bounds.Right-Bounds.Left,Bounds.Bottom-Bounds.Top);
508 Draw(dest,map,Altitude,bounds.Left,bounds.Top,Color);
509 map.Free;
510 end;
511
512 procedure TPhongShading.DrawSphere(dest: TBGRACustomBitmap; bounds: TRect;
513 Altitude: Single; Color: TBGRAPixel);
514 var map: TBGRABitmap;
515 temp: integer;
516 begin
517 if Bounds.Right < Bounds.Left then
518 begin
519 temp := Bounds.Left;
520 bounds.Left := bounds.Right;
521 Bounds.Right := temp;
522 end;
523 if Bounds.Bottom < Bounds.Top then
524 begin
525 temp := Bounds.Bottom;
526 bounds.Bottom := bounds.Top;
527 Bounds.Top := temp;
528 end;
529 map := CreateSpherePreciseMap(Bounds.Right-Bounds.Left,Bounds.Bottom-Bounds.Top);
530 Draw(dest,map,Altitude,bounds.Left,bounds.Top,Color);
531 map.Free;
532 end;
533
534 procedure TPhongShading.DrawRectangle(dest: TBGRACustomBitmap; bounds: TRect;
535 Border: Integer; Altitude: Single; Color: TBGRAPixel; RoundCorners: Boolean; Options: TRectangleMapOptions);
536 var map: TBGRABitmap;
537 temp: integer;
538 begin
539 if Bounds.Right < Bounds.Left then
540 begin
541 temp := Bounds.Left;
542 bounds.Left := bounds.Right;
543 Bounds.Right := temp;
544 end;
545 if Bounds.Bottom < Bounds.Top then
546 begin
547 temp := Bounds.Bottom;
548 bounds.Bottom := bounds.Top;
549 Bounds.Top := temp;
550 end;
551 if border > 10 then
552 begin
553 if RoundCorners then
554 map := CreateRoundRectanglePreciseMap(Bounds.Right-Bounds.Left,Bounds.Bottom-Bounds.Top,Border,Options)
555 else
556 map := CreateRectanglePreciseMap(Bounds.Right-Bounds.Left,Bounds.Bottom-Bounds.Top,Border,Options);
557 end else
558 begin
559 if RoundCorners then
560 map := CreateRoundRectangleMap(Bounds.Right-Bounds.Left,Bounds.Bottom-Bounds.Top,Border,Options)
561 else
562 map := CreateRectangleMap(Bounds.Right-Bounds.Left,Bounds.Bottom-Bounds.Top,Border,Options);
563 end;
564 Draw(dest,map,Altitude,bounds.Left,bounds.Top,Color);
565 map.Free;
566 end;
567
568 procedure TPhongShading.DrawMapNormal(dest: TBGRACustomBitmap; map: TBGRACustomBitmap;
569 mapAltitude: single; ofsX, ofsY: integer; ColorMap: TBGRACustomBitmap);
570 {$I phongdraw.inc }
571
572 procedure TPhongShading.DrawColorNormal(dest: TBGRACustomBitmap; map: TBGRACustomBitmap;
573 mapAltitude: single; ofsX, ofsY: integer; Color: TBGRAPixel);
574 {$define PARAM_SIMPLECOLOR}
575 {$I phongdraw.inc }
576
577 procedure TPhongShading.DrawScannerNormal(dest: TBGRACustomBitmap;
578 map: TBGRACustomBitmap; mapAltitude: single; ofsX, ofsY: integer;
579 ColorScan: IBGRAScanner);
580 {$define PARAM_SCANNER}
581 {$I phongdraw.inc }
582
583 {$ifdef BGRASSE_AVAILABLE}
584 procedure TPhongShading.DrawMapSSE(dest: TBGRACustomBitmap; map: TBGRACustomBitmap;
585 mapAltitude: single; ofsX, ofsY: integer; ColorMap: TBGRACustomBitmap);
586 {$define PARAM_PHONGSSE}
587 {$I phongdraw.inc }
588
589 procedure TPhongShading.DrawColorSSE(dest: TBGRACustomBitmap; map: TBGRACustomBitmap;
590 mapAltitude: single; ofsX, ofsY: integer; Color: TBGRAPixel);
591 {$define PARAM_PHONGSSE}
592 {$define PARAM_SIMPLECOLOR}
593 {$I phongdraw.inc }
594
595 procedure TPhongShading.DrawScannerSSE(dest: TBGRACustomBitmap;
596 map: TBGRACustomBitmap; mapAltitude: single; ofsX, ofsY: integer;
597 ColorScan: IBGRAScanner);
598 {$define PARAM_PHONGSSE}
599 {$define PARAM_SCANNER}
600 {$I phongdraw.inc }
601
602 {$endif}
603
604 {************************ maps ***********************************}
605
CreateConeMapnull606 function CreateConeMap(size: integer): TBGRABitmap;
607 var cx,cy,r: single;
608 mask: TGrayscaleMask;
609 begin
610 cx := (size-1)/2;
611 cy := (size-1)/2;
612 r := (size-1)/2;
613 result := TBGRABitmap.Create(size,size);
614 result.GradientFill(0,0,size,size,BGRAWhite,BGRABlack,gtRadial,PointF(cx,cy),PointF(cx+r,cy),dmSet,False);
615
616 mask := TGrayscaleMask.Create(size,size,BGRABlack);
617 mask.FillEllipseAntialias(cx,cy,r,r,BGRAWhite);
618 result.ApplyMask(mask);
619 mask.Free;
620 end;
621
CreateConePreciseMapnull622 function CreateConePreciseMap(width,height: integer): TBGRABitmap;
623 var cx,cy,rx,ry,d: single;
624 xb,yb: integer;
625 p: PBGRAPixel;
626 mask: TGrayscaleMask;
627 begin
628 result := TBGRABitmap.Create(width,height);
629 cx := (width-1)/2;
630 cy := (height-1)/2;
631 rx := (width-1)/2;
632 ry := (height-1)/2;
633 for yb := 0 to height-1 do
634 begin
635 p := result.scanline[yb];
636 for xb := 0 to width-1 do
637 begin
638 d := sqr((xb-cx)/(rx+1))+sqr((yb-cy)/(ry+1));
639 if d >= 1 then
640 p^ := BGRAPixelTransparent else
641 p^ := MapHeightToBGRA(1-sqrt(d),255);
642 inc(p);
643 end;
644 end;
645 //antialiased border
646 mask := TGrayscaleMask.Create(width,height,BGRABlack);
647 mask.FillEllipseAntialias(cx,cy,rx,ry,BGRAWhite);
648 result.ApplyMask(mask);
649 mask.Free;
650 end;
651
CreateVerticalConePreciseMapnull652 function CreateVerticalConePreciseMap(width, height: integer): TBGRABitmap;
653 var cx,rx,d,vpos: single;
654 xb,yb: integer;
655 p: PBGRAPixel;
656 mask: TGrayscaleMask;
657 begin
658 result := TBGRABitmap.Create(width,height);
659 if (height=0) or (width=0) then exit;
660 cx := (width-1)/2;
661 for yb := 0 to height-1 do
662 begin
663 p := result.scanline[yb];
664 vpos := (yb+1)/height;
665 rx := width/2*vpos;
666 for xb := 0 to width-1 do
667 begin
668 d := sqr((xb-cx)/(rx+1));
669 if d >= 1 then
670 p^ := BGRAPixelTransparent else
671 p^ := MapHeightToBGRA(sqrt(1-d)*vpos,255);
672 inc(p);
673 end;
674 end;
675 //antialiased border
676 mask := TGrayscaleMask.Create(width,height,BGRABlack);
677 mask.FillPolyAntialias([PointF(width/2,-0.5),PointF(0,height-0.5),PointF(width-0.5,height-0.5)],BGRAWhite);
678 result.ApplyMask(mask);
679 mask.Free;
680 end;
681
CreateVerticalCylinderPreciseMapnull682 function CreateVerticalCylinderPreciseMap(width, height: integer): TBGRABitmap;
683 var cx,rx,d: single;
684 xb: integer;
685 begin
686 result := TBGRABitmap.Create(width,height);
687 if (height=0) or (width=0) then exit;
688 rx := width/2;
689 cx := (width-1)/2;
690 for xb := 0 to width-1 do
691 begin
692 d := sqr((xb-cx)/(rx+1));
693 result.SetVertLine(xb,0,height-1,MapHeightToBGRA(sqrt(1-d),255));
694 end;
695 end;
696
CreateHorizontalCylinderPreciseMapnull697 function CreateHorizontalCylinderPreciseMap(width, height: integer
698 ): TBGRABitmap;
699 var cy,ry,d: single;
700 xb,yb: integer;
701 p: PBGRAPixel;
702 c: TBGRAPixel;
703 begin
704 result := TBGRABitmap.Create(width,height);
705 if (height=0) or (width=0) then exit;
706 ry := height/2;
707 cy := (height-1)/2;
708 for yb := 0 to height-1 do
709 begin
710 p := result.scanline[yb];
711 d := sqr((yb-cy)/(ry+1));
712 c := MapHeightToBGRA(sqrt(1-d),255);
713 for xb := 0 to width-1 do
714 begin
715 p^ := c;
716 inc(p);
717 end;
718 end;
719 end;
720
CreateSphereMapnull721 function CreateSphereMap(width,height: integer): TBGRABitmap;
722 var cx,cy,rx,ry,d: single;
723 xb,yb: integer;
724 p: PBGRAPixel;
725 h: integer;
726 mask: TGrayscaleMask;
727 begin
728 result := TBGRABitmap.Create(width,height);
729 cx := (width-1)/2;
730 cy := (height-1)/2;
731 rx := (width-1)/2;
732 ry := (height-1)/2;
733 for yb := 0 to height-1 do
734 begin
735 p := result.scanline[yb];
736 for xb := 0 to width-1 do
737 begin
738 d := sqr((xb-cx)/(rx+1))+sqr((yb-cy)/(ry+1));
739 if d >= 1 then
740 p^ := BGRAPixelTransparent else
741 begin
742 h := round(sqrt(1-d)*255);
743 p^.red := h;
744 p^.green := h;
745 p^.blue := h;
746 p^.alpha := 255;
747 end;
748 inc(p);
749 end;
750 end;
751 //antialiased border
752 mask := TGrayscaleMask.Create(width,height,BGRABlack);
753 mask.FillEllipseAntialias(cx,cy,rx,ry,BGRAWhite);
754 result.ApplyMask(mask);
755 mask.Free;
756 end;
757
758 procedure MapBorderLimit(width,height: integer; options: TRectangleMapOptions; var border: integer);
759 var maxHoriz,maxVert: integer;
760 begin
761 if [rmoNoLeftBorder,rmoNoRightBorder] <= options then maxHoriz := border else
762 if [rmoNoLeftBorder,rmoNoRightBorder] * options = [] then maxHoriz := width div 2 else
763 maxHoriz := width;
764 if border > maxHoriz then border := maxHoriz;
765
766 if [rmoNoTopBorder,rmoNoBottomBorder] <= options then maxVert := border else
767 if [rmoNoTopBorder,rmoNoBottomBorder] * options = [] then maxVert := height div 2 else
768 maxVert := height;
769 if border > maxVert then border := maxVert;
770 end;
771
772 procedure MapBorderLimit(width,height: integer; options: TRectangleMapOptions; var borderHoriz,borderVert: integer);
773 var maxHoriz,maxVert: integer;
774 begin
775 if [rmoNoLeftBorder,rmoNoRightBorder] <= options then maxHoriz := borderHoriz else
776 if [rmoNoLeftBorder,rmoNoRightBorder] * options = [] then maxHoriz := width div 2 else
777 maxHoriz := width;
778 if borderHoriz > maxHoriz then borderHoriz := maxHoriz;
779
780 if [rmoNoTopBorder,rmoNoBottomBorder] <= options then maxVert := borderVert else
781 if [rmoNoTopBorder,rmoNoBottomBorder] * options = [] then maxVert := height div 2 else
782 maxVert := height;
783 if borderVert > maxVert then borderVert := maxVert;
784 end;
785
CreateSpherePreciseMapnull786 function CreateSpherePreciseMap(width, height: integer): TBGRABitmap;
787 var cx,cy,rx,ry,d: single;
788 xb,yb: integer;
789 p: PBGRAPixel;
790 mask: TGrayscaleMask;
791 begin
792 result := TBGRABitmap.Create(width,height);
793 cx := (width-1)/2;
794 cy := (height-1)/2;
795 rx := (width-1)/2;
796 ry := (height-1)/2;
797 for yb := 0 to height-1 do
798 begin
799 p := result.scanline[yb];
800 for xb := 0 to width-1 do
801 begin
802 d := sqr((xb-cx)/(rx+1))+sqr((yb-cy)/(ry+1));
803 if d >= 1 then
804 p^ := BGRAPixelTransparent else
805 p^ := MapHeightToBGRA(sqrt(1-d),255);
806 inc(p);
807 end;
808 end;
809 //antialiased border
810 mask := TGrayscaleMask.Create(width,height,BGRABlack);
811 mask.FillEllipseAntialias(cx,cy,rx,ry,BGRAWhite);
812 result.ApplyMask(mask);
813 mask.Free;
814 end;
815
816 procedure RectangleMapRemoveCorners(dest: TBGRABitmap; options: TRectangleMapOptions);
817 begin
818 if [rmoNoLeftBorder,rmoNoTopBorder]*Options = [] then
819 begin
820 dest.SetPixel(0,0,BGRAPixelTransparent);
821 dest.ErasePixel(1,0,128);
822 dest.ErasePixel(0,1,128);
823 end;
824
825 if [rmoNoRightBorder,rmoNoTopBorder]*Options = [] then
826 begin
827 dest.SetPixel(dest.width-1,0,BGRAPixelTransparent);
828 dest.ErasePixel(dest.width-2,0,128);
829 dest.ErasePixel(dest.width-1,1,128);
830 end;
831
832 if [rmoNoRightBorder,rmoNoBottomBorder]*Options = [] then
833 begin
834 dest.SetPixel(dest.width-1,dest.height-1,BGRAPixelTransparent);
835 dest.ErasePixel(dest.width-2,dest.height-1,128);
836 dest.ErasePixel(dest.width-1,dest.height-2,128);
837 end;
838
839 if [rmoNoLeftBorder,rmoNoBottomBorder]*Options = [] then
840 begin
841 dest.SetPixel(0,dest.height-1,BGRAPixelTransparent);
842 dest.ErasePixel(1,dest.height-1,128);
843 dest.ErasePixel(0,dest.height-2,128);
844 end;
845 end;
846
CreateRectangleMapnull847 function CreateRectangleMap(width,height,border: integer; options: TRectangleMapOptions = []): TBGRABitmap;
848 var xb,yb: integer;
849 p: PBGRAPixel;
850 h: integer;
851 begin
852 MapBorderLimit(width,height,options,border);
853
854 result := TBGRABitmap.Create(width,height);
855 for yb := 0 to height-1 do
856 begin
857 p := result.scanline[yb];
858 for xb := 0 to width-1 do
859 begin
860 if not (rmoNoLeftBorder in options) and (xb < border) and (yb > xb) and (yb < height-1-xb) then h := xb else
861 if not (rmoNoRightBorder in options) and (xb > width-1-border) and (yb > width-1-xb) and (yb < height-1-(width-1-xb)) then h := width-1-xb else
862 if not (rmoNoTopBorder in options) and (yb < border) and (xb > yb) and (xb < width-1-yb) then h := yb else
863 if not (rmoNoBottomBorder in options) and (yb > height-1-border) and (xb > height-1-yb) and (xb < width-1-(height-1-yb)) then h := height-1-yb else
864 if not (rmoNoLeftBorder in options) and (xb < border) then h := xb else
865 if not (rmoNoRightBorder in options) and (xb > width-1-border) then h := width-1-xb else
866 if not (rmoNoTopBorder in options) and (yb < border) then h := yb else
867 if not (rmoNoBottomBorder in options) and (yb > height-1-border) then h := height-1-yb else
868 begin
869 p^ := BGRAWhite;
870 inc(p);
871 Continue;
872 end;
873
874 if rmoLinearBorder in options then h := h*256 div border else
875 h := round(sin((h+1/2)/border*Pi/2)*255);
876 p^.red := h;
877 p^.green := h;
878 p^.blue := h;
879 p^.alpha := 255;
880 inc(p);
881 end;
882 end;
883
884 RectangleMapRemoveCorners(result,options);
885 end;
886
CreateRectanglePreciseMapnull887 function CreateRectanglePreciseMap(width, height, border: integer;
888 options: TRectangleMapOptions): TBGRABitmap;
889 var xb,yb: integer;
890 p: PBGRAPixel;
891 h: single;
892 begin
893 MapBorderLimit(width,height,options,border);
894
895 result := TBGRABitmap.Create(width,height);
896 for yb := 0 to height-1 do
897 begin
898 p := result.scanline[yb];
899 for xb := 0 to width-1 do
900 begin
901 if not (rmoNoLeftBorder in options) and (xb < border) and (yb > xb) and (yb < height-1-xb) then h := xb else
902 if not (rmoNoRightBorder in options) and (xb > width-1-border) and (yb > width-1-xb) and (yb < height-1-(width-1-xb)) then h := width-1-xb else
903 if not (rmoNoTopBorder in options) and (yb < border) and (xb > yb) and (xb < width-1-yb) then h := yb else
904 if not (rmoNoBottomBorder in options) and (yb > height-1-border) and (xb > height-1-yb) and (xb < width-1-(height-1-yb)) then h := height-1-yb else
905 if not (rmoNoLeftBorder in options) and (xb < border) then h := xb else
906 if not (rmoNoRightBorder in options) and (xb > width-1-border) then h := width-1-xb else
907 if not (rmoNoTopBorder in options) and (yb < border) then h := yb else
908 if not (rmoNoBottomBorder in options) and (yb > height-1-border) then h := height-1-yb else
909 begin
910 p^ := BGRAWhite;
911 inc(p);
912 Continue;
913 end;
914
915 if rmoLinearBorder in options then h := h/border else
916 h := sin((h+1/2)/border*Pi/2);
917
918 p^ := MapHeightToBGRA(h,255);
919
920 inc(p);
921 end;
922 end;
923
924 RectangleMapRemoveCorners(result,options);
925 end;
926
CreateRectanglePreciseMapnull927 function CreateRectanglePreciseMap(width, height, borderWidth, borderHeight: integer;
928 options: TRectangleMapOptions): TBGRABitmap;
929 var xb,yb, minBorder: integer;
930 p: PBGRAPixel;
931 h: single;
932 smallStep: single;
933 begin
934 MapBorderLimit(width,height,options,borderWidth,borderHeight);
935
936 minBorder := min(borderWidth,borderHeight);
937 if minBorder > 0 then smallStep := 1/minBorder else smallStep:= 0;
938
939 result := TBGRABitmap.Create(width,height);
940 for yb := 0 to height-1 do
941 begin
942 p := result.scanline[yb];
943 for xb := 0 to width-1 do
944 begin
945 if not (rmoNoLeftBorder in options) and (xb < borderWidth) and (yb < borderHeight) then
946 h := min(xb/borderWidth, yb/borderHeight) else
947 if not (rmoNoRightBorder in options) and (xb > width-1-borderWidth) and (yb < borderHeight) then
948 h := min((width-1-xb)/borderWidth, yb/borderHeight) else
949 if not (rmoNoTopBorder in options) and (xb < borderWidth) and (yb > height-1-borderHeight) then
950 h := min(xb/borderWidth, (height-1-yb)/borderHeight) else
951 if not (rmoNoBottomBorder in options) and (xb > width-1-borderWidth) and (yb > height-1-borderHeight) then
952 h := min((width-1-xb)/borderWidth, (height-1-yb)/borderHeight) else
953 if not (rmoNoLeftBorder in options) and (xb < borderWidth) then h := xb/borderWidth else
954 if not (rmoNoRightBorder in options) and (xb > width-1-borderWidth) then h := (width-1-xb)/borderWidth else
955 if not (rmoNoTopBorder in options) and (yb < borderHeight) then h := yb/borderHeight else
956 if not (rmoNoBottomBorder in options) and (yb > height-1-borderHeight) then h := (height-1-yb)/borderHeight else
957 begin
958 p^ := BGRAWhite;
959 inc(p);
960 Continue;
961 end;
962
963 if not (rmoLinearBorder in options) then
964 h := sin((h+smallStep*0.5)*Pi*0.5);
965
966 p^ := MapHeightToBGRA(h,255);
967
968 inc(p);
969 end;
970 end;
971
972 RectangleMapRemoveCorners(result,options);
973 end;
974
CreateRoundRectangleMapnull975 function CreateRoundRectangleMap(width,height,border: integer; options: TRectangleMapOptions = []): TBGRABitmap;
976 var d: single;
977 xb,yb: integer;
978 p: PBGRAPixel;
979 h: integer;
980 begin
981 MapBorderLimit(width,height,options,border);
982
983 result := TBGRABitmap.Create(width,height);
984 for yb := 0 to height-1 do
985 begin
986 p := result.scanline[yb];
987 for xb := 0 to width-1 do
988 begin
989 if not (rmoNoLeftBorder in options) and not (rmoNoTopBorder in options) and (xb < border) and (yb < border) then d := border-sqrt(sqr(border-xb)+sqr(border-yb)) else
990 if not (rmoNoLeftBorder in options) and not (rmoNoBottomBorder in options) and (xb < border) and (yb > height-1-border) then d := border-sqrt(sqr(border-xb)+sqr(border-(height-1-yb))) else
991 if not (rmoNoRightBorder in options) and not (rmoNoTopBorder in options) and (xb > width-1-border) and (yb < border) then d := border-sqrt(sqr(border-(width-1-xb))+sqr(border-yb)) else
992 if not (rmoNoRightBorder in options) and not (rmoNoBottomBorder in options) and (xb > width-1-border) and (yb > height-1-border) then d := border-sqrt(sqr(border-(width-1-xb))+sqr(border-(height-1-yb))) else
993 if not (rmoNoLeftBorder in options) and (xb < border) then d := xb else
994 if not (rmoNoRightBorder in options) and (xb > width-1-border) then d := width-1-xb else
995 if not (rmoNoTopBorder in options) and (yb < border) then d := yb else
996 if not (rmoNoBottomBorder in options) and (yb > height-1-border) then d := height-1-yb else
997 begin
998 p^ := BGRAWhite;
999 inc(p);
1000 Continue;
1001 end;
1002
1003 d := (d+1)*border/(border+1);
1004
1005 if d < 0 then
1006 p^ := BGRAPixelTransparent else
1007 begin
1008 if rmoLinearBorder in options then h := trunc(d*256/border) else
1009 h := round(sin((d+1/2)/border*Pi/2)*255);
1010
1011 p^.red := h;
1012 p^.green := h;
1013 p^.blue := h;
1014 if d < 1 then p^.alpha := round(d*255) else
1015 p^.alpha := 255;
1016 end;
1017 inc(p);
1018 end;
1019 end;
1020 end;
1021
CreatePerlinNoiseMapnull1022 function CreatePerlinNoiseMap(AWidth, AHeight: integer; HorizontalPeriod: Single;
1023 VerticalPeriod: Single; Exponent: Double = 1; ResampleFilter: TResampleFilter = rfCosine): TBGRABitmap;
1024
1025 procedure AddNoise(frequencyH, frequencyV: integer; amplitude: byte; dest: TBGRABitmap);
1026 var small,resampled: TBGRABitmap;
1027 p: PBGRAPixel;
1028 i: Integer;
1029 begin
1030 if (frequencyH = 0) or (frequencyV = 0) then exit;
1031 small := TBGRABitmap.Create(frequencyH,frequencyV);
1032 p := small.data;
1033 for i := 0 to small.NbPixels-1 do
1034 begin
1035 p^.red := random(amplitude);
1036 p^.green := p^.red;
1037 p^.blue := p^.green;
1038 p^.alpha := 255;
1039 inc(p);
1040 end;
1041 small.ResampleFilter := ResampleFilter;
1042 resampled := small.Resample(dest.Width,dest.Height);
1043 dest.BlendImage(0,0,resampled,boAdditive);
1044 resampled.Free;
1045 small.Free;
1046 end;
1047
1048 var
1049 i: Integer;
1050 temp: TBGRABitmap;
1051
1052 begin
1053 result := TBGRABitmap.Create(AWidth,AHeight);
1054 for i := 0 to 5 do
1055 AddNoise(round(AWidth / HorizontalPeriod / (32 shr i)),round(AHeight / VerticalPeriod / (32 shr i)), round(exp(ln((128 shr i)/128)*Exponent)*128),result);
1056
1057 temp := result.FilterNormalize(False);
1058 result.Free;
1059 result := temp;
1060
1061 temp := result.FilterBlurRadial(1,rbNormal);
1062 result.Free;
1063 result := temp;
1064 end;
1065
CreateCyclicPerlinNoiseMapnull1066 function CreateCyclicPerlinNoiseMap(AWidth, AHeight: integer; HorizontalPeriod: Single = 1;
1067 VerticalPeriod: Single = 1; Exponent: Double = 1; ResampleFilter: TResampleFilter = rfCosine): TBGRABitmap;
1068
1069 procedure AddNoise(frequencyH, frequencyV: integer; amplitude: byte; dest: TBGRABitmap);
1070 var small,cycled,resampled: TBGRABitmap;
1071 p: PBGRAPixel;
1072 i: Integer;
1073 begin
1074 if (frequencyH = 0) or (frequencyV = 0) then exit;
1075 small := TBGRABitmap.Create(frequencyH,frequencyV);
1076 p := small.data;
1077 for i := 0 to small.NbPixels-1 do
1078 begin
1079 p^.red := random(amplitude);
1080 p^.green := p^.red;
1081 p^.blue := p^.green;
1082 p^.alpha := 255;
1083 inc(p);
1084 end;
1085 cycled := small.GetPart(rect(-2,-2,small.Width+2,small.Height+2));
1086 cycled.ResampleFilter := ResampleFilter;
1087 resampled := cycled.Resample(round((cycled.Width-1)*(dest.Width/frequencyH)),round((cycled.Height-1)*(dest.Height/frequencyV)));
1088 dest.BlendImage(round(-2*(dest.Width/frequencyH)),round(-2*(dest.Height/frequencyV)),resampled,boAdditive);
1089 resampled.Free;
1090 cycled.Free;
1091 small.Free;
1092 end;
1093
1094 var
1095 i: Integer;
1096 temp: TBGRABitmap;
1097
1098 begin
1099 result := TBGRABitmap.Create(AWidth,AHeight);
1100 for i := 0 to 5 do
1101 AddNoise(round(AWidth / HorizontalPeriod / (32 shr i)),round(AHeight / VerticalPeriod / (32 shr i)), round(exp(ln((128 shr i)/128)*Exponent)*128),result);
1102
1103 temp := result.FilterNormalize(False);
1104 result.Free;
1105 result := temp;
1106
1107 temp := result.FilterBlurRadial(1,rbNormal);
1108 result.Free;
1109 result := temp;
1110 end;
1111
CreateRoundRectanglePreciseMapnull1112 function CreateRoundRectanglePreciseMap(width, height, border: integer;
1113 options: TRectangleMapOptions): TBGRABitmap;
1114 var d: single;
1115 xb,yb: integer;
1116 p: PBGRAPixel;
1117 h: single;
1118 begin
1119 MapBorderLimit(width,height,options,border);
1120
1121 result := TBGRABitmap.Create(width,height);
1122 for yb := 0 to height-1 do
1123 begin
1124 p := result.scanline[yb];
1125 for xb := 0 to width-1 do
1126 begin
1127 if not (rmoNoLeftBorder in options) and not (rmoNoTopBorder in options) and (xb < border) and (yb < border) then d := border-sqrt(sqr(border-xb)+sqr(border-yb)) else
1128 if not (rmoNoLeftBorder in options) and not (rmoNoBottomBorder in options) and (xb < border) and (yb > height-1-border) then d := border-sqrt(sqr(border-xb)+sqr(border-(height-1-yb))) else
1129 if not (rmoNoRightBorder in options) and not (rmoNoTopBorder in options) and (xb > width-1-border) and (yb < border) then d := border-sqrt(sqr(border-(width-1-xb))+sqr(border-yb)) else
1130 if not (rmoNoRightBorder in options) and not (rmoNoBottomBorder in options) and (xb > width-1-border) and (yb > height-1-border) then d := border-sqrt(sqr(border-(width-1-xb))+sqr(border-(height-1-yb))) else
1131 if not (rmoNoLeftBorder in options) and (xb < border) then d := xb else
1132 if not (rmoNoRightBorder in options) and (xb > width-1-border) then d := width-1-xb else
1133 if not (rmoNoTopBorder in options) and (yb < border) then d := yb else
1134 if not (rmoNoBottomBorder in options) and (yb > height-1-border) then d := height-1-yb else
1135 begin
1136 p^ := BGRAWhite;
1137 inc(p);
1138 Continue;
1139 end;
1140
1141 d := (d+1)*border/(border+1);
1142
1143 if d < 0 then
1144 p^ := BGRAPixelTransparent else
1145 begin
1146 if rmoLinearBorder in options then h := d/border else
1147 h := sin((d+1/2)/border*Pi/2);
1148
1149 if d < 1 then p^:= MapHeightToBGRA(h,round(d*255)) else
1150 p^ := MapHeightToBGRA(h,255);
1151 end;
1152 inc(p);
1153 end;
1154 end;
1155 end;
1156
CreateRoundRectanglePreciseMapnull1157 function CreateRoundRectanglePreciseMap(width, height, borderWidth,
1158 borderHeight: integer; options: TRectangleMapOptions): TBGRABitmap;
1159 var d: single;
1160 xb,yb: integer;
1161 p: PBGRAPixel;
1162 h,smallStep,factor: single;
1163 minBorder: integer;
1164 begin
1165 MapBorderLimit(width,height,options,borderWidth,borderHeight);
1166
1167 minBorder := min(borderWidth,borderHeight);
1168 if minBorder > 0 then smallStep := 1/minBorder else smallStep:= 0;
1169 factor := minBorder/(minBorder+1);
1170 result := TBGRABitmap.Create(width,height);
1171 for yb := 0 to height-1 do
1172 begin
1173 p := result.scanline[yb];
1174 for xb := 0 to width-1 do
1175 begin
1176 if not (rmoNoLeftBorder in options) and not (rmoNoTopBorder in options) and (xb < borderWidth) and (yb < borderHeight) then
1177 d := 1-sqrt(sqr((borderWidth-xb)/borderWidth)+sqr((borderHeight-yb)/borderHeight)) else
1178 if not (rmoNoLeftBorder in options) and not (rmoNoBottomBorder in options) and (xb < borderWidth) and (yb > height-1-borderHeight) then
1179 d := 1-sqrt(sqr((borderWidth-xb)/borderWidth)+sqr((borderHeight-(height-1-yb))/borderHeight)) else
1180 if not (rmoNoRightBorder in options) and not (rmoNoTopBorder in options) and (xb > width-1-borderWidth) and (yb < borderHeight) then
1181 d := 1-sqrt(sqr((borderWidth-(width-1-xb))/borderWidth)+sqr((borderHeight-yb)/borderHeight)) else
1182 if not (rmoNoRightBorder in options) and not (rmoNoBottomBorder in options) and (xb > width-1-borderWidth) and (yb > height-1-borderHeight) then
1183 d := 1-sqrt(sqr((borderWidth-(width-1-xb))/borderWidth)+sqr((borderHeight-(height-1-yb))/borderHeight)) else
1184 if not (rmoNoLeftBorder in options) and (xb < borderWidth) then d := xb/borderWidth else
1185 if not (rmoNoRightBorder in options) and (xb > width-1-borderWidth) then d := (width-1-xb)/borderWidth else
1186 if not (rmoNoTopBorder in options) and (yb < borderHeight) then d := yb/borderHeight else
1187 if not (rmoNoBottomBorder in options) and (yb > height-1-borderHeight) then d := (height-1-yb)/borderHeight else
1188 begin
1189 p^ := BGRAWhite;
1190 inc(p);
1191 Continue;
1192 end;
1193
1194 d := (d + smallStep)*factor;
1195
1196 if d < 0 then
1197 p^ := BGRAPixelTransparent else
1198 begin
1199 if rmoLinearBorder in options then h := d else
1200 h := sin((d+smallStep*0.5)*Pi*0.5);
1201
1202 if d < smallStep then p^:= MapHeightToBGRA(h,round(d/smallStep*255)) else
1203 p^ := MapHeightToBGRA(h,255);
1204 end;
1205 inc(p);
1206 end;
1207 end;
1208 end;
1209
1210 initialization
1211
1212 Randomize;
1213
1214 end.
1215
1216