teeglcanvas.pas

第三方控件：PaintGrid.pas 网格型仪表控件源文件 Mymeter.pas 圆型仪表控件源文件 Project1是这两个控件的使用范例。 该

procedure TGLCanvas.Pyramid(Vertical:Boolean; Left,Top,Right,Bottom,z0,z1:Integer; DarkSides:Boolean);
var AWidth,
    AHeight,
    ADepth:Integer;
begin
  glPushMatrix;

  glEnable(GL_CULL_FACE);

  if Vertical then
  begin
    if Left>Right then SwapInteger(Left,Right);
    if Top>Bottom then glDisable(GL_CULL_FACE);
  end
  else
  begin
    if Top>Bottom then SwapInteger(Top,Bottom);
    if Left>Right then glDisable(GL_CULL_FACE);
  end;

  if z0>z1 then SwapInteger(z0,z1);

  glTranslatef(Left,-Bottom,-z0);

  if Vertical then
  begin
    AWidth:=Right-Left;
    AHeight:=Top-Bottom;
  end
  else
  begin
    AWidth:=Bottom-Top;
    AHeight:=Right-Left;
    glRotatef(90,0,0,1);
  end;

  ADepth:=z1-z0;

  if Brush.Style<>bsClear then
  begin
    SetColor(Brush.Color);
    SetBrushBitmap;

    glBegin(GL_TRIANGLE_FAN);

    TeeNormal(AWidth div 2,-AHeight,ADepth div 2);

    TeeVertex3D(AWidth div 2,AHeight,ADepth div 2);
    TeeNormal(0,0,-1);
    TeeVertex2D(0,0);
    TeeNormal(1,0,-1);
    TeeVertex2D(AWidth,0);
    TeeNormal(1,0,1);
    TeeVertex3D(AWidth,0,ADepth);
    TeeNormal(0,0,1);
    TeeVertex3D(0,0,ADepth);
    TeeNormal(0,0,-1);
    TeeVertex2D(0,0);

    glEnd;

    RectangleY(0,0,AWidth,0,ADepth);

    EndBrushBitmap;
  end;

  glDisable(GL_CULL_FACE);

  if Pen.Style<>psClear then
  begin
    SetPen;
    glBegin(GL_LINE_LOOP);
    TeeVertex2D(0,0);
    TeeVertex2D(AWidth,0);
    TeeVertex3D(AWidth,0,ADepth);
    TeeVertex3D(0,0,ADepth);
    glEnd;
    glBegin(GL_LINE_STRIP);
    TeeVertex2D(0,0);
    TeeVertex3D(AWidth div 2,AHeight,ADepth div 2);
    TeeVertex3D(0,0,ADepth);
    glEnd;
    glBegin(GL_LINE_STRIP);
    TeeVertex2D(AWidth,0);
    TeeVertex3D(AWidth div 2,AHeight,ADepth div 2);
    TeeVertex3D(AWidth,0,ADepth);
    glEnd;
  end;

  glPopMatrix;
  Assert(CheckGLError,'Pyramid');
end;

procedure TGLCanvas.InternalCylinder(Vertical:Boolean;
                     Left,Top,Right,Bottom,Z0,Z1:Integer; Dark3D:Boolean;
                     ConePercent:Integer);
Var tmpSize,
    tmp,
    tmp2,
    Radius:Integer;
begin
  glPushMatrix;
  Radius:=Abs(Z1-Z0) div 2;

  if Left>Right then SwapInteger(Left,Right);
  if Top>Bottom then SwapInteger(Top,Bottom);
  if z0>z1 then SwapInteger(z0,z1);

  if Vertical then
  begin
    Radius:=MinInteger((Right-Left) div 2,Radius);
    glTranslatef((Left+Right) div 2,-Top,-(z0+z1) div 2);
    glRotatef(90,1,0,0);
    tmpSize:=Bottom-Top;
  end
  else
  begin
    Radius:=MinInteger((Bottom-Top) div 2,Radius);
    glTranslatef(Left,-(Top+Bottom) div 2,-(z0+z1) div 2);
    glRotatef(90,0,1,0);
    tmpSize:=Right-Left;
  end;

  if ConePercent=100 then tmp:=Radius
                     else tmp:=Round(0.01*ConePercent*Radius);

  tmp2:=Math.Min(TeeNumCylinderSides,6*Radius);

  if Brush.Style<>bsClear then
  begin
    glEnable(GL_CULL_FACE);
    SetColor(Brush.Color);
    SetBrushBitmap;

    gluCylinder(Quadric,tmp,Radius,tmpSize,tmp2,TeeCylinderStacks);

    EndBrushBitmap;

    if ConePercent=100 then
    begin
      gluQuadricOrientation(Quadric, GLU_INSIDE);
      gluDisk(Quadric,0,tmp,tmp2,TeeCylinderStacks);
      gluQuadricOrientation(Quadric, GLU_OUTSIDE);
      glPushMatrix;
      glTranslated(0,0,tmpSize);
      gluDisk(Quadric,0,tmp,tmp2,TeeCylinderStacks);
      glPopMatrix;
    end;

    glDisable(GL_CULL_FACE);
  end;

  if Pen.Style<>psClear then
  begin
    SetPen;

    gluQuadricDrawStyle(Quadric, GLU_LINE);
    gluCylinder(Quadric,tmp+0.5,Radius+0.5,tmpSize+0.5,tmp2,6);
    gluQuadricDrawStyle(Quadric, GLU_FILL);
  end;

  glPopMatrix;
end;

procedure TGLCanvas.Cylinder(Vertical:Boolean; Left,Top,Right,Bottom,Z0,Z1:Integer; DarkCover:Boolean);
begin
  InternalCylinder(Vertical,Left,Top,Right,Bottom,Z0,Z1,DarkCover,100);
  Assert(CheckGLError,'Cylinder');
end;

procedure TGLCanvas.Cone(Vertical:Boolean; Left,Top,Right,Bottom,Z0,Z1:Integer; Dark3D:Boolean; ConePercent:Integer);
begin
  InternalCylinder(Vertical,Left,Top,Right,Bottom,Z0,Z1,Dark3D,ConePercent);
  Assert(CheckGLError,'Cone');
end;

procedure TGLCanvas.Sphere(x,y,z:Integer; Const Radius:Double);
begin
  glPushMatrix;
  glTranslatef(x,-y,-z);

  if Brush.Style<>bsClear then
  begin
    SetColor(Brush.Color);
    glEnable(GL_CULL_FACE);
    SetBrushBitmap;

    gluSphere(Quadric,Radius,TeeSphereSlices,TeeSphereStacks);

    EndBrushBitmap;

    glDisable(GL_CULL_FACE);
  end;

  if Pen.Style<>psClear then // 6.0
  begin
    SetPen;
    gluQuadricDrawStyle(Quadric, GLU_LINE);
    gluSphere(Quadric,Radius,TeeSphereSlices,TeeSphereStacks);
    gluQuadricDrawStyle(Quadric, GLU_FILL);
  end;

  glPopMatrix;
  Assert(CheckGLError,'Sphere');
end;

Procedure TGLCanvas.SetColor(AColor:TColor); {$IFDEF CLR}unsafe;{$ENDIF}
var tmp : GLMat;
begin
  ColorToGL(AColor,tmp);
  glColor4fv(PGLFloat(@tmp));
end;

procedure TGLCanvas.SetPen;
begin
  With Pen do
  begin
    if Style=psSolid then glDisable(GL_LINE_STIPPLE)
    else
    begin
      glEnable(GL_LINE_STIPPLE);
      Case Style of
       psSolid   : glLineStipple(1,$FFFF);
       psDot     : glLineStipple(1,$5555);
       psDash    : glLineStipple(1,$00FF);
       psDashDot : glLineStipple(1,$55FF);
      else
       glLineStipple(1,$1C47);
      end;
    end;

    if not IDrawToBitmap then
       glLineWidth(Width);

    SetColor(Color);
  end;
  Assert(CheckGLError,'SetPen');
end;

procedure TGLCanvas.LineTo(X, Y: Integer);
begin
  SetPen;
  glBegin(GL_LINES);
    TeeVertex2D(FX,FY);
    TeeVertex2D(X,Y);
  glEnd;
  Assert(CheckGLError,'LineTo');

  FX:=X;
  FY:=Y;
end;

procedure TGLCanvas.ClipRectangle(Const Rect:TRect);
begin
end;

procedure TGLCanvas.ClipCube(Const Rect:TRect; MinZ,MaxZ:Integer);
begin
//  glEnable(GL_CLIP_PLANE0);
end;

procedure TGLCanvas.UnClipRectangle;
begin
//  glDisable(GL_CLIP_PLANE0);
end;

function TGLCanvas.GetBackColor:TColor;
begin
  result:=clWhite;
end;

procedure TGLCanvas.SetBackColor(Color:TColor);
begin
  FBackColor:=Color;
end;

procedure TGLCanvas.SetBackMode(Mode:TCanvasBackMode);
begin
  FBackMode:=Mode;
end;

Function TGLCanvas.GetMonochrome:Boolean;
begin
  result:=False;
end;

Function TGLCanvas.GetPixel(x,y:Integer):TColor;
begin
  result:=clWhite; // 6.0 How to do this in OpenGL ?
end;

Procedure TGLCanvas.SetMonochrome(Value:Boolean);
begin
end;

// Textures

Const MaxTextures=20;
      MaxSizeTexture=800*600;

Type
  TTeeTextureBits=Array[0..MaxSizeTexture, 0..BytesPerPixel] 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;
{$IFNDEF CLR}
var t:Integer;
{$ENDIF}
begin
  {$IFNDEF CLR}
  for t:=0 to NumTextures-1 do Dispose(ITextures[t].Bits);
  {$ENDIF}
  NumTextures:=0;
end;

Function TGLCanvas.FindTexture(ABitmap:TBitmap):{$IFDEF LINUX}GLBoolean{$ELSE}GLUInt{$ENDIF};
{$IFNDEF CLR}

  Function ValidSize:Boolean;
  var MaxSize : Array[0..0] of Integer;
      tmp : Extended;
  begin
    glGetIntegerv(GL_MAX_TEXTURE_SIZE,@MaxSize);

    result:=(ABitmap.Width<=MaxSize[0]) and (ABitmap.Height<=MaxSize[0]);

    if result then
    begin
      tmp:=Log2(ABitmap.Width);
      result:=Round(tmp)=tmp;

      if result then
      begin
        tmp:=Log2(ABitmap.Height);
        result:=Round(tmp)=tmp;
      end;
    end;
  end;

var t,
    tt,
    tmpPos,
    tmpPos2 : Integer;
    tmp     : TColor;
    tmpLine : PByteArray;
    tmpMode : Integer;
{$ENDIF}
begin
  {$IFNDEF CLR}
  for t:=0 to NumTextures-1 do
  if ITextures[t].Bitmap=ABitmap then
  begin
    result:=ITextures[t].GLTexture;
    exit;
  end;

  if (NumTextures<MaxTextures) and ValidSize 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;
          tmpPos2:=tt*BytesPerPixel;

          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);
    Assert(CheckGLError,'GenTextures');
    glBindTexture(GL_TEXTURE_2D, ITextures[NumTextures-1].GLTexture);
    Assert(CheckGLError,'BinTexture');
    {$ENDIF}

    if TeeWrapTextures then tmpMode:=GL_REPEAT
                       else tmpMode:=GL_CLAMP;

    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, tmpMode);
    Assert(CheckGLError,'TexParam1');
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, tmpMode);
    Assert(CheckGLError,'TexParam2');

    tmp:=GL_NEAREST;
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, tmp);
    Assert(CheckGLError,'TexParam3');
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, tmp);
    Assert(CheckGLError,'TexParam4');

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

    Assert(CheckGLError,'TextImage2D');

    result:=ITextures[NumTextures-1].GLTexture;

  end
  else result:={$IFDEF LINUX}False{$ELSE}0{$ENDIF};

  {$ELSE}
  result:=0;

  {$ENDIF}
end;

procedure TGLCanvas.StretchDraw(const Rect: TRect; Graphic: TGraphic);
var tmp : TBitmap;
    Old : Boolean;
begin
  if Assigned(Graphic) then
  begin
    if Graphic is TBitmap then
       tmp:=TBitmap(Graphic)
    else
    begin
      tmp:=TBitmap.Create;
      tmp.Assign(Graphic);
    end;

    Old:=TeeWrapTextures;
    TeeWrapTextures:=False;

    if SetBrushBitmap(tmp) then
    begin
      glDisable(GL_TEXTURE_GEN_S);  // 7.02
      glDisable(GL_TEXTURE_GEN_T);
      glColor3f(1, 1, 1);
      InternalRectangle(Rect);
      EndBrushBitmap(tmp);
    end;

    TeeWrapTextures:=Old;

    if not (Graphic is TBitmap) then
       tmp.Free;

    Assert(CheckGLError,'StretchDraw');
  end;
end;

procedure TGLCanvas.Draw(X, Y: Integer; Graphic: TGraphic);
begin
  if Assigned(Graphic) then
     StretchDraw(TeeRect(X,Y,X+Graphic.Width,Y+Graphic.Height),Graphic);
end;

Procedure TGLCanvas.GradientFill( Const Rect:TRect;
                                  StartColor,EndColor:TColor;
                                  Direction:TGradientDirection;
                                  Balance:Integer=50);

  Procedure DoVertical(AStartColor,AEndColor:TColor);
  begin
    With Rect do
    begin
      SetColor(AEndColor);
      TeeVertex3D(Right,Bottom,GradientZ);
      SetColor(AStartColor);
      TeeVertex3D(Right,Top,GradientZ);
      TeeVertex3D(Left, Top,GradientZ);
      SetColor(AEndColor);
      TeeVertex3D(Left, Bottom,GradientZ);
    end;
  end;

  Procedure DoHorizontal(AStartColor,AEndColor:TColor);
  begin
    With Rect do
    begin
      SetColor(AEndColor);
      TeeVertex3D(Right,Bottom,GradientZ);
      TeeVertex3D(Right,Top,GradientZ);
      SetColor(AStartColor);
      TeeVertex3D(Left, Top,GradientZ);
      TeeVertex3D(Left, Bottom,GradientZ);
    end;
  end;

  Procedure DoDiagonal(AStartColor,AEndColor:TColor);

    procedure SetMidColor(A,B:TColor); {$IFDEF CLR}unsafe;{$ENDIF}
    var tmpA, tmpB : GLMat;
    begin
      ColorToGL(A,tmpA);
      ColorToGL(B,tmpB);
      tmpA[0]:=(tmpA[0]+tmpB[0])*0.5;
      tmpA[1]:=(tmpA[1]+tmpB[1])*0.5;
      tmpA[2]:=(tmpA[2]+tmpB[2])*0.5;

      glColor4fv(PGLFloat(@tmpA));
    end;

  begin
    With Rect do
    begin
      SetColor(AEndColor);
      TeeVertex3D(Right,Bottom,GradientZ);
      SetMidColor(AEndColor, AStartColor);
      TeeVertex3D(Right,Top,GradientZ);
      SetColor(AStartColor);
      TeeVertex3D(Left, Top,GradientZ);
      SetMidColor(AEndColor, AStartColor);
      TeeVertex3D(Left, Bottom,GradientZ);
    end;