[Pythianproject-cvsmail] CVS: PythianProject/Source/Units Glpanel.pas,NONE,1.1

SourceForge Headquarters 1320 Columbia Street Suite 310 San Diego, CA 92101 +1 (858) 422-6466

Update of /cvsroot/pythianproject/PythianProject/Source/Units
In directory slayer.i.sourceforge.net:/tmp/cvs-serv6272

Added Files:
	Glpanel.pas 
Log Message:
no message

--- NEW FILE ---
/////////////////////////////////////////////////////////////////////////
// Industrial Software Solutions
// 4205 Hideaway
// Arlington, Texas 76017
// Mitchell E. James
// May 18, 1996
// mj...@cy...
// http://www.cyberhighway.net/~mjames/

// note: When running under the Delphi 2.0 debugger the Windows GL subsystem errors out randomly.
// note: The Windows GL subsystem seems to work fine running Delphi GL executables.
// note: I haven't been running with a palette. Not sure if that works.

unit GLPanel;

interface

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

  type
    TPFDPixelType = (GLp_TYPE_RGBA, GLp_TYPE_COLORINDEX);
    TPFDLayerType = (GLL_MAIN_PLANE, GLL_OVERLAY_PLANE, GLL_UNDERLAY_PLANE);
    // PIXELFORMATDESCRIPTOR flags
    TPFDFlag = (GLf_DOUBLEBUFFER, GLf_STEREO, GLf_DRAW_TO_WINDOW,
                GLf_DRAW_TO_BITMAP, GLf_SUPPORT_GDI, GLf_SUPPORT_OPENGL,
                GLf_GENERIC_FORMAT, GLf_NEED_PALETTE, GLf_NEED_SYSTEM_PALETTE,
                GLf_SWAP_EXCHANGE, GLf_SWAP_COPY);
    TPFDPixelTypes = set of TPFDPixelType;
    TPFDLayerTypes = set of TPFDLayerType;
    TPFDFlags      = set of TPFDFlag;

  TGLPanel = class(TCustomPanel)
  private
    DC: HDC;
    hrc: HGLRC;
    Palette: HPALETTE;
    FFirstTimeInFlag: Boolean;
    FPFDChanged: Boolean;
    FPixelType: TPFDPixelTypes;
    FLayerType: TPFDLayerTypes;
    FFlags: TPFDFlags;
    GPixelType: Word;
    GLayerType: Smallint;
    GFlags: Word;
    FColorBits: Cardinal;
    FDepthBits: Cardinal;
    FOnGLDraw: TNotifyEvent; // pointer to users routine of GL draw commands
    FOnGLInit: TNotifyEvent; // pointer to users routine for GL initialization
    FOnGLPrep: TNotifyEvent; // pointer to users routine for static setup
    procedure ResetFlags (Value: TPFDFlags);
    procedure ResetPixelType (Value: TPFDPixelTypes);
    procedure ResetLayerType (Value: TPFDLayerTypes);
    procedure SetDCPixelFormat;
    procedure NewPaint;
  protected
    procedure SetFlags (Value: TPFDFlags);
    procedure SetPixelType (Value: TPFDPixelTypes);
    procedure SetLayerType (Value: TPFDLayerTypes);
    procedure SetColorBits (Value: Cardinal);
    procedure SetDepthBits (Value: Cardinal);
    function GetFlags : TPFDFlags;
    function GetPixelType: TPFDPixelTypes;
    function GetLayerType: TPFDLayerTypes;
    function GetColorBits: Cardinal;
    function GetDepthBits: Cardinal;
    procedure Paint; override;
    procedure Resize; override;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure GLReDraw;
    procedure NewGLPrep;
  published
    property Align;
    property Alignment;
//    property BevelInner;
//    property BevelOuter;
//    property BevelWidth;
//    property BorderWidth;
//    property BorderStyle;
    property DragCursor;
    property DragMode;
    property Enabled;
//    property Caption;
//    property Color;
    property GLColorBits: Cardinal read GetColorBits write SetColorBits
      default 24;
//    property Ctl3D;
    property GLDepthBits: Cardinal read GetDepthBits write SetDepthBits
      default 32;
    property GLFlags: TPFDFlags read Getflags write SetFlags
      default [GLf_DRAW_TO_WINDOW , GLf_SUPPORT_OPENGL];
//    property Font;
    property GLLayerType: TPFDLayerTypes read GetLayerType write SetLayerType
      default [GLL_MAIN_PLANE];
    property Locked;
//    property ParentColor;
//    property ParentCtl3D;
//    property ParentFont;
    property ParentShowHint;
    property GLPixelType: TPFDPixelTypes read GetPixelType write SetPixelType
      default [GLp_TYPE_RGBA];
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDrag;
    property OnGLDraw: TNotifyEvent read FOnGLDraw write FOnGLDraw;
    property OnGLInit: TNotifyEvent read FOnGLInit write FOnGLInit;
    property OnGLPrep: TNotifyEvent read FOnGLPrep write FOnGLPrep;

  end;

procedure Register;

implementation

procedure TGLPanel.Resize;
begin
  inherited Resize;
  if Assigned(OnResize) then OnResize(self);
end;
procedure TGLPanel.SetDCPixelFormat;
var
  hHeap: THandle;
  nColors, i: Integer;
  lpPalette: PLogPalette;
  byRedMask, byGreenMask, byBlueMask: Byte;
  nPixelFormat: Integer;
  pfd: TPixelFormatDescriptor;

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

  with pfd do begin
    nSize     := sizeof(pfd);   // Size of this structure
    nVersion  := 1;             // Version number
    dwFlags   := GFlags;        // Flags
    iPixelType:= GPixelType;    // RGBA pixel values
    cColorBits:= FColorBits;    // 24-bit color
    cDepthBits:= FDepthBits;    // 32-bit depth buffer
    iLayerType:= GLayerType;    // Layer type
  end;

  nPixelFormat := ChoosePixelFormat(DC, @pfd);
  SetPixelFormat(DC, nPixelFormat, @pfd);

  DescribePixelFormat(DC, nPixelFormat, sizeof(TPixelFormatDescriptor), pfd);

  if ((pfd.dwFlags and PFD_NEED_PALETTE) <> 0) then begin
    nColors   := 1 shl pfd.cColorBits;
    hHeap     := GetProcessHeap;
    lpPalette := HeapAlloc(hHeap, 0, sizeof(TLogPalette) + (nColors * sizeof(TPaletteEntry)));

    lpPalette^.palVersion := $300;
    lpPalette^.palNumEntries := nColors;

    byRedMask   := (1 shl pfd.cRedBits) - 1;
    byGreenMask := (1 shl pfd.cGreenBits) - 1;
    byBlueMask  := (1 shl pfd.cBlueBits) - 1;

    for i := 0 to nColors - 1 do begin
      lpPalette^.palPalEntry[i].peRed   := (((i shr pfd.cRedShift)   and byRedMask)   * 255) DIV byRedMask;
      lpPalette^.palPalEntry[i].peGreen := (((i shr pfd.cGreenShift) and byGreenMask) * 255) DIV byGreenMask;
      lpPalette^.palPalEntry[i].peBlue  := (((i shr pfd.cBlueShift)  and byBlueMask)  * 255) DIV byBlueMask;
      lpPalette^.palPalEntry[i].peFlags := 0;
    end;

    Palette := CreatePalette(lpPalette^);
    HeapFree(hHeap, 0, lpPalette);

    if (Palette <> 0) then begin
      SelectPalette(DC, Palette, False);
      RealizePalette(DC);
    end;
  end;
end;

procedure TGLPanel.ResetFlags (Value: TPFDFlags);
begin
  GFlags := 0;
  if GLf_DOUBLEBUFFER in Value then GFlags := GFlags or PFD_DOUBLEBUFFER;
  if GLf_STEREO in Value then GFlags := GFlags or PFD_STEREO;
  if GLf_DRAW_TO_WINDOW in Value then GFlags := GFlags or PFD_DRAW_TO_WINDOW;
  if GLf_DRAW_TO_BITMAP in Value then GFlags := GFlags or PFD_DRAW_TO_BITMAP;
  if GLf_SUPPORT_GDI in Value then GFlags := GFlags or PFD_SUPPORT_GDI;
  if GLf_SUPPORT_OPENGL in Value then GFlags := GFlags or PFD_SUPPORT_OPENGL;
  if GLf_GENERIC_FORMAT in Value then GFlags := GFlags or PFD_GENERIC_FORMAT;
  if GLf_NEED_PALETTE in Value then GFlags := GFlags or PFD_NEED_PALETTE;
  if GLf_NEED_SYSTEM_PALETTE in Value then GFlags := GFlags or PFD_NEED_SYSTEM_PALETTE;
  if GLf_SWAP_EXCHANGE in Value then GFlags := GFlags or PFD_SWAP_EXCHANGE;
  if GLf_SWAP_COPY in Value then GFlags := GFlags or PFD_SWAP_COPY;
end;

procedure TGLPanel.ResetPixelType (Value: TPFDPixelTypes);
begin
  if GLp_TYPE_RGBA in Value then GPixelType := PFD_TYPE_RGBA;
  if GLp_TYPE_COLORINDEX in Value then GPixelType := PFD_TYPE_COLORINDEX;
end;

procedure TGLPanel.ResetLayerType (Value: TPFDLayerTypes);
begin
  if GLL_MAIN_PLANE in Value then GLayerType := PFD_MAIN_PLANE;
  if GLL_OVERLAY_PLANE in Value then GLayerType := PFD_OVERLAY_PLANE;
  if GLL_UNDERLAY_PLANE in Value then GLayerType := PFD_UNDERLAY_PLANE;
end;

procedure TGLPanel.SetFlags(Value: TPFDFlags);
begin
  if FFlags <> Value then
  begin
    FFlags := Value;
    if not (csDesigning in ComponentState) then
    begin
      ResetFlags (Value);
      FPFDChanged := True;
    end;
  end;
end;

procedure TGLPanel.SetPixelType (Value: TPFDPixelTypes);
begin
  if FPixelType <> Value then
  begin
    FPixelType := Value;
    if not (csDesigning in ComponentState) then
    begin
      ResetPixelType (Value);
      FPFDChanged := True;
    end;
  end;
end;

procedure TGLPanel.SetLayerType (Value: TPFDLayerTypes);
begin
  if FLayerType <> Value then
  begin
    FLayerType := Value;
    if not (csDesigning in ComponentState) then
    begin
      ResetLayerType (Value);
      FPFDChanged := True;
    end;
  end;
end;

procedure TGLPanel.SetColorBits (Value: Cardinal);
begin
  FColorBits := Value;
end;

procedure TGLPanel.SetDepthBits (Value: Cardinal);
begin
  FDepthBits := Value;
end;

function TGLPanel.GetFlags : TPFDFlags;
begin
  GetFlags := FFlags;
end;

function TGLPanel.GetPixelType: TPFDPixelTypes;
begin
  GetPixelType := FPixelType;
end;

function TGLPanel.GetLayerType: TPFDLayerTypes;
begin
  GetLayerType := FLayerType;
end;

function TGLPanel.GetColorBits: Cardinal;
begin
  GetColorBits := FColorBits;
end;

function TGLPanel.GetDepthBits: Cardinal;
begin
  GetDepthBits := FDepthBits;
end;

procedure TGLPanel.Paint;
begin
end;

procedure TGLPanel.NewGLPrep;
begin
  if Assigned(OnGLPrep) then OnGLPrep(self);
  if Assigned(OnResize) then OnResize(self);
end;

procedure TGLPanel.NewPaint;
var
  ps : TPaintStruct;
begin
  inherited;
  if not (csDesigning in ComponentState) then
  begin
    // Draw the scene.
    if FPFDChanged then SetDCPixelFormat;
      if FFirstTimeInFlag then
      begin
        FFirstTimeInFlag := False;
        // Create a rendering context.
        InitOpenGL;
        DC := GetDC(Handle);
        SetDCPixelFormat;
        hrc := wglCreateContext(DC);
        wglMakeCurrent(DC, hrc);
        if Assigned(OnGLInit) then OnGlInit(self);
        if Assigned(OnGLPrep) then OnGLPrep(self);
        if Assigned(OnResize) then OnResize(self);
      end;
    BeginPaint(Handle, ps);
    if Assigned(OnGLDraw) then OnGLDraw(self);
    if GLf_DOUBLEBUFFER in FFlags then SwapBuffers(DC);
    EndPaint(Handle, ps);
  end;
end;

constructor TGLPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPFDChanged := False;
  FPixelType := [GLp_TYPE_RGBA];
  FFlags := [GLf_DRAW_TO_WINDOW, GLf_SUPPORT_OPENGL, GLf_DOUBLEBUFFER];
  FLayerType := [GLL_MAIN_PLANE];
  FColorBits := 24;
  FDepthBits := 32;
  ResetFlags(FFlags);
  ResetPixelType(FPixelType);
  ResetLayerType(FLayerType);
  FFirstTimeInFlag := True;
end;

destructor TGLPanel.Destroy;
begin
  if not (csDesigning in ComponentState) then
  begin
    // Clean up and terminate.
    wglMakeCurrent(0, 0);
    wglDeleteContext(hrc);

    if (Palette <> 0) then
      DeleteObject(Palette);
  end;
  inherited;
end;

procedure TGLPanel.GLReDraw;
begin
  NewPaint;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TGLPanel]);
end;

end.