TMcubeX: Delphi Version
{*****************************************************************************
* *
* TMcubeX.dpr *
* TMcubeXU.pas *
* *
* This program is similar to the TMcube example, but it shows how to create *
* a native, DirectDraw, or Direct3D program from the same source code. *
* *
*****************************************************************************}
unit TMcubeXU;
interface
{ define DIRECTX if creating a DirectDraw or Direct3D application }
{$DEFINE DIRECTX}
{$IFDEF DIRECTX}
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, FGWinD;
{$ELSE}
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, FGWin;
{$ENDIF}
type
TForm1 = class(TForm)
procedure AppOnActivate(Sender: TObject);
procedure AppIdle(Sender: TObject; var Done: Boolean);
procedure FormActivate(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormDestroy(Sender: TObject);
protected
procedure WMActivateApp(var Msg: TMessage); message WM_ACTIVATEAPP;
end;
var
Form1: TForm1;
implementation
{$J+}
{$R *.DFM}
type
POINT3D = record
x : double;
y : double;
z : double;
end;
const
{ render state }
RENDER_STATE = FG_PERSPECTIVE_TM or FG_ZBUFFER or FG_ZCLIP;
{ define the flag bits for fg_ddsetup() }
{ specify FG_DX_FLIP for a Direct3D application }
{ specify FG_DX_RENDER_HW or FG_DX_RENDER_SW for a Direct3D application }
{ specify FG_DX_ZBUFFER only if FG_ZBUFFER is defined in RENDER_STATE }
{$IFDEF DIRECTX}
DIRECTX_FLAGS = FG_DX_FLIP or FG_DX_RENDER_HW or FG_DX_ZBUFFER;
{$ENDIF}
{ virtual buffer dimensions }
vbWidth = 640;
vbHeight = 480;
vbDepth = 16;
{ six faces of a 40x40x40 cube, defined in object coordinates }
Face1 : array [1..4] of POINT3D = (
(x: 20.0; y:-20.0; z:-20.0),
(x:-20.0; y:-20.0; z:-20.0),
(x:-20.0; y: 20.0; z:-20.0),
(x: 20.0; y: 20.0; z:-20.0));
Face2 : array [1..4] of POINT3D = (
(x:-20.0; y:-20.0; z:-20.0),
(x:-20.0; y:-20.0; z: 20.0),
(x:-20.0; y: 20.0; z: 20.0),
(x:-20.0; y: 20.0; z:-20.0));
Face3 : array [1..4] of POINT3D = (
(x: 20.0; y: 20.0; z: 20.0),
(x:-20.0; y: 20.0; z: 20.0),
(x:-20.0; y:-20.0; z: 20.0),
(x: 20.0; y:-20.0; z: 20.0));
Face4 : array [1..4] of POINT3D = (
(x: 20.0; y:-20.0; z: 20.0),
(x: 20.0; y:-20.0; z:-20.0),
(x: 20.0; y: 20.0; z:-20.0),
(x: 20.0; y: 20.0; z: 20.0));
Face5 : array [1..4] of POINT3D = (
(x: 20.0; y:-20.0; z: 20.0),
(x:-20.0; y:-20.0; z: 20.0),
(x:-20.0; y:-20.0; z:-20.0),
(x: 20.0; y:-20.0; z:-20.0));
Face6 : array [1..4] of POINT3D = (
(x: 20.0; y: 20.0; z:-20.0),
(x:-20.0; y: 20.0; z:-20.0),
(x:-20.0; y: 20.0; z: 20.0),
(x: 20.0; y: 20.0; z: 20.0));
{ for convenience, an array of pointers to each of the six faces }
Faces : array [1..6] of ^POINT3D = (@Face1,@Face2,@Face3,@Face4,@Face5,@Face6);
{ width of texture map in pixels }
tmWidth = 64;
{ coordinates defining source polygon vertices within the texture map array }
tmSource : array [1..8] of integer = (
tmWidth-1,tmWidth-1, 0,tmWidth-1, 0,0, tmWidth-1,0);
AppIsActive : boolean = False;
AppIsReady : boolean = False;
var
{ texture map array }
Texture : array [1..6,1..tmWidth*tmWidth*(vbDepth div 8)] of byte;
dc : hDC;
hPal : hPalette;
hVB : integer;
hZB : integer;
hTM : array [1..6] of integer;
xAngle, yAngle, zAngle : integer;
xWorld, yWorld, zWorld : double;
{*****************************************************************************
* *
* DrawCube() *
* *
* Transforms, clips, projects, and draws each of the six cube faces. *
* *
*****************************************************************************}
procedure DrawCube;
var
i : integer;
begin
for i := 1 to 6 do
begin
fg_tmselect(hTM[i]);
fg_3Dtexturemapobject(Faces[i]^,tmSource,4);
end;
end;
{*****************************************************************************
* *
* ShowCube() *
* *
* Performs a blit or flip to make the cube visible. *
* *
*****************************************************************************}
procedure ShowCube;
begin
{$IFDEF DIRECTX}
fg_ddflip;
{$ELSE}
fg_vbpaste(0,vbWidth-1,0,vbHeight-1,0,vbHeight-1);
{$ENDIF}
end;
{*****************************************************************************
* *
* CheckForMovement() *
* *
* The CheckForMovement() function checks for key presses that control the *
* cube's movement, and if required redraws the cube at its new position and *
* orientation. It is called from the application's OnIdle event handler. *
* *
* The Redraw parameter controls when CheckForMovement() redraws the cube. *
* If False, the cube is redrawn only if its position or orientation has *
* changed since the last call. If True, the cube is redrawn no matter what. *
* *
*****************************************************************************}
procedure CheckForMovement(Redraw: boolean);
var
ShiftKey : boolean;
begin
{ check if either shift key is pressed }
ShiftKey := (fg_kbtest(42) = 1) or (fg_kbtest(54) = 1);
{ + and - move cube along the z axis (+ is toward viewer, - is }
{ away from viewer) }
if (fg_kbtest(74) = 1) then
begin
zWorld := zWorld + 3.0;
Redraw := True;
end
else if (fg_kbtest(78) = 1) then
begin
zWorld := zWorld - 3.0;
Redraw := True;
end
{ left and right arrow keys move cube along x axis }
else if (fg_kbtest(75) = 1) then
begin
xWorld := xWorld - 3.0;
Redraw := True;
end
else if (fg_kbtest(77) = 1) then
begin
xWorld := xWorld + 3.0;
Redraw := True;
end
{ up and down arrow keys move cube along y axis }
else if (fg_kbtest(72) = 1) then
begin
yWorld := yWorld + 3.0;
Redraw := True;
end
else if (fg_kbtest(80) = 1) then
begin
yWorld := yWorld - 3.0;
Redraw := True;
end
{ x rotates counterclockwise around x axis, X rotates clockwise }
else if (fg_kbtest(45) = 1) then
begin
if (ShiftKey) then
begin
Inc(xAngle,6);
if (xAngle >= 360) then Dec(xAngle,360);
end
else
begin
Dec(xAngle,6);
if (xAngle < 0) then Inc(xAngle,360);
end;
Redraw := True;
end
{ y rotates counterclockwise around y axis, Y rotates clockwise }
else if (fg_kbtest(21) = 1) then
begin
if (ShiftKey) then
begin
Inc(yAngle,6);
if (yAngle >= 360) then Dec(yAngle,360);
end
else
begin
Dec(yAngle,6);
if (yAngle < 0) then Inc(yAngle,360);
end;
Redraw := True;
end
{ z rotates counterclockwise around z axis, Z rotates clockwise }
else if (fg_kbtest(44) = 1) then
begin
if (ShiftKey) then
begin
Inc(zAngle,6);
if (zAngle >= 360) then Dec(zAngle,360);
end
else
begin
Dec(zAngle,6);
if (zAngle < 0) then Inc(zAngle,360);
end;
Redraw := True;
end;
{ if the cube's position or rotation changed, redraw the cube }
if (Redraw) then
begin
{$IFDEF DIRECTX}
{ tell Direct3D we're about to start a new frame }
fg_ddframe(0);
{$ENDIF}
{ prepare the z-buffer for the next frame }
fg_zbframe;
{ erase the previous frame from the virtual buffer }
fg_setcolor(-1);
fg_fillpage;
{ define the cube's new position and rotation in 3D world space }
fg_3Dsetobject(xWorld,yWorld,zWorld,xAngle*10,yAngle*10,zAngle*10);
{ draw the cube }
DrawCube;
{$IFDEF DIRECTX}
{ tell Direct3D we're finished with this frame }
fg_ddframe(1);
{$ENDIF}
{ display what we just drew }
ShowCube;
end;
end;
{****************************************************************************}
procedure TForm1.AppOnActivate(Sender: TObject);
begin
fg_realize(hPal);
end;
procedure TForm1.AppIdle(Sender: Tobject; var Done: Boolean);
begin
if AppIsActive and AppIsReady then CheckForMovement(False);
Done := False;
end;
{****************************************************************************}
procedure TForm1.WMActivateApp(var Msg: TMessage);
begin
AppIsActive := (Msg.WParam <> 0);
if AppIsActive and AppIsReady then
begin
{$IFDEF DIRECTX}
fg_ddrestore;
{$ENDIF}
CheckForMovement(True);
end;
end;
{****************************************************************************}
procedure TForm1.FormActivate(Sender: TObject);
begin
fg_realize(hPal);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i : integer;
begin
Visible := True;
{$IFDEF DIRECTX}
fg_ddsetup(vbWidth,vbHeight,vbDepth,DIRECTX_FLAGS);
{$ELSE}
fg_modeset(vbWidth,vbHeight,fg_colors,1);
WindowState := wsMaximized;
{$ENDIF}
dc := GetDC(Form1.Handle);
fg_setdc(dc);
hPal := fg_defpal;
fg_realize(hPal);
fg_vbinit;
fg_vbdepth(vbDepth);
{$IFDEF DIRECTX}
hVB := 0;
{$ELSE}
hVB := fg_vballoc(vbWidth,vbHeight);
{$ENDIF}
fg_vbopen(hVB);
fg_vbcolors;
hZB := fg_zballoc(vbWidth,vbHeight);
fg_zbopen(hZB);
{ define 3D viewport, clipping planes, and initial render state }
fg_3Dviewport(0,vbWidth-1,0,vbHeight-1,0.5);
fg_3Dsetzclip(40.0,1000.0);
fg_3Drenderstate(RENDER_STATE);
{ obtain the six texture maps from the CUBE.PCX file }
fg_tminit(6);
fg_showpcx('CUBE.PCX'+chr(0),FG_AT_XY or FG_KEEPCOLORS);
fg_move(0,tmWidth-1);
for i := 1 to 6 do
begin
if (vbDepth = 8) then
begin
fg_getimage(Texture[i],tmWidth,tmWidth);
fg_invert(Texture[i],tmWidth,tmWidth);
end
else
begin
fg_getdcb(Texture[i],tmWidth,tmWidth);
fg_invdcb(Texture[i],tmWidth,tmWidth);
end;
hTM[i] := fg_tmdefine(Texture[i],tmWidth,tmWidth);
fg_moverel(tmWidth,0);
end;
xAngle := 0;
yAngle := 0;
zAngle := 0;
xWorld := 0.0;
yWorld := 0.0;
zWorld := 100.0;
CheckForMovement(True);
Application.OnActivate := AppOnActivate;
Application.OnIdle := AppIdle;
AppIsActive := True;
AppIsReady := True;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (Key = VK_Escape) or (Key = VK_F12) then Close;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
fg_vbclose;
fg_tmfree(-1);
fg_zbfree(hZB);
{$IFDEF DIRECTX}
fg_vbfin;
{$ELSE}
fg_vbfree(hVB);
fg_vbfin;
fg_modeset(0,0,0,0);
{$ENDIF}
DeleteObject(hPal);
ReleaseDC(Form1.Handle,dc);
Application.Minimize;
end;
end.
|