OpenGL v Delphi4


Multitexturing

Příklad a zdroják ke stažení (296k)

Nejdříve načtu typy, konstanty, a proměnné. 

type
  PFNGLMULTITEXCOORD1FARBPROC = procedure(target: TGLenum; s,t : TGLfloat); stdcall;
  PFNGLMULTITEXCOORD2FARBPROC = procedure(target: TGLenum; s,t : TGLfloat); stdcall;
  PFNGLMULTITEXCOORD3FARBPROC = procedure(target: TGLenum; s,t : TGLfloat); stdcall;
  PFNGLMULTITEXCOORD4FARBPROC = procedure(target: TGLenum; s,t : TGLfloat); stdcall;
  PFNGLACTIVETEXTUREARBPROC = procedure(target: TGLenum); stdcall;
  PFNGLCLIENTACTIVETEXTUREARBPROC = procedure(target: TGLenum); stdcall;

const
  GL_MAX_TEXTURE_UNITS_ARB = $84E2;
  GL_RGB8 = $8051;
  GL_RGBA8 = $8058;
  GL_TEXTURE0_ARB = $84C0;
  GL_COMBINE_EXT = $8570;
  GL_COMBINE_RGB_EXT = $8571;
  GL_TEXTURE1_ARB = $84C1;

var
  glMultiTexCoord1fARB : PFNGLMULTITEXCOORD1FARBPROC = nil;
  glMultiTexCoord2fARB : PFNGLMULTITEXCOORD2FARBPROC = nil;
  glMultiTexCoord3fARB : PFNGLMULTITEXCOORD3FARBPROC = nil;
  glMultiTexCoord4fARB : PFNGLMULTITEXCOORD4FARBPROC = nil;
  glActiveTextureARB : PFNGLACTIVETEXTUREARBPROC = nil;
  glClientActiveTextureARB : PFNGLCLIENTACTIVETEXTUREARBPROC = nil;
  maxTexelUnits : integer = 1;

Potom nastavim všechny potřebné příkazy. 

procedure InitMultitexture;
begin
    glGetIntegerv(GL_MAX_TEXTURE_UNITS_ARB, @maxTexelUnits);
    glMultiTexCoord1fARB:= wglGetProcAddress('glMultiTexCoord1fARB');
    glMultiTexCoord2fARB:= wglGetProcAddress('glMultiTexCoord2fARB');
    glMultiTexCoord3fARB:= wglGetProcAddress('glMultiTexCoord3fARB');
    glMultiTexCoord4fARB:= wglGetProcAddress('glMultiTexCoord4fARB');
    glActiveTextureARB:= wglGetProcAddress('glActiveTextureARB');
    glClientActiveTextureARB    := wglGetProcAddress('glClientActiveTextureARB');
end;

A pak volám proceduru DrawQuad, která mi vyrenderuje čtverec a načte dvě textury do tohoto čtverce. 

procedure DrawQuad;
begin

    glActiveTextureARB(GL_TEXTURE0_ARB);
    glBindTexture(GL_TEXTURE_2D, TextureBin[1]);
    glTexEnvf(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE);
    glEnable(GL_TEXTURE_2D);
    glActiveTextureARB(GL_TEXTURE1_ARB);
    glBindTexture(GL_TEXTURE_2D, TextureBin[2]);
    glTexEnvf(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);
    glEnable(GL_TEXTURE_2D);

    a := a + 0.001;
    if a = 1 then a := 0;

    glBegin(GL_TRIANGLES);

      glMultiTexCoord2fARB(GL_TEXTURE0_ARB, 0, 0);
      glMultiTexCoord2fARB(GL_TEXTURE1_ARB, 0+a, 0+a);
      glVertex3f(-3, 3,0);

      glMultiTexCoord2fARB(GL_TEXTURE0_ARB, 1, 0);
      glMultiTexCoord2fARB(GL_TEXTURE1_ARB, 1+a, 0+a);
      glVertex3f( 3, 3,0);

      glMultiTexCoord2fARB(GL_TEXTURE0_ARB, 0, 1);
      glMultiTexCoord2fARB(GL_TEXTURE1_ARB, 0+a, 1+a);
      glVertex3f(-3,-3,0);

      glMultiTexCoord2fARB(GL_TEXTURE0_ARB, 1, 0);
      glMultiTexCoord2fARB(GL_TEXTURE1_ARB, 1+a, 0+a);
      glVertex3f( 3, 3,0);

      glMultiTexCoord2fARB(GL_TEXTURE0_ARB, 0, 1);
      glMultiTexCoord2fARB(GL_TEXTURE1_ARB, 0+a, 1+a);
      glVertex3f(-3,-3,0);

      glMultiTexCoord2fARB(GL_TEXTURE0_ARB, 1, 1);
      glMultiTexCoord2fARB(GL_TEXTURE1_ARB, 1+a, 1+a);
      glVertex3f( 3,-3,0);

    glEnd;

end;

glActiveTextureARB(GL_TEXTURE0_ARB); - Aktivuje první texturu.
glBindTexture(GL_TEXTURE_2D, TextureBin[1]); - Načítá první texturu.
GL_TEXTURE_2D - Dvojrozměrná textura.
TextureBin[1] - Číslo textury. Musí být integer.
glTexEnvf(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE); - Namapuje texturu.
GL_TEXTURE_ENV - Specifikuje cíl texturového mapování. Musí být vždy GL_TEXTURE_ENV.
GL_TEXTURE_ENV_MODE - Specifikuje jméno texturového mapování. Musí být vždy GL_TEXTURE_ENV_MODE
GL_REPLACE - Parametr. Pokud se dá GL_REPLACE, tak se objekt potažený touto texturou nebude stínovat. Pokud se dá GL_MODULATE, objekt se bude stínovat, musí být samozřejmě nastavený a zapnutý světlo a normálový vektor pro stínování.
glEnable(GL_TEXTURE_2D); - Zapne texturování.
glActiveTextureARB(GL_TEXTURE1_ARB); - Aktivuje druhou texturu.
glBindTexture(GL_TEXTURE_2D, TextureBin[2]); - Náčítá druhou texturu.
GL_TEXTURE_2D - Dvojrozměrná textura.
TextureBin[2] - Číslo textury. Musí být integer.
glTexEnvf(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE); - Namapuje texturu.
GL_TEXTURE_ENV - Specifikuje cíl texturového mapování. Musí být vždy GL_TEXTURE_ENV.
GL_TEXTURE_ENV_MODE - Specifikuje jméno texturového mapování. Musí být vždy GL_TEXTURE_ENV_MODE
GL_MODULATE - Parametr.
glEnable(GL_TEXTURE_2D); - Zapne texturování.
glBegin(GL_TRIANGLES); - Zapne objekt trojúhelník. Čtverec jsem totiž vytvořil ze dvou troujúhelníků.
glMultiTexCoord2fARB(GL_TEXTURE0_ARB, 0, 0); - Texturová koordinace první textury na prvním bodu objektu.
GL_TEXTURE0_ARB - První textura.
0, 0 - X,Y souřadnice koordinace první textury.
glMultiTexCoord2fARB(GL_TEXTURE1_ARB, 0+a, 0+a); - Texturová koordinace druhé textury na prvním bodu objektu.
GL_TEXTURE1_ARB - Druhá textura.
0+a, 0+a - X,Y souřadnice koordinace druhé textury.
glVertex3f(-3, 3,0); - X,Y,Z pozice prvního bodu objektu.

To samé se nastavuje pro všechny body objektu, jen s jinými souřadnicemi koordinace textury.





Textury načítám z obrázků, které jsou ve formátu 'jpg'. Volám proceduru LoadPicture, která zjistí, v jakém formátu je obrázek a podle toho převádí do textury buď z formátu 'bmp', nebo z formátu 'jpg'. 

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;



No a teď můžete mrknout na celej zdroják multitexturing_f.pas 

unit Multitexturing_f;


interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  OpenGL, jpeg;


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 InitQuad;
    procedure InitMultitexture;

    procedure DrawQuad;
    procedure MoveObject;
    procedure DrawScene;
    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);


//mutlitexturing
type
  PFNGLMULTITEXCOORD1FARBPROC = procedure(target: TGLenum; s,t : TGLfloat); stdcall;
  PFNGLMULTITEXCOORD2FARBPROC = procedure(target: TGLenum; s,t : TGLfloat); stdcall;
  PFNGLMULTITEXCOORD3FARBPROC = procedure(target: TGLenum; s,t : TGLfloat); stdcall;
  PFNGLMULTITEXCOORD4FARBPROC = procedure(target: TGLenum; s,t : TGLfloat); stdcall;
  PFNGLACTIVETEXTUREARBPROC = procedure(target: TGLenum); stdcall;
  PFNGLCLIENTACTIVETEXTUREARBPROC = procedure(target: TGLenum); stdcall;

const
  GL_MAX_TEXTURE_UNITS_ARB = $84E2;
  GL_RGB8 = $8051;
  GL_RGBA8 = $8058;
  GL_TEXTURE0_ARB = $84C0;
  GL_COMBINE_EXT = $8570;
  GL_COMBINE_RGB_EXT = $8571;
  GL_TEXTURE1_ARB = $84C1;

var
  glMultiTexCoord1fARB : PFNGLMULTITEXCOORD1FARBPROC = nil;
  glMultiTexCoord2fARB : PFNGLMULTITEXCOORD2FARBPROC = nil;
  glMultiTexCoord3fARB : PFNGLMULTITEXCOORD3FARBPROC = nil;
  glMultiTexCoord4fARB : PFNGLMULTITEXCOORD4FARBPROC = nil;
  glActiveTextureARB : PFNGLACTIVETEXTUREARBPROC = nil;
  glClientActiveTextureARB : PFNGLCLIENTACTIVETEXTUREARBPROC = nil;
  maxTexelUnits : integer = 1;

//other
type TRGBByte=record
     r: byte;
     g: byte;
     b: byte;
end;
type TRGBAByte=record
     r: byte;
     g: byte;
     b: byte;
     a: byte;
end;

type TRGBColors=array[1..1024*1024] of TRGBByte;
     TRGBAColors=array[1..1024*1024] of TRGBAByte;

type TTexture=record
     ColorSystem:TGLEnum;{ defaultne GL_RGB, mozno GL_RGBA }
     FileName:String;
     rgbcolor:^TRGBColors;
     rgbacolor:^TRGBAColors;
     Width:Word;
     Height:Word;
     Mip:boolean;
end;

var
  Form1: TForm1;
  Handles : integer;
  ThreadID : LongWord;
  TextureBin:array[1..256] of word;
  TextureH:TTexture;
  Texture:array[1..256] of TTexture;
  UniPicture:TPicture;
  X,Y,Z,
  a: real;
  AngleX,AngleY,AngleZ: integer;
  KeybUp, KeybDown, KeybRight, KeybLeft, KeybHome, KeybEnd, KeybEsc, KeybMoveUp, KeybMoveDown: boolean;
  RC : HGLRC;

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
  InitWindow;
  InitArea;
  Handles := BeginThread(nil, 0, Thread, nil, 0, ThreadID);
end;

procedure InitWindow;
var
  i: integer;
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);
  InitQuad;
  InitMultitexture;
  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(30.0,Form1.ClientWidth / Form1.ClientHeight,1.0,100.0);
  glViewport(0,0,Form1.ClientWidth,Form1.ClientHeight);
end;

procedure InitQuad;
var
  Path: string;
  i:integer;
begin
  AngleX := 0;
  AngleY := 0;
  AngleZ := 0;
  X := 0; Y := 0; Z := -15.0;
  Path := ExtractFilePath(Application.ExeName);
  InitTexture;
  LoadTexture(1,Path + 'Image1.jpg',gl_rgb8);
  LoadTexture(2,Path + 'Image2.jpg',gl_rgb8);
end;

procedure InitMultitexture;
begin
    glGetIntegerv(GL_MAX_TEXTURE_UNITS_ARB, @maxTexelUnits);
    glMultiTexCoord1fARB        := wglGetProcAddress('glMultiTexCoord1fARB');
    glMultiTexCoord2fARB        := wglGetProcAddress('glMultiTexCoord2fARB');
    glMultiTexCoord3fARB        := wglGetProcAddress('glMultiTexCoord3fARB');
    glMultiTexCoord4fARB        := wglGetProcAddress('glMultiTexCoord4fARB');
    glActiveTextureARB                := wglGetProcAddress('glActiveTextureARB');
    glClientActiveTextureARB    := wglGetProcAddress('glClientActiveTextureARB');
end;

procedure DrawQuad;
begin

    glActiveTextureARB(GL_TEXTURE0_ARB);
    glBindTexture(GL_TEXTURE_2D, TextureBin[1]);
    glTexEnvf(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE);
    glEnable(GL_TEXTURE_2D);
    glActiveTextureARB(GL_TEXTURE1_ARB);
    glBindTexture(GL_TEXTURE_2D, TextureBin[2]);
    glTexEnvf(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);
    glEnable(GL_TEXTURE_2D);

    a := a + 0.001;
    if a = 1 then a := 0;

    glBegin(GL_TRIANGLES);

    glMultiTexCoord2fARB(GL_TEXTURE0_ARB, 0, 0);
    glMultiTexCoord2fARB(GL_TEXTURE1_ARB, 0+a, 0+a);
    glVertex3f(-3, 3,0);

    glMultiTexCoord2fARB(GL_TEXTURE0_ARB, 1, 0);
    glMultiTexCoord2fARB(GL_TEXTURE1_ARB, 1+a, 0+a);
    glVertex3f( 3, 3,0);

    glMultiTexCoord2fARB(GL_TEXTURE0_ARB, 0, 1);
    glMultiTexCoord2fARB(GL_TEXTURE1_ARB, 0+a, 1+a);
    glVertex3f(-3,-3,0);

    glMultiTexCoord2fARB(GL_TEXTURE0_ARB, 1, 0);
    glMultiTexCoord2fARB(GL_TEXTURE1_ARB, 1+a, 0+a);
    glVertex3f( 3, 3,0);

    glMultiTexCoord2fARB(GL_TEXTURE0_ARB, 0, 1);
    glMultiTexCoord2fARB(GL_TEXTURE1_ARB, 0+a, 1+a);
    glVertex3f(-3,-3,0);

    glMultiTexCoord2fARB(GL_TEXTURE0_ARB, 1, 1);
    glMultiTexCoord2fARB(GL_TEXTURE1_ARB, 1+a, 1+a);
    glVertex3f( 3,-3,0);

  glEnd;

end;

procedure MoveObject;
begin
  ProcessKeyb;
  glMatrixMode(GL_MODELVIEW);
  glLoadIdentity;
  glTranslatef(0,0,0);                                //pozice kamery
  glRotatef(AngleX, 1, 0, 0);                        //rotace  X
  glRotatef(AngleY, 0, 1, 0);                        //rotace  Y
  glRotatef(AngleZ, 0, 0, 1);                        //rotace  Z }
  glTranslatef(X,Y,Z);                                //pozice kamery
end;

procedure DrawScene;
begin
  wglMakeCurrent(Form1.Canvas.Handle,RC);
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
  MoveObject;
  DrawQuad;
  glFlush;
  SwapBuffers(Form1.Canvas.Handle);
  wglMakeCurrent(0,0)
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  //šipka nahoru
       KeybUp := True;
    end;
  end;
  case Key of
    VK_DOWN: begin //šipka dolu
      KeybDown := True;
    end;
  end;
  case Key of
    VK_RIGHT: begin //doprava
      KeybRight := True;
    end;
  end;
  case Key of
    VK_LEFT: begin //doleva
      KeybLeft := True;
    end;
  end;
  case Key of
    VK_Home: begin //doprava
      KeybHome := True;
    end;
  end;
  case Key of
    VK_END: begin //doleva
      KeybEnd := True;
    end;
  end;
  case Key of
    27: begin //Q - Quit
      Application.Terminate;
      RestoreMode;
    end;
  end;
  case Key of
    VK_Return: begin //Enter
      SetFullScreen(640,480,16);
    end;
  end;
  case Key of
    VK_Prior: begin //pohyb nahoru
      KeybMoveUp := True;
    end;
  end;
  case Key of
    VK_Next: begin //pohyb dolu
      KeybMoveDown := True;
    end;
  end;
end;

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  case Key of
    VK_UP: begin  //šipka nahoru
       KeybUp := False;
    end;
  end;
  case Key of
    VK_DOWN: begin //šipka dolu
      KeybDown := False;
    end;
  end;
  case Key of
    VK_RIGHT: begin //doprava
      KeybRight := False;
    end;
  end;
  case Key of
    VK_LEFT: begin //doleva
      KeybLeft := False;
    end;
  end;
  case Key of
    VK_Home: begin //pohled nahoru
      KeybHome := False;
    end;
  end;
  case Key of
    VK_END: begin //pohled dolu
      KeybEnd := False;
    end;
  end;
  case Key of
    VK_Prior: begin //pohyb nahoru
      KeybMoveUp := False;
    end;
  end;
  case Key of
    VK_Next: begin //pohyb dolu
      KeybMoveDown := False;
    end;
  end;
end;

procedure ProcessKeyb;
begin
  if KeybUp then begin
    Z := Z + ((-sin((AngleY - 90) * (Pi/180))) * 0.08);
    X := X - ((sin((AngleY) * (Pi/180))) * 0.08);
  end;
  if KeybDown then begin
      Z := Z - ((-sin((AngleY - 90) * (Pi/180))) * 0.08);
      X := X + ((sin((AngleY) * (Pi/180))) * 0.08);
  end;
  if KeybRight then begin
      AngleY := AngleY + 1;
  end;
  if KeybLeft then begin
      AngleY := AngleY - 1;
  end;
  if KeybHome then begin
      AngleX := AngleX - 1;
  end;
  if KeybEnd then begin
      AngleX := AngleX + 1;
  end;
  if KeybMoveUp then begin
    Y := Y - 0.08;
  end;
  if KeybMoveDown then begin
    Y := Y + 0.08;
  end;
end;

end.



Detekce kolizí Výpočet koule, normálových vektorů, texturové koordinace
Home