teetrisurface.pas

Delphi TeeChartPro.6.01的源代码

{******************************************}
{     TeeChart Pro Charting Library        }
{           TriSurface Series              }
{ Copyright (c) 1995-2003 by David Berneda }
{         All Rights Reserved              }
{******************************************}
unit TeeTriSurface;
{$I TeeDefs.inc}

{ Adapted from Andre Bester's algorithm ([e-mail]) }

{ This unit implements the "Tri-Surface" charting series.

  A Tri-Surface is a 3D surface of triangles, automatically
  calculated from all XYZ points.

  All XYZ coordinates can have floating point decimals and
  can be expressed in any range.

  This series inherits all formatting properties like Pen,
  Brush, ColorRange and Palette from its ancestor class.

  Special properties:

    HideTriangles : Boolean ( default True )

      Triangles are ordered by Z position (hidding algorithm).
      When False, display speed might be faster but incorrect.

    CacheTriangles : Boolean ( default False )

      When True, triangles from XYZ data are just recalculated once
      instead of at every redraw.
      Set CacheTriangles to False after clearing or modifying XYZ data
      to force recalculating triangles.
}

interface

Uses {$IFNDEF LINUX}
     Windows, Messages,
     {$ENDIF}
     Classes,
     {$IFDEF CLX}
     QGraphics, Types,
     {$ELSE}
     Graphics,
     {$ENDIF}
     TeEngine, Chart, TeCanvas, TeeProcs, TeeSurfa;

Type
  ETriSurfaceException=class(ChartException);

  TCustomTriSurfaceSeries=class(TCustom3DPaletteSeries)
  private
    { Private declarations }
    FBorder : TChartHiddenPen;
    FHide   : Boolean;

    { internal }
    FNumLines     : Integer;
    ICreated      : Boolean;
    IPT           : Array of Integer;
    IPL           : Array of Integer;
    function IDxchg(I1,I2,I3,I4:Integer):integer;
    Procedure SetBorder(Value:TChartHiddenPen);
    procedure SetHide(const Value: Boolean);
  protected
    ImprovedTriangles : Boolean;
    Procedure AddSampleValues(NumValues:Integer); override;
    class Procedure CreateSubGallery(AddSubChart:TChartSubGalleryProc); override;
    procedure DoBeforeDrawValues; override;
    Procedure DrawMark(ValueIndex:Integer; Const St:String;
                       APosition:TSeriesMarkPosition); override;
    class Function GetEditorClass:String; override;
    class Procedure SetSubGallery(ASeries:TChartSeries; Index:Integer); override;
  public
    { Public declarations }
    CacheTriangles    : Boolean;
    NumTriangles      : Integer;

    Constructor Create(AOwner:TComponent); override;
    Destructor Destroy;override;

    Procedure Assign(Source:TPersistent); override;
    Procedure Clear; override;
    procedure DrawAllValues; override;
    Function NumSampleValues:Integer; override;

    property Border:TChartHiddenPen read FBorder write SetBorder;
    property Brush;
    property HideTriangles:Boolean read FHide write SetHide default True;
    property Pen;
  end;

  TTriSurfaceSeries=class(TCustomTriSurfaceSeries)
  published
    property Active;
    property ColorSource;
    property Cursor;
    property HorizAxis;
    property Marks;
    property ParentChart;
    property DataSource;
    property PercentFormat;
    property SeriesColor;
    property ShowInLegend;
    property Title;
    property ValueFormat;
    property VertAxis;
    property XLabelsSource;

    { events }
    property AfterDrawValues;
    property BeforeDrawValues;
    property OnAfterAdd;
    property OnBeforeAdd;
    property OnClearValues;
    property OnClick;
    property OnDblClick;
    property OnGetMarkText;
    property OnMouseEnter;
    property OnMouseLeave;

    property Border;
    property Brush;
    property EndColor;
    property MidColor;
    property LegendEvery;
    property Pen;
    property PaletteMin;
    property PaletteStep;
    property PaletteSteps;
    property PaletteStyle;
    property StartColor;
    property UseColorRange;
    property UsePalette;
    property UsePaletteMin;
    property TimesZOrder;
    property XValues;
    property YValues;
    property ZValues;
    { events }
    property OnGetColor;
  end;

implementation

Uses Math, TeeConst, TeeProCo;

{ TTriSurfaceSeries }
Constructor TCustomTriSurfaceSeries.Create(AOwner:TComponent);
begin
  inherited;
  FBorder:=TChartHiddenPen.Create(CanvasChanged);
  FBorder.Color:=clWhite;
  FHide:=True; { 5.02 }
  ImprovedTriangles:=True;
end;

Destructor TCustomTriSurfaceSeries.Destroy;
begin
  FBorder.Free;
  IPL:=nil;
  IPT:=nil;
  inherited;
end;

Function TCustomTriSurfaceSeries.NumSampleValues:Integer;
begin
  result:=15;
end;

Procedure TCustomTriSurfaceSeries.AddSampleValues(NumValues:Integer);
Const tmpRange  =    0.001;
      tmpRandom = 1000;
var t    : Integer;
    tmpX : Double;
    tmpZ : Double;
begin
  for t:=1 to 4+NumValues do
  begin
    tmpX:=System.Random(tmpRandom)*tmpRange;
    tmpZ:=System.Random(tmpRandom)*tmpRange;
    AddXYZ(tmpX,Sqr(Exp(tmpZ))*Cos(tmpX*tmpZ),tmpZ);
  end;
end;

class Function TCustomTriSurfaceSeries.GetEditorClass:String;
begin
  result:='TTriSurfaceSeriesEditor'; { <-- dont translate ! }
end;

Procedure TCustomTriSurfaceSeries.SetBorder(Value:TChartHiddenPen);
begin
  FBorder.Assign(Value);
end;

function TCustomTriSurfaceSeries.IDxchg(I1,I2,I3,I4:Integer):Integer;
var x1,x2,x3,x4 : Double;
    y1,y2,y3,y4 : Double;
    u1,u2,u3,u4 : Double;
    A1,A2,B1,B2,
    C1,C2       : Double;
    S1,S2,S3,S4 : Double;
begin
  result:=0;
  x1:=XValues.Value[I1];
  y1:=ZValues.Value[I1];
  x2:=XValues.Value[I2];
  y2:=ZValues.Value[I2];
  x3:=XValues.Value[I3];
  y3:=ZValues.Value[I3];
  x4:=XValues.Value[I4];
  y4:=ZValues.Value[I4];

  u3:=(y2-y3)*(x1-x3)-(x2-x3)*(y1-y3);
  u4:=(y1-y4)*(x2-x4)-(x1-x4)*(y2-y4);
  if (u3*u4)>0 then
  begin
    u1:=(y3-y1)*(x4-x1)-(x3-x1)*(y4-y1);
    u2:=(y4-y2)*(x3-x2)-(x4-x2)*(y3-y2);

    A1:=sqr(x1-x3)+sqr(y1-y3);
    B1:=sqr(x4-x1)+sqr(y4-y1);
    C1:=sqr(x3-x4)+sqr(y3-y4);
    A2:=sqr(x2-x4)+sqr(y2-y4);
    B2:=sqr(x3-x2)+sqr(y3-y2);
    C2:=sqr(x2-x1)+sqr(y2-y1);

    S1:=Sqr(u1)/(C1*Math.Max(A1,B1));
    S2:=Sqr(u2)/(C1*Math.Max(A2,B2));
    S3:=Sqr(u3)/(C2*Math.Max(B2,A1));
    S4:=Sqr(u4)/(C2*Math.Max(B1,A2));

    if Math.Min(S1,S2) < Math.Min(S3,S4) then
          result:=1;
  end;
end;

procedure TCustomTriSurfaceSeries.DoBeforeDrawValues;

  Procedure CreateTriangles;
  Var NLT3 : Integer;
      ITF  : Array[1..2] of Integer;
      ipl1 : Integer;
      ipl2 : Integer;
      IPTI1: Integer;
      IPTI2: Integer;

    Procedure CalcBorder;
    var i    : Integer;
        JLT3 : Integer;
        IPLJ1: Integer;
        IPLJ2: Integer;
    begin
      for i:=1 to NLT3 div 3 do
      begin
        JLT3:=i*3;
        IPLJ1:=IPL[JLT3-2];
        IPLJ2:=IPL[JLT3-1];
        if ((IPLJ1=ipl1) and (IPLJ2=IPTI2)) or
           ((IPLJ2=ipl1) and (IPLJ1=IPTI2)) then
           IPL[JLT3]:=ITF[1];
        if ((IPLJ1=ipl2) and (IPLJ2=IPTI1)) or
           ((IPLJ2=ipl2) and (IPLJ1=IPTI1)) then
           IPL[JLT3]:=ITF[2];
      end;
    end;

    Var DSQMN : TChartValue;
        IPMN1 : Integer;
        IPMN2 : Integer;
        ip1   : Integer;
        ip2   : Integer;
        NDPM1 : Integer;
        xd1   : TChartValue;
        xd2   : TChartValue;
        yd1   : TChartValue;
        yd2   : TChartValue;
        NDP0  : Integer;
        DSQI  : Double;
     tmpCount : Integer;

    { find closest pair and their midpoint }
    Function FindClosestPair:Boolean;
    // var i : Integer;
    begin
      result:=False;
      DSQMN:=Sqr(XValues.Value[1]-XValues.Value[0])+Sqr(ZValues.Value[1]-ZValues.Value[0]);

      IPMN1:=1;
      IPMN2:=2;
      ip1:=1;
      while (ip1<=NDPM1) and (not result) do
      begin
        xd1:=XValues.Value[IP1];
        yd1:=ZValues.Value[IP1];

        ip2:=ip1+1;
        while (ip2<=NDP0) and (not result) do
        begin
          xd2:=XValues.Value[IP2];
          yd2:=ZValues.Value[IP2];
          DSQI:=Sqr(xd2-xd1)+Sqr(yd2-yd1);

          if DSQI=0.0 then
          begin
            XValues.Value[ip2]:=XValues.Value[NDP0];
            YValues.Value[ip2]:=YValues.Value[NDP0];
            ZValues.Value[ip2]:=ZValues.Value[NDP0];

            (* 5.03
            { delete same point and shift array to fill gap }
            for i:=ip2 to NDP0-1 do
            begin
              XValues.Value[i]:=XValues.Value[i+1];
              // YValues.Value[i]:=YValues.Value[i+1];
              ZValues.Value[i]:=ZValues.Value[i+1];
            end;
            *)

            Dec(tmpCount);
            Dec(NDP0);
            Dec(NDPM1);
            Dec(ip2);
            result:=True;
          end
          else
          if DSQI<DSQMN then
          begin
            DSQMN:=DSQI;
            IPMN1:=ip1;
            IPMN2:=ip2;
          end;
          Inc(ip2);
        end;
        Inc(ip1);
      end;
    end;

Var JPMN : Integer;
    IWL  : Array of Integer;
    IWP  : Array of Integer;
    WK   : Array of Double;

    Procedure SortRest;
    Var XDMP : TChartValue;
        YDMP : TChartValue;
        jp1  : Integer;
        jp2  : Integer;
        tmpip1 : Integer;
        DSQ  : Double;
        tmp  : Integer;
    begin
      XDMP:=(XValues.Value[IPMN1]+XValues.Value[IPMN2])*0.5;
      YDMP:=(ZValues.Value[IPMN1]+ZValues.Value[IPMN2])*0.5;

      // sort other (NDP-2) datapoints in ascending order of
      // distance from midpoint and stores datapoint numbers
      // in IWP array

      jp1:=2;
      for tmpip1:=1 to NDP0 do
      if (tmpip1<>IPMN1) and (tmpip1<>IPMN2) then
      begin
        Inc(jp1);
        IWP[jp1]:=tmpip1;
        DSQ:=Sqr(XValues.Value[tmpIP1]-XDMP)+Sqr(ZValues.Value[tmpIP1]-YDMP);
        WK[jp1]:=DSQ;
      end;

      for jp1:=3 to NDPM1 do
      begin
        DSQMN:=WK[jp1];
        JPMN:=jp1;
        for jp2:=jp1 to NDP0 do
        begin
          DSQ:=WK[jp2];
          if DSQ<DSQMN then
          begin
            DSQMN:=DSQ;
            JPMN:=jp2;
          end;
        end;
        tmp:=IWP[jp1];
        IWP[jp1]:=IWP[JPMN];
        IWP[JPMN]:=tmp;
        DSQ:=WK[jp1];
        WK[JPMN]:=DSQ;
      end;
    end;

Var DSQ12 : Double;
Const Ratio = 1.0E-6;
      NRep  = 100;

    Procedure CheckColinear;
    Var AR       : Double;
        dx21     : Double;
        dy21     : Double;
        CoLinear : Double;
        jp       : Integer;
        ip       : Integer;
        jpmx     : Integer;
        i        : Integer;
    begin
      // if necessary modifies ordering so that first
      // three datapoints are not colinear
      AR:=DSQ12*ratio;

      xd1:=XValues.Value[IPMN1];
      yd1:=ZValues.Value[IPMN1];

      dx21:=XValues.Value[IPMN2]-xd1;
      dy21:=ZValues.Value[IPMN2]-yd1;

      ip:=0;
      jp:=3;
      CoLinear:=0.0;
      while (jp<=NDP0) and (colinear<=AR) do
      begin
        ip:=IWP[jp];
        CoLinear:=Abs((ZValues.Value[IP]-yd1)*dx21-(XValues.Value[IP]-xd1)*dy21);
        Inc(jp);
      end;
      Dec(jp);

      if jp=NDP0 then
         raise ETriSurfaceException.Create(TeeMsg_TriSurfaceAllColinear);

      if jp<>3 then
      begin
        jpmx:=jp;
        jp:=jpmx+1;
        for i:=4 to jpmx do
        begin
          Dec(jp);
          IWP[jp]:=IWP[jp-1];
        end;
        IWP[3]:=ip;
      end;
    end;

Var NTT3 : Integer;

    // forms first triangle-vertices in IPT array and border
    // line segments and triangle number in IPL array
    Procedure AddFirst;

      function Side(Const u1,v1,u2,v2,u3,v3:Double):Double;
      begin
        result:=(v3-v1)*(u2-u1)-(u3-u1)*(v2-v1);
      end;

    Var ip3 : Integer;
    begin
      ip1:=IPMN1;
      ip2:=IPMN2;
      ip3:=IWP[3];

      if Side( XValues.Value[IP1],ZValues.Value[IP1],
               XValues.Value[IP2],ZValues.Value[IP2],
               XValues.Value[IP3],ZValues.Value[IP3])<0 then
      begin
        ip1:=IPMN2;
        ip2:=IPMN1;
      end;

      NumTriangles:=1;
      NTT3:=3;

      { first triangle }
      IPT[1]:=ip1;
      IPT[2]:=ip2;
      IPT[3]:=ip3;

      FNumLines:=3;
      NLT3:=9;
      IPL[1]:=ip1;
      IPL[2]:=ip2;
      IPL[3]:=1;
      IPL[4]:=ip2;
      IPL[5]:=ip3;
      IPL[6]:=1;
      IPL[7]:=ip3;
      IPL[8]:=ip1;
      IPL[9]:=1;
    end;

    Procedure CalcTriangle(jp1:Integer);
    Var DXMN : Double;
        DYMN : Double;
        ARMN,dxmx,dymx,dsqmx,armx:Double;
        NSH,JWL : Integer;
        NLN,NLNT3,
        ITT3,
        NLF : Integer;
        tmp,
        jpmx : Integer;

      Procedure Part1;
      var jp2 : Integer;
          AR  : Double;
          DX,
          DY  : Double;
      begin
        for jp2:=2 to FNumLines do
        begin
          ip2:=IPL[3*jp2-2];

          xd2:=XValues.Value[IP2];
          yd2:=ZValues.Value[IP2];

          DX:=xd2-xd1;
          DY:=yd2-yd1;

          AR:=DY*DXMN-DX*DYMN;
          if AR<=ARMN then
          begin
            DSQI:=Sqr(DX)+Sqr(DY);
            if (AR<-ARMN) or (DSQI<DSQMN) then