jclqgraphics.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 JclGraphics.pas.                                                            }
{                                                                                                  }
{ The resampling algorithms and methods used in this library were adapted by Anders Melander from  }
{ the article "General Filtered Image Rescaling" by Dale Schumacher which appeared in the book     }
{ Graphics Gems III, published by Academic Press, Inc. Additional improvements were done by David  }
{ Ullrich and Josha Beukema.                                                                       }
{                                                                                                  }
{ (C)opyright 1997-1999 Anders Melander                                                            }
{                                                                                                  }
{ The Initial Developers of the Original Code are Alex Denissov, Wim De Cleen, Anders Melander     }
{ and Mike Lischke. Portions created by these individuals are Copyright (C) of these individuals.  }
{ All Rights Reserved.                                                                             }
{                                                                                                  }
{ Contributors:                                                                                    }
{   Alexander Radchenko                                                                            }
{   Charlie Calvert                                                                                }
{   Marcel van Brakel                                                                              }
{   Marcin Wieczorek                                                                               }
{   Matthias Thoma (mthoma)                                                                        }
{   Petr Vones (pvones)                                                                            }
{   Robert Marquardt (marquardt)                                                                   }
{   Robert Rossmair (rrossmair)                                                                    }
{                                                                                                  }
{**************************************************************************************************}

// For history, see end of file

unit JclQGraphics;

{$I jcl.inc}

interface

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

type
  EJclGraphicsError = class(EJclError);

  TDynDynIntegerArrayArray = array of TDynIntegerArray;
  TDynPointArray = array of TPoint;
  TDynDynPointArrayArray = array of TDynPointArray;
  TPointF = record
    X: Single;
    Y: Single;
  end;
  TDynPointArrayF = array of TPointF;

  { TJclBitmap32 draw mode }
  TDrawMode = (dmOpaque, dmBlend);

  { stretch filter }
  TStretchFilter = (sfNearest, sfLinear, sfSpline);

  TConversionKind = (ckRed, ckGreen, ckBlue, ckAlpha, ckUniformRGB, ckWeightedRGB);

  { resampling support types }
  TResamplingFilter =
    (rfBox, rfTriangle, rfHermite, rfBell, rfSpline, rfLanczos3, rfMitchell);

  { Matrix declaration for transformation }
  //  modify Jan 28, 2001 for use under BCB5
  //         the compiler show error 245 "language feature ist not available"
  //         we must take a record and under this we can use the static array
  //  Note:  the sourcecode modify general from M[] to M.A[] !!!!!
  //  TMatrix3d = array [0..2, 0..2] of Extended;  // 3x3 double precision

  TMatrix3d = record
    A: array [0..2, 0..2] of Extended;
  end;

  TDynDynPointArrayArrayF = array of TDynPointArrayF;

  TScanLine = array of Integer;
  TScanLines = array of TScanLine;

  TLUT8 = array [Byte] of Byte;
  TGamma = array [Byte] of Byte;
  TColorChannel = (ccRed, ccGreen, ccBlue, ccAlpha);

  TGradientDirection = (gdVertical, gdHorizontal);

  TPolyFillMode = (fmAlternate, fmWinding);
  TJclRegionCombineOperator = (coAnd, coDiff, coOr, coXor);
  TJclRegionBitmapMode = (rmInclude, rmExclude);
  TJclRegionKind = (rkNull, rkSimple, rkComplex, rkError);

//  modify Jan 28, 2001 for use under BCB5
//         the compiler show error 245 "language feature ist not available"
//         wie must take a record and under this we can use the static array
//  Note:  for init the array we used initialisation at the end of this unit
//
//  const
//    IdentityMatrix: TMatrix3d = (
//      (1, 0, 0),
//      (0, 1, 0),
//      (0, 0, 1));

var
  IdentityMatrix: TMatrix3d;

// Classes
type


  TJclTransformation = class(TObject)
  public
    function  GetTransformedBounds(const Src: TRect): TRect; virtual; abstract;
    procedure PrepareTransform; virtual; abstract;
    procedure Transform(DstX, DstY: Integer; out SrcX, SrcY: Integer); virtual; abstract;
    procedure Transform256(DstX, DstY: Integer; out SrcX256, SrcY256: Integer); virtual; abstract;
  end;

  TJclLinearTransformation = class(TJclTransformation)
  private
    FMatrix: TMatrix3d;
  protected
    A: Integer;
    B: Integer;
    C: Integer;
    D: Integer;
    E: Integer;
    F: Integer;
  public
    constructor Create; virtual;
    function  GetTransformedBounds(const Src: TRect): TRect; override;
    procedure PrepareTransform; override;
    procedure Transform(DstX, DstY: Integer; out SrcX, SrcY: Integer); override;
    procedure Transform256(DstX, DstY: Integer; out SrcX256, SrcY256: Integer); override;
    procedure Clear;
    procedure Rotate(Cx, Cy, Alpha: Extended); // degrees
    procedure Skew(Fx, Fy: Extended);
    procedure Scale(Sx, Sy: Extended);
    procedure Translate(Dx, Dy: Extended);
    property Matrix: TMatrix3d read FMatrix write FMatrix;
  end;

// Bitmap Functions
procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter;
  Radius: Single; Source: TGraphic; Target: TBitmap); overload;
procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter;
  Radius: Single; Bitmap: TBitmap); overload;

{$IFDEF MSWINDOWS}
procedure DrawBitmap(DC: HDC; Bitmap: HBITMAP; X, Y, Width, Height: Integer);

function ExtractIconCount(const FileName: string): Integer;
function BitmapToIcon(Bitmap: HBITMAP; cx, cy: Integer): HICON;
function IconToBitmap(Icon: HICON): HBITMAP;
{$ENDIF MSWINDOWS}



{$IFDEF MSWINDOWS}
function FillGradient(DC: HDC; ARect: TRect; ColorCount: Integer;
  StartColor, EndColor: TColor; ADirection: TGradientDirection): Boolean; overload;
{$ENDIF MSWINDOWS}



implementation

uses
  Math,
  {$IFDEF MSWINDOWS}
  CommCtrl, ShellApi,
  {$ENDIF MSWINDOWS}
  JclLogic;

type
  TRGBInt = record
    R: Integer;
    G: Integer;
    B: Integer;
  end;

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

  PPixelArray = ^TPixelArray;
  TPixelArray = array [0..0] of TBGRA;

  TBitmapFilterFunction = function(Value: Single): Single;

  PContributor = ^TContributor;
  TContributor = record
   Weight: Integer; // Pixel Weight
   Pixel: Integer;  // Source Pixel
  end;

  TContributors = array of TContributor;

  // list of source pixels contributing to a destination pixel
  TContributorEntry = record
   N: Integer;
   Contributors: TContributors;
  end;

  TContributorList = array of TContributorEntry;
  TJclGraphicAccess = class(TGraphic);

const
  DefaultFilterRadius: array [TResamplingFilter] of Single =
    (0.5, 1.0, 1.0, 1.5, 2.0, 3.0, 2.0);
  _RGB: TColor32 = $00FFFFFF;

var
  { Gamma bias for line/pixel antialiasing/shape correction }
  GAMMA_TABLE: TGamma;

threadvar
  // globally used cache for current image (speeds up resampling about 10%)
  CurrentLineR: array of Integer;
  CurrentLineG: array of Integer;
  CurrentLineB: array of Integer;

// Helper functions
function IntToByte(Value: Integer): Byte;
begin
  Result := Math.Max(0, Math.Min(255, Value));
end;


// Internal low level routines
procedure FillLongword(var X; Count: Integer; Value: Longword);
{asm
// EAX = X
// EDX = Count
// ECX = Value
        TEST    EDX, EDX
        JLE     @@EXIT

        PUSH    EDI
        MOV     EDI, EAX  // Point EDI to destination
        MOV     EAX, ECX
        MOV     ECX, EDX
        REP     STOSD    // Fill count dwords
        POP     EDI
@@EXIT:
end;}
var
  P: PLongword;
begin
  P := @X;
  while Count > 0 do
  begin
    P^ := Value;
    Inc(P);
    Dec(Count);
  end;
end;

function Clamp(Value: Integer): TColor32;
begin
  if Value < 0 then
    Result := 0
  else
  if Value > 255 then
    Result := 255
  else
    Result := Value;
end;

procedure TestSwap(var A, B: Integer);
{asm
// EAX = [A]
// EDX = [B]
        MOV     ECX, [EAX]     // ECX := [A]
        CMP     ECX, [EDX]     // ECX <= [B]? Exit
        JLE     @@EXIT
        //Replaced on more fast code
        //XCHG    ECX, [EDX]     // ECX <-> [B];
        //MOV     [EAX], ECX     // [A] := ECX
        PUSH    EBX
        MOV     EBX,[EDX]      // EBX := [B]
        MOV     [EAX],EBX      // [A] := EBX
        MOV     [EDX],ECX      // [B] := ECX
        POP     EBX
@@EXIT:
end;}
var
  X: Integer;
begin
  X := A; // optimization
  if X > B then
  begin
    A := B;
    B := X;
  end;
end;

function TestClip(var A, B: Integer; Size: Integer): Boolean;
begin
  TestSwap(A, B); // now A = min(A,B) and B = max(A, B)
  if A < 0 then
    A := 0;
  if B >= Size then
    B := Size - 1;
  Result := B >= A;
end;

function Constrain(Value, Lo, Hi: Integer): Integer;
begin
  if Value <= Lo then
    Result := Lo
  else
  if Value >= Hi then
    Result := Hi
  else
    Result := Value;
end;

// Filter functions for stretching of TBitmaps
// f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1

function BitmapHermiteFilter(Value: Single): Single;
begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 1 then
    Result := (2 * Value - 3) * Sqr(Value) + 1
  else
    Result := 0;
end;

// This filter is also known as 'nearest neighbour' Filter.

function BitmapBoxFilter(Value: Single): Single;
begin
  if (Value > -0.5) and (Value <= 0.5) then
    Result := 1.0
  else
    Result := 0.0;
end;

// aka 'linear' or 'bilinear' filter

function BitmapTriangleFilter(Value: Single): Single;
begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 1.0 then
    Result := 1.0 - Value
  else
    Result := 0.0;
end;

function BitmapBellFilter(Value: Single): Single;
begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 0.5 then
    Result := 0.75 - Sqr(Value)
  else
  if Value < 1.5 then
  begin
    Value := Value - 1.5;
    Result := 0.5 * Sqr(Value);
  end
  else
    Result := 0.0;
end;

// B-spline filter

function BitmapSplineFilter(Value: Single): Single;
var
  Temp: Single;
begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 1.0 then
  begin
    Temp := Sqr(Value);
    Result := 0.5 * Temp * Value - Temp + 2.0 / 3.0;
  end
  else
  if Value < 2.0 then
  begin
    Value := 2.0 - Value;
    Result := Sqr(Value) * Value / 6.0;
  end
  else
    Result := 0.0;
end;

function BitmapLanczos3Filter(Value: Single): Single;

  function SinC(Value: Single): Single;
  begin
    if Value <> 0.0 then
    begin
      Value := Value * Pi;
      Result := System.Sin(Value) / Value;
    end
    else
      Result := 1.0;
  end;

begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 3.0 then
    Result := SinC(Value) * SinC(Value / 3.0)
  else
    Result := 0.0;
end;

function BitmapMitchellFilter(Value: Single): Single;
const
  B = 1.0 / 3.0;
  C = 1.0 / 3.0;
var
  Temp: Single;
begin
  if Value < 0.0 then
    Value := -Value;
  Temp := Sqr(Value);
  if Value < 1.0 then
  begin
    Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * Temp)) +
      ((-18.0 + 12.0 * B + 6.0 * C) * Temp) +
      (6.0 - 2.0 * B));
    Result := Value / 6.0;
  end
  else
  if Value < 2.0 then
  begin
    Value := (((-B - 6.0 * C) * (Value * Temp)) +
      ((6.0 * B + 30.0 * C) * Temp) +
      ((-12.0 * B - 48.0 * C) * Value) +
      (8.0 * B + 24.0 * C));
    Result := Value / 6.0;
  end
  else
    Result := 0.0;
end;

const
  FilterList: array [TResamplingFilter] of TBitmapFilterFunction =
   (
    BitmapBoxFilter,
    BitmapTriangleFilter,
    BitmapHermiteFilter,
    BitmapBellFilter,
    BitmapSplineFilter,
    BitmapLanczos3Filter,
    BitmapMitchellFilter
   );

procedure FillLineCache(N, Delta: Integer; Line: Pointer);
var
  I: Integer;
  Run: PBGRA;
begin
  Run := Line;
  for I := 0 to N - 1 do
  begin
    CurrentLineR[I] := Run.R;
    CurrentLineG[I] := Run.G;
    CurrentLineB[I] := Run.B;
    Inc(PByte(Run), Delta);
  end;
end;

function ApplyContributors(N: Integer; Contributors: TContributors): TBGRA;
var
  J: Integer;
  RGB: TRGBInt;
  Total,
  Weight: Integer;
  Pixel: Cardinal;
  Contr: PContributor;
begin
  RGB.R := 0;
  RGB.G := 0;
  RGB.B := 0;