文件列表:

common2.pas (52278, 2009-08-26)
DCU (0, 2009-08-26)
dmHTMLHelp.pas (3977, 2008-12-16)
EarthWork.groupproj (1702, 2008-12-09)
GISBase.res (5756, 2008-12-03)
GISVIEW.cfg (771, 2009-08-24)
GISVIEW.dof (2023, 2009-08-24)
GISVIEW.dpr (3534, 2009-08-24)
GISVIEW.dproj (9259, 2008-12-18)
GISVIEW.dproj.local (62, 2008-12-18)
GISVIEW.identcache (4314, 2008-12-18)
GISVIEW.res (5112, 2009-08-24)
GISViewHelpMapID.pas (959, 2009-08-16)
HSR3D.ddp (51, 2009-07-11)
HSR3D.dfm (54238, 2009-07-11)
HSR3D.pas (35557, 2009-08-16)
MSI_Software.pas (1671, 2009-08-16)
TransLang.pas (10669, 2009-08-16)
TransLangCom.pas (5998, 2009-08-16)
UBD_Browser.ddp (51, 2009-01-23)
UBD_Browser.dfm (3034, 2009-01-23)
UBD_Browser.pas (15073, 2009-08-16)
UCommons.pas (131889, 2009-08-16)
UCommonsIndexMap.pas (14457, 2009-08-16)
UIndexMap.ddp (51, 2008-12-11)
UIndexMap.dfm (1409, 2008-12-18)
UIndexMap.pas (4085, 2009-08-16)
UINFO_MiniObj.ddp (51, 2008-11-14)
UINFO_MiniObj.dfm (2125, 2008-11-14)
UINFO_MiniObj.pas (6552, 2009-08-16)
UINFO_Object.ddp (51, 2009-04-23)
UINFO_Object.dfm (40440, 2009-04-23)
UINFO_Object.pas (13286, 2009-08-16)
UMainGISVIEW.ddp (51, 2009-08-26)
UMainGISVIEW.dfm (406522, 2009-08-26)
UMainGISVIEW.pas (106729, 2009-08-26)
UMap.ddp (51, 2009-08-24)
UMap.dfm (7913, 2009-08-24)
UMap.pas (48133, 2009-08-24)
UMutiCoordSet.ddp (51, 2008-12-22)
... ...

unit UGEO_ReadMEM; interface uses Math, UGEO_Common; //****************************************************************************// type GPointType = array[1..2] of Single; const //japan CoordinateSystemOrigin: array[1..19] of GPointType = ((33.0, 129.0 + (30 / 60)), //1 (33.0, 131.0), (36.0, 132.0 + (10 / 60)), (33.0, 133.0 + (30 / 60)), (36.0, 134.0 + (20 / 60)), //5 (36.0, 136.0), (36.0, 137.0 + (10 / 60)), (36.0, 138.0 + (30 / 60)), (36.0, 139.0 + (50 / 60)), (40.0, 140.0 + (50 / 60)), //10 (44.0, 140.0 + (15 / 60)), (44.0, 142.0 + (15 / 60)), (44.0, 144.0 + (15 / 60)), (26.0, 142.0), (26.0, 127.0 + (30 / 60)), //15 (26.0, 124.0), (26.0, 131.0), (20.0, 136.0), (26.0, 154.0) ); type Line_POS_TYPE = (LINE_HORIZONTAL, LINE_VERTICAL, LINE_CROSS); TDPoint = packed record X: double; Y: double; end; PDPoint = ^TDPoint; CCellLine = packed record m_CellX: integer; m_CellY: integer; M_LinePOS: Line_POS_TYPE; end; CGridCell = packed record m_DimensionX: integer; m_DimensionY: integer; GetGridLevel: integer; GetGridValue: double; GetPosition: TDPoint; end; TDOpj = packed record X: double; Y: double; Z: double; end; TCMakeContour = packed class m_MeshFileName: WideString; m_MeshFile: TextFile; m_TableName: string; m_StartXY: TDPoint; m_EndXY: TDPoint; MinDem, MaxDem: double; m_OBJArray: array of array of TDOpj; m_Unit: integer; m_CellSizeX, m_CellSizeY: double; m_XDemension: integer; m_YDemension: integer; m_MarkArray: array of array of array[1..3] of Boolean; m_StartCellLine: CCellLine; m_Coord_List: array of array[1..2] of double; m_lCount: integer; procedure LineCopy(var cl1, cl2: CCellLine); function GetIntLine_POS_TYPE(LineType: Line_POS_TYPE): integer; function IsValidCellLine(cl: CCellLine): Boolean; function IsMarking(cl: CCellLine): Boolean; function SetMarking(cl: CCellLine; tag: Boolean): Boolean; function IsOutCell(cl: CCellLine): Boolean; function LookUpPivote(mvalue: double; var cl: CCellLine; var x, y: double): Boolean; procedure GetNeighber(no: integer; ORG_line: CCellLine; var neighbor_line: CCellLine); function ReadValueMapXY(CellX, CellY: integer; var MAPX, MAPY: double): Boolean; function ReadValueElevation(CellX, CellY: integer; var MAPX, MAPY: double): double; function ReadValue(cl: CCellLine; var value1, value2, MAPX1, MAPY1, MAPX2, MAPY2: double): Boolean; function IsCoord_ListEndValue(x_next, y_next: double): Boolean; function MakeLinking(mvalue: double; var cl_from, cl_to: CCellLine; x_next, y_next: double; count: integer): integer; function GetIntersectPosition(mvalue: double; var cl: CCellLine; var x, y: double): Boolean; constructor Create; virtual; destructor Destroy; override; procedure CMakeContouCreate(gMeshFileName: WideString); procedure CMakeContouCreateLEM(gMeshFileName, gHEADERFileName: WideString; m_X, m_Y: integer); procedure CMakeContouClear; procedure StartBuildValueContour; procedure ConvertToLocalCoordinates(var XX, YY: Single); end; //****************************************************************************// implementation //****************************************************************************// function TCMakeContour.GetIntLine_POS_TYPE(LineType: Line_POS_TYPE): integer; begin result := -1; case LineType of LINE_HORIZONTAL: result := 0; LINE_VERTICAL: result := 1; LINE_CROSS: result := 2; end; end; function TCMakeContour.IsValidCellLine(cl: CCellLine): Boolean; begin if (cl.m_CellX < 0) or (cl.m_CellX >= m_XDemension) then begin result := false; exit; end; if (cl.m_CellY < 0) or (cl.m_CellY >= m_YDemension) then begin result := false; exit; end; if (GetIntLine_POS_TYPE(cl.m_LinePos) < GetIntLine_POS_TYPE(LINE_HORIZONTAL)) or (GetIntLine_POS_TYPE(cl.m_LinePos) > GetIntLine_POS_TYPE(LINE_CROSS)) then begin result := false; exit; end; {if ( cl.m_CellX = m_XDemension-1 ) then begin if ( cl.m_LinePos <> LINE_VERTICAL ) then begin result := false; exit; end; end; if ( cl.m_CellY = m_YDemension-1 ) then begin if ( cl.m_LinePos <> LINE_HORIZONTAL ) then begin result := false; exit; end; end;} result := true; end; function TCMakeContour.IsOutCell(cl: CCellLine): Boolean; var Temp_cl: CCellLine; begin if (not IsValidCellLine(cl)) then begin result := true; exit; end; case (cl.m_LinePos) of LINE_HORIZONTAL: begin Temp_cl.m_CellX := cl.m_CellX + 1; Temp_cl.m_CellY := cl.m_CellY; Temp_cl.M_LinePOS := cl.M_LinePOS; if (not IsValidCellLine(Temp_cl)) then begin result := false; exit; end; end; LINE_VERTICAL: begin Temp_cl.m_CellX := cl.m_CellX; Temp_cl.m_CellY := cl.m_CellY + 1; Temp_cl.M_LinePOS := cl.M_LinePOS; if (not IsValidCellLine(Temp_cl)) then begin result := false; exit; end; end; LINE_CROSS: begin Temp_cl.m_CellX := cl.m_CellX + 1; Temp_cl.m_CellY := cl.m_CellY + 1; Temp_cl.M_LinePOS := cl.M_LinePOS; if (not IsValidCellLine(Temp_cl)) then begin result := false; exit; end; end; end; result := true; end; function TCMakeContour.ReadValueMapXY(CellX, CellY: integer; var MAPX, MAPY: double): Boolean; begin try result := false; MapX := m_OBJArray[CellX, CellY].X; MapY := m_OBJArray[CellX, CellY].Y; result := true; except end; end; function TCMakeContour.ReadValueElevation(CellX, CellY: integer; var MAPX, MAPY: double): double; begin try result := 0; if ReadValueMapXY(CellX, CellY, MAPX, MAPY) then begin result := m_OBJArray[CellX, CellY].Z; end; except end; end; function TCMakeContour.ReadValue(cl: CCellLine; var value1, value2, MAPX1, MAPY1, MAPX2, MAPY2: double): Boolean; begin if (not IsValidCellLine(cl)) then begin result := false; exit; end; value1 := ReadValueElevation(cl.m_CellX, cl.m_CellY, MAPX1, MAPY1); case (cl.m_LinePos) of LINE_HORIZONTAL: value2 := ReadValueElevation(cl.m_CellX + 1, cl.m_CellY, MAPX2, MAPY2); LINE_VERTICAL: value2 := ReadValueElevation(cl.m_CellX, cl.m_CellY + 1, MAPX2, MAPY2); LINE_CROSS: value2 := ReadValueElevation(cl.m_CellX + 1, cl.m_CellY + 1, MAPX2, MAPY2); end; result := true; end; function TCMakeContour.IsCoord_ListEndValue(x_next, y_next: double): Boolean; var i: integer; begin result := false; if Length(m_Coord_List) > 0 then begin //if (m_Coord_List[Length(m_Coord_List)-1][1] = x_next) and (m_Coord_List[Length(m_Coord_List)-1][2] = y_next) then // result := true; for i := 0 to Length(m_Coord_List) - 1 do begin if (m_Coord_List[i][1] = x_next) and (m_Coord_List[i][2] = y_next) then begin result := true; exit; end; end; end; end; function TCMakeContour.MakeLinking(mvalue: double; var cl_from, cl_to: CCellLine; x_next, y_next: double; count: integer): integer; var pos: TDPoint; cl_next: CCellLine; find_tag: Boolean; no: integer; begin result := 0; find_tag := true; while (true) do begin SetMarking(cl_to, true); pos.X := x_next; pos.Y := y_next; if (not IsCoord_ListEndValue(pos.X, pos.Y)) then begin if (count = 0) then begin SetLength(m_Coord_List, Length(m_Coord_List) + 1); //if Length(m_Coord_List) > 0 then begin m_Coord_List[Length(m_Coord_List) - 1][1] := pos.X; //m_CoordList.InsertAfter( pos ); m_Coord_List[Length(m_Coord_List) - 1][2] := pos.Y; //end; end else begin SetLength(m_Coord_List, Length(m_Coord_List) + 1); //if Length(m_Coord_List) > 0 then begin m_Coord_List[Length(m_Coord_List) - 1][1] := pos.X; //m_CoordList.InsertBefore( pos ); m_Coord_List[Length(m_Coord_List) - 1][2] := pos.Y; //end; end; end; find_tag := false; for no := 0 to 3 do begin GetNeighber(no, cl_to, cl_next); if (cl_next.m_CellX = cl_to.m_CellX) and (cl_next.m_CellY = cl_to.m_CellY) and (cl_next.M_LinePOS = cl_to.M_LinePOS) then continue; if (cl_next.m_CellX = m_StartCellLine.m_CellX) and (cl_next.m_CellY = m_StartCellLine.m_CellY) {and ( cl_next.M_LinePOS = m_StartCellLine.M_LinePOS )}then begin result := 2; exit; end; if (IsMarking(cl_next)) then continue; //if (IsCoord_ListEndValue(pos.X, pos.Y)) then continue; if (GetIntersectPosition(mvalue, cl_next, x_next, y_next)) then begin LineCopy(cl_to, cl_from); LineCopy(cl_next, cl_to); find_tag := true; break; end else SetMarking(cl_next, true); end; if (find_tag = false) then begin result := 1; exit; end; end; end; function TCMakeContour.GetIntersectPosition(mvalue: double; var cl: CCellLine; var x, y: double): Boolean; var v1, v2, range: double; vv1, vv2: double; x2, y2: double; begin if (not IsOutCell(cl)) then begin result := false; exit; end; if not ReadValue(cl, v1, v2, x, y, x2, y2) then begin result := false; exit; end; vv1 := v1 + 0.0001; vv2 := v2 + 0.0001; if (vv1 < vv2) then begin if (vv1 <= mvalue) and (mvalue < vv2) then range := abs(mvalue - v1) / abs(v1 - v2) else begin result := false; exit; end; end else if (vv1 > vv2) then begin if (vv2 <= mvalue) and (mvalue < vv1) then range := 1.0 - abs(mvalue - v2) / abs(v2 - v1) else begin result := false; exit; end; end else begin if (v1 = mvalue) then result := true else result := false; exit; end; case (cl.m_LinePos) of LINE_HORIZONTAL: x := x + (x2 - x) * range; LINE_VERTICAL: y := y + (y2 - y) * range; LINE_CROSS: begin x := x + (x2 - x) * range; y := y + (y2 - y) * range; end; end; //x := RoundTo(x, -2); //y := RoundTo(y, -2); result := true; end; /////////////////////////////// function TCMakeContour.IsMarking(cl: CCellLine): Boolean; var Line_TYPE: integer; begin if (not IsValidCellLine(cl)) then begin result := true; exit; end; Line_TYPE := GetIntLine_POS_TYPE(cl.m_LinePos); if (m_MarkArray[cl.m_CellX, cl.m_CellY][Line_TYPE]) then result := true else result := false; end; function TCMakeContour.SetMarking(cl: CCellLine; tag: Boolean): Boolean; var Line_TYPE: integer; begin if (not IsValidCellLine(cl)) then begin result := false; exit; end; Line_TYPE := GetIntLine_POS_TYPE(cl.m_LinePos); m_MarkArray[cl.m_CellX, cl.m_CellY][Line_TYPE] := tag; result := true; end; procedure TCMakeContour.LineCopy(var cl1, cl2: CCellLine); begin cl2.m_CellX := cl1.m_CellX; cl2.m_CellY := cl1.m_CellY; cl2.M_LinePOS := cl1.M_LinePOS; end; /////////////////////////////// function TCMakeContour.LookUpPivote(mvalue: double; var cl: CCellLine; var x, y: double): Boolean; var i, Line_TYPE: integer; BeforeX, BeforeY: double; BeforeXY_OK: Boolean; begin if (m_StartCellLine.m_CellX >= m_XDemension) or (m_StartCellLine.m_CellX < 0) then begin m_StartCellLine.m_CellX := 0; end; if (m_StartCellLine.m_CellY >= m_YDemension) or (m_StartCellLine.m_CellY < 0) then begin m_StartCellLine.m_CellY := 0; end; LineCopy(m_StartCellLine, cl); while (cl.m_CellX < m_XDemension) do begin while (cl.m_CellY < m_YDemension) do begin Line_TYPE := GetIntLine_POS_TYPE(cl.m_LinePos); while (Line_TYPE <= GetIntLine_POS_TYPE(LINE_CROSS)) do begin if not IsMarking(cl) then begin if (GetIntersectPosition(mvalue, cl, x, y)) then begin BeforeXY_OK := False; BeforeX := 0; BeforeY := 0; if (m_StartCellLine.m_CellX > 0) and (m_StartCellLine.m_CellY > 0) and (cl.m_CellX >= m_StartCellLine.m_CellX - 1) and (cl.m_CellY >= m_StartCellLine.m_CellY - 1) and (cl.m_CellX <= m_StartCellLine.m_CellX + 1) and (cl.m_CellY <= m_StartCellLine.m_CellY + 1) then begin if Length(m_Coord_List) > 0 then begin BeforeX := m_Coord_List[0][1]; BeforeY := m_Coord_List[0][2]; BeforeXY_OK := True; end; end; SetLength(m_Coord_List, 0); if BeforeXY_OK then begin SetLength(m_Coord_List, 1); m_Coord_List[0][1] := BeforeX; m_Coord_List[0][2] := BeforeY; end; LineCopy(cl, m_StartCellLine); result := true; exit; end; end; //LINE_HORIZONTAL, LINE_VERTICAL, LINE_CROSS if cl.m_LinePos = LINE_HORIZONTAL then cl.m_LinePos := LINE_VERTICAL else if cl.m_LinePos = LINE_VERTICAL then cl.m_LinePos := LINE_CROSS; Line_TYPE := Line_TYPE + 1; end; cl.m_LinePos := LINE_HORIZONTAL; cl.m_CellY := cl.m_CellY + 1; end; cl.m_CellY := 0; cl.m_CellX := cl.m_CellX + 1; end; cl.m_CellX := 0; result := false; end; /////////////////////////////// procedure TCMakeContour.GetNeighber(no: integer; ORG_line: CCellLine; var neighbor_line: CCellLine); begin if no < 0 then begin LineCopy(ORG_line, neighbor_line); exit; end; case (ORG_line.m_LinePos) of LINE_HORIZONTAL: begin case (no) of 0: begin neighbor_line.m_CellX := ORG_line.m_CellX + 1; neighbor_line.m_CellY := ORG_line.m_CellY; neighbor_line.m_LinePos := LINE_VERTICAL; end; 1: begin neighbor_line.m_CellX := ORG_line.m_CellX; neighbor_line.m_CellY := ORG_line.m_CellY; neighbor_line.m_LinePos := LINE_CROSS; end; 2: begin neighbor_line.m_CellX := ORG_line.m_CellX; neighbor_line.m_CellY := ORG_line.m_CellY - 1; neighbor_line.m_LinePos := LINE_VERTICAL; end; 3: begin neighbor_line.m_CellX := ORG_line.m_CellX; neighbor_line.m_CellY := ORG_line.m_CellY - 1; neighbor_line.m_LinePos := LINE_CROSS; end; end; end; LINE_VERTICAL: begin case (no) of 0: begin neighbor_line.m_CellX := ORG_line.m_CellX; neighbor_line.m_CellY := ORG_line.m_CellY; neighbor_line.m_LinePos := LINE_CROSS; end; 1: begin neighbor_line.m_CellX := ORG_line.m_CellX; neighbor_line.m_CellY := ORG_line.m_CellY + 1; neighbor_line.m_LinePos := LINE_HORIZONTAL; end; 2: begin neighbor_line.m_CellX := ORG_line.m_CellX - 1; neighbor_line.m_CellY := ORG_line.m_CellY; neighbor_line.m_LinePos := LINE_CROSS; end; 3: begin neighbor_line.m_CellX := ORG_line.m_CellX - 1; neighbor_line.m_CellY := ORG_line.m_CellY; neighbor_line.m_LinePos := LINE_HORIZONTAL; end; end; end; LINE_CROSS: begin case (no) of 0: begin neighbor_line.m_CellX := ORG_line.m_CellX + 1; neighbor_line.m_CellY := ORG_line.m_CellY; neighbor_line.m_LinePos := LINE_VERTICAL; end; 1: begin neighbor_line.m_CellX := ORG_line.m_CellX; neighbor_line.m_CellY := ORG_line.m_CellY + 1; neighbor_line.m_LinePos := LINE_HORIZONTAL; end; 2: begin neighbor_line.m_CellX := ORG_line.m_CellX; neighbor_line.m_CellY := ORG_line.m_CellY; neighbor_line.m_LinePos := LINE_VERTICAL; end; 3: begin neighbor_line.m_CellX := ORG_line.m_CellX; neighbor_line.m_CellY := ORG_line.m_CellY; neighbor_line.m_LinePos := LINE_HORIZONTAL; end; end; end; end; if (neighbor_line.m_CellX >= m_XDemension) or (ORG_line.m_CellX < 0) then neighbor_line := ORG_line; if (neighbor_line.m_CellY >= m_YDemension) or (ORG_line.m_CellY < 0) then neighbor_line := ORG_line; end; /////////////////////////////////////////////////////////////////////////// constructor TCMakeContour.Create; begin end; destructor TCMakeContour.Destroy; begin end; procedure TCMakeContour.CMakeContouCreate(gMeshFileName: WideString); var i, j, k, LayerCoord: integer; S, SX, SY: string; degX, minX, secX, degY, minY, secY: double; MX, MY, UX, UY: double; begin m_TableName := ''; m_XDemension := 200; m_YDemension := 200; m_Unit := 50; SetLength(m_MarkArray, m_XDemension); SetLength(m_OBJArray, m_XDemension); for i := 0 to m_YDemension - 1 do begin SetLength(m_MarkArray[i], m_YDemension); SetLength(m_OBJArray[i], m_YDemension); end; m_StartCellLine.m_CellX := 0; m_StartCellLine.m_CellY := 0; m_StartCellLine.m_LinePos := LINE_HORIZONTAL; m_MeshFileName := gMeshFileName; AssignFile(m_MeshFile, m_MeshFileName); Reset(m_MeshFile); Readln(m_MeshFile, S); m_TableName := Copy(S, 1, 6); // SX := Copy(S, 37, 7); SY := Copy(S, 30, 7); degX := Str_To_Float(Copy(SX, 1, 3)); minX := Str_To_Float(Copy(SX, 4, 2)); secX := Str_To_Float(Copy(SX, 6, 2)); m_StartXY.X := degX + (minX / 60) + (secX / 3600); degY := Str_To_Float(Copy(SY, 1, 3)); minY := Str_To_Float(Copy(SY, 4, 2)); secY := Str_To_Float(Copy(SY, 6, 2)); m_StartXY.Y := degY + (minY / 60) + (secY / 3600); // SX := Copy(S, 51, 7); SY := Copy(S, 44, 7); degX := Str_To_Float(Copy(SX, 1, 3)); minX := Str_To_Float(Copy(SX, 4, 2)); secX := Str_To_Float(Copy(SX, 6, 2)); m_EndXY.X := degX + (minX / 60) + (secX / 3600); degY := Str_To_Float(Copy(SY, 1, 3)); minY := Str_To_Float(Copy(SY, 4, 2)); secY := Str_To_Float(Copy(SY, 6, 2)); m_EndXY.Y := degY + (minY / 60) + (secY / 3600); // m_CellSizeX := (ABS(m_EndXY.X - m_StartXY.X)) / m_XDemension; m_CellSizeY := (ABS(m_EndXY.Y - m_StartXY.Y)) / m_YDemension; MinDem := 999999; MaxDem := 0; UX := 50; UY := 50; MY := UY * (m_YDemension) - (UY / 2); //MY := m_StartXY.Y; for j := m_YDemension - 1 downto 0 do begin R ... ...

近期下载者：

相关文件：

评论：[我要评论] [举报此文件]

收藏者：