From 3f83f888f30cac27ba20a7c06792ed1365b7a14d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Stefan=20M=C3=BCller?= <stefan.mueller@aksdb.de>
Date: Wed, 5 Jun 2024 13:40:31 +0200
Subject: [PATCH] Updated solution for day 25, significantly speeding up the
 algorithm

---
 solvers/USnowverload.pas | 167 ++++++++++++++++++---------------------
 1 file changed, 75 insertions(+), 92 deletions(-)

diff --git a/solvers/USnowverload.pas b/solvers/USnowverload.pas
index f478564..6407018 100644
--- a/solvers/USnowverload.pas
+++ b/solvers/USnowverload.pas
@@ -34,10 +34,13 @@ type
   private
     FName: string;
     FMergedComponents: TSnowComponents;
+    FMergeParent: TSnowComponent;
   public
     property Name: string read FName;
     procedure AddMerged(constref AMerge: TSnowComponent);
+    function GetRootComponent: TSnowComponent;
     function GetMergeCount: Integer;
+    procedure Reset;
     constructor Create(const AName: string);
     destructor Destroy; override;
   end;
@@ -46,13 +49,13 @@ type
 
   TWire = class
   private
-    FComponent1, FComponent2, FOriginalComponent1, FOriginalComponent2: TSnowComponent;
+    FComponent1, FComponent2: TSnowComponent;
+    function GetComponent1: TSnowComponent;
+    function GetComponent2: TSnowComponent;
   public
-    property Component1: TSnowComponent read FComponent1;
-    property Component2: TSnowComponent read FComponent2;
-    procedure Reattach(constref AOldComponent, ANewComponent: TSnowComponent);
+    property Component1: TSnowComponent read GetComponent1;
+    property Component2: TSnowComponent read GetComponent2;
     function IsLoop: Boolean;
-    procedure Reset;
     constructor Create(constref AComponent1, AComponent2: TSnowComponent);
   end;
 
@@ -63,10 +66,10 @@ type
   TNetwork = class
   private
     FComponents: TSnowComponents;
-    FDisconnectableWires, FContractedWires: TWires;
+    FWires, FContracted: TWires;
   public
-    function FindOrCreateComponent(const AName: string): TSnowComponent;
-    procedure AddWire(constref AWire: TWire);
+    function FindOrAddComponent(const AName: string): TSnowComponent;
+    procedure AddWire(constref AComponent1, AComponent2: TSnowComponent);
     function RunMinCutContractionAlgorithm: Integer;
     procedure Reset;
     function GetResult: Integer;
@@ -93,29 +96,38 @@ 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;
+  AMerge.FMergeParent := Self;
+end;
+
+function TSnowComponent.GetRootComponent: TSnowComponent;
+begin
+  Result := Self;
+  while Result.FMergeParent <> nil do
+    Result := Result.FMergeParent;
 end;
 
 function TSnowComponent.GetMergeCount: Integer;
+var
+  c: TSnowComponent;
 begin
-  Result := FMergedComponents.Count + 1;
+  Result := 1;
+  for c in FMergedComponents do
+    Inc(Result, c.GetMergeCount);
+end;
+
+procedure TSnowComponent.Reset;
+begin
+  FMergedComponents.Clear;
+  FMergeParent := nil;
 end;
 
 constructor TSnowComponent.Create(const AName: string);
 begin
   FName := AName;
-  FMergedComponents := TSnowComponents.Create;
+  FMergedComponents := TSnowComponents.Create(False);
+  FMergeParent := nil;
 end;
 
 destructor TSnowComponent.Destroy;
@@ -126,36 +138,30 @@ end;
 
 { TWire }
 
-procedure TWire.Reattach(constref AOldComponent, ANewComponent: TSnowComponent);
+function TWire.GetComponent1: TSnowComponent;
 begin
-  if FComponent1 = AOldComponent then
-    FComponent1 := ANewComponent;
-  if FComponent2 = AOldComponent then
-    FComponent2 := ANewComponent;
+  Result := FComponent1.GetRootComponent;
+end;
+
+function TWire.GetComponent2: TSnowComponent;
+begin
+  Result := FComponent2.GetRootComponent;
 end;
 
 function TWire.IsLoop: Boolean;
 begin
-  Result := FComponent1 = FComponent2;
-end;
-
-procedure TWire.Reset;
-begin
-  FComponent1 := FOriginalComponent1;
-  FComponent2 := FOriginalComponent2;
+  Result := Component1 = Component2;
 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;
+function TNetwork.FindOrAddComponent(const AName: string): TSnowComponent;
 var
   found: Boolean;
 begin
@@ -173,95 +179,73 @@ begin
   end;
 end;
 
-procedure TNetwork.AddWire(constref AWire: TWire);
+procedure TNetwork.AddWire(constref AComponent1, AComponent2: TSnowComponent);
 begin
-  FDisconnectableWires.Add(AWire);
+  FWires.Add(TWire.Create(AComponent1, AComponent2));
 end;
 
 function TNetwork.RunMinCutContractionAlgorithm: Integer;
 var
-  r, i: Integer;
-  contraction, w: TWire;
+  r, count: Integer;
+  w: TWire;
 begin
-  while FComponents.Count > 2 do
+  count := FComponents.Count;
+  while count > 2 do
   begin
-    // Determines contraction.
-    r := Random(FDisconnectableWires.Count - 1);
-    contraction := FDisconnectableWires.ExtractIndex(r);
-    FContractedWires.Add(contraction);
+    // Determines contraction wire.
+    r := Random(FWires.Count - 1);
+    w := FWires.ExtractIndex(r);
+    FContracted.Add(w);
 
-    // 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
+    // Merges c2 into c1.
+    if not w.IsLoop then
     begin
-      FDisconnectableWires[i].Reattach(contraction.Component2, contraction.Component1);
-      if FDisconnectableWires[i].IsLoop then
-      begin
-        w := FDisconnectableWires.ExtractIndex(i);
-        FContractedWires.Add(w);
-      end;
-      Dec(i);
+      w.Component1.AddMerged(w.Component2);
+      Dec(count);
     end;
   end;
 
-  Result := FDisconnectableWires.Count;
+  Result := 0;
+  for w in FWires do
+    if not w.IsLoop then
+      Inc(Result);
 end;
 
 procedure TNetwork.Reset;
 var
-  i, j: Integer;
   c: TSnowComponent;
+  i: Integer;
   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;
+  for c in FComponents do
+    c.Reset;
 
-  // Resets the wires.
-  for w in FDisconnectableWires do
-    w.Reset;
-  i := FContractedWires.Count - 1;
+  i := FContracted.Count - 1;
   while i >= 0 do
   begin
-    w := FContractedWires.ExtractIndex(i);
-    w.Reset;
-    FDisconnectableWires.Add(w);
+    w := FContracted.ExtractIndex(i);
+    FWires.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;
+  Result := FComponents[0].GetRootComponent.GetMergeCount;
+  Result := Result * (FComponents.Count - Result);
 end;
 
 constructor TNetwork.Create;
 begin
   FComponents := TSnowComponents.Create;
-  FDisconnectableWires := TWires.Create;
-  FContractedWires := TWires.Create;
+  FWires := TWires.Create;
+  FContracted := TWires.Create;
 end;
 
 destructor TNetwork.Destroy;
 begin
   FComponents.Free;
-  FDisconnectableWires.Free;
-  FContractedWires.Free;
+  FWires.Free;
   inherited Destroy;
 end;
 
@@ -285,25 +269,24 @@ var
   i: Integer;
 begin
   split := ALine.Split([':', ' ']);
-  c1 := FNetwork.FindOrCreateComponent(split[0]);
+  c1 := FNetwork.FindOrAddComponent(split[0]);
   for i := 2 to Length(split) - 1 do
   begin
-    c2 := FNetwork.FindOrCreateComponent(split[i]);
-    FNetwork.AddWire(TWire.Create(c1, c2));
+    c2 := FNetwork.FindOrAddComponent(split[i]);
+    FNetwork.AddWire(c1, c2);
   end;
 end;
 
 procedure TSnowverload.Finish;
 var
-  cut, count: Integer;
+  cut: Integer;
 begin
   // Karger's algorithm with known minimum cut size.
   // See https://en.wikipedia.org/wiki/Karger%27s_algorithm
-  count := 1;
+  Randomize;
   cut := FNetwork.RunMinCutContractionAlgorithm;
   while cut > 3 do
   begin
-    Inc(count);
     FNetwork.Reset;
     cut := FNetwork.RunMinCutContractionAlgorithm;
   end;