unit MainForm;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Forms,
  Classes,
  ExtCtrls,
  DirectDraw,
  DDUtil,
  Menus;

const
  SCREEN_WIDTH = 640;
  SCREEN_HEIGHT = 480;
  SCREEN_BPP = 8;

  SPRITE_DIAMETER = 48;
  NUM_SPRITES = 25;

  HELPTEXT : PChar = 'Press Escape to quit.';

type
  PSpriteRecord = ^TSpriteRecord;
  TSpriteRecord = packed record
    fPosX : single;
    fPosY : single;
    fVelX : single;
    fVelY : single;
  end;

  TFormMain = class( TForm )
    MainMenu1 : TMainMenu;
    File1 : TMenuItem;
    Exit1 : TMenuItem;
    procedure FormCreate( Sender : TObject );
    procedure FormKeyUp( Sender : TObject; var Key : Word; Shift : TShiftState );
    procedure FormActivate( Sender : TObject );
    procedure FormDeactivate( Sender : TObject );
    procedure FormClose( Sender : TObject; var Action : TCloseAction );
    procedure FormShow( Sender : TObject );
    procedure FormPaint( Sender : TObject );
    procedure Exit1Click( Sender : TObject );
  private
    FLastTick : DWORD;
    FActive : Boolean;
    FDisplay : TDisplay;
    FLogoSurface : TSurface;
    FTextSurface : TSurface;
    FSprite : array[ 0..NUM_SPRITES - 1 ] of TSpriteRecord;
    procedure FormOnIdle( Sender : TObject; var Done : Boolean );
    //procedure WMPaint(var aMsg : TMessage); message WM_PAINT;
    procedure WMQueryNewPalette( var aMsg : TMessage ); message WM_QUERYNEWPALETTE;
    procedure WMGetMinMaxInfo( var aMsg : TMessage ); message WM_GETMINMAXINFO;
    procedure WMMove( var aMsg : TMessage ); message WM_MOVE;
    procedure WMSize( var aMsg : TMessage ); message WM_SIZE;
    procedure ErrorOut( hRet : HRESULT; FuncName : string );
    procedure FreeDirectDraw;
    procedure UpdateSprite( var pSprite : TSpriteRecord; fTimeDelta : Single );
    function DisplayFrame : HRESULT;
    function RestoreSurfaces : HRESULT;
    function ProcessNextFrame : HRESULT;
    function InitDirectDraw : HRESULT;
  end;

var
  FormMain : TFormMain;

implementation

{$R *.DFM}

{-----------------------------------------------------------------------------
   Name: TFormMain.ErrorOut
   Desc: Format and display errors
-----------------------------------------------------------------------------}

procedure TFormMain.ErrorOut( hRet : HRESULT; FuncName : string );
var
  ErrorMessage : string;
begin
  ErrorMessage := FuncName + ': ' + #13 + DDErrorString( hRet );
  MessageBox( Handle, PChar( ErrorMessage ), PChar( Caption ), MB_ICONERROR or MB_OK );
end;

{-----------------------------------------------------------------------------
   Name: TFormMain.Create
   Desc: Initialize the window
-----------------------------------------------------------------------------}

procedure TFormMain.FormCreate( Sender : TObject );
begin
  // Maximize the window
  Left := 0;
  Top := 0;
  Width := GetSystemMetrics( SM_CXSCREEN );
  Height := GetSystemMetrics( SM_CYSCREEN );
  Application.OnIdle := FormOnIdle;
end;

{-----------------------------------------------------------------------------
   Name: TFormMain.FormClose
   Desc: Cleanup
-----------------------------------------------------------------------------}

procedure TFormMain.FormClose( Sender : TObject; var Action : TCloseAction );
begin
  FreeDirectDraw;
  Application.Minimize;
end;

{-----------------------------------------------------------------------------
   Name: TFormMain.FormKeyUp
   Desc: React to keystrokes
-----------------------------------------------------------------------------}

procedure TFormMain.FormKeyUp( Sender : TObject; var Key : Word; Shift : TShiftState );
begin
  if ( Key = VK_F12 ) or ( Key = VK_ESCAPE ) then
  begin
    Key := 0;
    Close;
  end;
end;

{-----------------------------------------------------------------------------
   Name: TFormMain.FormActivate
   Desc: Toggle active-flag
-----------------------------------------------------------------------------}

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

{-----------------------------------------------------------------------------
   Name: TFormMain.FormDeactivate
   Desc: Toggle active-flag
----------------------------------------------------------------------------}

procedure TFormMain.FormDeactivate( Sender : TObject );
begin
  FActive := False;
end;

{-----------------------------------------------------------------------------
   Name: TFormMain.FormOnIdle
   Desc: Update frame and flip pages
-----------------------------------------------------------------------------}

procedure TFormMain.FormOnIdle( Sender : TObject; var Done : Boolean );
var
  hr : HRESULT;
begin
  if FActive then
  begin
    hr := ProcessNextFrame;
    if hr <> DD_OK then
    begin
      ErrorOut( hr, 'ProcessNextFrame' );
      Close;
    end;
  end;
  Done := False;
end;

{-----------------------------------------------------------------------------
   Name: TFormMain.FormShow
   Desc: Initialize Direct Draw
-----------------------------------------------------------------------------}

procedure TFormMain.FormShow( Sender : TObject );
var
  hr : HResult;
begin
  // Initialize DirectDraw
  hr := InitDirectDraw;
  if hr <> DD_OK then
  begin
    ErrorOut( hr, 'InitDirectDraw' );
    Application.Terminate;
  end;
end;

{-----------------------------------------------------------------------------
   Name: DisplayFrame()
   Desc: Blts a the sprites to the back buffer, then it blts or flips the
         back buffer onto the primary buffer.
-----------------------------------------------------------------------------}

function TFormMain.DisplayFrame : HRESULT;
var
  hr : HRESULT;
  iSprite : integer;
begin
  if FDisplay = nil then
  begin
    result := DD_OK;
    exit;
  end;

  // Fill the back buffer with black, ignoring errors until the flip
  FDisplay.Clear( 0 );

  // Blt the help text on the backbuffer, ignoring errors until the flip
  FDisplay.Blt( 10, 10, FTextSurface, nil );

  // Blt all the sprites onto the back buffer using color keying,
  // ignoring errors until the flip. Note that all of these sprites
  // use the same DirectDraw surface.
  for iSprite := 0 to NUM_SPRITES - 1 do
    FDisplay.Blt( Round( FSprite[ iSprite ].fPosX ), Round( FSprite[ iSprite ].fPosY ), FLogoSurface, nil );


  // Flip or blt the back buffer onto the primary buffer
  hr := FDisplay.Flip;
  if ( hr <> DD_OK ) then
  begin
    result := hr;
    exit;
  end;

  result := DD_OK;
end;

{-----------------------------------------------------------------------------
  Name: FreeDirectDraw
  Desc: Release all the DirectDraw objects
-----------------------------------------------------------------------------}

procedure TFormMain.FreeDirectDraw;
begin
  FLogoSurface.Free;
  FLogoSurface := nil;
  FTextSurface.Free;
  FTextSurface := nil;
  FDisplay.Free;
  FDisplay := nil;
end;

{-----------------------------------------------------------------------------
   Name: InitDirectDraw()
   Desc: Create the DirectDraw object, and init the surfaces
-----------------------------------------------------------------------------}

function TFormMain.InitDirectDraw : HRESULT;
var
  hr : HRESULT;
  iSprite : integer;
  FDDPal : IDIRECTDRAWPALETTE;
begin
  ZeroMemory( @FSprite, SizeOf( TSpriteRecord ) * NUM_SPRITES );

  FDDPal := nil;

  // Initialize all the surfaces we need
  FDisplay := TDisplay.Create;

  hr := FDisplay.CreateWindowedDisplay( Handle, SCREEN_WIDTH, SCREEN_HEIGHT );
  if ( hr <> DD_OK ) then
  begin
    ErrorOut( hr, 'CreateWindowedDisplay' );
    result := hr;
    exit;
  end;

  // Create and set the palette when in palettized color
  hr := FDisplay.CreatePaletteFromBitmap( FDDPal, PAnsiChar( '..\media\directx.bmp' ) {MakeIntResource( IDB_DIRECTX ) } );
  if ( hr <> DD_OK ) then
  begin
    //DXTRACE_ERR( 'CreatePaletteFromBitmap', hr );
    ErrorOut( hr, 'CreatePaletteFromBitmap' );
    result := hr;
    exit;
  end;

  FDisplay.SetPalette( FDDPal );

  FDDPal := nil;

  // Create a surface, and draw a bitmap resource on it.
  hr := FDisplay.CreateSurfaceFromBitmap( FLogoSurface, PAnsiChar( '..\media\directx.bmp' ) {MAKEINTRESOURCE( IDB_DIRECTX )}, SPRITE_DIAMETER, SPRITE_DIAMETER );
  if ( hr <> DD_OK ) then
  begin
    //DXTRACE_ERR( 'CreateSurfaceFromBitmap', hr );
    ErrorOut( hr, 'CreateSurfaceFromBitmap' );
    result := hr;
    exit;
  end;

  // Create a surface, and draw text to it.
  hr := FDisplay.CreateSurfaceFromText( FTextSurface, 0, HELPTEXT, RGB( 0, 0, 0 ), RGB( 255, 255, 0 ) );
  if ( hr <> DD_OK ) then
  begin
    //DXTRACE_ERR( 'CreateSurfaceFromText', hr );
    ErrorOut( hr, 'CreateSurfaceFromText' );
    result := hr;
    exit;
  end;

  // Set the color key for the logo sprite to black
  hr := FLogoSurface.SetColorKey( 0 );
  if ( hr <> DD_OK ) then
  begin
    //DXTRACE_ERR( 'SetColorKey', hr )
    ErrorOut( hr, 'SetColorKey' );
    result := hr;
    exit;
  end;

  // Init all the sprites.  All of these sprites look the same,
  // using the FDDSLogo surface.
  for iSprite := 0 to NUM_SPRITES - 1 do
  begin
    // Set the sprite's position and velocity
    FSprite[ iSprite ].fPosX := random( SCREEN_WIDTH );
    FSprite[ iSprite ].fPosY := random( SCREEN_HEIGHT );

    FSprite[ iSprite ].fVelX := 500.0 * random / RAND_MAX - 250.0;
    FSprite[ iSprite ].fVelY := 500.0 * random / RAND_MAX - 250.0;
  end;

  FLastTick := GetTickCount;

  result := DD_OK;
end;

{-----------------------------------------------------------------------------
   Name: ProcessNextFrame()
   Desc: Move the sprites, blt them to the back buffer, then
         flip or blt the back buffer to the primary buffer
-----------------------------------------------------------------------------}

function TFormMain.ProcessNextFrame : HRESULT;
var
  hr : HRESULT;
  dwCurrTick : DWord;
  dwTickDiff : DWord;
  iSprite : integer;
begin
  // Figure how much time has passed since the last time
  dwCurrTick := GetTickCount;
  dwTickDiff := dwCurrTick - FLastTick;

  // Don't update if no time has passed
  if ( dwTickDiff = 0 ) then
  begin
    result := DD_OK;
    exit
  end;

  FLastTick := dwCurrTick;

  // Move the sprites according to how much time has passed
  for iSprite := 0 to NUM_SPRITES - 1 do
    UpdateSprite( FSprite[ iSprite ], dwTickDiff / 1000.0 );

  // Display the sprites on the screen
  hr := DisplayFrame;
  if ( hr <> DD_OK ) then
  begin
    if ( hr <> DDERR_SURFACELOST ) then
    begin
      FreeDirectDraw;
      //DXTRACE_ERR( 'DisplayFrame', hr );
      result := hr;
      exit;
    end;

    // The surfaces were lost so restore them
    RestoreSurfaces;
  end;

  result := DD_OK;
end;

{-----------------------------------------------------------------------------
   Name: RestoreSurfaces()
   Desc: Restore all the surfaces, and redraw the sprite surfaces.
-----------------------------------------------------------------------------}

function TFormMain.RestoreSurfaces : HRESULT;
var
  hr : HRESULT;
  FDDPal : IDIRECTDRAWPALETTE;
begin
  hr := FDisplay.GetDirectDraw.RestoreAllSurfaces;
  if ( hr <> DD_OK ) then
  begin
    //DXTRACE_ERR( TEXT("RestoreAllSurfaces"), hr );
    result := hr;
    exit;
  end;

  // No need to re-create the surface, just re-draw it.
  hr := FTextSurface.DrawText( 0, HELPTEXT, 0, 0, RGB( 0, 0, 0 ), RGB( 255, 255, 0 ) );
  if ( hr <> DD_OK ) then
  begin
    //DXTRACE_ERR( TEXT("DrawText"), hr );
    result := hr;
    exit;
  end;

  // We need to release and re-load, and set the palette again to
  // redraw the bitmap on the surface.  Otherwise, GDI will not
  // draw the bitmap on the surface with the right palette
  FDDPal := nil;

  // No need to re-create the surface, just re-draw it.
  // We need to release and re-load, and set the palette again to
  hr := FDisplay.CreatePaletteFromBitmap( FDDPal, PAnsiChar( '..\media\directx.bmp' ) {MakeIntResource( IDB_DIRECTX ) } );
  if ( hr <> DD_OK ) then
  begin
    //DXTRACE_ERR( TEXT("CreatePaletteFromBitmap"), hr );
    result := hr;
    exit;
  end;

  FDisplay.SetPalette( FDDPal );

  FDDPal := nil;

  // No need to re-create the surface, just re-draw it.
  //hr := FLogoSurface.DrawBitmap( MakeIntResource( IDB_DIRECTX ), SPRITE_DIAMETER, SPRITE_DIAMETER );
  hr := FLogoSurface.DrawBitmap( PChar( '..\media\directx.bmp' ), SPRITE_DIAMETER, SPRITE_DIAMETER );
  if ( hr <> DD_OK ) then
  begin
    //DXTRACE_ERR( TEXT("DrawBitmap"), hr );
    result := hr;
    exit;
  end;


  // No need to re-create the surface, just re-draw it.
  hr := FTextSurface.DrawText( 0, HELPTEXT, 0, 0, RGB( 0, 0, 0 ), RGB( 255, 255, 0 ) );
  if ( hr <> DD_OK ) then
  begin
    result := hr;
    exit;
  end;


  result := DD_OK;
end;

{-----------------------------------------------------------------------------
   Name: UpdateSprite()
   Desc: Move the sprite around and make it bounce based on how much time
         has passed
-----------------------------------------------------------------------------}

procedure TFormMain.UpdateSprite( var pSprite : TSpriteRecord; fTimeDelta : Single );
begin
// Update the sprite position
  pSprite.fPosX := pSprite.fPosX + pSprite.fVelX * fTimeDelta;
  pSprite.fPosY := pSprite.fPosY + pSprite.fVelY * fTimeDelta;

  // Clip the position, and bounce if it hits the edge
  if ( pSprite.fPosX < 0.0 ) then
  begin
    pSprite.fPosX := 0;
    pSprite.fVelX := -pSprite.fVelX;
  end;

  if ( pSprite.fPosX >= SCREEN_WIDTH - SPRITE_DIAMETER ) then
  begin
    pSprite.fPosX := SCREEN_WIDTH - 1 - SPRITE_DIAMETER;
    pSprite.fVelX := -pSprite.fVelX;
  end;

  if ( pSprite.fPosY < 0 ) then
  begin
    pSprite.fPosY := 0;
    pSprite.fVelY := -pSprite.fVelY;
  end;

  if ( pSprite.fPosY > SCREEN_HEIGHT - SPRITE_DIAMETER ) then
  begin
    pSprite.fPosY := SCREEN_HEIGHT - 1 - SPRITE_DIAMETER;
    pSprite.fVelY := -pSprite.fVelY;
  end;
end;

procedure TFormMain.WMGETMINMAXINFO( var aMsg : TMessage );
var
  pMinMax : TMinMaxInfo;
  dwFrameWidth, dwFrameHeight, dwMenuHeight, dwCaptionHeight : DWORD;
begin
  // Don't allow resizing in windowed mode.
  // Fix the size of the window to 640x480 (client size)
  pMinMax := pMinMaxinfo( aMsg.lParam )^;

  dwFrameWidth := GetSystemMetrics( SM_CXSIZEFRAME );
  dwFrameHeight := GetSystemMetrics( SM_CYSIZEFRAME );
  dwMenuHeight := GetSystemMetrics( SM_CYMENU );
  dwCaptionHeight := GetSystemMetrics( SM_CYCAPTION );

  pMinMax.ptMinTrackSize.x := SCREEN_WIDTH + dwFrameWidth * 2;
  pMinMax.ptMinTrackSize.y := SCREEN_HEIGHT + dwFrameHeight * 2 + dwMenuHeight + dwCaptionHeight;

  pMinMax.ptMaxTrackSize.x := pMinMax.ptMinTrackSize.x;
  pMinMax.ptMaxTrackSize.y := pMinMax.ptMinTrackSize.y;
  aMsg.Result := 0;
end;

{procedure TFormMain.WMPaint(var aMsg: TMessage);
begin
  if( FDisplay <> nil ) then
  begin
    // Display the new position of the sprite
    if( DisplayFrame = DDERR_SURFACELOST ) then
    begin
      // If the surfaces were lost, then restore and try again
      RestoreSurfaces;
      DisplayFrame;
    end;
  end;
end;   }

procedure TFormMain.WMQueryNewPalette( var aMsg : TMessage );
var
  pDDPal : IDIRECTDRAWPALETTE;
begin
  pDDPal := nil;
  if ( FDisplay <> nil ) then
  begin
    // If we are in windowed mode with a desktop resolution in 8 bit
    // color, then the palette we created during init has changed
    // since then.  So get the palette back from the primary
    // DirectDraw surface, and set it again so that DirectDraw
    // realises the palette, then release it again.
    FDisplay.GetFrontBuffer.GetPalette( pDDPal );
    FDisplay.GetFrontBuffer.SetPalette( pDDPal );
    pDDPal := nil;
  end;
end;

procedure TFormMain.WMMove( var aMsg : TMessage );
begin
  // Retrieve the window position after a move.
  if ( FDisplay <> nil ) then
    FDisplay.UpdateBounds;
  aMsg.Result := 0;
end;

procedure TFormMain.WMSize( var aMsg : TMessage );
begin
  // Check to see if we are losing our window...
  if ( aMsg.wParam = SIZE_MAXHIDE ) or ( aMsg.wParam = SIZE_MINIMIZED ) then
    FActive := False
  else
    FActive := True;

  if ( FDisplay <> nil ) then
    FDisplay.UpdateBounds;
end;

procedure TFormMain.FormPaint( Sender : TObject );
begin
  if ( FDisplay <> nil ) then
  begin
    // Display the new position of the sprite
    if ( DisplayFrame = DDERR_SURFACELOST ) then
    begin
      // If the surfaces were lost, then restore and try again
      RestoreSurfaces;
      DisplayFrame;
    end;
  end;
end;

procedure TFormMain.Exit1Click( Sender : TObject );
begin
  Close;
end;

end.
