source: tags/1.4.0/UTrack.pas

unit UTrack;

interface

uses
  Classes, SysUtils, Math, Generics.Collections, UGeometric, DOM, XMLRead,
  XMLWrite, UXMLUtils, UItems;

type
  TTrack = class;
  TTrackPoint = class;
  TTrackPoints = class;
  TTrackLink = class;
  TTrackLinks = class;

  { TTrackPosition }

  TTrackPosition = record
    BaseTrackPoint: TTrackPoint;
    RelPos: Double;
    function GetTrackPosition: Integer;
    function GetVector: TVector;
    procedure Move(Distance: Double);
    procedure LoadFromXmlNode(Node: TDOMNode; Points: TTrackPoints);
    procedure SaveToXmlNode(Node: TDOMNode);
  end;

  { TTrackPoint }

  TTrackPoint = class(TItem)
    OwnerPoint: TObject;
    Position: TPoint;
    PositionDesigned: TPoint;
    Pending: Boolean;
    Track: TTrack;
    NeighPoints: TTrackPoints;
    NeighLinks: TTrackLinks;
    LinkUp: TTrackLink;
    LinkDown: TTrackLink;
    procedure Connect(TrackPoint: TTrackPoint);
    procedure Disconnect(TrackPoint: TTrackPoint);
    function GetDown: TTrackPoint;
    function GetUp: TTrackPoint;
    function GetNeighDown: TTrackPoint;
    function GetNeighUp: TTrackPoint;
    function GetLinkDown: TTrackLink;
    function GetLinkUp: TTrackLink;
    function GetTrackPosition: Integer;

    // Move to TTrackLink later
    function GetDistance: Integer;

    class function GetClassSysName: string; override;
    procedure LoadFromXmlNode(Node: TDOMNode); override;
    procedure SaveToXmlNode(Node: TDOMNode); override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TTrackPoints }

  TTrackPoints = class(TItems<TTrackPoint>)
    Track: TTrack;
    class function GetClassSysName: string; override;
    function CreateItem: TTrackPoint; override;
    procedure ResetToDesignatedPosition;
  end;

  { TTrackLink }

  TTrackLink = class(TItem)
    Points: TTrackPoints;
    Shift: TPoint;
    class function GetClassSysName: string; override;
    procedure LoadFromXmlNode(Node: TDOMNode); override;
    procedure SaveToXmlNode(Node: TDOMNode); override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TTrackLinks }

  TTrackLinks = class(TItems<TTrackLink>)
    class function GetClassSysName: string; override;
    function SearchPoints(Point1, Point2: TTrackPoint): TTrackLink;
  end;

  { TTrack }

  TTrack = class(TItem)
    Points: TTrackPoints;
    Links: TTrackLinks;
    Owner: TObject;
    function GetLength: Integer;
    procedure RouteTrack(TP1, TP2: TTrackPoint);
    procedure RemoveTrackBetween(TP1, TP2: TTrackPoint);
    constructor Create;
    destructor Destroy; override;
    class function GetClassSysName: string; override;
    procedure LoadFromXmlNode(Node: TDOMNode); override;
    procedure SaveToXmlNode(Node: TDOMNode); override;
  end;

  { TTrackPointsAngle }

  TTrackPointsAngle = class
    Angle: Double;
    TrackLinks: TTrackLinks;
    constructor Create;
    destructor Destroy; override;
  end;

  { TTrackPointsAngleGroup }

  TTrackPointsAngleGroup = class(TObjectList<TTrackPointsAngle>)
    function SearchAngle(Angle: Double): TTrackPointsAngle;
  end;


implementation

resourcestring
  SAlreadyConnectedTrackPoint = 'Trying to connect already connected track point';
  SAlreadyDisconnectedTrackPoint = 'Trying to disconnect not connected track point';
  STrackPointNotFound = 'Track point %d not found';

{ TTrackPosition }

function TTrackPosition.GetTrackPosition: Integer;
begin
  Result := Round(RelPos);
  if Assigned(BaseTrackPoint) then
    Result := Result + BaseTrackPoint.GetTrackPosition;
end;

function TTrackPosition.GetVector: TVector;
var
  D: Integer;
  UpPoint: TTrackPoint;
begin
  Result.Position := Point(0, 0);
  if Assigned(BaseTrackPoint) then
  with BaseTrackPoint do begin
    UpPoint := BaseTrackPoint.GetNeighUp;
    if Assigned(UpPoint) then begin
      Result.Direction := SubPoint(UpPoint.Position, Position);
      D := Distance(UpPoint.Position, Position);
      if D > 0 then begin
        Result.Position := Point(Trunc(Position.X + Result.Direction.X * RelPos / D),
          Trunc(Position.Y + Result.Direction.Y * RelPos / D));
      end else begin
        Result.Position := Position;
      end;
    end;
  end;
end;

procedure TTrackPosition.Move(Distance: Double);
var
  Direction: Integer;
begin
  Direction := Sign(Distance);
  Distance := Abs(Distance);
  while Distance > 0 do begin
    if Direction > 0 then begin
      if RelPos + Distance < BaseTrackPoint.GetDistance then begin
        RelPos := RelPos + Distance;
        Distance := 0;
      end else begin
        if Assigned(BaseTrackPoint.GetNeighUp) then begin
          Distance := Distance - (BaseTrackPoint.GetDistance - RelPos);
          BaseTrackPoint := BaseTrackPoint.GetNeighUp;
          RelPos := 0;
        end else
          // Reverse direction at the end of track
          Direction := -Direction;
      end;
    end else
    if Direction < 0 then begin
      if RelPos - Distance >= 0 then begin
        RelPos := RelPos - Distance;
        Distance := 0;
      end else begin
        if Assigned(BaseTrackPoint.GetNeighDown) then begin
          Distance := Distance - RelPos;
          BaseTrackPoint := BaseTrackPoint.GetNeighDown;
          RelPos := BaseTrackPoint.GetDistance;
        end else
        // Reverse direction at the end of track
        Direction := -Direction;
      end;
    end;
  end;
end;

procedure TTrackPosition.LoadFromXmlNode(Node: TDOMNode; Points: TTrackPoints);
begin
  RelPos := ReadDouble(Node, 'RelPos', RelPos);
  BaseTrackPoint := Points.FindById(ReadInteger(Node, 'BaseTrackPoint', 0));
end;

procedure TTrackPosition.SaveToXmlNode(Node: TDOMNode);
begin
  WriteDouble(Node, 'RelPos', RelPos);
  if Assigned(BaseTrackPoint) then
    WriteInteger(Node, 'BaseTrackPoint', BaseTrackPoint.Id)
    else WriteInteger(Node, 'BaseTrackPoint', 0)
end;

{ TTrackLinks }

class function TTrackLinks.GetClassSysName: string;
begin
  Result := 'Links';
end;

function TTrackLinks.SearchPoints(Point1, Point2: TTrackPoint): TTrackLink;
var
  I: Integer;
begin
  I := 0;
  while (I < 0) and
    ((Items[I].Points.First <> Point1) or (Items[I].Points.Last <> Point2)) and
    ((Items[I].Points.First <> Point2) or (Items[I].Points.Last <> Point1)) do
  Inc(I);
  if I < 0 then Result := Items[I]
    else Result := nil;
end;

{ TTrackPoints }

class function TTrackPoints.GetClassSysName: string;
begin
  Result := 'Points';
end;

function TTrackPoints.CreateItem: TTrackPoint;
begin
  Result := inherited;
  Result.Track := Track;
end;

procedure TTrackPoints.ResetToDesignatedPosition;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
    Items[I].Position := Items[I].PositionDesigned;
end;

{ TTrack }

constructor TTrack.Create;
begin
  Points := TTrackPoints.Create;
  Points.Track := Self;
  Links := TTrackLinks.Create;
end;

destructor TTrack.Destroy;
begin
  FreeAndNil(Points);
  FreeAndNil(Links);
  inherited;
end;

class function TTrack.GetClassSysName: string;
begin
  Result := 'Track';
end;

procedure TTrack.LoadFromXmlNode(Node: TDOMNode);
var
  NewNode: TDOMNode;
begin
  NewNode := Node.FindNode(DOMString(TTrackPoints.GetClassSysName));
  if Assigned(NewNode) then
    Points.LoadFromXmlNode(NewNode);

  NewNode := Node.FindNode(DOMString(TTrackLinks.GetClassSysName));
  if Assigned(NewNode) then
    Links.LoadFromXmlNode(NewNode);
end;

procedure TTrack.SaveToXmlNode(Node: TDOMNode);
var
  NewNode: TDOMNode;
begin
  Points.RebuildItemsId;
  Links.RebuildItemsId;

  NewNode := Node.OwnerDocument.CreateElement(DOMString(TTrackPoints.GetClassSysName));
  Node.AppendChild(NewNode);
  Points.SaveToXmlNode(NewNode);

  NewNode := Node.OwnerDocument.CreateElement(DOMString(TTrackLinks.GetClassSysName));
  Node.AppendChild(NewNode);
  Links.SaveToXmlNode(NewNode);
end;

function TTrack.GetLength: Integer;
var
  I: Integer;
begin
  Result := 0;
  for I := 0 to Points.Count - 1 do
  if I > 0 then
    Result := Result + Distance(Points[I].Position, Points[I - 1].Position);
end;

procedure TTrack.RouteTrack(TP1, TP2: TTrackPoint);
var
  NewTrackPoint: TTrackPoint;
  Delta: TPoint;
  P1, P2: TPoint;
  Index1, Index2: Integer;
begin
  RemoveTrackBetween(TP1, TP2);
  Index1 := Points.IndexOf(TP1);
  Index2 := Points.IndexOf(TP2);
  P1 := Points[Index1].PositionDesigned;
  P2 := Points[Index2].PositionDesigned;
  NewTrackPoint := Points.CreateItem;
  Delta := Point(P2.X - P1.X, P2.Y - P1.Y);
  if Abs(Delta.X) > Abs(Delta.Y) then begin
    NewTrackPoint.PositionDesigned := Point(P2.X - Sign(Delta.X) * Abs(Delta.Y), P1.Y);
    NewTrackPoint.Position := NewTrackPoint.PositionDesigned;
  end else begin
    NewTrackPoint.PositionDesigned := Point(P1.X, P2.Y - Sign(Delta.Y) * Abs(Delta.X));
    NewTrackPoint.Position := NewTrackPoint.PositionDesigned;
  end;
  Points.Insert(Index1 + 1, NewTrackPoint);
end;

procedure TTrack.RemoveTrackBetween(TP1, TP2: TTrackPoint);
var
  Index1, Index2: Integer;
  Temp: Integer;
  I: Integer;
begin
  Index1 := Points.IndexOf(TP1);
  Index2 := Points.IndexOf(TP2);
  if (Index1 = -1) then
    raise Exception.Create(Format(STrackPointNotFound, [1]));
  if (Index2 = -1) then
    raise Exception.Create(Format(STrackPointNotFound, [2]));
  if Index1 > Index2 then begin
    Temp := Index1;
    Index1 := Index2;
    Index2 := Temp;
  end;
  for I := 1 to Index2 - Index1 - 1 do
    Points.Delete(Index1 + 1);
end;

{ TTrackLink }

class function TTrackLink.GetClassSysName: string;
begin
  Result := 'Link';
end;

procedure TTrackLink.LoadFromXmlNode(Node: TDOMNode);
begin
  inherited;
end;

procedure TTrackLink.SaveToXmlNode(Node: TDOMNode);
begin
  inherited;
end;

constructor TTrackLink.Create;
begin
  Points := TTrackPoints.Create;
  Points.OwnsObjects := False;
end;

destructor TTrackLink.Destroy;
begin
  FreeAndNil(Points);
  inherited;
end;

{ TTrackPointsAngleGroup }

function TTrackPointsAngleGroup.SearchAngle(Angle: Double): TTrackPointsAngle;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Angle <> Angle) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

{ TTrackPointsAngle }

constructor TTrackPointsAngle.Create;
begin
  TrackLinks := TTrackLinks.Create;
  TrackLinks.OwnsObjects := False;
end;

destructor TTrackPointsAngle.Destroy;
begin
  FreeAndNil(TrackLinks);
  inherited;
end;

{ TTrackPoint }

procedure TTrackPoint.Connect(TrackPoint: TTrackPoint);
var
  NewLink: TTrackLink;
begin
  if NeighPoints.IndexOf(TrackPoint) = -1 then begin
    NeighPoints.Add(TrackPoint);
    TrackPoint.NeighPoints.Add(Self);

    // Add new link to both self and connected track point
    NewLink := Track.Links.CreateItem;
    NewLink.Points.Add(TrackPoint);
    NewLink.Points.Add(Self);
    NeighLinks.Add(NewLink);
    TrackPoint.NeighLinks.Add(NewLink);
    Track.Links.Add(NewLink);
  end else raise Exception.Create(SAlreadyConnectedTrackPoint);
end;

procedure TTrackPoint.Disconnect(TrackPoint: TTrackPoint);
var
  Index: Integer;
  Link: TTrackLink;
begin
  Index := NeighPoints.IndexOf(TrackPoint);
  if NeighPoints.IndexOf(TrackPoint) <> -1 then begin
    NeighPoints.Delete(Index);
    TrackPoint.NeighPoints.Remove(Self);

    // Remove link from both track points
    Link := NeighLinks.SearchPoints(Self, TrackPoint);
    NeighLinks.Remove(Link);
    TrackPoint.NeighLinks.Remove(Link);
    Track.Links.Remove(Link);
  end else raise Exception.Create(SAlreadyDisconnectedTrackPoint);
end;

function TTrackPoint.GetDown: TTrackPoint;
var
  I: Integer;
begin
  I := Track.Points.IndexOf(Self) - 1;
  while (I >= 0) and not Assigned(Track.Points[I].OwnerPoint) do
    Dec(I);
  if I >= 0 then Result := Track.Points[I]
    else Result := nil;
end;

function TTrackPoint.GetUp: TTrackPoint;
var
  I: Integer;
begin
  I := Track.Points.IndexOf(Self) + 1;
  while (I < Track.Points.Count) and not Assigned(Track.Points[I].OwnerPoint) do
    Inc(I);
  if I < Track.Points.Count then Result := Track.Points[I]
    else Result := nil;
end;

function TTrackPoint.GetNeighDown: TTrackPoint;
var
  NewIndex: Integer;
begin
  Result := nil;
  NewIndex := Track.Points.IndexOf(Self) - 1;
  if NewIndex >= 0 then Result := Track.Points[NewIndex];
end;

function TTrackPoint.GetNeighUp: TTrackPoint;
var
  NewIndex: Integer;
begin
  Result := nil;
  if Assigned(Track) then begin
    NewIndex := Track.Points.IndexOf(Self) + 1;
    if NewIndex < Track.Points.Count then Result := Track.Points[NewIndex];
  end;
end;

function TTrackPoint.GetLinkDown: TTrackLink;
begin
  if Assigned(LinkDown) then Result := LinkDown
    else begin
      LinkDown := TTrackLink.Create;
      LinkDown.Points.Add(GetNeighDown);
      LinkDown.Points.Add(Self);
      Result := LinkDown;
      GetNeighDown.LinkUp := LinkDown;
    end;
end;

function TTrackPoint.GetLinkUp: TTrackLink;
begin
  if Assigned(LinkUp) then Result := LinkUp
    else begin
      LinkUp := TTrackLink.Create;
      LinkUp.Points.Add(Self);
      LinkUp.Points.Add(GetNeighUp);
      Result := LinkUp;
      GetNeighUp.LinkDown := LinkUp;
    end;
end;

function TTrackPoint.GetTrackPosition: Integer;
var
  Index: Integer;
  I: Integer;
begin
  Result := 0;
  Index := Track.Points.IndexOf(Self);
  for I := 0 to Index - 1 do
    Result := Result + Track.Points[I].GetDistance;
end;

function TTrackPoint.GetDistance: Integer;
var
  Index: Integer;
begin
  Index := Track.Points.IndexOf(Self);
  if Index + 1 < Track.Points.Count then begin
    Result := Distance(Track.Points[Index + 1].Position, Track.Points[Index].Position);
  end else Result := 0;
end;

class function TTrackPoint.GetClassSysName: string;
begin
  Result := 'Point';
end;

procedure TTrackPoint.LoadFromXmlNode(Node: TDOMNode);
begin
  inherited;
  Position.X := ReadInteger(Node, 'PositionX', Position.X);
  Position.Y := ReadInteger(Node, 'PositionY', Position.Y);
  PositionDesigned.X := ReadInteger(Node, 'PositionDesignedX', PositionDesigned.X);
  PositionDesigned.Y := ReadInteger(Node, 'PositionDesignedY', PositionDesigned.Y);
end;

procedure TTrackPoint.SaveToXmlNode(Node: TDOMNode);
begin
  inherited;
  WriteInteger(Node, 'PositionX', Position.X);
  WriteInteger(Node, 'PositionY', Position.Y);
  WriteInteger(Node, 'PositionDesignedX', PositionDesigned.X);
  WriteInteger(Node, 'PositionDesignedY', PositionDesigned.Y);
end;

constructor TTrackPoint.Create;
begin
  NeighPoints := TTrackPoints.Create;
  NeighPoints.OwnsObjects := False;
  NeighLinks := TTrackLinks.Create;
  NeighLinks.OwnsObjects := False;
end;

destructor TTrackPoint.Destroy;
begin
  FreeAndNil(NeighLinks);
  FreeAndNil(NeighPoints);
  Track := nil;
  OwnerPoint := nil;
  inherited;
end;

end.