Added solution for "Day 23: A Long Walk", part 2

README.md

@@ -184,6 +184,14 @@ For part 1, if a brick lands on a single supporting brick, that brick below cann
 
 For part 2, given a starting brick, the algorithm makes use of the tracked vertical connections to find a group of bricks supported by it, such that all supports of the bricks in the group are also in the group. This group of bricks would fall if the starting brick was disintegrated, so its size is counted for each possible starting brick.
 
+### Day 23: A Long Walk
+
+:mag_right: Puzzle: <https://adventofcode.com/2023/day/23>, :white_check_mark: Solver: [`ULongWalk.pas`](solvers/ULongWalk.pas)
+
+There is a nice *O(|V| * |E|)* algorithm for the maximum flow in a directed acyclic graph, if a topological ordering of the vertices is know. It's relatively easy to parse the edges ("paths") of the long walk from the input such that a topological ordering results, by adding the vertices ("crossings") only after all in-edges have been found.
+
+For part 2, I believe there is no polynomial algorithm known for the general case, and even with the given restraints I was unable to come up with one. Instead, my solution uses a depth-first search to parse all options in the network. This was feasible for the given input with some smart data structures to limit iterations of the vertex or edge lists, and with shortcuts to determine early if a search branch can be abandoned.
+
 ### Day 24: Never Tell Me the Odds
 
 :star: :mag_right: Puzzle: <https://adventofcode.com/2023/day/24>, :white_check_mark: Solver: [`UNeverTellMeTheOdds.pas`](solvers/UNeverTellMeTheOdds.pas)

solvers/ULongWalk.pas

@@ -27,16 +27,21 @@ uses
 type
   TCrossing = class;
 
+  TPathSelectionState = (pssNone, pssIncluded, pssExcluded);
+
   { TPath }
 
   TPath = class
   private
-    FEnd: TCrossing;
+    FStart, FEnd: TCrossing;
     FLength: Integer;
+    FSelected: TPathSelectionState;
   public
+    property StartCrossing: TCrossing read FStart;
     property EndCrossing: TCrossing read FEnd;
     property Length: Integer read FLength;
-    constructor Create(const ALength: Integer; const AEnd: TCrossing);
+    property Selected: TPathSelectionState read FSelected write FSelected;
+    constructor Create(const ALength: Integer; const AStart, AEnd: TCrossing);
   end;
 
   TPaths = specialize TObjectList<TPath>;
@@ -55,20 +60,51 @@ type
   TCrossing = class
   private
     FPosition: TPoint;
-    FOutPaths: TPaths;
+    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)
@@ -76,12 +112,15 @@ type
     FLines: TStringList;
     FPaths: TPaths;
     FCrossings, FWaitingForOtherInPath: TCrossings;
-    FStart: TCrossing;
+    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;
@@ -101,30 +140,163 @@ implementation
 
 { TPath }
 
-constructor TPath.Create(const ALength: Integer; const AEnd: TCrossing);
+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 }
@@ -136,17 +308,17 @@ end;
 
 procedure TLongWalk.ProcessPaths;
 var
-  stack: TPathStartQueue;
+  queue: TPathStartQueue;
   pathStart: TPathStart;
 begin
-  stack := TPathStartQueue.Create;
+  queue := TPathStartQueue.Create;
-  pathStart.Position := FStart.Position;
+  pathStart.Crossing := FCrossings.First;
-  pathStart.Crossing := FStart;
+  pathStart.Position := FCrossings.First.Position;
   pathStart.ReverseDirection := CDirectionUp;
-  stack.Enqueue(pathStart);
+  queue.Enqueue(pathStart);
-  while stack.Count > 0 do
+  while queue.Count > 0 do
-    StepPath(stack);
+    StepPath(queue);
-  stack.Free;
+  queue.Free;
 end;
 
 procedure TLongWalk.StepPath(const AStartPositionQueue: TPathStartQueue);
@@ -161,8 +333,8 @@ var
   path: TPath;
 begin
   start := AStartPositionQueue.Dequeue;
-  len := 1;
+  len := 0;
-  if start.Crossing <> FStart then
+  if start.Crossing <> FCrossings.First then
     Inc(len);
   oneMore := False;
   stop := False;
@@ -190,9 +362,11 @@ begin
   until stop;
 
   crossing := FindOrCreateCrossing(start.Position, AStartPositionQueue);
-  path := TPath.Create(len, crossing);
+  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
@@ -255,6 +429,8 @@ begin
   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;
@@ -264,17 +440,82 @@ begin
   begin
     for path in crossing.OutPaths do
       if path.EndCrossing.Distance < crossing.Distance + path.Length then
-        path.EndCrossing.Distance := crossing.Distance + path.Length;
+        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;
@@ -289,10 +530,7 @@ end;
 procedure TLongWalk.ProcessDataLine(const ALine: string);
 begin
   if FLines.Count = 0 then
-  begin
+    FCrossings.Add(TCrossing.Create(Point(ALine.IndexOf(CPathChar) + 1, 0)));
-    FStart := TCrossing.Create(Point(ALine.IndexOf(CPathChar) + 1, 0));
-    FCrossings.Add(FStart);
-  end;
   FLines.Add(ALine);
 end;
 
@@ -300,6 +538,7 @@ procedure TLongWalk.Finish;
 begin
   ProcessPaths;
   FindLongestPath;
+  FindLongestPathIgnoreSlopes;
 end;
 
 function TLongWalk.GetDataFileName: string;

tests/ULongWalkTestCases.pas

@@ -1,6 +1,6 @@
 {
   Solutions to the Advent Of Code.
-  Copyright (C) 2023  Stefan Müller
+  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
@@ -33,6 +33,7 @@ type
     function CreateSolver: ISolver; override;
   published
     procedure TestPart1;
+    procedure TestPart2;
   end;
 
 implementation
@@ -49,6 +50,11 @@ begin
   AssertEquals(94, FSolver.GetResultPart1);
 end;
 
+procedure TLongWalkExampleTestCase.TestPart2;
+begin
+  AssertEquals(154, FSolver.GetResultPart2);
+end;
+
 initialization
 
   RegisterTest('TLongWalk', TLongWalkExampleTestCase);