Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
OpenGL - радиальное размытие

Пасьянс косынка - сильнодействующий психотропный препарат для нейролингвистического зомбирования разработанный в секретной лаборатории КГБ Ұ7708. Вызывает 100%-ное привыкание с первой дозы. Позволяет контролировать сознание косынкоманов, подавляет желание работать, вызывает состояние апатии и расслабленности. Побочные эффекты: редкие уколы совести (надо поработать), но проходит по мере увеличения дозы препарата.


// К заголовку RadialBlur(For OpenGL)
// Данный код работает правильно только, если в пректе 0 форм ,
// а сам код введен в DPR файл!

program RadialBlur;

uses
  Windows,
  Messages,
  OpenGL;

const
  WND_TITLE = 'Radial Blur';
  FPS_TIMER = 1; // Timer to calculate FPS
  FPS_INTERVAL = 1000; // Calculate FPS every 1000 ms

type
  TVector = array[0..2] of glFloat;
var
  h_Wnd: HWND; // Global window handle
  h_DC: HDC; // Global device context
  h_RC: HGLRC; // OpenGL rendering context
  keys: array[0..255] of Boolean; // Holds keystrokes
  FPSCount: Integer = 0; // Counter for FPS
  ElapsedTime: Integer; // Elapsed time between frames

  // Textures
  BlurTexture: glUint; // An Unsigned Int To Store The Texture Number

  // User vaiables
  Angle: glFloat;
  Vertexes: array[0..3] of TVector;
  normal: TVector;

  // Lights and Materials
  globalAmbient: array[0..3] of glFloat = (0.2, 0.2, 0.2, 1.0);
  // Set Ambient Lighting To Fairly Dark Light (No Color)
  Light0Pos: array[0..3] of glFloat = (0.0, 5.0, 10.0, 1.0);
  // Set The Light Position
  Light0Ambient: array[0..3] of glFloat = (0.2, 0.2, 0.2, 1.0);
  // More Ambient Light
  Light0Diffuse: array[0..3] of glFloat = (0.3, 0.3, 0.3, 1.0);
  // Set The Diffuse Light A Bit Brighter
  Light0Specular: array[0..3] of glFloat = (0.8, 0.8, 0.8, 1.0);
  // Fairly Bright Specular Lighting

  LmodelAmbient: array[0..3] of glFloat = (0.2, 0.2, 0.2, 1.0);
  // And More Ambient Light

{$R *.RES}

procedure glBindTexture(target: GLenum; texture: GLuint);
  stdcall; external opengl32;

procedure glGenTextures(n: GLsizei; var textures: GLuint);
  stdcall; external opengl32;

procedure glCopyTexSubImage2D(target: GLenum; level, xoffset,
  yoffset, x, y: GLint; width, height: GLsizei);
  stdcall; external opengl32;

procedure glCopyTexImage2D(target: GLenum; level: GLint;
  internalFormat: GLenum; x, y: GLint;
  width, height: GLsizei; border: GLint); stdcall; external opengl32;

{------------------------------------------------------------------}
{ Function to convert int to string. (No sysutils = smaller EXE) }
{------------------------------------------------------------------}
// using SysUtils increase file size by 100K

function IntToStr(Num: Integer): string;
begin
  Str(Num, result);
end;

function EmptyTexture: glUint;
var
  txtnumber: glUint;
  data: array of glUint;
  pData: Pointer;
begin
  // Create Storage Space For Texture Data (128x128x4)
  GetMem(pData, 128 * 128 * 4);

  glGenTextures(1, txtnumber); // Create 1 Texture
  glBindTexture(GL_TEXTURE_2D, txtnumber); // Bind The Texture
  glTexImage2D(GL_TEXTURE_2D, 0, 4, 128, 128, 0, GL_RGBA,
    GL_UNSIGNED_BYTE, pData);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);

  result := txtNumber;
end;

procedure ReduceToUnit(var vector: array of glFloat);
var
  length: glFLoat;
begin
  // Calculates The Length Of The Vector
  length := sqrt((vector[0] * vector[0]) + (vector[1] * vector[1]) +
    (vector[2] * vector[2]));
  if Length = 0 then
    Length := 1;

  vector[0] := vector[0] / length;
  vector[1] := vector[1] / length;
  vector[2] := vector[2] / length;
end;

procedure calcNormal(const v: array of TVector;
  var cross: array of glFloat);
var
  v1, v2: array[0..2] of glFloat;
begin
  // Finds The Vector Between 2 Points By Subtracting
  // The x,y,z Coordinates From One Point To Another.

  // Calculate The Vector From Point 1 To Point 0
  v1[0] := v[0][0] - v[1][0]; // Vector 1.x=Vertex[0].x-Vertex[1].x
  v1[1] := v[0][1] - v[1][1]; // Vector 1.y=Vertex[0].y-Vertex[1].y
  v1[2] := v[0][2] - v[1][2]; // Vector 1.z=Vertex[0].y-Vertex[1].z
  // Calculate The Vector From Point 2 To Point 1
  v2[0] := v[1][0] - v[2][0]; // Vector 2.x=Vertex[0].x-Vertex[1].x
  v2[1] := v[1][1] - v[2][1]; // Vector 2.y=Vertex[0].y-Vertex[1].y
  v2[2] := v[1][2] - v[2][2]; // Vector 2.z=Vertex[0].z-Vertex[1].z
  // Compute The Cross Product To Give Us A Surface Normal
  cross[0] := v1[1] * v2[2] - v1[2] * v2[1]; // Cross Product For Y - Z
  cross[1] := v1[2] * v2[0] - v1[0] * v2[2]; // Cross Product For X - Z
  cross[2] := v1[0] * v2[1] - v1[1] * v2[0]; // Cross Product For X - Y

  ReduceToUnit(cross); // Normalize The Vectors
end;

// Draws A Helix

procedure ProcessHelix;
const
  Twists = 5;
  MaterialColor: array[1..4] of glFloat = (0.4, 0.2, 0.8, 1.0);
  Specular: array[1..4] of glFloat = (1, 1, 1, 1);
var
  x, y, z: glFLoat;
  phi, theta: Integer;
  r, u, v: glFLoat;
begin
  glLoadIdentity(); // Reset The Modelview Matrix
  // Eye Position (0,5,50) Center Of Scene (0,0,0), Up On Y Axis
  gluLookAt(0, 5, 50, 0, 0, 0, 0, 1, 0);

  glPushMatrix(); // Push The Modelview Matrix
  glTranslatef(0, 0, -50); // Translate 50 Units Into The Screen
  glRotatef(angle / 2.0, 1, 0, 0); // Rotate By angle/2 On The X-Axis
  glRotatef(angle / 3.0, 0, 1, 0); // Rotate By angle/3 On The Y-Axis

  glMaterialfv(GL_FRONT_AND_BACK, GL_AMBIENT_AND_DIFFUSE, @MaterialColor);
  glMaterialfv(GL_FRONT_AND_BACK, GL_SPECULAR, @specular);

  r := 1.5; // Radius

  glBegin(GL_QUADS); // Begin Drawing Quads
  phi := 0;
  while phi < 360 do
  begin
    theta := 0;
    while theta < 360 * twists do
    begin
      v := phi / 180 * pi; // Calculate Angle Of First Point ( 0 )
      u := theta / 180.0 * pi; // Calculate Angle Of First Point ( 0 )

      x := cos(u) * (2 + cos(v)) * r; // Calculate x Position (1st Point)
      y := sin(u) * (2 + cos(v)) * r; // Calculate y Position (1st Point)
      z := (u - (2 * pi) + sin(v)) * r; // Calculate z Position (1st Point)

      vertexes[0][0] := x; // Set x Value Of First Vertex
      vertexes[0][1] := y; // Set y Value Of First Vertex
      vertexes[0][2] := z; // Set z Value Of First Vertex

      v := (phi / 180 * pi); // Calculate Angle Of Second Point ( 0 )
      u := ((theta + 20) / 180 * pi); // Calculate Angle Of Second Point ( 20 )

      x := cos(u) * (2 + cos(v)) * r; // Calculate x Position (2nd Point)
      y := sin(u) * (2 + cos(v)) * r; // Calculate y Positio
      z := (u - (2 * pi) + sin(v)) * r; // Calculate z Position (2nd Point)

      vertexes[1][0] := x; // Set x Value Of Second Vertex
      vertexes[1][1] := y; // Set y Value Of Second Vertex
      vertexes[1][2] := z; // Set z Value Of Second Vertex

      v := (phi + 20) / 180 * pi; // Calculate Angle Of Third Point ( 20 )
      u := (theta + 20) / 180 * pi; // Calculate Angle Of Third Point ( 20 )

      x := cos(u) * (2 + cos(v)) * r; // Calculate x Position (3rd Point)
      y := sin(u) * (2 + cos(v)) * r; // Calculate y Position (3rd Point)
      z := (u - (2 * pi) + sin(v)) * r; // Calculate z Position (3rd Point)

      vertexes[2][0] := x; // Set x Value Of Third Vertex
      vertexes[2][1] := y; // Set y Value Of Third Vertex
      vertexes[2][2] := z; // Set z Value Of Third Vertex

      v := (phi + 20) / 180 * pi; // Calculate Angle Of Fourth Point ( 20 )
      u := theta / 180 * pi; // Calculate Angle Of Fourth Point ( 0 )

      x := cos(u) * (2 + cos(v)) * r; // Calculate x Position (4th Point)
      y := sin(u) * (2 + cos(v)) * r; // Calculate y Position (4th Point)
      z := (u - (2 * pi) + sin(v)) * r; // Calculate z Position (4th Point)

      vertexes[3][0] := x; // Set x Value Of Fourth Vertex
      vertexes[3][1] := y; // Set y Value Of Fourth Vertex
      vertexes[3][2] := z; // Set z Value Of Fourth Vertex

      calcNormal(vertexes, normal); // Calculate The Quad Normal

      glNormal3f(normal[0], normal[1], normal[2]); // Set The Normal

      // Render The Quad
      glVertex3f(vertexes[0][0], vertexes[0][1], vertexes[0][2]);
      glVertex3f(vertexes[1][0], vertexes[1][1], vertexes[1][2]);
      glVertex3f(vertexes[2][0], vertexes[2][1], vertexes[2][2]);
      glVertex3f(vertexes[3][0], vertexes[3][1], vertexes[3][2]);
      theta := theta + 20;
    end;
    phi := phi + 20;
  end;
  glEnd(); // Done Rendering Quads
  glPopMatrix(); // Pop The Matrix
end;

// Set Up An Ortho View

procedure ViewOrtho;
begin
  glMatrixMode(GL_PROJECTION); // Select Projection
  glPushMatrix(); // Push The Matrix
  glLoadIdentity(); // Reset The Matrix
  glOrtho(0, 640, 480, 0, -1, 1); // Select Ortho Mode (640x480)
  glMatrixMode(GL_MODELVIEW); // Select Modelview Matrix
  glPushMatrix(); // Push The Matrix
  glLoadIdentity(); // Reset The Matrix
end;

// Set Up A Perspective View

procedure ViewPerspective;
begin
  glMatrixMode(GL_PROJECTION); // Select Projection
  glPopMatrix(); // Pop The Matrix
  glMatrixMode(GL_MODELVIEW); // Select Modelview
  glPopMatrix(); // Pop The Matrix
end;

// Renders To A Texture

procedure RenderToTexture;
begin
  glViewport(0, 0, 128, 128); // Set Our Viewport (Match Texture Size)
  ProcessHelix(); // Render The Helix
  glBindTexture(GL_TEXTURE_2D, BlurTexture); // Bind To The Blur Texture

  // Copy Our ViewPort To The Blur Texture (From 0,0 To 128,128... No Border)
  glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_LUMINANCE, 0, 0, 128, 128, 0);
  glClearColor(0.0, 0.0, 0.5, 0.5); // Set The Clear Color To Medium Blue
  // Clear The Screen And Depth Buffer
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
  glViewport(0, 0, 640, 480); // Set Viewport (0,0 to 640x480)
end;

// Draw The Blurred Image

procedure DrawBlur(const times: Integer; const inc: glFloat);
var
  spost, alpha, alphainc: glFloat;
  I: Integer;
begin
  alpha := 0.2;

  glEnable(GL_TEXTURE_2D); // Enable 2D Texture Mapping
  glDisable(GL_DEPTH_TEST); // Disable Depth Testing
  glBlendFunc(GL_SRC_ALPHA, GL_ONE); // Set Blending Mode
  glEnable(GL_BLEND); // Enable Blending
  glBindTexture(GL_TEXTURE_2D, BlurTexture); // Bind To The Blur Texture
  ViewOrtho(); // Switch To An Ortho View

  alphainc := alpha / times; // alphainc=0.2f / Times To Render Blur

  glBegin(GL_QUADS); // Begin Drawing Quads
  // Number Of Times To Render Blur
  for I := 0 to times - 1 do
  begin
    glColor4f(1.0, 1.0, 1.0, alpha); // Set The Alpha Value (Starts At 0.2)
    glTexCoord2f(0 + spost, 1 - spost); // Texture Coordinate ( 0, 1 )
    glVertex2f(0, 0); // First Vertex ( 0, 0 )

    glTexCoord2f(0 + spost, 0 + spost); // Texture Coordinate ( 0, 0 )
    glVertex2f(0, 480); // Second Vertex ( 0, 480 )

    glTexCoord2f(1 - spost, 0 + spost); // Texture Coordinate ( 1, 0 )
    glVertex2f(640, 480); // Third Vertex ( 640, 480 )

    glTexCoord2f(1 - spost, 1 - spost); // Texture Coordinate ( 1, 1 )
    glVertex2f(640, 0); // Fourth Vertex ( 640, 0 )

    // Gradually Increase spost (Zooming Closer To Texture Center)
    spost := spost + inc;
    // Gradually Decrease alpha (Gradually Fading Image Out)
    alpha := alpha - alphainc;
  end;
  glEnd(); // Done Drawing Quads

  ViewPerspective(); // Switch To A Perspective View

  glEnable(GL_DEPTH_TEST); // Enable Depth Testing
  glDisable(GL_TEXTURE_2D); // Disable 2D Texture Mapping
  glDisable(GL_BLEND); // Disable Blending
  glBindTexture(GL_TEXTURE_2D, 0); // Unbind The Blur Texture
end;

{------------------------------------------------------------------}
{ Function to draw the actual scene }
{------------------------------------------------------------------}

procedure glDraw();
begin
  // Clear The Screen And The Depth Buffer
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
  glLoadIdentity(); // Reset The View
  RenderToTexture; // Render To A Texture
  ProcessHelix; // Draw Our Helix
  DrawBlur(25, 0.02); // Draw The Blur Effect

  angle := ElapsedTime / 5; // Update angle Based On The Clock
end;

{------------------------------------------------------------------}
{ Initialise OpenGL }
{------------------------------------------------------------------}

procedure glInit();
begin
  glClearColor(0.0, 0.0, 0.0, 0.5); // Black Background
  glShadeModel(GL_SMOOTH); // Enables Smooth Color Shading
  glClearDepth(1.0); // Depth Buffer Setup
  glDepthFunc(GL_LESS); // The Type Of Depth Test To Do

  glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST);
  file:
  //Realy Nice perspective calculations

  glEnable(GL_DEPTH_TEST); // Enable Depth Buffer
  glEnable(GL_TEXTURE_2D); // Enable Texture Mapping

  // Set The Ambient Light Model
  glLightModelfv(GL_LIGHT_MODEL_AMBIENT, @LmodelAmbient);

  // Set The Global Ambient Light Model
  glLightModelfv(GL_LIGHT_MODEL_AMBIENT, @GlobalAmbient);
  glLightfv(GL_LIGHT0, GL_POSITION, @light0Pos); // Set The Lights Position
  glLightfv(GL_LIGHT0, GL_AMBIENT, @light0Ambient); // Set The Ambient Light
  glLightfv(GL_LIGHT0, GL_DIFFUSE, @light0Diffuse); // Set The Diffuse Light
  // Set Up Specular Lighting
  glLightfv(GL_LIGHT0, GL_SPECULAR, @light0Specular);
  glEnable(GL_LIGHTING); // Enable Lighting
  glEnable(GL_LIGHT0); // Enable Light0

  BlurTexture := EmptyTexture(); // Create Our Empty Texture
  glShadeModel(GL_SMOOTH); // Select Smooth Shading
  glMateriali(GL_FRONT, GL_SHININESS, 128);
end;

{------------------------------------------------------------------}
{ Handle window resize }
{------------------------------------------------------------------}

procedure glResizeWnd(Width, Height: Integer);
begin
  if (Height = 0) then // prevent divide by zero exception
    Height := 1;
  glViewport(0, 0, Width, Height); // Set the viewport for the OpenGL window
  glMatrixMode(GL_PROJECTION); // Change Matrix Mode to Projection
  glLoadIdentity(); // Reset View
  gluPerspective(45.0, Width / Height, 2.0, 200.0);
  // Do the perspective calculations. Last value = max clipping depth

  glMatrixMode(GL_MODELVIEW); // Return to the modelview matrix
  glLoadIdentity(); // Reset View
end;

{------------------------------------------------------------------}
{ Processes all the keystrokes }
{------------------------------------------------------------------}

procedure ProcessKeys;
begin
end;

{------------------------------------------------------------------}
{ Determines the application’s response to the messages received }
{------------------------------------------------------------------}

function WndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM):
  LRESULT; stdcall;
begin
  case (Msg) of
    WM_CREATE:
      begin
        // Insert stuff you want executed when the program starts
      end;
    WM_CLOSE:
      begin
        PostQuitMessage(0);
        Result := 0
      end;
    // Set the pressed key (wparam) to equal true so we can check if its pressed
    WM_KEYDOWN:
      begin
        keys[wParam] := True;
        Result := 0;
      end;
    // Set the released key (wparam) to equal false so we can check if its pressed
    WM_KEYUP:
      begin
        keys[wParam] := False;
        Result := 0;
      end;
    WM_SIZE: // Resize the window with the new width and height
      begin
        glResizeWnd(LOWORD(lParam), HIWORD(lParam));
        Result := 0;
      end;
    WM_TIMER: // Add code here for all timers to be used.
      begin
        if wParam = FPS_TIMER then
        begin
          FPSCount := Round(FPSCount * 1000 / FPS_INTERVAL);
          // calculate to get per Second incase intercal is
          // less or greater than 1 second
          SetWindowText(h_Wnd, PChar(WND_TITLE + ' [' + intToStr(FPSCount)
            + ' FPS]'));
          FPSCount := 0;
          Result := 0;
        end;
      end;
  else
    // Default result if nothing happens
    Result := DefWindowProc(hWnd, Msg, wParam, lParam);
  end;
end;

{---------------------------------------------------------------------}
{ Properly destroys the window created at startup (no memory leaks) }
{---------------------------------------------------------------------}

procedure glKillWnd(Fullscreen: Boolean);
begin
  if Fullscreen then // Change back to non fullscreen
  begin
    ChangeDisplaySettings(devmode(nil^), 0);
    ShowCursor(True);
  end;

  // Makes current rendering context not current, and releases the device
  // context that is used by the rendering context.
  if (not wglMakeCurrent(h_DC, 0)) then
    MessageBox(0, 'Release of DC and RC failed!', 'Error',
      MB_OK or MB_ICONERROR);

  // Attempts to delete the rendering context
  if (not wglDeleteContext(h_RC)) then
  begin
    MessageBox(0, 'Release of rendering context failed!', 'Error',
      MB_OK or MB_ICONERROR);
    h_RC := 0;
  end;

  // Attemps to release the device context
  if ((h_DC = 1) and (ReleaseDC(h_Wnd, h_DC) < > 0)) then
  begin
    MessageBox(0, 'Release of device context failed!', 'Error',
      MB_OK or MB_ICONERROR);
    h_DC := 0;
  end;

  // Attempts to destroy the window
  if ((h_Wnd < > 0) and (not DestroyWindow(h_Wnd))) then
  begin
    MessageBox(0, 'Unable to destroy window!', 'Error', MB_OK or
      h_Wnd := 0;
  end;

  // Attempts to unregister the window class
  if (not UnRegisterClass('OpenGL', hInstance)) then
  begin
    MessageBox(0, 'Unable to unregister window class!', 'Error',
      MB_OK or MB_ICONERROR);
    hInstance := 0;
  end;
end;

{--------------------------------------------------------------------}
{ Creates the window and attaches a OpenGL rendering context to it }
{--------------------------------------------------------------------}

function glCreateWnd(Width, Height: Integer; Fullscreen: Boolean;
  PixelDepth: Integer): Boolean;
var
  wndClass: TWndClass; // Window class
  dwStyle: DWORD; // Window styles
  dwExStyle: DWORD; // Extended window styles
  dmScreenSettings: DEVMODE; // Screen settings (fullscreen, etc...)
  PixelFormat: GLuint; // Settings for the OpenGL rendering
  h_Instance: HINST; // Current instance
  pfd: TPIXELFORMATDESCRIPTOR; // Settings for the OpenGL window
begin
  h_Instance := GetModuleHandle(nil);
  file: //Grab An Instance For Our Window
  ZeroMemory(@wndClass, SizeOf(wndClass)); // Clear the window class structure

  with wndClass do // Set up the window class
  begin
    style := CS_HREDRAW or // Redraws entire window if length changes
    CS_VREDRAW or // Redraws entire window if height changes
    CS_OWNDC; // Unique device context for the window
    lpfnWndProc := @WndProc; // Set the window procedure to our func WndProc
    hInstance := h_Instance;
    hCursor := LoadCursor(0, IDC_ARROW);
    lpszClassName := 'OpenGL';
  end;

  if (RegisterClass(wndClass) = 0) then // Attemp to register the window class
  begin
    MessageBox(0, 'Failed to register the window class!', 'Error',
      MB_OK or MB_ICONERROR);
    Result := False;
    Exit
  end;

  // Change to fullscreen if so desired
  if Fullscreen then
  begin
    ZeroMemory(@dmScreenSettings, SizeOf(dmScreenSettings));
    with dmScreenSettings do
    begin // Set parameters for the screen setting
      dmSize := SizeOf(dmScreenSettings);
      dmPelsWidth := Width; // Window width
      dmPelsHeight := Height; // Window height
      dmBitsPerPel := PixelDepth; // Window color depth
      dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL;
    end;

    // Try to change screen mode to fullscreen
    if (ChangeDisplaySettings(dmScreenSettings, CDS_FULLSCREEN) =
      DISP_CHANGE_FAILED) then
    begin
      MessageBox(0, 'Unable to switch to fullscreen!', 'Error',
        MB_OK or MB_ICONERROR);
      Fullscreen := False;
    end;
  end;

  // If we are still in fullscreen then
  if (Fullscreen) then
  begin
    dwStyle := WS_POPUP or // Creates a popup window
    WS_CLIPCHILDREN // Doesn't draw within child windows
    or WS_CLIPSIBLINGS; // Doesn't draw within sibling windows
    dwExStyle := WS_EX_APPWINDOW; // Top level window
    ShowCursor(False); // Turn of the cursor (gets in the way)
  end
  else
  begin
    dwStyle := WS_OVERLAPPEDWINDOW or // Creates an overlapping window
    WS_CLIPCHILDREN or // Doesn't draw within child windows
    WS_CLIPSIBLINGS; // Doesn't draw within sibling windows
    dwExStyle := WS_EX_APPWINDOW or // Top level window
    WS_EX_WINDOWEDGE; // Border with a raised edge
  end;

  // Attempt to create the actual window
  h_Wnd := CreateWindowEx(dwExStyle, // Extended window styles
    'OpenGL', // Class name
    WND_TITLE, // Window title (caption)
    dwStyle, // Window styles
    0, 0, // Window position
    Width, Height, // Size of window
    0, // No parent window
    0, // No menu
    h_Instance, // Instance
    nil); // Pass nothing to WM_CREATE
  if h_Wnd = 0 then
  begin
    glKillWnd(Fullscreen); // Undo all the settings we've changed
    MessageBox(0, 'Unable to create window!', 'Error', MB_OK or MB_ICONERROR);
    Result := False;
    Exit;
  end;

  // Try to get a device context
  h_DC := GetDC(h_Wnd);
  if (h_DC = 0) then
  begin
    glKillWnd(Fullscreen);
    MessageBox(0, 'Unable to get a device context!', 'Error',
      MB_OK or MB_ICONERROR);
    Result := False;
    Exit;
  end;

  // Settings for the OpenGL window
  with pfd do
  begin
    // Size Of This Pixel Format Descriptor
    nSize := SizeOf(TPIXELFORMATDESCRIPTOR);
    nVersion := 1; // The version of this data structure
    dwFlags := PFD_DRAW_TO_WINDOW // Buffer supports drawing to window
    or PFD_SUPPORT_OPENGL // Buffer supports OpenGL drawing
    or PFD_DOUBLEBUFFER; // Supports double buffering
    iPixelType := PFD_TYPE_RGBA; // RGBA color format
    cColorBits := PixelDepth; // OpenGL color depth
    cRedBits := 0; // Number of red bitplanes
    cRedShift := 0; // Shift count for red bitplanes
    cGreenBits := 0; // Number of green bitplanes
    cGreenShift := 0; // Shift count for green bitplanes
    cBlueBits := 0; // Number of blue bitplanes
    cBlueShift := 0; // Shift count for blue bitplanes
    cAlphaBits := 0; // Not supported
    cAlphaShift := 0; // Not supported
    cAccumBits := 0; // No accumulation buffer
    cAccumRedBits := 0; // Number of red bits in a-buffer
    cAccumGreenBits := 0; // Number of green bits in a-buffer
    cAccumBlueBits := 0; // Number of blue bits in a-buffer
    cAccumAlphaBits := 0; // Number of alpha bits in a-buffer
    cDepthBits := 16; // Specifies the depth of the depth buffer
    cStencilBits := 0; // Turn off stencil buffer
    cAuxBuffers := 0; // Not supported
    iLayerType := PFD_MAIN_PLANE; // Ignored
    bReserved := 0; // Number of overlay and underlay planes
    dwLayerMask := 0; // Ignored
    dwVisibleMask := 0; // Transparent color of underlay plane
    dwDamageMask := 0; // Ignored
  end;

  // Attempts to find the pixel format supported by a device context that
  // is the best match to a given pixel format specification.
  PixelFormat := ChoosePixelFormat(h_DC, @pfd);
  if (PixelFormat = 0) then
  begin
    glKillWnd(Fullscreen);
    MessageBox(0, 'Unable to find a suitable pixel format', 'Error',
      MB_OK or MB_ICONERROR);
    Result := False;
    Exit;
  end;

  // Sets the specified device context's pixel format to the format
  // specified by the PixelFormat.
  if (not SetPixelFormat(h_DC, PixelFormat, @pfd)) then
  begin
    glKillWnd(Fullscreen);
    MessageBox(0, 'Unable to set the pixel format', 'Error',
      MB_OK or MB_ICONERROR);
    Result := False;
    Exit;
  end;

  // Create a OpenGL rendering context
  h_RC := wglCreateContext(h_DC);
  if (h_RC = 0) then
  begin
    glKillWnd(Fullscreen);
    MessageBox(0, 'Unable to create an OpenGL rendering context',
      'Error', MB_OK or MB_ICONERROR);
    Result := False;
    Exit;
  end;

  // Makes the specified OpenGL rendering context the calling
  // thread's current rendering context
  if (not wglMakeCurrent(h_DC, h_RC)) then
  begin
    glKillWnd(Fullscreen);
    MessageBox(0, 'Unable to activate OpenGL rendering context', 'Error',
      MB_OK or MB_ICONERROR);
    Result := False;
    Exit;
  end;

  // Initializes the timer used to calculate the FPS
  SetTimer(h_Wnd, FPS_TIMER, FPS_INTERVAL, nil);

  // Settings to ensure that the window is the topmost window
  ShowWindow(h_Wnd, SW_SHOW);
  SetForegroundWindow(h_Wnd);
  SetFocus(h_Wnd);

  // Ensure the OpenGL window is resized properly
  glResizeWnd(Width, Height);
  glInit();

  Result := True;
end;

{--------------------------------------------------------------------}
{ Main message loop for the application }
{--------------------------------------------------------------------}

function WinMain(hInstance: HINST; hPrevInstance: HINST;
  lpCmdLine: PChar; nCmdShow: Integer): Integer; stdcall;
var
  msg: TMsg;
  finished: Boolean;
  DemoStart, LastTime: DWord;
begin
  finished := False;

  // Perform application initialization:
  if not glCreateWnd(640, 480, FALSE, 32) then
  begin
    Result := 0;
    Exit;
  end;

  DemoStart := GetTickCount(); // Get Time when demo started

  // Main message loop:
  while not finished do
  begin
    // Check if there is a message for this window
    if (PeekMessage(msg, 0, 0, 0, PM_REMOVE)) then
    begin
      // If WM_QUIT message received then we are done
      if (msg.message = WM_QUIT) then
        finished := True
      else
      begin // Else translate and dispatch the message to this window
        TranslateMessage(msg);
        DispatchMessage(msg);
      end;
    end
    else
    begin
      Inc(FPSCount); // Increment FPS Counter

      LastTime := ElapsedTime;
      ElapsedTime := GetTickCount() - DemoStart; // Calculate Elapsed Time
      // Average it out for smoother movement
      ElapsedTime := (LastTime + ElapsedTime) div 2;

      glDraw(); // Draw the scene
      SwapBuffers(h_DC); // Display the scene

      if (keys[VK_ESCAPE]) then // If user pressed ESC then set finised TRUE
        finished := True
      else
        ProcessKeys; // Check for any other key Pressed
    end;
  end;
  glKillWnd(FALSE);
  Result := msg.wParam;
end;

begin
  WinMain(hInstance, hPrevInst, CmdLine, CmdShow);
end.

Проект Delphi World © Выпуск 2002 - 2024
Автор проекта: USU Software
Вы можете выкупить этот проект.