AdventOfCode2023/solvers/USandSlabs.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 USandSlabs;

{$mode ObjFPC}{$H+}

interface

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

const
  CGroundSize = 10;

type
  TBrick = class;
  TBricks = specialize TObjectList<TBrick>;

  { TBrick }

  TBrick = class
  private
    FX1, FY1, FZ1, FX2, FY2, FZ2: Integer;
    FIsDisintegratable: Boolean;
    FSupportBricks, FTopBricks: TBricks;
  public
    property X1: Integer read FX1;
    property Y1: Integer read FY1;
    property Z1: Integer read FZ1;
    property X2: Integer read FX2;
    property Y2: Integer read FY2;
    property Z2: Integer read FZ2;
    property IsDisintegratable: Boolean read FIsDisintegratable write FIsDisintegratable;
    property SupportBricks: TBricks read FSupportBricks;
    constructor Create(const AX1, AY1, AZ1, AX2, AY2, AZ2: Integer);
    constructor Create(const ALine: string);
    destructor Destroy; override;
    procedure SetZ1(const AValue: Integer);
    procedure AddTopBrick(const ABrick: TBrick);
    function CalcChainCount: Integer;
  end;

  { TBrickComparer }

  TBrickComparer = class(TInterfacedObject, specialize IComparer<TBrick>)
  public
    function Compare(constref ALeft, ARight: TBrick): Integer; overload;
  end;

  { TGroundTile }

  TGroundTile = record
    Height: Integer;
    TopBrick: TBrick;
  end;

  TGround = array[0..CGroundSize - 1, 0.. CGroundSize - 1] of TGroundTile;

  { TSandSlabs }

  TSandSlabs = class(TSolver)
  private
    FBricks: TBricks;
    FGround: TGround;
    procedure InitGround;
    procedure StackBrick(const ABrick: TBrick);
  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

{ TBrick }

constructor TBrick.Create(const AX1, AY1, AZ1, AX2, AY2, AZ2: Integer);
begin
  FX1 := AX1;
  FY1 := AY1;
  FZ1 := AZ1;
  FX2 := AX2;
  FY2 := AY2;
  FZ2 := AZ2;
  FIsDisintegratable := True;
  FSupportBricks := TBricks.Create(False);
  FTopBricks := TBricks.Create(False);
end;

constructor TBrick.Create(const ALine: string);
var
  split: TStringArray;
begin
  split := ALine.Split([',', '~']);
  Create(StrToInt(split[0]), StrToInt(split[1]), StrToInt(split[2]), StrToInt(split[3]), StrToInt(split[4]),
    StrToInt(split[5]));
end;

destructor TBrick.Destroy;
begin
  FSupportBricks.Free;
  FTopBricks.Free;
  inherited Destroy;
end;

procedure TBrick.SetZ1(const AValue: Integer);
begin
  Inc(FZ2, AValue - FZ1);
  FZ1 := AValue;
end;

procedure TBrick.AddTopBrick(const ABrick: TBrick);
begin
  FTopBricks.Add(ABrick);
end;

function TBrick.CalcChainCount: Integer;
var
  chainBricks, uncheckedTopBricks: TBricks;
  support, chain: TBrick;
  allSupportsInChain, foundInChain: Boolean;
begin
  if FIsDisintegratable then
    Result := 0
  else begin
    chainBricks := TBricks.Create(False);
    uncheckedTopBricks := TBricks.Create(TBrickComparer.Create, False);
    uncheckedTopBricks.AddRange(FTopBricks);
    while uncheckedTopBricks.Count > 0 do
    begin
      uncheckedTopBricks.Sort;

      foundInChain := False;
      for chain in chainBricks do
        if chain = uncheckedTopBricks[0] then
          foundInChain := True;

      if not foundInChain then
      begin
        allSupportsInChain := True;
        for support in uncheckedTopBricks[0].FSupportBricks do
          if support <> Self then
          begin
            foundInChain := False;
            for chain in chainBricks do
              if chain = support then
              begin
                foundInChain := True;
                Break;
              end;
            if not foundInChain then
            begin
              allSupportsInChain := False;
              Break;
            end;
          end;
        if allSupportsInChain then
        begin
          chainBricks.Add(uncheckedTopBricks[0]);
          uncheckedTopBricks.AddRange(uncheckedTopBricks[0].FTopBricks);
        end;
      end;
      uncheckedTopBricks.Delete(0);
    end;
    uncheckedTopBricks.Free;

    Result := chainBricks.Count;
    chainBricks.Free;
  end;
end;

{ TBrickComparer }

function TBrickComparer.Compare(constref ALeft, ARight: TBrick): Integer;
begin
  Result := ALeft.FZ1 - ARight.FZ1;
end;

{ TSandSlabs }

procedure TSandSlabs.InitGround;
var
  i, j: Integer;
begin
  for i := 0 to CGroundSize - 1 do
    for j := 0 to CGroundSize - 1 do
    begin
      FGround[i, j].Height := 0;
      FGround[i, j].TopBrick := nil;
    end;
end;

procedure TSandSlabs.StackBrick(const ABrick: TBrick);
var
  i, j, max: Integer;
begin
  Inc(FPart1);

  // Checks height and supportBricks for this brick.
  max := 0;
  for i := ABrick.X1 to ABrick.X2 do
    for j := ABrick.Y1 to ABrick.Y2 do
      if max <= FGround[i, j].Height then
      begin
        if max < FGround[i, j].Height then
        begin
          max := FGround[i, j].Height;
          ABrick.SupportBricks.Clear;
        end;
        if (FGround[i, j].TopBrick <> nil) and not ABrick.SupportBricks.Contains(FGround[i, j].TopBrick) then
          ABrick.SupportBricks.Add(FGround[i, j].TopBrick);
      end;

  // Updates disintegration flag.
  if (ABrick.SupportBricks.Count = 1)
  and ABrick.SupportBricks[0].IsDisintegratable then
  begin
    ABrick.SupportBricks[0].IsDisintegratable := False;
    Dec(FPart1);
  end;
  for i := 0 to ABrick.SupportBricks.Count - 1 do
    ABrick.SupportBricks[i].AddTopBrick(ABrick);

  // Adjusts height and write brick to ground.
  ABrick.SetZ1(max + 1);
  for i := ABrick.X1 to ABrick.X2 do
    for j := ABrick.Y1 to ABrick.Y2 do
    begin
      FGround[i, j].Height := ABrick.Z2;
      FGround[i, j].TopBrick := ABrick;
    end;
end;

constructor TSandSlabs.Create;
begin
  FBricks := TBricks.Create(TBrickComparer.Create);
end;

destructor TSandSlabs.Destroy;
begin
  FBricks.Free;
  inherited Destroy;
end;

procedure TSandSlabs.ProcessDataLine(const ALine: string);
begin
  FBricks.Add(TBrick.Create(ALine));
end;

procedure TSandSlabs.Finish;
var
  brick: TBrick;
begin
  FBricks.Sort;
  InitGround;
  for brick in FBricks do
    StackBrick(brick);
  for brick in FBricks do
    Inc(FPart2, brick.CalcChainCount);
end;

function TSandSlabs.GetDataFileName: string;
begin
  Result := 'sand_slabs.txt';
end;

function TSandSlabs.GetPuzzleName: string;
begin
  Result := 'Day 22: Sand Slabs';
end;

end.