_graphutils.pas

East make Tray Icon in delphi

    FinalR := Round(255.0 * ( 2.998 * X - 1.458 * Y - 0.541 * Z));
    FinalG := Round(255.0 * (-0.952 * X + 1.893 * Y + 0.059 * Z));
    FinalB := Round(255.0 * ( 0.099 * X - 0.198 * Y + 1.099 * Z));

    TargetPtr^ := Max(0, Min(255, Byte(FinalB)));
    Inc(TargetPtr);
    TargetPtr^ := Max(0, Min(255, Byte(FinalG)));
    Inc(TargetPtr);
    TargetPtr^ := Max(0, Min(255, Byte(FinalR)));
    Inc(TargetPtr);

    Dec(PixelCount);
  end;
end;

// reorders a stream of "Count" RGB values to BGR, additionally an eventual sample size adjustment is done

procedure RGBToBGR(const Source, Target: Pointer; const BitsPerSample: Byte; Count: Cardinal); overload;
var
  SourceRun16: PRGBWord;
  SourceRun8: PRGB;
  TargetRun: PBGR;
begin
  Count := Count div 3;
  // usually only 8 bit samples are used but Photoshop allows for 16 bit samples
  case BitsPerSample of
    8:
      begin
        SourceRun8 := Source;
        TargetRun := Target;
        while Count > 0 do
        begin
          TargetRun.R := SourceRun8.R;
          TargetRun.G := SourceRun8.G;
          TargetRun.B := SourceRun8.B;
          Inc(SourceRun8);
          Inc(TargetRun);
          Dec(Count);
        end;
      end;
    16:
      begin
        SourceRun16 := Source;
        TargetRun := Target;
        while Count > 0 do
        begin
          TargetRun.R := SourceRun16.R shr 8;
          TargetRun.G := SourceRun16.G shr 8;
          TargetRun.B := SourceRun16.B shr 8;
          Inc(SourceRun16);
          Inc(TargetRun);
          Dec(Count);
        end;
      end;
    else
      raise EColorConversionError.CreateResFmt(@RsBitsPerSampleNotSupported, [BitsPerSample]);
  end;
end;

// reorders a stream of "Count" RGB values to BGR, additionally an eventual sample size adjustment is done

procedure RGBToBGR(const R, G, B, Target: Pointer; const BitsPerSample: Byte; Count: Cardinal); overload;
var
  R8, G8, B8: PByte;
  R16, G16, B16: PWord;
  TargetRun: PByte;
begin
  Count := Count div 3;
  // usually only 8 bits samples are used but Photoshop allows 16 bits samples too
  case BitsPerSample of
    8:
      begin
        R8 := R;
        G8 := G;
        B8 := B;
        TargetRun := Target;
        while Count > 0 do
        begin
          TargetRun^ := B8^;
          Inc(B8);
          Inc(TargetRun);
          TargetRun^ := G8^;
          Inc(G8);
          Inc(TargetRun);
          TargetRun^ := R8^;
          Inc(R8);
          Inc(TargetRun);
          Dec(Count);
        end;
      end;
    16:
      begin
        R16 := R;
        G16 := G;
        B16 := B;
        TargetRun := Target;
        while Count > 0 do
        begin
          TargetRun^ := B16^ shr 8;
          Inc(B16);
          Inc(TargetRun);
          TargetRun^ := G16^ shr 8;
          Inc(G16);
          Inc(TargetRun);
          TargetRun^ := R16^ shr 8;
          Inc(R16);
          Inc(TargetRun);
          Dec(Count);
        end;
      end;
    else
      raise EColorConversionError.CreateResFmt(@RsBitsPerSampleNotSupported, [BitsPerSample]);
  end;
end;

// reorders a stream of "Count" RGBA values to BGRA, additionally an eventual sample
// size adjustment is done

procedure RGBAToBGRA(const Source, Target: Pointer; const BitsPerSample: Byte; Count: Cardinal);
var
  SourceRun16: PRGBAWord;
  SourceRun8: PRGBA;
  TargetRun: PBGRA;
begin
  Count := Count div 4;
  // usually only 8 bit samples are used but Photoshop allows for 16 bit samples
  case BitsPerSample of
    8:
      begin
        SourceRun8 := Source;
        TargetRun := Target;
        while Count > 0 do
        begin
          TargetRun.R := SourceRun8.R;
          TargetRun.G := SourceRun8.G;
          TargetRun.B := SourceRun8.B;
          TargetRun.A := SourceRun8.A;
          Inc(SourceRun8);
          Inc(TargetRun);
          Dec(Count);
        end;
      end;
    16:
      begin
        SourceRun16 := Source;
        TargetRun := Target;
        while Count > 0 do
        begin
          TargetRun.R := SourceRun16.B shr 8;
          TargetRun.G := SourceRun16.G shr 8;
          TargetRun.B := SourceRun16.R shr 8;
          TargetRun.A := SourceRun16.A shr 8;
          Inc(SourceRun16);
          Inc(TargetRun);
          Dec(Count);
        end;
      end;
    else
      raise EColorConversionError.CreateResFmt(@RsBitsPerSampleNotSupported, [BitsPerSample]);
  end;
end;

procedure WinColorToOpenGLColor(const Color: TColor; out Red, Green, Blue: Float);
var
  Temp: TColorRec;
begin
  Temp.Value := ColorToRGB(Color);
  Red   := (Temp.R / High(Temp.R));
  Green := (Temp.G / High(Temp.G));
  Blue  := (Temp.B / High(Temp.B));
end;

function OpenGLColorToWinColor(const Red, Green, Blue: Float): TColor;
var
  Temp: TColorRec;
begin
  Temp.R := Round(Red   * High(Temp.R));
  Temp.G := Round(Green * High(Temp.G));
  Temp.B := Round(Blue  * High(Temp.B));
  Temp.Flag := 0;
  Result := Temp.Value;
end;

function Color32(WinColor: TColor): TColor32; overload;
begin
  WinColor := ColorToRGB(WinColor);
  Result := ColorSwap(WinColor);
end;

function Color32(const R, G, B: Byte; const A: Byte): TColor32; overload;
begin
  Result := A shl 24 + R shl 16 + G shl 8 + B;
end;

function Color32(const Index: Byte; const Palette: TPalette32): TColor32; overload;
begin
  Result := Palette[Index];
end;

function Gray32(const Intensity: Byte; const Alpha: Byte): TColor32;
begin
  Result := TColor32(Alpha) shl 24 + TColor32(Intensity) shl 16 +
    TColor32(Intensity) shl 8 + TColor32(Intensity);
end;

function WinColor(const Color32: TColor32): TColor;
begin
  // the alpha channel byte is set to zero
  Result := (Color32 and _R shr 16) or (Color32 and _G) or
    (Color32 and _B shl 16);
end;

function RedComponent(const Color32: TColor32): Integer;
begin
  Result := Color32 and _R shr 16;
end;

function GreenComponent(const Color32: TColor32): Integer;
begin
  Result := Color32 and _G shr 8;
end;

function BlueComponent(const Color32: TColor32): Integer;
begin
  Result := Color32 and _B;
end;

function AlphaComponent(const Color32: TColor32): Integer;
begin
  Result := Color32 shr 24;
end;

function Intensity(const R, G, B: Single): Single;
const
  RFactor =  61 / 256;
  GFactor = 174 / 256;
  BFactor =  21 / 256;
begin
  Result := RFactor * R + GFactor * G + BFactor * B;
end;

// input:  RGB components
// output: (R * 61 + G * 174 + B * 21) div 256

function Intensity(const Color32: TColor32): Integer;
begin
  Result := (Color32 and _B) * 21      // Blue
    + ((Color32 and _G) shr 8) * 174   // Green
    + ((Color32 and _R) shr 16) * 61;  // Red
  Result := Result shr 8;
end;

function SetAlpha(const Color32: TColor32; NewAlpha: Integer): TColor32;
begin
  Result := (Color32 and _RGB) or (TColor32(NewAlpha) shl 24);
end;

procedure HLSToRGB(const H, L, S: Single; out R, G, B: Single);
var
  M1, M2: Single;

  function HueToColorValue(Hue: Single): Single;
  begin
    Hue := Hue - Floor(Hue);

    if 6 * Hue < 1 then
      Result := M1 + (M2 - M1) * Hue * 6
    else
    if 2 * Hue < 1 then
      Result := M2
    else
    if 3 * Hue < 2 then
      Result := M1 + (M2 - M1) * (2 / 3 - Hue) * 6
    else
      Result := M1;
  end;
    
begin
  if S = 0 then
  begin
    R := L;
    G := R;
    B := R;
  end
  else
  begin
    if L <= 0.5 then
      M2 := L * (1 + S)
    else
      M2 := L + S - L * S;
    M1 := 2 * L - M2;
    R := HueToColorValue(H + 1 / 3);
    G := HueToColorValue(H);
    B := HueToColorValue(H - 1 / 3)
  end;
end;

{$IFNDEF DROP_OBSOLETE_CODE}
procedure HSLToRGB(const H, S, L: Single; out R, G, B: Single);
begin
  HLSToRGB(H, L, S, R, G, B);
end;
{$ENDIF ~DROP_OBSOLETE_CODE}

function HSLToRGB(const H, S, L: Single): TColor32;
var
  R, G, B: Single;
begin
  HLSToRGB(H, L, S, R, G, B);
  Result := Color32(Round(R * 255), Round(G * 255), Round(B * 255), 255);
end;

function HLSToRGB(const HLS: TColorVector): TColorVector;
begin
  HLSToRGB(HLS.H, HLS.L, HLS.S, Result.R, Result.G, Result.B);
end;

procedure RGBToHLS(const R, G, B: Single; out H, L, S: Single);
var
  D, Cmax, Cmin: Single;
begin
  Cmax := Max(R, Max(G, B));
  Cmin := Min(R, Min(G, B));
  L := (Cmax + Cmin) / 2;

  if Cmax = Cmin then
  begin
    H := 0;
    S := 0
  end
  else
  begin
    D := Cmax - Cmin;
    if L < 0.5 then
      S := D / (Cmax + Cmin)
    else
      S := D / (2 - Cmax - Cmin);
    if R = Cmax then
      H := (G - B) / D
    else
    if G = Cmax then
      H := 2 + (B - R) / D
    else
      H := 4 + (R - G) / D;
    H := H / 6;
    if H < 0 then
      H := H + 1;
  end;
end;

{$IFNDEF DROP_OBSOLETE_CODE}
procedure RGBToHSL(const R, G, B: Single; out H, S, L: Single);
begin
  RGBToHLS(R, G, B, H, L, S);
end;
{$ENDIF ~DROP_OBSOLETE_CODE}

procedure RGBToHSL(const RGB: TColor32; out H, S, L: Single);
begin
  RGBToHLS(RedComponent(RGB) / 255, GreenComponent(RGB) / 255, BlueComponent(RGB) / 255, H, L, S);
end;

function RGBToHLS(const RGB: TColorVector): TColorVector;
begin
  RGBToHLS(RGB.R, RGB.G, RGB.B, Result.H, Result.L, Result.S);
end;

{ Translated C-code from Microsoft Knowledge Base
-------------------------------------------
Converting Colors Between RGB and HLS (HBS)
Article ID: Q29240
Creation Date: 26-APR-1988
Revision Date: 02-NOV-1995
The information in this article applies to:

Microsoft Windows Software Development Kit (SDK) for Windows versions 3.1 and 3.0
Microsoft Win32 Application Programming Interface (API) included with:

    - Microsoft Windows NT versions 3.5 and 3.51
    - Microsoft Windows 95 version 4.0
SUMMARY


The code fragment below converts colors between RGB (Red, Green, Blue) and HLS/HBS (Hue, Lightness, Saturation/Hue, Brightness, Saturation).


MORE INFORMATION


/* Color Conversion Routines --

RGBToHLS() takes a DWORD RGB value, translates it to HLS, and stores the results in the global vars H, L, and S. HLSToRGB takes the current values of H, L, and S and returns the equivalent value in an RGB DWORD.

A point of reference for the algorithms is Foley and Van Dam, "Fundamentals of Interactive Computer Graphics," Pages 618-19. Their algorithm is in floating point. CHART implements a less general (hardwired ranges) integral algorithm.
There are potential round-off errors throughout this sample. ((0.5 + x)/y) without floating point is phrased ((x + (y/2))/y), yielding a very small round-off error. This makes many of the following divisions look strange. */ }

const
  HLSMAX = High(THLSValue);     // H,L, and S vary over 0-HLSMAX
  RGBMAX = 255;                 // R,G, and B vary over 0-RGBMAX
                                // HLSMAX BEST IF DIVISIBLE BY 6
                                // RGBMAX, HLSMAX must each fit in a byte.

// Hue is undefined if Saturation is 0 (grey-scale).
// This value determines where the Hue value is initially set for achromatic colors.
  UNDEFINED = HLSMAX * 2 div 3;

type
  TInternalRGB = packed record
    R: Byte;
    G: Byte;
    B: Byte;
    I: Byte;
  end;

function RGB(R, G, B: Byte): TColor;
begin
  TInternalRGB(Result).R := R;
  TInternalRGB(Result).G := G;
  TInternalRGB(Result).B := B;
  TInternalRGB(Result).I := 0;
end;

function RGBToHLS(const RGBColor: TColorRef): THLSVector;
var
  R, G, B: Integer;              // input RGB values
  H, L, S: Integer;
  Cmax, Cmin: Byte;              // max and min RGB values
  Rdelta,Gdelta,Bdelta: Integer; // intermediate value: % of spread from max
begin
  // get R, G, and B out of DWORD
  R := TInternalRGB(RGBColor).R;
  G := TInternalRGB(RGBColor).G;
  B := TInternalRGB(RGBColor).B;

  // calculate lightness
  Cmax := R;
  if G > Cmax then
    Cmax := G;
  if B > Cmax