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

This commit is contained in:
Stefan Müller 2023-12-25 00:44:13 +01:00 committed by Stefan Müller
parent c3ecaf59fa
commit 5495b32692
6 changed files with 410 additions and 2 deletions

View File

@ -129,6 +129,10 @@
<Filename Value="solvers\USandSlabs.pas"/> <Filename Value="solvers\USandSlabs.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
</Unit> </Unit>
<Unit>
<Filename Value="solvers\ULongWalk.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
</Units> </Units>
</ProjectOptions> </ProjectOptions>
<CompilerOptions> <CompilerOptions>

View File

@ -27,7 +27,7 @@ uses
UTrebuchet, UCubeConundrum, UGearRatios, UScratchcards, UGiveSeedFertilizer, UWaitForIt, UCamelCards, UTrebuchet, UCubeConundrum, UGearRatios, UScratchcards, UGiveSeedFertilizer, UWaitForIt, UCamelCards,
UHauntedWasteland, UNumberTheory, UMirageMaintenance, UPipeMaze, UCosmicExpansion, UHotSprings, UPointOfIncidence, UHauntedWasteland, UNumberTheory, UMirageMaintenance, UPipeMaze, UCosmicExpansion, UHotSprings, UPointOfIncidence,
UParabolicReflectorDish, ULensLibrary, UFloorWillBeLava, UClumsyCrucible, ULavaductLagoon, UAplenty, UParabolicReflectorDish, ULensLibrary, UFloorWillBeLava, UClumsyCrucible, ULavaductLagoon, UAplenty,
UPulsePropagation, UStepCounter, USandSlabs; UPulsePropagation, UStepCounter, USandSlabs, ULongWalk;
type type
@ -91,6 +91,7 @@ begin
20: engine.RunAndFree(TPulsePropagation.Create); 20: engine.RunAndFree(TPulsePropagation.Create);
21: engine.RunAndFree(TStepCounter.Create); 21: engine.RunAndFree(TStepCounter.Create);
22: engine.RunAndFree(TSandSlabs.Create); 22: engine.RunAndFree(TSandSlabs.Create);
23: engine.RunAndFree(TLongWalk.Create);
end; end;
engine.Free; engine.Free;

321
solvers/ULongWalk.pas Normal file
View File

@ -0,0 +1,321 @@
{
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 := 'long_walk.txt';
end;
function TLongWalk.GetPuzzleName: string;
begin
Result := 'Day 23: A Long Walk';
end;
end.

View File

@ -132,6 +132,10 @@
<Filename Value="USandSlabsTestCases.pas"/> <Filename Value="USandSlabsTestCases.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
</Unit> </Unit>
<Unit>
<Filename Value="ULongWalkTestCases.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
</Units> </Units>
</ProjectOptions> </ProjectOptions>
<CompilerOptions> <CompilerOptions>

View File

@ -8,7 +8,7 @@ uses
UHauntedWastelandTestCases, UMirageMaintenanceTestCases, UPipeMazeTestCases, UCosmicExpansionTestCases, UHauntedWastelandTestCases, UMirageMaintenanceTestCases, UPipeMazeTestCases, UCosmicExpansionTestCases,
UHotSpringsTestCases, UPointOfIncidenceTestCases, UParabolicReflectorDishTestCases, ULensLibraryTestCases, UHotSpringsTestCases, UPointOfIncidenceTestCases, UParabolicReflectorDishTestCases, ULensLibraryTestCases,
UFloorWillBeLavaTestCases, UClumsyCrucibleTestCases, ULavaductLagoonTestCases, UAplentyTestCases, UFloorWillBeLavaTestCases, UClumsyCrucibleTestCases, ULavaductLagoonTestCases, UAplentyTestCases,
UPulsePropagationTestCases, UStepCounterTestCases, USandSlabsTestCases; UPulsePropagationTestCases, UStepCounterTestCases, USandSlabsTestCases, ULongWalkTestCases;
{$R *.res} {$R *.res}

View File

@ -0,0 +1,78 @@
{
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 ULongWalkTestCases;
{$mode ObjFPC}{$H+}
interface
uses
Classes, SysUtils, fpcunit, testregistry, USolver, UBaseTestCases, ULongWalk;
type
{ TLongWalkFullDataTestCase }
TLongWalkFullDataTestCase = class(TEngineBaseTest)
protected
function CreateSolver: ISolver; override;
published
procedure TestPart1;
end;
{ TLongWalkExampleTestCase }
TLongWalkExampleTestCase = class(TExampleEngineBaseTest)
protected
function CreateSolver: ISolver; override;
published
procedure TestPart1;
end;
implementation
{ TLongWalkFullDataTestCase }
function TLongWalkFullDataTestCase.CreateSolver: ISolver;
begin
Result := TLongWalk.Create;
end;
procedure TLongWalkFullDataTestCase.TestPart1;
begin
AssertEquals(2218, FSolver.GetResultPart1);
end;
{ TLongWalkExampleTestCase }
function TLongWalkExampleTestCase.CreateSolver: ISolver;
begin
Result := TLongWalk.Create;
end;
procedure TLongWalkExampleTestCase.TestPart1;
begin
AssertEquals(94, FSolver.GetResultPart1);
end;
initialization
RegisterTest(TLongWalkFullDataTestCase);
RegisterTest(TLongWalkExampleTestCase);
end.