AdventOfCode2023/solvers/ULongWalk.pas

{
  Solutions to the Advent Of Code.
  Copyright (C) 2023-2024  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, UCommon;

type
  TCrossing = class;

  TPathSelectionState = (pssNone, pssIncluded, pssExcluded);

  { TPath }

  TPath = class
  private
    FStart, FEnd: TCrossing;
    FLength: Integer;
    FSelected: TPathSelectionState;
  public
    property StartCrossing: TCrossing read FStart;
    property EndCrossing: TCrossing read FEnd;
    property Length: Integer read FLength;
    property Selected: TPathSelectionState read FSelected write FSelected;
    constructor Create(const ALength: Integer; const AStart, 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, FPaths: TPaths;
    FDistance: Integer;
    FNotExcludedDegree: Integer;
  public
    property Position: TPoint read FPosition;
    property OutPaths: TPaths read FOutPaths;
    property Paths: TPaths read FPaths;
    property Distance: Integer read FDistance write FDistance;
    property NotExcludedDegree: Integer read FNotExcludedDegree write FNotExcludedDegree;
    function CalcNextPickIndex(const AMinIndex: Integer): Integer;
    constructor Create(constref APosition: TPoint);
    destructor Destroy; override;
    procedure AddOutPath(const AOutPath: TPath);
    procedure AddInPath(const AInPath: TPath);
  end;

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

  TPathChoiceResult = (pcrContinue, pcrTargetReached, pcrTargetUnreachable, pcrNoMinimum);

  { TPathChoice }

  TPathChoice = class
  private
    FPrevious: TPathChoice;
    FPickIndex: Integer;
    FPick: TPath;
    FEndCrossing: TCrossing;
    FAutoExcludes: TPaths;
    FExcludeCost: Int64;
    FIncludeCost: Int64;
  public
    property PickIndex: Integer read FPickIndex;
    property EndCrossing: TCrossing read FEndCrossing;
    property IncludeCost: Int64 read FIncludeCost;
    function Apply(constref ATargetCrossing: TCrossing; const AExcludeCostLimit: Int64): TPathChoiceResult;
    procedure Revert;
    constructor Create(const AStartCrossing: TCrossing);
    constructor Create(const APickIndex: Integer; const APrevious: TPathChoice = nil);
    destructor Destroy; override;
  end;

  TPathChoiceStack = specialize TStack<TPathChoice>;

  { TLongWalk }

  TLongWalk = class(TSolver)
  private
    FLines: TStringList;
    FPaths: TPaths;
    FCrossings, FWaitingForOtherInPath: TCrossings;
    FPathLengthSum: Int64;
    function GetPosition(constref APoint: TPoint): Char;
    procedure ProcessPaths;
    procedure StepPath(const AStartPositionQueue: TPathStartQueue);
    function FindOrCreateCrossing(constref APosition: TPoint; const AStartPositionQueue: TPathStartQueue): TCrossing;
    // Treats the graph as directed for part 1.
    procedure FindLongestPath;
    // Treats the graph as undirected for part 2.
    procedure FindLongestPathIgnoreSlopes;
  public
    constructor Create;
    destructor Destroy; override;
    procedure ProcessDataLine(const ALine: string); override;
    procedure Finish; override;
    function GetDataFileName: string; override;
    function GetPuzzleName: string; override;
  end;

const
  CPathChar = '.';
  CForestChar = '#';
  CRightSlopeChar = '>';
  CDownSlopeChar = 'v';

implementation

{ TPath }

constructor TPath.Create(const ALength: Integer; const AStart, AEnd: TCrossing);
begin
  FLength := ALength;
  FStart := AStart;
  FEnd := AEnd;
  FSelected := pssNone;
end;

{ TCrossing }

function TCrossing.CalcNextPickIndex(const AMinIndex: Integer): Integer;
begin
  Result := AMinIndex;
  while (Result < FPaths.Count) and (FPaths[Result].Selected <> pssNone) do
    Inc(Result);
end;

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

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

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

procedure TCrossing.AddInPath(const AInPath: TPath);
begin
  FPaths.Add(AInPath);
  Inc(FNotExcludedDegree);
end;

{ TPathChoice }

function TPathChoice.Apply(constref ATargetCrossing: TCrossing; const AExcludeCostLimit: Int64): TPathChoiceResult;
var
  path: TPath;
  excludeStack: TCrossingStack;
  crossing, otherCrossing: TCrossing;
begin
  Result := pcrContinue;

  // Includes the selected path (edge) and checks whether target has been reached.
  FPick.Selected := pssIncluded;
  if FEndCrossing = ATargetCrossing then
    Result := pcrTargetReached
  else if FPrevious <> nil then
  begin
    // If the target has not been reached, starts at the starting crossing (which is the same as FPRevious.EndCrossing)
    // and recursively excludes other connected paths (edges).
    excludeStack := TCrossingStack.Create;
    excludeStack.Push(FPrevious.EndCrossing);

    while excludeStack.Count > 0 do
    begin
      crossing := excludeStack.Pop;
      for path in crossing.Paths do
        if path.Selected = pssNone then
        begin
          // Checks whether the path (edge) to the target crossing has been excluded and if so exits. The input data
          // should be such that there is only one such path.
          // The last crossing is always an end, never a start of a path (edge).
          if path.EndCrossing = ATargetCrossing then
          begin
            Result := pcrTargetUnreachable;
            excludeStack.Free;
            Exit;
          end
          else begin
            // Excludes the path (edge).
            path.Selected := pssExcluded;
            crossing.NotExcludedDegree := crossing.NotExcludedDegree - 1;
            FAutoExcludes.Add(path);
            FExcludeCost := FExcludeCost + path.Length;

            // Checks if this choice is worse than the current best.
            if FExcludeCost >= AExcludeCostLimit then
            begin
              Result := pcrNoMinimum;
              excludeStack.Free;
              Exit;
            end;

            // Finds the crossing on the other side, updates it, and possibly pushes it for recursion.
            if crossing = path.StartCrossing then
              otherCrossing := path.EndCrossing
            else
              otherCrossing := path.StartCrossing;

            otherCrossing.NotExcludedDegree := otherCrossing.NotExcludedDegree - 1;
            if otherCrossing.NotExcludedDegree < 2 then
              excludeStack.Push(otherCrossing);
          end;
        end;
    end;

    excludeStack.Free;
  end;
end;

procedure TPathChoice.Revert;
var
  path: TPath;
begin
  FPick.Selected := pssNone;
  for path in FAutoExcludes do begin
    path.Selected := pssNone;
    path.StartCrossing.NotExcludedDegree := path.StartCrossing.NotExcludedDegree + 1;
    path.EndCrossing.NotExcludedDegree := path.EndCrossing.NotExcludedDegree + 1;
  end;
end;

constructor TPathChoice.Create(const AStartCrossing: TCrossing);
begin
  FPrevious := nil;
  FPickIndex := 0;
  FPick := AStartCrossing.Paths[FPickIndex];
  FEndCrossing := FPick.EndCrossing;
  FExcludeCost := 0;
  FIncludeCost := FPick.FLength;
  FAutoExcludes := TPaths.Create(False);
end;

constructor TPathChoice.Create(const APickIndex: Integer; const APrevious: TPathChoice);
begin
  FPrevious := APrevious;
  FPickIndex := APickIndex;
  FPick := FPrevious.EndCrossing.Paths[FPickIndex];

  if FPick.StartCrossing = FPrevious.EndCrossing then
    FEndCrossing := FPick.EndCrossing
  else
    FEndCrossing := FPick.StartCrossing;

  FExcludeCost := FPrevious.FExcludeCost;
  FIncludeCost := FPrevious.FIncludeCost + FPick.FLength;
  FAutoExcludes := TPaths.Create(False);
end;

destructor TPathChoice.Destroy;
begin
  FAutoExcludes.Free;
  inherited Destroy;
end;

{ TLongWalk }

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

procedure TLongWalk.ProcessPaths;
var
  queue: TPathStartQueue;
  pathStart: TPathStart;
begin
  queue := TPathStartQueue.Create;
  pathStart.Crossing := FCrossings.First;
  pathStart.Position := FCrossings.First.Position;
  pathStart.ReverseDirection := CDirectionUp;
  queue.Enqueue(pathStart);
  while queue.Count > 0 do
    StepPath(queue);
  queue.Free;
end;

procedure TLongWalk.StepPath(const AStartPositionQueue: TPathStartQueue);
var
  start: TPathStart;
  new: TPoint;
  pdirection: PPoint;
  c: Char;
  len: Integer;
  oneMore, stop: Boolean;
  crossing: TCrossing;
  path: TPath;
begin
  start := AStartPositionQueue.Dequeue;
  len := 0;
  if start.Crossing <> FCrossings.First then
    Inc(len);
  oneMore := False;
  stop := False;
  repeat
    for pdirection in CPCardinalDirections do
      if pdirection^ <> start.ReverseDirection then
      begin
        new := start.Position + pdirection^;
        c := GetPosition(new);
        if c <> CForestChar then
        begin
          start.ReverseDirection := Point(-pdirection^.X, -pdirection^.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, start.Crossing, crossing);
  FPathLengthSum := FPathLengthSum + path.FLength;
  FPaths.Add(path);
  start.Crossing.AddOutPath(path);
  crossing.AddInPath(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 + CDirectionLeft) = CRightSlopeChar)
  and (GetPosition(APosition + CDirectionUp) = 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 + CDirectionRight;
    if GetPosition(pathStart.Position) = CRightSlopeChar then
    begin
      pathStart.ReverseDirection := CDirectionLeft;
      AStartPositionQueue.Enqueue(pathStart);
    end;

    pathStart.Position := APosition + CDirectionDown;
    if GetPosition(pathStart.Position) = CDownSlopeChar then
    begin
      pathStart.ReverseDirection := CDirectionUp;
      AStartPositionQueue.Enqueue(pathStart);
    end;
  end
end;

// In a directed graph with a topological ordering on the crossings (vertices), the maximum distance can be computed
// simply by traversing the crossings in that order and calculating the maximum locally.
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 + 1;
  end;
  FPart1 := FCrossings.Last.Distance;
end;

// For the undirected graph, we are running a DFS for the second to last crossing (vertex) with backtracking to find the
// minimum of excluded crossings and paths.
procedure TLongWalk.FindLongestPathIgnoreSlopes;
var
  pickIndex: Integer;
  choice: TPathChoice;
  stack: TPathChoiceStack;
  minExcludeCost, newExcludeCost: Int64;
begin
  minExcludeCost := FPathLengthSum + FCrossings.Count - 1 - FPart1;

  // Prepares the first pick, which is the only path connected to the first crossing.
  stack := TPathChoiceStack.Create;
  choice := TPathChoice.Create(FCrossings.First);
  choice.Apply(FCrossings.Last, minExcludeCost);
  stack.Push(choice);

  // Runs a DFS for last crossing with backtracking, trying to find the minimum cost of excluded paths (i.e. edges).
  pickIndex := -1;
  while stack.Count > 0 do
  begin
    // Chooses next path.
    pickIndex := stack.Peek.EndCrossing.CalcNextPickIndex(pickIndex + 1);
    if pickIndex < stack.Peek.EndCrossing.Paths.Count then
    begin
      choice := TPathChoice.Create(pickIndex, stack.Peek);
      case choice.Apply(FCrossings.Last, minExcludeCost) of
        // Continues DFS, target has not yet been reached.
        pcrContinue: begin
          stack.Push(choice);
          pickIndex := -1;
          Continue;
        end;
        // Updates minimum and backtracks last choice, after target has been reached.
        pcrTargetReached: begin
          // Calculates new exclude cost based on path length sum and the choice's include cost. This effectively
          // accounts for the "undecided" paths (edges) as well. Note that this does not actually need the choice's
          // exclude costs, these are only required for the early exit in TPathChoice.Apply().
          newExcludeCost := FCrossings.Count - stack.Count - 2 + FPathLengthSum - choice.IncludeCost;
          if minExcludeCost > newExcludeCost then
            minExcludeCost := newExcludeCost;

          choice.Revert;
          choice.Free;
        end;
        // Backtracks last choice, after target has been excluded or exclude costs ran over the current best.
        pcrTargetUnreachable, pcrNoMinimum: begin
          choice.Revert;
          choice.Free;
        end;
      end;
    end
    else begin
      choice := stack.Pop;
      pickIndex := choice.PickIndex;
      choice.Revert;
      choice.Free;
    end;
  end;
  stack.Free;

  FPart2 := FPathLengthSum - minExcludeCost + FCrossings.Count - 1;
end;

constructor TLongWalk.Create;
begin
  FLines := TStringList.Create;
  FPaths := TPaths.Create;
  FCrossings := TCrossings.Create;
  FWaitingForOtherInPath := TCrossings.Create(False);
  FPathLengthSum := 0;
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
    FCrossings.Add(TCrossing.Create(Point(ALine.IndexOf(CPathChar) + 1, 0)));
  FLines.Add(ALine);
end;

procedure TLongWalk.Finish;
begin
  ProcessPaths;
  FindLongestPath;
  FindLongestPathIgnoreSlopes;
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.