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, laz2_XMLWrite, DateUtils,
  mvTypes, mvGpsObj;

type

  { TGpxReader }

  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;

  { TGpxWriter }

  TGpxWriter = class
  public
    class procedure SaveToStream(AStream: TStream; AList: TGpsObjectList);
    class procedure SaveToFile(AFileName: String; AList: TGPSObjectList);
  end;


implementation

uses
  Math,
  mvExtraData;

var
  PointSettings: TFormatSettings;

function GetTZD: TTime;
begin
  Result := -(DateUtils.OneMinute * SysUtils.GetLocalTimeOffset);
end;

function Str2DTTZD_l(S: AnsiString; out Tzd: TTime; out IsLocal: Boolean): TDateTime;
const
  FMT = 'yyyy"-"mm"-"dd"T"hh":"nn":"ss';
var
  I, L, Sg: Integer;
  Millis: Int64;

  procedure RaiseErr;
  begin
    raise EConvertError.Create('Bad ISO8601 format.');
  end;

begin
  L := Length(S);
  if (L > 19) and (S[20] in ['.', ',']) then // 'YYYY-MM-DDTHH:NN:SS[.,]?.*'
  begin
    I := 21; // beyond the millis dot
    S[20] := '.';
    // Unfortunately, millis are not scanned correctly with zzz format chars.
    // .8 is scanned same as .08 or .008 which is *totally* wrong!
    Result := ScanDateTime(FMT {+ '"."zzz'}, S);
    Millis := 0;
    Sg := 0;
    while (I < L) and (S[I] in ['0'..'9']) do
    begin
      if Sg < 3 then // Only first three
      begin
        Millis := Millis * 10 + (Ord(S[I]) - Ord('0'));
        Inc(Sg);
      end;
      Inc(I); // Skip millis field
    end;
    case Sg of
      0: RaiseErr;
      1: Millis := Millis * 100;
      2: Millis := Millis * 10;
    end;
    // Adjust with milliseconds
    Result := IncMilliSecond(Result, Millis);
  end
  else
  begin
    I := 20; // beyond the seconds
    Result := ScanDateTime(FMT, S);
  end;

  // ScanDateTime does not treat trailing characters as error
  if I <= L then   // Length('YYYY-MM-DDTHH:NN:SS')
  begin

    // Check Zulu
    if (I = L) and (S[I] = 'Z') then
      Tzd := 0.0 // TZD is zero

    // Check TZD
    else if ((L - I) in [2,4,5]) and (S[I] in ['+', '-']) then
    begin
      if S[I] = '-' then Sg := -1 else Sg := 1;
      case (L - I) of
        2: Tzd := ScanDateTime('hh', Copy(S, I + 1, 2)) * Sg;
        4: Tzd := ScanDateTime('hhnn', Copy(S, I + 1, 4)) * Sg;
        5: Tzd := ScanDateTime('hh:nn', Copy(S, I + 1, 5)) * Sg;
      end;
    end

    // Garbage at the end
    else
      RaiseErr;

    IsLocal := False; // Qualified
  end
  else
  begin
    Tzd := GetTZD;   // Using local TZD!!!
    IsLocal := True; // Unqualified (local time)
  end;
end;

function Str2DTTZD(S: AnsiString; out Tzd: TTime): TDateTime;
var
  Local: Boolean;
begin
  Result := Str2DTTZD_l(S, Tzd, Local);
end;

function ExtractISODateTime(AText: String): TDateTime;
var
  Tzd: TTime;
begin
  try
    Result := Str2DTTZD(AText, Tzd);
  except
    Result := NO_DATE;
  end;
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;

class procedure TGpxWriter.SaveToStream(AStream: TStream; AList: TGpsObjectList
  );
var
  Doc: TXMLDocument;
  RootNode: TDOMNode;
  I: Integer;
  O: TGPSObj;

  function CreateTextElement(ANode: TDOMNode; ATag, AValue: DOMString): TDOMNode;
  begin
    Result := ANode;
    Result.AppendChild(Doc.CreateElement(ATag)).AppendChild(
      Doc.CreateTextNode(AValue));
  end;

  function CreatePoint(AName: String; APOI: TGPSPoint): TDOMElement;
  begin
    Result := Doc.CreateElement(AName);
    Result.SetAttribute('lat', APOI.Lat.ToString);
    Result.SetAttribute('lon', APOI.Lon.ToString);
    if APOI.Name <> '' then
      CreateTextElement(Result, 'name', APOI.Name);
    if APOI.Elevation <> NO_ELE then
      CreateTextElement(Result, 'ele', APOI.Elevation.ToString);
    if APOI.DateTime <> NO_DATE then
      CreateTextElement(Result, 'time', DateToISO8601(APOI.DateTime));
  end;

begin
  Doc := TXMLDocument.Create;
  try
    RootNode := Doc.CreateElement('gpx');
    Doc.AppendChild(RootNode);
    RootNode := Doc.DocumentElement;
    TDOMElement(RootNode).SetAttribute('version', '1.1');
    TDOMElement(RootNode).SetAttribute('creator',
      'LazMapViewer https://wiki.lazarus.freepascal.org/LazMapViewer');

    for I := 0 to Pred(AList.Count) do
    begin
      O := AList[I];
      if O is TGPSPointOfInterest then
        RootNode.AppendChild(CreatePoint('wpt', TGPSPoint(O)))
      else if O is TGPSPoint then
        RootNode.AppendChild(CreatePoint('wpt', TGPSPoint(O)))
      else if O is TGPSTrack then
        {TODO};
    end;
    WriteXMLFile(doc, AStream);

  finally
    Doc.Free;
  end;
end;

class procedure TGpxWriter.SaveToFile(AFileName: String; AList: TGPSObjectList);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(AFileName, fmCreate);
  try
    SaveToStream(Stream, AList);
  finally
    Stream.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.