Tunnel: Delphi Version
{*****************************************************************************
* *
* Tunnel.dpr *
* TunnelU.pas *
* *
* This program draws a Gouraud-shaded tunnel and allows the viewer to move *
* through the tunnel using keyboard controls. *
* *
*****************************************************************************}
unit TunnelU;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, FGWin;
type
TForm1 = class(TForm)
procedure AppOnActivate(Sender: TObject);
procedure AppIdle(Sender: TObject; var Done: Boolean);
procedure FormActivate(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure FormDestroy(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
POINT3D = record
x : double;
y : double;
z : double;
end;
const
{ virtual buffer dimensions }
vbWidth = 640;
vbHeight = 480;
{ four sides of a 20x40x100 tunnel, defined in 3D world coordinates }
Floor : array [1..4] of POINT3D = (
(x:-10.0; y: 0.0; z:100.0),
(x:-10.0; y: 0.0; z:200.0),
(x: 10.0; y: 0.0; z:200.0),
(x: 10.0; y: 0.0; z:100.0));
WestSide : array [1..4] of POINT3D = (
(x:-10.0; y: 0.0; z:100.0),
(x:-10.0; y:40.0; z:100.0),
(x:-10.0; y:40.0; z:200.0),
(x:-10.0; y: 0.0; z:200.0));
EastSide : array [1..4] of POINT3D = (
(x: 10.0; y: 0.0; z:100.0),
(x: 10.0; y: 0.0; z:200.0),
(x: 10.0; y:40.0; z:200.0),
(x: 10.0; y:40.0; z:100.0));
Ceiling : array [1..4] of POINT3D = (
(x:-10.0; y:40.0; z:100.0),
(x: 10.0; y:40.0; z:100.0),
(x: 10.0; y:40.0; z:200.0),
(x:-10.0; y:40.0; z:200.0));
{ RGB color values at each vertex of each side }
FloorRGB : array [1..4*3] of byte =
(192,192,192, 64, 64, 64, 64, 64, 64, 192,192,192);
WestSideRGB : array [1..4*3] of byte =
( 32, 32,255, 32, 32,255, 32, 32, 96, 32, 32, 96);
EastSideRGB : array [1..4*3] of byte =
( 32, 32,255, 32, 32, 96, 32, 32, 96, 32, 32,255);
CeilingRGB : array [1..4*3] of byte =
(192,192,192, 192,192,192, 64, 64, 64, 64, 64, 64);
{ for convenience, an array of pointers to each of the four sides }
Faces : array [1..4] of ^POINT3D =
(@Floor,@WestSide,@EastSide,@Ceiling);
{ a similar array of pointers to each side's RGB values }
FacesRGB : array [1..4] of ^byte =
(@FloorRGB,@WestSideRGB,@EastSideRGB,@CeilingRGB);
var
dc : hDC;
hPal : hPalette;
hVB : integer;
cxClient, cyClient : integer;
hZB : integer;
Redraw : boolean;
{*****************************************************************************
* *
* DrawTunnel() *
* *
* Draws each of the tunnel's four sides in 3D world space. *
* *
*****************************************************************************}
procedure DrawTunnel;
var
i : integer;
begin
for i := 1 to 4 do
begin
fg_3Dshade(Faces[i]^,FacesRGB[i]^,4);
end;
end;
{*****************************************************************************
* *
* CheckForMovement() *
* *
* The CheckForMovement() function checks for key presses that control the *
* user's movement, and if required redraws the tunnel viewed from the new *
* camera position. It is called from the WinMain() message loop when there *
* are no messages waiting. *
* *
*****************************************************************************}
procedure CheckForMovement;
begin
{ up arrow moves viewer forward }
if (fg_kbtest(72) = 1) then
begin
fg_3Dmoveforward(2.0);
Redraw := True;
end
{ down arrow moves viewer backward }
else if (fg_kbtest(80) = 1) then
begin
fg_3Dmoveforward(-2.0);
Redraw := True;
end
{ right arrow turns viewer to the right }
else if (fg_kbtest(77) = 1) then
begin
fg_3Drotateright(6*10);
Redraw := True;
end
{ left arrow turns viewer to the left }
else if (fg_kbtest(75) = 1) then
begin
fg_3Drotateright(-6*10);
Redraw := True;
end;
{ if the viewer's position or rotation changed, redraw the tunnel }
if (Redraw) then
begin
{ prepare the z-buffer for the next frame }
fg_zbframe;
{ erase the previous frame from the virtual buffer }
fg_setcolor(-1);
fg_fillpage;
{ draw the tunnel }
DrawTunnel;
{ display what we just drew }
fg_vbscale(0,vbWidth-1,0,vbHeight-1,0,cxClient-1,0,cyClient-1);
Redraw := False;
end;
end;
{****************************************************************************}
procedure TForm1.AppOnActivate(Sender: TObject);
begin
fg_realize(hPal);
Invalidate;
end;
procedure TForm1.AppIdle(Sender: Tobject; var Done: Boolean);
begin
CheckForMovement;
Done := False;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
fg_realize(hPal);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
vbDepth : integer;
begin
dc := GetDC(Form1.Handle);
fg_setdc(dc);
hPal := fg_defpal;
fg_realize(hPal);
fg_vbinit;
vbDepth := fg_colors;
if (vbDepth < 16) then vbDepth := 16;
fg_vbdepth(vbDepth);
hVB := fg_vballoc(vbWidth,vbHeight);
fg_vbopen(hVB);
fg_vbcolors;
hZB := fg_zballoc(vbWidth,vbHeight);
fg_zbopen(hZB);
fg_setcolor(-1);
fg_fillpage;
fg_3Dviewport(0,vbWidth-1,0,vbHeight-1,1.0);
fg_3Drenderstate(FG_ZBUFFER or FG_ZCLIP);
fg_3Dlookat(0.0,10.0,50.0,0.0,10.0,100.0);
Redraw := True;
Application.OnActivate := AppOnActivate;
Application.OnIdle := AppIdle;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
fg_vbscale(0,vbWidth-1,0,vbHeight-1,0,cxClient-1,0,cyClient-1);
end;
procedure TForm1.FormResize(Sender: TObject);
begin
cxClient := ClientWidth;
cyClient := ClientHeight;
Invalidate;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
fg_vbclose;
fg_zbfree(hZB);
fg_vbfree(hVB);
fg_vbfin;
DeleteObject(hPal);
ReleaseDC(Form1.Handle,dc);
end;
end.
|