AdventOfCode2023/solvers/ULongWalk.pas

{
  Solutions to the Advent Of Code.
  Copyright (C) 2023  Stefan Müller

  This program is free software: you can redistribute it and/or modify it under
  the terms of the GNU General Public License as published by the Free Software
  Foundation, either version 3 of the License, or (at your option) any later
  version.

  This program is distributed in the hope that it will be useful, but WITHOUT
  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.

  You should have received a copy of the GNU General Public License along with
  this program.  If not, see <http://www.gnu.org/licenses/>.
}

unit ULongWalk;

{$mode ObjFPC}{$H+}

interface

uses
  Classes, SysUtils, Generics.Collections, USolver;

type
  TPoints = specialize TList<TPoint>;

  TCrossing = class;

  { TPath }

  TPath = class
  private
    FEnd: TCrossing;
    FLength: Integer;
  public
    property EndCrossing: TCrossing read FEnd;
    property Length: Integer read FLength;
    constructor Create(const ALength: Integer; const AEnd: TCrossing);
  end;

  TPaths = specialize TObjectList<TPath>;

  { TPathStart }

  TPathStart = record
    Position, ReverseDirection: TPoint;
    Crossing: TCrossing;
  end;

  TPathStartQueue = specialize TQueue<TPathStart>;

  { TCrossing }

  TCrossing = class
  private
    FPosition: TPoint;
    FOutPaths: TPaths;
    FDistance: Integer;
  public
    property Position: TPoint read FPosition;
    property OutPaths: TPaths read FOutPaths;
    property Distance: Integer read FDistance write FDistance;
    constructor Create(constref APosition: TPoint);
    destructor Destroy; override;
    procedure AddOutPath(const AOutPath: TPath);
  end;

  TCrossings = specialize TObjectList<TCrossing>;
  TCrossingStack = specialize TStack<TCrossing>;

  { TLongWalk }

  TLongWalk = class(TSolver)
  private
    FLines: TStringList;
    FPaths: TPaths;
    FCrossings, FWaitingForOtherInPath: TCrossings;
    FStart: TCrossing;
    function GetPosition(constref APoint: TPoint): Char;
    procedure ProcessPaths;
    procedure StepPath(const AStartPositionQueue: TPathStartQueue);
    function FindOrCreateCrossing(constref APosition: TPoint; const AStartPositionQueue: TPathStartQueue): TCrossing;
    procedure FindLongestPath;
  public
    constructor Create;
    destructor Destroy; override;
    procedure ProcessDataLine(const ALine: string); override;
    procedure Finish; override;
    function GetDataFileName: string; override;
    function GetPuzzleName: string; override;
  end;

  TDirection = (dirRight, dirDown, dirLeft, dirUp);

const
  CPathChar = '.';
  CForestChar = '#';
  CRightSlopeChar = '>';
  CDownSlopeChar = 'v';
  CDirections: array[TDirection] of TPoint = ((X: 1; Y: 0), (X: 0; Y: 1), (X: -1; Y: 0), (X: 0; Y: -1));
  CStartReverseDirection: TPoint = (X: 0; Y: -1);

implementation

{ TPath }

constructor TPath.Create(const ALength: Integer; const AEnd: TCrossing);
begin
  FLength := ALength;
  FEnd := AEnd;
end;

{ TCrossing }

constructor TCrossing.Create(constref APosition: TPoint);
begin
  FPosition := APosition;
  FOutPaths := TPaths.Create(False);
  FDistance := 0;
end;

destructor TCrossing.Destroy;
begin
  FOutPaths.Free;
  inherited Destroy;
end;

procedure TCrossing.AddOutPath(const AOutPath: TPath);
begin
  FOutPaths.Add(AOutPath);
end;

{ TLongWalk }

function TLongWalk.GetPosition(constref APoint: TPoint): Char;
begin
  Result := FLines[APoint.Y][APoint.X];
end;

procedure TLongWalk.ProcessPaths;
var
  stack: TPathStartQueue;
  pathStart: TPathStart;
begin
  stack := TPathStartQueue.Create;
  pathStart.Position := FStart.Position;
  pathStart.Crossing := FStart;
  pathStart.ReverseDirection := CStartReverseDirection;
  stack.Enqueue(pathStart);
  while stack.Count > 0 do
    StepPath(stack);
  stack.Free;
end;

procedure TLongWalk.StepPath(const AStartPositionQueue: TPathStartQueue);
var
  start: TPathStart;
  new, direction: TPoint;
  c: Char;
  len: Integer;
  oneMore, stop: Boolean;
  crossing: TCrossing;
  path: TPath;
begin
  start := AStartPositionQueue.Dequeue;
  len := 1;
  if start.Crossing <> FStart then
    Inc(len);
  oneMore := False;
  stop := False;
  repeat
    for direction in CDirections do
      if direction <> start.ReverseDirection then
      begin
        new := start.Position + direction;
        c := GetPosition(new);
        if c <> CForestChar then
        begin
          start.ReverseDirection := Point(-direction.X, -direction.Y);
          start.Position := new;

          if oneMore or (new.Y = FLines.Count - 1) then
            stop := True
          else
            Inc(len);

          if c <> CPathChar then
            oneMore := True;
          Break;
        end;
      end;
  until stop;

  crossing := FindOrCreateCrossing(start.Position, AStartPositionQueue);
  path := TPath.Create(len, crossing);
  FPaths.Add(path);
  start.Crossing.AddOutPath(path);
end;

// Crossing with multiple (two) entries will only be added to FCrossings once both in-paths have been processed. This
// guarantees a topological order in the list of crossings, which is required for our longest path algorithm.
function TLongWalk.FindOrCreateCrossing(constref APosition: TPoint; const AStartPositionQueue: TPathStartQueue):
  TCrossing;
var
  i: Integer;
  pathStart: TPathStart;
begin
  Result := nil;

  // Checks if the crossing has already been encountered.
  i := 0;
  while (i < FWaitingForOtherInPath.Count) and (Result = nil) do
  begin
    if FWaitingForOtherInPath[i].Position = APosition then
    begin
      Result := FWaitingForOtherInPath[i];
      FCrossings.Add(Result);
    end
    else
      Inc(i);
  end;

  if Result <> nil then
  begin
    FWaitingForOtherInPath.Delete(i);
    Exit;
  end;

  // Creates a new crossing.
  Result := TCrossing.Create(APosition);

  // Checks if the new crossing has multiple entries.
  if (GetPosition(APosition + CDirections[dirLeft]) = CRightSlopeChar)
  and (GetPosition(APosition + CDirections[dirUp]) = CDownSlopeChar) then
    FWaitingForOtherInPath.Add(Result)
  else
    FCrossings.Add(Result);

  if APosition.Y < FLines.Count - 1 then
  begin
    // Adds the exits of this crossing to the stack as starts for new paths.
    pathStart.Crossing := Result;

    pathStart.Position := APosition + CDirections[dirRight];
    if GetPosition(pathStart.Position) = CRightSlopeChar then
    begin
      pathStart.ReverseDirection := CDirections[dirLeft];
      AStartPositionQueue.Enqueue(pathStart);
    end;

    pathStart.Position := APosition + CDirections[dirDown];
    if GetPosition(pathStart.Position) = CDownSlopeChar then
    begin
      pathStart.ReverseDirection := CDirections[dirUp];
      AStartPositionQueue.Enqueue(pathStart);
    end;
  end
end;

procedure TLongWalk.FindLongestPath;
var
  crossing: TCrossing;
  path: TPath;
begin
  for crossing in FCrossings do
  begin
    for path in crossing.OutPaths do
      if path.EndCrossing.Distance < crossing.Distance + path.Length then
        path.EndCrossing.Distance := crossing.Distance + path.Length;
  end;
  FPart1 := FCrossings.Last.Distance;
end;

constructor TLongWalk.Create;
begin
  FLines := TStringList.Create;
  FPaths := TPaths.Create;
  FCrossings := TCrossings.Create;
  FWaitingForOtherInPath := TCrossings.Create(False);
end;

destructor TLongWalk.Destroy;
begin
  FLines.Free;
  FPaths.Free;
  FCrossings.Free;
  FWaitingForOtherInPath.Free;
  inherited Destroy;
end;

procedure TLongWalk.ProcessDataLine(const ALine: string);
begin
  if FLines.Count = 0 then
  begin
    FStart := TCrossing.Create(Point(ALine.IndexOf(CPathChar) + 1, 0));
    FCrossings.Add(FStart);
  end;
  FLines.Add(ALine);
end;

procedure TLongWalk.Finish;
begin
  ProcessPaths;
  FindLongestPath;
end;

function TLongWalk.GetDataFileName: string;
begin
  Result := 'a_long_walk.txt';
end;

function TLongWalk.GetPuzzleName: string;
begin
  Result := 'Day 23: A Long Walk';
end;

end.