unit Rect1;

interface

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

type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    ZValue1: TMenuItem;
    YValue1: TMenuItem;
    XValue1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure ZValue1Click(Sender: TObject);
    procedure YValue1Click(Sender: TObject);
    procedure XValue1Click(Sender: TObject);
  private
    oldw,
    oldh: integer;
    xvalue,
    yvalue,
    zvalue: glFloat;
    GLContext: HGLRC;
    glDC: HDC;
    errorCode: GLenum;
    openGLReady: boolean;
    procedure ExceptionGL(Sender:TObject;E:Exception);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject); 
var
  pfd: TPixelFormatDescriptor;
  FormatIndex: integer;
begin
  Application.OnException := ExceptionGL;
  fillchar(pfd,SizeOf(pfd),0);
  with pfd do
  begin
    nSize      := SizeOf(pfd);
    nVersion   := 1; {The current version of the desccriptor is 1}
    dwFlags    := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL;
    iPixelType := PFD_TYPE_RGBA;
    cColorBits := 24; {support 24-bit color}
    cDepthBits := 32; {depth of z-axis}
    iLayerType := PFD_MAIN_PLANE;
  end; {with}
  glDC := getDC(handle);
  FormatIndex := ChoosePixelFormat(glDC,@pfd);
  if FormatIndex=0 then
    raise Exception.Create('ChoosePixelFormat failed '+
      IntToStr(GetLastError)); 

  if not SetPixelFormat(glDC,FormatIndex,@pfd) then
    raise Exception.Create('SetPixelFormat failed '+
      IntToStr(GetLastError));

  GLContext := wglCreateContext(glDC);
  if GLContext=0 then
    raise Exception.Create('wglCreateContext failed '+
      IntToStr(GetLastError)); 

  if not wglMakeCurrent(glDC,GLContext) then
    raise Exception.Create('wglMakeCurrent failed '+
      IntToStr(GetLastError));

  glOrtho(-1.0,1.0,-1.0,1.0,-1.0,1.0);
  
  OpenGLReady := true;
  oldw := ClientWidth;
  oldh := ClientHeight;
end; {FormCreate}

procedure TForm1.FormDestroy(Sender: TObject);
begin
  OpenGLReady := false;
  wglMakeCurrent(glDC,0);
  wglDeleteContext(GLContext);
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  if not openGLReady then
    exit;
  {green background}
  glClearColor(0.0,0.4,0.0,0.0);
  glClear(GL_COLOR_BUFFER_BIT);

  {red rectangle}
  glColor3f(0.5,0.0,0.0);
  glBegin(GL_POLYGON);
    glVertex3f(xvalue+0.25,yvalue+0.25,zvalue);
    glVertex3f(xvalue+0.75,yvalue+0.25,zvalue);
    glVertex3f(xvalue+0.75,yvalue+0.75,zvalue);
    glVertex3f(xvalue+0.25,yvalue+0.75,zvalue);
  glEnd;
  
  glFlush;

  errorCode := glGetError;
  if errorCode<>GL_NO_ERROR then
    raise Exception.Create('Error in Paint'#13+
      gluErrorString(errorCode));
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  if not openGLReady then
    exit;
  glViewPort(0,0,ClientWidth,ClientHeight);
  errorCode := glGetError;
  if errorCode<>GL_NO_ERROR then
    raise Exception.Create('FormResize:'+gluErrorString(errorCode));
  if (ClientWidth<=oldw) and (ClientHeight<=oldh) then
    FormPaint(Sender);
  oldh := ClientHeight;
  oldw := ClientWidth;
end;

procedure TForm1.ExceptionGL(Sender:TObject;E:Exception);
begin
  ShowMessage(E.Message);
  repeat
    errorCode := glGetError;
    if errorCode<>GL_NO_ERROR then
      showMessage(gluErrorString(errorCode));
  until errorCode=GL_NO_ERROR;
end;

procedure TForm1.Zvalue1Click(Sender: TObject);
var
  zString: string[7];
begin
  zString := InputBox('Z-Value','float:','0.0');
  zvalue := StrToFloat(zString);
end;

procedure TForm1.YValue1Click(Sender: TObject);
var
  yString: string[7];
begin
  yString := InputBox('Y-Value','float:','0.0');
  yvalue := StrToFloat(yString);
end;

procedure TForm1.XValue1Click(Sender: TObject);
var
  xString: string[7];
begin
  xString := InputBox('X-Value','float:','0.0');
  xvalue := StrToFloat(xString);
end;

end.
