AdventOfCode2023/solvers/USnowverload.pas

{
  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.