{******************************************************************************}
{* Иллюстрация к книге "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
  TfrmDD = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    Images: TImage;
    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;
    FActive        : BOOL;
    FDDPal         : IDirectDrawPalette;
    bkRect         : TRect;
    FDDSOne        : IDirectDrawSurface7;
    FDDSTwo        : IDirectDrawSurface7;
    FDDSImages     : IDirectDrawSurface7;
    function UpdateFrame : HRESULT;
    function FlipPages : HRESULT;
    function RestoreAll : HRESULT;
    procedure FDDSSpritesCreate;
    function FDDSSpritesRestore : HRESULT;
    procedure DeadMonster (const Number : Integer);
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
  public
    { Public declarations }
  protected
    procedure FormSetCursor(var aMsg : TMessage); message WM_SETCURSOR;
  end;

const
  ScreenWidth    = 640;
  ScreenHeight   = 480;
  ScreenBitDepth = 8;
  imageBack1     = '..\Bk1.bmp';
  imageBack2     = '..\Bk2.bmp';

type
  TBaseSprite = class
    PosX, PosY : Integer;
    SpriteWidth : Integer;
    SpriteHeight : Integer;
    function GetRect : TRect;
    procedure Show; virtual; abstract;
  private
    rcRect : TRect;
  end;

type
  TWarrior = class (TBaseSprite)
    Direction : (dirLeft, dirRight);
    constructor Create;
    procedure Show; override;
  end;

type
  TBullet = class (TBaseSprite)
    Delay : DWORD;
    constructor Create;
    procedure Show; override;
  private
    Xinc : Integer;
    Yinc : Integer;
    ThisTickCount : DWORD;
    LastTickCount : DWORD;
  end;

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

  TSprite = class (TBaseSprite)
    Delay : DWORD;
    AnimFrame : Integer;
    FrameCount : Integer;
    Collide : BOOL;
    Live : BOOL;
    constructor Create (const SprDelay : DWORD);
    function GetCenterX : Integer;
    function GetCenterY : Integer;
    procedure CalcVector;
    procedure Hit(S : TSprite);
    procedure Show; override;
  private
    Xinc : Integer;
    Yinc : Integer;
    CollideInfo : TCollideInfo;
    ThisTickCount : DWORD;
    LastTickCount : DWORD;
  end;

const
  DelayMonsters = 1000;
  MaxSprites    = 100;

var
  lftRect       : Integer = 0;

  Monsters : Array [0..MaxSprites - 1] of TSprite;
  Bullets : Array [0..MaxSprites - 1] of TBullet;

  Warrior : TWarrior;

  GlobalThisTickCount : DWORD;
  GlobalLastTickCount : DWORD;
  NumMonsters : Integer = 0;
  NumBullets : Integer = 0;

var
  frmDD : TfrmDD;

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.FDDSSpritesCreate;
var
  DC : HDC;
  ddsd : TDDSurfaceDesc2;
  hRet : HResult;
begin
  ZeroMemory (@ddsd, SizeOf(ddsd));
  with ddsd do begin
       dwSize := SizeOf(ddsd);
       dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;
       dwHeight := Images.Height;
       dwWidth := Images.Width;
       ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
  end;

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

  if FDDSImages.GetDC(DC) = DD_OK then begin
     BitBlt(DC, 0, 0, Images.Width, Images.Height, Images.Canvas.Handle,
            0, 0, SRCCOPY);
     FDDSImages.ReleaseDC(DC);
  end;
  DDSetColorKey (FDDSImages, RGB(0, 255, 0));

  FDDSImages.SetPalette(frmDD.FDDPal);
end;

function TfrmDD.FDDSSpritesRestore : HRESULT;
var
  DC : HDC;
  hRet : HResult;
begin
  hRet := FDDSImages._Restore;
  if Failed (hRet) then begin
     Result := hRet;
     Exit
  end;

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

  Result := FDDSImages.SetPalette(frmDD.FDDPal);
end;

procedure TSprite.Hit(S : TSprite);
begin
  if not Collide then begin
     CollideInfo.X := S.GetCenterX;
     CollideInfo.Y := S.GetCenterY;
     Collide := True;
  end;
end;

constructor TSprite.Create (const SprDelay : DWORD);
begin
  Delay := SprDelay;

  if random > 0.5 then begin
     FrameCount := 4;
     AnimFrame := random (FrameCount);
     SpriteHeight := 22;
     SpriteWidth := 124 div 4;
     SetRect (rcRect, AnimFrame * SpriteWidth, 0,
              AnimFrame * SpriteWidth + SpriteWidth, SpriteHeight);
     end
     else begin
     FrameCount := 6;
     AnimFrame := random (FrameCount);
     SpriteHeight := 14;
     SpriteWidth := 78 div 6;
     SetRect (rcRect, AnimFrame * SpriteWidth, 22,
              AnimFrame * SpriteWidth + SpriteWidth, 22 + SpriteHeight);
  end;

  Collide := False;

  PosX := random (1280 - SpriteWidth);
  PosY := random (420 - SpriteHeight);

  CalcVector;

  Live := True;
  LastTickCount := GetTickCount;
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.Show;
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 > 1280 - SpriteWidth then begin
  	Xinc := -Xinc;
  	PosX := 1280 - SpriteWidth;
          end
          else if PosX < 0 then begin
  	Xinc := -Xinc;
  	PosX := 0;
  end;

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

  ThisTickCount := GetTickCount;
  if ThisTickCount - LastTickCount > Delay then begin
     SetRect (rcRect, AnimFrame * SpriteWidth, rcRect.Top,
              AnimFrame * SpriteWidth + SpriteWidth, rcRect.Top + SpriteHeight);
     LastTickCount := ThisTickCount;
     AnimFrame := (AnimFrame + 1) mod FrameCount;
  end;

  if (PosX > lftRect) and (PosX < 640 + lftRect) then
  frmDD.FDDSBack.BltFast(PosX - lftRect, PosY, frmDD.FDDSImages, @rcRect,
                         DDBLTFAST_DONOTWAIT or DDBLTFAST_SRCCOLORKEY);
end;

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

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

function SpritesCollidePixel(Sprite1, Sprite2 : TBaseSprite) : BOOL;
var
  Rect1 : TRect;
  Rect2 : TRect;
  IRect : TRect;
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;

  Result := True;
end;

constructor TWarrior.Create;
begin
  SpriteHeight := 29;
  SpriteWidth := 26;

  PosX := 320;
  PosY := 382;

  Direction := dirRight;
end;

procedure TWarrior.Show;
begin
  if Direction = dirRight
     then SetRect (rcRect, 0, 70, SpriteWidth, 70 + SpriteHeight)
     else SetRect (rcRect, SpriteWidth, 70, 2 * SpriteWidth, 70 + SpriteHeight);
  frmDD.FDDSBack.BltFast(PosX, PosY, frmDD.FDDSImages, @rcRect,
                         DDBLTFAST_DONOTWAIT or DDBLTFAST_SRCCOLORKEY);
end;

constructor TBullet.Create;
begin
  SpriteHeight := 8;
  SpriteWidth := 8;

  SetRect (rcRect, 0, 62, SpriteWidth, 62 + SpriteHeight);

  Delay := 2;
  PosX := 400;
  PosY := 400;
  Xinc := 0;
  Yinc := 0;
  LastTickCount := GetTickCount;
end;

procedure TBullet.Show;
begin
  ThisTickCount := GetTickCount;
  if ThisTickCount - LastTickCount > Delay then begin
     PosX := PosX + Xinc;
     PosY := PosY + Yinc;
     LastTickCount := ThisTickCount;
  end;
  frmDD.FDDSBack.BltFast(PosX - lftRect - (SpriteWidth div 2), PosY, frmDD.FDDSImages, @rcRect,
                   DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);
end;

procedure UpdateBul;
var
  wrkI, wrkJ : Integer;
begin
  for wrkI := 0 to NumBullets - 2 do
     if (Bullets [wrkI].PosX > 640 + lftRect) or (Bullets [wrkI].PosX < 0) or
        (Bullets [wrkI].PosY < 0) then begin
     for wrkJ := wrkI to NumBullets - 1 do
     with Bullets [wrkJ] do begin
       PosX := Bullets [wrkJ + 1].PosX;
       PosY := Bullets [wrkJ + 1].PosY;
       Xinc := Bullets [wrkJ + 1].Xinc;
       Yinc := Bullets [wrkJ + 1].Yinc;
     end;
     NumBullets := NumBullets - 1;
  end;
end;

procedure TfrmDD.DeadMonster (const Number : Integer);
begin
  with Monsters[Number] do begin
       SpriteHeight := 25;
       SpriteWidth := 25;
       FrameCount := 4;
       AnimFrame := random (FrameCount);
       Xinc := 0;
       Yinc := 0;
       SetRect (rcRect, AnimFrame * SpriteWidth, 37,
                AnimFrame * SpriteWidth + SpriteWidth, 62);
       Live := False;
  end;
end;

procedure TfrmDD.FormCreate(Sender: TObject);
var
  hRet : HRESULT;
  ddsd : TDDSurfaceDesc2;
  ddscaps : TDDSCaps2;
  wrki : Integer;
begin
  FDDPal := nil;
  FDDSImages := nil;
  FDDSOne := nil;
  FDDSTwo := 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, imageBack1);
  if FDDPal = nil then ErrorOut(hRet, 'DDLoadPalette');

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

  FDDSOne := DDLoadBitmap(FDD, imageBack1, 0, 0);
  if FDDSOne = nil then ErrorOut(hRet, 'DDLoadBitmap');

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

  FDDSTwo := DDLoadBitmap(FDD, imageBack2, 0, 0);
  if FDDSTwo = nil then ErrorOut(hRet, 'DDLoadBitmap');

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

  SetRect(bkRect, 0, 0, ScreenWidth, ScreenHeight);

  FDDSPrimary.BltFast(0, 0, FDDSOne, @bkRect, DDBLTFAST_WAIT);

  Randomize;

  FDDSSpritesCreate;

  Warrior := TWarrior.Create;

  for wrkI := Low (Monsters) to High (Monsters) do
      Monsters [wrkI] := TSprite.Create (40 + random (40));

  for wrkI := Low (Bullets) to High (Bullets) do
      Bullets [wrkI] := TBullet.Create;
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
var
  wrkI : Integer;
begin
  if Assigned(FDD) then begin
      if Assigned(FDDSPrimary) then begin
         if Assigned(FDDPal) then begin
            FDDPal._Release;
            FDDPal := nil;
         end;
         if Assigned(FDDSImages) then begin
            FDDSImages._Release;
            FDDSImages := nil;
         end;
         if Assigned(FDDSOne) then begin
            FDDSOne._Release;
            FDDSOne := nil;
         end;
         if Assigned(FDDSTwo) then begin
            FDDSTwo._Release;
            FDDSTwo := nil;
         end;
         FDDSPrimary._Release;
         FDDSPrimary := nil;
      end;
      FDD._Release;
      FDD := nil;
  end;
  for wrkI := Low (Monsters) to High (Monsters) do
     if Assigned (Monsters [wrkI]) then Monsters [wrkI].Free;
  if Assigned (Warrior) then Warrior.Free;
  for wrkI := Low (Bullets) to High (Bullets) do
     if Assigned (Bullets [wrkI]) then Bullets [wrkI].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) or (Key = VK_F12) then begin
     Close;
     Exit;
  end else
  if Key = VK_LEFT then begin
     Warrior.Direction := dirLeft;
     Warrior.PosX := Warrior.PosX - 2;
     if Warrior.PosX < 0 then begin
     Warrior.PosX := 0;
     lftRect := lftRect - 2;
     if lftRect < 0 then lftRect := 0;
     end
     end else
  if Key = VK_RIGHT then begin
     Warrior.Direction := dirRight;
     Warrior.PosX := Warrior.PosX + 2;
     if Warrior.PosX > 640 - Warrior.SpriteWidth
        then begin
        Warrior.PosX := 640 - Warrior.SpriteWidth;
        lftRect := lftRect + 2;
        if lftRect > 640 then lftRect := 640;
     end
     end else
  if Key = VK_SPACE then begin
     NumBullets := NumBullets + 1;
     if NumBullets < High (Bullets) then begin
        if Warrior.Direction = dirRight then begin
                   Bullets [NumBullets - 1].PosX := Warrior.PosX + Warrior.SpriteWidth + lftRect;
                   Bullets [NumBullets - 1].PosY := 400;
                   Bullets [NumBullets - 1].Xinc := 2;
                   Bullets [NumBullets - 1].Yinc := 0;
                   end
                   else begin
                   Bullets [NumBullets - 1].PosX := Warrior.PosX + lftRect;
                   Bullets [NumBullets - 1].PosY := 400;
                   Bullets [NumBullets - 1].Xinc := -2;
                   Bullets [NumBullets - 1].Yinc := 0;
           end
        end
        else NumBullets := NumBullets - 1;
     end else
  if Key = VK_UP then begin
        NumBullets := NumBullets + 1;
        if NumBullets < High (Bullets) then begin
                      Bullets [NumBullets - 1].Xinc := 0;
                      Bullets [NumBullets - 1].Yinc := -2;
                      Bullets [NumBullets - 1].PosY := 400;
           if Warrior.Direction = dirRight
              then Bullets [NumBullets - 1].PosX := Warrior.PosX + Warrior.SpriteWidth + lftRect
              else Bullets [NumBullets - 1].PosX := Warrior.PosX + lftRect;
        end
        else NumBullets := NumBullets - 1;
  end;
end;

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

function TfrmDD.RestoreAll : HRESULT;
var
  hRet : HRESULT;
begin
  hRet := FDDSPrimary._Restore;
  if Succeeded (hRet) then begin
      FDDPal := nil;
      FDDPal := DDLoadPalette(FDD, imageBack1);
      if Assigned (FDDPal) then begin
         hRet := FDDSPrimary.SetPalette(FDDPal);
         if Failed (hRet) then begin
            Result := hRet;
            Exit
         end;
      end;
      hRet := FDDSOne._Restore;
      if Failed (hRet) then begin
        Result := hRet;
        Exit
      end;
      hRet := DDReLoadBitmap(FDDSOne, imageBack1);
      if Failed (hRet) then ErrorOut(hRet, 'DDReLoadBitmap');
      FDDSPrimary.BltFast(0, 0, FDDSOne, @bkRect, DDBLTFAST_WAIT);
      hRet := FDDSTwo._Restore;
      if Failed (hRet) then begin
        Result := hRet;
        Exit
      end;
      hRet := DDReLoadBitmap(FDDSTwo, imageBack2);
      if Failed (hRet) then ErrorOut(hRet, 'DDReLoadBitmap');
      hRet := FDDSSpritesRestore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit
      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
  FActive := True;
end;

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

function TfrmDD.UpdateFrame : HRESULT;
var
  wrkI, s1, s2 : Integer;
  rcRectOne : TRect;
  rcRectTwo : TRect;
begin
  GlobalThisTickCount := GetTickCount;

  SetRect(rcRectOne, lftRect, 0, ScreenWidth, ScreenHeight);
  FDDSBack.BltFast(0, 0, FDDSOne, @rcRectOne, DDBLTFAST_WAIT);
  if lftRect > 0 then begin
     SetRect(rcRectTwo, 0, 0, lftRect, ScreenHeight);
     FDDSBack.BltFast(ScreenWidth - lftRect, 0, FDDSTwo, @rcRectTwo, DDBLTFAST_WAIT);
  end;

  if (GlobalThisTickCount - GlobalLastTickCount > DelayMonsters)
         and (NumMonsters < High (Monsters) - 1) then begin
         Inc (NumMonsters);
         GlobalLastTickCount := GlobalThisTickCount;
  end;

  for wrkI := 0 to NumMonsters - 1 do Monsters [wrkI].Show;

  Warrior.Show;

  UpdateBul;

  for wrkI := 0 to NumBullets - 1 do Bullets [wrkI].Show;

  for s1 := 0 to NumMonsters - 1 do
      for s2 := 0 to NumBullets - 1 do
	  if Monsters [s1].Live and (Monsters [s1].PosX > lftRect)
          and (Monsters [s1].PosX < 640 + lftRect) and
          SpritesCollidePixel (Monsters [s1], Bullets [s2]) then begin
             Bullets [s2].PosY := -10;
             DeadMonster (s1);
  end;

  for s1 := 0 to NumMonsters - 2 do
      for s2 := s1 + 1 to NumMonsters - 1 do
	  if Monsters [s1].Live and Monsters [s2].Live and
             SpritesCollidePixel (Monsters [s1], Monsters[s2]) then begin
	     Monsters [s1].Hit(Monsters [s2]);
	     Monsters [s2].Hit(Monsters [s1]);
  end;

  Result := DD_OK;
end;

function TfrmDD.FlipPages : HRESULT;
var
  hRet : HRESULT;
begin
  hRet := DD_OK;
  while TRUE do begin
     hRet := FDDSPrimary.Flip(nil, 0);
     if hRet = DD_OK then Break;
     if hRet = DDERR_SURFACELOST then begin
        hRet := RestoreAll;
        if Failed (hRet) then Break;
     end;
     if hRet <> DDERR_WASSTILLDRAWING then Break;
  end;
  Result := hRet;
end;

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

end.

