unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  DDirectDraw, DDraw, ExtCtrls;

type         
  TForm1 = class(TForm)
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormPaint(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    DD: TDirectDraw;
    DDSPrimary, DDSBack: TDirectDrawSurface;
    Phase: Byte;

    procedure finiObjects;
    procedure doInit;
  public
  end;
                
const
  szMsg = 'Page Flipping Test: Press F10 to exit';
  szFrontMsg = 'Front buffer (F10 to quit)';
  szBackMsg = 'Back buffer (F10 to quit)';
  TIMER_RATE = 500;

var
  Form1: TForm1;

implementation

{$R *.DFM}

(*
 * finiObjects
 *
 * finished with all objects we use; release them
 *)
procedure TForm1.finiObjects;
begin
  Timer1.Enabled := False;

  if (DD <> nil) then
  begin
    DD.RestoreDisplayMode;
    DD.Free;
    DD := nil;
  end;
end;


(*
 * doInit - do work required for every instance of the application:
 *                create the window, initialize data
 *)
procedure TForm1.doInit;
var
  dc: HDC;
  ddscaps: TDDSCaps;
  ddsd: TDDSurfaceDesc;
begin
  try
    (*
     * create the main DirectDraw object
     *)
    DD := TDirectDraw.Create( nil );

    // Get exclusive mode
    DD.SetCooperativeLevel( Handle, DDSCL_EXCLUSIVE or DDSCL_FULLSCREEN );

    DD.SetDisplayMode( 640, 480, 8 );

    // Create the primary surface with 1 back buffer
    ddsd.dwSize := sizeof( ddsd );
    ddsd.dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
    ddsd.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE or
              DDSCAPS_FLIP or
              DDSCAPS_COMPLEX;
    ddsd.dwBackBufferCount := 1;
    DDSPrimary := TDirectDrawSurface.Create( DD, ddsd );

    // Get a pointer to the back buffer
    ddscaps.dwCaps := DDSCAPS_BACKBUFFER;
    DDSBack := DDSPrimary.GetAttachedSurface( ddscaps );

      // draw some text.
    DDSPrimary.GetDC( DC );
    try
      SetBkColor( DC, RGB( 0, 0, 255 ) );
      SetTextColor( DC, RGB( 255, 255, 0 ) );
      TextOut( DC, 0, 0, szFrontMsg, strlen(szFrontMsg) );
    finally
      DDSPrimary.ReleaseDC( DC );
    end;

    DDSBack.GetDC( DC );
    try
      SetBkColor( DC, RGB( 0, 0, 255 ) );
      SetTextColor( DC, RGB( 255, 255, 0 ) );
      TextOut( DC, 0, 0, szBackMsg, strlen(szBackMsg) );
    finally
      DDSBack.ReleaseDC( DC );
    end;

    Timer1.Interval := TIMER_RATE;

    Timer1.Enabled := True;
  except
    on Exception do
    begin
      ShowMessage( 'Direct Draw Init Failed' );
      finiObjects;
      raise;
    end;
  end;
end;



procedure TForm1.Timer1Timer(Sender: TObject);
var
  DC: HDC;
begin
  if DDSPrimary.IsLost then
    if not DDSPrimary.Restore then exit;

  try
    // Flip surfaces
    DDSBack.GetDC( DC );
    try
      SetBkColor( DC, RGB( 0, 0, 255 ) );
      SetTextColor( DC, RGB( 255, 255, 0 ) );

      if ( phase <> 0 ) then
      begin
        TextOut( DC, 0, 0, szFrontMsg, strlen(szFrontMsg) );
        phase := 0;
      end
      else
      begin
        TextOut( DC, 0, 0, szBackMsg, strlen(szBackMsg) );
        phase := 1;
      end;
    finally
      DDSBack.ReleaseDC( DC );
    end;

    DDSPrimary.Flip( nil, DDFLIP_WAIT );
  except
    on E: EDirectDrawError do
      if E.ErrorCode <> DDERR_SURFACELOST then raise;
  end;
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
  Phase := 0;

  Screen.Cursor := crNone;

end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_F10 then
    Close;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  rc: TRECT;
  size: TSIZE;
begin
	rc := GetClientRect;
	GetTextExtentPoint( Canvas.Handle, szMsg, lstrlen(szMsg), size );
	SetBkColor( Canvas.Handle, RGB( 0, 0, 255 ) );
	SetTextColor( Canvas.Handle, RGB( 255, 255, 0 ) );
	TextOut( Canvas.Handle, (rc.right - size.cx) div 2, (rc.bottom - size.cy) div 2,
	    szMsg, strlen( szMsg ) );
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  finiObjects;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  if (DD = nil) then
    doInit;
end;

end.
