{******************************************************************************}
{* Иллюстрация к книге "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
  TWordArray = Array [0..255, 0..255] of Word;

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;
    FDDSPrimary    : IDirectDrawSurface7;
    FDDSImage      : IDirectDrawSurface7;
    FDDSBackGround : IDirectDrawSurface7;
    FDDSBack       : IDirectDrawSurface7;
    FActive        : BOOL;
    ThisTickCount  : DWORD;
    LastTickCount  : DWORD;
    function Rotating : HRESULT;
    function UpdateFrame : HRESULT;
    function RestoreAll : HRESULT;
    function Prepare : HRESULT;
    function Rotate (const pictOriginal : TWordArray) : TWordArray;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
  public
    { Public declarations }
  end;

const
  ScreenWidth    = 640;
  ScreenHeight   = 480;
  ScreenBitDepth = 16;
  imageBmp       = '..\DEATH.BMP';

var
  frmDD : TfrmDD;
  Pict : TWordArray;

implementation

{$R *.DFM}

var
  Angle : Single = 0;

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;
  ddscaps : TDDSCaps2;
begin
  wrkBitmap := TBitMap.Create;
  wrkBitmap.Height := 480;
  wrkBitmap.Width := 640;
  BitBlt(wrkBitmap.Canvas.Handle, 0, 0, 640, 480, GetDC (GetDesktopWindow), 0, 0, SRCCOPY);

  FDDSBackGround  := nil;
  FDDSImage := 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');

  FDDSImage := DDLoadBitmap(FDD, imageBmp, 0, 0);
  if FDDSImage = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');

  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  := 640;
     dwHeight := 480;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSBackGround , nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create Back Surface');

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

  wrkBitmap.Free;

  if Failed (Prepare) then Close;

  if Assigned(FDDSImage) then FDDSImage := nil;
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned(FDD) then begin
      if Assigned(FDDSBackGround) then FDDSBackGround  := nil;
      if Assigned(FDDSBack) then FDDSBack := nil;
      if Assigned(FDDSPrimary) then FDDSPrimary := nil;
      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
  Close;
end;

function TfrmDD.RestoreAll : HRESULT;
begin
  Result := FDDSPrimary._Restore;
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
  hRet : HRESULT;
begin
  ThisTickCount := GetTickCount;

  if ThisTickCount - LastTickCount > 10 then begin
     hRet := FDDSBack.BltFast (0, 0, FDDSBackGround, nil, DDBLTFAST_WAIT);
     if Failed (hRet) then begin
        Result := hRet;
        Exit;
     end;

     hRet := Rotating;
     if Failed (hRet) then begin
        Result := hRet;
        Exit;
     end;

     hRet := FDDSPrimary.Flip(nil, DDFLIP_WAIT);
     if Failed (hRet) then begin
        Result := hRet;
        Exit;
     end;

     LastTickCount := GetTickCount;
  end;

  Result := DD_OK;
end;

function TfrmDD.Rotating : HRESULT;
var
  desc : TDDSURFACEDESC2;
  Image : TWordArray;
  hRet : HRESULT;
function Blend (const X, Y : Integer) : HRESULT;
const
  ALPHA = 127;
var
  i, j : Integer;
  wrkPointer : PWord;
  sTemp, dTemp : Word;
  sb, db, sg, dg, sr, dr : Byte;
  blue, green, red : Byte;
begin
  for i := 0 to 255 do
      for j := 0 to 255 do
       if Image [i, j] <> 0 then begin
       wrkPointer := PWORD (Integer(desc.lpSurface) + (Y + j) * desc.lPitch +
                     (X + i) * (ScreenBitDepth div 8));
       sTemp := Image [i, j];
       dTemp := wrkPointer^;

       sb := sTemp and $1f;
       db := dTemp and $1f;
       sg := (sTemp shr 5)  and $3f;
       dg := (dTemp shr 5)  and $3f;
       sr := (sTemp shr 11) and $1f;
       dr := (dTemp shr 11) and $1f;
       blue  := (ALPHA * (sb - db) shr 8) + db;
       green := (ALPHA * (sg - dg) shr 8) + dg;
       red   := (ALPHA * (sr - dr) shr 8) + dr;
       wrkPointer^ := blue or (green shl 5) or (red shl 11);
  end;

  Result := DD_OK;
end;
begin
  ZeroMemory (@desc, SizeOf(desc));
  desc.dwSize := SizeOf(desc);

  Image := Rotate (Pict);

  hRet := FDDSBack.Lock (nil, desc, DDLOCK_WAIT, 0);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  Blend (193, 113);

  Result := FDDSBack.Unlock (nil);
end;

function TfrmDD.Prepare : HRESULT;
var
  desc : TDDSURFACEDESC2;
  i, j : Integer;
  hRet : HRESULT;
begin
  ZeroMemory (@desc, SizeOf(desc));
  desc.dwSize := SizeOf(desc);

  hRet := FDDSImage.Lock (nil, desc, DDLOCK_WAIT, 0);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  for i := 0 to 255 do
      for j := 0 to 255 do
       Pict [i, j] := PWord (Integer (desc.lpSurface) +
                             j * desc.lPitch + 2 * i)^;

  Result := FDDSImage.Unlock (nil);
end;

function TfrmDD.Rotate (const pictOriginal : TWordArray) : TWordArray;
var
  i, j, k : Integer;
begin
  ZeroMemory (@Result, SizeOf (Result));

  for j := 0 to 255 do
    for i := 0 to 255 do begin
        k := trunc (sin (Angle + j * 3 * Pi / 255) * 10);
        if (i - k >= 0) and (i - k <= 255) then
        Result [i, j] := pictOriginal [i - k, j];
  end;

  Angle := Angle + 0.2;
  if Angle > 2 * Pi then Angle := Angle - 2 * Pi;
end;

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

end.

