teblock.pas

Do your applications look a little boring? Would you like to get spectacular yet easy to use visual

unit teBlock;

interface

{$INCLUDE teDefs.inc}

uses
  SysUtils, Classes, TransEff, teMasked, teRender,
  {$ifdef CLX}
  QForms, QGraphics;
  {$else}
  Windows, Messages, Forms, Graphics;
  {$endif CLX}

type
{$ifndef TE_NOHLP}
  TStyleBlock = procedure (CurrentFrame, TotFrames: Longint;
    var Col, Row: Integer; Dual: Boolean) of object;
{$endif TE_NOHLP}

  TBlockTransition = class(TMaskedTransition)
  private
    StyleBlockProc: TStyleBlock;
    FPuzzle: Boolean;
    FCols,
    FRows: Integer;
    FBlockHeight,
    FBlockWidth,
    ExtSize: Integer;
    IsPixel: Boolean;
    BlocksOrder: PDWordArray;
    PuzzleV_1,
    PuzzleV_2,
    PuzzleV_3,
    PuzzleV_4,
    PuzzleH_1,
    PuzzleH_2,
    PuzzleH_3,
    PuzzleH_4: TBitmap;
    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, TotalFrames, LastExecutedFrame: Longint); override;
    procedure MaskFrame(MaskBmp: TBitmap;
      CurrentFrame, Step, TotalFrames, LastExecutedFrame: Longint;
      Data: TTETransitionData; Draw, CalcDirtyRects: Boolean); override;
    procedure Initialize(Data: TTETransitionData; var Frames: Longint); override;
    procedure Finalize(Data: TTETransitionData); override;
    function  Smooth: 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;
    procedure StyleBlockByArray(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
    procedure StyleBlockByArrayReversed(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
    procedure Style2_1Block(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
    procedure Style2_2Block(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
    procedure Style2_3Block(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
    procedure Style2_4Block(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
    procedure Style2_5Block(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
    procedure Style2_6Block(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
    procedure Style2_7Block(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
    procedure Style2_8Block(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
    procedure Style3_1Block(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
    procedure Style3_2Block(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
    procedure Style3_3Block(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
    procedure Style3_4Block(CurrentFrame, TotFrames: Longint;
      var Col, Row: Integer; Dual: Boolean);
  public
    constructor Create(AOwner: TComponent{$ifdef DP} = nil{$endif}); 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;

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

  StyleBlockProc := nil;
  FDual          := False;
  FPuzzle        := False;
  FBlockHeight   := 50;
  FBlockWidth    := 50;
  FCountOfStyles :=  4;
  FCols          :=  0;
  FRows          :=  0;
  BlocksOrder    := nil;
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 Frames: Longint);

  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;
    Monocrhome: 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;

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

      if Monocrhome
      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 - ExtSize) div 2, 0,
        (Result.Width - ExtSize) div 2 + ExtSize, ExtSize);
      Result.Canvas.FillRect(Rect((Result.Width - ExtSize) div 2, ExtSize div 2,
        (Result.Width - ExtSize) div 2 + ExtSize, ExtSize));
      Result.Canvas.FillRect(Rect(0, ExtSize, Result.Width,
        Result.Height - ExtSize));
      Result.Canvas.Ellipse((Result.Width - ExtSize) div 2,
        Result.Height - ExtSize, (Result.Width - ExtSize) div 2 + ExtSize,
        Result.Height);
      Result.Canvas.FillRect(Rect((Result.Width - ExtSize) div 2,
        Result.Height - ExtSize, (Result.Width - ExtSize) div 2 + ExtSize,
        Result.Height - (ExtSize div 2)));
      if Monocrhome
      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 - ExtSize) div 2, ExtSize,
        ((Result.Height - ExtSize) div 2) + ExtSize);
      Result.Canvas.FillRect(Rect(0, (Result.Height - ExtSize) div 2,
        ExtSize div 2, (Result.Height - ExtSize) div 2 + ExtSize));
      Result.Canvas.Ellipse(Result.Width - ExtSize,
        (Result.Height - ExtSize) div 2, Result.Width,
        ((Result.Height - ExtSize) div 2) + ExtSize);
      Result.Canvas.FillRect(Rect(Result.Width - (ExtSize div 2),
        (Result.Height - ExtSize) div 2, Result.Width,
        (Result.Height - ExtSize) div 2 + ExtSize));
    end
    else
    begin
      Result.Width  := Width + (2 * ExtSize);
      Result.Height := Height;

      if Monocrhome
      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 - ExtSize) div 2, ExtSize,
        (Result.Height - ExtSize) div 2 + ExtSize);
      Result.Canvas.FillRect(Rect(ExtSize div 2, (Result.Height - ExtSize) div 2,
        ExtSize, (Result.Height - ExtSize) div 2 + ExtSize));
      Result.Canvas.FillRect(Rect(ExtSize, 0, Result.Width - ExtSize,
        Result.Height));
      Result.Canvas.Ellipse(Result.Width - ExtSize,
        (Result.Height - ExtSize) div 2, Result.Width,
        (Result.Height - ExtSize) div 2 + ExtSize);
      Result.Canvas.FillRect(Rect(Result.Width - ExtSize,
        (Result.Height - ExtSize) div 2,
        Result.Width - (ExtSize div 2),
        (Result.Height - ExtSize) div 2 + ExtSize));
      if Monocrhome
      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 - ExtSize) div 2, 0,
        ((Result.Width - ExtSize) div 2) + ExtSize, ExtSize);
      Result.Canvas.FillRect(Rect((Result.Width - ExtSize) div 2, 0,
        (Result.Width - ExtSize) div 2 + ExtSize, ExtSize div 2));
      Result.Canvas.Ellipse((Result.Width - ExtSize) div 2,
        Result.Height - ExtSize, ((Result.Width - ExtSize) div 2) + ExtSize,
        Result.Height);
      Result.Canvas.FillRect(Rect((Result.Width - ExtSize) div 2,
        Result.Height - (ExtSize div 2),
        (Result.Width - ExtSize) div 2 + ExtSize, Result.Height));
    end;
  end;

  procedure Style1BlocksOrder;
  var
    Index: DWord;
    TotalBlocks,
    i,
    aux,
    Col,
    Row: Longint;
  begin
    Randomize;
    TotalBlocks := ColsToUse * RowsToUse;
    GetMem(BlocksOrder, (TotalBlocks+1) * 4);
    Index := 1;
    for Row := 1 to RowsToUse do
    begin
      aux := Row shl 16;
      for Col := 1 to ColsToUse do
      begin
        BlocksOrder[Index] := aux + Col;
        Inc(Index);
      end;
    end;
    for i := 1 to TotalBlocks do
    begin
      aux                := BlocksOrder[i];
      Index              := Random(TotalBlocks) + 1;
      BlocksOrder[i]     := BlocksOrder[Index];
      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;
    IncCol         := 1;
    IncRow         := 0;
    R              := Rect(0, 1, ColsToUse + 1, RowsToUse + 1);
    GetMem(BlocksOrder, (TotalBlocks+1) * 4);
    BlocksOrder[1] := (Row shl 16) + Col;
    for i := 2 to TotalBlocks do
    begin
      if IncCol <> 0 then
      begin