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