1
0
Files
applications
bindings
components
Comba_Animation
aboutcomponent
acs
beepfp
callite
captcha
chelper
chemtext
cmdline
cmdlinecfg
colorpalette
cryptini
csvdocument
epiktimer
everettrandom
examplecomponent
exctrls
extrasyn
fpexif
fpsound
fpspreadsheet
fractions
freetypepascal
geckoport
gradcontrols
grid_semaphor
industrialstuff
iosdesigner
iphonelazext
jujiboutils
jvcllaz
kcontrols
lazautoupdate
lazbarcodes
lazmapviewer
examples
images
source
addons
mvcache.pas
mvde_intfgraphics.pas
mvde_lcl.pas
mvdlefpc.pas
mvdownloadengine.pas
mvdragobj.pas
mvdrawingengine.pas
mvengine.pas
mvextradata.pas
mvgeonames.pas
mvgpsobj.pas
mvgpx.pas
mvjobqueue.pas
mvjobs.pas
mvmapprovider.pas
mvmapviewer.pas
mvmapviewer_icons.res
mvmapviewerreg.pas
mvtypes.pas
lazmapviewer_bgra.lpk
lazmapviewer_bgra.pas
lazmapviewer_rgbgraphics.lpk
lazmapviewer_rgbgraphics.pas
lazmapviewer_synapse.lpk
lazmapviewer_synapse.pas
lazmapviewerpkg.lpk
lazmapviewerpkg.pas
lclextensions
longtimer
manualdock
mbColorLib
mplayer
multithreadprocs
nvidia-widgets
onguard
orpheus
playsoundpackage
poweredby
powerpdf
rgbgraphics
richmemo
richview
rtfview
rx
scrolltext
smnetgradient
spktoolbar
splashabout
svn
systools
tdi
thtmlport
tparadoxdataset
tvplanit
xdev_toolkit
zlibar
zmsql
examples
image_sources
lclbindings
wst
lazarus-ccr/components/lazmapviewer/source/mvgpx.pas

422 lines
11 KiB
ObjectPascal
Raw Normal View History

{ Reads/writes GPX files
(C) 2019 Werner Pamler (user wp at Lazarus forum https://forum.lazarus.freepascal.org)
License: modified LGPL with linking exception (like RTL, FCL and LCL)
See the file COPYING.modifiedLGPL.txt, included in the Lazarus distribution,
for details about the license.
See also: https://wiki.lazarus.freepascal.org/FPC_modified_LGPL
}
unit mvGPX;
{$mode objfpc}{$H+}
{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined}
interface
uses
Classes, SysUtils, laz2_DOM, laz2_XMLRead, DateUtils,
mvTypes, mvGpsObj;
type
TGpxReader = class
private
ID: Integer;
FMinLat, FMinLon, FMaxLat, FMaxLon: Double;
protected
procedure ReadExtensions(ANode: TDOMNode; ATrack: TGpsTrack);
function ReadPoint(ANode: TDOMNode): TGpsPoint;
procedure ReadRoute(ANode: TDOMNode; AList: TGpsObjectlist);
procedure ReadTrack(ANode: TDOMNode; AList: TGpsObjectList);
procedure ReadTracks(ANode: TDOMNode; AList: TGpsObjectList);
procedure ReadTrackSegment(ANode: TDOMNode; ATrack: TGpsTrack);
procedure ReadWayPoints(ANode: TDOMNode; AList: TGpsObjectList);
public
function LoadFromFile(AFileName: String; AList: TGpsObjectList): Integer;
function LoadFromFile(AFileName: String; AList: TGpsObjectList; out ABounds: TRealArea): Integer;
function LoadFromStream(AStream: TStream; AList: TGpsObjectList): Integer;
function LoadFromStream(AStream: TStream; AList: TGpsObjectList; out ABounds: TRealArea): Integer;
end;
implementation
uses
Math,
mvExtraData;
var
PointSettings: TFormatSettings;
function ExtractISODateTime(AText: String): TDateTime;
type
TISODateRec = packed record
Y: array[0..3] of ansichar;
SepYM: ansichar;
M: array[0..1] of ansichar;
SepMD: ansichar;
D: array[0..1] of ansichar;
end;
PISODateRec = ^TISODateRec;
TISOTimeRec = packed record
H: array[0..1] of ansichar;
SepHM: ansichar;
M: array[0..1] of ansichar;
SepMS: ansiChar;
S: array[0..1] of ansichar;
DecSep: ansichar;
MS: array[0..2] of ansichar;
end;
PISOTimeRec = ^TISOTimeRec;
const
NUMBER: array['0'..'9'] of Integer = (0, 1, 2, 3, 4, 5, 6, 7, 8, 9);
var
yr,mon,dy, hr,mn,sec,s1000: Integer;
begin
if Pos('T', AText) = 11 then begin
with PISODateRec(PChar(@AText[1]))^ do begin
yr := 1000*NUMBER[Y[0]] + 100*NUMBER[Y[1]] + 10*NUMBER[Y[2]] + NUMBER[Y[3]];
mon := 10*NUMBER[M[0]] + NUMBER[M[1]];
dy := 10*NUMBER[D[0]] + NUMBER[D[1]];
end;
with PISOTimeRec(PChar(@AText[12]))^ do begin
hr := 10*NUMBER[H[0]] + NUMBER[H[1]];
mn := 10*NUMBER[M[0]] + NUMBER[M[1]];
sec := 10*NUMBER[S[0]] + NUMBER[S[1]];
s1000 := 100*NUMBER[MS[0]] + 10*NUMBER[MS[1]] + NUMBER[MS[2]];
if (s1000 < 0) or (s1000 > 1000) then s1000 := 0;
end;
Result := EncodeDate(yr, mon, dy) + EncodeTime(hr, mn, sec, s1000);
end else
if not TryStrToDateTime(AText, Result) then
Result := NO_DATE;
end;
function GetAttrValue(ANode: TDOMNode; AAttrName: string) : string;
var
i: LongWord;
Found: Boolean;
begin
Result := '';
if (ANode = nil) or (ANode.Attributes = nil) then
exit;
Found := false;
i := 0;
while not Found and (i < ANode.Attributes.Length) do begin
if ANode.Attributes.Item[i].NodeName = AAttrName then begin
Found := true;
Result := ANode.Attributes.Item[i].NodeValue;
end;
inc(i);
end;
end;
function GetNodeValue(ANode: TDOMNode): String;
var
child: TDOMNode;
begin
Result := '';
child := ANode.FirstChild;
if Assigned(child) and (child.NodeName = '#text') then
Result := child.NodeValue;
end;
function TryStrToGpxColor(AGpxText: String; out AColor: LongInt): Boolean;
type
PGpxColorRec = ^TGpxColorRec;
TGpxColorRec = record
r: array[0..1] of char;
g: array[0..1] of char;
b: array[0..1] of char;
end;
var
rv, gv, bv: Integer;
ch: Char;
begin
Result := false;
if Length(AGpxText) <> 6 then
exit;
for ch in AGpxText do
if not (ch in ['0'..'9', 'A'..'F', 'a'..'f']) then exit;
with PGpxColorRec(@AGpxText[1])^ do begin
rv := (ord(r[0]) - ord('0')) * 16 + ord(r[1]) - ord('0');
gv := (ord(g[0]) - ord('0')) * 16 + ord(g[1]) - ord('0');
bv := (ord(b[0]) - ord('0')) * 16 + ord(b[1]) - ord('0');
end;
AColor := rv + gv shl 8 + bv shl 16;
Result := true;
end;
{ TGpxReader }
{ Loads the specified gpx file and stores the tracks, points etc. in the provided
list. All items share the same mapviewer ID which is selected randomly and
return as function result. ABounds is the geo rectangle enclosing the items. }
function TGpxReader.LoadFromFile(AFileName: String; AList: TGpsObjectList;
out ABounds: TRealArea): Integer;
var
stream: TStream;
begin
stream := TFileStream.Create(AFileName, fmOpenRead + fmShareDenyNone);
try
Result := LoadFromStream(stream, AList, ABounds);
finally
stream.Free;
end;
end;
function TGpxReader.LoadFromFile(AFileName: String; AList: TGpsObjectList): Integer;
var
area: TRealArea;
begin
Result := LoadFromFile(AFileName, AList, area);
end;
{ See LoadFromFile. }
function TGpxReader.LoadFromStream(AStream: TStream; AList: TGpsObjectList;
out ABounds: TRealArea): Integer;
var
doc: TXMLDocument = nil;
begin
try
ID := random(MaxInt - 1000) + 1000;
FMinLon := 9999; FMinLat := 9999;
FMaxLon := -9999; FMaxLat := -9999;
ReadXMLFile(doc, AStream);
ReadWayPoints(doc.DocumentElement.FindNode('wpt'), AList);
ReadTracks(doc.DocumentElement.FindNode('trk'), AList);
ReadRoute(doc.DocumentElement.FindNode('rte'), AList);
ABounds.TopLeft.Lon := FMinLon;
ABounds.TopLeft.Lat := FMaxLat;
ABounds.BottomRight.Lon := FMaxLon;
ABounds.BottomRight.Lat := FMinLat;
Result := ID;
finally
doc.Free;
end;
end;
function TGpxReader.LoadFromStream(AStream: TStream; AList: TGpsObjectList): Integer;
var
area: TRealArea;
begin
Result := LoadFromStream(AStream, AList, area);
end;
procedure TGpxReader.ReadExtensions(ANode: TDOMNode; ATrack: TGpsTrack);
var
linenode: TDOMNode;
childNode: TDOMNode;
nodeName: string;
color: LongInt;
w: Double = -1;
colorUsed: Boolean = false;
s: String;
begin
if ANode = nil then
exit;
lineNode := ANode.FirstChild;
while lineNode <> nil do begin
nodeName := lineNode.NodeName;
if nodeName = 'line' then begin
childNode := lineNode.FirstChild;
while childNode <> nil do begin
nodeName := childNode.NodeName;
s := GetNodeValue(childNode);
case nodeName of
'color':
if TryStrToGpxColor(s, color) then colorUsed := true;
'width':
TryStrToFloat(s, w, PointSettings);
end;
childNode := childNode.NextSibling;
end;
end;
lineNode := lineNode.NextSibling;
end;
if (w <> -1) or colorUsed then begin
if ATrack.ExtraData = nil then
ATrack.ExtraData := TTrackExtraData.Create(ID);
if (ATrack.ExtraData is TTrackExtraData) then begin
TTrackExtraData(ATrack.ExtraData).Width := w;
TTrackExtraData(ATrack.ExtraData).Color := color;
end;
end;
end;
function TGpxReader.ReadPoint(ANode: TDOMNode): TGpsPoint;
var
s, slon, slat, sName: String;
lon, lat, ele: Double;
dt: TDateTime;
node: TDOMNode;
nodeName: String;
begin
Result := nil;
if ANode = nil then
exit;
slon := GetAttrValue(ANode, 'lon');
slat := GetAttrValue(ANode, 'lat');
if (slon = '') or (slat = '') then
exit;
if not TryStrToFloat(slon, lon, PointSettings) then
exit;
if not TryStrToFloat(slat, lat, PointSettings) then
exit;
sName := '';
dt := NO_DATE;
ele := NO_ELE;
node := ANode.FirstChild;
while node <> nil do begin
nodeName := node.NodeName;
case nodeName of
'ele' :
begin
s := GetNodeValue(node);
if s <> '' then
TryStrToFloat(s, ele, PointSettings);
end;
'name':
sName := GetNodeValue(node);
'time':
begin
s := GetNodeValue(node);
if s <> '' then
dt := ExtractISODateTime(s);
end;
end;
node := node.NextSibling;
end;
Result := TGpsPoint.Create(lon, lat, ele, dt);
Result.Name := sname;
FMinLon := Min(FMinLon, lon);
FMaxLon := Max(FMaxLon, lon);
FMinLat := Min(FMinLat, lat);
FMaxLat := Max(FMaxLat, lat);
end;
procedure TGpxReader.ReadRoute(ANode: TDOMNode; AList: TGpsObjectlist);
var
trk: TGpsTrack;
nodeName: string;
pt: TGpsPoint;
trkName: String;
begin
if ANode = nil then
exit;
ANode := ANode.FirstChild;
if ANode = nil then
exit;
trk := TGpsTrack.Create;
while ANode <> nil do begin
nodeName := ANode.NodeName;
case nodeName of
'name':
trkName := GetNodeValue(ANode);
'rtept':
begin
pt := ReadPoint(ANode);
if pt <> nil then trk.Points.Add(pt);
end;
end;
ANode := ANode.NextSibling;
end;
trk.Name := trkName;
AList.Add(trk, ID);
end;
procedure TGpxReader.ReadTrack(ANode: TDOMNode; AList: TGpsObjectList);
var
trk: TGpsTrack;
nodeName: string;
pt: TGpsPoint;
trkName: String = '';
begin
if ANode = nil then
exit;
ANode := ANode.FirstChild;
if ANode = nil then
exit;
trk := TGpsTrack.Create;
while ANode <> nil do begin
nodeName := ANode.NodeName;
case nodeName of
'name':
trkName := GetNodeValue(ANode);
'trkseg':
ReadTrackSegment(ANode.FirstChild, trk);
'trkpt':
begin
pt := ReadPoint(ANode);
if pt <> nil then trk.Points.Add(pt);
end;
'extensions':
ReadExtensions(ANode, trk);
end;
ANode := ANode.NextSibling;
end;
trk.Name := trkName;
AList.Add(trk, ID);
end;
procedure TGpxReader.ReadTracks(ANode: TDOMNode; AList: TGpsObjectList);
var
nodeName: String;
begin
while ANode <> nil do begin
nodeName := ANode.NodeName;
if nodeName = 'trk' then
ReadTrack(ANode, AList);
ANode := ANode.NextSibling;
end;
end;
procedure TGpxReader.ReadTrackSegment(ANode: TDOMNode; ATrack: TGpsTrack);
var
gpsPt: TGpsPoint;
nodeName: String;
begin
while ANode <> nil do begin
nodeName := ANode.NodeName;
if nodeName = 'trkpt' then begin
gpsPt := ReadPoint(ANode);
if gpsPt <> nil then
ATrack.Points.Add(gpsPt);
end;
ANode := ANode.NextSibling;
end;
end;
procedure TGpxReader.ReadWayPoints(ANode: TDOMNode; AList: TGpsObjectList);
var
nodeName: String;
gpsPt: TGpsPoint;
begin
while ANode <> nil do begin
nodeName := ANode.NodeName;
if nodeName = 'wpt' then begin
gpsPt := ReadPoint(ANode);
if gpsPt <> nil then
AList.Add(gpsPt, ID);
end;
ANode := ANode.NextSibling;
end;
end;
initialization
PointSettings := DefaultFormatSettings;
PointSettings.DecimalSeparator := '.';
end.