{******************************************************************************}
{* Иллюстрация к книге "DirectX. Графика в проектах Delphi".                  *}
{* Издательство BHV. www.bhv.ru                                               *}
{* Краснов М.В. softgl@chat.ru                                                *}
{******************************************************************************}
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  AppEvnts, ExtCtrls,
  DirectDraw, DDUtil8;

type
  TSPRITE_STRUCT = record
    fPosX : Integer;
    fPosY : Integer;
    fVelX : Integer;
    fVelY : Integer;
  end;
    
type
  TfrmDD = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ApplicationEvents1Deactivate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ApplicationEvents1Restore(Sender: TObject);
    procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
    procedure FormActivate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    g_pDisplay     : CDisplay;
    g_pLogoSurface : CSurface;
    g_pTextSurface : CSurface;
    FActive        : BOOL;
    ThisTickCount  : DWORD;
    LastTickCount  : DWORD;
    function RestoreSurfaces : HRESULT;
    function UpdateFrame : HRESULT;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
    procedure UpdateSprite( var pSprite : TSPRITE_STRUCT );
  public
    { Public declarations }
  protected
    procedure FormSetCursor(var aMsg : TMessage); message WM_SETCURSOR;
  end;

const
  ScreenWidth     = 640;
  ScreenHeight    = 480;
  ScreenBitDepth  = 8;
  SPRITE_DIAMETER = 48;
  NUM_SPRITES     = 25;
  imageBmp        = '..\DirectX.bmp';
  HELPTEXT        = 'Press Escape to quit.';

var
  frmDD : TfrmDD;
  g_Sprite : Array [0..NUM_SPRITES-1] of TSPRITE_STRUCT;
  g_pe : Array [0..255] of PALETTEENTRY;

implementation

{$R *.DFM}

procedure TfrmDD.ErrorOut(hRet : HRESULT; FuncName : String);
var
  t : TextFile;
begin
  AssignFile (t, 'Debug.txt');
  Rewrite (t);
  WriteLn (t, FuncName + ': ' + DDErrorString (hRet));
  CloseFile (t);
  Destroy;
end;

procedure TfrmDD.FormCreate(Sender: TObject);
var
  hr : HRESULT;
  iSprite : Integer;
begin
  g_pDisplay := CDisplay.Create;
  hr := g_pDisplay.CreateFullScreenDisplay( Handle, ScreenWidth,
                                            ScreenHeight, ScreenBitDepth );

  if FAILED( hr ) then ErrorOut (hr, 'This display card does not support 640x480x8.');

  hr := g_pDisplay.CreateSurfaceFromBitmap( g_pLogoSurface, imageBmp,
                                            SPRITE_DIAMETER, SPRITE_DIAMETER );
  if( FAILED( hr ) ) then ErrorOut (hr, 'CreateSurfaceFromBitmap');

  hr := g_pDisplay.CreateSurfaceFromText( g_pTextSurface, Font.Handle, HELPTEXT,
                                                      RGB(0,0,0), RGB(255, 255, 0) );
  if( FAILED( hr ) ) then ErrorOut (hr, 'CreateSurfaceFromText');

  hr := g_pLogoSurface.SetColorKey( 0 );
  if( FAILED( hr ) ) then ErrorOut (hr, 'SetColorKey');

  Randomize;
  for iSprite := 0 to NUM_SPRITES - 1 do begin
      g_Sprite[iSprite].fPosX := random (ScreenWidth - SPRITE_DIAMETER);
      g_Sprite[iSprite].fPosY := random (ScreenHeight - SPRITE_DIAMETER);

      g_Sprite[iSprite].fVelX := random (5) + 1;
      g_Sprite[iSprite].fVelY := random (5) + 1;
  end;

  if( FAILED( hr ) ) then ErrorOut (hr, 'GetEntries');

  ThisTickCount := GetTickCount;
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned (g_pLogoSurface) then g_pLogoSurface.Free;
  if Assigned (g_pTextSurface) then g_pTextSurface.Free; 
  if Assigned (g_pDisplay) then g_pDisplay.Free;
end;

procedure TfrmDD.ApplicationEvents1Deactivate(Sender: TObject);
begin
  FActive := False;
  Application.Minimize;
end;

procedure TfrmDD.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_ESCAPE then Close;
end;

procedure TfrmDD.ApplicationEvents1Restore(Sender: TObject);
begin
  WindowState := wsMaximized;
  FActive := True;
end;

function TfrmDD.RestoreSurfaces : HRESULT;
var
  hr : HRESULT;
begin
  hr := g_pDisplay.GetDirectDraw.RestoreAllSurfaces;
  if( FAILED( hr ) ) then begin
      Result := hr;
      Exit;
  end;

  hr := g_pTextSurface.DrawText ( Font.Handle, HELPTEXT,
                                 0, 0, RGB(0,0,0), RGB(255, 255, 0));
  if( FAILED( hr ) ) then begin
      Result := hr;
      Exit;
  end;

  hr := g_pLogoSurface.DrawBitmap( imageBmp,
                                   SPRITE_DIAMETER, SPRITE_DIAMETER );
  if( FAILED( hr ) ) then begin
      Result := hr;
      Exit;
  end;

  Result := S_OK;
end;

procedure TfrmDD.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);
begin
  if FActive then
     if Failed ( UpdateFrame ) then RestoreSurfaces;

  Done := False;
end;

procedure TfrmDD.FormActivate(Sender: TObject);
begin
  FActive := True;
end;

function TfrmDD.UpdateFrame : HRESULT;
var
  iSprite : Integer;
begin
  g_pDisplay.Clear (0);

  ThisTickCount := GetTickCount;

  if ThisTickCount - LastTickCount > 10 then begin
     for iSprite := 0 to NUM_SPRITES - 1 do
      UpdateSprite( g_Sprite[ iSprite ] );

     LastTickCount := GetTickCount;
  end;

  for iSprite := 0 to NUM_SPRITES - 1 do
  g_pDisplay.ColorKeyBlt( g_Sprite[iSprite].fPosX,
                      g_Sprite[iSprite].fPosY, g_pLogoSurface.GetDDrawSurface, nil);

  g_pDisplay.Blt( 10, 10, g_pTextSurface, nil );

  Result := g_pDisplay.Present;
end;

procedure TfrmDD.UpdateSprite( var pSprite : TSPRITE_STRUCT );
begin
  pSprite.fPosX := pSprite.fPosX + pSprite.fVelX;
  pSprite.fPosY := pSprite.fPosY + pSprite.fVelY;

  if( pSprite.fPosX < 0 ) then begin
      pSprite.fPosX := 0;
      pSprite.fVelX := -pSprite.fVelX;
  end;

  if( pSprite.fPosX >= ScreenWidth - SPRITE_DIAMETER ) then begin
      pSprite.fPosX := ScreenWidth - 1 - SPRITE_DIAMETER;
      pSprite.fVelX := -pSprite.fVelX;
  end;

  if( pSprite.fPosY < 0 ) then begin
      pSprite.fPosY := 0;
      pSprite.fVelY := -pSprite.fVelY;
  end;

  if( pSprite.fPosY > ScreenHeight - SPRITE_DIAMETER ) then begin
      pSprite.fPosY := ScreenHeight - 1 - SPRITE_DIAMETER;
      pSprite.fVelY := -pSprite.fVelY;
  end;
end;

procedure TfrmDD.FormSetCursor(var aMsg : TMessage);
begin
  SetCursor(0);
end;

procedure TfrmDD.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Hide
end;

end.

