绘制球体上德尔福的TImage控制(Draw Sphere on TImage control of

2019-08-17 22:07发布

站内文章 / 前端开发
58 0 0

我想提请球是这样的：

下面的代码生成圆的顶点和借鉴的TImage一个圈，但我想它SPHERE： 

for i := 0 to 360 do begin 
   //Find value of X and Y 
   pntCordXY.X := Radius * Cos(DegToRad(i)); 
   pntCordXY.Y := Radius * Sin(DegToRad(i)); 
   if i = 0 then 
      image1.Canvas.MoveTo(Round(pntCordXY.X), Round(pntCordXY.Y)) 
   else 
      image1.Canvas.LineTo(Round(pntCordXY.X), Round(pntCordXY.Y)); 
end;

Answer 1:

事实证明，这是一个有趣的练习; 有趣的问题！

起初，你特别要求在做出这一领域TImage ，但该组件被认为可以用于显示图形。 当然，这有一个画布上由此可以得出，但我下面用一个TPaintBox这是自己画的首选组件。 因为，你将不得不这样画自己。 完全。

主料需要：

  • 一些数学计算在球体上的3D点，用于旋转围绕多个轴线全球，也许用于3D点转换成2D屏幕坐标系统。 基本要点有： 

     type TPoint3D = record X: Double; Y: Double; Z: Double; end; function Sphere(Phi, Lambda: Double): TPoint3D; begin Result.X := Cos(Phi) * Sin(Lambda); Result.Y := Sin(Phi); Result.Z := Cos(Phi) * Cos(Lambda); end; function RotateAroundX(const P: TPoint3D; Alfa: Double): TPoint3D; begin Result.X := PX; Result.Y := PY * Cos(Alfa) + PZ * Sin(Alfa); Result.Z := PY * -Sin(Alfa) + PZ * Cos(Alfa); end; function RotateAroundY(const P: TPoint3D; Beta: Double): TPoint3D; begin Result.X := PX * Cos(Beta) + PZ * Sin(Beta); Result.Y := PY; Result.Z := PX * -Sin(Beta) + PZ * Cos(Beta); end;

  • 一些全球变量一起工作： 

     var Alfa: Integer; //Rotation around X axis Beta: Integer; //Rotation around Y axis C: TPoint; //Center R: Integer; //Radius Phi: Integer; //Angle relative to XY plane Lambda: Integer; //Angle around Z axis (from pole to pole) P: TPoint3D; //2D projection of a 3D point on the sphere's surface

  • 代码来计算纬度圈的所有点： 

     for Phi := -8 to 8 do for Lambda := 0 to 360 do begin P := Sphere(DegToRad(Phi * 10), DegToRad(Lambda)); P := RotateAroundX(P, Alfa); P := RotateAroundY(P, Beta); end;

  • 代码来计算经度经脉的所有点： 

     for Lambda := 0 to 17 do for Phi := 0 to 360 do begin P := Sphere(DegToRad(Phi), DegToRad(Lambda * 10)); P := RotateAroundX(P, Alfa); P := RotateAroundY(P, Beta); end;

    这些点可以用来画上颜料盒直线或曲线。 这些点的Z值不用于绘画，但他们是有帮助的决定点是否位于地球的背面或正面。

  • 逻辑和艾滋病。 可以得出在全球前所有的点，直线或曲线之前，在地球后面的那些必须首先绘制，为了保持深度 。

  • 绘图框架或图形库。 德尔福是默认配备了标准的Windows GDI，可通过Canvas的颜料盒的财产。 另一种可能性是GDI +这是更先进的，并且可以是更有效的。 特别是考虑到反aliassing。 这是两个框架和我一起工作，但也有其他人。 例如：OpenGL中，其将3D对象自动至2D，并且能够添加3D表面，信号灯，材料，着色器，以及许多其他功能的。

  • 一种测试应用程序，这是在这个问题的底部加入。

  • 双缓冲技术来获得涂装工作，无闪烁。 我选择上一切都绘制一个单独的位图对象，之前画上油漆框位图。 演示程序还演示了没有它的性能（常规： GDIMultipleColorsDirect ）。

建立：

掉落油漆盒窗体上，并将其设置为Align属性alClient ，添加一个定时器组件进行仿真，添加表单事件处理程序OnCreate ， OnDestroy ， OnKeyPress ，和OnResize ，然后添加一个事件处理程序PaintBox1.OnPaint 。 

object Form1: TForm1
  Left = 497
  Top = 394
  Width = 450
  Height = 450
  Caption = 'Sphere'
  Color = clWhite
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnKeyPress = FormKeyPress
  OnResize = FormResize
  PixelsPerInch = 96
  TextHeight = 13
  object PaintBox1: TPaintBox
    Left = 0
    Top = 0
    Width = 434
    Height = 414
    Align = alClient
    OnPaint = PaintBox1Paint
  end
  object Timer1: TTimer
    Interval = 25
    OnTimer = Timer1Timer
    Left = 7
    Top = 7
  end
end

第一次尝试：

在默认GDI，我吸取每一点每一个点线。 要添加的深度（透视）的感觉，我给前面的线更大的宽度。 另外，我逐渐让从暗线溢出的颜色的光（常规： GDIMultipleColors ）。

第二次尝试：

尼斯，但所有的像素是这么难！ 让我们尝试做一些抗aliassing ourselfs ...;）。此外，我减少了色彩数到二：黑暗就在眼前，光在后面。 这是为了摆脱所有单独的线段：现在每圈和经络分为两条折线。 （：常规我在用于抗aliassing效果之间使用的第三颜色GDIThreeColors ）。

GDI +救援：

这个反aliassing不是最迷人的。 要获得真正的平滑的油漆工作，让我们的代码转换为GDI +的风格。 对于2009年Delphi和起来，该库可从这里 。 对于老版本的Delphi，该库可从这里 。

在GDI +，绘图工作稍有不同。 创建一个TGPGraphics对象并将其连接到与它的构造设备上下文。 随后，在物体上绘制操作由API翻译和将被输出到的目的地上下文，在这种情况下，位图（常规： GDIPlusDualLinewidths ）。

可以做得更好？

嗯，这是相当成才了。 但是，这个地球是编造出来的折线只用两种不同的线宽。 让我们添加一些介于两者之间。 在每一个圆或子午线段的计数由受控Precision （：常规恒定GDIPlusMultipleLinewidths ）。

示例应用程序：

按下一键循环通过上述程序。 

unit Globe;

interface

uses
  Windows, SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls, Math,
  GDIPAPI, GDIPOBJ;

type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure PaintBox1Paint(Sender: TObject);
  private
    FBmp: TBitmap;
    FPen: TGPPen;
    procedure GDIMultipleColorsDirect;
    procedure GDIMultipleColors;
    procedure GDIThreeColors;
    procedure GDIPlusDualLinewidths;
    procedure GDIPlusMultipleLinewidths;
  public
    A: Integer; //Alfa, rotation round X axis
    B: Integer; //Beta, rotation round Y axis
    C: TPoint;  //Center
    R: Integer; //Radius
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
  LineColorFore = $00552B00;
  LineColorMiddle = $00AA957F;
  LineColorBack = $00FFDFBF;
  BackColor = clWhite;
  LineWidthFore = 4.5;
  LineWidthBack = 1.5;
  Precision = 10; //Should be even!

type
  TCycle = 0..Precision - 1;

  TPoint3D = record
    X: Double;
    Y: Double;
    Z: Double;
  end;

function Sphere(Phi, Lambda: Double): TPoint3D;
begin
  Result.X := Cos(Phi) * Sin(Lambda);
  Result.Y := Sin(Phi);
  Result.Z := Cos(Phi) * Cos(Lambda);
end;

function RotateAroundX(const P: TPoint3D; Alfa: Double): TPoint3D;
begin
  Result.X := P.X;
  Result.Y := P.Y * Cos(Alfa) + P.Z * Sin(Alfa);
  Result.Z := P.Y * -Sin(Alfa) + P.Z * Cos(Alfa);
end;

function RotateAroundY(const P: TPoint3D; Beta: Double): TPoint3D;
begin
  Result.X := P.X * Cos(Beta) + P.Z * Sin(Beta);
  Result.Y := P.Y;
  Result.Z := P.X * -Sin(Beta) + P.Z * Cos(Beta);
end;

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  Brush.Style := bsClear; //This is múch cheaper then DoubleBuffered := True
  FBmp := TBitmap.Create;
  FPen := TGPPen.Create(ColorRefToARGB(ColorToRGB(clBlack)));
  A := 35;
  B := 25;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FPen.Free;
  FBmp.Free;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  C.X := PaintBox1.ClientWidth div 2;
  C.Y := PaintBox1.ClientHeight div 2;
  R := Min(C.X, C.Y) - 10;
  FBmp.Width := PaintBox1.ClientWidth;
  FBmp.Height := PaintBox1.ClientHeight;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  A := A + 2;
  B := B + 1;
  PaintBox1.Invalidate;
end;

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
  Tag := Tag + 1;
  PaintBox1.Invalidate;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  case Tag mod 5 of
    0: GDIMultipleColorsDirect;
    1: GDIMultipleColors;
    2: GDIThreeColors;
    3: GDIPlusDualLinewidths;
    4: GDIPlusMultipleLinewidths;
  end;
end;

procedure TForm1.GDIPlusMultipleLinewidths;
var
  Lines: array of TPointFDynArray;
  PointCount: Integer;
  LineCount: Integer;
  Drawing: TGPGraphics;
  Alfa: Double;
  Beta: Double;
  Cycle: TCycle;
  Phi: Integer;
  Lambda: Integer;
  P: TPoint3D;
  Filter: TCycle;
  PrevFilter: TCycle;
  I: Integer;

  procedure ResetLines;
  begin
    SetLength(Lines, 0);
    LineCount := 0;
    PointCount := 0;
  end;

  procedure FinishLastLine;
  begin
    if PointCount < 2 then
      Dec(LineCount)
    else
      SetLength(Lines[LineCount - 1], PointCount);
  end;

  procedure NewLine;
  begin
    if LineCount > 0 then
      FinishLastLine;
    SetLength(Lines, LineCount + 1);
    SetLength(Lines[LineCount], 361);
    Inc(LineCount);
    PointCount := 0;
  end;

  procedure AddPoint(X, Y: Single);
  begin
    Lines[LineCount - 1][PointCount] := MakePoint(X, Y);
    Inc(PointCount);
  end;

  function CycleFromZ(Z: Single): TCycle;
  begin
    Result := Round((Z + 1) / 2 * High(TCycle));
  end;

  function CycleToLineWidth(ACycle: TCycle): Single;
  begin
    Result := LineWidthBack +
      (LineWidthFore - LineWidthBack) * (ACycle / High(TCycle));
  end;

  function CycleToLineColor(ACycle: TCycle): TGPColor;
  begin
    if ACycle <= (High(TCycle) div 2) then
      Result := ColorRefToARGB(ColorToRGB(LineColorBack))
    else
      Result := ColorRefToARGB(ColorToRGB(LineColorFore));
  end;

begin
  Drawing := TGPGraphics.Create(FBmp.Canvas.Handle);
  try
    Drawing.Clear(ColorRefToARGB(ColorToRGB(clWhite)));
    Drawing.SetSmoothingMode(SmoothingModeAntiAlias);
    Alfa := DegToRad(A);
    Beta := DegToRad(B);
    for Cycle := Low(TCycle) to High(TCycle) do
    begin
      ResetLines;
      //Latitude
      for Phi := -8 to 8 do
      begin
        NewLine;
        PrevFilter := 0;
        for Lambda := 0 to 360 do
        begin
          P := Sphere(DegToRad(Phi * 10), DegToRad(Lambda));
          P := RotateAroundX(P, Alfa);
          P := RotateAroundY(P, Beta);
          Filter := CycleFromZ(P.Z);
          if Filter <> PrevFilter then
          begin
            AddPoint(C.X + P.X * R, C.Y + P.Y * R);
            NewLine;
          end;
          if Filter = Cycle then
            AddPoint(C.X + P.X * R, C.Y + P.Y * R);
          PrevFilter := Filter;
        end;
      end;
      //Longitude
      for Lambda := 0 to 17 do
      begin
        NewLine;
        PrevFilter := 0;
        for Phi := 0 to 360 do
        begin
          P := Sphere(DegToRad(Phi), DegToRad(Lambda * 10));
          P := RotateAroundX(P, Alfa);
          P := RotateAroundY(P, Beta);
          Filter := CycleFromZ(P.Z);
          if Filter <> PrevFilter then
          begin
            AddPoint(C.X + P.X * R, C.Y + P.Y * R);
            NewLine;
          end;
          if Filter = Cycle then
            AddPoint(C.X + P.X * R, C.Y + P.Y * R);
          PrevFilter := Filter;
        end;
      end;
      FinishLastLine;
      FPen.SetColor(CycleToLineColor(Cycle));
      FPen.SetWidth(CycleToLineWidth(Cycle));
      for I := 0 to LineCount - 1 do
        Drawing.DrawLines(FPen, PGPPointF(@(Lines[I][0])), Length(Lines[I]));
      if Cycle = (High(TCycle) div 2 + 1) then
        Drawing.DrawEllipse(FPen, C.X - R, C.Y - R, 2 * R, 2 * R);
    end;
  finally
    Drawing.Free;
  end;
  PaintBox1.Canvas.Draw(0, 0, FBmp);
end;

procedure TForm1.GDIPlusDualLinewidths;
const
  LineColors: array[Boolean] of TColor = (LineColorFore, LineColorBack);
  LineWidths: array[Boolean] of Single = (LineWidthFore, LineWidthBack);
  BackColor = clWhite;
var
  Lines: array of TPointFDynArray;
  PointCount: Integer;
  LineCount: Integer;
  Drawing: TGPGraphics;
  Alfa: Double;
  Beta: Double;
  Phi: Integer;
  Lambda: Integer;
  BackSide: Boolean;
  P: TPoint3D;
  PrevZ: Double;
  I: Integer;

  procedure ResetLines;
  begin
    SetLength(Lines, 0);
    LineCount := 0;
    PointCount := 0;
  end;

  procedure FinishLastLine;
  begin
    if PointCount < 2 then
      Dec(LineCount)
    else
      SetLength(Lines[LineCount - 1], PointCount);
  end;

  procedure NewLine;
  begin
    if LineCount > 0 then
      FinishLastLine;
    SetLength(Lines, LineCount + 1);
    SetLength(Lines[LineCount], 361);
    Inc(LineCount);
    PointCount := 0;
  end;

  procedure AddPoint(X, Y: Single);
  begin
    Lines[LineCount - 1][PointCount] := MakePoint(X, Y);
    Inc(PointCount);
  end;

begin
  Drawing := TGPGraphics.Create(FBmp.Canvas.Handle);
  try
    Drawing.Clear(ColorRefToARGB(ColorToRGB(clWhite)));
    Drawing.SetSmoothingMode(SmoothingModeAntiAlias);
    Alfa := DegToRad(A);
    Beta := DegToRad(B);
    for BackSide := True downto False do
    begin
      ResetLines;
      //Latitude
      for Phi := -8 to 8 do
      begin
        NewLine;
        PrevZ := 0;
        for Lambda := 0 to 360 do
        begin
          P := Sphere(DegToRad(Phi * 10), DegToRad(Lambda));
          P := RotateAroundX(P, Alfa);
          P := RotateAroundY(P, Beta);
          if Sign(P.Z) <> Sign(PrevZ) then
            NewLine;
          if (BackSide and (P.Z < 0)) or (not BackSide and (P.Z >= 0)) then
            AddPoint(C.X + P.X * R, C.Y + P.Y * R);
          PrevZ := P.Z;
        end;
      end;
      //Longitude
      for Lambda := 0 to 17 do
      begin
        NewLine;
        PrevZ := 0;
        for Phi := 0 to 360 do
        begin
          P := Sphere(DegToRad(Phi), DegToRad(Lambda * 10));
          P := RotateAroundX(P, Alfa);
          P := RotateAroundY(P, Beta);
          if Sign(P.Z) <> Sign(PrevZ) then
            NewLine;
          if (BackSide and (P.Z < 0)) or (not BackSide and (P.Z >= 0)) then
            AddPoint(C.X + P.X * R, C.Y + P.Y * R);
          PrevZ := P.Z;
        end;
      end;
      FinishLastLine;
      FPen.SetColor(ColorRefToARGB(ColorToRGB(LineColors[BackSide])));
      FPen.SetWidth(LineWidths[BackSide]);
      for I := 0 to LineCount - 1 do
        Drawing.DrawLines(FPen, PGPPointF(@(Lines[I][0])), Length(Lines[I]));
    end;
    Drawing.DrawEllipse(FPen, C.X - R, C.Y - R, 2 * R, 2 * R);
  finally
    Drawing.Free;
  end;
  PaintBox1.Canvas.Draw(0, 0, FBmp);
end;

procedure TForm1.GDIThreeColors;
const
  LineColors: array[TValueSign] of TColor = (LineColorBack, LineColorMiddle,
    LineColorFore);
  LineWidths: array[TValueSign] of Integer = (2, 4, 2);
var
  Lines: array of array of TPoint;
  PointCount: Integer;
  LineCount: Integer;
  Alfa: Double;
  Beta: Double;
  Phi: Integer;
  Lambda: Integer;
  BackSide: Boolean;
  P: TPoint3D;
  PrevZ: Double;
  I: TValueSign;
  J: Integer;

  procedure ResetLines;
  begin
    SetLength(Lines, 0);
    LineCount := 0;
    PointCount := 0;
  end;

  procedure FinishLastLine;
  begin
    if PointCount < 2 then
      Dec(LineCount)
    else
      SetLength(Lines[LineCount - 1], PointCount);
  end;

  procedure NewLine;
  begin
    if LineCount > 0 then
      FinishLastLine;
    SetLength(Lines, LineCount + 1);
    SetLength(Lines[LineCount], 361);
    Inc(LineCount);
    PointCount := 0;
  end;

  procedure AddPoint(APoint: TPoint); overload;
  var
    Last: TPoint;
  begin
    if PointCount > 0 then
    begin
      Last := Lines[LineCount - 1][PointCount - 1];
      if (APoint.X = Last.X) and (APoint.Y = Last.Y) then
        Exit;
    end;
    Lines[LineCount - 1][PointCount] := APoint;
    Inc(PointCount);
  end;

  procedure AddPoint(X, Y: Integer); overload;
  begin
    AddPoint(Point(X, Y));
  end;

begin
  FBmp.Canvas.Brush.Color := BackColor;
  FBmp.Canvas.FillRect(Rect(0, 0, FBmp.Width, FBmp.Height));
  Alfa := DegToRad(A);
  Beta := DegToRad(B);
  for BackSide := True downto False do
  begin
    ResetLines;
    //Latitude
    for Phi := -8 to 8 do
    begin
      NewLine;
      PrevZ := 0;
      for Lambda := 0 to 360 do
      begin
        P := Sphere(DegToRad(Phi * 10), DegToRad(Lambda));
        P := RotateAroundX(P, Alfa);
        P := RotateAroundY(P, Beta);
        if Sign(P.Z) <> Sign(PrevZ) then
          NewLine;
        if (BackSide and (P.Z < 0)) or (not BackSide and (P.Z >= 0)) then
          AddPoint(Round(C.X + P.X * R), Round(C.Y + P.Y * R));
        PrevZ := P.Z;
      end;
    end;
    //Longitude
    for Lambda := 0 to 17 do
    begin
      NewLine;
      PrevZ := 0;
      for Phi := 0 to 360 do
      begin
        P := Sphere(DegToRad(Phi), DegToRad(Lambda * 10));
        P := RotateAroundX(P, Alfa);
        P := RotateAroundY(P, Beta);
        if Sign(P.Z) <> Sign(PrevZ) then
          NewLine;
        if (BackSide and (P.Z < 0)) or (not BackSide and (P.Z >= 0)) then
          AddPoint(Round(C.X + P.X * R), Round(C.Y + P.Y * R));
        PrevZ := P.Z;
      end;
    end;
    FinishLastLine;
    if BackSide then
    begin
      FBmp.Canvas.Pen.Color := LineColors[-1];
      FBmp.Canvas.Pen.Width := LineWidths[-1];
      for J := 0 to LineCount - 1 do
        FBmp.Canvas.Polyline(Lines[J]);
    end
    else
      for I := 0 to 1 do
      begin
        FBmp.Canvas.Pen.Color := LineColors[I];
        FBmp.Canvas.Pen.Width := LineWidths[I];
        for J := 0 to LineCount - 1 do
          FBmp.Canvas.Polyline(Lines[J])
      end
  end;
  FBmp.Canvas.Brush.Style := bsClear;
  FBmp.Canvas.Ellipse(C.X - R, C.Y - R, C.X + R, C.Y + R);
  PaintBox1.Canvas.Draw(0, 0, FBmp);
end;

procedure TForm1.GDIMultipleColors;
var
  Alfa: Double;
  Beta: Double;
  Phi: Integer;
  Lambda: Integer;
  P: TPoint3D;
  Backside: Boolean;

  function ColorFromZ(Z: Single): TColorRef;
  var
    R: Integer;
    G: Integer;
    B: Integer;
  begin
    Z := (Z + 1) / 2;
    R := GetRValue(LineColorFore) - GetRValue(LineColorBack);
    R := GetRValue(LineColorBack) + Round(Z * R);
    G := GetGValue(LineColorFore) - GetGValue(LineColorBack);
    G := GetGValue(LineColorBack) + Round(Z * G);
    B := GetBValue(LineColorFore) - GetBValue(LineColorBack);
    B := GetBValue(LineColorBack) + Round(Z * B);
    Result := RGB(R, G, B);
  end;

begin
  FBmp.Canvas.Pen.Width := 2;
  FBmp.Canvas.Brush.Color := BackColor;
  FBmp.Canvas.FillRect(PaintBox1.ClientRect);
  Alfa := DegToRad(A);
  Beta := DegToRad(B);
  for Backside := True downto False do
  begin
    if not BackSide then
      FBmp.Canvas.Pen.Width := 3;
    //Latitude
    for Phi := -8 to 8 do
      for Lambda := 0 to 360 do
      begin
        P := Sphere(DegToRad(Phi * 10), DegToRad(Lambda));
        P := RotateAroundX(P, Alfa);
        P := RotateAroundY(P, Beta);
        if (Lambda = 0) or (Backside and (P.Z >= 0)) or
          (not Backside and (P.Z < 0)) then
            FBmp.Canvas.MoveTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R))
        else
        begin
          FBmp.Canvas.Pen.Color := ColorFromZ(P.Z);
          FBmp.Canvas.LineTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R));
        end;
      end;
    //Longitude
    for Lambda := 0 to 17 do
      for Phi := 0 to 360 do
      begin
        P := Sphere(DegToRad(Phi), DegToRad(Lambda * 10));
        P := RotateAroundX(P, Alfa);
        P := RotateAroundY(P, Beta);
        if (Phi = 0) or (Backside and (P.Z >= 0)) or
          (not Backside and (P.Z < 0)) then
            FBmp.Canvas.MoveTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R))
        else
        begin
          FBmp.Canvas.Pen.Color := ColorFromZ(P.Z);
          FBmp.Canvas.LineTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R));
        end;
      end;
  end;
  PaintBox1.Canvas.Draw(0, 0, FBmp);
end;

procedure TForm1.GDIMultipleColorsDirect;
var
  Alfa: Double;
  Beta: Double;
  Phi: Integer;
  Lambda: Integer;
  P: TPoint3D;
  Backside: Boolean;

  function ColorFromZ(Z: Single): TColorRef;
  var
    R: Integer;
    G: Integer;
    B: Integer;
  begin
    Z := (Z + 1) / 2;
    R := GetRValue(LineColorFore) - GetRValue(LineColorBack);
    R := GetRValue(LineColorBack) + Round(Z * R);
    G := GetGValue(LineColorFore) - GetGValue(LineColorBack);
    G := GetGValue(LineColorBack) + Round(Z * G);
    B := GetBValue(LineColorFore) - GetBValue(LineColorBack);
    B := GetBValue(LineColorBack) + Round(Z * B);
    Result := RGB(R, G, B);
  end;

begin
  PaintBox1.Canvas.Pen.Width := 2;
  PaintBox1.Canvas.Brush.Color := BackColor;
  PaintBox1.Canvas.FillRect(PaintBox1.ClientRect);
  Alfa := DegToRad(A);
  Beta := DegToRad(B);
  for Backside := True downto False do
  begin
    if not BackSide then
      PaintBox1.Canvas.Pen.Width := 3;
    //Latitude
    for Phi := -8 to 8 do
      for Lambda := 0 to 360 do
      begin
        P := Sphere(DegToRad(Phi * 10), DegToRad(Lambda));
        P := RotateAroundX(P, Alfa);
        P := RotateAroundY(P, Beta);
        if (Lambda = 0) or (Backside and (P.Z >= 0)) or
          (not Backside and (P.Z < 0)) then
            PaintBox1.Canvas.MoveTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R))
        else
        begin
          PaintBox1.Canvas.Pen.Color := ColorFromZ(P.Z);
          PaintBox1.Canvas.LineTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R));
        end;
      end;
    //Longitude
    for Lambda := 0 to 17 do
      for Phi := 0 to 360 do
      begin
        P := Sphere(DegToRad(Phi), DegToRad(Lambda * 10));
        P := RotateAroundX(P, Alfa);
        P := RotateAroundY(P, Beta);
        if (Phi = 0) or (Backside and (P.Z >= 0)) or
          (not Backside and (P.Z < 0)) then
            PaintBox1.Canvas.MoveTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R))
        else
        begin
          PaintBox1.Canvas.Pen.Color := ColorFromZ(P.Z);
          PaintBox1.Canvas.LineTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R));
        end;
      end;
  end;
end;

end.

（与感谢bummi的评论 。）



文章来源: Draw Sphere on TImage control of Delphi
标签： delphi 3d geometry
举报

收藏的人(0)

Ta的文章 更多文章
登录 后发表评论
0条评论
还没有人评论过~