utmain.pas

用Delphi语句实现对地图放大

unit utMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,Math, StdCtrls, Buttons, Menus, ExtCtrls,strUtils;

  
Type TMatrix    = Array Of Array of Double;    //要素值?
     TVector    = Array Of Double;
     TVectorL4D = Array [0..4] of Double;
     TVectorL4I = Array [0..4] of Integer;
     TCastArray = Array [0..2,0..2,0..2] of Integer;
     TPointList  =Array [0..158] of TPoint;
type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    Panel1: TPanel;
    Image1: TImage;
    PopupMenu1: TPopupMenu;
    N4: TMenuItem;
    N5: TMenuItem;
    Timer1: TTimer;
    Label1: TLabel;
    N6: TMenuItem;
    N7: TMenuItem;
    N8: TMenuItem;
    procedure BitBtn1Click(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ReDrawmap();
    procedure N4Click(Sender: TObject);
    procedure N5Click(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure N7Click(Sender: TObject);
    procedure N8Click(Sender: TObject);

  private
    { Private declarations }
    procedure TestStation();
  public
    { Public declarations }
    Procedure Conrec      ( D:  TMatrix ; // 2D - Data field
                          ilb,iub,           // west - east   ilb lower bound
                                             //               iub upper bound
                          jlb,jub : Integer; // north - south jlb lower bound
                                             //               jub upper bound
                          x : TVector;       // coord. vector west - east
                          y : TVector;       // coord. vector north - south
                          nc: Integer;       // nc number of cut levels
                          z : TVector);      // values of cut levels
//----------------------------------------------

    Function PosToPoint(pos:TPoint):TPoint;
    Function PointToPos(Pnt:TPoint):TPoint;
    procedure SetMapLeftTop(LeftPot:TPoint);
    procedure SetZoom(intZoom:integer);
    Function  GetMapLeftTop():TPoint;
    Function  GetZoom():Integer;
    procedure Zoom(fn:real;ptFix:TPoint);
    procedure DrawJWDGrid(DrawText:boolean);
    procedure DrawMap();
    procedure FillPoly(DC :HDC;FillColor :TColor);
  end;


var
  Form1: TForm1;
  iOriginPos:TPoint;
  iZoom:Integer;
  MouseOrig:TPoint;

//------------------------------------------------------------------------------
Const
 im : Array [0..3] of Integer = (0,1,1,0);   // coord. cast array west - east
 jm : Array [0..3] of Integer = (0,0,1,1);   // coord. cast array north - south
//------------------------------------------------------------------------------

 implementation
 uses utTool,utShowFactor;

{$R *.dfm}

{ TForm1 }

procedure TForm1.Conrec(D: TMatrix; ilb, iub, jlb, jub: Integer; x,
  y: TVector; nc: Integer; z: TVector);


Var
 m1,m2,m3,deside:Integer;
 dmin,dmax,x1,x2,y1,y2:Double;
 lcnt,i,j,k,m:Integer;
 casttab : TCastArray;
 h       : TVectorL4D;
 sh      : TVectorL4I;
 xh,yh   : TVectorL4D;
 temp1,temp2:Double ;
 r:Byte;

 // ------- service xsec west east lin. interpol -------------------------------
 Function xsec(p1,p2:Integer):Double;
  Begin
   result:=(h[p2]*xh[p1]-h[p1]*xh[p2])/(h[p2]-h[p1]);
  End;

 //------- service ysec north south lin interpol -------------------------------
 Function ysec(p1,p2:Integer):Double;
  Begin
   result := (h[p2]*yh[p1]-h[p1]*yh[p2])/(h[p2]-h[p1]);
  End;

Begin
 // set casting array
 casttab[0,0,0]:=0;casttab[0,0,1]:=0;casttab[0,0,2]:=8;
 casttab[0,1,0]:=0;casttab[0,1,1]:=2;casttab[0,1,2]:=5;
 casttab[0,2,0]:=7;casttab[0,2,1]:=6;casttab[0,2,2]:=9;

 casttab[1,0,0]:=0;casttab[1,0,1]:=3;casttab[1,0,2]:=4;
 casttab[1,1,0]:=1;casttab[1,1,1]:=3;casttab[1,1,2]:=1;
 casttab[1,2,0]:=4;casttab[1,2,1]:=3;casttab[1,2,2]:=0;

 casttab[2,0,0]:=9;casttab[2,0,1]:=6;casttab[2,0,2]:=7;
 casttab[2,1,0]:=5;casttab[2,1,1]:=2;casttab[2,1,2]:=0;
 casttab[2,2,0]:=8;casttab[2,2,1]:=0;casttab[2,2,2]:=0;

 // set line counter
 lcnt:=0;
 //-----------------------------------------------------------------------------
 For j:=jub-1 DownTo jlb Do Begin     // over all north - south and              +For j
  For i:=ilb To iub-1 Do Begin        // east - west coordinates of datafield    +For i
   // set casting bounds from array
   temp1 := min(D[i  , j],D[i  ,j+1]);
   temp2 := min(D[i+1, j],D[i+1,j+1]);
   dmin  := min(temp1, temp2);
   temp1 := max(D[i  , j],D[i  ,j+1]);
   temp2 := max(D[i+1, j],D[i+1,j+1]);
   dmax  := max(temp1, temp2);
   If (dmax>=z[0]) And (dmin<=z[nc-1]) Then Begin // ask horzintal cut avail.    +If dmin && dmax in z[0] .. z[nc-1]
    For k:=0 To nc-1 Do Begin                     // over all possible cuts ---- +For k
     If (z[k]>dmin) And (z[k]<=dmax) Then Begin   // aks for cut intervall ----- +If z[k] in dmin .. dmax
       //-----------------------------------------------------------------------
       For m:=4 Downto 0 Do Begin  // deteriening the cut casts and set the ---- +For m
       If (m>0) Then Begin         // height and coordinate vectors
        h[m]  := D[i+im[m-1],j+jm[m-1]]-z[k];
        xh[m] := x[i+im[m-1]];
        yh[m] := y[j+jm[m-1]];
       End Else Begin
        h[0]  := (h[1]+h[2]+h[3]+h[4])/4;
        xh[0] := (x[i]+x[i+1])/2;
        yh[0] := (y[j]+y[j+1])/2;
       End; // If m>0 then Else
       If h[m]>0 Then sh[m]:=1
        Else If h[m]<0 Then sh[m]:=-1
         Else sh[m]:=0;
       End; // ----------------------------------------------------------------- -For m

       //-----------------------------------------------------------------------
      For m:=1 to 4 Do Begin // set directional casttable
        //
        // Note: at this stage the relative heights of the corners and the
        // centre are in the h array, and the corresponding coordinates are
        // in the xh and yh arrays. The centre of the box is indexed by 0
        // and the 4 corners by 1 to 4 as shown below.
        // Each triangle is then indexed by the parameter m, and the 3
        // vertices of each triangle are indexed by parameters m1,m2,and
        // m3.
        // It is assumed that the centre of the box is always vertex 2
        // though this isimportant only when all 3 vertices lie exactly on
        // the same contour level, in which case only the side of the box
        // is drawn.
        //
        //      AS ANY BODY NOWS IST FROM THE ORIGINAL    
        //
        //      vertex 4 +-------------------+ vertex 3
        //               | \               / |
        //               |   \    m-3    /   |
        //               |     \       /     |
        //               |       \   /       |
        //               |  m=2    X   m=2   |       the centre is vertex 0
        //               |       /   \       |
        //               |     /       \     |
        //               |   /    m=1    \   |
        //               | /               \ |
        //      vertex 1 +-------------------+ vertex 2
        //
        //
        //
        //               Scan each triangle in the box
        //
       m1 := m; m2 := 0;
       If NOT(m=4) Then m3 := m+1 Else m3 :=1;
       deside := casttab[sh[m1]+1 ,sh[m2]+1, sh[m3]+1];
       If NOT(deside=0) Then Begin // ask is there a desition available -------- +If If NOT(deside=0)
        Case deside Of // ------- determin the by desided cast cuts ------------ +Case deside;
          1: Begin x1:=xh[m1]; y1:=yh[m1]; x2:=xh[m2]; y2:=yh[m2]; End;
          2: Begin x1:=xh[m2]; y1:=yh[m2]; x2:=xh[m3]; y2:=yh[m3]; End;
          3: Begin x1:=xh[m3]; y1:=yh[m3]; x2:=xh[m1]; y2:=yh[m1]; End;
          4: Begin x1:=xh[m1]; y1:=yh[m1]; x2:=xsec(m2,m3); y2:=ysec(m2,m3);
             End;
          5: Begin x1:=xh[m2]; y1:=yh[m2]; x2:=xsec(m3,m1); y2:=ysec(m3,m1);
             End;
          6: Begin x1:=xh[m3]; y1:=yh[m3]; x2:=xsec(m1,m2); y2:=ysec(m1,m2);
             End;
          7: Begin x1:=xsec(m1,m2); y1:=ysec(m1,m2);
                   x2:=xsec(m2,m3); y2:=ysec(m2,m3);
             End;
          8: Begin x1:=xsec(m2,m3); y1:=ysec(m2,m3);
                   x2:=xsec(m3,m1); y2:=ysec(m3,m1);
             End;
          9: Begin x1:=xsec(m3,m1); y1:=ysec(m3,m1);
                   x2:=xsec(m1,m2); y2:=ysec(m1,m2);
             End;
        End; // ---------------------------------------------------------------  -Case deside;

        // ----------Do someting with the results ----------------------------

         Writeln(Format('%2.2f %2.2f %2.2f %2.2f %2.2f',
          [z[k],x1,y1,x2,y2]));
        // -------------------------------------------------------------------
       End; // -----------------------------------------------------------------  -If Not(deside=0)
      End; // ------------------------------------------------------------------  -For m
     End; // -------------------------------------------------------------------  -If z[k] in dmin .. dmax
    End; // --------------------------------------------------------------------  -For k
   End; // ---------------------------------------------------------------------  -If dmin && dmax in z[0] .. z[nc-1]
  End; // ----------------------------------------------------------------------  -For i
 End; // -----------------------------------------------------------------------  -For j
End;
//------ End of ----------------------------------------------------------------



//------------------------------------------------------------------------------

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
  application.Terminate;
end;


//------------------------------------------------------------------------------
//将经纬度转化为坐标上对应的点
//------------------------------------------------------------------------------
function TForm1.PosToPoint(pos: TPoint): TPoint;
var x,y,z:real;
begin
  z:=izoom/1000.0;
  x:=(pos.X-iOriginPos.x)*Z;
  Y:=(iOriginPos.Y-Pos.Y)*Z;
  result.X:=Trunc(x);          //将实数转化为整数
  result.Y:=Trunc(y);

end;

//------------------------------------------------------------------------------
//将地图上对应的点转化为坐标
//------------------------------------------------------------------------------
function TForm1.PointToPos(Pnt: TPoint): TPoint;
var Z:real;
begin
  z:=iZoom/1000.0;

    Result.X:=Trunc(iOriginPos.X+pnt.X/z+0.5);
    Result.Y:=Trunc(iOriginPos.Y-pnt.Y/z+0.5);

end;

//------------------------------------------------------------------------------
//设置地图左上角的坐标
//------------------------------------------------------------------------------
procedure TForm1.SetMapLeftTop(LeftPot: TPoint);
const MaxX=200000;
      MaxY=120000;
begin
    if LeftPot.x>MaxX  then LeftPot.X:=MaxX;
    if LeftPot.x<-maxX then LeftPot.X:=MaxX;
    if LeftPot.y>Maxy  then LeftPot.y:=Maxy;
    if LeftPot.Y<-maxy then LeftPot.y:=Maxy;
    iOriginPos:=leftPot;
end;


//------------------------------------------------------------------------------
//设置地图的缩放比例
//------------------------------------------------------------------------------
procedure TForm1.SetZoom(intZoom: integer);
begin
   //if (izoom<200) or (izoom>1600) then
   //   exit;
   izoom:=intZoom;
end;

function TForm1.GetMapLeftTop: TPoint;
begin
   result:=iOriginPos;
end;

function TForm1.GetZoom: Integer;
begin
  result:=izoom;
end;

//------------------------------------------------------------------------------
//缩放
//------------------------------------------------------------------------------
procedure TForm1.Zoom(fn: real; ptFix: TPoint);
var pt1,pt2,pt3:TPoint;
    z:integer;
begin
  pt1:=PointtoPos(ptFix);   //固定点
  z:=getzoom();