unit UColorhelper;
interface
uses FMX.Graphics, FMX.ImgList, FMX.MultiResBitmap;
type
THueWeights =
Array [0 .. 360]
of Single;
TColorHelper =
class
private
class function calcHueWeights(
const Data: TBitmapData): THueWeights;
class function calcBestHSV(Data: TBitmapData;
const bestHue: Integer;
out bestH, bestS, bestV: Double): Boolean;
class function calcBestHue(
const hueWeights: THueWeights): Integer;
public
class procedure ColorToHSV(
const Color: Cardinal;
var H, S, V: Double);
class function HSVToColor(H, S, V: Double): Cardinal;
class procedure HSVtoRGB(
const H, S, V: Double;
var R, G, B: Double);
class procedure RGBToHSV(
const R, G, B: Double;
VAR H, S, V: Double);
class function CalcBestColor(
const ABitmap: TBitmap): Cardinal;
class function IsDarkColor(
const Color: Cardinal): Boolean;
class function AdjustOverlayColor(
const Color: Cardinal;
const DefaultColor: Cardinal = $FF7F7F7F): Cardinal;
class function createBlurredImage(input: TBitmap; radius: Integer;
blurResampleSize: Integer): TBitmap;
class procedure FastBlur(Dst: TBitmap; radius: Integer;
Passes: Integer = 3);
class procedure Grayscale(ABitmap: TBitmap; AColor: Cardinal = 0);
overload;
class procedure Grayscale(AList: TImageList; ABitmap:
String;
AColor: Cardinal = 0);
overload;
class procedure Grayscale(AList: TImageList; ABitmaps:
Array of String;
AColor: Cardinal = 0);
overload;
end;
implementation
uses System.Math, System.UITypes, System.Types;
const
BUCKET_SIZE = 5;
GREY_THRESHOLD = 4.0E-4;
INDEX_JUMP_SIZE = 23;
WEIGHT_THRESHOLD = 0.1;
const
VALUE_DAMPING_FACTOR = 0.8;
// RGB, each 0 to 255, to HSV.
// H = 0.0 to 360.0 (corresponding to 0..360.0 degrees around hexcone)
// S = 0.0 (shade of gray) to 1.0 (pure color)
// V = 0.0 (black) to 1.0 {white)
// Based on C Code in "Computer Graphics -- Principles and Practice,"
// Foley et al, 1996, p. 592.
class procedure TColorHelper.RGBToHSV(
const R, G, B: Double;
var H, S, V: Double);
var
Delta: Double;
Min: Double;
begin
Min := MinValue([R, G, B]);
// USES Math
V := MaxValue([R, G, B]);
Delta := V - Min;
// Calculate saturation: saturation is 0 if r, g and b are all 0
if V = 0.0
then
S := 0
else
S := Delta / V;
if S = 0.0
then
H := NaN
// Achromatic: When s = 0, h is undefined
else
begin // Chromatic
if R = V
then // between yellow and magenta [degrees]
H := 60.0 * (G - B) / Delta
else if G = V
then // between cyan and yellow
H := 120.0 + 60.0 * (B - R) / Delta
else if B = V
then // between magenta and cyan
H := 240.0 + 60.0 * (R - G) / Delta;
if H < 0.0
then
H := H + 360.0
end
end { RGBtoHSV };
// Based on C Code in "Computer Graphics -- Principles and Practice,"
// Foley et al, 1996, p. 593.
//
// H = 0.0 to 360.0 (corresponding to 0..360 degrees around hexcone)
// NaN (undefined) for S = 0
// S = 0.0 (shade of gray) to 1.0 (pure color)
// V = 0.0 (black) to 1.0 (white)
class procedure TColorHelper.HSVtoRGB(
const H, S, V: Double;
var R, G, B: Double);
var
f: Double;
i: Integer;
hTemp: Double;
// since H is CONST parameter
p, q, t: Double;
begin
if S = 0.0
// color is on black-and-white center line
then
begin
if IsNaN(H)
then
begin
R := V;
// achromatic: shades of gray
G := V;
B := V
end
else
exit;
end
else
begin // chromatic color
if H = 360.0
// 360 degrees same as 0 degrees
then
hTemp := 0.0
else
hTemp := H;
hTemp := hTemp / 60;
// h is now IN [0,6)
i := TRUNC(hTemp);
// largest integer <= h
f := hTemp - i;
// fractional part of h
p := V * (1.0 - S);
q := V * (1.0 - (S * f));
t := V * (1.0 - (S * (1.0 - f)));
CASE i
OF
0:
begin
R := V;
G := t;
B := p
end;
1:
begin
R := q;
G := V;
B := p
end;
2:
begin
R := p;
G := V;
B := t
end;
3:
begin
R := p;
G := q;
B := V
end;
4:
begin
R := t;
G := p;
B := V
end;
5:
begin
R := V;
G := p;
B := q
end
end
end
end { HSVtoRGB };
function floorEven(
const num: Integer): Integer;
inline;
begin
result := num
and -2;
end;
function roundMult4(
const num: Integer): Integer;
inline;
begin
result := (num + 2)
and -4;
end;
function Fixed(S: Single): Cardinal;
inline;
begin
result := Round(S * 65536);
end;
class procedure TColorHelper.ColorToHSV(
const Color: Cardinal;
var H, S, V: Double);
begin
RGBToHSV((Color
shr 16)
and $FF, (Color
shr 8)
and $FF,
(Color
and $FF), H, S, V);
end;
class function TColorHelper.HSVToColor(H, S, V: Double): Cardinal;
var
R, G, B: Double;
begin
HSVtoRGB(H, S, V, R, G, B);
result := $FF000000
or TRUNC(R)
shl 16
or TRUNC(G)
shl 8
or TRUNC(B);
end;
class function TColorHelper.calcHueWeights(
const Data: TBitmapData)
: THueWeights;
var
Hue, Saturation, Value: Double;
product: Double;
j, xp, yp: Integer;
begin
xp := 0;
yp := 0;
fillchar(result, sizeof(result), 0);
while (yp < Data.Height)
do
begin
ColorToHSV(Data.GetPixel(xp, yp), Hue, Saturation, Value);
if not IsNaN(Hue)
then
begin
product := Saturation * Value;
if (product >= WEIGHT_THRESHOLD)
then
begin
j := Round(Hue);
result[j] := result[j] + product;
end;
end;
inc(xp, INDEX_JUMP_SIZE);
if xp >= Data.Width
then
begin
dec(xp, Data.Width);
inc(yp);
end;
end;
end;
class function TColorHelper.calcBestHue(
const hueWeights: THueWeights): Integer;
var
i: Integer;
total: Single;
besttotal: Single;
bestHue, hueCandidate: Integer;
begin
total := 0;
for i := 0
to BUCKET_SIZE - 1
do
total := total + hueWeights[i];
besttotal := total;
bestHue := 2;
for i := 1
to high(hueWeights)
do
begin
total := (total + hueWeights[((i + BUCKET_SIZE) - 1)
mod 360]) -
hueWeights[i];
hueCandidate := (i + 2)
mod 360;
if (total > besttotal)
or (((abs(total - besttotal)) < 1.0E-6)
and
(hueWeights[hueCandidate] > hueWeights[bestHue]))
then
begin
besttotal := total;
bestHue := hueCandidate;
end;
end;
result := bestHue;
end;
class function TColorHelper.calcBestHSV(Data: TBitmapData;
const bestHue: Integer;
out bestH, bestS, bestV: Double): Boolean;
var
totalSaturation: Double;
totalValue: Double;
numCloseToHue: Integer;
numConsidered: Integer;
xp, yp: Integer;
Hue, Saturation, Value: Double;
begin
result := false;
if Data.Width > 4096
then
exit;
totalSaturation := 0.0;
totalValue := 0.0;
numCloseToHue := 0;
numConsidered := int64((Data.Width * Data.Height + INDEX_JUMP_SIZE) - 1)
div INDEX_JUMP_SIZE;
xp := 0;
yp := 0;
while yp < Data.Height
do
begin
ColorToHSV(Data.GetPixel(xp, yp), Hue, Saturation, Value);
if not IsNaN(Hue)
and (abs(TRUNC((Hue - (bestHue)) + 2.0)
mod 360) < 5.0)
and (Saturation * Value >= WEIGHT_THRESHOLD)
then
begin
totalSaturation := totalSaturation + Saturation;
totalValue := totalValue + Value;
inc(numCloseToHue);
end;
inc(xp, INDEX_JUMP_SIZE);
if xp > Data.Width
then
begin
dec(xp, Data.Width);
inc(yp);
end;
end;
if (numCloseToHue = 0)
or (numConsidered = 0)
then
begin
bestH := bestHue;
bestS := 0.0;
bestV := 0.0;
end
else
begin
bestH := bestHue;
bestS := totalSaturation / numCloseToHue;
bestV := totalValue / numCloseToHue;
result := ((totalSaturation + totalValue) / numConsidered) >=
GREY_THRESHOLD;
end;
end;
class function TColorHelper.IsDarkColor(
const Color: Cardinal): Boolean;
//Var H, S, V: Double;
var Col: TAlphaColorRec
absolute Color;
begin
// ColorToHSV(Color, H, S, V);result := V < 220;
result := (1-(0.299* Col.R + 0.587*Col.G + 0.114*Col.B)/255)>0.5;
end;
class function TColorHelper.CalcBestColor(
const ABitmap: TBitmap): Cardinal;
var
Data: TBitmapData;
bestHue: Integer;
Hue, Saturation, Value: Double;
isColorfulEnough: Boolean;
begin
result := 0;
if not assigned(ABitmap)
then
exit;
ABitmap.Map(TMapAccess.
Read, Data);
bestHue := calcBestHue(calcHueWeights(Data));
isColorfulEnough := calcBestHSV(Data, bestHue, Hue, Saturation, Value);
if isColorfulEnough
then
result := HSVToColor(Hue, Saturation, Value)
else
result := $FFFFFFFF;
ABitmap.Unmap(Data);
end;
class procedure TColorHelper.FastBlur(Dst: TBitmap; radius: Integer;
Passes: Integer = 3);
type
PARGB32 = ^TARGB32;
TARGB32 =
packed record
B: Byte;
G: Byte;
R: Byte;
a: Byte;
end;
TLine32 =
array [0 .. MaxInt
div sizeof(TARGB32) - 1]
of TARGB32;
PLine32 = ^TLine32;
PSumRecord = ^TSumRecord;
TSumRecord =
packed record
saB, sag, saR, saA: Cardinal;
end;
var
j, X, Y, w, H, ny, tx, ty: Integer;
ptrD: Integer;
s1: PLine32;
C: TAlphaColor;
sa:
array of TSumRecord;
sr1, sr2: TSumRecord;
n: Cardinal;
Data: TBitmapData;
begin
if radius = 0
then
exit;
Dst.Map(TMapAccess.ReadWrite, Data);
try
n := Fixed(1 / ((radius * 2) + 1));
w := Dst.Width - 1;
H := Dst.Height - 1;
SetLength(sa, w + 1 + (radius * 2));
s1 := PLine32(Data.GetScanline(0));
ptrD := Integer(Data.GetScanline(1)) - Integer(s1);
ny := Integer(s1);
for Y := 0
to H
do
begin
for j := 1
to Passes
do
begin
X := -radius;
while X <= w + radius
do
begin
tx := X;
if tx < 0
then
tx := 0
else if tx >= w
then
tx := w;
if X + radius - 1 < 0
then
sr1 := sa[0]
else
sr1 := sa[X + radius - 1];
C := PAlphaColor(ny + tx
shl 2)^;
with sa[X + radius]
do
begin
saA := sr1.saA + C
shr 24;
saR := sr1.saR + C
shr 16
and $FF;
sag := sr1.sag + C
shr 8
and $FF;
saB := sr1.saB + C
and $FF;
end;
inc(X);
end;
for X := 0
to w
do
begin
tx := X + radius;
sr1 := sa[tx + radius];
if tx - 1 - radius < 0
then
sr2 := sa[0]
else
sr2 := sa[tx - 1 - radius];
PAlphaColor(ny + X
shl 2)^ := (sr1.saA - sr2.saA) * n
shl 8
and
$FF000000
or (sr1.saR - sr2.saR) * n
and $FF0000
or
(sr1.sag - sr2.sag) * n
shr 8
and $FF00
or (sr1.saB - sr2.saB)
* n
shr 16;
end;
end;
inc(ny, ptrD);
end;
SetLength(sa, H + 1 + (radius * 2));
for X := 0
to w
do
begin
for j := 1
to Passes
do
begin
ny := Integer(s1);
Y := -radius;
while Y <= H + radius
do
begin
if (Y > 0)
and (Y < H)
then
inc(ny, ptrD);
if Y + radius - 1 < 0
then
sr1 := sa[0]
else
sr1 := sa[Y + radius - 1];
C := PAlphaColor(ny + X
shl 2)^;
with sa[Y + radius]
do
begin
saA := sr1.saA + C
shr 24;
saR := sr1.saR + C
shr 16
and $FF;
sag := sr1.sag + C
shr 8
and $FF;
saB := sr1.saB + C
and $FF;
end;
inc(Y);
end;
ny := Integer(s1);
for Y := 0
to H
do
begin
ty := Y + radius;
sr1 := sa[ty + radius];
if ty - 1 - radius < 0
then
sr2 := sa[0]
else
sr2 := sa[ty - 1 - radius];
PAlphaColor(ny + X
shl 2)^ := (sr1.saA - sr2.saA) * n
shl 8
and
$FF000000
or (sr1.saR - sr2.saR) * n
and $FF0000
or
(sr1.sag - sr2.sag) * n
shr 8
and $FF00
or (sr1.saB - sr2.saB)
* n
shr 16;
inc(ny, ptrD);
end;
end;
end;
SetLength(sa, 0);
finally
Dst.Unmap(Data);
end;
end;
class function TColorHelper.createBlurredImage(input: TBitmap; radius: Integer;
blurResampleSize: Integer): TBitmap;
var
mAspectRatio: Single;
scaledHeight: Integer;
begin
mAspectRatio := input.Width / input.Height;
scaledHeight := max(2, floorEven(input.Height
div blurResampleSize));
result := TBitmap.Create
(max(4, roundMult4(TRUNC((scaledHeight) * mAspectRatio))), scaledHeight);
result.Canvas.BeginScene(
nil);
result.Canvas.DrawBitmap(input, rectf(0, 0, input.Width, input.Height),
rectf(0, 0, result.Width, result.Height), 1);
result.Canvas.EndScene;
TColorHelper.FastBlur(result, radius);
end;
class function TColorHelper.AdjustOverlayColor(
const Color: Cardinal;
const DefaultColor: Cardinal = $FF7F7F7F): Cardinal;
var
H, S, V, MinValue: Double;
begin
if (Color = 0)
then
result := $FF7F7F7F
else
begin
TColorHelper.ColorToHSV(DefaultColor, H, S, MinValue);
TColorHelper.ColorToHSV(Color, H, S, V);
V := V * VALUE_DAMPING_FACTOR;
if (V < MinValue)
then
V := MinValue;
result := TColorHelper.HSVToColor(H, S, V);
end;
end;
class procedure TColorHelper.Grayscale(AList: TImageList; ABitmaps:
Array of String;
AColor: Cardinal = 0);
var i: integer;
begin
for i := 0
to high(ABitmaps)
do
GrayScale(AList, ABitmaps[i], AColor);
end;
class procedure TColorHelper.Grayscale(AList: TImageList; ABitmap:
String;
AColor: Cardinal = 0);
var
Size: TSize;
Item: TCustomBitmapItem;
begin
if not assigned(AList)
then
exit;
Size := TSize.Create(0, 0);
if AList.BitmapItemByName(ABitmap, Item, Size)
then
Grayscale(Item.Bitmap, AColor);
end;
class procedure TColorHelper.Grayscale(ABitmap: TBitmap; AColor: Cardinal = 0);
var
X: Integer;
Y: Integer;
Gray: Byte;
Data: TBitmapData;
Pixel: PAlphaColorRec;
Color: TAlphaColorRec
absolute AColor;
amount: Single;
begin
amount := 0.5;
Color.R := TRUNC(Color.R * amount);
Color.G := TRUNC(Color.G * amount);
Color.B := TRUNC(Color.B * amount);
ABitmap.Map(TMapAccess.ReadWrite, Data);
for Y := 0
to Data.Height - 1
do
begin
Pixel := Data.GetScanline(Y);
for X := 0
to Data.Width - 1
do
begin
Gray := Round((0.299 * Pixel.R) + (0.587 * Pixel.G) + (0.114 * Pixel.B));
if Pixel.a > 0
then
begin
if AColor = 0
then
begin
Pixel.R := Gray;
Pixel.G := Gray;
Pixel.B := Gray;
end
else
begin
Gray := TRUNC(Gray * (1 - amount));
{$IFDEF POSIX}
Pixel.R := Color.B + Gray;
Pixel.G := Color.G + Gray;
Pixel.B := Color.R + Gray;
{$ELSE}
Pixel.R := Color.R + Gray;
Pixel.G := Color.G + Gray;
Pixel.B := Color.B + Gray;
{$ENDIF}
end;
end;
inc(Pixel);
end;
end;
ABitmap.Unmap(Data);
end;
end.