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

solvers/USnowverload.pas

@@ -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.
+