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;
    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;

  { TWire }

  TWire = class
  private
    FComponent1, FComponent2: TSnowComponent;
    function GetComponent1: TSnowComponent;
    function GetComponent2: TSnowComponent;
  public
    property Component1: TSnowComponent read GetComponent1;
    property Component2: TSnowComponent read GetComponent2;
    function IsLoop: Boolean;
    constructor Create(constref AComponent1, AComponent2: TSnowComponent);
  end;

  TWires = specialize TObjectList<TWire>;

  { TNetwork }

  TNetwork = class
  private
    FComponents: TSnowComponents;
    FWires, FContracted: TWires;
  public
    function FindOrAddComponent(const AName: string): TSnowComponent;
    procedure AddWire(constref AComponent1, AComponent2: TSnowComponent);
    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);
begin
  FMergedComponents.Add(AMerge);
  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 := 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(False);
  FMergeParent := nil;
end;

destructor TSnowComponent.Destroy;
begin
  FMergedComponents.Free;
  inherited Destroy;
end;

{ TWire }

function TWire.GetComponent1: TSnowComponent;
begin
  Result := FComponent1.GetRootComponent;
end;

function TWire.GetComponent2: TSnowComponent;
begin
  Result := FComponent2.GetRootComponent;
end;

function TWire.IsLoop: Boolean;
begin
  Result := Component1 = Component2;
end;

constructor TWire.Create(constref AComponent1, AComponent2: TSnowComponent);
begin
  FComponent1 := AComponent1;
  FComponent2 := AComponent2;
end;

{ TNetwork }

function TNetwork.FindOrAddComponent(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 AComponent1, AComponent2: TSnowComponent);
begin
  FWires.Add(TWire.Create(AComponent1, AComponent2));
end;

function TNetwork.RunMinCutContractionAlgorithm: Integer;
var
  r, count: Integer;
  w: TWire;
begin
  count := FComponents.Count;
  while count > 2 do
  begin
    // Determines contraction wire.
    r := Random(FWires.Count - 1);
    w := FWires.ExtractIndex(r);
    FContracted.Add(w);

    // Merges c2 into c1.
    if not w.IsLoop then
    begin
      w.Component1.AddMerged(w.Component2);
      Dec(count);
    end;
  end;

  Result := 0;
  for w in FWires do
    if not w.IsLoop then
      Inc(Result);
end;

procedure TNetwork.Reset;
var
  c: TSnowComponent;
  i: Integer;
  w: TWire;
begin
  for c in FComponents do
    c.Reset;

  i := FContracted.Count - 1;
  while i >= 0 do
  begin
    w := FContracted.ExtractIndex(i);
    FWires.Add(w);
    Dec(i);
  end;
end;

function TNetwork.GetResult: Integer;
begin
  Result := FComponents[0].GetRootComponent.GetMergeCount;
  Result := Result * (FComponents.Count - Result);
end;

constructor TNetwork.Create;
begin
  FComponents := TSnowComponents.Create;
  FWires := TWires.Create;
  FContracted := TWires.Create;
end;

destructor TNetwork.Destroy;
begin
  FComponents.Free;
  FWires.Free;
  FContracted.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.FindOrAddComponent(split[0]);
  for i := 2 to Length(split) - 1 do
  begin
    c2 := FNetwork.FindOrAddComponent(split[i]);
    FNetwork.AddWire(c1, c2);
  end;
end;

procedure TSnowverload.Finish;
var
  cut: Integer;
begin
  // Karger's algorithm with known minimum cut size.
  // See https://en.wikipedia.org/wiki/Karger%27s_algorithm
  Randomize;
  cut := FNetwork.RunMinCutContractionAlgorithm;
  while cut > 3 do
  begin
    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.