unit GenericCanvas;

// Copyright (C) 2003, 2004 MySQL AB
//
// This program is free software; you can redistribute it and/or modify
// it under the terms of the GNU General Public License as published by
// the Free Software Foundation; either version 2 of the License, or
// (at your option) any later version.
//
// This program is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
// GNU General Public License for more details.
//
// You should have received a copy of the GNU General Public License
// along with this program; if not, write to the Free Software
// Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
//----------------------------------------------------------------------------------------------------------------------
//
// Proof-of-concept implementation of an OpenGL canvas for database design purposes.

//----------------------------------------------------------------------------------------------------------------------

interface

uses
  Windows, Messages, Controls, Classes, Graphics, Sysutils;

type
  TViewport = record
    Left, Top,
    Width, Height: Integer;
  end;

  TGenericCanvasViewer = class(TWinControl)
  private
    FRenderingContext: HGLRC;
    FDeviceContext: HDC; 
    FViewport: TViewport;
    FOnRender,
    FOnSetup: TNotifyEvent;
    FBackground: TColor;
    FCanRender: Boolean;
    procedure SetBackground(const Value: TColor);

    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); Message WM_ERASEBKGND;
    procedure WMPaint(var Message: TWMPaint); Message WM_PAINT;
    procedure WMSize(var Message: TWMSize); Message WM_SIZE;
  protected
    procedure ApplyBackground;
    procedure ApplyPerspective;
    procedure ClearBuffers;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
  public
    constructor Create(AOwner: TComponent); override;

    procedure DisableContext;
    procedure EnableContext;
    procedure RenderScene;

    property DeviceContext: HDC read FDeviceContext;
    property Font;
    property RenderingContext: HGLRC read FRenderingContext;
  published
    property Anchors;
    property Align;
    property Background: TColor read FBackground write SetBackground;
    property Constraints;
    property DragCursor;
    property DragMode;
    property Enabled;
    property HelpContext;
    property Hint;
    property PopupMenu;
    property Visible;

    property OnClick;
    property OnDragDrop;
    property OnDragOver;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnRender: TNotifyEvent read FOnRender write FOnRender;
    property OnSetup: TNotifyEvent read FOnSetup write FOnSetup;
  end;
  
//----------------------------------------------------------------------------------------------------------------------

implementation

//----------------------------------------------------------------------------------------------------------------------

constructor TGenericCanvasViewer.Create(AOwner: TComponent);

begin
  inherited;
  
  Width := 150;
  Height := 150;
  FCanRender := True;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGenericCanvasViewer.SetBackground(const Value: TColor);

begin
  if FBackground <> Value then
  begin
    FBackground := Value;
    if not (csLoading in ComponentState) and (FRenderingContext <> 0) and  FCanRender then
      ApplyBackground;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGenericCanvasViewer.WMEraseBkgnd(var Message: TWMEraseBkgnd);

begin
  Message.Result := 1;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGenericCanvasViewer.WMPaint(var Message: TWMPaint);

var
  PS: TPaintStruct;

begin
  BeginPaint(Handle, PS);
  if FCanRender then
    RenderScene;
  EndPaint(Handle, PS);
  Message.Result := 0;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGenericCanvasViewer.WMSize(var Message: TWMSize);

begin
  // Update viewport (here always the entire window).
  with FViewPort do
  begin
    Width := Message.Width;
    Height := Message.Height;
    if Height = 0 then
      Height := 1;
  end;

  if (FRenderingContext <> 0) and  FCanRender then
  begin
    ActivateRenderingContext(FDeviceContext, FRenderingContext);
    ApplyPerspective;
    DeactivateRenderingContext;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGenericCanvasViewer.ApplyBackground;

var
  Color: COLORREF;
  R, G, B: Single;

begin
  ActivateRenderingContext(FDeviceContext, FRenderingContext);
  Color := ColorToRGB(FBackground);
  R := GetRValue(Color) / 255;
  G := GetGValue(Color) / 255;
  B := GetBValue(Color) / 255;
  glClearColor(R, G, B, 1);
  DeactivateRenderingContext;
  Refresh;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGenericCanvasViewer.ApplyPerspective;

begin
  with FViewport do
  begin
    glMatrixMode(GL_PROJECTION);
    glLoadIdentity;

    //gluPerspective(35, Width / Height, 1, 100);

    glOrtho(Left, Left + Width, Top + Height, Top, -100, 100);
    glMatrixMode(GL_MODELVIEW);
    glViewport(0, 0, Width, Height);
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGenericCanvasViewer.ClearBuffers;

begin
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGenericCanvasViewer.CreateParams(var Params: TCreateParams);

begin
  inherited;

  with Params do
  begin
    Style := Style or WS_CLIPCHILDREN or WS_CLIPSIBLINGS;
    WindowClass.Style :=  CS_VREDRAW or CS_HREDRAW or CS_OWNDC;
  end
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGenericCanvasViewer.CreateWnd;

var
  Dummy: HPALETTE;
  
begin
  inherited;

  FDeviceContext := GetDC(Handle);
  FRenderingContext := CreateRenderingContext(FDeviceContext, [opDoubleBuffered], 32, 0, 0, 0, 0, Dummy);
  if FRenderingContext = 0 then
    raise Exception.Create('Creation of OpenGL rendering context failed.');

  ActivateRenderingContext(FDeviceContext, FRenderingContext);
  if not GL_VERSION_1_1 then
  begin
    DestroyRenderingContext(FRenderingContext);
    raise Exception.Create('Your version of OpenGL is outdated.');
  end;

  // Set the viewport to the entire window size.
  with FViewPort do
  begin
    Left := 0;
    Top := 0;
    Width := Self.Width;
    Height := Self.Height;
    ApplyPerspective;
  end;

  ApplyBackground;

  if Assigned(FOnSetup) then
    FOnSetup(Self);
  DeactivateRenderingContext;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGenericCanvasViewer.DestroyWnd;

begin
  ReleaseDC(Handle, FDeviceContext);
  
  inherited;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGenericCanvasViewer.DisableContext;

begin
  FCanRender := False;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGenericCanvasViewer.EnableContext;

begin
  if not FCanRender then
  begin
    FCanRender := True;
    if FRenderingContext <> 0 then
    begin
      ActivateRenderingContext(FDeviceContext, FRenderingContext);
      ApplyPerspective;
      DeactivateRenderingContext;
    end;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGenericCanvasViewer.RenderScene;

// This is the actual paint routine. All initialization must already have been done.
// The event FOnRender is triggered to let the application draw whatever is needed.

begin
  ActivateRenderingContext(FDeviceContext, FRenderingContext);
  ClearBuffers;
  glMatrixMode(GL_MODELVIEW);
  glLoadIdentity;
  if Assigned(FOnRender) then
    FOnRender(Self);
  SwapBuffers(FDeviceContext);
  DeactivateRenderingContext;
end;

//----------------------------------------------------------------------------------------------------------------------

end.