1 // SPDX-License-Identifier: GPL-3.0-only
2 unit UGraph;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 Classes, SysUtils, bgrabitmap, bgrabitmaptypes, LazPaintType, Graphics, BGRALayers, LCLType,
10 BCComboBox;
11
12 var
13 NicePointMaxRadius: integer = 6;
14 FrameDashLength: integer = 4;
15 CanvasScale: integer = 1;
16
ComputeRationull17 function ComputeRatio(ARatio: string): single;
RatioToStrnull18 function RatioToStr(ARatio: single): string;
19
RectUnionnull20 function RectUnion(const rect1,Rect2: TRect): TRect;
RectInternull21 function RectInter(const rect1,Rect2: TRect): TRect;
RectOfsnull22 function RectOfs(const ARect: TRect; ofsX,ofsY: integer): TRect;
GetShapeBoundsnull23 function GetShapeBounds(const pts: array of TPointF; width: single): TRect;
DoPixelatenull24 function DoPixelate(source: TBGRABitmap; pixelSize: integer; quality: string): TBGRABitmap;
25 procedure DrawCheckers(bmp : TBGRABitmap; ARect: TRect; AScale: single = 1);
26 procedure DrawGrid(bmp: TBGRABitmap; sizex,sizey: single; ofsx,ofsy: single);
ComputeAnglenull27 function ComputeAngle(dx,dy: single): single;
GetSelectionCenternull28 function GetSelectionCenter(bmp: TBGRABitmap): TPointF;
29 procedure ComputeSelectionMask(image: TBGRABitmap; destMask: TBGRABitmap; ARect: TRect);
30 procedure SubstractMask(image: TBGRABitmap; DestX,DestY: Integer; mask: TBGRABitmap; SourceMaskRect: TRect);
NicePointBoundsnull31 function NicePointBounds(x,y: single): TRect;
NicePointnull32 function NicePoint(bmp: TBGRABitmap; x,y: single; alpha: byte = 192):TRect; overload;
NicePointnull33 function NicePoint(bmp: TBGRABitmap; ptF: TPointF; alpha: byte = 192):TRect; overload;
34 procedure NiceLine(bmp: TBGRABitmap; x1,y1,x2,y2: single; alpha: byte = 192);
NiceTextnull35 function NiceText(bmp: TBGRABitmap; x,y,bmpWidth,bmpHeight: integer; s: string; align: TAlignment = taLeftJustify; valign: TTextLayout = tlTop): TRect;
ComputeColorCirclenull36 function ComputeColorCircle(tx,ty: integer; light: word; hueCorrection: boolean = true): TBGRABitmap;
37
38 procedure RenderCloudsOn(bmp: TBGRABitmap; color: TBGRAPixel);
39 procedure RenderWaterOn(bmp: TBGRABitmap; waterColor, skyColor: TBGRAPixel);
40
CreateMetalFloorTexturenull41 function CreateMetalFloorTexture(tx: integer): TBGRABitmap;
CreatePlastikTexturenull42 function CreatePlastikTexture(tx,ty: integer): TBGRABitmap;
CreateCamouflageTexturenull43 function CreateCamouflageTexture(tx,ty: integer): TBGRABitmap;
CreateSnowPrintTexturenull44 function CreateSnowPrintTexture(tx,ty: integer): TBGRABitmap;
CreateRoundStoneTexturenull45 function CreateRoundStoneTexture(tx,ty: integer): TBGRABitmap;
CreateStoneTexturenull46 function CreateStoneTexture(tx,ty: integer): TBGRABitmap;
CreateWaterTexturenull47 function CreateWaterTexture(tx,ty: integer): TBGRABitmap;
CreateMarbleTexturenull48 function CreateMarbleTexture(tx,ty: integer): TBGRABitmap;
CreateWoodTexturenull49 function CreateWoodTexture(tx,ty: integer): TBGRABitmap;
CreateVerticalWoodTexturenull50 function CreateVerticalWoodTexture(tx,ty: integer): TBGRABitmap;
51
ClearTypeFilternull52 function ClearTypeFilter(source: TBGRACustomBitmap): TBGRACustomBitmap;
ClearTypeInverseFilternull53 function ClearTypeInverseFilter(source: TBGRACustomBitmap): TBGRACustomBitmap;
WaveDisplacementFilternull54 function WaveDisplacementFilter(source: TBGRACustomBitmap;
55 ARect: TRect; ACenter: TPointF;
56 AWaveLength, ADisplacement, APhase: single): TBGRACustomBitmap;
57
DoResamplenull58 function DoResample(source :TBGRABitmap; newWidth, newHeight: integer; StretchMode: TResampleMode): TBGRABitmap;
59 procedure DrawPenStyle(AComboBox: TBCComboBox; ARect: TRect; APenStyle: TPenStyle; State: TOwnerDrawState); overload;
60 procedure DrawPenStyle(ABitmap: TBGRABitmap; ARect: TRect; APenStyle: TPenStyle; c: TBGRAPixel); overload;
61 procedure DrawArrow(AComboBox: TBCComboBox; ARect: TRect; AStart: boolean; AKindStr: string; ALineCap: TPenEndCap; State: TOwnerDrawState); overload;
62 procedure DrawArrow(ABitmap: TBGRABitmap; ARect: TRect; AStart: boolean; AKindStr: string; ALineCap: TPenEndCap; AColor: TBGRAPixel); overload;
63
64 implementation
65
66 uses GraphType, math, Types, FileUtil, dialogs, BGRAAnimatedGif,
67 BGRAGradients, BGRATextFX, uresourcestrings, LCScaleDPI,
68 BGRAThumbnail, LCVectorPolyShapes, BGRAPolygon;
69
ComputeRationull70 function ComputeRatio(ARatio: string): single;
71 var
72 idxCol,errPos: Integer;
73 num,denom: double;
74 begin
75 result := 0;
76 ARatio := stringreplace(ARatio,FormatSettings.DecimalSeparator,'.',[rfReplaceAll]);
77 if ARatio = '' then exit;
78
79 idxCol := pos(':',ARatio);
80 if idxCol = 0 then exit;
81 val(copy(ARatio,1,idxCol-1),num,errPos);
82 if errPos <> 0 then exit;
83 if num < 0 then exit;
84 val(copy(ARatio,idxCol+1,length(ARatio)-idxCol),denom,errPos);
85 if errPos <> 0 then exit;
86 if denom <= 0 then exit;
87 result := num/denom;
88 end;
89
RatioToStrnull90 function RatioToStr(ARatio: single): string;
91 var
92 num,denom: integer;
93
94 procedure InvFrac;
95 var temp: integer;
96 begin
97 temp := num;
98 num := denom;
99 denom := temp;
100 end;
101
102 procedure AddFrac(AValue: integer);
103 begin
104 inc(num, AValue*denom);
105 end;
106
107 const MaxDev = 3;
108 var
109 dev: array[1..MaxDev] of integer;
110 devCount, i: integer;
111 curVal, remain: Single;
112
113 begin
114 if ARatio < 0 then ARatio := -ARatio;
115 curVal := ARatio;
116 devCount := 0;
117 repeat
118 inc(devCount);
119 dev[devCount] := trunc(ARatio);
120 remain := frac(curVal);
121 if abs(remain) < 1e-3 then break;
122 curVal := 1/remain;
123 until devCount = MaxDev;
124 num := dev[devCount];
125 denom := 1;
126 for i := devCount-1 downto 1 do
127 begin
128 InvFrac;
129 AddFrac(dev[i]);
130 end;
131 result := IntToStr(num)+':'+IntToStr(denom);
132 end;
133
RectUnionnull134 function RectUnion(const rect1, Rect2: TRect): TRect;
135 begin
136 if IsRectEmpty(rect1) then
137 begin
138 if IsRectEmpty(rect2) then
139 result := EmptyRect
140 else
141 result:= rect2;
142 end else
143 begin
144 result := rect1;
145 if not IsRectEmpty(rect2) then
146 UnionRect(result,result,rect2);
147 end;
148 end;
149
RectInternull150 function RectInter(const rect1, Rect2: TRect): TRect;
151 begin
152 result := EmptyRect;
153 IntersectRect(result,rect1,rect2);
154 end;
155
RectOfsnull156 function RectOfs(const ARect: TRect; ofsX, ofsY: integer): TRect;
157 begin
158 result := ARect;
159 OffsetRect(result,ofsX,ofsY);
160 end;
161
GetShapeBoundsnull162 function GetShapeBounds(const pts: array of TPointF; width: single): TRect;
163 var ix,iy,i: integer;
164 begin
165 width /= 2;
166 result.Left := high(Integer);
167 result.Top := high(Integer);
168 result.Right := low(Integer);
169 result.Bottom := low(Integer);
170 for i := 0 to high(pts) do
171 if not isEmptyPointF(pts[i]) then
172 begin
173 ix := floor(pts[i].x - width);
174 iy := floor(pts[i].y - width);
175 if ix < result.left then result.left := ix;
176 if iy < result.Top then result.top := iy;
177 ix := ceil(pts[i].x + width)+1;
178 iy := ceil(pts[i].y + width)+1;
179 if ix > result.right then result.right := ix;
180 if iy > result.bottom then result.bottom := iy;
181 end;
182 if (result.right <= result.left) or (result.bottom <= result.top) then
183 result := EmptyRect;
184 end;
185
DoPixelatenull186 function DoPixelate(source: TBGRABitmap; pixelSize: integer; quality: string): TBGRABitmap;
187 var
188 filter: TResampleFilter;
189 useFilter: boolean;
190 begin
191 if quality = rsMitchell then
192 filter := rfMitchell else
193 if quality = rsSpline then
194 filter := rfSpline
195 else
196 filter := rfLinear;
197 useFilter := quality <> rsFast;
198
199 result := source.FilterPixelate(pixelSize,useFilter,filter) as TBGRABitmap;
200 end;
201
202 procedure DrawCheckers(bmp: TBGRABitmap; ARect: TRect; AScale: single = 1);
203 begin
204 DrawThumbnailCheckers(bmp, ARect, False, AScale);
205 end;
206
207 procedure DrawGrid(bmp: TBGRABitmap; sizex, sizey: single; ofsx,ofsy: single);
208 var xb,yb: integer;
209 imgGrid: TBGRABitmap;
210 alpha: byte;
211 begin
212 ofsx := ofsx - floor(ofsx/sizex)*sizex;
213 ofsy := ofsy - floor(ofsy/sizey)*sizey;
214
215 imgGrid := TBGRABitmap.Create(bmp.Width,1);
216 alpha := min(96,round((abs(sizex)+abs(sizey))*(96/16/2)));
217 imgGrid.DrawLineAntialias(0,0,imgGrid.width-1,0,BGRA(255,255,255,alpha),BGRA(0,0,0,alpha),
218 min(3,max(1,round(sizex/8))),true);
219 for yb := 1 to ceil(bmp.Height/sizey) do
220 begin
221 bmp.PutImage(0,round(ofsy),imgGrid,dmFastBlend);
222 ofsy += sizey;
223 end;
224 imgGrid.Free;
225
226 imgGrid := TBGRABitmap.Create(1,bmp.Height);
227 imgGrid.DrawLineAntialias(0,0,0,imgGrid.height-1,BGRA(0,0,0,alpha),BGRA(255,255,255,alpha),
228 min(3,max(1,round(sizey/8))),true);
229 for xb := 1 to ceil(bmp.Width/sizex) do
230 begin
231 bmp.PutImage(round(ofsx),0,imgGrid,dmFastBlend);
232 ofsx += sizex;
233 end;
234 imgGrid.Free;
235 end;
236
237 procedure RenderCloudsOn(bmp: TBGRABitmap; color: TBGRAPixel);
238 const minDensity=180; maxDensity=240;
239 var i,k,x,y: integer;
240 fact,radius: single;
241 tempBmp: TBGRABitmap;
242 ptemp: PBGRAPixel;
243 begin
244 if color.alpha = 0 then exit;
245
246 tempBmp := TBGRABitmap.Create(bmp.width,bmp.Height,BGRABlack);
247 fact := (bmp.width+bmp.Height)/15;
248 for i := 120 downto 20 do
249 begin
250 for k := 1 to 2 do
251 begin
252 radius := ((i+random(50))/100)*fact;
253 x := random(bmp.Width);
254 y := random(bmp.Height);
255 tempBmp.GradientFill(floor(x-radius),floor(y-radius),ceil(x+radius),ceil(y+radius),BGRA(255,255,255,128),BGRAPixelTransparent,gtRadial,pointf(x,y),pointf(x+radius+0.5,y),dmFastBlend,false);
256 end;
257 end;
258
259 ptemp := tempBmp.Data;
260 for i := tempBmp.nbPixels-1 downto 0 do
261 begin
262 if ptemp^.red < minDensity then ptemp^:= BGRAPixelTransparent else
263 if ptemp^.red > maxDensity then ptemp^:= color else
264 ptemp^ := BGRA(color.red,color.green,color.blue,color.alpha*(ptemp^.red-minDensity) div (maxDensity-minDensity));
265 inc(ptemp);
266 end;
267 bmp.PutImage(0,0,tempBmp,dmDrawWithTransparency);
268 tempBmp.free;
269 end;
270
271 procedure RenderWaterOn(bmp: TBGRABitmap; waterColor, skyColor: TBGRAPixel);
272 var Noise,Temp: TBGRABitmap;
273 Phong: TPhongShading;
274 begin
275 Noise := CreateCyclicPerlinNoiseMap(bmp.Width,bmp.Height,1,1,1.2);
276 Temp := Noise.FilterBlurRadial(1,rbFast) as TBGRABitmap;
277 Noise.Free;
278 Noise := Temp;
279 Noise.ApplyGlobalOpacity(waterColor.alpha);
280 waterColor.alpha := 255;
281
282 Phong := TPhongShading.Create;
283 Phong.NegativeDiffusionFactor := 0.1;
284 Phong.AmbientFactor := 0.7;
285 Phong.LightSourceDistanceFactor := 0;
286 Phong.LightDestFactor := 0;
287 Phong.LightSourceIntensity := 300;
288 Phong.LightPosition := Point(-500,-500);
289 Phong.LightColor := skyColor;
290 Phong.Draw(bmp,Noise,30,0,0,waterColor);
291 Noise.Free;
292 Phong.Free;
293 end;
294
Interp256null295 function Interp256(value1,value2,position: integer): integer; inline;
296 begin
297 result := (value1*(256-position)+value2*position) shr 8;
298 end;
299
Interp256null300 function Interp256(color1,color2: TBGRAPixel; position: integer): TBGRAPixel; inline;
301 begin
302 result.red := Interp256(color1.red,color2.red,position);
303 result.green := Interp256(color1.green,color2.green,position);
304 result.blue := Interp256(color1.blue,color2.blue,position);
305 result.alpha := Interp256(color1.alpha,color2.alpha,position);
306 end;
307
CreateWoodTexturenull308 function CreateWoodTexture(tx,ty: integer): TBGRABitmap;
309 var
310 colorOscillation, globalColorVariation: integer;
311 p: PBGRAPixel;
312 i: Integer;
313 begin
314 result := CreateCyclicPerlinNoiseMap(tx,ty,1.5,1.5,1,rfBestQuality);
315 p := result.Data;
316 for i := 0 to result.NbPixels-1 do
317 begin
318 colorOscillation := round(sqrt((sin(p^.red*Pi/16)+1)/2)*256);
319 globalColorVariation := p^.red;
320 p^:= Interp256( Interp256(BGRA(247,188,120),BGRA(255,218,170),colorOscillation),
321 Interp256(BGRA(157,97,60),BGRA(202,145,112),colorOscillation), globalColorVariation);
322 inc(p);
323 end;
324 end;
325
CreateVerticalWoodTexturenull326 function CreateVerticalWoodTexture(tx, ty: integer): TBGRABitmap;
327 var
328 globalPos: single;
329 colorOscillation, globalColorVariation: integer;
330 p: PBGRAPixel;
331 i: Integer;
332 x,nbVertical: integer;
333 begin
334 result := CreateCyclicPerlinNoiseMap(tx,ty,1,1,1,rfBestQuality);
335 p := result.Data;
336 x := 0;
337 nbVertical := tx div 128;
338 if nbVertical = 0 then nbVertical := 1;
339 for i := 0 to result.NbPixels-1 do
340 begin
341 globalPos := p^.red*Pi/32 + nbVertical*x*2*Pi/tx*8;
342 colorOscillation := round(sqrt((sin(globalPos)+1)/2)*256);
343 globalColorVariation := p^.red; //round(sin(globalPos/8)*128+128);
344 p^:= Interp256( Interp256(BGRA(247,188,120),BGRA(255,218,170),colorOscillation),
345 Interp256(BGRA(157,97,60),BGRA(202,145,112),colorOscillation), globalColorVariation);
346 inc(p);
347 inc(x);
348 if x = tx then x := 0;
349 end;
350 end;
351
ClearTypeFilternull352 function ClearTypeFilter(source: TBGRACustomBitmap): TBGRACustomBitmap;
353 var
354 mul3,temp: TBGRACustomBitmap;
355 xb,yb: integer;
356 pmul3,pdest: PBGRAPixel;
357 a: byte;
358 begin
359 source.ResampleFilter := rfSpline;
360 mul3 := source.Resample(source.Width*3-2,source.Height);
361 temp := source.NewBitmap(source.Width*3,source.Height);
362 temp.PutImage(1,0,mul3,dmSet);
363 for yb := 0 to temp.Height-1 do
364 begin
365 temp.SetPixel(0,yb,temp.GetPixel(1,yb));
366 temp.SetPixel(temp.Width-1,yb,temp.GetPixel(temp.Width-2,yb));
367 end;
368 mul3.free;
369 mul3 := temp;
370 result := source.NewBitmap(source.Width,source.Height);
371 for yb := 0 to result.Height-1 do
372 begin
373 pmul3 := mul3.ScanLine[yb];
374 pdest := result.ScanLine[yb];
375 for xb := result.width-1 downto 0 do
376 begin
377 a := (pmul3+1)^.alpha;
378 if a = 0 then pdest^:= BGRAPixelTransparent
379 else
380 begin
381 pdest^.alpha := a;
382 if pmul3^.alpha = 0 then pdest^.red := 128 else
383 pdest^.red := pmul3^.red;
384 pdest^.green := (pmul3+1)^.green;
385 if (pmul3+2)^.alpha = 0 then pdest^.blue := 128 else
386 pdest^.blue := (pmul3+2)^.blue;
387 end;
388 inc(pdest);
389 inc(pmul3,3);
390 end;
391 end;
392 mul3.free;
393 end;
394
ClearTypeInverseSubFilternull395 function ClearTypeInverseSubFilter(source: TBGRACustomBitmap): TBGRACustomBitmap;
396 const
397 blueA = 20;
398 blueB = 0;
399 blueC = 2;
400 redA = 20;
401 redB = 0;
402 redC = 2;
403
404 maxV = 255;
405
406 var yb,xb: integer;
407 psrc,pdest,pgray: PBGRAPixel;
408 a,v: integer;
409 grayscale,temp: TBGRACustomBitmap;
Merge3null410 function Merge3(c1, c2, c3: TBGRAPixel): TBGRAPixel;
411 var c123: cardinal;
412 begin
413 if (c1.alpha = 0) then
414 Result := MergeBGRA(c2,c3)
415 else
416 if (c2.alpha = 0) then
417 Result := MergeBGRA(c1,c3)
418 else
419 if (c3.alpha = 0) then
420 Result := MergeBGRA(c1,c2)
421 else
422 begin
423 c123 := c1.alpha + c2.alpha + c3.alpha;
424 Result.red := (c1.red * c1.alpha + c2.red * c2.alpha + c3.red * c3.alpha + c123 shr 1) div c123;
425 Result.green := (c1.green * c1.alpha + c2.green * c2.alpha + c3.green * c3.alpha + c123 shr 1) div c123;
426 Result.blue := (c1.blue * c1.alpha + c2.blue * c2.alpha + c3.blue * c3.alpha + c123 shr 1) div c123;
427 Result.alpha := (c123 + 1) div 3;
428 end;
429 end;
430
431 begin
432 if source.width <= 1 then
433 begin
434 result := source.duplicate;
435 exit;
436 end;
437 grayscale := source;
438 temp := source.NewBitmap(source.Width,source.Height);
439 for yb := 0 to source.Height-1 do
440 begin
441 psrc := source.Scanline[yb];
442 pgray := grayscale.ScanLine[yb];
443 pdest := temp.Scanline[yb];
444 pdest^.red := psrc^.red;
445 pdest^.green := psrc^.green;
446 pdest^.alpha := psrc^.alpha;
447 a := (psrc^.alpha*blueA) - ((psrc+1)^.alpha*(blueB));
448 if a > 0 then
449 begin
450 v := ((integer(psrc^.blue)*blueA)*psrc^.alpha - integer((psrc+1)^.blue*blueB)*(psrc+1)^.alpha) div a;
451 if v >= maxV then
452 pdest^.blue := 255 else
453 if v > 0 then
454 pdest^.blue := v
455 else
456 pdest^.blue := 0;
457 end
458 else
459 pdest^.blue := psrc^.blue;
460 inc(pdest);
461 inc(psrc);
462 inc(pgray);
463 for xb := source.width-3 downto 0 do
464 begin
465 pdest^.green := psrc^.green;
466 pdest^.alpha := psrc^.alpha;
467
468 a := (psrc^.alpha*redA) - ((psrc-1)^.alpha*(redB));
469 if a > 0 then
470 begin
471 v := ((integer(psrc^.red)*redA)*psrc^.alpha - integer((psrc-1)^.red*redB+((pgray-1)^.green-pgray^.green)*redC)*(psrc-1)^.alpha) div a;
472 if v >= maxV then
473 pdest^.red := 255 else
474 if v > 0 then
475 pdest^.red := v
476 else
477 pdest^.red := 0;
478 end
479 else
480 pdest^.red := psrc^.red;
481
482 a := (psrc^.alpha*blueA) - ((psrc+1)^.alpha*(blueB));
483 if a > 0 then
484 begin
485 v := ((integer(psrc^.blue)*blueA)*psrc^.alpha - integer((psrc+1)^.blue*blueB+((pgray+1)^.green-pgray^.green)*blueC)*(psrc+1)^.alpha) div a;
486 if v >= maxV then
487 pdest^.blue := 255 else
488 if v > 0 then
489 pdest^.blue := v
490 else
491 pdest^.blue := 0;
492 end
493 else
494 pdest^.blue := psrc^.blue;
495 inc(pdest);
496 inc(psrc);
497 inc(pgray);
498 end;
499 pdest^.green := psrc^.green;
500 pdest^.blue := psrc^.blue;
501 pdest^.alpha := psrc^.alpha;
502
503 a := (psrc^.alpha*redA) - ((psrc-1)^.alpha*(redB));
504 if a > 0 then
505 begin
506 v := ((integer(psrc^.red)*redA)*psrc^.alpha - integer((psrc-1)^.red*redB)*(psrc-1)^.alpha) div a;
507 if v >= maxV then
508 pdest^.red := 255 else
509 if v > 0 then
510 pdest^.red := v
511 else
512 pdest^.red := 0;
513 end
514 else
515 pdest^.red := psrc^.red;
516 end;
517
518 result := temp;
519 end;
520
ClearTypeSharpenFilternull521 function ClearTypeSharpenFilter(source, diffbmp: TBGRACustomBitmap): TBGRACustomBitmap;
522 const
523 factnum = 3;
524 factdenom = 5;
525 var
526 xb,yb,maxx: integer;
527 psrc,pdest,pdiff: PBGRAPixel;
528 d1,d2 : integer;
529
clampnull530 function clamp(value: integer) : byte;
531 begin
532 if value <= 0 then result := 0
533 else if value >= 255 then result := 255
534 else result := value;
535 end;
536
adjustDiffnull537 function adjustDiff(ref,v1,v2: integer): integer;
538 begin
539 v1 -= ref;
540 v2 -= ref;
541 result := v1+v2;
542 end;
543
544 begin
545 if diffbmp = nil then diffbmp := source;
546 if (source.width <= 1) or (diffbmp.width <> source.width) or (diffbmp.height <> source.height) then
547 begin
548 result := source.Duplicate();
549 exit;
550 end;
551 result := source.NewBitmap(source.Width,source.Height);
552 for yb := 0 to result.Height-1 do
553 begin
554 psrc := source.ScanLine[yb];
555 pdest := result.ScanLine[yb];
556 pdiff := diffbmp.ScanLine[yb];
557 maxx := result.width-1;
558 for xb := 0 to maxx do
559 begin
560 if psrc^.alpha <> 0 then
561 begin
562 if (xb > 0) and ((psrc-1)^.alpha <>0) and (xb < maxx) and ((psrc+1)^.alpha <>0) then
563 begin
564 d1 := BGRADiff((pdiff-1)^,pdiff^);
565 d2 := BGRADiff((pdiff+1)^,pdiff^);
566 if (d1 > 20) and (d2 > 20) and (d1+d2 > 100) then
567 begin
568 pdest^.red := clamp(psrc^.red - (adjustDiff(psrc^.red,(psrc+1)^.red,(psrc-1)^.red))*factnum div (2*factdenom));
569 pdest^.green := psrc^.green;
570 pdest^.blue := clamp(psrc^.blue - (adjustDiff(psrc^.blue,(psrc+1)^.blue,(psrc-1)^.blue))*factnum div (2*factdenom));
571 pdest^.alpha := psrc^.alpha;
572 end
573 else
574 pdest^ := psrc^;
575 end else
576 if (xb < maxx) and ((psrc+1)^.alpha <>0) then
577 begin
578 pdest^.red := clamp(psrc^.red - ((psrc+1)^.red-psrc^.red) *factnum div factdenom);
579 pdest^.green := psrc^.green;
580 pdest^.blue := clamp(psrc^.blue - ((psrc+1)^.blue-psrc^.blue) *factnum div factdenom);
581 pdest^.alpha := psrc^.alpha;
582 end else
583 if (xb > 0) and ((psrc-1)^.alpha <>0) then
584 begin
585 pdest^.red := clamp(psrc^.red - ((psrc-1)^.red-psrc^.red)*factnum div factdenom);
586 pdest^.green := psrc^.green;
587 pdest^.blue := clamp(psrc^.blue - ((psrc-1)^.blue-psrc^.blue)*factnum div factdenom);
588 pdest^.alpha := psrc^.alpha;
589 end else
590 pdest^ := psrc^;
591 end else
592 pdest^ := BGRAPixelTransparent;
593
594 inc(pdest);
595 inc(psrc);
596 inc(pdiff);
597 end;
598 end;
599 end;
600
ClearTypeRemoveContradictionnull601 function ClearTypeRemoveContradiction(source: TBGRACustomBitmap): TBGRACustomBitmap;
602 var
603 xb,yb: integer;
604 dr,db: integer;
605 ratio: single;
606 psrc,pdest: PBGRAPixel;
607
608 begin
609 if source.width <= 1 then
610 begin
611 result := source.Duplicate();
612 exit;
613 end;
614 result := source.NewBitmap(source.Width,source.Height);
615 for yb := 0 to result.Height-1 do
616 begin
617 psrc := source.ScanLine[yb];
618 pdest := result.ScanLine[yb];
619 pdest^ := psrc^;
620 for xb := result.width-2 downto 0 do
621 begin
622 (pdest+1)^ := (psrc+1)^;
623 if (psrc^.alpha > 10) and ((psrc+1)^.alpha > 10) then
624 begin
625 dr := psrc^.red-(psrc+1)^.red;
626 db := psrc^.blue-(psrc+1)^.blue;
627 if ((db < 0) and (dr > 0)) or
628 ((db > 0) and (dr < 0)) then
629 begin
630 ratio := abs(dr/db);
631 if (ratio > 0.2) and (ratio < 5) then
632 begin
633 dr := (psrc^.red*psrc^.alpha+(psrc+1)^.red*(psrc+1)^.alpha) div (psrc^.alpha+(psrc+1)^.alpha);
634 db := (psrc^.blue*psrc^.alpha+(psrc+1)^.blue*(psrc+1)^.alpha) div (psrc^.alpha+(psrc+1)^.alpha);
635 pdest^.red := dr;
636 pdest^.blue := db;
637 (pdest+1)^.red := dr;
638 (pdest+1)^.blue := db;
639 end;
640 end;
641 end;
642 inc(pdest);
643 inc(psrc);
644 end;
645 end;
646 end;
647
ClearTypeInverseFilternull648 function ClearTypeInverseFilter(source: TBGRACustomBitmap): TBGRACustomBitmap;
649 var
650 mul3,temp: TBGRACustomBitmap;
651 xb,yb: integer;
652 pmul3,pdest: PBGRAPixel;
653 a: byte;
654 begin
655 source.ResampleFilter := rfSpline;
656 mul3 := source.Resample(source.Width*3-2,source.Height);
657 temp := source.NewBitmap(source.Width*3,source.Height);
658 temp.PutImage(1,0,mul3,dmSet);
659 for yb := 0 to temp.Height-1 do
660 begin
661 temp.SetPixel(0,yb,temp.GetPixel(1,yb));
662 temp.SetPixel(temp.Width-1,yb,temp.GetPixel(temp.Width-2,yb));
663 end;
664 mul3.free;
665 mul3 := temp;
666 result := source.NewBitmap(source.Width,source.Height);
667 for yb := 0 to result.Height-1 do
668 begin
669 pmul3 := mul3.ScanLine[yb];
670 pdest := result.ScanLine[yb];
671 for xb := result.width-1 downto 0 do
672 begin
673 a := (pmul3+1)^.alpha;
674 if a = 0 then pdest^:= BGRAPixelTransparent
675 else
676 begin
677 pdest^.alpha := a;
678 if (pmul3+2)^.alpha = 0 then pdest^.red := 128 else
679 pdest^.red := (pmul3+2)^.red;
680 pdest^.green := (pmul3+1)^.green;
681 if pmul3^.alpha = 0 then pdest^.blue := 128 else
682 pdest^.blue := pmul3^.blue;
683 end;
684 inc(pdest);
685 inc(pmul3,3);
686 end;
687 end;
688 mul3.free;
689
690 temp := ClearTypeRemoveContradiction(result);
691 result.free;
692 result := temp;
693
694 temp := result;
695 result := ClearTypeSharpenFilter(temp,source);
696 temp.Free;
697
698 temp := ClearTypeRemoveContradiction(result);
699 result.free;
700 result := temp;
701 end;
702
703 type
704 { TWaveDisplacementScanner }
705
706 TWaveDisplacementScanner = class(TBGRACustomScanner)
707 Source: TBGRACustomBitmap;
708 Center: TPointF;
709 Wavelength, Displacement, PhaseRad: single;
ScanAtnull710 function ScanAt(X,Y: Single): TBGRAPixel; override;
711 end;
712
713 { TWaveDisplacementScanner }
714
ScanAtnull715 function TWaveDisplacementScanner.ScanAt(X, Y: Single): TBGRAPixel;
716 var
717 u, disp: TPointF;
718 dist: Single;
719 alpha: ValReal;
720 begin
721 u := PointF(X,Y)-Center;
722 dist := VectLen(u);
723 if dist = 0 then disp := PointF(0,0) else
724 begin
725 u := u*(1/dist);
726 alpha := PhaseRad+dist*2*Pi/Wavelength;
727 disp := u*sin(alpha)*Displacement;
728 end;
729 result := Source.GetPixel(x+disp.x,y+disp.y);
730 end;
731
WaveDisplacementFilternull732 function WaveDisplacementFilter(source: TBGRACustomBitmap; ARect: TRect;
733 ACenter: TPointF; AWaveLength, ADisplacement, APhase: single): TBGRACustomBitmap;
734 var scan: TWaveDisplacementScanner;
735 begin
736 scan := TWaveDisplacementScanner.Create;
737 scan.Center := ACenter;
738 scan.Source := source;
739 scan.Wavelength := AWaveLength;
740 scan.Displacement := ADisplacement;
741 scan.PhaseRad := APhase*Pi/180;
742 result := TBGRABitmap.Create(source.Width,source.Height);
743 result.FillRect(ARect, scan, dmSet);
744 scan.Free;
745 end;
746
DoResamplenull747 function DoResample(source: TBGRABitmap; newWidth, newHeight: integer;
748 StretchMode: TResampleMode): TBGRABitmap;
749 begin
750 result := source.Resample(newWidth,newHeight,StretchMode) as TBGRABitmap;
751 end;
752
753 procedure DrawArrowMask(AMask: TBGRABitmap; AStart: boolean; AKindStr: string; ALineCap: TPenEndCap);
754 var
755 kind: TArrowKind;
756 x1,x2,xm1,xm2,y,w,temp: single;
757 begin
758 AMask.Fill(BGRABlack);
759 kind := StrToArrowKind(AKindStr);
760 ApplyArrowStyle(AMask.Arrow,AStart,kind,PointF(1.5,1.5));
761 AMask.LineCap := ALineCap;
762 w := AMask.Height/5;
763 if w > 0 then
764 begin
765 x1 := w*2.5;
766 x2 := 0;
767 xm1 := 0;
768 xm2 := w*2.5;
769 if kind in[akNone,akCut] then x1 -= w*0.7 else
770 if kind in[akFlipped,akFlippedCut] then x1 += w*0.7;
771 if not AStart then
772 begin
773 temp := x1;
774 x1 := -x2;
775 x2 := -temp;
776 end else
777 begin
778 xm1 := (AMask.Width-0.5)-xm1;
779 xm2 := (AMask.Width-0.5)-xm2;
780 end;
781 x1 -= 0.5;
782 x2 += AMask.Width-0.5;
783 y := (AMask.Height-1)/2;
784 if kind in[akTail,akNone,akTip] then w *= 2;
785 AMask.DrawLineAntialias(x1,y,x2,y,BGRAWhite,w);
786 if AMask.Width > AMask.Height*2 then
787 AMask.GradientFill(0,0,AMask.width,AMask.height,BGRABlack,BGRAPixelTransparent,gtLinear,PointF(xm1,0),PointF(xm2,0),dmDrawWithTransparency);
788 end;
789 end;
790
791 procedure DrawPenStyle(AComboBox: TBCComboBox; ARect: TRect;
792 APenStyle: TPenStyle; State: TOwnerDrawState);
793 var bmp : TBGRABitmap;
794 c,c2: TBGRAPixel;
795 scale: Double;
796 begin
797 if odSelected in State then
798 begin
799 c := ColorToBGRA(AComboBox.DropDownFontHighlight);
800 c2 := ColorToBGRA(AComboBox.DropDownHighlight);
801 end
802 else
803 begin
804 c := ColorToBGRA(AComboBox.DropDownFontColor);
805 c2 := ColorToBGRA(AComboBox.DropDownColor);
806 end;
807 scale := AComboBox.GetCanvasScaleFactor;
808 with Size(ARect) do bmp := TBGRABitmap.Create(round(cx*scale),round(cy*scale),c2);
809 DrawPenStyle(bmp, bmp.ClipRect,APenStyle, c);
810 bmp.Draw(ACombobox.Canvas,ARect,true);
811 bmp.Free;
812 end;
813
814 procedure DrawPenStyle(ABitmap: TBGRABitmap; ARect: TRect;
815 APenStyle: TPenStyle; c: TBGRAPixel);
816 begin
817 ABitmap.LineCap := pecFlat;
818 ABitmap.PenStyle:= APenStyle;
819 ABitmap.DrawLineAntialias(ARect.Left+ARect.Width/10-0.5,ARect.Top+ARect.Height/2-0.5,
820 ARect.Right-ARect.Width/10-0.5,ARect.Top+ARect.Height/2-0.5, c, ARect.Width/10);
821 end;
822
823 procedure DrawArrow(AComboBox: TBCComboBox; ARect: TRect; AStart: boolean; AKindStr: string; ALineCap: TPenEndCap; State: TOwnerDrawState);
824 var mask, bmp : TBGRABitmap;
825 c,c2: TBGRAPixel;
826 scale: Double;
827 begin
828 if odSelected in State then
829 begin
830 c2 := ColorToBGRA(AComboBox.DropDownHighlight);
831 c := ColorToBGRA(AComboBox.DropDownFontHighlight);
832 end else
833 begin
834 c2 := ColorToBGRA(AComboBox.DropDownColor);
835 c := ColorToBGRA(AComboBox.DropDownFontColor);
836 end;
837 scale := AComboBox.GetCanvasScaleFactor;
838 with Size(ARect) do mask:= TBGRABitmap.Create(round(cx*scale),round(cy*scale),BGRABlack);
839 DrawArrowMask(mask, AStart, AKindStr, ALineCap);
840 bmp := TBGRABitmap.Create(mask.Width,mask.Height,c2);
841 bmp.FillMask(0,0,mask,c,dmDrawWithTransparency);
842 bmp.Draw(ACombobox.Canvas,ARect,true);
843 bmp.Free;
844 mask.Free;
845 end;
846
847 procedure DrawArrow(ABitmap: TBGRABitmap; ARect: TRect; AStart: boolean; AKindStr: string; ALineCap: TPenEndCap; AColor: TBGRAPixel); overload;
848 var mask: TBGRABitmap;
849 begin
850 with Size(ARect) do mask:= TBGRABitmap.Create(cx,cy,BGRABlack);
851 DrawArrowMask(mask, AStart, AKindStr, ALineCap);
852 ABitmap.FillMask(ARect.Left,ARect.Top, mask, AColor, dmDrawWithTransparency);
853 mask.Free;
854 end;
855
CreateMarbleTexturenull856 function CreateMarbleTexture(tx,ty: integer): TBGRABitmap;
857 var
858 colorOscillation: integer;
859 p: PBGRAPixel;
860 i: Integer;
861 begin
862 result := CreateCyclicPerlinNoiseMap(tx,ty,0.5,0.5,0.8,rfBestQuality);
863 p := result.Data;
864 for i := 0 to result.NbPixels-1 do
865 begin
866 colorOscillation := round(sqrt(sqrt((sin(p^.red*Pi/128+0.5)+1)/2))*256);
867 p^ := Interp256(BGRA(161,117,105),BGRA(218,197,180),colorOscillation);
868 inc(p);
869 end;
870 end;
871
CreateWaterTexturenull872 function CreateWaterTexture(tx,ty: integer): TBGRABitmap;
873 const blurSize = 5;
874 var
875 temp: TBGRABitmap;
876 phong: TPhongShading;
877 begin
878 result := CreateCyclicPerlinNoiseMap(tx,ty,1,1,1.2,rfBestQuality);
879 temp:= result.GetPart(rect(-blurSize,-blurSize,tx+blurSize,ty+blurSize)) as TBGRABitmap;
880 BGRAReplace(temp,temp.FilterBlurRadial(blurSize,rbFast));
881 phong := TPhongShading.Create;
882 phong.LightSourceDistanceFactor := 0;
883 phong.LightDestFactor := 0;
884 phong.LightSourceIntensity := 150;
885 phong.LightPositionZ := 80;
886 phong.LightColor := BGRA(105,233,240);
887 phong.NegativeDiffusionFactor := 0.3;
888 phong.SpecularIndex := 20;
889 phong.AmbientFactor := 0.4;
890 phong.Draw(result,temp,20,-blurSize,-blurSize,BGRA(28,139,166));
891 phong.Free;
892 temp.Free;
893 end;
894
CreateStoneTexturenull895 function CreateStoneTexture(tx,ty: integer): TBGRABitmap;
896 var
897 temp: TBGRABitmap;
898 phong: TPhongShading;
899 begin
900 result := CreateCyclicPerlinNoiseMap(tx,ty,1,1,0.6);
901 temp:= result.GetPart(rect(-2,-2,tx+2,ty+2)) as TBGRABitmap;
902 phong := TPhongShading.Create;
903 phong.LightSourceDistanceFactor := 0;
904 phong.LightDestFactor := 0;
905 phong.LightSourceIntensity := 100;
906 phong.LightPositionZ := 100;
907 phong.NegativeDiffusionFactor := 0.3;
908 phong.AmbientFactor := 0.5;
909 phong.Draw(result,temp,30,-2,-2,BGRA(170,170,170));
910 phong.Free;
911 temp.Free;
912 end;
913
CreateRoundStoneTexturenull914 function CreateRoundStoneTexture(tx,ty: integer): TBGRABitmap;
915 var
916 temp: TBGRABitmap;
917 phong: TPhongShading;
918 begin
919 result := CreateCyclicPerlinNoiseMap(tx,ty,1,1,1.2,rfBestQuality);
920 temp:= result.GetPart(rect(-2,-2,tx+2,ty+2)) as TBGRABitmap;
921 BGRAReplace(temp,temp.FilterBlurRadial(2,rbFast));
922 phong := TPhongShading.Create;
923 phong.LightSourceDistanceFactor := 0;
924 phong.LightDestFactor := 0;
925 phong.LightSourceIntensity := 70;
926 phong.LightPositionZ := 100;
927 phong.NegativeDiffusionFactor := 0;
928 phong.SpecularIndex := 10;
929 phong.AmbientFactor := 0.5;
930 phong.LightColor := BGRA(255,255,192);
931 phong.Draw(result,temp,30,-2,-2,BGRA(170,170,170));
932 phong.Free;
933 temp.Free;
934 end;
935
CreateSnowPrintTexturenull936 function CreateSnowPrintTexture(tx,ty: integer): TBGRABitmap;
937 var
938 v: single;
939 p: PBGRAPixel;
940 i: Integer;
941
942 temp: TBGRABitmap;
943 phong: TPhongShading;
944 begin
945 result := CreateCyclicPerlinNoiseMap(tx,ty,1,1,1.2,rfBestQuality);
946
947 p := result.Data;
948 for i := 0 to result.NbPixels-1 do
949 begin
950 v := p^.red;
951 if v > 80 then v := (v-80)/10+80;
952 if v < 50 then v := 50-(50-v)/10;
953 p^ := MapHeightToBGRA(v/255,255);
954 inc(p);
955 end;
956
957 temp:= result.GetPart(rect(-2,-2,tx+2,ty+2)) as TBGRABitmap;
958 phong := TPhongShading.Create;
959 phong.LightSourceDistanceFactor := 0;
960 phong.LightDestFactor := 0;
961 phong.LightSourceIntensity := 100;
962 phong.LightPositionZ := 100;
963 phong.NegativeDiffusionFactor := 0.3;
964 phong.Draw(result,temp,30,-2,-2,BGRAWhite);
965 phong.Free;
966 temp.Free;
967 end;
968
CreateCamouflageTexturenull969 function CreateCamouflageTexture(tx,ty: integer): TBGRABitmap;
970 var
971 v: integer;
972 p: PBGRAPixel;
973 i: Integer;
974
975 temp: TBGRABitmap;
976 begin
977 result := CreateCyclicPerlinNoiseMap(tx,ty,1,1,1,rfBestQuality);
978
979 p := result.Data;
980 for i := 0 to result.NbPixels-1 do
981 begin
982 v := p^.red;
983 if v < 64 then p^:= BGRA(31,33,46) else
984 if v < 128 then p^:= BGRA(89,71,57) else
985 if v < 192 then p^:= BGRA(80,106,67) else
986 p^:= BGRA(161,157,121);
987 inc(p);
988 end;
989
990 temp := result.getPart(rect(-2,-2,tx+2,ty+2)) as TBGRABitmap;
991 BGRAReplace(temp,temp.FilterMedian(moMediumSmooth));
992 result.PutImage(-2,-2,temp,dmSet);
993 temp.Free;
994 end;
995
CreatePlastikTexturenull996 function CreatePlastikTexture(tx,ty: integer): TBGRABitmap;
997 const blurSize = 2;
998 var
999 temp: TBGRABitmap;
1000 phong: TPhongShading;
1001 p: PBGRAPixel;
1002 i: Integer;
1003 v: Byte;
1004 begin
1005 result := CreateCyclicPerlinNoiseMap(tx,ty,1,1,1);
1006
1007 p := result.Data;
1008 for i := 0 to result.NbPixels-1 do
1009 begin
1010 v := p^.red;
1011 if v < 32 then v:= v*2 else
1012 if (v > 32) and (v < 224) then v := (v-32) div 2 + 64 else
1013 if v >= 224 then v:= (v-224)*2+(224-32) div 2;
1014 p^:= BGRA(v,v,v);
1015 inc(p);
1016 end;
1017
1018 temp:= result.GetPart(rect(-blurSize,-blurSize,tx+blurSize,ty+blurSize)) as TBGRABitmap;
1019 BGRAReplace(temp,temp.FilterNormalize(False));
1020 BGRAReplace(temp,temp.FilterBlurMotion(ty div 6,90,False));
1021 BGRAReplace(temp,temp.FilterBlurRadial(blurSize,rbFast));
1022
1023 phong := TPhongShading.Create;
1024 phong.LightSourceDistanceFactor := 0;
1025 phong.LightDestFactor := 0;
1026 phong.LightSourceIntensity := 300;
1027 phong.LightPositionZ := 10;
1028 phong.NegativeDiffusionFactor := 0;
1029 phong.AmbientFactor := 0.6;
1030 phong.SpecularIndex := 25;
1031 phong.SpecularFactor:= 10;
1032 phong.Draw(result,temp,10,-blurSize,-blurSize,BGRA(58,206,113));
1033 phong.Free;
1034 temp.Free;
1035 end;
1036
CreateMetalFloorTexturenull1037 function CreateMetalFloorTexture(tx: integer): TBGRABitmap;
1038 var
1039 temp,noise: TBGRABitmap;
1040 phong: TPhongShading;
1041 ty: integer;
1042 begin
1043 ty := tx div 2;
1044 result := TBGRABitmap.Create(tx,ty,BGRABlack);
1045 result.FillEllipseAntialias(tx*1.2/8,ty/2,tx/20,ty/3,BGRA(240,240,240));
1046 result.FillEllipseAntialias(tx*2.8/8,ty/2,tx/20,ty/3,BGRA(240,240,240));
1047 result.FillEllipseAntialias(tx*3/4,ty*1.2/4,ty/3,tx/20,BGRA(240,240,240));
1048 result.FillEllipseAntialias(tx*3/4,ty*2.8/4,ty/3,tx/20,BGRA(240,240,240));
1049 BGRAReplace(result,result.FilterBlurRadial(1,rbFast));
1050
1051 noise := CreateCyclicPerlinNoiseMap(tx,ty,1,1,1);
1052 noise.FillRect(0,0,tx,ty,BGRA(0,0,0,220),dmLinearBlend);
1053 result.BlendImage(0,0,noise,boAdditive);
1054 noise.free;
1055
1056 temp:= result.GetPart(rect(-2,-2,tx+2,ty+2)) as TBGRABitmap;
1057 phong := TPhongShading.Create;
1058 phong.LightSourceDistanceFactor := 0;
1059 phong.LightDestFactor := 0;
1060 phong.LightSourceIntensity := 100;
1061 phong.LightPositionZ := 80;
1062 phong.NegativeDiffusionFactor := 0;
1063 phong.AmbientFactor := 0.5;
1064 phong.Draw(result,temp,10,-2,-2,BGRA(116,116,116));
1065 phong.Free;
1066 temp.Free;
1067 end;
1068
ComputeAnglenull1069 function ComputeAngle(dx, dy: single): single;
1070 begin
1071 if dy = 0 then
1072 begin
1073 if dx < 0 then result := 180 else result := 0;
1074 end else
1075 if dx = 0 then
1076 begin
1077 if dy < 0 then result := -90 else result := 90;
1078 end else
1079 begin
1080 result := ArcTan(dy/dx)*180/Pi;
1081 if dx < 0 then result += 180;
1082 end;
1083 end;
1084
GetSelectionCenternull1085 function GetSelectionCenter(bmp: TBGRABitmap): TPointF;
1086 var xb,yb: integer; p: PBGRAPixel;
1087 xsum,ysum,asum,alpha: single;
1088 begin
1089 if bmp = nil then
1090 begin
1091 result := pointF(0,0);
1092 exit;
1093 end;
1094 xsum := 0;
1095 ysum := 0;
1096 asum := 0;
1097 for yb := 0 to bmp.Height-1 do
1098 begin
1099 p := bmp.ScanLine[yb];
1100 for xb := 0 to bmp.Width-1 do
1101 begin
1102 alpha := p^.red/255; inc(p);
1103 xsum += xb*alpha;
1104 ysum += yb*alpha;
1105 asum += alpha;
1106 end;
1107 end;
1108 if asum = 0 then
1109 result := pointF(bmp.width/2-0.5, bmp.Height/2-0.5) else
1110 result := pointF(xsum/asum,ysum/asum);
1111 end;
1112
1113 procedure ComputeSelectionMask(image: TBGRABitmap; destMask: TBGRABitmap; ARect: TRect);
1114 var
1115 aimage: byte;
1116 xb,yb: integer; pimage, pmask: PBGRAPixel;
1117 begin
1118 IntersectRect(ARect, ARect,rect(0,0,image.Width,image.Height));
1119 IntersectRect(ARect, ARect,rect(0,0,destMask.Width,destMask.Height));
1120 for yb := ARect.Top to ARect.Bottom-1 do
1121 begin
1122 pimage := image.ScanLine[yb]+ARect.Left;
1123 pmask := destMask.ScanLine[yb]+ARect.Left;
1124 for xb := ARect.Left to ARect.Right-1 do
1125 begin
1126 aimage := pimage^.alpha;
1127 pmask^ := BGRA(aimage,aimage,aimage,255);
1128 if aimage <> 0 then pimage^.alpha := 255;
1129 inc(pimage);
1130 inc(pmask);
1131 end;
1132 end;
1133 end;
1134
1135 procedure SubstractMask(image: TBGRABitmap; DestX,DestY: Integer; mask: TBGRABitmap; SourceMaskRect: TRect);
1136 var
1137 xb,yb: integer;
1138 pimage, pmask: PBGRAPixel;
1139 aimage, amask: byte;
1140 Delta: TPoint;
1141 begin
1142 if not IntersectRect(SourceMaskRect,SourceMaskRect,rect(0,0,mask.Width,mask.Height)) then exit;
1143 Delta.X := - SourceMaskRect.Left + DestX;
1144 Delta.Y := - SourceMaskRect.Top + DestY;
1145 OffsetRect(SourceMaskRect, Delta.x, Delta.y);
1146 if not IntersectRect(SourceMaskRect,SourceMaskRect,rect(0,0,image.Width,image.Height)) then exit;
1147 OffsetRect(SourceMaskRect, -Delta.x, -Delta.y);
1148 for yb := SourceMaskRect.Top to SourceMaskRect.Bottom-1 do
1149 begin
1150 pimage := image.ScanLine[yb+Delta.Y]+SourceMaskRect.Left+Delta.X;
1151 pmask := mask.ScanLine[yb]+SourceMaskRect.Left;
1152 for xb := SourceMaskRect.Left to SourceMaskRect.Right-1 do
1153 begin
1154 amask := pmask^.red;
1155 if amask <> 0 then
1156 begin
1157 aimage := pimage^.alpha;
1158 if aimage > amask then
1159 pimage^.alpha := aimage-amask else
1160 pimage^ := BGRAPixelTransparent;
1161 end;
1162 inc(pimage);
1163 inc(pmask);
1164 end;
1165 end;
1166 end;
1167
NicePointBoundsnull1168 function NicePointBounds(x,y: single): TRect;
1169 begin
1170 result := rect(floor(x)-NicePointMaxRadius*CanvasScale-1,floor(y)-NicePointMaxRadius*CanvasScale-1,
1171 ceil(x)+NicePointMaxRadius*CanvasScale+2,ceil(y)+NicePointMaxRadius*CanvasScale+2);
1172 end;
1173
NicePointnull1174 function NicePoint(bmp: TBGRABitmap; x, y: single; alpha: byte = 192): TRect;
1175 var
1176 multi: TBGRAMultishapeFiller;
1177 oldClip: TRect;
1178 begin
1179 result := NicePointBounds(x,y);
1180 if not Assigned(bmp) then exit;
1181 oldClip := bmp.ClipRect;
1182 bmp.IntersectClip(result);
1183 multi := TBGRAMultishapeFiller.Create;
1184 multi.AddEllipseBorder(x,y,NicePointMaxRadius*CanvasScale-1*CanvasScale,
1185 NicePointMaxRadius*CanvasScale-1*CanvasScale, CanvasScale*3, BGRA(0,0,0,alpha));
1186 multi.AddEllipseBorder(x,y,NicePointMaxRadius*CanvasScale-1*CanvasScale,
1187 NicePointMaxRadius*CanvasScale-1*CanvasScale, CanvasScale*1, BGRA(255,255,255,alpha));
1188 multi.PolygonOrder:= poLastOnTop;
1189 multi.Draw(bmp);
1190 multi.Free;
1191 bmp.ClipRect := oldClip;
1192 end;
1193
NicePointnull1194 function NicePoint(bmp: TBGRABitmap; ptF: TPointF; alpha: byte = 192): TRect;
1195 begin
1196 result := NicePoint(bmp,ptF.x,ptF.y,alpha);
1197 end;
1198
1199 procedure NiceLine(bmp: TBGRABitmap; x1, y1, x2, y2: single; alpha: byte = 192);
1200 begin
1201 if not Assigned(bmp) then exit;
1202 bmp.DrawLineAntialias(round(x1), round(y1), round(x2), round(y2),BGRA(0,0,0,alpha),3,True);
1203 bmp.DrawLineAntialias(round(x1), round(y1), round(x2), round(y2),BGRA(255,255,255,alpha),1,True);
1204 end;
1205
NiceTextnull1206 function NiceText(bmp: TBGRABitmap; x, y, bmpWidth,bmpHeight: integer; s: string; align: TAlignment; valign: TTextLayout): TRect;
1207 var fx: TBGRATextEffect;
1208 f: TFont;
1209 ofs: integer;
1210 previousClip: TRect;
1211 begin
1212 f := TFont.Create;
1213 f.Name := 'Arial';
1214 f.Height := DoScaleY(16*CanvasScale,OriginalDPI);
1215 ofs := DoScaleX(4*CanvasScale,OriginalDPI);
1216 fx := TBGRATextEffect.Create(s,f,true);
1217 if valign = tlBottom then y := y-fx.TextSize.cy else
1218 if valign = tlCenter then y := y-fx.TextSize.cy div 2;
1219 if y+fx.TextSize.cy > bmpHeight then y := bmpHeight-fx.TextSize.cy;
1220 if y < 0 then y := 0;
1221 if align = taRightJustify then x := x-fx.TextSize.cx else
1222 if align = taCenter then x := x-fx.TextSize.cx div 2;
1223 if x+fx.TextSize.cx > bmpWidth then x := bmpWidth-fx.TextSize.cx;
1224 if x < 0 then x := 0;
1225 result := rect(x,y,x+fx.TextWidth+2*ofs,y+fx.TextHeight+2*ofs);
1226 if Assigned(bmp) then
1227 begin
1228 previousClip := bmp.ClipRect;
1229 bmp.ClipRect := result;
1230 fx.DrawShadow(bmp,x+ofs,y+ofs,ofs,BGRABlack);
1231 fx.DrawOutline(bmp,x,y,BGRABlack);
1232 fx.Draw(bmp,x,y,BGRAWhite);
1233 bmp.ClipRect := previousClip;
1234 end;
1235 fx.Free;
1236 f.Free;
1237 end;
1238
ComputeColorCirclenull1239 function ComputeColorCircle(tx, ty: integer; light: word; hueCorrection: boolean = true): TBGRABitmap;
1240 var xb,yb : integer;
1241 pdest: PBGRAPixel;
1242 angle,xc,yc: single;
1243 ec: TExpandedPixel;
1244 c: TBGRAPixel;
1245 gray,level: Word;
1246 begin
1247 result := TBGRABitmap.Create(tx,ty);
1248 result.FillEllipseAntialias(tx/2-0.5,ty/2-0.5,tx/2,ty/2,BGRABlack);
1249 xc := tx/2-0.5;
1250 yc := ty/2-0.5;
1251 for yb := 0 to ty-1 do
1252 begin
1253 pdest := result.scanline[yb];
1254 For xb := 0 to tx-1 do
1255 begin
1256 if pdest^.alpha <> 0 then
1257 begin
1258 ec.alpha := $FFFF;
1259 angle := ComputeAngle(xb-xc,yb-yc);
1260 if angle < 0 then angle += 360;
1261 if hueCorrection then
1262 angle := GtoH(round(angle/360*65536) and 65535)/65536*360;
1263 if angle < 60 then
1264 begin
1265 ec.red := $FFFF;
1266 ec.green := round(angle/60*$FFFF);
1267 ec.blue := $0000;
1268 end else
1269 if angle < 120 then
1270 begin
1271 ec.red := $FFFF-round((angle-60)/60*$FFFF);
1272 ec.green := $FFFF;
1273 ec.blue := $0000;
1274 end else
1275 if angle < 180 then
1276 begin
1277 ec.red := $0000;
1278 ec.green := $FFFF;
1279 ec.blue := round((angle-120)/60*$FFFF);
1280 end else
1281 if angle < 240 then
1282 begin
1283 ec.red := $0000;
1284 ec.green := $FFFF-round((angle-180)/60*$FFFF);
1285 ec.blue := $FFFF;
1286 end else
1287 if angle < 300 then
1288 begin
1289 ec.red := round((angle-240)/60*$FFFF);
1290 ec.green := $0000;
1291 ec.blue := $FFFF;
1292 end else
1293 begin
1294 ec.red := $FFFF;
1295 ec.green := $0000;
1296 ec.blue := $FFFF-round((angle-300)/60*$FFFF);
1297 end;
1298 gray := min($FFFF,max(0,$FFFF - round((sqrt(sqr((xb-xc)/(tx/2))+sqr((yb-yc)/(ty/2)))*1.2-0.1)*$FFFF)));
1299 level := max(max(ec.red,ec.green),ec.blue);
1300 {$hints off}
1301 ec.red := (ec.red*(not gray)+level*gray) shr 16;
1302 ec.green := (ec.green*(not gray)+level*gray) shr 16;
1303 ec.blue := (ec.blue*(not gray)+level*gray) shr 16;
1304 {$hints on}
1305 ec.red := (ec.red*light) shr 16;
1306 ec.green := (ec.green*light) shr 16;
1307 ec.blue := (ec.blue*light) shr 16;
1308 c := GammaCompression(ec);
1309 c.alpha := pdest^.alpha;
1310 pdest^ := c;
1311 end;
1312 inc(pdest);
1313 end;
1314 end;
1315 end;
1316
1317 initialization
1318
1319 Randomize;
1320
1321 end.
1322
1323