{******************************************************************************}
{* Иллюстрация к книге "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 FormCanResize(Sender: TObject; var NewWidth,
      NewHeight: Integer; var Resize: Boolean);
    procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
    procedure ApplicationEvents1Deactivate(Sender: TObject);
    procedure ApplicationEvents1Restore(Sender: TObject);
  private
    { Private declarations }
    FDD            : IDirectDraw7;
    FDDSPrimary    : IDirectDrawSurface7;
    FDDSBack       : IDirectDrawSurface7;
    FDDClipper     : IDirectDrawClipper;
    FActive        : BOOL;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
    function UpdateFrame : BOOL;
    function InitSurfaces(Window : THandle) : HRESULT;
  public
    { Public declarations }
  protected
    procedure WindowMove (var Msg: TWMMove); message WM_MOVE;
  end;

var
  frmDD : TfrmDD;

  x1 : Integer = 0;
  y1 : Integer = 0;
  x2 : Integer = 40;
  y2 : Integer = 40;

  xDir : Integer = 4;
  yDir : Integer = 4;

  rcScreen    : TRECT;
  rcViewport  : TRECT;
  rcWindow    : TRECT;
  flgWindowed : BOOL = False;

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;
begin
  FDDClipper := nil;
  FDDSBack := nil;
  FDDSPrimary := nil;
  FDD := nil;

  if flgWindowed then begin
     BorderStyle := bsSizeable;
     ShowCursor(True);
     end
     else begin
     BorderStyle := bsNone;
     ShowCursor(False);
  end;

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

  if Failed(InitSurfaces(Handle)) then Close;

  FActive := True;
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned(FDD) then begin
      if Assigned(FDDSBack) then FDDSBack := nil;
      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_RETURN) and (ssAlt in Shift) then begin
     FActive := False;
     flgWindowed := not flgWindowed;
     FormCreate(nil);
  end else
  if (Key = VK_ESCAPE) or (Key = VK_F12) then Close;
end;

function TfrmDD.UpdateFrame : BOOL;
var
  ddbltfx : TDDBLTFX;
  DC : HDC;
  hOldBrush : HBrush;
  hOldPen : HPen;
begin
  ZeroMemory(@ddbltfx, SizeOf(ddbltfx));
  ddbltfx.dwSize := SizeOf(ddbltfx);
  ddbltfx.dwFillColor := 0;
  FDDSBack.Blt(nil, nil, nil, DDBLT_COLORFILL or DDBLT_WAIT, @ddbltfx);

  if FDDSBack.GetDC(DC) = DD_OK then begin
     SetBkColor(DC, RGB(0, 0, 255));
     SetTextColor(DC, RGB(255, 255, 0));
     hOldBrush := SelectObject(DC, GetStockObject(LTGRAY_BRUSH));
     hOldPen := SelectObject(DC, GetStockObject(WHITE_PEN));
     Ellipse(DC, x1, y1, x2, y2);
     SelectObject(DC, hOldPen);
     SelectObject(DC, hOldBrush);

     x1 := x1 + xDir;
     x2 := x2 + xDir;
     if x1 < 0 then begin
        x1 := 0;
        x2 := 40;
        xDir := -xDir;
     end;
     if x2 >= 640 then begin
        x1 := 640 - 1 - 40;
        x2 := 640 - 1;
        xDir := -xDir;
     end;
     y1 := y1 + yDir;
     y2 := y2 + yDir;
     if y1 < 0 then begin
        y1 := 0;
        y2 := 40;
        yDir := -yDir;
     end;
     if y2 >= 480 then begin
        y1 := 480 - 1 - 40;
        y2 := 480 - 1;
        yDir := -yDir;
     end;

     TextOut(DC, 0, 0, 'Press Escape to quit', 20);
     if flgWindowed
        then TextOut(DC, 0, 20, 'Press Alt-Enter to switch to Full-Screen mode', 45)
        else TextOut(DC, 0, 20, 'Press Alt-Enter to switch to Windowed mode', 42);

     FDDSBack.ReleaseDC(DC);
     Result := True;
  end
  else Result := False;
end;

function TfrmDD.InitSurfaces(Window : THandle) : HRESULT;
var
  hRet : HRESULT;
  ddsd : TDDSURFACEDESC2;
  ddscaps : TDDSCAPS2;
  p : TPoint;
begin
  if flgWindowed then begin
     hRet := FDD.SetCooperativeLevel(Window, DDSCL_NORMAL);
     if Failed(hRet) then begin
        Result := hRet;
        ErrorOut(hRet, 'SetCooperativeLevel');
        Exit;
     end;

     Windows.GetClientRect(Window, rcViewport);
     Windows.GetClientRect(Window, rcScreen);

     p.X := rcScreen.Left;
     p.Y := rcScreen.Top;
     Windows.ClientToScreen(Window, p);
     OffsetRect(rcScreen, p.X, p.Y);

     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, 'CreateSurface FAILED');

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

     FDDClipper.SetHWnd(0, Window);
     FDDSPrimary.SetClipper(FDDClipper);
     FDDClipper := nil;

     with ddsd do begin
          dwFlags        := DDSD_WIDTH or DDSD_HEIGHT or DDSD_CAPS;
          dwWidth        := 640;
          dwHeight       := 480;
          ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
     end;
     hRet := FDD.CreateSurface(ddsd, FDDSBack, nil);
     if Failed(hRet) then ErrorOut(hRet, 'CreateSurface2 FAILED');
  end
  else begin
     hRet := FDD.SetCooperativeLevel(Window, DDSCL_EXCLUSIVE or
                                             DDSCL_FULLSCREEN);
     if Failed(hRet) then ErrorOut(hRet, 'SetCooperativeLevel FAILED');

     hRet := FDD.SetDisplayMode(640, 480, 8, 0, 0);
     if Failed(hRet) then ErrorOut(hRet, 'SetDisplayMode FAILED');

     SetRect(rcViewport, 0, 0, 640, 480);
     CopyMemory (@rcScreen, @rcViewport, SizeOf(TRECT));

     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, 'CreateSurface FAILED');

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

procedure TfrmDD.FormCanResize(Sender: TObject; var NewWidth,
  NewHeight: Integer; var Resize: Boolean);
begin
  Resize := False;
end;

procedure TfrmDD.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);
var
  hRet : HRESULT;
begin
  if FActive then begin
     if UpdateFrame then while TRUE do begin
        if flgWindowed
            then hRet := FDDSPrimary.Blt(@rcScreen, FDDSBack,
                                         @rcViewport, DDBLT_WAIT, nil)
            else
            hRet := FDDSPrimary.Flip(nil, 0);

        if hRet = DD_OK then Break;
        if hRet = DDERR_SURFACELOST then begin
           hRet := FDDSPrimary._Restore;
           if Failed(hRet) then Break;
        end;
        if hRet <> DDERR_WASSTILLDRAWING then Break;
     end
     else FDDSPrimary._Restore;
  end;
  Done := False;
end;

procedure TfrmDD.WindowMove (var Msg: TWMMove);
var
  p : TPoint;
begin
  inherited;
  Windows.GetClientRect(Handle, rcViewport);
  Windows.GetClientRect(Handle, rcScreen);

  p.X := rcScreen.Left;
  p.Y := rcScreen.Top;
  Windows.ClientToScreen(Handle, p);
  OffsetRect(rcScreen, p.X, p.Y);
end;

procedure TfrmDD.ApplicationEvents1Deactivate(Sender: TObject);
begin
  FActive := False;
  if flgWindowed then GetWindowRect(Handle, rcWindow);
  Application.Minimize;
end;

procedure TfrmDD.ApplicationEvents1Restore(Sender: TObject);
begin
  if flgWindowed then begin
     Left := rcWindow.Left;
     Top := rcWindow.Top;
     end
     else WindowState := wsMaximized;

  FActive := True;
end;

end.

