{******************************************************************************}
{* Иллюстрация к книге "DirectX. Графика в проектах Delphi".                  *}
{* Издательство BHV. www.bhv.ru                                               *}
{* Краснов М.В. softgl@chat.ru                                                *}
{******************************************************************************}

//-----------------------------------------------------------------------------
// File: GammaControl.cpp
//
// Desc: This sample demonstrates how to use DirectDraw full-screen mode
//       using the exclusive DirectDraw cooperative level.
//
// Copyright (c) 1999-2000 Microsoft Corporation. All rights reserved.
//-----------------------------------------------------------------------------

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  AppEvnts, ExtCtrls,
  DirectDraw, DDUtil8;

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 ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
    procedure FormActivate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    g_pDisplay     : CDisplay;
    g_pTextSurface : CSurface;
    g_pGammaControl: IDIRECTDRAWGAMMACONTROL;
    FActive        : BOOL;
    ThisTickCount  : DWORD;
    LastTickCount  : DWORD;
    function RestoreSurfaces : HRESULT;
    function UpdateFrame : HRESULT;
    function UpdateGammaRamp : HRESULT;
    function DisplayFrame : HRESULT;
    function HasGammaSupport : BOOL;
    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 = 32;
  HELPTEXT = 'Press Escape to quit.';
  NUM_COLOR_BARS  = 63;

var
  frmDD : TfrmDD;
  g_lGammaRamp : LongInt = 256;
  step : Integer = -1;

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
  hr : HRESULT;
begin
  g_pGammaControl := nil;
  g_pDisplay := CDisplay.Create;
  hr := g_pDisplay.CreateFullScreenDisplay( Handle, ScreenWidth,
                                            ScreenHeight, ScreenBitDepth );

  if FAILED( hr ) then ErrorOut (hr, 'This display card does not support 640x480x8.');

  hr := g_pDisplay.CreateSurfaceFromText( g_pTextSurface, Font.Handle, HELPTEXT,
                                                      RGB(0,0,0), RGB(255, 255, 0) );
  if( FAILED( hr ) ) then ErrorOut (hr, 'CreateSurfaceFromText');

  if not HasGammaSupport then ErrorOut (DD_FALSE,
     'The primary surface does not support gamma control.');

  hr := g_pDisplay.GetFrontBuffer.QueryInterface( IID_IDirectDrawGammaControl,
                                                    g_pGammaControl );
  if( FAILED( hr ) ) then ErrorOut (hr, 'GammaControl');

  ThisTickCount := GetTickCount;
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned (g_pTextSurface) then g_pTextSurface.Free;
  if Assigned (g_pDisplay) then g_pDisplay.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 then Close;
end;

procedure TfrmDD.ApplicationEvents1Restore(Sender: TObject);
begin
  WindowState := wsMaximized;
  FActive := True;
end;

function TfrmDD.RestoreSurfaces : HRESULT;
var
  hr : HRESULT;
begin
  hr := g_pDisplay.GetDirectDraw.RestoreAllSurfaces;
  if( FAILED( hr ) ) then begin
      Result := hr;
      Exit;
  end;

  hr := g_pTextSurface.DrawText ( Font.Handle, HELPTEXT,
                                 0, 0, RGB(0,0,0), RGB(255, 255, 0));
  if( FAILED( hr ) ) then begin
      Result := hr;
      Exit;
  end;

  Result := S_OK;
end;

procedure TfrmDD.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);
begin
  if FActive then
     if Failed ( UpdateFrame ) then RestoreSurfaces;

  Done := False;
end;

procedure TfrmDD.FormActivate(Sender: TObject);
begin
  FActive := True;
end;

function TfrmDD.UpdateFrame : HRESULT;
var
  hr : HRESULT;
begin
  ThisTickCount := GetTickCount;

  if ThisTickCount - LastTickCount > 10 then begin
      g_lGammaRamp := g_lGammaRamp + step;
      if g_lGammaRamp < 0 then begin
         g_lGammaRamp := 0;
         step := - step;
         end
         else if g_lGammaRamp > 256 then begin
         g_lGammaRamp := 256;
         step := - step;
      end;

      hr := UpdateGammaRamp;

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

     LastTickCount := GetTickCount;
  end;

  hr := DisplayFrame;
  if Failed ( hr ) then begin
     Result := hr;
     Exit
  end;

  g_pDisplay.Blt( 10, 10, g_pTextSurface, nil );

  Result := g_pDisplay.Present;
end;

function TfrmDD.UpdateGammaRamp : HRESULT;
var
  hr : HRESULT;
  ddgr : TDDGAMMARAMP;
  dwGamma : WORD;
  iColor : Integer;
begin
  ZeroMemory( @ddgr, sizeof(ddgr) );

  hr := g_pGammaControl.GetGammaRamp( 0, ddgr );

  if( FAILED( hr ) ) then begin
      Result := hr;
      Exit
  end;

  dwGamma := 0;

  for iColor := 0 to 255 do begin
      ddgr.red[iColor]   := dwGamma;
      ddgr.green[iColor] := dwGamma;
      ddgr.blue[iColor]  := dwGamma;

      dwGamma := dwGamma + g_lGammaRamp;
  end;

  hr := g_pGammaControl.SetGammaRamp( 0, ddgr );
  if( FAILED( hr ) ) then begin
      Result := hr;
      Exit
  end;

  Result := S_OK;
end;

function TfrmDD.DisplayFrame : HRESULT;
var
  ddsd : TDDSURFACEDESC2;
  hr : HRESULT;
  ddbltfx : TDDBLTFX;
  rctDest : TRECT;
  dwRShift: DWORD;
  dwGShift: DWORD;
  dwBShift: DWORD;
  dwRColorLevels: DWORD;
  dwGColorLevels: DWORD;
  dwBColorLevels: DWORD;
  dwBits: DWORD;
  dwColor: DWORD;
  pFrontBuffer : IDIRECTDRAWSURFACE7;
  pBackBuffer : IDIRECTDRAWSURFACE7;
  i : DWORD;
begin
  pFrontBuffer := g_pDisplay.GetFrontBuffer;
  pBackBuffer := g_pDisplay.GetBackBuffer;

  ZeroMemory( @ddsd,sizeof(ddsd) );
  ddsd.dwSize := sizeof(ddsd);
  hr := pFrontBuffer.GetSurfaceDesc( ddsd );
  if( FAILED( hr ) ) then begin
      Result := hr;
      Exit
  end;

  g_pDisplay.Clear(0);

  g_pTextSurface.GetBitMaskInfo( ddsd.ddpfPixelFormat.dwRBitMask, dwRShift, dwBits );
  g_pTextSurface.GetBitMaskInfo( ddsd.ddpfPixelFormat.dwGBitMask, dwGShift, dwBits );
  g_pTextSurface.GetBitMaskInfo( ddsd.ddpfPixelFormat.dwBBitMask, dwBShift, dwBits );

  dwRColorLevels := ddsd.ddpfPixelFormat.dwRBitMask shr dwRShift;
  dwGColorLevels := ddsd.ddpfPixelFormat.dwGBitMask shr dwGShift;
  dwBColorLevels := ddsd.ddpfPixelFormat.dwBBitMask shr dwBShift;

  ZeroMemory( @ddbltfx, sizeof(ddbltfx) );
  ddbltfx.dwSize      := sizeof(ddbltfx);

  for i := 0 to NUM_COLOR_BARS - 1 do begin
      rctDest.left   := ScreenWidth div (NUM_COLOR_BARS + 1) * (i + 0);
      rctDest.right  := ScreenWidth div (NUM_COLOR_BARS + 1) * (i + 1);

      dwColor := dwRColorLevels * i div NUM_COLOR_BARS;
      ddbltfx.dwFillColor := dwColor shl dwRShift;

      rctDest.top    := ScreenHeight div 3 * 0;
      rctDest.bottom := ScreenHeight div 3 * 1;
      pBackBuffer.Blt( @rctDest, nil, nil,
                       DDBLT_COLORFILL or DDBLT_WAIT,
                       @ddbltfx );

      dwColor := ( dwGColorLevels * i div NUM_COLOR_BARS );
      ddbltfx.dwFillColor := dwColor shl dwGShift;

      rctDest.top    := ScreenHeight div 3 * 1;
      rctDest.bottom := ScreenHeight div 3 * 2;
      pBackBuffer.Blt( @rctDest, nil, nil,
                       DDBLT_COLORFILL or DDBLT_WAIT,
                       @ddbltfx );

      dwColor := ( dwBColorLevels * i div NUM_COLOR_BARS );
      ddbltfx.dwFillColor := dwColor shl dwBShift;

      rctDest.top    := ScreenHeight div 3 * 2;
      rctDest.bottom := ScreenHeight div 3 * 3;
      pBackBuffer.Blt( @rctDest, nil, nil,
                       DDBLT_COLORFILL or DDBLT_WAIT,
                       @ddbltfx );
  end;

  Result := S_OK;
end;

function TfrmDD.HasGammaSupport : BOOL;
var
  ddcaps : TDDCAPS;
begin
  ZeroMemory( @ddcaps, sizeof(ddcaps) );
  ddcaps.dwSize := sizeof(ddcaps);

  g_pDisplay.GetDirectDraw.GetCaps( @ddcaps, nil );
  
  if( ddcaps.dwCaps2 and DDCAPS2_PRIMARYGAMMA ) <> 0
      then Result := TRUE
      else Result := FALSE;
end;

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

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

end.

