Added solution for "Day 25: Snowverload", part 1

This commit is contained in:
Stefan Müller 2024-06-04 17:14:24 +02:00
parent 216839c98b
commit c5ea70ed21
6 changed files with 414 additions and 2 deletions

View File

@ -149,6 +149,10 @@
<Filename Value="UPolynomialRoots.pas"/> <Filename Value="UPolynomialRoots.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
</Unit> </Unit>
<Unit>
<Filename Value="solvers\USnowverload.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, UMirageMaintenance, UPipeMaze, UCosmicExpansion, UHotSprings, UPointOfIncidence, UHauntedWasteland, UMirageMaintenance, UPipeMaze, UCosmicExpansion, UHotSprings, UPointOfIncidence,
UParabolicReflectorDish, ULensLibrary, UFloorWillBeLava, UClumsyCrucible, ULavaductLagoon, UAplenty, UParabolicReflectorDish, ULensLibrary, UFloorWillBeLava, UClumsyCrucible, ULavaductLagoon, UAplenty,
UPulsePropagation, UStepCounter, USandSlabs, ULongWalk, UNeverTellMeTheOdds; UPulsePropagation, UStepCounter, USandSlabs, ULongWalk, UNeverTellMeTheOdds, USnowverload;
type type
@ -96,6 +96,7 @@ begin
22: engine.RunAndFree(TSandSlabs.Create); 22: engine.RunAndFree(TSandSlabs.Create);
23: engine.RunAndFree(TLongWalk.Create); 23: engine.RunAndFree(TLongWalk.Create);
24: engine.RunAndFree(TNeverTellMeTheOdds.Create); 24: engine.RunAndFree(TNeverTellMeTheOdds.Create);
25: engine.RunAndFree(TSnowverload.Create);
end; end;
engine.Free; engine.Free;

324
solvers/USnowverload.pas Normal file
View File

@ -0,0 +1,324 @@
{
Solutions to the Advent Of Code.
Copyright (C) 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 USnowverload;
{$mode ObjFPC}{$H+}
interface
uses
Classes, SysUtils, Generics.Collections, USolver;
type
TSnowComponent = class;
TSnowComponents = specialize TObjectList<TSnowComponent>;
{ TSnowComponent }
TSnowComponent = class
private
FName: string;
FMergedComponents: TSnowComponents;
public
property Name: string read FName;
procedure AddMerged(constref AMerge: TSnowComponent);
function GetMergeCount: Integer;
constructor Create(const AName: string);
destructor Destroy; override;
end;
{ TWire }
TWire = class
private
FComponent1, FComponent2, FOriginalComponent1, FOriginalComponent2: TSnowComponent;
public
property Component1: TSnowComponent read FComponent1;
property Component2: TSnowComponent read FComponent2;
procedure Reattach(constref AOldComponent, ANewComponent: TSnowComponent);
function IsLoop: Boolean;
procedure Reset;
constructor Create(constref AComponent1, AComponent2: TSnowComponent);
end;
TWires = specialize TObjectList<TWire>;
{ TNetwork }
TNetwork = class
private
FComponents: TSnowComponents;
FDisconnectableWires, FContractedWires: TWires;
public
function FindOrCreateComponent(const AName: string): TSnowComponent;
procedure AddWire(constref AWire: TWire);
function RunMinCutContractionAlgorithm: Integer;
procedure Reset;
function GetResult: Integer;
constructor Create;
destructor Destroy; override;
end;
{ TSnowverload }
TSnowverload = class(TSolver)
private
FNetwork: TNetwork;
public
constructor Create;
destructor Destroy; override;
procedure ProcessDataLine(const ALine: string); override;
procedure Finish; override;
function GetDataFileName: string; override;
function GetPuzzleName: string; override;
end;
implementation
{ TSnowComponent }
procedure TSnowComponent.AddMerged(constref AMerge: TSnowComponent);
var
i: Integer;
c: TSnowComponent;
begin
FMergedComponents.Add(AMerge);
i := AMerge.FMergedComponents.Count - 1;
while i >= 0 do
begin
c := AMerge.FMergedComponents.ExtractIndex(i);
FMergedComponents.Add(c);
Dec(i);
end;
end;
function TSnowComponent.GetMergeCount: Integer;
begin
Result := FMergedComponents.Count + 1;
end;
constructor TSnowComponent.Create(const AName: string);
begin
FName := AName;
FMergedComponents := TSnowComponents.Create;
end;
destructor TSnowComponent.Destroy;
begin
FMergedComponents.Free;
inherited Destroy;
end;
{ TWire }
procedure TWire.Reattach(constref AOldComponent, ANewComponent: TSnowComponent);
begin
if FComponent1 = AOldComponent then
FComponent1 := ANewComponent;
if FComponent2 = AOldComponent then
FComponent2 := ANewComponent;
end;
function TWire.IsLoop: Boolean;
begin
Result := FComponent1 = FComponent2;
end;
procedure TWire.Reset;
begin
FComponent1 := FOriginalComponent1;
FComponent2 := FOriginalComponent2;
end;
constructor TWire.Create(constref AComponent1, AComponent2: TSnowComponent);
begin
FComponent1 := AComponent1;
FComponent2 := AComponent2;
FOriginalComponent1 := AComponent1;
FOriginalComponent2 := AComponent2;
end;
{ TNetwork }
function TNetwork.FindOrCreateComponent(const AName: string): TSnowComponent;
var
found: Boolean;
begin
found := False;
for Result in FComponents do
if Result.Name = AName then
begin
found := True;
Break;
end;
if not found then
begin
Result := TSnowComponent.Create(AName);
FComponents.Add(Result);
end;
end;
procedure TNetwork.AddWire(constref AWire: TWire);
begin
FDisconnectableWires.Add(AWire);
end;
function TNetwork.RunMinCutContractionAlgorithm: Integer;
var
r, i: Integer;
contraction, w: TWire;
begin
while FComponents.Count > 2 do
begin
// Determines contraction.
r := Random(FDisconnectableWires.Count - 1);
contraction := FDisconnectableWires.ExtractIndex(r);
FContractedWires.Add(contraction);
// Merges contraction.Component2 into contraction.Component1.
contraction.Component1.AddMerged(FComponents.Extract(contraction.Component2));
// Fix the wires connected to contraction.Component2.
i := FDisconnectableWires.Count - 1;
while i >= 0 do
begin
FDisconnectableWires[i].Reattach(contraction.Component2, contraction.Component1);
if FDisconnectableWires[i].IsLoop then
begin
w := FDisconnectableWires.ExtractIndex(i);
FContractedWires.Add(w);
end;
Dec(i);
end;
end;
Result := FDisconnectableWires.Count;
end;
procedure TNetwork.Reset;
var
i, j: Integer;
c: TSnowComponent;
w: TWire;
begin
// Resets the components.
i := 0;
while i < FComponents.Count do
begin
j := FComponents[i].FMergedComponents.Count - 1;
while j >= 0 do
begin
c := FComponents[i].FMergedComponents.ExtractIndex(j);
FComponents.Add(c);
Dec(j);
end;
Inc(i);
end;
// Resets the wires.
for w in FDisconnectableWires do
w.Reset;
i := FContractedWires.Count - 1;
while i >= 0 do
begin
w := FContractedWires.ExtractIndex(i);
w.Reset;
FDisconnectableWires.Add(w);
Dec(i);
end;
end;
function TNetwork.GetResult: Integer;
begin
Result := 0;
if FComponents.Count = 2 then
Result := FComponents[0].GetMergeCount * FComponents[1].GetMergeCount;
end;
constructor TNetwork.Create;
begin
FComponents := TSnowComponents.Create;
FDisconnectableWires := TWires.Create;
FContractedWires := TWires.Create;
end;
destructor TNetwork.Destroy;
begin
FComponents.Free;
FDisconnectableWires.Free;
FContractedWires.Free;
inherited Destroy;
end;
{ TSnowverload }
constructor TSnowverload.Create;
begin
FNetwork := TNetwork.Create;
end;
destructor TSnowverload.Destroy;
begin
FNetwork.Free;
inherited Destroy;
end;
procedure TSnowverload.ProcessDataLine(const ALine: string);
var
split: TStringArray;
c1, c2: TSnowComponent;
i: Integer;
begin
split := ALine.Split([':', ' ']);
c1 := FNetwork.FindOrCreateComponent(split[0]);
for i := 2 to Length(split) - 1 do
begin
c2 := FNetwork.FindOrCreateComponent(split[i]);
FNetwork.AddWire(TWire.Create(c1, c2));
end;
end;
procedure TSnowverload.Finish;
var
cut, count: Integer;
begin
// Karger's algorithm with known minimum cut size.
// See https://en.wikipedia.org/wiki/Karger%27s_algorithm
count := 1;
cut := FNetwork.RunMinCutContractionAlgorithm;
while cut > 3 do
begin
Inc(count);
FNetwork.Reset;
cut := FNetwork.RunMinCutContractionAlgorithm;
end;
FPart1 := FNetwork.GetResult;
end;
function TSnowverload.GetDataFileName: string;
begin
Result := 'snowverload.txt';
end;
function TSnowverload.GetPuzzleName: string;
begin
Result := 'Day 25: Snowverload';
end;
end.

View File

@ -148,6 +148,10 @@
<Filename Value="UBigIntTestCases.pas"/> <Filename Value="UBigIntTestCases.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
</Unit> </Unit>
<Unit>
<Filename Value="USnowverloadTestCases.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
</Units> </Units>
</ProjectOptions> </ProjectOptions>
<CompilerOptions> <CompilerOptions>

View File

@ -9,7 +9,8 @@ uses
UHotSpringsTestCases, UPointOfIncidenceTestCases, UParabolicReflectorDishTestCases, ULensLibraryTestCases, UHotSpringsTestCases, UPointOfIncidenceTestCases, UParabolicReflectorDishTestCases, ULensLibraryTestCases,
UFloorWillBeLavaTestCases, UClumsyCrucibleTestCases, ULavaductLagoonTestCases, UAplentyTestCases, UFloorWillBeLavaTestCases, UClumsyCrucibleTestCases, ULavaductLagoonTestCases, UAplentyTestCases,
UPulsePropagationTestCases, UStepCounterTestCases, USandSlabsTestCases, ULongWalkTestCases, UPulsePropagationTestCases, UStepCounterTestCases, USandSlabsTestCases, ULongWalkTestCases,
UNeverTellMeTheOddsTestCases, UBigIntTestCases, UPolynomialTestCases, UPolynomialRootsTestCases; UNeverTellMeTheOddsTestCases, UBigIntTestCases, UPolynomialTestCases, UPolynomialRootsTestCases,
USnowverloadTestCases;
{$R *.res} {$R *.res}

View File

@ -0,0 +1,78 @@
{
Solutions to the Advent Of Code.
Copyright (C) 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 USnowverloadTestCases;
{$mode ObjFPC}{$H+}
interface
uses
Classes, SysUtils, fpcunit, testregistry, USolver, UBaseTestCases, USnowverload;
type
{ TSnowverloadFullDataTestCase }
TSnowverloadFullDataTestCase = class(TEngineBaseTest)
protected
function CreateSolver: ISolver; override;
published
procedure TestPart1;
end;
{ TSnowverloadExampleTestCase }
TSnowverloadExampleTestCase = class(TExampleEngineBaseTest)
protected
function CreateSolver: ISolver; override;
published
procedure TestPart1;
end;
implementation
{ TSnowverloadFullDataTestCase }
function TSnowverloadFullDataTestCase.CreateSolver: ISolver;
begin
Result := TSnowverload.Create;
end;
procedure TSnowverloadFullDataTestCase.TestPart1;
begin
AssertEquals(552695, FSolver.GetResultPart1);
end;
{ TSnowverloadExampleTestCase }
function TSnowverloadExampleTestCase.CreateSolver: ISolver;
begin
Result := TSnowverload.Create;
end;
procedure TSnowverloadExampleTestCase.TestPart1;
begin
AssertEquals(54, FSolver.GetResultPart1);
end;
initialization
RegisterTest(TSnowverloadFullDataTestCase);
RegisterTest(TSnowverloadExampleTestCase);
end.