AdventOfCode2023/solvers/UAplenty.pas

{
  Solutions to the Advent Of Code.
  Copyright (C) 2023  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 UAplenty;

{$mode ObjFPC}{$H+}

interface

uses
  Classes, SysUtils, Generics.Collections, USolver, UIntervals;

type
  TMachinePartCategory = (mpcExtremelyCoolLookingCategoryIndex, mpcMusicalCategoryIndex, mpcAerodynamicCategoryIndex,
    mpcShinyCategoryIndex);

  { TMachinePart }

  TMachinePart = class
  private
    FCategories: array[TMachinePartCategory] of Integer;
    function GetCategory(const AIndex: TMachinePartCategory): Integer;
  public
    property Category[AIndex: TMachinePartCategory]: Integer read GetCategory;
    constructor Create(const ALine: string);
    function CalcRating: Integer;
  end;

  TWorkflowRuleEffect = class;

  { TMultiMachinePart }

  TMultiMachinePart = class
  private
    FCategories: array[TMachinePartCategory] of TIntervalSet;
    FNextEffect: TWorkflowRuleEffect;
    function GetCategory(const AIndex: TMachinePartCategory): TIntervalSet;
  public
    property Category[AIndex: TMachinePartCategory]: TIntervalSet read GetCategory;
    property NextEffect: TWorkflowRuleEffect read FNextEffect write FNextEffect;
    constructor CreateEmpty;
    constructor Create;
    destructor Destroy; override;
    function IsEmpty: Boolean;
    function CalcCombinations: Int64;
    function Clone(const AReplaceCategory: TMachinePartCategory; const AReplaceCategoryValue: TIntervalSet):
      TMultiMachinePart;
  end;

  TMultiMachineParts = specialize TObjectList<TMultiMachinePart>;

  TWorkflow = class;

  TWorkflowRuleEffectType = (wetAccept, wetReject, wetMove);

  { TWorkflowRuleEffect }

  TWorkflowRuleEffect = class
  private
    FEffectType: TWorkflowRuleEffectType;
    FMoveDestinationName: string;
    FMoveDestination: TWorkflow;
  public
    property EffectType: TWorkflowRuleEffectType read FEffectType;
    property MoveDestinationName: string read FMoveDestinationName;
    property MoveDestination: TWorkflow read FMoveDestination write FMoveDestination;
    constructor Create(const ALine: string);
    function IsEqualTo(const AOther: TWorkflowRuleEffect): Boolean;
  end;

  { TWorkflowRule }

  TWorkflowRule = class
  private
    FCategory: TMachinePartCategory;
    FMatches: TIntervalSet;
    FEffect: TWorkflowRuleEffect;
  public
    property Effect: TWorkflowRuleEffect read FEffect;
    constructor Create(const ALine: string);
    destructor Destroy; override;
    function IsMatch(const AMachinePart: TMachinePart): Boolean;
    function GetMatched(const AMultiMachinePart: TMultiMachinePart): TMultiMachinePart;
    function GetUnmatched(const AMultiMachinePart: TMultiMachinePart): TMultiMachinePart;
  end;

  TWorkflowRules = specialize TObjectList<TWorkflowRule>;

  { TWorkflow }

  TWorkflow = class
  private
    FName: string;
    FRules: TWorkflowRules;
    FLastEffect: TWorkflowRuleEffect;
  public
    property Name: string read FName;
    constructor Create(const ALine: string);
    destructor Destroy; override;
    function Process(const AMachinePart: TMachinePart): TWorkflowRuleEffect;
    function Process(const AMultiMachinePart: TMultiMachinePart): TMultiMachineParts;
  end;

  TWorkflows = specialize TObjectList<TWorkflow>;

  { TAplenty }

  TAplenty = class(TSolver)
  private
    FIsReadingWorkflows: Boolean;
    FWorkflows: TWorkflows;
    FStart: TWorkflow;
    procedure ProcessWorkflowLine(const ALine: string);
    procedure ProcessMachinePartLine(const ALine: string);
    function CalcAcceptedMachinePartCount: Int64;
    procedure CheckMoveDestination(const AEffect: TWorkflowRuleEffect);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Init; override;
    procedure ProcessDataLine(const ALine: string); override;
    procedure Finish; override;
    function GetDataFileName: string; override;
    function GetPuzzleName: string; override;
  end;

const
  CAccepted = 'A';
  CRejected = 'R';
  CLessThanChar = '<';
  CStartWorkflowName = 'in';
  CCategoryMinimum = 1;
  CCategoryMaximum = 4000;

implementation

{ TMachinePart }

function TMachinePart.GetCategory(const AIndex: TMachinePartCategory): Integer;
begin
  Result := FCategories[AIndex];
end;

constructor TMachinePart.Create(const ALine: string);
var
  split: TStringArray;
begin
  split := ALine.Split(',');
  FCategories[mpcExtremelyCoolLookingCategoryIndex] := StrToInt(Copy(split[0], 4, Length(split[0]) - 3));
  FCategories[mpcMusicalCategoryIndex] := StrToInt(Copy(split[1], 3, Length(split[1]) - 2));
  FCategories[mpcAerodynamicCategoryIndex] := StrToInt(Copy(split[2], 3, Length(split[2]) - 2));
  FCategories[mpcShinyCategoryIndex] := StrToInt(Copy(split[3], 3, Length(split[3]) - 3));
end;

function TMachinePart.CalcRating: Integer;
var
  cat: Integer;
begin
  Result := 0;
  for cat in FCategories do
    Inc(Result, cat);
end;

{ TMultiMachinePart }

function TMultiMachinePart.GetCategory(const AIndex: TMachinePartCategory): TIntervalSet;
begin
  Result := FCategories[AIndex];
end;

constructor TMultiMachinePart.CreateEmpty;
begin

end;

constructor TMultiMachinePart.Create;
var
  cat: TMachinePartCategory;
begin
  for cat in TMachinePartCategory do
    FCategories[cat] := TIntervalSet.Create(CCategoryMinimum, CCategoryMaximum - CCategoryMinimum + 1);
end;

destructor TMultiMachinePart.Destroy;
var
  cat: TMachinePartCategory;
begin
  for cat in TMachinePartCategory do
    FCategories[cat].Free;
  inherited Destroy;
end;

function TMultiMachinePart.IsEmpty: Boolean;
var
  cat: TIntervalSet;
begin
  Result := False;
  for cat in FCategories do
    if cat.IsEmpty then
    begin
      Result := True;
      Exit;
    end;
end;

function TMultiMachinePart.CalcCombinations: Int64;
var
  cat: TIntervalSet;
begin
  Result := 1;
  for cat in FCategories do
    Result := Result * cat.Count;
end;

function TMultiMachinePart.Clone(const AReplaceCategory: TMachinePartCategory; const AReplaceCategoryValue:
  TIntervalSet): TMultiMachinePart;
var
  cat: TMachinePartCategory;
begin
  Result := TMultiMachinePart.CreateEmpty;
  for cat in TMachinePartCategory do
    if cat = AReplaceCategory then
      Result.FCategories[cat] := AReplaceCategoryValue
    else
      Result.FCategories[cat] := FCategories[cat].Clone;
end;

{ TWorkflowRuleEffect }

constructor TWorkflowRuleEffect.Create(const ALine: string);
begin
  if ALine = CAccepted then
    FEffectType := wetAccept
  else if ALine = CRejected then
    FEffectType := wetReject
  else begin
    FEffectType := wetMove;
    FMoveDestinationName := ALine;
    FMoveDestination := nil;
  end;
end;

function TWorkflowRuleEffect.IsEqualTo(const AOther: TWorkflowRuleEffect): Boolean;
begin
  Result := (FEffectType = AOther.FEffectType) and (FMoveDestinationName = AOther.FMoveDestinationName);
end;

{ TWorkflowRule }

constructor TWorkflowRule.Create(const ALine: string);
var
  split: TStringArray;
  threshold: Cardinal;
begin
  case ALine[1] of
    'x': FCategory := mpcExtremelyCoolLookingCategoryIndex;
    'm': FCategory := mpcMusicalCategoryIndex;
    'a': FCategory := mpcAerodynamicCategoryIndex;
    's': FCategory := mpcShinyCategoryIndex;
  end;

  split := ALine.Split(':');
  threshold := StrToInt(Copy(split[0], 3, Length(split[0]) - 2));
  if Aline[2] = CLessThanChar then
    FMatches := TIntervalSet.Create(CCategoryMinimum, threshold - 1)
  else
    FMatches := TIntervalSet.Create(threshold + 1, CCategoryMaximum - threshold);

  FEffect := TWorkflowRuleEffect.Create(split[1]);
end;

destructor TWorkflowRule.Destroy;
begin
  FEffect.Free;
  FMatches.Free;
  inherited Destroy;
end;

function TWorkflowRule.IsMatch(const AMachinePart: TMachinePart): Boolean;
begin
  Result := FMatches.Contains(AMachinePart.Category[FCategory]);
end;

function TWorkflowRule.GetMatched(const AMultiMachinePart: TMultiMachinePart): TMultiMachinePart;
var
  new: TIntervalSet;
begin
  new := AMultiMachinePart.Category[FCategory].Intersect(FMatches);
  Result := AMultiMachinePart.Clone(FCategory, new);
  Result.NextEffect := FEffect;
end;

function TWorkflowRule.GetUnmatched(const AMultiMachinePart: TMultiMachinePart): TMultiMachinePart;
var
  new: TIntervalSet;
begin
  new := AMultiMachinePart.Category[FCategory].Difference(FMatches);
  Result := AMultiMachinePart.Clone(FCategory, new);
end;

{ TWorkflow }

constructor TWorkflow.Create(const ALine: string);
var
  split: TStringArray;
  i: Integer;
begin
  split := ALine.Split([',', '{', '}']);
  FName := split[0];
  FRules := TWorkflowRules.Create;
  for i := 1 to Length(split) - 3 do
    FRules.Add(TWorkflowRule.Create(split[i]));
  FLastEffect := TWorkflowRuleEffect.Create(split[Length(split) - 2]);

  i := FRules.Count;
  while (i > 0) and (FRules[i - 1].Effect.IsEqualTo(FLastEffect)) do
    Dec(i);
  if i < FRules.Count then
    FRules.DeleteRange(i, FRules.Count - i);
end;

destructor TWorkflow.Destroy;
begin
  FRules.Free;
  FLastEffect.Free;
  inherited Destroy;
end;

function TWorkflow.Process(const AMachinePart: TMachinePart): TWorkflowRuleEffect;
var
  rule: TWorkflowRule;
begin
  for rule in FRules do
    if rule.IsMatch(AMachinePart) then
    begin
      Result := rule.Effect;
      Exit;
    end;
  Result := FLastEffect;
end;

function TWorkflow.Process(const AMultiMachinePart: TMultiMachinePart): TMultiMachineParts;
var
  rule: TWorkflowRule;
  current, new: TMultiMachinePart;
begin
  Result := TMultiMachineParts.Create(False);
  current := AMultiMachinePart;
  for rule in FRules do
  begin
    if rule.Effect.EffectType <> wetReject then
    begin
      new := rule.GetMatched(current);
      if new.IsEmpty then
        new.Free
      else
        Result.Add(new);
    end;
    new := rule.GetUnmatched(current);
    current.Free;
    if new.IsEmpty then
    begin
      new.Free;
      Exit;
    end
    else
      current := new;
  end;
  if FLastEffect.EffectType <> wetReject then
  begin
    current.NextEffect := FLastEffect;
    Result.Add(current);
  end
  else
    current.Free;
end;

{ TAplenty }

procedure TAplenty.ProcessWorkflowLine(const ALine: string);
var
  workflow: TWorkflow;
begin
  workflow := TWorkflow.Create(ALine);
  FWorkflows.Add(workflow);
  if workflow.Name = CStartWorkflowName then
    FStart := workflow;
end;

procedure TAplenty.ProcessMachinePartLine(const ALine: string);
var
  part: TMachinePart;
  workflow: TWorkflow;
  effect: TWorkflowRuleEffect;
begin
  part := TMachinePart.Create(ALine);
  workflow := FStart;
  repeat
    effect := workflow.Process(part);
    if effect.EffectType = wetMove then
    begin
      CheckMoveDestination(effect);
      workflow := effect.MoveDestination;
    end;
  until effect.EffectType <> wetMove;

  if effect.EffectType = wetAccept then
    Inc(FPart1, part.CalcRating);
  part.Free;
end;

function TAplenty.CalcAcceptedMachinePartCount: Int64;
var
  part: TMultiMachinePart;
  parts: TMultiMachineParts;
  stack: specialize TStack<TMultiMachinePart>;
  workflow: TWorkflow;
begin
  Result := 0;
  stack := specialize TStack<TMultiMachinePart>.Create;
  stack.Push(TMultiMachinePart.Create);

  repeat
    part := stack.Pop;
    if part.NextEffect = nil then
      workflow := FStart
    else begin
      CheckMoveDestination(part.NextEffect);
      workflow := part.NextEffect.MoveDestination;
    end;
    parts := workflow.Process(part);
    for part in parts do
      if part.NextEffect.EffectType = wetAccept then
      begin
        Inc(Result, part.CalcCombinations);
        part.Free;
      end
      else
        stack.Push(part);
    parts.Free;
  until stack.Count = 0;

  stack.Free;
end;

procedure TAplenty.CheckMoveDestination(const AEffect: TWorkflowRuleEffect);
var
  destination: TWorkflow;
begin
  if AEffect.MoveDestination = nil then
    for destination in FWorkflows do
      if destination.Name = AEffect.MoveDestinationName then
      begin
        AEffect.MoveDestination := destination;
        Break;
      end;
end;

constructor TAplenty.Create;
begin
  FWorkflows := TWorkflows.Create;
end;

destructor TAplenty.Destroy;
begin
  FWorkflows.Free;
  inherited Destroy;
end;

procedure TAplenty.Init;
begin
  inherited Init;
  FIsReadingWorkflows := True;
end;

procedure TAplenty.ProcessDataLine(const ALine: string);
begin
  if ALine = '' then
    FIsReadingWorkflows := False
  else if FIsReadingWorkflows then
    ProcessWorkflowLine(ALine)
  else
    ProcessMachinePartLine(ALine);
end;

procedure TAplenty.Finish;
begin
  FPart2 := CalcAcceptedMachinePartCount;
end;

function TAplenty.GetDataFileName: string;
begin
  Result := 'aplenty.txt';
end;

function TAplenty.GetPuzzleName: string;
begin
  Result := 'Day 19: Aplenty';
end;

end.