teetrisurface.pas

第三方控件：PaintGrid.pas 网格型仪表控件源文件 Mymeter.pas 圆型仪表控件源文件 Project1是这两个控件的使用范例。 该

          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;
        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;
        WK[jp1]:=Sqr(XValues.Value[tmpIP1]-XDMP)+Sqr(ZValues.Value[tmpIP1]-YDMP);
      end;

      for jp1:=3 to NDPM1 do
      begin
        DSQMN:=WK[jp1];
        JPMN:=jp1;
        for jp2:=jp1 to NDP0 do
        begin
          // optimized...
          if WK[jp2]<DSQMN then
          begin
            DSQMN:=WK[jp2];
            JPMN:=jp2;
          end;
        end;

        tmp:=IWP[jp1];
        IWP[jp1]:=IWP[JPMN];
        IWP[JPMN]:=tmp;
        WK[JPMN]:=WK[jp1];
      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
            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 // todo: optimize?
              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];