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

interface

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

type
  TCollideInfo = record
     X, Y : Integer;
  end;

  TSprite = class
    SpriteWidth : Integer;
    SpriteHeight : Integer;
    FSpriteSurface : IDirectDrawSurface7;
    PosX, PosY : Integer;
    Collide : BOOL;
    function GetRect : TRect;
    function GetCenterX : Integer;
    function GetCenterY : Integer;
    function Show (const FDDSBack : IDirectDrawSurface7) : HRESULT;
    procedure CalcVector;
    procedure Update;
    procedure Init (const FDD : IDirectDraw7; const fileName : PChar);
    procedure Hit(const S : TSprite);
  private
    Xinc : Integer;
    Yinc : Integer;
    CollideInfo : TCollideInfo;
  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 FormActivate(Sender: TObject);
    procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    FDD            : IDirectDraw7;
    FDDSBack       : IDirectDrawSurface7;
    FDDSPrimary    : IDirectDrawSurface7;
    FDDPal         : IDirectDrawPalette;
    FActive        : BOOL;
    ThisTickCount  : DWORD;
    LastTickCount  : DWORD;
    function UpdateFrame : HRESULT;
    function FlipPages : HRESULT;
    function RestoreAll : HRESULT;
    function Clear (R, G, B : Byte) : HRESULT;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
    function SpritesCollidePixel(sprite1, sprite2 : TSprite) : BOOL;
  public
    { Public declarations }
  protected
    procedure FormSetCursor(var aMsg : TMessage); message WM_SETCURSOR;
  end;

const
  ScreenWidth    = 640;
  ScreenHeight   = 480;
  ScreenBitDepth = 8;
  NumSprites     = 10;

var
  frmDD : TfrmDD;
  spr : Array [0..NumSprites - 1] of TSprite;
  PixelFormat : TDDPixelFormat;

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 TSprite.Hit(const S : TSprite);
begin
  if not Collide then begin
     CollideInfo.X := S.GetCenterX;
     CollideInfo.Y := S.GetCenterY;
     Collide := True;
  end;
end;

function TSprite.GetCenterX : Integer;
begin
  Result := PosX + SpriteWidth div 2;
end;

function TSprite.GetCenterY : Integer;
begin
  Result := PosY + SpriteHeight div 2;
end;

procedure TSprite.Init (const FDD : IDirectDraw7; const fileName : PChar);
var
  Bitmap : TBitmap;
  hRet : HResult;
  DC : HDC;
  ddsd : TDDSurfaceDesc2;
begin
  FSpriteSurface := nil;

  Bitmap := TBitmap.Create;
  Bitmap.LoadFromFile(fileName);

  ZeroMemory(@ddsd,SizeOf(ddsd));
  with ddsd do begin
       dwSize := SizeOf(ddsd);
       dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
       ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
       dwHeight := bitmap.Height;
       dwWidth := bitmap.width;
       ddpfPixelFormat := PixelFormat;
  end;

  hRet := FDD.CreateSurface(ddsd, FSpriteSurface, nil);
  if Failed(hRet) then frmDD.ErrorOut(hRet, 'CreateSpriteSurface');

  if FSpriteSurface.GetDC(DC) = DD_OK then begin
     BitBlt(DC, 0, 0, Bitmap.Width, Bitmap.Height, Bitmap.Canvas.Handle,
            0, 0, SRCCOPY);
     FSpriteSurface.ReleaseDC(DC);
  end;

  hRet := DDSetColorKey (FSpriteSurface, RGB(255, 255, 255));
  if Failed (hRet) then frmDD.ErrorOut(hRet, 'DDSetColorKey');

  SpriteWidth := Bitmap.Width;
  SpriteHeight := Bitmap.Height;

  Bitmap.Free;

  hRet := FSpriteSurface.SetPalette(frmDD.FDDPal);
  if Failed (hRet) then frmDD.ErrorOut(hRet, 'SetPalette');

  Collide := False;

  PosX := random (500);
  PosY := random (300);

  CalcVector;
end;

function TSprite.GetRect : TRect;
begin
  SetRect (Result, PosX, PosY, PosX + SpriteWidth, PosY + SpriteHeight);
end;

procedure TSprite.CalcVector;
begin
  Xinc := random (7) - 3;
  Yinc := random (7) - 3;

  if (Xinc = 0) or (Yinc = 0) then CalcVector;
end;

procedure TSprite.Update;
var
  CenterX : Integer;
  CenterY : Integer;
  XVect : Integer;
  YVect : Integer;
begin
  if Collide then begin
     CenterX := GetCenterX;
     CenterY := GetCenterY;
     XVect := CollideInfo.X - CenterX;
     YVect := CollideInfo.Y - CenterY;
     if ((Xinc > 0) and (Xvect > 0)) or ((Xinc < 0) and (XVect < 0))
          then Xinc := -Xinc;
     if ((Yinc > 0) and (YVect > 0) or (Yinc<0) and (YVect < 0))
        then	Yinc := -Yinc;
     Collide := False;
  end;

  PosX := PosX + Xinc;
  PosY := PosY + Yinc;

  if PosX > ScreenWidth - SpriteWidth then begin
     Xinc := -Xinc;
     PosX := ScreenWidth - SpriteWidth;
     end else
     if PosX < 0 then begin
     Xinc := -Xinc;
     PosX := 0;
  end;

  if PosY > ScreenHeight - SpriteHeight then begin
     Yinc := -Yinc;
     PosY := ScreenHeight - SpriteHeight;
     end else
     if PosY < 0 then begin
     Yinc := -Yinc;
     PosY := 0;
  end;
end;

function TSprite.Show (const FDDSBack : IDirectDrawSurface7) : HRESULT;
begin
  Result := FDDSBack.BltFast (PosX, PosY, FSpriteSurface, nil, DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);
end;

procedure TfrmDD.FormCreate(Sender: TObject);
var
  hRet : HRESULT;
  ddsd : TDDSurfaceDesc2;
  ddscaps : TDDSCaps2;
  i : Integer;
begin
  FDDPal := nil;
  FDDSBack := nil;
  FDDSPrimary := nil;
  FDD := nil;

  hRet := DirectDrawCreateEx (nil, FDD, IDirectDraw7, nil);
  if Failed (hRet) then ErrorOut(hRet, 'DirectDrawCreateEx');

  hRet := FDD.SetCooperativeLevel(Handle, DDSCL_FULLSCREEN or DDSCL_EXCLUSIVE);
  if Failed (hRet) then ErrorOut(hRet, 'SetCooperativeLevel');

  hRet := FDD.SetDisplayMode (ScreenWidth, ScreenHeight, ScreenBitDepth, 0, 0);
  if Failed (hRet) then ErrorOut(hRet, 'SetDisplayMode');

  ZeroMemory(@ddsd, SizeOf(ddsd));
  with ddsd do begin
       dwSize := SizeOf(ddsd);
       dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
       ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX;
       dwBackBufferCount := 1;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSPrimary, nil);
  if Failed (hRet) then ErrorOut(hRet, 'Create Primary Surface');

  ZeroMemory(@ddscaps, SizeOf(ddscaps));
  ddscaps.dwCaps := DDSCAPS_BACKBUFFER;
  hRet := FDDSPrimary.GetAttachedSurface(ddscaps, FDDSBack);
  if Failed (hRet) then ErrorOut(hRet, 'GetAttachedSurface');

  FDDSBack._AddRef;

  FDDPal := DDLoadPalette(FDD, '1.bmp');
  if FDDPal = nil then ErrorOut(DD_FALSE, 'DDLoadPalette');

  hRet := FDDSPrimary.SetPalette(FDDPal);
  if Failed (hRet) then ErrorOut(hRet, 'SetPalette');

  ZeroMemory(@PixelFormat, SizeOf(PixelFormat));
  PixelFormat.dwSize := SizeOf(PixelFormat);
  hRet := FDDSPrimary.GetPixelFormat(PixelFormat);
  if Failed (hRet) then ErrorOut(hRet, 'GetPixelFormat');

  Randomize;

  spr [0] := TSprite.Create;
  spr [0].Init (FDD, '1.bmp');

  for i := 1 to NumSprites - 1 do begin
    spr [i] := TSprite.Create;
    spr [i].Init (FDD, '2.bmp');
  end;
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
var
  i : Integer;
begin
  if Assigned(FDD) then begin
      if Assigned(FDDPal) then FDDPal := nil;
      for i := 0 to NumSprites - 1 do begin
          if Assigned(spr [i].FSpriteSurface) then begin
             spr [i].FSpriteSurface._Release;
             spr [i].FSpriteSurface := nil;
          end;
      spr [i].Free;
      end;
      if Assigned(FDDSPrimary) then begin
         FDDSPrimary._Release;
         FDDSPrimary := nil;
      end;
      FDD._Release;
      FDD := nil;
  end;
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) or (Key = VK_F12) then Close;
end;

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

function TfrmDD.RestoreAll : HRESULT;
var
  i : Integer;
  hRet : HRESULT;
begin
  hRet := FDDSPrimary._Restore;
  if Succeeded (hRet) then begin
      FDDPal := nil;
      FDDPal := DDLoadPalette(FDD, '1.bmp');
      if FDDPal <> nil then begin
         if Failed (FDDSPrimary.SetPalette(FDDPal))
            then ErrorOut(DDERR_PALETTEBUSY, 'SetPalette');
         end
         else ErrorOut(DDERR_PALETTEBUSY, 'DDLoadPalette');
      for i := 0 to NumSprites - 1 do begin
          hRet := spr [i].FSpriteSurface._Restore;
          if Failed(hRet) then begin
             Result := hRet;
             Exit;
          end;
          if Failed (spr [i].FSpriteSurface.SetPalette(FDDPal))
            then ErrorOut(DDERR_PALETTEBUSY, 'SetPalette');

          if i = 0 then spr [i].Init (FDD, '1.bmp')
                   else spr [i].Init (FDD, '2.bmp');
      end;
      Result := DD_OK
  end else Result := hRet;
end;

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

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

procedure TfrmDD.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);
begin
  if FActive then
     if Failed (UpdateFrame) then RestoreAll;
  Done := False;
end;

function TfrmDD.UpdateFrame : HRESULT;
var
  i : Integer;
  s1, s2 : Integer;
  hRet : HRESULT;
begin
  ThisTickCount := GetTickCount;

  if ThisTickCount - LastTickCount > 10 then begin
     hRet := Clear (255, 255, 255);
     if Failed (hRet) then begin
        Result := hRet;
        Exit;
     end;

     for i := 0 to NumSprites - 1 do begin
        spr [i].Update;
        hRet := spr [i].Show (FDDSBack);
        if Failed (hRet) then begin
           Result := hRet;
           Exit;
        end;
     end;

     for s1 := 0 to NumSprites - 1 do
         for s2 := s1 + 1 to NumSprites - 1 do
	    if SpritesCollidePixel (spr [s1], spr[s2]) then begin
	       spr [s1].Hit (spr [s2]);
	       spr [s2].Hit (spr [s1]);
     end;

     FlipPages;
     LastTickCount := GetTickCount;
  end;

  Result := DD_OK;
end;

function TfrmDD.FlipPages : HRESULT;
begin
  if Failed (FDDSPrimary.Flip(nil, DDFLIP_WAIT))
     then Result := RestoreAll
     else Result := DD_OK;
end;

function TfrmDD.Clear (R, G, B : Byte) : HRESULT;
var
  ddbltfx : TDDBLTFX;
begin
  ZeroMemory(@ddbltfx, SizeOf(ddbltfx));
  ddbltfx.dwSize := SizeOf(ddbltfx);
  ddbltfx.dwFillColor := RGB (R, G, B);
  Result := FDDSBack.Blt(nil, nil, nil, DDBLT_COLORFILL or DDBLT_WAIT, @ddbltfx);
end;

function TfrmDD.SpritesCollidePixel(Sprite1, Sprite2 : TSprite) : BOOL;
var
  Rect1 : TRect;
  Rect2 : TRect;
  IRect : TRect;
  r1target : TRect;
  r2target : TRect;
  locWidth : Integer;
  locHeight : Integer;
  Desc1, Desc2 : TDDSURFACEDESC2;
  Ret : BOOL;
  Surfptr1 : POINTER;
  Surfptr2 : POINTER;
  Pixel1 : PBYTE;
  Pixel2 : PBYTE;
  XX, YY : Integer;
label
  Done;
begin
  Rect1 := Sprite1.GetRect;
  Rect2 := Sprite2.GetRect;

  IntersectRect (IRect, Rect1, Rect2);

  if (IRect.Left = 0) and (IRect.Top = 0) and
     (IRect.Right = 0) and (IRect.Bottom = 0) then begin
      Result := FALSE;
      Exit;
  end;

  IntersectRect (r1target, Rect1, IRect);

  OffsetRect(r1target, -Rect1.Left, -Rect1.Top);

  IntersectRect (r2target, Rect2, IRect);
  OffsetRect(r2target, -Rect2.Left, -Rect2.Top);

  r2target.Right := r2target.Right - 1;
  r2target.Bottom := r2target.Bottom - 1;

  locWidth := IRect.Right - IRect.Left;
  locHeight := IRect.Bottom - IRect.Top;

  ZeroMemory (@desc1, SizeOf(desc1));
  desc1.dwSize := SizeOf(desc1);

  ZeroMemory (@desc2, SizeOf(desc2));
  desc2.dwSize := SizeOf(desc2);

  Ret := False;

  Sprite1.FSpriteSurface.Lock( nil, desc1, DDLOCK_WAIT, 0 );
  Surfptr1 := desc1.lpSurface;

  Sprite2.FSpriteSurface.Lock( nil, desc2, DDLOCK_WAIT, 0 );
  Surfptr2 := desc2.lpSurface;

  for YY := 0 to locHeight - 1 do
  	for XX := 0 to locWidth - 1 do begin
        Pixel1 := PByte (Integer(Surfptr1)+(yy+r1target.Top)*desc1.lPitch
  			+(xx+r1target.Left));
  	Pixel2 := PByte (Integer(Surfptr2)+(yy+r2target.Top)*desc2.lPitch
  			+(xx+r2target.Left));
  	if (Pixel1^ <> 191) and (Pixel2^ <> 191) then begin
  		Ret := True;
  		goto Done;
  	end;
  end;

Done:
  Sprite2.FSpriteSurface.Unlock( nil );
  Sprite1.FSpriteSurface.Unlock( nil );

  Result := Ret;
end;

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

end.


