在Delphi的TImage控件上绘制球体 [英] Draw Sphere on TImage control of Delphi

查看：34 发布时间：2021/11/25 2:21:28 delphi 3d geometry

本文介绍了在Delphi的TImage控件上绘制球体的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

我想画这样的球体:

下面的代码是生成圆的顶点并在 TIMAGE 上绘制一个圆，但我希望它用于 SPHERE:

for i := 0 to 360 do begin//求X和Y的值pntCordXY.X := 半径 * Cos(DegToRad(i));pntCordXY.Y := 半径 * Sin(DegToRad(i));如果 i = 0 那么image1.Canvas.MoveTo(Round(pntCordXY.X), Round(pntCordXY.Y))别的image1.Canvas.LineTo(Round(pntCordXY.X), Round(pntCordXY.Y));结尾;

解决方案

结果证明这是一个有趣的练习；好问题！

起初，您专门要求在 TImage 上绘制这样一个球体，但该组件应该用于显示图形.当然，它有一个可以在其上绘制的画布，但在下文中我使用了一个 TPaintBox，它是自己绘画的首选组件.因为，你必须自己画这个.完全.

所需材料:

用于计算球体上的 3D 点、围绕多个轴旋转地球以及将 3D 点转换为 2D 屏幕坐标系的一些数学运算.基础知识是:

类型TPoint3D = 记录X:双；Y:双；Z:双；结尾;函数 Sphere(P Lambda: Double): TPoint3D;开始结果.X := Cos(Phi) * Sin(Lambda);结果.Y := Sin(Phi);结果.Z := Cos(Phi) * Cos(Lambda);结尾;函数 RotateAroundX(const P: TPoint3D; Alfa: Double): TPoint3D;开始结果.X := P.X;结果.Y := P.Y * Cos(Alfa) + P.Z * Sin(Alfa);结果.Z := P.Y * -Sin(Alfa) + P.Z * Cos(Alfa);结尾;函数 RotateAroundY(const P: TPoint3D; Beta: Double): TPoint3D;开始结果.X := P.X * Cos(Beta) + P.Z * Sin(Beta);结果.Y := P.Y;结果.Z := P.X * -Sin(Beta) + P.Z * Cos(Beta);结尾;

一些可以使用的地球变量:

var阿尔法:整数；//绕X轴旋转测试版:整数；//绕Y轴旋转C:T点；//中心R:整数；//半径Phi:整数；//相对于XY平面的角度Lambda:整数；//绕Z轴的角度(从极点到极点)P:TPoint3D；//3D 点在球体表面的 2D 投影

计算纬度圈所有点的代码:

for Phi := -8 to 8 do对于 Lambda := 0 到 360 做开始P := Sphere(DegToRad(Phi * 10), DegToRad(Lambda));P := RotateAroundX(P, Alfa);P := RotateAroundY(P, Beta);结尾;

计算经线所有点的代码:
```
对于 Lambda := 0 到 17 做对于 Phi := 0 到 360 做开始P := Sphere(DegToRad(Phi), DegToRad(Lambda * 10));P := RotateAroundX(P, Alfa);P := RotateAroundY(P, Beta);结尾;
```
这些点可用于在油漆盒上绘制线条或曲线.这些点的 Z 值不用于绘图，但它们有助于确定该点位于地球的背面还是正面.
逻辑和辅助.在绘制地球前面的所有点、线或曲线之前，必须先绘制地球后面的点、线或曲线，以保持深度.
绘图框架或绘图库.默认情况下，Delphi 配备了标准的 Windows GDI，可通过绘制框的 Canvas 属性获得.另一种可能性是 GDI+，它更先进，效率更高.特别是考虑抗锯齿.这是我使用的两个框架，但还有其他框架.例如:OpenGL，它可以自动将 3D 对象转换为 2D，并且能够添加 3D 表面、灯光、材质、着色器和更多功能.
一个测试应用，添加在这个问题的底部.
一种双缓冲技术，使油漆工作无闪烁.在绘制该位图之前，我选择了一个单独的位图对象，在该对象上绘制了所有内容.演示程序还演示了没有它的性能(例程:GDIMultipleColorsDirect).

设置:

在你的表单上放置一个绘制框，并将其Align属性设置为alClient，添加一个用于模拟的计时器组件，为OnCreate添加表单事件处理程序、OnDestroy、OnKeyPress 和 OnResize，并为 PaintBox1.OnPaint 添加事件处理程序.

对象 Form1:TForm1左 = 497顶部 = 394宽度 = 450高度 = 450标题 = '球'颜色 = clWhiteFont.Charset = DEFAULT_CHARSETFont.Color = clWindowText字体.高度 = -11Font.Name = 'MS 无衬线'字体样式 = []OldCreateOrder = FalseOnCreate = FormCreateOnDestroy = FormDestroyOnKeyPress = FormKeyPressOnResize = FormResize每英寸像素数 = 96文本高度 = 13对象 PaintBox1: TPaintBox左 = 0顶部 = 0宽度 = 434高度 = 414对齐 = alClientOnPaint = PaintBox1Paint结尾对象 Timer1:TTimer间隔 = 25OnTimer = Timer1Timer左 = 7顶部 = 7结尾结尾

第一次尝试:

使用默认 GDI，我从每个点到下一个点画线.为了增加深度感(透视)，我给前面的线条更大的宽度.另外，我逐渐让线条的颜色由深到浅溢出(例程:GDIMultipleColors).

第二次尝试:

不错，但所有像素都太难了！让我们尝试自己做一些抗锯齿... ;) 此外，我将颜色计数减少到两种:前面是暗，后面是亮.这是为了摆脱所有单独的线段:现在每个圆和子午线都被分成两条折线.我在中间使用了第三种颜色来实现抗锯齿效果(例程:GDIThreeColors).

GDI+ 来拯救:

这种抗锯齿并不是最迷人的.为了获得真正流畅的绘制工作，让我们将代码转换为 GDI+ 样式.对于 Delphi 2009 及更高版本，可以从.)

I want to draw sphere like this:

Below code is generates Circle's Vertices and Drawing a Circle on TIMAGE BUT i want it for 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;

解决方案

This turned out to be a fun exercise; nice question!

At first, you ask specifically for drawing such a sphere on a TImage, but that component is supposed to be used for showing graphics. Sure, it has a canvas on which can be drawn, but hereunder I use a TPaintBox which is the preferred component for own painting. Because, you will have to paint this yourself. Entirely.

Ingredients needed:

Some math for calculating the 3D points on a sphere, for rotating the globe around multiple axes, and maybe for converting the 3D points to the 2D screen coordinate system. The basics are:

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 := 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;

Some globe-variables to work with:

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

Code to calculate all points of the latitude circles:

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;

Code to calculate all points of the longitude meridians:
```
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;
```
These points can be used to draw lines or curves on the paint box. The Z value of these points are not used for drawing, but they are helpful to decide whether the point lies on the back or front side of the globe.
Logic and aids. Before all points, lines or curves in front of the globe can be drawn, the ones in the back of globe have to be drawn first, in order to preserve depth.
A drawing framework or drawing library. Delphi is by default equipped with standard Windows GDI, available via the Canvas property of the paint box. Another possibility is GDI+ which is more advanced and can be more efficient. Especially considering anti-aliassing. These are the two frameworks I worked with, but there are also others. For example: OpenGL, which converts 3D objects to 2D automatically and is capable of adding 3D surfaces, lights, materials, shaders, and many more features.
A testing application, which is added at the bottom of this question.
A double buffering technique to get the paint work flicker-free. I chose a separate bitmap object on which everything is drawn, prior to painting that bitmap on the paint box. The demo program also demonstrates the performance without it (routine: GDIMultipleColorsDirect).

Setup:

Drop a paint box on your form, and set its Align property to alClient, add a timer component for simulation, add form event handlers for OnCreate, OnDestroy, OnKeyPress, and OnResize, and add an event handler for 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

First attempt:

With default GDI, I draw lines from every point to every next point. To add a feeling of depth (perspective), I gave the lines in front a greater width. Also, I gradually let the colors of the lines overflow from dark to light (routine: GDIMultipleColors).

Second attempt:

Nice, but all pixels are so hard! Let's try doing some anti-aliassing ourselfs... ;) Furthermore, I reduced the color count to two: dark in front, light in the back. This in order to get rid of all separate line segments: now every circle and meridian is devided into two polylines. I used a third color in between for the anti-aliassing effect (routine: GDIThreeColors).

GDI+ to the rescue:

This anti-aliassing isn't most charming. To get really smooth paint work, let's convert the code to GDI+ style. For Delphi 2009 and up, the library is available from here. For older Delphi versions, the library is available from here.

In GDI+, drawing works a bit differently. Create a TGPGraphics object and attach it to a device context with its constructor. Subsequently, drawing operations on the object are translated by the API and will be output to the destination context, the bitmap in this case (routine: GDIPlusDualLinewidths).

Can it even better?

Well, that's quite someting already. But this globe is made up out of polylines with just two different line widths. Let's add some in between. The count of segments in each circle or meridian is controlled by the Precision constant (routine: GDIPlusMultipleLinewidths).

Sample application:

Press a key to cycle through the above mentioned routines.

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.

(With thanks to bummi's comment.)

这篇关于在Delphi的TImage控件上绘制球体的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！

查看全文

在Delphi的TImage控件上绘制球体 [英] Draw Sphere on TImage control of Delphi

问题描述

所需材料:

设置:

第一次尝试:

第二次尝试:

GDI+ 来拯救:

Ingredients needed:

Setup:

First attempt:

Second attempt:

GDI+ to the rescue:

Can it even better?

Sample application:

相关文章

C#最新文章

热门教程

热门工具

登录关闭

在Delphi的TImage控件上绘制球体 [英] Draw Sphere on TImage control of Delphi

问题描述

所需材料:

设置:

第一次尝试:

第二次尝试:

GDI+ 来拯救:

Ingredients needed:

Setup:

First attempt:

Second attempt:

GDI+ to the rescue:

Can it even better?

Sample application:

相关文章

C#最新文章

热门教程

热门工具

登录 关闭

登录关闭