/GR32Ex/GR_Animation.pas
Pascal | 594 lines | 490 code | 64 blank | 40 comment | 40 complexity | 7cfa72c1d2123decbf21ac5a3018f44b MD5 | raw file
Possible License(s): MPL-2.0-no-copyleft-exception
- (* ***** BEGIN LICENSE BLOCK *****
- * Version: MPL 1.1
- *
- * 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 GR_Animation
- *
- * The Initial Developer of the Original Code is Riceball LEE
- * Portions created by Riceball LEE are Copyright (C) 2008
- * Portions created by Michael Faust - http://www.alpha-interactive.de/ are Copyright (C) 2000-2005
- * All Rights Reserved.
- *
- * Contributor(s):
- *
- * ***** END LICENSE BLOCK ***** *)
- unit GR_Animation;
-
- {$I Setting.inc}
-
- interface
-
- uses
- {$ifdef Debug}
- DbugIntf,
- {$endif}
- Windows,
- SysUtils, Classes
- , Graphics
- , GR32
- , GR32_Layers
- , GR32_Transforms
- , GR32_Filters
- //, GR_Graphics
- //, GR_FilterEx
- //, GR_GraphUtils
- //, PNGImage
- //, GR32_PNG
- ;
-
- type
- TGRSpeed = 10..1000;
-
- TGRAnimationFrameClass = class of TGRAnimationFrame;
- TGRAnimationFrame = class(TCollectionItem)
- protected
- //for transparent
- FBackgroundColor: TColor;
- FBitmap: TBitmap32;
- FDelayTime: LongWord;
- procedure SetBitmap(const aBitmap: TBitmap32);
- public
- constructor Create(Collection: TCollection); override;
- destructor Destroy; override;
- published
- property BackgroundColor: TColor read FBackgroundColor write FBackgroundColor;
- property Bitmap: TBitmap32 read FBitmap write SetBitmap;
- property DelayTime: LongWord read FDelayTime write FDelayTime;
- end;
-
- TGRAnimationFrames = class(TCollection)
- private
- FOwner: TPersistent;
- function GetItem(Index: Integer): TGRAnimationFrame;
- procedure SetItem(Index: Integer; Value: TGRAnimationFrame);
- protected
- function GetOwner: TPersistent; override;
- public
- constructor Create(aOwner: TPersistent);
- function Add: TGRAnimationFrame;
- property Items[Index: Integer]: TGRAnimationFrame read GetItem write SetItem; default;
- end;
-
- TGRAniDisplayFrameEvent = procedure(Sender: TObject; aFrame: TGRAnimationFrame) of object;
- TGRAnimationDirection = (adForward, adRewind);
- TGRAniLoopEvent = procedure(Sender: TObject; var Continued: Boolean) of object;
- TGRAnimationClass = class of TGRAnimation;
- //the abstract animation class
- TGRAnimation = class(TPersistent)
- protected
- FOwner: TPersistent;
- FFrames: TGRAnimationFrames;
- FSpeed: TGRSpeed;
- FLooped: Boolean;
- FRunning: Boolean;
- FEnabled: Boolean;
- FFlipAlpha: Boolean;
- FCurrentIndex: Integer;
- FDirection: TGRAnimationDirection;
- FBackgroundColor: TColor;
- FOnLoop: TGRAniLoopEvent;
- FOnDisplayFrame: TGRAniDisplayFrameEvent;
- procedure SetFrames(const Value: TGRAnimationFrames);
- function GetOwner: TPersistent;override;
- function GetInterval(const FrameIndex: Integer): Integer; virtual;
- procedure SetSpeed(const Value: TGRSpeed);
- function GetFrameDelay(const FrameIndex: Integer; const SafeMode: Boolean=True): Integer;virtual;
- function GetNextIndex(var aIndex: Integer; const CanLoop: Boolean): Boolean;
- function IndexIsValid(const aIndex: Integer): Boolean;
- procedure DoLoop(var aContinued: Boolean);
-
- procedure DoFlipAlphaChannel(BMP32: TBitmap32);
- procedure DoFlipAlphaChannels;
- public
- procedure RequestFlipAlphaChannel;
- function DisplayFirstFrame(): Boolean;
- function DisplayFrame(const FrameIndex: Integer): Boolean;
- procedure LoadFromFile(const Filename: string);
- procedure SaveToFile(const Filename: string);
- procedure LoadFromStream(const aStream: TStream);virtual;abstract;
- procedure SaveToStream(const aStream: TStream);virtual;abstract;
- procedure Assign(Source: TPersistent);override;
- constructor Create(aOwner: TPersistent);virtual;
- destructor Destroy; override;
-
- property BackgroundColor: TColor read FBackgroundColor write FBackgroundColor;
- property Enabled: Boolean read FEnabled write FEnabled;
- property Frames: TGRAnimationFrames read FFrames write SetFrames;
- property FlipAlphaChannel: Boolean read FFlipAlpha write FFlipAlpha;
- property IsRunning: Boolean read FRunning;
- property Owner: TPersistent read FOwner;
- property Speed: TGRSpeed read FSpeed write SetSpeed;
- property Looped: Boolean read FLooped write FLooped;
- property OnLoop: TGRAniLoopEvent read FOnLoop write FOnLoop;
- property OnDisplayFrame: TGRAniDisplayFrameEvent read FOnDisplayFrame write FOnDisplayFrame;
- end;
-
- //to play the TGRAnimation frames.
- // abondon, use the New Animator-Effects Arch Framework.
- TGRAnimationThread = class(TThread)
- protected
- FInterval: LongWord;
- FAni: TGRAnimation;
- FStop: THandle;
- FEnabled: Boolean;
-
- procedure SetEnabled(const Value: Boolean);
- procedure SetInterval(const Value: LongWord);
-
- procedure Execute; override;
- public
- constructor Create(const aAnimation: TGRAnimation);
- destructor Destroy; override;
-
- property Enabled: Boolean read FEnabled write SetEnabled;
- property Interval: LongWord read FInterval write SetInterval;
- end;
-
- type
- PAniFileFormat = ^TAniFileFormat;
- TAniFileFormat = record
- AnimationClass: TGRAnimationClass;
- Extension: string;
- Description: string;
- DescResID: Integer;
- end;
-
- TAniFileFormatsList = class(TList)
- public
- constructor Create;
- destructor Destroy; override;
- procedure Add(const Ext, Desc: String; DescID: Integer; AClass: TGRAnimationClass);
- function FindExt(Ext: string): TGRAnimationClass;
- function FindClassName(const Classname: string): TGRAnimationClass;
- procedure Remove(AClass: TGRAnimationClass);
- procedure BuildFilterStrings(AnimationClass: TGRAnimationClass;
- var Descriptions, Filters: string);
- end;
-
-
- procedure RegisterAnimation(const AExtension, ADescription: string; const aClass: TGRAnimationClass);
- function GAniFileFormats: TAniFileFormatsList;
-
- implementation
-
- uses
- Consts;
-
- const
- G32DefaultDelay: ShortInt = 100; // Time in ms.
- G32MinimumDelay: ShortInt = 10; // Time in ms.
-
- { TAniFileFormatsList }
- constructor TAniFileFormatsList.Create;
- begin
- inherited Create;
- end;
-
- destructor TAniFileFormatsList.Destroy;
- var
- I: Integer;
- begin
- for I := 0 to Count-1 do
- Dispose(PAniFileFormat(Items[I]));
- inherited Destroy;
- end;
-
- procedure TAniFileFormatsList.Add(const Ext, Desc: String; DescID: Integer;
- AClass: TGRAnimationClass);
- var
- NewRec: PAniFileFormat;
- begin
- New(NewRec);
- with NewRec^ do
- begin
- Extension := AnsiLowerCase(Ext);
- AnimationClass := AClass;
- Description := Desc;
- DescResID := DescID;
- end;
- inherited Add(NewRec);
- end;
-
- function TAniFileFormatsList.FindExt(Ext: string): TGRAnimationClass;
- var
- I: Integer;
- begin
- Ext := AnsiLowerCase(Ext);
- for I := Count-1 downto 0 do
- with PAniFileFormat(Items[I])^ do
- if Extension = Ext then
- begin
- Result := AnimationClass;
- Exit;
- end;
- Result := nil;
- end;
-
- function TAniFileFormatsList.FindClassName(const ClassName: string): TGRAnimationClass;
- var
- I: Integer;
- begin
- for I := Count-1 downto 0 do
- begin
- Result := PAniFileFormat(Items[I])^.AnimationClass;
- if Result.ClassName = Classname then Exit;
- end;
- Result := nil;
- end;
-
- procedure TAniFileFormatsList.Remove(AClass: TGRAnimationClass);
- var
- I: Integer;
- P: PAniFileFormat;
- begin
- for I := Count-1 downto 0 do
- begin
- P := PAniFileFormat(Items[I]);
- if P^.AnimationClass.InheritsFrom(AClass) then
- begin
- Dispose(P);
- Delete(I);
- end;
- end;
- end;
-
- procedure TAniFileFormatsList.BuildFilterStrings(AnimationClass: TGRAnimationClass;
- var Descriptions, Filters: string);
- var
- C, I: Integer;
- P: PAniFileFormat;
- begin
- Descriptions := '';
- Filters := '';
- C := 0;
- for I := Count-1 downto 0 do
- begin
- P := PAniFileFormat(Items[I]);
- if P^.AnimationClass.InheritsFrom(AnimationClass) and (P^.Extension <> '') then
- with P^ do
- begin
- if C <> 0 then
- begin
- Descriptions := Descriptions + '|';
- Filters := Filters + ';';
- end;
- if (Description = '') and (DescResID <> 0) then
- Description := LoadStr(DescResID);
- FmtStr(Descriptions, '%s%s (*.%s)|*.%2:s', [Descriptions, Description, Extension]);
- FmtStr(Filters, '%s*.%s', [Filters, Extension]);
- Inc(C);
- end;
- end;
- if C > 1 then
- FmtStr(Descriptions, '%s (%s)|%1:s|%s', [sAllFilter, Filters, Descriptions]);
- end;
-
- var
- FAniFileFormats: TAniFileFormatsList = nil;
-
- function GAniFileFormats: TAniFileFormatsList;
- begin
- if FAniFileFormats = nil then FAniFileFormats := TAniFileFormatsList.Create;
- Result := FAniFileFormats;
- end;
-
-
- procedure RegisterAnimation(const AExtension, ADescription: string; const aClass: TGRAnimationClass);
- begin
- GAniFileFormats.Add(AExtension, ADescription, 0, aClass);
- end;
-
- { TGRAnimationFrame }
- constructor TGRAnimationFrame.Create(Collection: TCollection);
- begin
- inherited;
- FBitmap := TBitmap32.Create;
- end;
-
- destructor TGRAnimationFrame.Destroy;
- begin
- FBitmap.Free;
- inherited;
- end;
-
- procedure TGRAnimationFrame.SetBitmap(const aBitmap: TBitmap32);
- begin
- FBitmap.Assign(aBitmap);
- end;
-
- { TGRAnimationFrames }
- function TGRAnimationFrames.Add: TGRAnimationFrame;
- begin
- Result := TGRAnimationFrame(inherited Add);
- end;
-
- constructor TGRAnimationFrames.Create(aOwner: TPersistent);
- begin
- inherited Create(TGRAnimationFrame);
- FOwner := aOwner;
- end;
-
- function TGRAnimationFrames.GetItem(Index: Integer): TGRAnimationFrame;
- begin
- Result := TGRAnimationFrame(inherited GetItem(Index));
- end;
-
- function TGRAnimationFrames.GetOwner: TPersistent;
- begin
- Result := FOwner;
- end;
-
- procedure TGRAnimationFrames.SetItem(Index: Integer; Value: TGRAnimationFrame);
- begin
- inherited SetItem(Index, Value);
- end;
-
- { TGRAnimation }
- constructor TGRAnimation.Create(aOwner: TPersistent);
- begin
- inherited Create();
- FOwner := aOwner;
- FFrames := TGRAnimationFrames.Create(Self);
- FSpeed := 100;
- end;
-
- destructor TGRAnimation.Destroy;
- begin
- FFrames.Free;
- inherited;
- end;
- procedure TGRAnimation.Assign(Source: TPersistent);
- begin
- if Source is TGRAnimation then
- with Source as TGRAnimation do
- begin
- Self.FFrames.Assign(FFrames);
- Self.FSpeed := FSpeed;
- end;
- inherited;
- end;
-
- function TGRAnimation.DisplayFirstFrame(): Boolean;
- begin
- Result := DisplayFrame(0);
- end;
-
- function TGRAnimation.DisplayFrame(const FrameIndex: Integer): Boolean;
- begin
- Result := FEnabled and IndexIsValid(FrameIndex);
- if Result then
- begin
- if Assigned(FOnDisplayFrame) then
- FOnDisplayFrame(Self, FFrames[FrameIndex]);
- if Frames.Count > 1 then
- GetNextIndex(FCurrentIndex, FLooped);
- end;
- end;
-
- procedure TGRAnimation.DoLoop(var aContinued: Boolean);
- begin
- if Assigned(FOnLoop) then
- FOnLoop(Self, aContinued);
- end;
-
- function TGRAnimation.GetFrameDelay(const FrameIndex: Integer; const SafeMode: Boolean): Integer;
- begin
- Result := 0;
- if IndexIsValid(FrameIndex) then
- Result := Frames.Items[FrameIndex].DelayTime;
- if (Result < G32MinimumDelay) and SafeMode then
- begin
- if (Result = 0) then
- Result := G32DefaultDelay
- else
- Result := G32MinimumDelay;
- end;
- end;
-
- function TGRAnimation.GetInterval(const FrameIndex: Integer): Integer;
- begin
- Result := GetFrameDelay(FrameIndex);
- Result := Result * 100 div FSpeed;
- end;
-
- function TGRAnimation.GetNextIndex(var aIndex: Integer; const CanLoop: Boolean): Boolean;
- begin
- Result := False;
- if (Frames.Count > 0) then
- begin
- if (FDirection = adForward) then
- begin
- if (aIndex < Frames.Count -1) then
- begin
- inc(aIndex);
- Result := true;
- end
- else begin
- aIndex := 0;
- Result := CanLoop and (Frames.Count > 1);
- if Result then DoLoop(Result);
- end;
- end
- else begin
- if (aIndex > 0) then
- begin
- dec(aIndex);
- Result := true;
- end
- else begin
- aIndex := Frames.Count -1; // decrement it right here !
- Result := CanLoop and (Frames.Count > 1);
- if Result then DoLoop(Result);
- end;
- end;
- end;
- end;
-
- function TGRAnimation.GetOwner: TPersistent;
- begin
- Result := FOwner;
- end;
-
- function TGRAnimation.IndexIsValid(const aIndex: Integer): Boolean;
- begin
- Result := (aIndex >= 0) and (aIndex < Frames.Count);
- end;
-
-
- procedure TGRAnimation.LoadFromFile(const Filename: string);
- var
- Stream: TStream;
- begin
- Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyWrite);
- try
- LoadFromStream(Stream);
- finally
- Stream.Free;
- end;
- end;
-
- procedure TGRAnimation.DoFlipAlphaChannel(BMP32: TBitmap32);
- var
- X: Integer;
- P: PColor32;
- begin
- P := @(BMP32).Bits[0];
- for X := 0 to BMP32.Width * BMP32.Height -1 do
- begin
- P^ := P^ XOR $FF000000;
- inc(P);
- end;
- end;
-
- procedure TGRAnimation.DoFlipAlphaChannels;
- var
- I: Integer;
- begin
- for I := 0 to FFrames.Count -1 do
- DoFlipAlphaChannel( FFrames.Items[I].Bitmap );
- end;
-
- procedure TGRAnimation.RequestFlipAlphaChannel;
- begin
- if FFlipAlpha then
- DoFlipAlphaChannels;
- end;
-
- procedure TGRAnimation.SaveToFile(const Filename: string);
- var
- Stream: TStream;
- begin
- Stream := TFileStream.Create(Filename, fmCreate or fmShareDenyWrite);
- try
- SaveToStream(Stream);
- finally
- Stream.Free;
- end;
- end;
-
- procedure TGRAnimation.SetFrames(const Value: TGRAnimationFrames);
- begin
- FFrames.Assign(Value);
- end;
-
- procedure TGRAnimation.SetSpeed(const Value: TGRSpeed);
- begin
- if (FSpeed <> Value) then
- begin
- FSpeed := Value;
- end;
- end;
-
- { TGRAnimationThread }
-
- constructor TGRAnimationThread.Create(const aAnimation: TGRAnimation);
- begin
- inherited Create(true);
- FStop := CreateEvent(nil, False, False, nil);
- FAni := aAnimation;
- Enabled := false;
- FreeOnTerminate:= false;
- FInterval := G32DefaultDelay;
- end;
-
- destructor TGRAnimationThread.Destroy;
- begin
- Enabled := false;
- CloseHandle(FStop);
- Terminate;
- inherited Destroy;
- end;
-
- procedure TGRAnimationThread.SetEnabled(const Value: Boolean);
- begin
- if (Value <> FEnabled) and (not Terminated) then
- begin
- FEnabled := Value;
- if FEnabled and (FInterval > 0) then
- Resume
- else
- Suspend;
- end;
- end;
-
- procedure TGRAnimationThread.SetInterval(const Value: LongWord);
- var
- WasEnabled: Boolean;
- begin
- if (Value <> FInterval) and (not Terminated) then
- begin
- WasEnabled := FEnabled;
- FInterval := Value;
- Enabled := WasEnabled and (FInterval > 0);
- end;
- end;
-
- procedure TGRAnimationThread.Execute;
- begin
- repeat
- if (WaitForSingleObject(FStop, FInterval) = WAIT_TIMEOUT) and (not Terminated) then
- begin
- if FAni.Enabled then
- begin
- FAni.DisplayFrame(FAni.FCurrentIndex);
- FAni.FRunning := FAni.GetNextIndex(FAni.FCurrentIndex, FAni.FLooped);
- if FAni.IsRunning then
- begin
- Interval := FAni.GetInterval(FAni.FCurrentIndex);
- end;
- Enabled := FAni.IsRunning;
- end;
- end;
- until Terminated;
- end;
-
- end.