teblock.pas

delphi2007界面效果控件源码

unit teBlock;

interface

{$RANGECHECKS OFF}
{$INCLUDE teDefs.inc}

uses
  SysUtils, Classes, TransEff, teMasked, Windows, Messages, Graphics, teRender;

type
  TBlockTransition = class(TMaskedTransition)
  private
    FPuzzle: Boolean;
    FCols,
    FRows: Integer;
    FBlockHeight,
    FBlockWidth: Integer;
    FDual: Boolean;

    procedure SetBlockHeight(Value: Integer);
    procedure SetBlockWidth(Value: Integer);
    procedure SetCols(Value: Integer);
    procedure SetRows(Value: Integer);
  protected
    ColsToUse,
    RowsToUse: Integer;

    procedure ExecuteFrame(Data: TTETransitionData;
      CurrentFrame, Step, LastExecutedFrame: Longint); override;
    procedure MaskFrame(MaskBmp: TBitmap; CurrentFrame, Step, LastExecutedFrame:
      Longint; Data: TTETransitionData; Draw, CalcDirtyRects: Boolean); override;
    procedure Initialize(Data: TTETransitionData; var TotalFrames: Longint);
      override;
    function  Smooth(Device: TTETransitionDevice): Boolean; override;
    function  CalcTotalFrames(Data: TTETransitionData): Longint; override;
    function  CalculateReversedSubStyle(
      const StyleValue, SubStyleValue: Word): Word; override;
    function  GetBlockBounds(Data: TTETransitionData; CheckPuzzle: Boolean;
      Col, Row: Longint): TRect;
    function GetInfo(Device: TTETransitionDevice): TTETransitionInfo; override;
    procedure StyleBlockByArray(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
    procedure StyleBlockByArrayReversed(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
    procedure Style2_1Block(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
    procedure Style2_2Block(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
    procedure Style2_3Block(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
    procedure Style2_4Block(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
    procedure Style2_5Block(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
    procedure Style2_6Block(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
    procedure Style2_7Block(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
    procedure Style2_8Block(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
    procedure Style3_1Block(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
    procedure Style3_2Block(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
    procedure Style3_3Block(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
    procedure Style3_4Block(Data: TTETransitionData;
      CurrentFrame, TotFrames: Longint; var Col, Row: Integer; Dual: Boolean);
  public
    constructor Create(AOwner: TComponent = nil); override;
    class function Description: String; override;

    procedure Assign(Source: TPersistent); override;
    class function GetEditor: String; override;
    function  CountOfSubStyles(StyleValue: Word): Word; override;

    property CountOfStyles;
  published
    property BlockHeight: Integer read FBlockHeight write SetBlockHeight default 50;
    property BlockWidth: Integer read FBlockWidth write SetBlockWidth default 50;
    property Cols: Integer read FCols write SetCols default 0;
    property Dual: Boolean read FDual write FDual default False;
    property Puzzle: Boolean read FPuzzle write FPuzzle default False;
    property Rows: Integer read FRows write SetRows default 0;
    property Reversed;
    property Style;
    property SubStyle;
  end;

implementation

uses teMskWk;

type
  TStyleBlock = procedure (Data: TTETransitionData;
    CurrentFrame, TotFrames: Longint; var Col, Row: Integer;
    Dual: Boolean) of object;

  TBlockData = class(TTECustomData)
  public
    StyleBlockProc: TStyleBlock;
    ExtSize: Integer;
    IsPixel: Boolean;
    BlocksOrder: PDWordArray;
    PuzzleV_1,
    PuzzleV_2,
    PuzzleV_3,
    PuzzleV_4,
    PuzzleH_1,
    PuzzleH_2,
    PuzzleH_3,
    PuzzleH_4: TBitmap;

    destructor Destroy; override;
  end;

constructor TBlockTransition.Create(AOwner: TComponent);
begin
  inherited;

  FDual          := False;
  FPuzzle        := False;
  FBlockHeight   := 50;
  FBlockWidth    := 50;
  FCountOfStyles :=  4;
  FCols          :=  0;
  FRows          :=  0;
end;

class function TBlockTransition.Description: String;
begin
  Result := 'Blocks';
end;

procedure TBlockTransition.SetBlockHeight(Value: Integer);
begin
  if FBlockHeight <> Value then
  begin
    FBlockHeight := Value;
    if FBlockHeight < 1 then
      FBlockHeight := 1;
    FRows := 0;
  end;
end;

procedure TBlockTransition.SetBlockWidth(Value: Integer);
begin
  if FBlockWidth <> Value then
  begin
    FBlockWidth := Value;
    if FBlockWidth < 1 then
      FBlockWidth := 1;
    FCols := 0;
  end;
end;

procedure TBlockTransition.SetCols(Value: Integer);
begin
  if FCols <> Value then
  begin
    FCols := Value;
    if FCols < 1 then
      FCols := 1;
    FBlockWidth  := 0;
  end;
end;

procedure TBlockTransition.SetRows(Value: Integer);
begin
  if FRows <> Value then
  begin
    FRows := Value;
    if FRows < 1 then
      FRows := 1;
    FBlockHeight := 0;
  end;
end;

procedure TBlockTransition.Initialize(Data: TTETransitionData; var TotalFrames:
  Longint);
var
  BlockData: TBlockData;

  function CalcLCM(const Number1, Number2: Longint): Longint;
  var
    i,
    j: Integer;
    Multiple1,
    Multiple2: Longint;
  begin
    i := 1;
    j := 1;

    repeat
      Multiple1 := Number1 * i;
      Multiple2 := Number2 * j;
      if Multiple1 > Multiple2
      then Inc(j)
      else if Multiple1 < Multiple2
      then Inc(i)
    until Multiple1 = Multiple2;

    Result := Multiple1 + 1;
  end;

  function CreatePuzzle(const Vertical: Boolean; const Item: Integer;
    Monochrome: Boolean; Color: Byte): TBitmap;
  var
    Width,
    Height: Integer;
  begin
    Width  := Data.Width  div ColsToUse;
    if Item mod 2 = 0 then
      Inc(Width);

    Height := Data.Height div RowsToUse;
    if Item > 2 then
      Inc(Height);

    Result := TBitmap.Create;
    Result.Canvas.Lock;

    if Vertical
    then
    begin
      Result.Width  := Width;
      Result.Height := Height + (2 * BlockData.ExtSize);

      if Monochrome
      then
      begin
        Result.PixelFormat := pf1bit;
        Result.Canvas.Pen  .Color := clBlack;
        Result.Canvas.Brush.Color := clBlack;
        FillRect(Result.Canvas.Handle, Rect(0, 0, Result.Width, Result.Height),
          GetStockObject(WHITE_BRUSH));
      end
      else
      begin
        Result.PixelFormat := pf8bit;
        Result.Palette     := CreateGrayScalePalette;
        Result.Canvas.Pen  .Color := $02000000 or RGB(Color, Color, Color);
        Result.Canvas.Brush.Color := $02000000 or RGB(Color, Color, Color);
        FillRect(Result.Canvas.Handle, Rect(0, 0, Result.Width, Result.Height),
          GetStockObject(BLACK_BRUSH));
      end;

      Result.Canvas.Ellipse((Result.Width - BlockData.ExtSize) div 2, 0,
        (Result.Width - BlockData.ExtSize) div 2 + BlockData.ExtSize,
        BlockData.ExtSize);
      Result.Canvas.FillRect(Rect((Result.Width - BlockData.ExtSize) div 2,
        BlockData.ExtSize div 2,
        (Result.Width - BlockData.ExtSize) div 2 + BlockData.ExtSize,
        BlockData.ExtSize));
      Result.Canvas.FillRect(Rect(0, BlockData.ExtSize, Result.Width,
        Result.Height - BlockData.ExtSize));
      Result.Canvas.Ellipse((Result.Width - BlockData.ExtSize) div 2,
        Result.Height - BlockData.ExtSize,
        (Result.Width - BlockData.ExtSize) div 2 + BlockData.ExtSize,
        Result.Height);
      Result.Canvas.FillRect(Rect((Result.Width - BlockData.ExtSize) div 2,
        Result.Height - BlockData.ExtSize,
        (Result.Width - BlockData.ExtSize) div 2 + BlockData.ExtSize,
        Result.Height - (BlockData.ExtSize div 2)));
      if Monochrome
      then
      begin
        Result.Canvas.Pen  .Color := clWhite;
        Result.Canvas.Brush.Color := clWhite;
      end
      else
      begin
        Result.Canvas.Pen  .Color := clBlack;
        Result.Canvas.Brush.Color := clBlack;
      end;
      Result.Canvas.Ellipse(0, (Result.Height - BlockData.ExtSize) div 2,
        BlockData.ExtSize,
        ((Result.Height - BlockData.ExtSize) div 2) + BlockData.ExtSize);
      Result.Canvas.FillRect(Rect(0, (Result.Height - BlockData.ExtSize) div 2,
        BlockData.ExtSize div 2,
        (Result.Height - BlockData.ExtSize) div 2 + BlockData.ExtSize));
      Result.Canvas.Ellipse(Result.Width - BlockData.ExtSize,
        (Result.Height - BlockData.ExtSize) div 2, Result.Width,
        ((Result.Height - BlockData.ExtSize) div 2) + BlockData.ExtSize);
      Result.Canvas.FillRect(Rect(Result.Width - (BlockData.ExtSize div 2),
        (Result.Height - BlockData.ExtSize) div 2, Result.Width,
        (Result.Height - BlockData.ExtSize) div 2 + BlockData.ExtSize));
    end
    else
    begin
      Result.Width  := Width + (2 * BlockData.ExtSize);
      Result.Height := Height;

      if Monochrome
      then
      begin
        Result.PixelFormat := pf1bit;
        Result.Canvas.Pen  .Color := clBlack;
        Result.Canvas.Brush.Color := clBlack;
        FillRect(Result.Canvas.Handle, Rect(0, 0, Result.Width, Result.Height),
          GetStockObject(WHITE_BRUSH));
      end
      else
      begin
        Result.PixelFormat := pf8bit;
        Result.Palette     := CreateGrayScalePalette;
        Result.Canvas.Pen  .Color := $02000000 or RGB(Color, Color, Color);
        Result.Canvas.Brush.Color := $02000000 or RGB(Color, Color, Color);
        FillRect(Result.Canvas.Handle, Rect(0, 0, Result.Width, Result.Height),
           GetStockObject(BLACK_BRUSH));
      end;

      Result.Canvas.Ellipse(0, (Result.Height - BlockData.ExtSize) div 2,
        BlockData.ExtSize,
        (Result.Height - BlockData.ExtSize) div 2 + BlockData.ExtSize);
      Result.Canvas.FillRect(Rect(BlockData.ExtSize div 2,
        (Result.Height - BlockData.ExtSize) div 2, BlockData.ExtSize,
        (Result.Height - BlockData.ExtSize) div 2 + BlockData.ExtSize));
      Result.Canvas.FillRect(Rect(BlockData.ExtSize, 0,
        Result.Width - BlockData.ExtSize, Result.Height));
      Result.Canvas.Ellipse(Result.Width - BlockData.ExtSize,
        (Result.Height - BlockData.ExtSize) div 2, Result.Width,
        (Result.Height - BlockData.ExtSize) div 2 + BlockData.ExtSize);
      Result.Canvas.FillRect(Rect(Result.Width - BlockData.ExtSize,
        (Result.Height - BlockData.ExtSize) div 2,
        Result.Width - (BlockData.ExtSize div 2),
        (Result.Height - BlockData.ExtSize) div 2 + BlockData.ExtSize));
      if Monochrome
      then
      begin
        Result.Canvas.Pen  .Color := clWhite;
        Result.Canvas.Brush.Color := clWhite;
      end
      else
      begin
        Result.Canvas.Pen  .Color := clBlack;
        Result.Canvas.Brush.Color := clBlack;
      end;
      Result.Canvas.Ellipse((Result.Width - BlockData.ExtSize) div 2, 0,
        ((Result.Width - BlockData.ExtSize) div 2) + BlockData.ExtSize,
        BlockData.ExtSize);
      Result.Canvas.FillRect(Rect((Result.Width - BlockData.ExtSize) div 2, 0,
        (Result.Width - BlockData.ExtSize) div 2 + BlockData.ExtSize,
        BlockData.ExtSize div 2));
      Result.Canvas.Ellipse((Result.Width - BlockData.ExtSize) div 2,
        Result.Height - BlockData.ExtSize,
        ((Result.Width - BlockData.ExtSize) div 2) + BlockData.ExtSize,
        Result.Height);
      Result.Canvas.FillRect(Rect((Result.Width - BlockData.ExtSize) div 2,
        Result.Height - (BlockData.ExtSize div 2),
        (Result.Width - BlockData.ExtSize) div 2 + BlockData.ExtSize,
        Result.Height));
    end;
  end;

  procedure Style1BlocksOrder;
  var
    Index: DWord;
    TotalBlocks,
    i,
    aux,
    Col,
    Row: Longint;
  begin
    Randomize;
    TotalBlocks := ColsToUse * RowsToUse;
    GetMem(BlockData.BlocksOrder, (TotalBlocks+1) * 4);
    Index := 1;
    for Row := 1 to RowsToUse do
    begin
      aux := Row shl 16;
      for Col := 1 to ColsToUse do
      begin
        BlockData.BlocksOrder[Index] := aux + Col;
        Inc(Index);
      end;
    end;
    for i := 1 to TotalBlocks do
    begin
      aux                          := BlockData.BlocksOrder[i];
      Index                        := Random(TotalBlocks) + 1;
      BlockData.BlocksOrder[i]     := BlockData.BlocksOrder[Index];
      BlockData.BlocksOrder[Index] := aux;
    end;
  end;

  procedure Style4_1BlocksOrder;
  var
    TotalBlocks,
    Col,
    Row,
    PrevCol,
    PrevRow,
    IncCol,
    IncRow: Longint;
    i: Longint;
    R : TRect;
  begin
    TotalBlocks := ColsToUse * RowsToUse;
    Col         := 1;
    Row         := 1;
    PrevCol     := Col;
    PrevRow     := Row;