lazarus-ccr/components/lazmapviewer/source/mvgpx.pas

{ 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.