Changeset 521 for GraphicTest/Packages/bgrabitmap/bgragradients.pas

Timestamp:

Apr 17, 2019, 12:58:41 AM (5 years ago)

Author:

chronos

Message:

• Modified: Propagate project build mode options to used packages.
• Added: Check memory leaks using heaptrc.
• Modified: Update BGRABitmap package.

Location:

GraphicTest

Files:

• . (modified) (1 prop)
• Packages/bgrabitmap/bgragradients.pas (modified) (7 diffs)

GraphicTest

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc

GraphicTest/Packages/bgrabitmap/bgragradients.pas

@@ -29 +29 @@
 function nGradientInfo(StartColor, StopColor: TBGRAPixel; Direction: TGradientDirection; EndPercent: Single): TnGradientInfo;
 
-function nGradientAlphaFill(ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo): TBGRABitmap;
-function nGradientAlphaFill(AWidth, AHeight: Integer; ADir: TGradientDirection; const AGradient: array of TnGradientInfo): TBGRABitmap;
-procedure nGradientAlphaFill(ACanvas: TCanvas; ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo);
-procedure nGradientAlphaFill(ABitmap: TBGRABitmap; ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo);
+function nGradientAlphaFill(ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo): TBGRABitmap; overload;
+function nGradientAlphaFill(AWidth, AHeight: Integer; ADir: TGradientDirection; const AGradient: array of TnGradientInfo): TBGRABitmap; overload;
+procedure nGradientAlphaFill(ACanvas: TCanvas; ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo); overload;
+procedure nGradientAlphaFill(ABitmap: TBGRABitmap; ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo); overload;
 
 function DoubleGradientAlphaFill(ARect: TRect; AStart1,AStop1,AStart2,AStop2: TBGRAPixel;
-                                 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single): TBGRABitmap;
+                                 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single): TBGRABitmap; overload;
 function DoubleGradientAlphaFill(AWidth,AHeight: Integer; AStart1,AStop1,AStart2,AStop2: TBGRAPixel;
-                                 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single): TBGRABitmap;
+                                 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single): TBGRABitmap; overload;
 procedure DoubleGradientAlphaFill(ACanvas: TCanvas; ARect: TRect; AStart1,AStop1,AStart2,AStop2: TBGRAPixel;
-                                 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single);
+                                 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single); overload;
 procedure DoubleGradientAlphaFill(ABitmap: TBGRABitmap; ARect: TRect; AStart1,AStop1,AStart2,AStop2: TBGRAPixel;
-                                 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single);
+                                 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single); overload;
 
 {----------------------------------------------------------------------}
@@ -155 +155 @@
 { Create a precise height map for a rectangle height map with a border (not grayscale anymore but more precise) }
 function CreateRectanglePreciseMap(width,height,border: integer; options: TRectangleMapOptions = []): TBGRABitmap;
+function CreateRectanglePreciseMap(width, height, borderWidth, borderHeight: integer; options: TRectangleMapOptions): TBGRABitmap;
 
 { Create a round rectangle height map with a border }
@@ -161 +162 @@
 { Create a precise height map for a round rectangle height map with a border (not grayscale anymore but more precise) }
 function CreateRoundRectanglePreciseMap(width,height,border: integer; options: TRectangleMapOptions = []): TBGRABitmap;
+function CreateRoundRectanglePreciseMap(width,height,borderWidth,borderHeight: integer; options: TRectangleMapOptions = []): TBGRABitmap;
 
 {---------- Perlin Noise -------------}
@@ -177 +179 @@
 implementation
 
-uses Types, SysUtils{$IFDEF BGRABITMAP_USE_LCL}, BGRATextFX{$ENDIF}; {GraphType unit used by phongdraw.inc}
+uses Types, Math, SysUtils{$IFDEF BGRABITMAP_USE_LCL}, BGRATextFX{$ENDIF}; {GraphType unit used by phongdraw.inc}
 
 {$IFDEF BGRABITMAP_USE_LCL}function TextShadow(AWidth, AHeight: Integer; AText: String;
@@ -767 +769 @@
 end;
 
+procedure MapBorderLimit(width,height: integer; options: TRectangleMapOptions; var borderHoriz,borderVert: integer);
+var maxHoriz,maxVert: integer;
+begin
+  if [rmoNoLeftBorder,rmoNoRightBorder] <= options then maxHoriz := borderHoriz else
+  if [rmoNoLeftBorder,rmoNoRightBorder] * options = [] then maxHoriz := width div 2 else
+    maxHoriz := width;
+  if borderHoriz > maxHoriz then borderHoriz := maxHoriz;
+
+  if [rmoNoTopBorder,rmoNoBottomBorder] <= options then maxVert := borderVert else
+  if [rmoNoTopBorder,rmoNoBottomBorder] * options = [] then maxVert := height div 2 else
+    maxVert := height;
+  if borderVert > maxVert then borderVert := maxVert;
+end;
+
 function CreateSpherePreciseMap(width, height: integer): TBGRABitmap;
 var cx,cy,rx,ry,d: single;
@@ -898 +914 @@
      if rmoLinearBorder in options then h := h/border else
        h := sin((h+1/2)/border*Pi/2);
+
+     p^ := MapHeightToBGRA(h,255);
+
+     inc(p);
+   end;
+  end;
+
+  RectangleMapRemoveCorners(result,options);
+end;
+
+function CreateRectanglePreciseMap(width, height, borderWidth, borderHeight: integer;
+  options: TRectangleMapOptions): TBGRABitmap;
+var xb,yb, minBorder: integer;
+    p: PBGRAPixel;
+    h: single;
+    smallStep: single;
+begin
+  MapBorderLimit(width,height,options,borderWidth,borderHeight);
+
+  minBorder := min(borderWidth,borderHeight);
+  if minBorder > 0 then smallStep := 1/minBorder else smallStep:= 0;
+
+  result := TBGRABitmap.Create(width,height);
+  for yb := 0 to height-1 do
+  begin
+   p := result.scanline[yb];
+   for xb := 0 to width-1 do
+   begin
+     if not (rmoNoLeftBorder in options) and (xb < borderWidth) and (yb < borderHeight) then
+        h := min(xb/borderWidth, yb/borderHeight) else
+     if not (rmoNoRightBorder in options) and (xb > width-1-borderWidth) and (yb < borderHeight) then
+        h := min((width-1-xb)/borderWidth, yb/borderHeight) else
+     if not (rmoNoTopBorder in options) and (xb < borderWidth) and (yb > height-1-borderHeight) then
+        h := min(xb/borderWidth, (height-1-yb)/borderHeight) else
+     if not (rmoNoBottomBorder in options) and  (xb > width-1-borderWidth) and (yb > height-1-borderHeight) then
+        h := min((width-1-xb)/borderWidth, (height-1-yb)/borderHeight) else
+     if not (rmoNoLeftBorder in options) and (xb < borderWidth) then h := xb/borderWidth else
+     if not (rmoNoRightBorder in options) and (xb > width-1-borderWidth) then h := (width-1-xb)/borderWidth else
+     if not (rmoNoTopBorder in options) and (yb < borderHeight) then h := yb/borderHeight else
+     if not (rmoNoBottomBorder in options) and (yb > height-1-borderHeight) then h := (height-1-yb)/borderHeight else
+     begin
+       p^ := BGRAWhite;
+       inc(p);
+       Continue;
+     end;
+
+     if not (rmoLinearBorder in options) then
+       h := sin((h+smallStep*0.5)*Pi*0.5);
 
      p^ := MapHeightToBGRA(h,255);
@@ -1090 +1154 @@
 end;
 
+function CreateRoundRectanglePreciseMap(width, height, borderWidth,
+  borderHeight: integer; options: TRectangleMapOptions): TBGRABitmap;
+var d: single;
+    xb,yb: integer;
+    p: PBGRAPixel;
+    h,smallStep,factor: single;
+    minBorder: integer;
+begin
+  MapBorderLimit(width,height,options,borderWidth,borderHeight);
+
+  minBorder := min(borderWidth,borderHeight);
+  if minBorder > 0 then smallStep := 1/minBorder else smallStep:= 0;
+  factor := minBorder/(minBorder+1);
+  result := TBGRABitmap.Create(width,height);
+  for yb := 0 to height-1 do
+  begin
+   p := result.scanline[yb];
+   for xb := 0 to width-1 do
+   begin
+     if not (rmoNoLeftBorder in options) and not (rmoNoTopBorder in options) and (xb < borderWidth) and (yb < borderHeight) then
+        d := 1-sqrt(sqr((borderWidth-xb)/borderWidth)+sqr((borderHeight-yb)/borderHeight)) else
+     if not (rmoNoLeftBorder in options) and not (rmoNoBottomBorder in options) and (xb < borderWidth) and (yb > height-1-borderHeight) then
+        d := 1-sqrt(sqr((borderWidth-xb)/borderWidth)+sqr((borderHeight-(height-1-yb))/borderHeight)) else
+     if not (rmoNoRightBorder in options) and not (rmoNoTopBorder in options) and (xb > width-1-borderWidth) and (yb < borderHeight) then
+        d := 1-sqrt(sqr((borderWidth-(width-1-xb))/borderWidth)+sqr((borderHeight-yb)/borderHeight)) else
+     if not (rmoNoRightBorder in options) and not (rmoNoBottomBorder in options) and (xb > width-1-borderWidth) and (yb > height-1-borderHeight) then
+        d := 1-sqrt(sqr((borderWidth-(width-1-xb))/borderWidth)+sqr((borderHeight-(height-1-yb))/borderHeight)) else
+     if not (rmoNoLeftBorder in options) and (xb < borderWidth) then d := xb/borderWidth else
+     if not (rmoNoRightBorder in options) and (xb > width-1-borderWidth) then d := (width-1-xb)/borderWidth else
+     if not (rmoNoTopBorder in options) and (yb < borderHeight) then d := yb/borderHeight else
+     if not (rmoNoBottomBorder in options) and (yb > height-1-borderHeight) then d := (height-1-yb)/borderHeight else
+     begin
+       p^ := BGRAWhite;
+       inc(p);
+       Continue;
+     end;
+
+     d := (d + smallStep)*factor;
+
+     if d < 0 then
+       p^ := BGRAPixelTransparent else
+     begin
+       if rmoLinearBorder in options then h := d else
+         h := sin((d+smallStep*0.5)*Pi*0.5);
+
+       if d < smallStep then p^:= MapHeightToBGRA(h,round(d/smallStep*255)) else
+         p^ := MapHeightToBGRA(h,255);
+     end;
+     inc(p);
+   end;
+  end;
+end;
+
 initialization
 

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc