teeglcanvas.pas

Delphi TeeChartPro.6.01的源代码

{******************************************}
{    TeeChart Pro OpenGL Canvas            }
{ Copyright (c) 1998-2003 by David Berneda }
{       All Rights Reserved                }
{******************************************}
unit TeeGLCanvas;
{$I TeeDefs.inc}

{$IFOPT D-}
{$C-}  { Turn off assertions }
{$ENDIF}

interface

uses
   {$IFNDEF LINUX}
   Windows, Messages,
   {$ENDIF}
   SysUtils, Classes,
   {$IFDEF CLX}
   Qt, QGraphics, QControls, Types,
   {$ELSE}
   Graphics, Controls,
   {$ENDIF}
   {$IFDEF LINUX}
   OpenGLLinux,
   {$ELSE}
   OpenGL2,
   {$ENDIF}
   TeeConst, TeCanvas;

type  GLMat=Array[0..3] of GLFloat;

      {$IFDEF LINUX}
      PGLUQuadricObj=GLUQuadricObj;
      {$ENDIF}

var   TeeOpenGLFontExtrusion : Integer=0;

      TeeOpenGLFontName      : PChar=TeeMsg_DefaultEngFontName; //'Microsoft Sans Serif';

      TeeMaterialAmbient     : Double=1;
      TeeMaterialDiffuse     : Double=1;
      TeeMaterialSpecular    : Double=1;

      TeeFullLightModel :GLENum= GL_FALSE;
      TeeLightLocal     :GLENum= GL_FALSE;
      TeeColorPlanes    :GLENum= GL_FRONT_AND_BACK;

      TeeTextAngleY  : Integer=0;
      TeeTextAngleZ  : Integer=0;

      TeeDefaultLightSpot:Integer=180;

      TeeSphereSlices:Integer = 16;
      TeeSphereStacks:Integer = 16;

      TeeSmooth : Boolean = False;
      TeeSmoothQuality : GLEnum = GL_FASTEST;

      TeePerspectiveQuality : GLEnum = GL_NICEST;

const TeeFontListRange  = 128-32+1;

type
    TGLCanvas = class(TCanvas3D)
    private
      { Private declarations }
      FBackColor     : TColor;
      FBackMode      : TCanvasBackMode;

      FDepth         : Integer;
      FTextAlign     : Integer;

      FWidth         : Integer;
      FHeight        : Integer;
      FXCenter       : Integer;
      FYCenter       : Integer;

      FOnInit        : TNotifyEvent;

      { internal }
      FDC            : TTeeCanvasHandle;

      HRC            : HGLRC;
      FX             : Integer;
      FY             : Integer;
      FZ             : Integer;
      FIs3D          : Boolean;

      { fonts }
      TheFontHandle  : Integer;
      FontOffset     : Integer;
      IFontCreated   : Boolean;

      FUseBuffer     : Boolean;
      IDestCanvas    : TCanvas;
      IDrawToBitmap  : Boolean;
      FSavedError    : GLEnum;
      FQuadric       : PGLUQuadricObj;

      Function CalcPerspective:Double;
      Function CalcZoom:Double;
      Procedure DeleteTextures;
      Procedure DestroyGLContext;
      Procedure DoProjection;
      Procedure EndBrushBitmap;
      Function FindTexture(ABitmap:TBitmap):{$IFDEF LINUX}GLBoolean{$ELSE}GLUInt{$ENDIF};
      {$IFNDEF LINUX}
      Function GetDCHandle:HDC;
      {$ENDIF}
      Procedure InitMatrix;
      procedure SetBrushBitmap;
      Procedure SetColor(AColor:TColor);
      Procedure SetPen;
      Procedure TeeVertex2D(x,y:Integer);
      Procedure TeeVertex3D(x,y,z:Integer);
      Procedure TeeNormal(x,y,z:Integer);
      procedure InternalCylinder(Vertical:Boolean; Left,Top,Right,Bottom,
                          Z0,Z1:Integer; Dark3D:Boolean; ConePercent:Integer);
    protected
      { Protected declarations }
      {$IFNDEF LINUX}
      Procedure CreateFontOutlines;
      {$ENDIF}
      Procedure InitOpenGLFont;
      Procedure InitAmbientLight(AmbientLight:Integer);
      Procedure InitLight(Num:Integer; Const AColor:GLMat; Const X,Y,Z:Double);
      Procedure SetShininess(Const Value:Double);
      procedure SetDrawStyle(Value:TTeeCanvasSurfaceStyle);
    public
      FontOutlines   : Boolean;
      ShadeQuality   : Boolean;
      DrawStyle      : TTeeCanvasSurfaceStyle;

      { Public declarations }
      Constructor Create;
      Destructor Destroy; override;

      Function CheckGLError:Boolean;
      Procedure DeleteFont;
      Procedure Repaint;

      { 2d }
      Function GetSupports3DText:Boolean; override;
      Function GetSupportsFullRotation:Boolean; override;
      Function GetTextAlign:TCanvasTextAlign; override;
      Function GetUseBuffer:Boolean; override;
      Procedure SetUseBuffer(Value:Boolean); override;
      Function GetHandle:TTeeCanvasHandle; override;
      procedure SetPixel(X, Y: Integer; Value: TColor); override;

      { 3d }
      Procedure EnableRotation;
      Procedure DisableRotation;
      Procedure SetMaterialColor;

      procedure SetPixel3D(X,Y,Z:Integer; Value: TColor); override;

      Procedure SetBackMode(Mode:TCanvasBackMode); override;
      Function GetMonochrome:Boolean; override;
      Function GetPixel(x,y:Integer):TColor; override;
      Procedure SetMonochrome(Value:Boolean); override;
      Procedure SetBackColor(Color:TColor); override;
      Function GetBackMode:TCanvasBackMode; override;
      Function GetBackColor:TColor; override;
      Procedure SetTextAlign(Align:TCanvasTextAlign); override;

      Function BeginBlending(const R:TRect; Transparency:TTeeTransparency):TTeeBlend; override;
      procedure EndBlending(Blend:TTeeBlend); override;

      procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); override;
      procedure Donut( XCenter,YCenter,XRadius,YRadius:Integer;
                       Const StartAngle,EndAngle,HolePercent:Double); override;
      procedure Draw(X, Y: Integer; Graphic: TGraphic); override;
      procedure EraseBackground(const Rect: TRect); override;
      procedure FillRect(const Rect: TRect); override;
      procedure Frame3D( var Rect: TRect; TopColor,BottomColor: TColor;
                         Width: Integer); override;
      procedure Ellipse(X1, Y1, X2, Y2: Integer); override;
      procedure LineTo(X,Y:Integer); override;
      procedure MoveTo(X,Y:Integer); override;
      procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); override;
      procedure Rectangle(X0,Y0,X1,Y1:Integer); override;
      procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer); override;
      procedure StretchDraw(const Rect: TRect; Graphic: TGraphic); override;
      Procedure TextOut(X,Y:Integer; const Text:String); override;
      Procedure DoHorizLine(X0,X1,Y:Integer); override;
      Procedure DoVertLine(X,Y0,Y1:Integer); override;
      procedure ClipRectangle(Const Rect:TRect); override;
      procedure ClipCube(Const Rect:TRect; MinZ,MaxZ:Integer); override;
      procedure UnClipRectangle; override;
      Procedure GradientFill( Const Rect:TRect;
                              StartColor,EndColor:TColor;
                              Direction:TGradientDirection;
                              Balance:Integer=50); override;
      procedure RotateLabel(x,y:Integer; Const St:String; RotDegree:Integer); override;
      procedure RotateLabel3D(x,y,z:Integer;
                              Const St:String; RotDegree:Integer); override;
      Procedure Invalidate; override;
      Procedure Line(X0,Y0,X1,Y1:Integer); override;
      Procedure Polygon(const Points: array of TPoint); override;
      { 3d }
      Procedure Calculate2DPosition(Var x,y:Integer; z:Integer); override;
      Function Calculate3DPosition(x,y,z:Integer):TPoint; override;
      Procedure Projection(MaxDepth:Integer; const Bounds,Rect:TRect); override;
      Function InitWindow( DestCanvas:TCanvas;
                           A3DOptions:TView3DOptions;
                           ABackColor:TColor;
                           Is3D:Boolean;
                           Const UserRect:TRect):TRect; override;
      Procedure ShowImage(DestCanvas,DefaultCanvas:TCanvas; Const UserRect:TRect); override;
      Function ReDrawBitmap:Boolean; override;
      Procedure Arrow( Filled:Boolean;
                       Const FromPoint,ToPoint:TPoint;
                       ArrowWidth,ArrowHeight,Z:Integer); override;
      Procedure Cube(Left,Right,Top,Bottom,Z0,Z1:Integer; DarkSides:Boolean); override;
      procedure Cylinder(Vertical:Boolean; Left,Top,Right,Bottom,Z0,Z1:Integer; DarkCover:Boolean); override;
      procedure EllipseWithZ(X1, Y1, X2, Y2, Z:Integer); override;
      Procedure RectangleZ(Left,Top,Bottom,Z0,Z1:Integer); override;
      Procedure RectangleY(Left,Top,Right,Z0,Z1:Integer); override;
      procedure FrontPlaneBegin; override;
      procedure FrontPlaneEnd; override;
      Procedure HorizLine3D(Left,Right,Y,Z:Integer); override;
      procedure LineTo3D(X,Y,Z:Integer); override;
      Procedure LineWithZ(X0,Y0,X1,Y1,Z:Integer); override;
      procedure MoveTo3D(X,Y,Z:Integer); override;
      procedure Pie3D( XCenter,YCenter,XRadius,YRadius,Z0,Z1:Integer;
                       Const StartAngle,EndAngle:Double;
                       DarkSides,DrawSides:Boolean;
                       DonutPercent:Integer=0); override;
      procedure Plane3D(Const A,B:TPoint; Z0,Z1:Integer); override;
      procedure PlaneWithZ(P1,P2,P3,P4:TPoint; Z:Integer); override;
      procedure PlaneFour3D(Var Points:TFourPoints; Z0,Z1:Integer); override;
      procedure PolygonWithZ(Points: array of TPoint; Z:Integer); override;
      procedure Polyline(const Points:{$IFDEF D5}array of TPoint{$ELSE}TPointArray{$ENDIF}); override; // 6.0
      procedure Pyramid(Vertical:Boolean; Left,Top,Right,Bottom,z0,z1:Integer; DarkSides:Boolean); override;
      Procedure PyramidTrunc(Const R:TRect; StartZ,EndZ:Integer;
                             TruncX,TruncZ:Integer); override;
      Procedure RectangleWithZ(Const Rect:TRect; Z:Integer); override;
      Procedure Surface3D( Style:TTeeCanvasSurfaceStyle;
                           SameBrush:Boolean;
                           NumXValues,NumZValues:Integer;
                           CalcPoints:TTeeCanvasCalcPoints ); override;
      Procedure TextOut3D(X,Y,Z:Integer; const Text:String); override;
      procedure Triangle3D(Const Points:TTrianglePoints3D; Const Colors:TTriangleColors3D); override;
      procedure TriangleWithZ(Const P1,P2,P3:TPoint; Z:Integer); override;
      Procedure VertLine3D(X,Top,Bottom,Z:Integer); override;
      Procedure ZLine3D(X,Y,Z0,Z1:Integer); override;

      procedure Sphere(x,y,z:Integer; Const Radius:Double); override;
      procedure Cone(Vertical:Boolean; Left,Top,Right,Bottom,Z0,Z1:Integer; Dark3D:Boolean; ConePercent:Integer); override;

      { events }
      property OnInit:TNotifyEvent read FOnInit write FOnInit;
    published
    end;

Procedure ColorToGL(AColor:TColor; Var C:GLMat);

implementation

Uses Math;

Const TeeZoomScale     = -80000;
      TeeSolidCubeList =   8888;
      TeeWireCubeList  = TeeSolidCubeList+1;

var ITransp:Single=1;

Function MinInteger(a,b:Integer):Integer;
begin
  if a>b then result:=b else result:=a;
end;

Procedure ColorToGL(AColor:TColor; Var C:GLMat);
begin
  AColor:=ColorToRGB(AColor);
  C[0]:=Byte(AColor)/255;
  C[1]:=Byte(AColor shr 8)/255;
  C[2]:=Byte(AColor shr 16)/255;
  C[3]:=ITransp;
end;

{ TGLCanvas }
Constructor TGLCanvas.Create;
begin
  inherited Create;
  FSavedError:=GL_NO_ERROR;

(*
  // not necessary
  FUseBuffer:=False;
  IDestCanvas:=nil;
  IFontCreated:=False;
  FontOutlines:=False;
  Wireframe:=tcsSolid;
  FX:=0;
  FY:=0;
  FZ:=0;
  FIs3D:=False;
  HRC:=0;
  FQuadric:=nil;
*)

  FontZoom:=100;
  TheFontHandle:=-1;
  FTextAlign:=TA_LEFT;
end;

Procedure TGLCanvas.DestroyGLContext;
begin
  DeleteFont;

  if HRC<>0 then
  begin

    {$IFNDEF LINUX}
    DeactivateRenderingContext;
    DestroyRenderingContext(HRC);
    {$ENDIF}

    HRC:=0;
//    Assert(CheckGLError,'DestroyGLContext');
  end;
end;

Destructor TGLCanvas.Destroy;
begin
  if Assigned(FQuadric) then gluDeleteQuadric(FQuadric);
  DestroyGLContext;
  DeleteTextures;
  inherited;
end;

Function TGLCanvas.CheckGLError:Boolean;
begin
  FSavedError:=glGetError;
  result:=FSavedError=GL_NO_ERROR;
  if not result then
     FSavedError:=FSavedError+1-1;
end;

Procedure TGLCanvas.Calculate2DPosition(Var x,y:Integer; z:Integer);
begin { nothing yet }
end;

Function TGLCanvas.Calculate3DPosition(x,y,z:Integer):TPoint;
begin
  result:=TeePoint(x,y);
end;

Procedure TGLCanvas.DoProjection;
Var tmp  : Double;
    FarZ : Integer;
begin
  FarZ:=400*(FDepth+1);

  glViewport(0, 0, FWidth, FHeight);
  Assert(CheckGLError,'ViewPort'+IntToStr(FSavedError));

  glMatrixMode(GL_PROJECTION);
  Assert(CheckGLError,'Projection');
  glLoadIdentity;
  Assert(CheckGLError,'ProjectionInit');

  tmp:=100.0/CalcZoom;

  if (not FIs3D) or View3DOptions.Orthogonal then
  begin
    glOrtho(-FXCenter*tmp,FXCenter*tmp,-FYCenter*tmp,FYCenter*tmp,0.1,tmp*FarZ);
    Assert(CheckGLError,'Orthogonal');
  end
  else
  begin
    if tmp<1 then tmp:=1;
    gluPerspective(Math.Max(10,View3DOptions.Perspective),    // Field-of-view angle
                   FWidth/FHeight,  // Aspect ratio of viewing volume
                   0.1,             // Distance to near clipping plane
                   tmp*FarZ);       // Distance to far clipping plane
    Assert(CheckGLError,'Perspective');
  end;

  SetDrawStyle(DrawStyle);
end;

Procedure TGLCanvas.Projection(MaxDepth:Integer; const Bounds,Rect:TRect);
begin
  RectSize(Bounds,FWidth,FHeight);
  RectCenter(Rect,FXCenter,FYCenter);
  FDepth:=MaxDepth;
  DoProjection;
  InitMatrix;
end;

Function TGLCanvas.CalcPerspective:Double;
begin
  if FIs3D and (not View3DOptions.Orthogonal) then
     result:=Math.Max(10,View3DOptions.Perspective)*0.04
  else
     result:=1;
end;

Function TGLCanvas.CalcZoom:Double;
begin
  result:=Math.Max(1,View3DOptions.Zoom)*CalcPerspective;
end;

Procedure TGLCanvas.InitMatrix;
const tmpInv=1/255.0;
var AColor : TColor;
begin
  AColor:=ColorToRGB(FBackColor);
  glClearColor( GetRValue(AColor)*tmpInv,
                GetGValue(AColor)*tmpInv,
                GetBValue(AColor)*tmpInv,
                1);
  Assert(CheckGLError,'ClearColor');

  glDisable(GL_DITHER);

  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
  Assert(CheckGLError,'Clear');

  glEnable(GL_DITHER);

  glMatrixMode(GL_MODELVIEW);
  Assert(CheckGLError,'ModelView');
  glLoadIdentity;
  Assert(CheckGLError,'ModelInit');

  With View3DOptions do glTranslatef(HorizOffset,-VertOffset,TeeZoomScale/CalcZoom);

  if ShadeQuality then glShadeModel(GL_SMOOTH)
                  else glShadeModel(GL_FLAT);

  Assert(CheckGLError,'ShadeModel');

  if Assigned(FOnInit) then FOnInit(Self);

  Assert(CheckGLError,'Init');

  With View3DOptions do
  if FIs3D then
  begin
    glRotatef(Tilt, 0, 0, 1);
    if not Orthogonal then glRotatef(-Elevation, 1, 0, 0);
    glRotatef(Rotation, 0, 1, 0);
  end;

  glTranslatef( -FXCenter+RotationCenter.X,
                FYCenter+RotationCenter.Y,
                RotationCenter.Z+(0.5*FDepth));

  Assert(CheckGLError,'Rotations');

  if not Assigned(FQuadric) then FQuadric:=gluNewQuadric;
  if ShadeQuality then gluQuadricNormals(FQuadric,GL_SMOOTH)
                  else gluQuadricNormals(FQuadric,GL_FLAT);
  Assert(CheckGLError,'QuadricNormals');
end;

Procedure TGLCanvas.TeeVertex2D(x,y:Integer);
begin
  glVertex2i(x,-y);
end;

Procedure TGLCanvas.TeeVertex3D(x,y,z:Integer);
begin
  glVertex3i(x,-y,-z);
end;

Procedure TGLCanvas.TeeNormal(x,y,z:Integer);
begin
  glNormal3i(x,y,-z);
end;

Const MaxTextures=10;
Type TTeeTextureBits=Array[0..800*600,0..3] of GLUByte;
     PTeeTextureBits=^TTeeTextureBits;
     TTeeTexture=record
       Bits      : PTeeTextureBits;
       Bitmap    : Pointer;
       GLTexture : {$IFDEF LINUX}GLBoolean{$ELSE}GLUInt{$ENDIF};
     end;

Var ITextures:Array[0..MaxTextures-1] of TTeeTexture;
    NumTextures:Integer=0;

Procedure TGLCanvas.DeleteTextures;
var t:Integer;
begin
  for t:=0 to NumTextures-1 do Dispose(ITextures[t].Bits);
  NumTextures:=0;
end;

Function TGLCanvas.FindTexture(ABitmap:TBitmap):{$IFDEF LINUX}GLBoolean{$ELSE}GLUInt{$ENDIF};
var t,
    tt,
    tmpPos,
    tmpPos2 : Integer;
    tmp     : TColor;
    tmpLine : PByteArray;
begin
  for t:=0 to NumTextures-1 do
  if ITextures[t].Bitmap=ABitmap then
  begin
    result:=ITextures[t].GLTexture;
    exit;
  end;

  if NumTextures<MaxTextures then
  begin
    Inc(NumTextures);
    ITextures[NumTextures-1].Bitmap:=ABitmap;

    New(ITextures[NumTextures-1].Bits);

    With ABitmap do
    begin
      PixelFormat:=TeePixelFormat;

      for t:=0 to Height-1 do
      begin
        tmpLine:=PByteArray(ScanLine[t]);

        for tt:=0 to Width-1 do
        begin
          tmpPos:=t*Height+tt;
          {$IFDEF CLX}
          tmpPos2:=tt*4;
          {$ELSE}
          tmpPos2:=tt*3;
          {$ENDIF}

          With ITextures[NumTextures-1] do
          begin
            bits^[tmpPos,0]:=tmpLine[tmpPos2+2];
            bits^[tmpPos,1]:=tmpLine[tmpPos2+1];
            bits^[tmpPos,2]:=tmpLine[tmpPos2+0];
            bits^[tmpPos,3]:=255;
          end;
        end;
      end;
    end;

    glPixelStorei(GL_UNPACK_ALIGNMENT, 4);

    {$IFNDEF LINUX}
    glGenTextures(1, @ITextures[NumTextures-1].GLTexture);
    glBindTexture(GL_TEXTURE_2D, ITextures[NumTextures-1].GLTexture);
    {$ENDIF}

    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT);

    tmp:=GL_NEAREST;
    //tmp:=GL_LINEAR;
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, tmp);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, tmp);

    glTexEnvi(GL_TEXTURE_ENV,GL_TEXTURE_ENV_MODE,GL_MODULATE);

    With ABitmap do
      glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, Width, Height, 0,
                   GL_RGBA, GL_UNSIGNED_BYTE, ITextures[NumTextures-1].Bits);

    result:=ITextures[NumTextures-1].GLTexture;
  end
  else result:={$IFDEF LINUX}False{$ELSE}0{$ENDIF};
end;

procedure TGLCanvas.SetBrushBitmap;