- unit Unit1;
- interface
- uses
- Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
- Dialogs, OpenGL12, Geometry, AppEvnts, Textures;
- const
- FarClipping = 5000.0;
- NearClipping = 1.0;
- MapSize = 2048;
- MapResolution = 86;
- type
- TMapDaten = Array[0..MapResolution, 0..MapResolution] of Byte;
- TForm1 = class(TForm)
- procedure FormCreate(Sender: TObject);
- procedure FormShow(Sender: TObject);
- procedure FormDestroy(Sender: TObject);
- procedure FormResize(Sender: TObject);
- procedure ApplicationEventsIdle(Sender: TObject; var Done: Boolean);
- procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
- Shift: TShiftState; X, Y: Integer);
- procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
- Shift: TShiftState; X, Y: Integer);
- procedure FormKeyDown(Sender: TObject; var Key: Word;
- Shift: TShiftState);
- procedure FormKeyUp(Sender: TObject; var Key: Word;
- Shift: TShiftState);
- procedure CheckKeys;
- private
- OpenGLInitialized : Boolean;
- RC : HGLRC; //OpenGL Rendering Context
- SkyBoxTexturen : Array[0..5] of TGlUInt;
- StartTick : Cardinal;
- Frames : LongInt;
- XRotation, YRotation : Single;
- MouseX, MouseY : LongInt;
- MapDaten : TMapDaten;
- { Private-Deklarationen }
- public
- { Public-Deklarationen }
- end;
- var
- Form1: TForm1;
- Keys: Array[0..255] of Boolean;
- Rotate,RotateX,PosX,PosY,PosZ,CamX,CamY: Single;
- implementation
- {$R *.dfm}
- procedure TForm1.CheckKeys;
- begin
- if Keys[VK_LEFT] then begin
- Rotate:=Rotate - 2 * (100 / 20);
- if Rotate<0 then
- Rotate:=Rotate + 360;
- end;
- if Keys[VK_RIGHT] then begin
- Rotate:=Rotate + 2 * (100 / 20);
- if Rotate>360 then
- Rotate:=Rotate - 360;
- end;
- if Keys[VK_UP] then begin
- PosX:=PosX + Sin(-Rotate * (PI / 180)) * (0.1);
- PosZ:=PosZ + Cos(-Rotate * (PI / 180)) * (0.1);
- end;
- if Keys[VK_DOWN] then begin
- PosX:=PosX - Sin(-Rotate * (PI / 180)) * (0.1);
- PosZ:=PosZ - Cos(-Rotate * (PI / 180)) * (0.1);
- end;
- end;
- procedure TForm1.FormCreate(Sender: TObject);
- begin
- //OpenGL ist noch nicht bereit
- OpenGLInitialized := False;
- //Kontrolle ob die Bilbliiotheken geladen sind
- if not LoadOpenGL then
- Halt(100);
- Application.OnIdle := ApplicationEventsIdle;
- end;
- procedure TForm1.FormShow(Sender: TObject);
- procedure SetPixelFormat;
- var
- PixelFormat : TGLuint;
- PFD : pixelformatdescriptor;
- begin
- with pfd do
- begin
- nSize:= SizeOf( PIXELFORMATDESCRIPTOR );
- nVersion:= 1;
- dwFlags:= PFD_DRAW_TO_WINDOW
- or PFD_SUPPORT_OPENGL
- or PFD_DOUBLEBUFFER;
- iPixelType:= PFD_TYPE_RGBA;
- cColorBits:= 16;
- cRedBits:= 0;
- cRedShift:= 0;
- cGreenBits:= 0;
- cBlueBits:= 0;
- cBlueShift:= 0;
- cAlphaBits:= 0;
- cAlphaShift:= 0;
- cAccumBits:= 0;
- cAccumRedBits:= 0;
- cAccumGreenBits:= 0;
- cAccumBlueBits:= 0;
- cAccumAlphaBits:= 0;
- cDepthBits:= 16;
- cStencilBits:= 0;
- cAuxBuffers:= 0;
- iLayerType:= PFD_MAIN_PLANE;
- bReserved:= 0;
- dwLayerMask:= 0;
- dwVisibleMask:= 0;
- dwDamageMask:= 0
- end;
- PixelFormat := ChoosePixelFormat(Canvas.Handle, @pfd);
- if (PixelFormat=0) then
- MessageDlg('Can''t find a suitable PixelFormat.', mtError, [mbOk], 0);
- if (not Windows.SetPixelFormat(Canvas.Handle,PixelFormat,@pfd)) then
- MessageDlg('Can''t set PixelFormat.', mtError, [mbOk], 0)
- end;
- procedure StartGl;
- begin
- RC := wglCreateContext(Canvas.Handle);
- if (RC=0) then
- begin
- MessageDlg('Can''t create RC', mtError, [mbOk], 0);
- Halt(100)
- end;
- if (not wglMakeCurrent(Canvas.Handle, RC)) then
- begin
- MessageDlg('Can''t activate RC', mtError, [mbOk], 0);
- Halt(100)
- end
- end;
- procedure SetupGL;
- const
- light_position : array[0..3] of TGLfloat = (-1.0, 1.0, 1.0, 0.0);
- mat_specular : array[0..3] of TGLfloat = (0.1, 0.1, 0.1, 1.0);
- mat_shininess : array[0..0] of TGLfloat = (0.0);
- mat_ambient : array[0..3] of TGLfloat = (0.7, 0.7, 0.7, 0.0);
- mat_diffuse : array[0..3] of TGLfloat = (0.8, 0.8, 0.8, 0.0);
- begin
- glClearColor(0.0, 0.0, 0.0, 0.0); //Hintergrundfarbe
- glEnable(GL_DEPTH_TEST);
- glEnable(gl_Cull_Face);
- glEnable(GL_TEXTURE_2D);
- glShadeModel(GL_SMOOTH);
- glMaterialfv(GL_FRONT, GL_SPECULAR, @mat_specular[0]);
- glMaterialfv(GL_FRONT, GL_SHININESS, @mat_shininess[0]);
- glMaterialfv(GL_FRONT, GL_AMBIENT, @mat_ambient[0]);
- glMaterialfv(GL_FRONT, GL_DIFFUSE, @mat_diffuse[0]);
- glLightfv(GL_LIGHT0, GL_POSITION, @light_position[0]);
- glEnable(GL_LIGHTING);
- glEnable(GL_LIGHT0)
- end;
- procedure LoadTextures;
- const
- SkyTexturesName : Array[0..5] of String = ('north.jpg', 'east.jpg', 'south.jpg',
- 'west.jpg', 'top.jpg', 'bottom.jpg');
- var
- I : Integer;
- begin
- //Bilder für SkyBox laden
- for I := 0 to 5 do
- LoadTexture(SkyTexturesName[I], SkyBoxTexturen[I], False);
- end;
- procedure LoadHeightMap;
- var
- Bmp : TBitMap;
- X,Z : LongInt;
- begin
- Bmp := TBitMap.Create;
- try
- Bmp.LoadFromFile('YU14H.bmp');
- //Bitmap in MapDaten laden...
- for X := 0 to MapResolution do
- for Z := 0 to MapResolution do
- MapDaten[X,Z] := Trunc(Bmp.Canvas.Pixels[Trunc(X/MapResolution*Bmp.Width),
- Trunc(Z/MapResolution*Bmp.Height)] / clWhite * 255)
- except
- MessageDlg('Fehler beim laden der Heightmap', mtError, [mbOk], 0)
- end;
- Bmp.Free
- end;
- begin
- RC := 0;
- SetPixelFormat;
- StartGL;
- //Extensions auslesen
- ClearExtensions;
- ReadExtensions;
- //GLStatus Variablen einstellen
- SetupGL;
- LoadTextures;
- Frames := 0;
- StartTick := GetTickCount;
- OpenGLInitialized := True
- end;
- procedure TForm1.FormDestroy(Sender: TObject);
- begin
- OpenGLInitialized := False;
- if RC<>0 then
- begin
- if (not wglMakeCurrent(Canvas.Handle,0)) then
- MessageBox(0,'Release of DC and RC failed.',' Shutdown Error',MB_OK or MB_ICONERROR);
- if (not wglDeleteContext(RC)) then
- begin
- MessageBox(0,'Release of Rendering Context failed.',' Shutdown Error',MB_OK or MB_ICONERROR);
- end
- end;
- RC:=0
- end;
- procedure TForm1.FormResize(Sender: TObject);
- begin
- glViewport(0, 0, ClientWidth, ClientHeight);
- glMatrixMode(GL_PROJECTION);
- glLoadIdentity();
- gluPerspective(60.0,ClientWidth/ClientHeight,NearClipping,FarClipping);
- // hier wird das Verhätlnis zwischen errechnet Höhe und Breite der Oberfläche errechnet.
- glMatrixMode(GL_MODELVIEW);
- glLoadIdentity
- end;
- procedure TForm1.ApplicationEventsIdle(Sender: TObject;
- var Done: Boolean);
- var
- Triangles : LongInt;
- procedure PaintSkyBox;
- const
- QuadPosition : Array[0..5] of Array[0..3] of Array[0..2] of Single =
- (((2.005,2.005,-1.995),(2.005,-2.005,-1.995),(-2.005,-2.005,-1.995),(-2.005,2.005,-1.995)), //Nordseite
- ((1.995,2.005,2),(1.995,-2.005,2),(1.995,-2.005,-2),(1.995,2.005,-2)), //Ostseite
- ((-2.005,2.005,1.995),(-2.005,-2.005, 1.995),(2.005,-2.005,1.995),(2.005,2.005,1.995)), //Südseite
- ((-1.995,2.005,-2),(-1.995,-2.005,-2),(-1.995,-2.005,2),(-1.995,2.005,2)), //Westseite
- ((-2,2,-2),(-2,2,2),(2,2,2), (2,2,-2)),
- ((2,-2,-2),(2,-2,2),(-2,-2,2),(-2,-2,-2)));
- TexturePos : Array[0..3] of Array[0..1] of Single =
- ((1,1),(1,0),(0, 0),(0, 1));
- var
- Side, Vertex : Integer;
- begin
- for Side := 0 to 5 do
- begin
- //Textur aktivieren
- glBindTexture(GL_TEXTURE_2D, SkyBoxTexturen[Side]);
- glBegin(GL_QUADS);
- //Vertieces und Tex Coords übergeben
- for Vertex := 3 downto 0 do
- begin
- glTexCoord2fv(@TexturePos[Vertex][0]);
- glVertex3fv(@QuadPosition[Side][Vertex][0])
- end;
- glEnd()
- end
- end;
- procedure PaintHeightMap;
- const
- VertPos : Array[0..3] of Array[0..1] of Byte =
- ((0,0),(0,1),(1,1),(1,0));
- var
- X,Z,I : LongInt;
- Vertieces : Array[0..3] of TVertex;
- procedure PaintTriangle(V1, V2, V3 : Integer);
- var
- Normale : TVertex;
- begin
- Inc(Triangles);
- Normale := VectorCrossProduct(VectorSubtract(Vertieces[V1], Vertieces[V2]),
- VectorSubtract(Vertieces[V2], Vertieces[V3]));
- NormalizeVector(Normale);
- glNormal3fv(@Normale[0]);
- glBegin(GL_TRIANGLES);
- glVertex3fv(@Vertieces[V1][0]);
- glVertex3fv(@Vertieces[V2][0]);
- glVertex3fv(@Vertieces[V3][0]);
- glEnd()
- end; (*PaintTriangle*)
- begin
- for X := 0 to MapResolution - 1 do
- for Z := 0 to MapResolution - 1 do
- begin
- //Alle Vertieces erzeugen
- for I := 0 to 3 do
- begin
- Vertieces[I][0] := (X + VertPos[I][0])/MapResolution*MapSize;
- Vertieces[I][2] := (Z + VertPos[I][1])/MapResolution*MapSize;
- Vertieces[I][1] := MapDaten[X + VertPos[I][0],Z + VertPos[I][1]]
- end;
- PaintTriangle(0,1,3);
- PaintTriangle(1,2,3)
- end
- end; (*PaintHeightMap*)
- var
- Error : LongInt;
- begin
- Done := True;
- if not OpenGLInitialized then Exit;
- Done := False;
- Triangles := 0;
- glClear(GL_DEPTH_BUFFER_BIT or GL_COLOR_BUFFER_BIT);
- glLoadIdentity;
- glRotatef(XRotation, 1, 0,0);
- glRotatef(YRotation, 0, 1,0);
- CheckKeys;
- glTranslatef(PosX,PosY,PosZ);
- glRotatef(Rotate,0,1,0);
- glPushAttrib(GL_LIGHTING);
- glDisable(GL_LIGHTING);
- PaintSkyBox;
- glPopAttrib();
- glClear(GL_DEPTH_BUFFER_BIT);
- glTranslatef(-(MapSize div 2), -200, -(MapSize div 2));
- PaintHeightMap;
- //Error Handler
- Error := glgetError;
- if Error <> GL_NO_ERROR then
- begin
- MessageBeep(65535);
- Caption := gluErrorString(Error)
- end;
- //Frame Counter
- Inc(Frames);
- if GetTickCount - StartTick >=1000 then
- begin
- Caption := Format('Sky Box Demo FPS: %f Triangles: %d', [Frames/(GetTickCount - StartTick)*1000,
- Triangles]);
- Frames := 0;
- StartTick := GetTickCount
- end;
- SwapBuffers(Canvas.Handle)
- end;
- procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
- Shift: TShiftState; X, Y: Integer);
- begin
- MouseCapture := True;
- MouseX := X;
- MouseY := Y;
- end;
- procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
- Shift: TShiftState; X, Y: Integer);
- begin
- MouseCapture := False
- end;
- procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
- Shift: TShiftState);
- begin
- Keys[Key] := true;
- end;
- procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word;
- Shift: TShiftState);
- begin
- Keys[Key] := false;
- end;
- end.