teeglcanvas.pas

BCB第三方组件

Const tmpSpec=0.99;
      tmpDif =0.99;
      tmpAmb =0.1;
var tmp : GLMat;
begin
  glEnable(GL_LIGHTING);
  glEnable(Num);
  AssertLight('EnableLight');

  tmp[0]:=tmpAmb;
  tmp[1]:=tmpAmb;
  tmp[2]:=tmpAmb;
  tmp[3]:=1;
  tmp:=AColor;
  glLightfv(Num,GL_AMBIENT, PGLFloat(@tmp));
  AssertLight('LightAmbient');

  tmp[0]:=tmpDif;
  tmp[1]:=tmpDif;
  tmp[2]:=tmpDif;
  tmp[3]:=1;
  glLightfv(Num,GL_DIFFUSE, PGLFloat(@tmp));
  AssertLight('LightDiffuse');

  tmp[0]:=tmpSpec;
  tmp[1]:=tmpSpec;
  tmp[2]:=tmpSpec;
  tmp[3]:=1;
  glLightfv(Num,GL_SPECULAR, PGLFloat(@tmp));
  AssertLight('LightSpecular');

  tmp[0]:=  Position.X;
  tmp[1]:= -Position.Y;
  tmp[2]:= -Position.Z;
  tmp[3]:=1;
  glLightfv(Num,GL_POSITION, PGLFloat(@tmp));
  AssertLight('LightPosition');

  if UseDirection then
  begin
    tmp[0]:=  Direction.X;
    tmp[1]:= -Direction.Y;
    tmp[2]:= -Direction.Z;
  end
  else
  begin
    tmp[0]:=0;
    tmp[1]:=0;
    tmp[2]:=1;
  end;

  tmp[3]:=0;

  glLightfv(Num,GL_SPOT_DIRECTION, PGLFloat(@tmp));
  AssertLight('LightDirection');

  if SpotDegrees=180 then
     glLightf(Num,GL_SPOT_CUTOFF,TeeDefaultLightSpot)
  else
     glLightf(Num,GL_SPOT_CUTOFF,SpotDegrees);

  AssertLight('LightSpot');
end;

Procedure TGLCanvas.ShowImage(DestCanvas,DefaultCanvas:TCanvas; Const UserRect:TRect);
begin
  glFlush;
  Assert(CheckGLError,'Flush');

  {$IFNDEF LINUX}
  SwapBuffers(GetDCHandle);
  {$ENDIF}

  SetCanvas(DefaultCanvas);
  Assert(CheckGLError,'ShowImage');

  if IDrawToBitmap then  // 7.02
     DeleteTextures;
end;

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

procedure TGLCanvas.Rectangle(X0,Y0,X1,Y1:Integer);
begin
  if Brush.Style<>bsClear then
     FillRect(TeeRect(X0,Y0,X1,Y1));

  if Pen.Style<>psClear then
  begin
    SetPen;
    glBegin(GL_LINE_LOOP);
    TeeVertex2D(X0,Y0);
    TeeVertex2D(X1,Y0);
    TeeVertex2D(X1,Y1);
    TeeVertex2D(X0,Y1);
    glEnd;
  end;

  Assert(CheckGLError,'Rectangle');
end;

procedure TGLCanvas.SetTextAlign(Align:Integer);
begin
  FTextAlign:=Align;
end;

procedure TGLCanvas.MoveTo(X, Y: Integer);
begin
  FX:=X;
  FY:=Y;
end;

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;
    inverse : Boolean;
begin
  inverse:=False;
  glPushMatrix;
  Radius:=Abs(Z1-Z0) div 2;

  if Left>Right then
  Begin
    inverse:=True;
    SwapInteger(Left,Right);
  end;
  if Top>Bottom then
  Begin
   inverse:=True;
   SwapInteger(Top,Bottom);
  end;
  if z0>z1 then SwapInteger(z0,z1);

  if Vertical then
  begin
    Radius:=MinInteger((Right-Left) div 2,Radius);
    if (inverse) then
    Begin
      glTranslatef((Left + Right) div 2, -Bottom, -(z0 + z1) div 2);
      glRotatef(270, 1, 0, 0);
    end
    else
    Begin
      glTranslatef((Left+Right) div 2,-Top,-(z0+z1) div 2);
      glRotatef(90,1,0,0);
    end;
    tmpSize:=Bottom-Top;
  end
  else
  begin
    Radius:=MinInteger((Bottom-Top) div 2,Radius);
    if (inverse) then
    Begin
      glTranslatef(Left,-(Top+Bottom) div 2,-(z0+z1) div 2);
      glRotatef(90,0,1,0);
    end
    else
    Begin
      glTranslatef(Right,-(Top+Bottom) div 2,-(z0+z1) div 2);
      glRotatef(270,0,1,0);
    end;
    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(const x,y,z,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.Sphere(x,y,z:Integer; Const Radius:Double);
begin
  Sphere(1.0*x,y,z,Radius);
end;

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

procedure TGLCanvas.SetPen;
begin
  SetPen(Pen);
end;

procedure TGLCanvas.SetPen(APen:TPen);
begin
  With APen 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