jclqgraphutils.pas

East make Tray Icon in delphi

{**************************************************************************************************}
{  WARNING:  JEDI preprocessor generated unit.  Do not edit.                                       }
{**************************************************************************************************}

{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is JclGraphUtils.pas.                                                          }
{                                                                                                  }
{ The Initial Developers of the Original Code are Pelle F. S. Liljendal and Marcel van Brakel.     }
{ Portions created by these individuals are Copyright (C) of these individuals.                    }
{ All Rights Reserved.                                                                             }
{                                                                                                  }
{ Contributors:                                                                                    }
{   Jack N.A. Bakker                                                                               }
{   Mike Lischke                                                                                   }
{   Robert Marquardt (marquardt)                                                                   }
{   Alexander Radchenko                                                                            }
{   Robert Rossmair (rrossmair)                                                                    }
{   Olivier Sannier (obones)                                                                       }
{   Matthias Thoma (mthoma)                                                                        }
{   Petr Vones (pvones)                                                                            }
{                                                                                                  }
{**************************************************************************************************}

// For history, see end of file

unit JclQGraphUtils;

interface

{$I jcl.inc}

uses
  Types,
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF MSWINDOWS}
  SysUtils,
  Qt, QGraphics,
  JclBase;

type
  PColor32 = ^TColor32;
  TColor32 = type Longword;
  PColor32Array = ^TColor32Array;
  TColor32Array = array [0..MaxInt div SizeOf(TColor32) - 1] of TColor32;
  PPalette32 = ^TPalette32;
  TPalette32 = array [Byte] of TColor32;
  TArrayOfColor32 = array of TColor32;

  { Blending Function Prototypes }
  TCombineReg  = function(X, Y, W: TColor32): TColor32;
  TCombineMem  = procedure(F: TColor32; var B: TColor32; W: TColor32);
  TBlendReg    = function(F, B: TColor32): TColor32;
  TBlendMem    = procedure(F: TColor32; var B: TColor32);
  TBlendRegEx  = function(F, B, M: TColor32): TColor32;
  TBlendMemEx  = procedure(F: TColor32; var B: TColor32; M: TColor32);
  TBlendLine   = procedure(Src, Dst: PColor32; Count: Integer);
  TBlendLineEx = procedure(Src, Dst: PColor32; Count: Integer; M: TColor32);

  { Auxiliary structure to support TColor manipulation }
  TColorRec = packed record
    case Integer of
      0: (Value: Longint);
      1: (Red, Green, Blue: Byte);
      2: (R, G, B, Flag: Byte);
      {$IFDEF MSWINDOWS}
      3: (Index: Word); // GetSysColor, PaletteIndex
      {$ENDIF MSWINDOWS}
  end;

  TColorVector = record
    case Integer of
      0: (Coord: array [0..2] of Single);
      1: (R, G, B: Single);
      2: (H, L, S: Single);
  end;

  THLSValue = 0..240;
  THLSVector = record
    Hue: THLSValue;
    Luminance: THLSValue;
    Saturation: THLSValue;
  end;


  { position codes for clipping algorithm }
  TClipCode = (ccLeft, ccRight, ccAbove, ccBelow);
  TClipCodes = set of TClipCode;
  PClipCodes = ^TClipCodes;

const
  { Some predefined color constants }
  clBlack32     = TColor32($FF000000);
  clDimGray32   = TColor32($FF3F3F3F);
  clGray32      = TColor32($FF7F7F7F);
  clLightGray32 = TColor32($FFBFBFBF);
  clWhite32     = TColor32($FFFFFFFF);
  clMaroon32    = TColor32($FF7F0000);
  clGreen32     = TColor32($FF007F00);
  clOlive32     = TColor32($FF7F7F00);
  clNavy32      = TColor32($FF00007F);
  clPurple32    = TColor32($FF7F007F);
  clTeal32      = TColor32($FF007F7F);
  clRed32       = TColor32($FFFF0000);
  clLime32      = TColor32($FF00FF00);
  clYellow32    = TColor32($FFFFFF00);
  clBlue32      = TColor32($FF0000FF);
  clFuchsia32   = TColor32($FFFF00FF);
  clAqua32      = TColor32($FF00FFFF);

  { Some semi-transparent color constants }
  clTrWhite32   = TColor32($7FFFFFFF);
  clTrBlack32   = TColor32($7F000000);
  clTrRed32     = TColor32($7FFF0000);
  clTrGreen32   = TColor32($7F00FF00);
  clTrBlue32    = TColor32($7F0000FF);

procedure EMMS;

// Dialog Functions
{$IFDEF MSWINDOWS}
function DialogUnitsToPixelsX(const DialogUnits: Word): Word;
function DialogUnitsToPixelsY(const DialogUnits: Word): Word;
function PixelsToDialogUnitsX(const PixelUnits: Word): Word;
function PixelsToDialogUnitsY(const PixelUnits: Word): Word;
{$ENDIF MSWINDOWS}

// Points
function NullPoint: TPoint;

function PointAssign(const X, Y: Integer): TPoint;
procedure PointCopy(var Dest: TPoint; const Source: TPoint);
function PointEqual(const P1, P2: TPoint): Boolean;
function PointIsNull(const P: TPoint): Boolean;
procedure PointMove(var P: TPoint; const DeltaX, DeltaY: Integer);

// Rectangles
function NullRect: TRect;

function RectAssign(const Left, Top, Right, Bottom: Integer): TRect;
function RectAssignPoints(const TopLeft, BottomRight: TPoint): TRect;
function RectBounds(const Left, Top, Width, Height: Integer): TRect;
function RectCenter(const R: TRect): TPoint;
procedure RectCopy(var Dest: TRect; const Source: TRect);
procedure RectFitToScreen(var R: TRect);  { TODO -cHelp : Doc }
procedure RectGrow(var R: TRect; const Delta: Integer);
procedure RectGrowX(var R: TRect; const Delta: Integer);
procedure RectGrowY(var R: TRect; const Delta: Integer);
function RectEqual(const R1, R2: TRect): Boolean;
function RectHeight(const R: TRect): Integer;
function RectIncludesPoint(const R: TRect; const Pt: TPoint): Boolean;
function RectIncludesRect(const R1, R2: TRect): Boolean;
function RectIntersection(const R1, R2: TRect): TRect;
function RectIntersectRect(const R1, R2: TRect): Boolean;
function RectIsEmpty(const R: TRect): Boolean;
function RectIsNull(const R: TRect): Boolean;
function RectIsSquare(const R: TRect): Boolean;
function RectIsValid(const R: TRect): Boolean;
procedure RectMove(var R: TRect; const DeltaX, DeltaY: Integer);
procedure RectMoveTo(var R: TRect; const X, Y: Integer);
procedure RectNormalize(var R: TRect);
function RectsAreValid(R: array of TRect): Boolean;
function RectUnion(const R1, R2: TRect): TRect;
function RectWidth(const R: TRect): Integer;

// Clipping
function ClipCodes(const X, Y, MinX, MinY, MaxX, MaxY: Float): TClipCodes; overload;
function ClipCodes(const X, Y: Float; const ClipRect: TRect): TClipCodes; overload;
function ClipLine(var X1, Y1, X2, Y2: Integer; const ClipRect: TRect): Boolean; overload;
function ClipLine(var X1, Y1, X2, Y2: Float; const MinX, MinY, MaxX, MaxY: Float;
  Codes: PClipCodes = nil): Boolean; overload;
procedure DrawPolyLine(const Canvas: TCanvas; var Points: TPointArray; const ClipRect: TRect);

// Color
type
  EColorConversionError = class(EJclError);

procedure GetRGBValue(const Color: TColor; out Red, Green, Blue: Byte);
function SetRGBValue(const Red, Green, Blue: Byte): TColor;
function GetColorBlue(const Color: TColor): Byte;
function GetColorFlag(const Color: TColor): Byte;
function GetColorGreen(const Color: TColor): Byte;
function GetColorRed(const Color: TColor): Byte;
function SetColorBlue(const Color: TColor; const Blue: Byte): TColor;
function SetColorFlag(const Color: TColor; const Flag: Byte): TColor;
function SetColorGreen(const Color: TColor; const Green: Byte): TColor;
function SetColorRed(const Color: TColor; const Red: Byte): TColor;

function BrightColor(const Color: TColor; const Pct: Single): TColor;
function BrightColorChannel(const Channel: Byte; const Pct: Single): Byte;
function DarkColor(const Color: TColor; const Pct: Single): TColor;
function DarkColorChannel(const Channel: Byte; const Pct: Single): Byte;

procedure CIED65ToCIED50(var X, Y, Z: Extended);
procedure CMYKToBGR(const Source, Target: Pointer; const BitsPerSample: Byte; Count: Cardinal); overload;
procedure CMYKToBGR(const C, M, Y, K, Target: Pointer; const BitsPerSample: Byte; Count: Cardinal); overload;
procedure CIELABToBGR(const Source, Target: Pointer; const Count: Cardinal); overload;
procedure CIELABToBGR(LSource, aSource, bSource: PByte; const Target: Pointer; const Count: Cardinal); overload;
procedure RGBToBGR(const Source, Target: Pointer; const BitsPerSample: Byte; Count: Cardinal); overload;
procedure RGBToBGR(const R, G, B, Target: Pointer; const BitsPerSample: Byte; Count: Cardinal); overload;
procedure RGBAToBGRA(const Source, Target: Pointer; const BitsPerSample: Byte; Count: Cardinal);

procedure WinColorToOpenGLColor(const Color: TColor; out Red, Green, Blue: Float);
function OpenGLColorToWinColor(const Red, Green, Blue: Float): TColor;

function Color32(WinColor: TColor): TColor32; overload;
function Color32(const R, G, B: Byte; const A: Byte = $FF): TColor32; overload;
function Color32(const Index: Byte; const Palette: TPalette32): TColor32; overload;
function Gray32(const Intensity: Byte; const Alpha: Byte = $FF): TColor32;
function WinColor(const Color32: TColor32): TColor;

function RedComponent(const Color32: TColor32): Integer;
function GreenComponent(const Color32: TColor32): Integer;
function BlueComponent(const Color32: TColor32): Integer;
function AlphaComponent(const Color32: TColor32): Integer;

function Intensity(const R, G, B: Single): Single; overload;
function Intensity(const Color32: TColor32): Integer; overload;

function SetAlpha(const Color32: TColor32; NewAlpha: Integer): TColor32;

procedure HLSToRGB(const H, L, S: Single; out R, G, B: Single); overload;
function HLSToRGB(const HLS: TColorVector): TColorVector; overload;
function HLSToRGB(const Hue, Luminance, Saturation: THLSValue): TColorRef; overload;
procedure RGBToHLS(const R, G, B: Single; out H, L, S: Single); overload;
function RGBToHLS(const RGB: TColorVector): TColorVector; overload;
function RGBToHLS(const RGBColor: TColorRef): THLSVector; overload;

// obsolete; use corresponding HLS aliases instead
{$IFNDEF DROP_OBSOLETE_CODE}
procedure HSLToRGB(const H, S, L: Single; out R, G, B: Single); overload;
  {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}
procedure RGBToHSL(const R, G, B: Single; out H, S, L: Single); overload;
  {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}
{$ENDIF ~DROP_OBSOLETE_CODE}

// keep HSL identifier to avoid ambiguity with HLS overload
function HSLToRGB(const H, S, L: Single): TColor32; overload;
procedure RGBToHSL(const RGB: TColor32; out H, S, L: Single); overload;


// Misc
function ColorToHTML(const Color: TColor): string;

// Petr Vones
{$IFDEF MSWINDOWS}
function ShortenString(const DC: HDC; const S: WideString; const Width: Integer; const RTL: Boolean;
  EllipsisWidth: Integer = 0): WideString;
{$ENDIF MSWINDOWS}

var
  { Blending Function Variables }
  CombineReg: TCombineReg;
  CombineMem: TCombineMem;

  BlendReg: TBlendReg;
  BlendMem: TBlendMem;

  BlendRegEx: TBlendRegEx;
  BlendMemEx: TBlendMemEx;

  BlendLine: TBlendLine;
  BlendLineEx: TBlendLineEx;

implementation

uses
  Math,
  JclResources, JclSysInfo, JclLogic;

type
  // resampling support types
  TRGBInt = record
    R: Integer;
    G: Integer;
    B: Integer;
  end;

  PRGBWord = ^TRGBWord;
  TRGBWord = record
    R: Word;
    G: Word;
    B: Word;
  end;

  PRGBAWord = ^TRGBAWord;
  TRGBAWord = record
    R: Word;
    G: Word;
    B: Word;
    A: Word;
  end;

  PBGR = ^TBGR;
  TBGR = packed record
    B: Byte;
    G: Byte;
    R: Byte;
  end;

  PBGRA = ^TBGRA;
  TBGRA = packed record
    B: Byte;
    G: Byte;
    R: Byte;
    A: Byte;
  end;

  PRGB = ^TRGB;
  TRGB = packed record
    R: Byte;
    G: Byte;
    B: Byte;
  end;

  PRGBA = ^TRGBA;
  TRGBA = packed record
    R: Byte;
    G: Byte;
    B: Byte;
    A: Byte;
  end;

const
  { Component masks }
  _R   = TColor32($00FF0000);
  _G   = TColor32($0000FF00);
  _B   = TColor32($000000FF);
  _RGB = TColor32($00FFFFFF);
  Bias = $00800080;

var
  MMX_ACTIVE: Boolean;


//=== Internal LowLevel ======================================================

function ColorSwap(WinColor: TColor): TColor32;
// this function swaps R and B bytes in ABGR and writes $FF into A component
{asm
// EAX = WinColor
        MOV     ECX, EAX     // ECX = WinColor
        MOV     EDX, EAX     // EDX = WinColor

        AND     ECX, $FF0000 // B component
        AND     EAX, $0000FF // R component
        AND     EDX, $00FF00 // G component

        OR      EAX, $00FF00 // write $FF into A component
        SHR     ECX, 16      // shift B
        SHL     EAX, 16      // shift AR
        OR      ECX, EDX     // ECX = GB
        OR      EAX, ECX     // set GB
end;}
begin
  Result := $FF000000 or                        // A component
    TColor32((WinColor and $0000FF) shl  16) or // R component
    TColor32( WinColor and $00FF00) or          // G component
    TColor32((WinColor and $FF0000) shr 16);    // B component
end;

//=== Blending routines ======================================================

function _CombineReg(X, Y, W: TColor32): TColor32;
{asm
  // combine RGBA channels of colors X and Y with the weight of X given in W
  // Result Z = W * X + (1 - W) * Y (all channels are combined, including alpha)
  // EAX <- X
  // EDX <- Y
  // ECX <- W

  // W = 0 or $FF?
        JCXZ    @1              // CX = 0 ?  => Result := EDX
        CMP     ECX, $FF        // CX = $FF ?  => Result := EAX
        JE      @2

        PUSH    EBX

  // P = W * X
        MOV     EBX, EAX        // EBX  <-  Xa Xr Xg Xb
        AND     EAX, $00FF00FF  // EAX  <-  00 Xr 00 Xb
        AND     EBX, $FF00FF00  // EBX  <-  Xa 00 Xg 00
        IMUL    EAX, ECX        // EAX  <-  Pr ** Pb **
        SHR     EBX, 8          // EBX  <-  00 Xa 00 Xg
        IMUL    EBX, ECX        // EBX  <-  Pa ** Pg **
        ADD     EAX, Bias
        AND     EAX, $FF00FF00  // EAX  <-  Pr 00 Pb 00
        SHR     EAX, 8          // EAX  <-  00 Pr 00 Pb
        ADD     EBX, Bias
        AND     EBX, $FF00FF00  // EBX  <-  Pa 00 Pg 00
        OR      EAX, EBX        // EAX  <-  Pa Pr Pg Pb

  // W = 1 - W; Q = W * Y
        XOR     ECX, $000000FF  // ECX  <-  1 - ECX
        MOV     EBX, EDX        // EBX  <-  Ya Yr Yg Yb
        AND     EDX, $00FF00FF  // EDX  <-  00 Yr 00 Yb
        AND     EBX, $FF00FF00  // EBX  <-  Ya 00 Yg 00
        IMUL    EDX, ECX        // EDX  <-  Qr ** Qb **
        SHR     EBX, 8          // EBX  <-  00 Ya 00 Yg
        IMUL    EBX, ECX        // EBX  <-  Qa ** Qg **
        ADD     EDX, Bias
        AND     EDX, $FF00FF00  // EDX  <-  Qr 00 Qb 00
        SHR     EDX, 8          // EDX  <-  00 Qr ** Qb
        ADD     EBX, Bias
        AND     EBX, $FF00FF00  // EBX  <-  Qa 00 Qg 00
        OR      EBX, EDX        // EBX  <-  Qa Qr Qg Qb

  // Z = P + Q (assuming no overflow at each byte)
        ADD     EAX, EBX        // EAX  <-  Za Zr Zg Zb

        POP     EBX
        RET

@1:     MOV     EAX, EDX
@2:     RET
end;}
begin
  // combine RGBA channels of colors X and Y with the weight of X given in W
  // Result Z = W * X + (1 - W) * Y (all channels are combined, including alpha)

  if W = 0 then
    Result := Y        //May be if W <= 0 ???
  else
  if W = $FF then Result := X //May be if W >= $FF ??? Or if W > $FF ???
  else
  begin
    Result :=