teeffect.pas

这个东西的功能很强大

{==============================================================================

  LibFX
  Copyright (C) 2000-2003 by Evgeny Kryukov
  All rights reserved

===============================================================================}

unit TeEffect;

{$I TeDefine.inc}
{$T-,W-,X+,P+}

interface

uses
  {$IFDEF KFX_CLX}
  Qt, Types, QGraphics,
  {$ELSE}
  Windows, Graphics,
  {$ENDIF}
  Classes, SysUtils, Clipbrd, Forms, ExtCtrls, TeBitmap, TeUtils;

{!============================================================================!}

const
  sEffectVersion = '2.1.0';
  sEffectVersionPropText = 'LibFX Version ' + sEffectVersion;

var
  Sig: PChar = '- ' + sEffectVersionPropText +
    {$IFDEF KS_DELPHI4} ' - D4 - '+ {$ENDIF}
    {$IFDEF KS_CBUILDER4} ' - CB4 - ' + {$ENDIF}
    {$IFDEF KS_DELPHI5} ' - D5 - '+ {$ENDIF}
    {$IFDEF KS_CBUILDER5} ' - CB5 - '+ {$ENDIF}
    {$IFDEF KS_DELPHI6} ' - D6 - '+ {$ENDIF}
    {$IFDEF KS_CBUILDER6} ' - CB6 - '+ {$ENDIF}
    {$IFDEF KS_DELPHI7} ' - D7 - '+ {$ENDIF}
    'Copyright (C) 1998-2003 by Evgeny Kryukov -';


resourcestring

{ Error messages }

  SProcListAlreadyExists = 'Effect procedute %s already exists in list';


const

  { WARNINGS ! Do not translate this strings }
  SRandomSelection   = '[ RANDOM ] - Random selection';
  SBitmap            = '[ BITMAP ] - Bitmap Animation';
  SFade              = '[ FADE ] - ';
  SSlide             = '[ SLIDE ] - ';
  SManual            = '[ MANUAL ] - ';


type

  TteProc = procedure;
  TteAnimationRec = class;

{ Fade Matrix }

  PteMatrixFade = ^TteMatrixFade;
  TteMatrixFade = array[0..0] of Byte;

  TteProcFade = procedure (var Matrix: TteMatrixFade; Width, Height: integer; Percent: byte);

{ Slide Matrix }

  TtePointSlide = record
    Alpha: Byte;
    X, Y: SmallInt;
  end;

  PteMatrixSlide = ^TteMatrixSlide;
  TteMatrixSlide = array[0..0] of TtePointSlide;

  TteProcSlide = procedure (var Matrix: TteMatrixSlide; Width, Height: integer; Percent: byte);

{ Manual }

  TteProcManual = procedure (SourceImage, DestImage: TteBitmap; Animation: TteAnimationRec; Percent: byte);

{ Proc kind }

  TteProcKind = (pkFade, pkSlide, pkManual);

{ ProcList Declaration }

  TteProcItem = class
  private
    FKind: TteProcKind;
    FProc: TteProc;
    FName: string;
  public
    property Kind: TteProcKind read FKind write FKind;
    property Proc: TteProc read FProc write FProc;
    property Name: string read FName write FName;
  end;

{ Animation property }

  TteRotation = (krNone, krRotate90, krRotate180, krRotate270);
  TteEffectKind = string;

  TteAnimationRec = class(TComponent)
  private
    FEnabled: boolean;
    FTime: integer;
    FResolution: integer;
    FTileCount: integer;
    FEffect: TteEffectKind;
    FRotation: TteRotation;
    FBitmap: TBitmap;
    procedure SetResolution(const Value: integer);
    procedure SetTileCount(const Value: integer);
    procedure SetTime(const Value: integer);
    procedure SetBitmap(const Value: TBitmap);
  protected
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property Effect: TteEffectKind read FEffect write FEffect;
    property Enabled: boolean read FEnabled write FEnabled default false;
    property Resolution: integer read FResolution write SetResolution default 1;
    property Rotation: TteRotation read FRotation write FRotation default krNone;
    property TileCount: integer read FTileCount write SetTileCount default 1;
    property Time: integer read FTime write SetTime default 400;
  end;


procedure ExecuteAnimation(ACanvas: TCanvas; AX, AY: integer; ASourceImage, ADestImage: TteBitmap; AAnimation: TteAnimationRec);

function StartMultiAnimation(ACanvas: TCanvas; AX, AY: integer; ASourceImage, ADestImage: TteBitmap; AAnimation: TteAnimationRec; AIndex: integer = -1): integer;
procedure StopMultiAnimation(AIndex: integer; DrawLastFrame: boolean = false);
function IsAnimating(AIndex: integer): boolean;

function ReserveIndex: integer;
procedure ReleaseReserved(AIndex: integer);

{$IFDEF KS_DEBUG}
var Outline: TStrings;
{$ENDIF}


const
  AlphaMask = $FF000000;
  
procedure StretchAlphaRect(var X; Width, Height, XDst, YDst, WDst, HDst,
  XSrc, YSrc, WSrc, HSrc: integer; var Alpha);


type

  TteProcList = class(TList)
  private
    function GetProcs(Index: string): TteProcItem;
  public
    procedure Clear; override;
    property Procs[Index: string]: TteProcItem read GetProcs; default;
  end;

  EProcItemError = class(Exception);

const
  ProcList: TteProcList = nil;
  EffectList: TStrings = nil;  // All effects list

function GetEffectList: TStrings;
function GetEffectListComma: string;

procedure RegisterProc(AName: string; AKind: TteProcKind; AProc: TteProc);


type

{ Timer }

  TteTimer = class
  private
    StartValue, StopValue: Int64;
    FFrequency: Int64;
    FCalibrate: Int64;
    {$IFDEF KS_LINUX}
    FCalibrateUSleep: Int64;
    {$ENDIF}
    function GetElapsed: Extended;
    {$IFDEF KS_LINUX}
    procedure MeasureFrequency;
    procedure CalibrateLinux;
    procedure CalibrateUSleep;
    {$ENDIF}
    {$IFDEF KS_WIN}
    procedure CalibrateWindows;
    {$ENDIF}
  protected
    property Calibrate: Int64 read FCalibrate;
  public
    constructor Create;
    function GetFrequency: Int64;
    procedure Start;
    procedure Stop;
    property Elapsed: Extended read GetElapsed;
  end;

procedure StartTimer(var Timer: TteTimer);
function StopTimer(var Timer: TteTimer): Single;


implementation {===============================================================}


const

  MaxAni = 200;
  TimerInterval = 20;

var

  MultiTimer: TTimer;

type

  TteMultiAniRec = record
    Index: integer;
    MatrixWidth, MatrixHeight: integer;
    MatrixLen: integer;
    MatrixFade: PteMatrixFade;
    CopyMatrixFade: PteMatrixFade;
    MatrixSlide: PteMatrixSlide;
    Animating, Drawing, Reserved: boolean;
    CurTime: single;
    Animation: TteAnimationRec;
    DestImage, SourceImage, ResultImage: TteBitmap;
    ProcItem: TteProcItem;
    Canvas: TCanvas;
    X, Y: integer;
  end;

  TteMultiObject = class
    {$IFDEF KS_STATICEFFECTTIMER }
    T: TteTimer;
    constructor Create;
    destructor Destroy; override;
    {$ENDIF}
    procedure DoMultiTimer(Sender: TObject);
  end;

procedure CalcFrameFade(AMultiRec: TteMultiAniRec;
  Percent: byte);
var
  i, j: integer; { loop variables }
  DstRect: TRect;
begin
  { MatrixFade's Animation }
  with AMultiRec do
  begin
    { Clear matrix }
    if Animation.Rotation <> krNone then
    begin
      { Need use copymatrix for rotation }
      FillChar(CopyMatrixFade^, MatrixHeight * MatrixWidth, 0);
      if Animation.Rotation in [krRotate90, krRotate270] then
        TteProcFade(ProcItem.Proc)(CopyMatrixFade^, MatrixHeight, MatrixWidth, Percent)
      else
        TteProcFade(ProcItem.Proc)(CopyMatrixFade^, MatrixWidth, MatrixHeight, Percent);
    end
    else
    begin
      FillChar(MatrixFade^, MatrixHeight * MatrixWidth, 0);
      TteProcFade(ProcItem.Proc)(MatrixFade^, MatrixWidth, MatrixHeight, Percent);
    end;

    { Matrix rotation }
    if Animation.Rotation = krRotate90 then
    begin
      for i := 0 to MatrixWidth - 1 do
        for j := 0 to MatrixHeight - 1 do
          MatrixFade^[i + (MatrixHeight - j - 1) * MatrixWidth] := CopyMatrixFade^[j + i * MatrixHeight];
    end;

    if Animation.Rotation = krRotate180 then
    begin
      for i := 0 to MatrixWidth - 1 do
        for j := 0 to MatrixHeight - 1 do
          MatrixFade^[(MatrixWidth - i - 1)  + (MatrixHeight - j - 1) * MatrixWidth] := CopyMatrixFade^[i + j * MatrixWidth];
    end;

    if Animation.Rotation = krRotate270 then
    begin
      for i := 0 to MatrixWidth - 1 do
        for j := 0 to MatrixHeight - 1 do
          MatrixFade^[(MatrixWidth - i - 1) + j * MatrixWidth] := CopyMatrixFade^[j + i * MatrixHeight];
    end;

    { Apply Matrix }
    for i := 0 to Animation.TileCount - 1 do
      for j := 0 to Animation.TileCount - 1 do
      begin
        DstRect := Rect(0, 0, MatrixWidth * Animation.Resolution, MatrixHeight * Animation.Resolution);
        OffsetRect(DstRect, i * RectWidth(DstRect), j * RectHeight(DstRect));

        StretchAlphaRect(DestImage.Bits^, DestImage.Width, DestImage.Height,
          DstRect.Left, DstRect.Top, RectWidth(DstRect), RectHeight(DstRect),
          0, 0, MatrixWidth, MatrixHeight, MatrixFade^);
      end;

    { Clear alpha }
    ClearAlphaFunc(DestImage.Bits, DestImage.Width * DestImage.Height, teTransparent);

    { Blending }
    DestImage.AlphaBlend := true;
    DestImage.Draw(ResultImage, 0, 0);
  end;
end;

procedure CalcFrameSlide(AMultiRec: TteMultiAniRec;
  Percent: byte);
var
  SourceColor, DestColor: PteColor;
  MatrixValue: TtePointSlide;
  RepeatWidth, RepeatHeight: integer;
  MatrixX, MatrixY, TileX, TileY, ResX, ResY: integer; { loop variables }
  Sx, Sy: integer; { Source position }
  Dx, Dy: integer; { Dest position }
begin
  { MatrixSlide's Animation }
  with AMultiRec do
  begin
    FillChar(MatrixSlide^, MatrixLen, 0);

    { Perform matrix proc }
    if Animation.Rotation in [krRotate90, krRotate270] then
      TteProcSlide(ProcItem.Proc)(MatrixSlide^, MatrixHeight, MatrixWidth, Percent)
    else
      TteProcSlide(ProcItem.Proc)(MatrixSlide^, MatrixWidth, MatrixHeight, Percent);

    { }
    RepeatWidth := ResultImage.Width div Animation.TileCount + 1;
    RepeatHeight := ResultImage.Height div Animation.TileCount + 1;

    { Apply matrix }
    try
      for TileX := 0 to Animation.TileCount-1 do
        for TileY := 0 to Animation.TileCount-1 do
          for MatrixX := 0 to MatrixWidth - 1 do
            for MatrixY := 0 to MatrixHeight - 1 do
            begin
              for ResX := MatrixX * Animation.Resolution to (MatrixX + 1) * Animation.Resolution do
                for ResY := MatrixY * Animation.Resolution to (MatrixY + 1) * Animation.Resolution do
                begin
                  Sx := (TileX * RepeatWidth) + ResX;
                  Sy := (TileY * RepeatHeight) + ResY;

                  { Get matrix value}
                  case Animation.Rotation of
                    krRotate90:
                      begin
                        MatrixValue := MatrixSlide[MatrixY + MatrixHeight * (MatrixWidth - MatrixX - 1)];
                        Dx := (TileX * RepeatWidth) + (MatrixWidth - MatrixValue.Y - 1) * Animation.Resolution + (ResX - MatrixX * Animation.Resolution);
                        Dy := (TileY * RepeatHeight) + MatrixValue.X * Animation.Resolution + (ResY - MatrixY * Animation.Resolution);
                      end;
                    krRotate180:
                      begin
                        MatrixValue := MatrixSlide[(MatrixWidth - MatrixX - 1) + MatrixWidth * (MatrixHeight - MatrixY - 1)];
                        Dx := (TileX * RepeatWidth) + (MatrixWidth - MatrixValue.X - 1) * Animation.Resolution + (ResX - MatrixX * Animation.Resolution);
                        Dy := (TileY * RepeatHeight) + (MatrixHeight - MatrixValue.Y - 1) * Animation.Resolution + (ResY - MatrixY * Animation.Resolution);
                      end;
                    krRotate270:
                      begin
                        MatrixValue := MatrixSlide[(MatrixHeight - MatrixY - 1) + MatrixHeight * MatrixX];
                        Dx := (TileX * RepeatWidth) + MatrixValue.Y * Animation.Resolution + (ResX - MatrixX * Animation.Resolution);
                        Dy := (TileY * RepeatHeight) + (MatrixHeight - MatrixValue.X - 1) * Animation.Resolution + (ResY - MatrixY * Animation.Resolution);
                      end;
                    else
                      { None }
                      MatrixValue := MatrixSlide[MatrixX + MatrixWidth * MatrixY];
                      Dx := (TileX * RepeatWidth) + MatrixValue.X * Animation.Resolution + (ResX - MatrixX * Animation.Resolution);
                      Dy := (TileY * RepeatHeight) + MatrixValue.Y * Animation.Resolution + (ResY - MatrixY * Animation.Resolution);
                  end;

                  { Check source point use loop }
                  if Sx >= DestImage.Width then Continue;
                  if Sy >= DestImage.Height then Continue;

                  { Get color pointer }
                  SourceColor := ResultImage.PixelPtr[Sx, Sy];

                  { Check dest position (use direct value) }
                  if (Dx >= DestImage.Width) or (Dy >= DestImage.Height) or (Dx < 0) or (Dy < 0) then
                    Continue;

                  if (Dx < TileX * RepeatWidth) or (Dx > (TileX + 1) * RepeatWidth) or
                     (Dy < TileY * RepeatHeight) or (Dy > (TileY + 1) * RepeatHeight)
                  then
                    Continue;

                  { Get destination }
                  DestColor := DestImage.PixelPtr[Dx, Dy];

                  { Apply matrix }
                  if (DestColor^ and AlphaMask = 0) then
                    Continue // Transparent
                  else
                    if MatrixValue.Alpha = $FF then
                      SourceColor^ := DestColor^
                    else
                    begin
                      DestColor^ := DestColor^ and not AlphaMask;
                      DestColor^ := DestColor^ or (MatrixValue.Alpha shl 24);
                      SourceColor^ := PixelAlphaBlendFunc(DestColor^, SourceColor^);
                    end;
                end;
            end;
    finally
      EMMS;
    end;
  end;
end;

procedure CalcFrameBitmap(AMultiRec: TteMultiAniRec;
  Percent: byte);
var
  i, j, Value: integer; { loop variables }
  DstRect: TRect;
begin
  { Bitmap's Animation }
  with AMultiRec do
  begin
    { Change Matrix }
    for i := 0 to MatrixWidth - 1 do
      for j := 0 to MatrixHeight - 1 do
      begin
        { Read default value }
        if Animation.Rotation = krNone then
          Value := CopyMatrixFade^[i + j * MatrixWidth]
        else
          if Animation.Rotation = krRotate90 then
            Value := CopyMatrixFade^[j + i * MatrixHeight]
          else
            if Animation.Rotation = krRotate180 then
              Value := CopyMatrixFade^[(MatrixWidth - i - 1) + (MatrixHeight - j - 1) * MatrixWidth]
            else
              Value := CopyMatrixFade^[(MatrixHeight - j - 1) + i * MatrixHeight];

        { Calc new value }
        Inc(Value, MulDiv($1FE , Percent, 100));
        Dec(Value, $FF);

        if Value < 0 then Value := 0;
        if Value > $FF then Value := $FF;

        { Smoth level }
  //      if Value > 0 then Value := $FF;

        { Write value }
        MatrixFade^[i + j * MatrixWidth] := Value;
      end;

    { Apply Matrix }
    for i := 0 to Animation.TileCount - 1 do
      for j := 0 to Animation.TileCount - 1 do
      begin