{******************************************************************************}
{* Иллюстрация к книге "DirectX. Графика в проектах Delphi".                  *}
{* Издательство BHV. www.bhv.ru                                               *}
{* Краснов М.В. softgl@chat.ru                                                *}
{******************************************************************************}
//-----------------------------------------------------------------------------
// File: DirectSurfaceWrite.cpp
//
// Desc: This sample demonstrates how to animate sprites using
//       DirectDraw.  The samples runs in full-screen mode.  Pressing any
//       key will exit the sample.
//
// Copyright (c) 1999-2000 Microsoft Corporation. All rights reserved.
//-----------------------------------------------------------------------------

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_pSpriteSurface : CSurface;
    g_pTextSurface   : CSurface;
    FActive          : BOOL;
    ThisTickCount    : DWORD;
    LastTickCount    : DWORD;
    function DrawSprite : HRESULT;
    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  = 16;
  SPRITE_DIAMETER = 250;
  NUM_SPRITES     = 5;
  HELPTEXT        = 'Press Escape to quit.';

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

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.CreateSurface( g_pSpriteSurface, SPRITE_DIAMETER, SPRITE_DIAMETER );

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

  hr := DrawSprite;
  if( FAILED( hr ) ) then ErrorOut (hr, 'DrawSprite');

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

  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;

  ThisTickCount := GetTickCount;
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned (g_pSpriteSurface) then g_pSpriteSurface.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;

  Result := DrawSprite;
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.Blt( g_Sprite[iSprite].fPosX,
                   g_Sprite[iSprite].fPosY,
                   g_pSpriteSurface, 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;

function TfrmDD.DrawSprite : HRESULT;
var
    ddsd : TDDSURFACEDESC2;
    hr : HRESULT;
    dwShift : DWORD;
    dwBits : DWORD;
    dwRed : DWORD ;
    dwGreen : DWORD ;
    dwBlue : DWORD;
    fPercentX : Single;
    fPercentY : Single;
    fPercentXY : Single;
    pDDS : IDIRECTDRAWSURFACE7;
    pDDSColor : PWORD;
    iX, iY : DWORD;
begin
    pDDS := g_pSpriteSurface.GetDDrawSurface;

    ZeroMemory( @ddsd, sizeof(ddsd) );
    ddsd.dwSize := sizeof(ddsd);

    hr := pDDS.Lock( nil, ddsd, DDLOCK_WAIT, 0 );
    if( FAILED( hr ) ) then begin
        Result := hr;
        Exit
    end;

    pDDSColor := PWORD (ddsd.lpSurface);

    for iY := 0 to ddsd.dwHeight - 1 do begin
        for iX := 0 to ddsd.dwWidth - 1 do begin
            g_pSpriteSurface.GetBitMaskInfo( ddsd.ddpfPixelFormat.dwRBitMask, dwShift, dwBits );
            fPercentY := abs( ddsd.dwHeight / 2 - iY ) / ( ddsd.dwHeight / 2 ) + 0.25;
            if( fPercentY > 1.00 ) then fPercentY := 1.00;
            dwRed := trunc ((ddsd.ddpfPixelFormat.dwRBitMask shr dwShift) * fPercentY) shl dwShift;

            g_pSpriteSurface.GetBitMaskInfo( ddsd.ddpfPixelFormat.dwGBitMask, dwShift, dwBits );
            fPercentX := abs( ddsd.dwWidth / 2 - iX ) / ( ddsd.dwWidth / 2 ) + 0.25;
            if( fPercentX > 1.00 ) then fPercentX := 1.00;
            dwGreen :=  trunc ( (ddsd.ddpfPixelFormat.dwGBitMask shr dwShift) * fPercentX) shl dwShift;

            g_pSpriteSurface.GetBitMaskInfo( ddsd.ddpfPixelFormat.dwBBitMask, dwShift, dwBits );
            fPercentX := abs( ddsd.dwWidth / 2 - iX ) / ( ddsd.dwWidth / 4 );
            fPercentX := 1.0 - fPercentX * fPercentX;
            fPercentY := abs( ddsd.dwHeight / 2 - iY ) / ( ddsd.dwHeight / 4 );
            fPercentY := 1.0 - fPercentY * fPercentY;
            fPercentXY := fPercentX + fPercentY;
            if( fPercentXY > 1.0 ) then fPercentXY := 1.0;
            if( fPercentXY < 0.0 ) then fPercentXY := 0.0;
            dwBlue := trunc ( (ddsd.ddpfPixelFormat.dwBBitMask shr dwShift) * fPercentXY ) shl dwShift;

            pDDSColor^ := dwRed or dwGreen or dwBlue;

            pDDSColor := PWORD ( Integer (pDDSColor) + sizeof (WORD));
        end;

        pDDSColor := PWORD ( DWORD (ddsd.lpSurface) + ( iY + 1 ) * ddsd.lPitch );
    end;

    Result := pDDS.Unlock(nil);
end;

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

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

end.

