Child ablak (frmMDI.pas)

Top  Previous  Next

///////////////////////////////////////////////////////////////

///Небольшая программа для генерации ландшафтов  (Клас      ///

///хранения ландшафтов уже имеет методы сохранения/загрузки ///

///которые при желании можно использовать!!!)               ///

///Автор - BoogeMan        BoogeSoft@yandex.ru              ///

///////////////////////////////////////////////////////////////

 

unit frmGLMDI;

 

interface

 

 

uses

Windows, Messages, Classes, Graphics, Forms,

Controls, SysUtils, OpenGL, Mesh, Menus, StdCtrls, Dialogs, ExtCtrls,

ComCtrls, Buttons;

 

const BUFSIZE = 512;

 

type

TfrmGL = class(TForm)

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

     Shift: TShiftState);

   procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,

     Y: Integer);

   procedure FormMouseUp(Sender: TObject; Button: TMouseButton;

     Shift: TShiftState; X, Y: Integer);

   procedure FormMouseDown(Sender: TObject; Button: TMouseButton;

     Shift: TShiftState; X, Y: Integer);

   procedure FormCanResize(Sender: TObject; var NewWidth,

     NewHeight: Integer; var Resize: Boolean);

   procedure N14Click(Sender: TObject);

   procedure N15Click(Sender: TObject);

   procedure N11Click(Sender: TObject);

   procedure N12Click(Sender: TObject);

   procedure N7Click(Sender: TObject);

   procedure Grayface2Click(Sender: TObject);

   procedure N3Click(Sender: TObject);

   procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState;

     MousePos: TPoint; var Handled: Boolean);

   procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState;

     MousePos: TPoint; var Handled: Boolean);

   procedure Button1Click(Sender: TObject);

   procedure FormClose(Sender: TObject; var Action: TCloseAction);

private

   DC: HDC;

   hrc: HGLRC;

 

       mDown : Boolean;

       bRBtnDown : Boolean;

 

   procedure Init;

   procedure SetDCPixelFormat;

protected

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

public

       MyMesh : TGeo3DMesh;

       viewP : array [0..3] of GLint;

   constructor Create(AOwner : TComponent; sDem, sIMG : string);

   destructor Destroy;override;

       procedure ZoomIn;

   procedure ZoomOut;

   function DoSelect(X,Y : integer) : integer;

end;

 

 

var

frmGL: TfrmGL;

Anglex,Angley,angle, dLength : GLfloat;

xm,ym : Integer;

 

implementation

 

uses frmMain;

 

{$R *.DFM}

 

{=======================================================================

Инициализация}

procedure TfrmGL.Init;

begin

         glEnable(GL_DEPTH_TEST);

 

         glEnable(GL_LIGHT0);

 

       glenable (GL_COLOR_MATERIAL);

       gldisable (GL_NORMALIZE);

end;

 

procedure TfrmGL.WMPaint(var Msg: TWMPaint);

var

ps : TPaintStruct;

begin

 

  BeginPaint (Handle, ps);

  glClear (GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);

 

   glPushMatrix;

 

   glRotatef (Anglex, 1.0,0.0 , 0.0);

   glRotatef (Angley, 0.0,1.0 , 0.0);

 

       MyMesh.Draw; // Рисуем объект

 

   glPopMatrix;

 

   SwapBuffers (DC);

EndPaint (Handle, ps);

 

end;

 

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

Shift: TShiftState);

begin

If Key = VK_ESCAPE then Close

else if Key = 38 then ZoomOut

else if Key = 40 then ZoomIn;

end;

 

procedure TfrmGL.FormMouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

begin

       If mdown then begin

          anglex:=anglex+(y-ym);

          angley:=angley+(x-xm);

          InvalidateRect(Handle, nil, False);

       end;

       if bRBtnDown then begin

               gluLookAt((xm - x)/500, (y - ym)/500, 0,(xm - x)/500,(y - ym)/500,-100,0,1,0);

          InvalidateRect(Handle, nil, false);

       end;

//    DoSelect(X, Y);

       xm:=x;ym:=y;

end;

 

procedure TfrmGL.FormMouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

       if Button = mbLeft then begin

           mdown := false;

   end

   else

   if Button = mbRight then begin

               bRBtnDown := FALSE;   

   end;

end;

 

procedure TfrmGL.FormMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

       if Button = mbLeft then begin

               mdown:=true;

   end

   else

   if Button = mbRight then begin

               bRBtnDown := TRUE;

   end;

       xm:=x;

       ym:=y;

end;

 

procedure TfrmGL.SetDCPixelFormat;

var

nPixelFormat: Integer;

pfd: TPixelFormatDescriptor;

begin

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

 

pfd.dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or

                PFD_DOUBLEBUFFER;

nPixelFormat := ChoosePixelFormat(DC, @pfd);

SetPixelFormat(DC, nPixelFormat, @pfd);

end;

 

procedure TfrmGL.FormCanResize(Sender: TObject; var NewWidth,

NewHeight: Integer; var Resize: Boolean);

begin

glViewPort (0, 0, ClientWidth, ClientHeight);

glMatrixMode(GL_PROJECTION);

glLoadIdentity;

gluPerspective(50.0, ClientWidth / ClientHeight, 0.01, 5000.0);

glMatrixMode(GL_MODELVIEW);

glLoadIdentity;

glTranslatef(0.0, 0.3, -1.0);

InvalidateRect(Handle, nil, False);

 

       glFogi(GL_FOG_MODE, GL_exp2);

       glFogfv(GL_FOG_COLOR, @color);

//        glFogf(GL_FOG_START,25);

//    glFogf(GL_FOG_END ,55);

   glFogf(GL_FOG_DENSITY, 0.020);

   glEnable (GL_FOG);

 

   glenable(GL_COLOR_MATERIAL);

   glEnable(GL_LIGHT0);

 

   glEnable(GL_CULL_FACE);

 

end;

 

procedure TfrmGL.N14Click(Sender: TObject);

begin

glEnable(GL_LIGHTING);

InvalidateRect(Handle, nil, False);

end;

 

procedure TfrmGL.N15Click(Sender: TObject);

begin

gldisable(GL_LIGHTING);

InvalidateRect(Handle, nil, False);

end;

 

procedure TfrmGL.N11Click(Sender: TObject);

begin

       MyMesh.MeshConfig.smt:=true;

   InvalidateRect(Handle, nil, False);

end;

 

procedure TfrmGL.N12Click(Sender: TObject);

begin

       MyMesh.MeshConfig.smt:=false;

       InvalidateRect(Handle, nil, False);

end;

 

procedure TfrmGL.N7Click(Sender: TObject);

begin

glenable (GL_COLOR_MATERIAL);

InvalidateRect(Handle, nil, False);

end;

 

procedure TfrmGL.Grayface2Click(Sender: TObject);

begin

glColor3f(0.5,0.5,0.5);

gldisable (GL_COLOR_MATERIAL);

InvalidateRect(Handle, nil, False);

end;

 

procedure TfrmGL.N3Click(Sender: TObject);

begin

       Close;

end;

 

procedure TfrmGL.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;

MousePos: TPoint; var Handled: Boolean);

begin

       ZoomIn;

end;

 

procedure TfrmGL.ZoomIn;

begin

       dLength := 0.1;

       gluLookAt(0,0,dLength,0,0,-100,0,1,0);

   InvalidateRect(Handle, nil, false);

end;

 

procedure TfrmGL.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;

MousePos: TPoint; var Handled: Boolean);

begin

       ZoomOut;

end;

 

procedure TfrmGL.ZoomOut;

begin

       dLength := -0.1;

       gluLookAt(0,0,dLength,0,0,-100,0,1,0);

   InvalidateRect(Handle, nil, false);

end;

 

function TfrmGL.DoSelect(X, Y: integer): integer;

var selectBuff : Array[0..BUFSIZE] of glUint;

begin

glGetIntegerv(GL_VIEWPORT, @viewP);   // Viewport = [0, 0, width, height]

glSelectBuffer(BUFSIZE, @selectBuff);

glRenderMode(GL_SELECT);

glInitNames;

glPushName(0);

 

glMatrixMode(GL_PROJECTION);

glPushMatrix();

glLoadIdentity();

gluPickMatrix(x, ClientHeight - y, 5, 5, @viewP);      // Set-up pick matrix

gluPerspective(45, ClientWidth / ClientHeight, -100, -100);  // Do the perspective calculations. Last value = max clipping depth

glMatrixMode(GL_MODELVIEW);

 

glMatrixMode(GL_PROJECTION);

glPopMatrix();

glMatrixMode(GL_MODELVIEW);

if glRenderMode(GL_RENDER)>0 then

       result:= selectBuff[3]

else

       result:= -1;

 

   caption := floattostr(result) + ' objs selected!'

end;

 

procedure TfrmGL.Button1Click(Sender: TObject);

var

       n : GLINT;

begin

       glGetIntegerV(GL_NAME_STACK_DEPTH, @n);

   ShowMessage(IntToStr(n));

end;

 

constructor TfrmGL.Create(AOwner: TComponent; sDem, sIMG: string);

begin

       inherited Create(AOwner);

 

       DC := GetDC(Handle);

       SetDCPixelFormat;

       hrc := wglCreateContext(DC);

       wglMakeCurrent(DC, hrc);

       glClearColor (0.0, 0.0, 0.0, 1.0);

       Init;

 

       anglex:= 20;

 

       myMesh := TGeo3DMesh.Create(sDEM, sIMG);

   myMesh.MeshConfig.mode:=gl_triangles;

       myMesh.MeshConfig.clr:=true;

       myMesh.MeshConfig.txt:=true;

 

   mymesh.BuildTree;

end;

 

destructor TfrmGL.Destroy;

begin

   Mymesh.Free;

 

       wglMakeCurrent(0, 0);

       wglDeleteContext(hrc);

       ReleaseDC(Handle, DC);

       DeleteDC (DC);

 

       inherited;

end;

 

procedure TfrmGL.FormClose(Sender: TObject; var Action: TCloseAction);

begin

       Action := caFree;

end;

 

end.