OpenGL inicializálása

Ez egy példa arra, hogy egy teljes formot hogyan alkalmazhatunk OpenGL felületként;

A Draw rutinba írhatod meg a saját grafikus utasításaidat.

unit gl_1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

OpenGL, JPeg, ExtCtrls;

type

PPixelArray = ^TPixelArray;

TPixelArray = array [0..0] of Byte;

TPoint2d = record

   x,y: double;

end;

TForm1 = class(TForm)

   procedure FormCreate(Sender: TObject);

   procedure FormDestroy(Sender: TObject);

   procedure FormResize(Sender: TObject);

   procedure FormActivate(Sender: TObject);

   procedure FormKeyDown(Sender: TObject; var Key: Word;

     Shift: TShiftState);

   procedure FormKeyPress(Sender: TObject; var Key: Char);

private

   FZoom: double;

   FRotAngle: double;

   FCentrum: TPoint2d;

   procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;

   procedure WMEraseBkGnd(var Message:TWMEraseBkGnd); message WM_ERASEBKGND;

   function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;

     MousePos: TPoint): Boolean; override;

   Procedure CMChildkey( Var msg: TCMChildKey ); message CM_CHILDKEY;

   procedure SetZoom(const Value: double);

   procedure SetRotAngle(const Value: double);

   procedure SetCentrum(const Value: TPoint2d);

private

   DC: HDC;

   hrc: HGLRC;

   Tex: cardinal;

   oLeft,oRight,oBottom,oTop : double;

   x,y: double;

   procedure SetDCPixelFormat;

   procedure Draw;

   function CreateTexture(Texture: String): cardinal;

public

   property Centrum: TPoint2d read FCentrum write SetCentrum;

   property Zoom: double read FZoom write SetZoom;

   property RotAngle: double read FRotAngle write SetRotAngle;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

Initopengl;

DC := GetDC(Handle);

SetDCPixelFormat;

hrc := wglCreateContext(DC);

wglMakeCurrent(DC, hrc);

glShadeModel(GL_SMOOTH);

glEnable(GL_TEXTURE_2D);

glEnable(GL_ALPHA_TEST);

glEnable(GL_BLEND);

glBlendFunc(GL_ONE,GL_ONE);

glMatrixMode(GL_PROJECTION);

glViewport(0, 0, ClientWidth, ClientHeight);

FCentrum.x := 0; FCentrum.y := 0;

oLeft:=-10; oRight:=10; oBottom:=-10; oTop := 10;

FZoom := 0.5;

FRotAngle := 0;

x:=0; y:=0;

end;

procedure TForm1.FormActivate(Sender: TObject);

begin

//  Tex := CreateTexture('Texture.jpg');

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

wglMakeCurrent(0, 0);

wglDeleteContext(hrc);

ReleaseDC(Handle, DC);

closeopengl;

end;

procedure TForm1.SetDCPixelFormat;

var

nPixelFormat: Integer;

pfd: TPixelFormatDescriptor;

begin

FillChar(pfd, SizeOf(pfd), 0);

with pfd do begin

   nSize     := sizeof(pfd);

   nVersion  := 1;

   dwFlags   := PFD_DRAW_TO_WINDOW or

                PFD_SUPPORT_OPENGL or

                PFD_DOUBLEBUFFER;

   iPixelType:= PFD_TYPE_RGBA;

   cColorBits:= 16;

   cDepthBits:= 16;

   iLayerType:= PFD_MAIN_PLANE;

end;

nPixelFormat := ChoosePixelFormat(DC, @pfd);

SetPixelFormat(DC, nPixelFormat, @pfd);

end;

procedure TForm1.Draw;

var ps : TPaintStruct;

begin

BeginPaint(Handle, ps);

glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);

glLoadIdentity();

// Draw a Rectangle

glColor3d(1,0,0);

glTranslatef(x,y,1);

glRotatef(FRotAngle,0,0,1);

glRectf(1.1,1.1,-1.1,-1.1);

glBegin(GL_LINE_STRIP);

glEnd;

glPopMatrix;

SwapBuffers(DC);

EndPaint(Handle, ps);

end;

procedure TForm1.WMPaint(var Msg: TWMPaint);

begin

FormResize(nil);

end;

procedure TForm1.FormResize(Sender: TObject);

begin

if (Height=0)

   then Height:=1;

glViewport(0, 0, Width, Height);

glMatrixMode(GL_PROJECTION);

glLoadIdentity();

gluOrtho2d(oLeft,oRight,oBottom,oTop);

glMatrixMode(GL_MODELVIEW);

Draw;

end;

function TForm1.CreateTexture(Texture : String): cardinal;

var

bitmap: TBitmap;

BMInfo : TBitmapInfo;

I, ImageSize : Integer;

Temp : Byte;

MemDC : HDC;

Picture: TJpegImage;

Tex: PPixelArray;

begin

glenable(GL_TEXTURE_2D);

glGenTextures(1, @Result);

glBindTexture(GL_TEXTURE_2D, Result);

Bitmap:=TBitMap.Create;

Picture:=TJpegImage.Create;

Picture.LoadFromFile(Texture);

Bitmap.Assign(Picture);

with BMinfo.bmiHeader do begin

   FillChar (BMInfo, SizeOf(BMInfo), 0);

   biSize := sizeof (TBitmapInfoHeader);

   biBitCount := 24;

   biWidth := Picture.Width;

   biHeight := Picture.Height;

   ImageSize := biWidth * biHeight;

   biPlanes := 1;

   biCompression := BI_RGB;

   MemDC := CreateCompatibleDC (0);

   GetMem (Tex, ImageSize *3);

   try

     GetDIBits (MemDC, Bitmap.Handle, 0, biHeight, Tex, BMInfo, DIB_RGB_COLORS);

     glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);

     glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER,GL_LINEAR);

     glTexImage2d(GL_TEXTURE_2D, 0, 3, biwidth, biheight, 0, GL_BGR_EXT, GL_UNSIGNED_BYTE, tex);

     For I := 0 to ImageSize - 1 do begin

         Temp := tex [I * 3];

         tex [I * 3] := tex [I * 3 + 2];

         tex [I * 3 + 2] := Temp;

     end;

    finally

     DeleteDC (MemDC);

     Bitmap.Free;

     Picture.Free;

     freemem(tex);

  end;

end;

end;

procedure TForm1.SetZoom(const Value: double);

var dx,dy: double;

begin

dx := oRight - FCentrum.x;

dy := oTop - FCentrum.y;

oLeft := FCentrum.x-dx*FZoom/Value;

oRight:= FCentrum.x+dx*FZoom/Value;

oBottom := FCentrum.y-dy*FZoom/Value;

oTop := FCentrum.y+dy*FZoom/Value;

FZoom := Value;

FormResize(nil);

end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

Case Key of

VK_ESCAPE    : Close;

VK_ADD       : Zoom := Zoom*1.1;

VK_SUBTRACT  : Zoom := Zoom*0.9;

end;

end;

procedure TForm1.WMEraseBkGnd(var Message: TWMEraseBkGnd);

begin

Message.Result := 1

end;

procedure TForm1.SetRotAngle(const Value: double);

begin

FRotAngle := Value;

invalidate;

end;

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);

begin

Case Key of

'l' : RotAngle := FRotAngle+1;

'r' : RotAngle := FRotAngle-1;

end;

end;

procedure TForm1.CMChildkey(var msg: TCMChildKey);

var dx,dy : double;

   k     :double;

begin

k:=0.05;

dx := 0; dy:=0;

msg.result := 1; // declares key as handled

Case msg.charcode of

   VK_LEFT    : dx:=-k;

   VK_RIGHT   : dx:=k;

   VK_UP      : dy:=-k;

   VK_DOWN    : dy:=k;

else

   msg.result := 0;

end;

if (dx<>0) or (dy<>0) then begin

    x:=x+dx;y:=y+dy

end;

invalidate;

end;

procedure TForm1.SetCentrum(const Value: TPoint2d);

var dx,dy: double;

begin

dx := Value.x - FCentrum.x;

dy := Value.y - FCentrum.y;

oLeft := oLeft+dx;

oRight:= oRight+dx;

oBottom := oBottom+dy;

oTop := oTop+dy;

FCentrum := Value;

invalidate;

end;

function TForm1.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;

MousePos: TPoint): Boolean;

begin

if WheelDelta>0 then Zoom:=FZoom*1.1;

if WheelDelta<0 then Zoom:=FZoom*0.9;

end;

end.