{******************************************************************************}
{* Иллюстрация к книге "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;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
    procedure ApplicationEvents1Minimize(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
    FDD            : IDirectDraw7;
    FDDSPrimary    : IDirectDrawSurface7;
    FDDSBack       : IDirectDrawSurface7;
    FDDClipper     : IDirectDrawClipper;
    FDDSTiger      : IDirectDrawSurface7;
    FDDSTree       : IDirectDrawSurface7;
    FDDSEarth      : IDirectDrawSurface7;
    FDDSBackGround : IDirectDrawSurface7;
    FDDSActive     : BOOL;
    ThisTickCount  : DWORD;
    LastTickCount  : DWORD;
    function RestoreAll : HRESULT;
    procedure UpdateFrame;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
    function InitImages : HRESULT;
  public
    { Public declarations }
  end;

var
  frmDD : TfrmDD;
  LastTickCountTiger : DWORD;
  LastTickCountEarth : DWORD;
  CurFrameTiger : Integer = 0;
  CurFrameEarth : Integer = 0;
  LeftTree : Integer = 0;
  rcTiger : TRECT;
  rcEarth : TRECT;
  SpeedTrees : Integer = 5;
  DelayTiger : DWORD = 50;
  DelayEarth : DWORD = 30;
  PixelFormat : TDDPixelFormat;

const
  BackBitmap = 'Stars.bmp';
  EarthBitmap = 'Earth.bmp';
  TigerBitmap = 'Tiger.bmp';
  TreesBitmap = 'Trees.bmp';
  TreesWidth = 320;
  TreesHeight = 118;
  TigerWidth = 240;
  TigerHeight = 96;

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
  hRet : HRESULT;
  ddsd : TDDSurfaceDesc2;
  wrkBitMap : TBitmap;
begin
  FDDSBack := nil;
  FDDSTiger := nil;
  FDDSTree  := nil;
  FDDSEarth := nil;
  FDDSBackGround := nil;
  FDDClipper := nil;
  FDDSPrimary := nil;
  FDD := nil;

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

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

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

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

  hRet := FDD.CreateClipper(0, FDDClipper, nil);
  if Failed (hRet) then ErrorOut(hRet, 'CreateClipper FAILED');

  hRet := FDDClipper.SetHWnd(0, Handle);
  if Failed (hRet) then ErrorOut(hRet, 'SetHWnd FAILED');

  hRet := FDDSPrimary.SetClipper(FDDClipper);
  if Failed (hRet) then ErrorOut(hRet, 'SetClipper FAILED');

  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;
     ddpfPixelFormat := PixelFormat;
     dwWidth  := ClientWidth;
     dwHeight := ClientHeight;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSBack, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create Back Surface');

  wrkBitMap := TBitmap.Create;
  wrkBitMap.LoadFromFile(TigerBitmap);

  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;
    dwWidth  := wrkBitMap.Width;
    dwHeight := wrkBitMap.Height;
    ddpfPixelFormat := PixelFormat;
  end;

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

  hRet := DDCopyBitmap (FDDSTiger, wrkBitMap.Handle, 0, 0, wrkBitMap.Width, wrkBitMap.Height);
  if Failed (hRet) then ErrorOut(hRet, 'DDCopyBitmap');

  hRet := DDSetColorKey (FDDSTiger, RGB(166, 202, 240));
  if Failed (hRet) then ErrorOut(hRet, 'DDSetColorKey');

  wrkBitMap.LoadFromFile(TreesBitmap);

  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;
    dwWidth  := wrkBitMap.Width;
    dwHeight := wrkBitMap.Height;
    ddpfPixelFormat := PixelFormat;
  end;

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

  hRet := DDCopyBitmap (FDDSTree, wrkBitMap.Handle, 0, 0, wrkBitMap.Width, wrkBitMap.Height);
  if Failed (hRet) then ErrorOut(hRet, 'DDCopyBitmap');

  hRet := DDSetColorKey (FDDSTree, RGB(166, 202, 240));
  if Failed (hRet) then ErrorOut(hRet, 'DDSetColorKey');

  wrkBitMap.LoadFromFile(BackBitmap);

  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;
    dwWidth  := wrkBitMap.Width;
    dwHeight := wrkBitMap.Height;
    ddpfPixelFormat := PixelFormat;
  end;

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

  hRet := DDCopyBitmap (FDDSBackGround, wrkBitMap.Handle, 0, 0, wrkBitMap.Width, wrkBitMap.Height);
  if Failed (hRet) then ErrorOut(hRet, 'DDCopyBitmap');

  wrkBitMap.Free;

  FDDSEarth := DDLoadBitmap(FDD, EarthBitmap, 0, 0);
  if FDDSEarth = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');

  hRet := DDSetColorKey (FDDSEarth, RGB(166, 202, 240));
  if Failed (hRet) then ErrorOut(hRet, 'DDSetColorKey');

  rcTiger.Left := 0;
  rcTiger.Right := TigerWidth;

  ThisTickCount := GetTickCount;
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned(FDD) then begin
      if Assigned(FDDClipper) then begin
         FDDClipper._Release;
         FDDClipper := nil;
      end;
      if Assigned(FDDSTiger) then begin
         FDDSTiger._Release;
         FDDSTiger := nil;
      end;
      if Assigned(FDDSTree) then begin
         FDDSTree._Release;
         FDDSTree := nil;
      end;
      if Assigned(FDDSEarth) then begin
         FDDSEarth._Release;
         FDDSEarth := nil;
      end;
      if Assigned(FDDSBackGround) then begin
         FDDSBackGround._Release;
         FDDSBackGround := nil;
      end;
      if Assigned(FDDSBack) then begin
         FDDSBack._Release;
         FDDSBack := nil;
      end;
      if Assigned(FDDSPrimary) then FDDSPrimary := nil;
      FDD := nil;
  end;
  ShowCursor (True);
end;

procedure TfrmDD.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = VK_ESCAPE) or (Key = VK_F12) then Close else
  if Key = Ord ('S') then begin
     SpeedTrees := SpeedTrees + 1;
     if SpeedTrees > 100 then SpeedTrees := 100;
  end else
  if Key = Ord ('T') then begin
     DelayTiger := DelayTiger - 2;
     if DelayTiger < 5 then DelayTiger := 5;
  end else
  if Key = Ord ('E') then begin
     DelayEarth := DelayEarth - 2;
     if DelayEarth < 5 then DelayEarth := 5;
  end else
  if Key = Ord ('R') then begin
     DelayEarth := 30;
     SpeedTrees := 5;
     DelayTiger := 50;
  end;
end;

function TfrmDD.RestoreAll : HRESULT;
var
  hRet : HRESULT;
begin
  hRet := FDDSPrimary._Restore;
  if Succeeded (hRet) then begin
      hRet := FDDSBack._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := FDDSTiger._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := FDDSTree._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := FDDSEarth._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := FDDSBackGround._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      Result := InitImages;
  end else Result := hRet;
end;

procedure TfrmDD.UpdateFrame;
var
  rcDest, wrkRect : TRECT;
  p : TPOINT;
  rcTree : TRECT;
begin
  p.X := 0;
  p.Y := 0;
  Windows.ClientToScreen(Handle, p);
  Windows.GetClientRect(Handle, rcDest);
  OffsetRect(rcDest, p.X, p.Y);
  SetRect (wrkRect, 0, 0, ClientWidth, ClientHeight);

  FDDSBack.BltFast (0, 0, FDDSBackGround,
                    @wrkRect, DDBLTFAST_WAIT);

  SetRect(rcTree, LeftTree, 0, TreesWidth, TreesHeight);

  FDDSBack.BltFast (0, ClientHeight - TreesHeight,
                    FDDSTree,
                    @rcTree,
                    DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);

  SetRect(rcTree, 0, 0, LeftTree, TreesHeight);

  FDDSBack.BltFast (ClientWidth - LeftTree,
                    ClientHeight - TreesHeight,
                    FDDSTree,
                    @rcTree,
                    DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);

  LeftTree := (LeftTree + SpeedTrees) mod ClientWidth;

  if ThisTickCount - LastTickCountTiger > DelayTiger then begin
     CurFrameTiger := (CurFrameTiger + 1) mod 7;
     rcTiger.Top := CurFrameTiger * TigerHeight;
     rcTiger.Bottom := (CurFrameTiger + 1) * TigerHeight;
     LastTickCountTiger := GetTickCount;
  end;

  FDDSBack.BltFast (40, 190,
                    FDDSTiger,
                    @rcTiger, DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);

  if ThisTickCount - LastTickCountEarth > DelayEarth then begin
     rcEarth.Left := (CurFrameEarth mod 6) * 64;
     rcEarth.Right := (CurFrameEarth mod 6 + 1) * 64;
     rcEarth.Top := CurFrameEarth div 6 * 56;
     rcEarth.Bottom := CurFrameEarth div 6 * 56 + 56;
     CurFrameEarth := (CurFrameEarth + 1) mod 36;
     LastTickCountEarth := GetTickCount;
  end;

  FDDSBack.BltFast (40, 40,
                    FDDSEarth,
                    @rcEarth,
                    DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);

  if Failed (FDDSPrimary.Blt (@rcDest, FDDSBack, @wrkRect, DDBLT_WAIT, nil))
     then while Failed (RestoreAll) do;
end;

procedure TfrmDD.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);
begin
  if FDDSActive then begin
  ThisTickCount := GetTickCount;
  if ThisTickCount - LastTickCount > 10 then begin
     UpdateFrame;
     LastTickCount := GetTickCount;
  end;
  end;
  Done := False;
end;

procedure TfrmDD.ApplicationEvents1Minimize(Sender: TObject);
begin
  FDDSActive := False;
end;

procedure TfrmDD.FormShow(Sender: TObject);
begin
  FDDSActive := True;
end;

function TfrmDD.InitImages : HRESULT;
var
  wrkBitMap : TBitmap;
  hRet : HRESULT;
begin
  wrkBitMap := TBitmap.Create;
  wrkBitMap.LoadFromFile(TigerBitmap);

  hRet := DDCopyBitmap (FDDSTiger, wrkBitMap.Handle, 0, 0, wrkBitMap.Width, wrkBitMap.Height);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  wrkBitMap.LoadFromFile(TreesBitmap);

  hRet := DDCopyBitmap (FDDSTree, wrkBitMap.Handle, 0, 0, wrkBitMap.Width, wrkBitMap.Height);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  wrkBitMap.LoadFromFile(BackBitmap);

  hRet := DDCopyBitmap (FDDSBackGround, wrkBitMap.Handle, 0, 0, wrkBitMap.Width, wrkBitMap.Height);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  wrkBitMap.LoadFromFile(EarthBitmap);

  Result := DDCopyBitmap (FDDSEarth, wrkBitMap.Handle, 0, 0, wrkBitMap.Width, wrkBitMap.Height);

  wrkBitMap.Free;
end;

end.

