teetrisurface.pas

Delphi TeeChartPro.6.01的源代码

            begin
              JPMN:=jp2;
              DXMN:=DX;
              DYMN:=DY;
              DSQMN:=DSQI;
              ARMN:=DSQMN*ratio;
            end;
          end;

          AR:=DY*DXMX-DX*DYMX;
          if AR>=-ARMX then
          begin
            DSQI:=Sqr(DX)+Sqr(DY);
            if (AR>ARMX) or (DSQI<DSQMX) then
            begin
              JPMX:=jp2;
              DXMX:=DX;
              DYMX:=DY;
              DSQMX:=DSQI;
              ARMX:=DSQMX*ratio;
            end;
          end;
        end;
      end;

      Procedure ShiftIPLArray;
      var i : Integer;
          tmpSource : Integer;
      begin
        // shifts the IPL array to have invisible border
        // line segments contained in 1st part of array
        for i:=1 to NSH do
        begin
          tmp:=i*3;
          tmpSource:=tmp+NLT3;
          IPL[tmpSource-2]:=IPL[tmp-2];
          IPL[tmpSource-1]:=IPL[tmp-1];
          IPL[tmpSource]  :=IPL[tmp];
        end;

        for i:=1 to NLT3 div 3 do
        begin
          tmp:=i*3;
          tmpSource:=tmp+(NSH*3);
          IPL[tmp-2]:=IPL[tmpSource-2];
          IPL[tmp-1]:=IPL[tmpSource-1];
          IPL[tmp]  :=IPL[tmpSource];
        end;

        Dec(JPMX,NSH);
      end;

      Procedure AddTriangles;
      var jp2   : Integer;
          IPTI  : Integer;
          IT    : Integer;
          jp2t3 : Integer;
      begin
        // adds triangles to IPT array, updates border line
        // segments in IPL array and sets flags for the border
        // line segments to be reexamined in the iwl array
        JWL:=0;
        NLNT3:=0;
        for jp2:=JPMX to FNumLines do
        begin
          jp2t3:=jp2*3;
          ipl1:=IPL[jp2t3-2];
          ipl2:=IPL[jp2t3-1];
          IT:=IPL[jp2t3];

          // add triangle to IPT array
          Inc(NumTriangles);
          Inc(NTT3,3);
          IPT[NTT3-2]:=ipl2;
          IPT[NTT3-1]:=ipl1;
          IPT[NTT3]:=ip1;

          // updates borderline segments in ipl array
          if jp2=JPMX then
          begin
            IPL[jp2t3-1]:=ip1;
            IPL[jp2t3]:=NumTriangles;
          end;
          if jp2=FNumLines then
          begin
            NLN:=JPMX+1;
            NLNT3:=NLN*3;
            IPL[NLNT3-2]:=ip1;
            IPL[NLNT3-1]:=IPL[1];
            IPL[NLNT3]:=NumTriangles;
          end;

          // determine vertex that is not on borderline segments
          ITT3:=IT*3;
          IPTI:=IPT[ITT3-2];
          if (IPTI=ipl1) or (IPTI=ipl2) then
          begin
            IPTI:=IPT[ITT3-1];
            if (IPTI=ipl1) or (IPTI=ipl2) then IPTI:=IPT[ITT3];
          end;

          // checks if exchange is necessary
          if IDxchg(ip1,IPTI,ipl1,ipl2)<>0 then
          begin
            // modifies ipt array if necessary
            IPT[ITT3-2]:=IPTI;
            IPT[ITT3-1]:=ipl1;
            IPT[ITT3]:=ip1;
            IPT[NTT3-1]:=IPTI;

            if jp2=JPMX then IPL[jp2t3]:=IT;
            if (jp2=FNumLines) and (IPL[3]=IT) then IPL[3]:=NumTriangles;

            // set flags in IWL array
            JWL:=JWL+4;
            IWL[JWL-3]:=ipl1;
            IWL[JWL-2]:=IPTI;
            IWL[JWL-1]:=IPTI;
            IWL[JWL]:=ipl2;
          end;
        end;
      end;

      Procedure ImproveTriangles;
      Var ILF    : Integer;
          tmpNLF : Integer;
          IPT1   : Integer;
          IPT2   : Integer;
          IPT3   : Integer;
          IREP   : Integer;
          IT1T3  : Integer;
          IT2T3  : Integer;
          LoopFlag : Boolean;
          NTF    : Integer;
          NTT3P3 : Integer;
      begin
        // improve triangulation
        NTT3P3:=NTT3+3;
        IREP:=1;
        while IREP<=NREP do
        begin
          for ILF:=1 to NLF do
          begin
            ipl1:=IWL[ILF*2-1];
            ipl2:=IWL[ILF*2];

            // locates in ipt array two triangles on
            // both sides of flagged line segment
            NTF:=0;
            LoopFlag:=True;
            tmp:=3;
            while LoopFlag and (tmp<=NTT3) do
            begin
              ITT3:=NTT3P3-tmp;
              IPT1:=IPT[ITT3-2];
              IPT2:=IPT[ITT3-1];
              IPT3:=IPT[ITT3];

              if (ipl1=IPT1) or (ipl1=IPT2) or (ipl1=IPT3) then
              begin
                if (ipl2=IPT1) or (ipl2=IPT2) or (ipl2=IPT3) then
                begin
                  Inc(NTF);
                  ITF[NTF]:=ITT3 div 3;
                  if NTF=2 then LoopFlag:=False;
                end;
              end;
              Inc(tmp,3);
            end;

            if NTF>=2 then
            begin
              IT1T3:=ITF[1]*3;
              IPTI1:=IPT[IT1T3-2];
              if (IPTI1=ipl1) or (IPTI1=ipl2) then
              begin
                IPTI1:=IPT[IT1T3-1];
                if (IPTI1=ipl1) or (IPTI1=ipl2) then IPTI1:=IPT[IT1T3];
              end;

              IT2T3:=ITF[2]*3;
              IPTI2:=IPT[IT2T3-2];
              if (IPTI2=ipl1) or (IPTI2=ipl2) then
              begin
                IPTI2:=IPT[IT2T3-1];
                if (IPTI2=ipl1) or (IPTI2=ipl2) then IPTI2:=IPT[IT2T3];
              end;

               // checks if exchange necessary
              if IDxchg(IPTI1,IPTI2,ipl1,ipl2)<>0 then
              begin
                 IPT[IT1T3-2]:=IPTI1;
                 IPT[IT1T3-1]:=IPTI2;
                 IPT[IT1T3]:=ipl1;

                 IPT[IT2T3-2]:=IPTI2;
                 IPT[IT2T3-1]:=IPTI1;
                 IPT[IT2T3]:=ipl2;

                 JWL:=JWL+8;

                 IWL[JWL-7]:=ipl1;
                 IWL[JWL-6]:=IPTI1;
                 IWL[JWL-5]:=IPTI1;
                 IWL[JWL-4]:=ipl2;
                 IWL[JWL-3]:=ipl2;
                 IWL[JWL-2]:=IPTI2;
                 IWL[JWL-1]:=IPTI2;
                 IWL[JWL]  :=ipl1;

                 CalcBorder;
              end;
            end;
          end;

          tmp:=NLF;
          NLF:=JWL div 2;
          if NLF=tmp then break
          else
          begin // reset IWL array for next round
            JWL:=0;
            tmp:=(tmp+1)*2;
            tmpNLF:=2*NLF;
            while tmp<=tmpNLF do
            begin
              Inc(JWL,2);
              IWL[JWL-1]:=IWL[tmp-1];
              IWL[JWL]  :=IWL[tmp];
              Inc(tmp,2);
            end;
            NLF:=JWL div 2;
          end;

          Inc(IREP);
        end;
      end;

    begin
      ip1:=IWP[jp1];

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

      // determine visible borderline segments
      ip2:=IPL[1];
      JPMN:=1;

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

      DXMN:=xd2-xd1;
      DYMN:=yd2-yd1;
      DSQMN:=Sqr(DXMN)+Sqr(DYMN);

      ARMN:=DSQMN*Ratio;
      jpmx:=1;
      dxmx:=DXMN;
      dymx:=DYMN;
      dsqmx:=DSQMN;
      armx:=ARMN;

      Part1;

      if jpmx<jpmn then Inc(jpmx,FNumLines);

      NSH:=JPMN-1;
      if NSH>0 then ShiftIPLArray;

      AddTriangles;

      FNumLines:=NLN;
      NLT3:=NLNT3;
      NLF:=JWL div 2;
      if (NLF<>0) and ImprovedTriangles then
         ImproveTriangles;
    end;

  Var jp1 : Integer;
  begin
    tmpCount:=Count;
    NDP0:=tmpCount-1;
    NDPM1:=NDP0-1;
    SetLength(IPT,6*tmpCount-15);
    SetLength(IPL,6*tmpCount);
    SetLength(IWL,18*tmpCount);
    SetLength(IWP,tmpCount);
    SetLength(WK,tmpCount);
    try
      if not FindClosestPair then
      begin
        DSQ12:=DSQMN;
        SortRest;
        CheckColinear;
        AddFirst;
        // add the remaining NDP-3 data points one by one
        for jp1:=4 to NDP0 do CalcTriangle(jp1);
        ICreated:=True;
      end
      else
        raise ETriSurfaceException.Create(TeeMsg_TriSurfaceSimilar);
    finally
      IWL:=nil;
      IWP:=nil;
      WK:=nil;
    end;
  end;

begin
  inherited;
  if Count<4 then
  begin
    NumTriangles:=0;
    raise ETriSurfaceException.Create(TeeMsg_TriSurfaceLess);
  end
  else
  if (not CacheTriangles) or (not ICreated) then { 5.02 }
     CreateTriangles;
end;

type PTriangle=^TTriangle;
     TTriangle=packed record
       Color : TColor;
       Next  : PTriangle;
       Prev  : PTriangle;
       P     : TTrianglePoints;
       Z     : Double;
     end;

     TTeeCanvasAccess3D=class(TTeeCanvas3D);

procedure TCustomTriSurfaceSeries.DrawAllValues;
Var Points : TTrianglePoints3D;
    Colors : TTriangleColors3D;

  Procedure CalcPoint(APoint,Index:Integer);
  begin
    With Points[APoint] do
    begin
      X:=CalcXPos(Index);
      Y:=CalcYPos(Index);
      Z:=CalcZPos(Index);
    end;
    Colors[APoint]:=ValueColor[Index];
  end;

var t   : Integer;
    tmp : Integer;
    Triangles   : PTriangle;
    Triangle    : PTriangle;
    tmpForward  : Boolean;

    { sort triangles by Z (draw first triangles with bigger depth) }
    Procedure AddByZ(ATriangle:PTriangle);
    var tmp  : PTriangle;
        Last : PTriangle;
    begin
      Last:=nil;
      tmp:=Triangles;
      while Assigned(tmp) do
      begin
        if (tmpForward and (ATriangle.Z>tmp.Z)) or
           ((not tmpForward) and (tmp.Z>ATriangle.Z)) then
        begin
          if Assigned(tmp.Prev) then
          begin
            ATriangle.Prev:=tmp.Prev;
            tmp.Prev.Next:=ATriangle;
          end
          else Triangles:=ATriangle;
          tmp.Prev:=ATriangle;
          ATriangle.Next:=tmp;
          exit;
        end;
        Last:=tmp;
        tmp:=tmp.Next;
      end;
      if Assigned(Last) then
      begin
        Last.Next:=ATriangle;
        ATriangle.Prev:=Last;
      end
      else Triangles:=ATriangle;
    end;

var tmpTriangle : PTriangle;
begin
  With TTeeCanvasAccess3D(ParentChart.Canvas) do
  begin
    if Self.Pen.Visible or (Self.Brush.Style<>bsClear) then
    begin
      AssignBrush(Self.Brush,Self.Brush.Color);
      AssignVisiblePen(Self.Pen);

      if HideTriangles and (not SupportsFullRotation) and (Brush.Style=bsSolid) then
      begin
        { create a list of triangles sorted by Z }
        tmpForward:=not ParentChart.DepthAxis.Inverted;
        Triangles:=nil;
        for t:=1 to NumTriangles do
        begin
          tmp:=3*t;
          CalcPoint(0,IPT[tmp-2]);
          CalcPoint(1,IPT[tmp-1]);
          CalcPoint(2,IPT[tmp]);

          New(tmpTriangle);
          with tmpTriangle^ do
          begin
            Next:=nil;
            Prev:=nil;
            { aproximate Z to the greatest of 3 triangle corners }
            Z:=Math.Max(ZValues.Value[IPT[tmp]],
               Math.Max(ZValues.Value[IPT[tmp-1]],ZValues.Value[IPT[tmp-2]]));
            { calculate XY screen positions of corners }
            Calc3DPoint(P[0],Points[0].X,Points[0].Y,Points[0].Z);
            Calc3DPoint(P[1],Points[1].X,Points[1].Y,Points[1].Z);
            Calc3DPoint(P[2],Points[2].X,Points[2].Y,Points[2].Z);
            Color:=Colors[0];
          end;

          AddByZ(tmpTriangle);
        end;

        { draw all triangles }
        Triangle:=Triangles;
        while Assigned(Triangle) do
        begin
          Brush.Color:=Triangle.Color;
          Polygon(Triangle.P);
          { free triangle memory }
          tmpTriangle:=Triangle;
          Triangle:=Triangle.Next;
          Dispose(tmpTriangle);
        end;
      end
      else { draw all triangles, do not hide }
      for t:=1 to NumTriangles do
      begin
        tmp:=3*t;
        CalcPoint(0,IPT[tmp-2]);
        CalcPoint(1,IPT[tmp-1]);
        CalcPoint(2,IPT[tmp]);
        Triangle3D(Points,Colors);
      end;
    end;

    if Self.FBorder.Visible then
    begin
      AssignVisiblePen(Self.FBorder);

      { draw border }
      for t:=1 to FNumLines do
      begin
        CalcPoint(0,IPL[3*t-2]);
        with Points[0] do MoveTo3D(x,y,z);
        CalcPoint(1,IPL[3*t-1]);
        with Points[1] do LineTo3D(x,y,z);
      end;
    end;
  end;
end;

Procedure TCustomTriSurfaceSeries.DrawMark( ValueIndex:Integer; Const St:String;
                                            APosition:TSeriesMarkPosition);
begin
  Marks.ZPosition:=CalcZPos(ValueIndex);
  Marks.ApplyArrowLength(APosition);
  inherited;
end;

procedure TCustomTriSurfaceSeries.Assign(Source: TPersistent);
begin
  if Source is TCustomTriSurfaceSeries then
  with TCustomTriSurfaceSeries(Source) do
  begin
    Self.Border:=Border;
    Self.ImprovedTriangles:=ImprovedTriangles;
    Self.FHide:=HideTriangles;
  end;
  inherited;
end;

class procedure TCustomTriSurfaceSeries.CreateSubGallery(
  AddSubChart: TChartSubGalleryProc);
begin
  inherited;
  AddSubChart(TeeMsg_WireFrame);
  AddSubChart(TeeMsg_NoLine);
  AddSubChart(TeeMsg_Border);
end;

class procedure TCustomTriSurfaceSeries.SetSubGallery(
  ASeries: TChartSeries; Index: Integer);
begin
  With TCustomTriSurfaceSeries(ASeries) do
  Case Index of
    2: Brush.Style:=bsClear;
    3: Pen.Visible:=False;
    4: Border.Visible:=True;
  else inherited;
  end;
end;

procedure TCustomTriSurfaceSeries.Clear;
begin
  inherited;
  ICreated:=False;
end;

procedure TCustomTriSurfaceSeries.SetHide(const Value: Boolean);
begin
  SetBooleanProperty(FHide,Value);
end;

initialization
  RegisterTeeSeries( TTriSurfaceSeries, @TeeMsg_GalleryTriSurface,
                     @TeeMsg_Gallery3D,1);
finalization
  UnRegisterTeeSeries([TTriSurfaceSeries]);
end.