Firemonkey TBitmap einfärben

[CHackbart]

Anbei mal meine Farbhelfer Routinen:

Delphi-Quellcode:

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.

Christian