{ This Code Was Created By Jan Koci 2001 Visit My Site At koci.opengl.cz } unit Transp_f; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, OpenGL, jpeg, Menus, StdCtrls, Math; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure FormPaint(Sender: TObject); procedure FormResize(Sender: TObject); procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); procedure ClearFace(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; end; procedure InitScene; procedure InitWindow; procedure PixelFormat(DC : HDC); procedure InitArea; procedure DrawScene; procedure MoveObject; procedure InitTriangleTexture; procedure DrawBackground; procedure DrawButterfly; procedure SetFullScreen(SizeX,SizeY,Bits:longint); procedure RestoreMode; procedure ProcessKeyb; procedure InitTexture; procedure LoadTexture(Num:LongInt;FileName:string;Typ:word); procedure LoadPicture(FileName:String;var Pic:TPicture); procedure StoreTexture(Num:LongInt;Pic:TPicture); procedure SetTexture(Num:Longint;Typ:word); //Textures type TRGBByte=record r: TGLubyte; g: TGLubyte; b: TGLubyte; end; type TRGBAByte=record r: TGLubyte; g: TGLubyte; b: TGLubyte; a: TGLubyte; end; type TRGBColors=array[1..1024*1024] of TRGBByte; TRGBAColors=array[1..1024*1024] of TRGBAByte; type TTexture=record ColorSystem:TGLEnum; FileName:String; rgbcolor:^TRGBColors; rgbacolor:^TRGBAColors; Width:Word; Height:Word; Mip:boolean; end; //Triangles type TPoint3=record x: TGLFloat; y: TGLFloat; z: TGLFloat; end; type TPoint2=record x: TGLInt; y: TGLInt; end; var Point1, Point2, Point3, Point4: array [1..3] of TPoint3; Coord1, Coord2, Coord3, Coord4: array [1..3] of TPoint2; ViewAngle, NearClip, FarClip: TGLFloat; //other var Form1: TForm1; Handles : integer; ThreadID : LongWord; TextureBin:array[1..256] of word; TextureH:TTexture; Texture:array[1..256] of TTexture; UniPicture:TPicture; Angle, Tran: TPoint3; KeybUp, KeybDown, KeybRight, KeybLeft, KeybHome, KeybEnd, KeybEsc, KeybMoveUp, KeybMoveDown: boolean; RC : HGLRC; MoveSpeed: single=0.1; const PFDError = 'Chyba při nastavení PFD.'; implementation {$R *.DFM} function Thread(P : pointer) : integer; var i: integer; begin i := 1; repeat Form1.Repaint; until i = 2; end; procedure TForm1.FormCreate(Sender: TObject); begin InitScene; end; procedure InitScene; begin Tran.Z := -25; ViewAngle := 30; NearClip := 0.1; FarClip := 100000; Coord1[1].x := 0; Coord1[1].y := 0; Coord2[1].x := 1; Coord2[1].y := 0; Coord3[1].x := 0; Coord3[1].y := 1; Coord4[1].x := 1; Coord4[1].y := 1; Point1[1].x := -160; Point1[1].y := 120; Point1[1].z := 0; Point2[1].x := 160; Point2[1].y := 120; Point2[1].z := 0; Point3[1].x := -160; Point3[1].y := -120; Point3[1].z := 0; Point4[1].x := 160; Point4[1].y := -120; Point4[1].z := 0; Coord1[2].x := 0; Coord1[2].y := 0; Coord2[2].x := 1; Coord2[2].y := 0; Coord3[2].x := 0; Coord3[2].y := 1; Coord4[2].x := 1; Coord4[2].y := 1; Point1[2].x := -3; Point1[2].y := 3; Point1[2].z := 2; Point2[2].x := 3; Point2[2].y := 3; Point2[2].z := 2; Point3[2].x := -3; Point3[2].y := -3; Point3[2].z := 2; Point4[2].x := 3; Point4[2].y := -3; Point4[2].z := 2; Coord1[3].x := 0; Coord1[3].y := 0; Coord2[3].x := 1; Coord2[3].y := 0; Coord3[3].x := 0; Coord3[3].y := 1; Coord4[3].x := 1; Coord4[3].y := 1; Point1[3].x := -3; Point1[3].y := 3; Point1[3].z := 2.1; Point2[3].x := 3; Point2[3].y := 3; Point2[3].z := 2.1; Point3[3].x := -3; Point3[3].y := -3; Point3[3].z := 2.1; Point4[3].x := 3; Point4[3].y := -3; Point4[3].z := 2.1; InitWindow; InitArea; Handles := BeginThread(nil, 0, Thread, nil, 0, ThreadID); end; procedure InitWindow; begin PixelFormat(Form1.Canvas.Handle); RC := wglCreateContext(Form1.Canvas.Handle); wglMakeCurrent(Form1.Canvas.Handle,RC); glClearColor(0.0,0.0,0.0,0.0); glShadeModel(GL_SMOOTH); glEnable(GL_DEPTH_TEST); InitTriangleTexture; wglMakeCurrent(0,0); end; procedure PixelFormat(DC : HDC); var PFD : TPixelFormatDescriptor; nPixelFormat : integer; begin FillChar(PFD,SizeOf(PFD),0); with PFD do begin nSize := SizeOf(TPixelFormatDescriptor); nVersion := 1; dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER; iPixelType := PFD_TYPE_RGBA; cColorBits := 24; cDepthBits := 32; iLayerType := PFD_MAIN_PLANE; end; nPixelFormat := ChoosePixelFormat(DC,@PFD); Assert(nPixelFormat <> 0,PFDError); SetPixelFormat(DC,nPixelFormat,@PFD) end; procedure InitArea; begin glMatrixMode(GL_PROJECTION); glLoadIdentity; gluPerspective(ViewAngle,Form1.ClientWidth / Form1.ClientHeight,NearClip,FarClip); glViewport(0,0,Form1.ClientWidth,Form1.ClientHeight); end; procedure DrawScene; begin wglMakeCurrent(Form1.Canvas.Handle,RC); glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); DrawBackground; MoveObject; DrawButterfly; glFlush; SwapBuffers(Form1.Canvas.Handle); wglMakeCurrent(0,0) end; procedure MoveObject; begin ProcessKeyb; glMatrixMode(GL_MODELVIEW); glLoadIdentity; glPushMatrix; glTranslatef(0,0,0); glRotatef(Angle.x, 1, 0, 0); glRotatef(Angle.y, 0, 1, 0); glRotatef(Angle.z, 0, 0, 1); glTranslatef(Tran.X,Tran.Y,Tran.Z); end; procedure InitTriangleTexture; var Path: string; begin Path := ExtractFilePath(Application.ExeName); InitTexture; LoadTexture(1,Path + 'back.jpg',gl_rgb8); LoadTexture(2,Path + 'mask.jpg',gl_rgb8); LoadTexture(3,Path + 'bab.jpg',gl_rgb8); end; procedure DrawBackground; begin glPushMatrix; glTranslatef(0,0,-400); glDisable(GL_BLEND); glBindTexture(GL_TEXTURE_2D, TextureBin[1]); glEnable(GL_TEXTURE_2D); glBegin(GL_TRIANGLES); glTexCoord2f(Coord1[1].x,Coord1[1].y); glVertex3f(Point1[1].x,Point1[1].y,Point1[1].z); glTexCoord2f(Coord2[1].x,Coord2[1].y); glVertex3f(Point2[1].x,Point2[1].y,Point2[1].z); glTexCoord2f(Coord3[1].x,Coord3[1].y); glVertex3f(Point3[1].x,Point3[1].y,Point3[1].z); ////////////////////////////////////////////////// glTexCoord2f(Coord2[1].x,Coord2[1].y); glVertex3f(Point2[1].x,Point2[1].y,Point2[1].z); glTexCoord2f(Coord3[1].x,Coord3[1].y); glVertex3f(Point3[1].x,Point3[1].y,Point3[1].z); glTexCoord2f(Coord4[1].x,Coord4[1].y); glVertex3f(Point4[1].x,Point4[1].y,Point4[1].z); glEnd; glPopMatrix; end; procedure DrawButterfly; var i: integer; begin for i := 2 to 3 do begin glEnable(GL_BLEND); if i = 2 then glBlendFunc(GL_DST_COLOR,GL_ZERO); if i = 3 then glBlendFunc(GL_ONE, GL_ONE); glBindTexture(GL_TEXTURE_2D, TextureBin[i]); glEnable(GL_TEXTURE_2D); glBegin(GL_TRIANGLES); glTexCoord2f(Coord1[i].x,Coord1[i].y); glVertex3f(Point1[i].x,Point1[i].y,Point1[i].z); glTexCoord2f(Coord2[i].x,Coord2[i].y); glVertex3f(Point2[i].x,Point2[i].y,Point2[i].z); glTexCoord2f(Coord3[i].x,Coord3[i].y); glVertex3f(Point3[i].x,Point3[i].y,Point3[i].z); ////////////////////////////////////////////////// glTexCoord2f(Coord2[i].x,Coord2[i].y); glVertex3f(Point2[i].x,Point2[i].y,Point2[i].z); glTexCoord2f(Coord3[i].x,Coord3[i].y); glVertex3f(Point3[i].x,Point3[i].y,Point3[i].z); glTexCoord2f(Coord4[i].x,Coord4[i].y); glVertex3f(Point4[i].x,Point4[i].y,Point4[i].z); glEnd; end; glDisable(GL_BLEND); glPopMatrix; end; procedure SetFullScreen(SizeX,SizeY,Bits:longint); var dmScreenSettings: DEVMODE; begin ZeroMemory( @dmScreenSettings, sizeof( DEVMODE ) ); dmScreenSettings.dmSize := sizeof( DEVMODE ); dmScreenSettings.dmPelsWidth := SizeX; // Width dmScreenSettings.dmPelsHeight := SizeY; // Height dmScreenSettings.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT; // Color Depth dmScreenSettings.dmBitsPerPel := Bits; ChangeDisplaySettings(dmScreenSettings, CDS_FULLSCREEN); // Switch To Fullscreen Mode Form1.WindowState := wsMaximized; end; procedure RestoreMode; begin ChangeDisplaySettings(DEVMODE(nil^), 0); end; procedure InitTexture; var a:word; f:TGluint; begin UniPicture:=TPicture.Create; for a:=1 to 256 do begin glGenTextures(1, @f);TextureBin[a]:=f; end; for a:=1 to 256 do begin with texture[a] do begin rgbacolor:=nil; rgbcolor:=nil; ColorSystem:=Gl_RGB; glBindTexture(GL_TEXTURE_2D,TextureBin[a]); glTexParameterf(GL_Texture_2D,GL_Texture_Wrap_S,gl_repeat); glTexParameterf(GL_Texture_2D,GL_Texture_Wrap_T,gl_repeat); glTexParameterf(GL_Texture_2D,GL_Texture_Mag_Filter,GL_Linear); glTexParameterf(GL_Texture_2D,GL_Texture_Min_Filter,GL_Linear); glTexEnvf(GL_Texture_Env, GL_Texture_Env_Mode, GL_MODULATE); end; end; end; procedure LoadTexture(Num:LongInt;FileName:string;Typ:word); begin if (Typ=gl_rgba2) or (Typ=gl_rgba4) or (Typ=gl_rgba8) or (Typ=gl_rgba16) then texture[num].colorsystem:=gl_rgba else texture[num].colorsystem:=gl_rgb; LoadPicture(FileName,UniPicture); texture[num].filename:=ExtractFileName(FileName); StoreTexture(Num,UniPicture); SetTexture(Num,Typ); end; procedure LoadPicture(FileName:String;var Pic:TPicture); var Y:TPicture; temp:boolean; searchrec:tsearchrec; begin filename:=uppercase(filename); if findfirst(filename,$3f,searchrec)<>0 then begin MessageDlg('Picture '+filename+' not found !!!', mtError, [mbOK], 0); halt; end; if ExtractFileExt(FileName)='.JPG' then begin Y:=TPicture.Create; Y.LoadFromFile(FileName); temp:=y.Graphic is TJPEGImage; if temp then begin Pic.Bitmap.Width:=y.Graphic.Width; Pic.Bitmap.Height:=y.Graphic.Height; Pic.Bitmap.Canvas.draw(0,0,Y.Graphic); end; Y.Free; end; if ExtractFileExt(FileName)='.BMP' then begin Pic.LoadFromFile(FileName); end; end; procedure StoreTexture(Num:LongInt;Pic:TPicture); var bih : TBitmapInfoHeader; bi : TBitmapInfo; poz,poz2:longint; i,j : longint; begin with Texture[Num] do begin Width:=Pic.Bitmap.Width;Height:=Pic.Bitmap.Height; TextureH.rgbcolor:=AllocMem(Width*Height*sizeof(TRGBByte)); end; with bih do begin biSize:=SizeOf(bih); biWidth:=Pic.width;biHeight:=Pic.height; biPlanes:=1;biBitCount:=24;biCompression:=BI_RGB; biSizeImage:=Pic.width; biXPelsPerMeter:=0;biYPelsPerMeter:=0;biClrImportant:=0; biClrUsed := 0; end; bi.bmiHeader := bih; GetDIBits(Pic.Bitmap.Canvas.Handle,Pic.Bitmap.Handle,0,Pic.width,textureH.rgbcolor,bi,dib_rgb_colors); with Texture[Num] do begin if ColorSystem=GL_RGB then begin rgbcolor:=AllocMem(Width*Height*sizeof(TRGBByte)); for i := 0 to Pic.height-1 do begin for j := 1 to Pic.width do begin poz:=j+i*texture[num].width; poz2:=j+((pic.height-1)-i)*texture[num].width; with texture[num].rgbcolor^[poz2] do begin r:=textureH.rgbcolor^[poz].b; g:=textureH.rgbcolor^[poz].g; b:=textureH.rgbcolor^[poz].r; end; end; end; end else begin rgbacolor:=AllocMem(Width*Height*sizeof(TRGBAByte)); for i := 0 to Pic.height-1 do begin for j := 1 to Pic.width do begin poz:=j+i*texture[num].width; poz2:=j+((pic.height-1)-i)*texture[num].width; with texture[num].rgbacolor^[poz2] do begin r:=textureH.rgbcolor^[poz].b; g:=textureH.rgbcolor^[poz].g; b:=textureH.rgbcolor^[poz].r; if r+g+b=0 then a:=0 else a:=255; end; end; end; end; end; FreeMem(TextureH.rgbcolor); end; procedure SetTexture(Num:Longint;Typ:word); begin with Texture[Num] do begin Mip:=false; glBindTexture(GL_TEXTURE_2D,TextureBin[num]); if ColorSystem=GL_RGB then begin glTexImage2d(GL_Texture_2D,0,TYP,width,height,0,GL_RGB,GL_Unsigned_byte,rgbcolor); end else begin glTexImage2d(GL_Texture_2D,0,TYP,width,height,0,GL_RGBA,GL_Unsigned_byte,rgbacolor); end; end; end; procedure TForm1.ClearFace(var Message: TWMEraseBkgnd); begin Message.Result := 1; end; procedure TForm1.FormDestroy(Sender: TObject); begin wglDeleteContext(RC); end; procedure TForm1.FormPaint(Sender: TObject); begin DrawScene; end; procedure TForm1.FormResize(Sender: TObject); begin wglMakeCurrent(Canvas.Handle,RC); InitArea; DrawScene; wglMakeCurrent(0,0); end; procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin case Key of VK_UP: begin //Forward KeybUp := True; end; end; case Key of VK_DOWN: begin //Backward KeybDown := True; end; end; case Key of VK_RIGHT: begin //Rotate right KeybRight := True; end; end; case Key of VK_LEFT: begin //Rotate left KeybLeft := True; end; end; case Key of VK_Home: begin //Look up KeybHome := True; end; end; case Key of VK_END: begin //Look down KeybEnd := True; end; end; case Key of 27: begin //Q - Quit Application.Terminate; RestoreMode; end; end; case Key of VK_Return: begin //Full Screen SetFullScreen(640,480,16); end; end; case Key of VK_Prior: begin //move up KeybMoveUp := True; end; end; case Key of VK_Next: begin //move down KeybMoveDown := True; end; end; end; procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); begin case Key of VK_UP: begin //Forward KeybUp := False; end; end; case Key of VK_DOWN: begin //Backward KeybDown := False; end; end; case Key of VK_RIGHT: begin //Rotate right KeybRight := False; end; end; case Key of VK_LEFT: begin //Rotate left KeybLeft := False; end; end; case Key of VK_Home: begin //Look up KeybHome := False; end; end; case Key of VK_END: begin //Look down KeybEnd := False; end; end; case Key of VK_Prior: begin //move up KeybMoveUp := False; end; end; case Key of VK_Next: begin //move down KeybMoveDown := False; end; end; end; procedure ProcessKeyb; begin if KeybUp then begin Tran.Z := Tran.Z + ((-sin((Angle.Y - 90) * (Pi/180))) * MoveSpeed); Tran.X := Tran.X - ((sin((Angle.Y) * (Pi/180))) * MoveSpeed); end; if KeybDown then begin Tran.Z := Tran.Z - ((-sin((Angle.Y - 90) * (Pi/180))) * MoveSpeed); Tran.X := Tran.X + ((sin((Angle.Y) * (Pi/180))) * MoveSpeed); end; if KeybRight then begin Tran.X := Tran.X + MoveSpeed; end; if KeybLeft then begin Tran.X := Tran.X - MoveSpeed; end; if KeybHome then begin // Angle.X := Angle.X - 1; end; if KeybEnd then begin // Angle.X := Angle.X + 1; end; if KeybMoveUp then begin Tran.Y := Tran.Y + MoveSpeed; end; if KeybMoveDown then begin Tran.Y := Tran.Y - MoveSpeed; end; end; end.