{******************************************************************************}
{* Иллюстрация к книге "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);
  private
    { Private declarations }
    FDD            : IDirectDraw7;
    FDDSPrimary    : IDirectDrawSurface7;
    FDDSFont       : IDirectDrawSurface7;
    FDDSGround     : IDirectDrawSurface7;
    FDDSWork       : IDirectDrawSurface7;    
    ThisTickCount  : DWORD;
    LastTickCount  : DWORD;
    procedure GeneratePos;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
  public
    { Public declarations }
  end;

const
  imageBmp      = '..\font.bmp';
  NumbLines = 70;

var
  frmDD : TfrmDD;
  OutLiteral : String;
  StrList : Array [0..NumbLines - 1] of String;
  WinWidth, PosX  : Integer;
  WinHeight, PosY : Integer;
  tmpRect : TRECT;

const
  FileName = 'dictionary.txt';
  Delay = 50;

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;
  t : TextFile;
  i, maxLength : Integer;
begin
  FDDSWork := nil;
  FDDSGround := nil;
  FDDSFont := 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');

  FDDSFont := DDLoadBitmap(FDD, imageBmp, 0, 0);
  if FDDSFont = nil then ErrorOut(hRet, 'DDLoadBitmap');

  WinWidth  := GetSystemMetrics(SM_CXSCREEN);
  WinHeight := GetSystemMetrics(SM_CYSCREEN);

  ZeroMemory(@ddsd, SizeOf(ddsd));
  with ddsd do begin
       dwSize := SizeOf(ddsd);
       dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;
       ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
       dwWidth := WinWidth;
       dwHeight := WinHeight;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSGround, nil);
  if Failed (hRet) then ErrorOut(hRet, 'CreateSurface');

  AssignFile (t, FileName);
  Reset (t);
  maxLength := 0;
  for i := 0 to NumbLines - 1 do begin
      ReadLn (t, StrList [i]);
      if length (StrList [i]) > maxLength then maxLength := length (StrList [i]);
  end;
  CloseFile (t);

  ZeroMemory(@ddsd, SizeOf(ddsd));
  with ddsd do begin
       dwSize := SizeOf(ddsd);
       dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;
       ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
       dwWidth := maxLength * 15;
       dwHeight := 15;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSWork, nil);
  if Failed (hRet) then ErrorOut(hRet, 'CreateSurface');

  Randomize;

  OutLiteral := StrList [random (NumbLines)];

  GeneratePos;

  LastTickCount := GetTickCount;
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned(FDD) then begin
      if Assigned(FDDSWork) then begin
         FDDSWork._Release;
         FDDSWork := nil;
      end;
      if Assigned(FDDSGround) then begin
         FDDSGround._Release;
         FDDSGround := nil;
      end;
      if Assigned(FDDSFont) then begin
         FDDSFont._Release;
         FDDSFont := nil;
      end;
      if Assigned(FDDSPrimary) then begin
         FDDSPrimary._Release;
         FDDSPrimary := nil;
      end;
      FDD._Release;  
      FDD := nil;
  end;
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.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);
var
  rcRect : TRECT;
  i, X, Y : Integer;
procedure OutChar (ch : Char; PosX : Integer);
var
  chRect : TRECT;
  wrkI : integer;
begin
  wrkI := ord (ch) - 32;
  chRect.Left := wrkI mod 16 * 15;
  chRect.Top := wrkI div 16 * 15;
  chRect.Right := chRect.Left + 15;
  chRect.Bottom := chRect.Top + 15;

  FDDSWork.BltFast(PosX, 0, FDDSFont, @chRect, DDBLTFAST_DONOTWAIT);
end;

begin
  ThisTickCount := GetTickCount;

  Done := False;

  if (ThisTickCount - LastTickCount) < Delay then Exit;

  SetRect (rcRect, PosX, PosY, PosX + length (OutLiteral) * 15, PosY + 15);
  FDDSGround.BltFast(PosX, PosY, FDDSPrimary, @rcRect, DDBLTFAST_WAIT);
  FDDSPrimary.BltFast(PosX, PosY, FDDSWork, @tmpRect, DDBLTFAST_WAIT);

  X := PosX;
  Y := PosY;

  OutLiteral := StrList [random (NumbLines)];

  GeneratePos;

  for i := 1 to length (OutLiteral) do
      OutChar (OutLiteral [i], (i - 1) * 15);

  SetRect (tmpRect, 0, 0, length (OutLiteral) * 15, 15);

  FDDSPrimary.BltFast(X, Y, FDDSGround, @rcRect, DDBLTFAST_WAIT);

  LastTickCount := GetTickCount;
end;

procedure TfrmDD.GeneratePos;
begin
  PosX := random (WinWidth - Length (OutLiteral) * 15);
  PosY := random (WinHeight - 15);
end;

end.

