Updated day 12 WIP solver

UCommon.pas

@@ -22,7 +22,7 @@ unit UCommon;
 interface
 
 uses
-  Classes, SysUtils;
+  Classes, SysUtils, Generics.Collections;
 
 type
   PPoint = ^TPoint;
@@ -39,6 +39,9 @@ const
   CDirectionLeftUp: TPoint = (X: -1; Y: -1);
   CPCardinalDirections: array[0..3] of PPoint = (@CDirectionRight, @CDirectionDown, @CDirectionLeft, @CDirectionUp);
 
+type
+  TIntegerList = specialize TList<Integer>;
+
 implementation
 
 end.

solvers/UHotSprings.pas

@@ -1,6 +1,6 @@
 {
   Solutions to the Advent Of Code.
-  Copyright (C) 2023  Stefan Müller
+  Copyright (C) 2023-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
@@ -22,31 +22,97 @@ unit UHotSprings;
 interface
 
 uses
-  Classes, SysUtils, Generics.Collections, USolver;
+  Classes, SysUtils, Math, Generics.Collections, USolver, UCommon;
 
 const
   COperationalChar = '.';
   CDamagedChar = '#';
   CWildcardChar = '?';
-  COperationalPatternChars = [COperationalChar, CWildcardChar];
+  //COperationalPatternChars = [COperationalChar, CWildcardChar];
-  CDamagedPatternChars = [CDamagedChar, CWildcardChar];
+  //CDamagedPatternChars = [CDamagedChar, CWildcardChar];
-  CPart2Repetition = 4;
+  CPart2Repetition = 2;
 
 type
 
+  //{ TBlockAssignment }
+  //
+  //TBlockAssignment = class
+  //private
+  //  FPrevious: TBlockAssignment;
+  //  FPattern: string;
+  //  FValidation: TIntegerList;
+  //public
+  //  property Validation: TIntegerList read FValidation;
+  //  constructor Create(const APattern: string; constref APrevious: TBlockAssignment = nil);
+  //  destructor Destroy; override;
+  //  procedure WriteDebug;
+  //end;
+  //
+  //TBlockAssignments = specialize TObjectList<TBlockAssignment>;
+
+  TValidationLengths = array of array of Integer;
+  //TPatternLengths = array of Integer;
+  TIntegerArray = array of Integer;
+
+  { TDamage }
+
+  TDamage = record
+    Start, Length, CharsRemaining: Byte;
+  end;
+
+  TDamages = specialize TList<TDamage>;
+  TDamagesBlocks = specialize TObjectList<TDamages>;
+
+  { TConditionRecord }
+
+  TConditionRecord = class
+  private
+    FValidation: TIntegerList;
+    // List of non-empty, maximum-length parts of the pattern without operational springs.
+    FBlockPatterns: TStringList;
+    // Array 'a' of accumulated validation block lengths. 'a[i, j]' denotes the combined length of consecutive
+    // validation numbers from 'FValidation[i]' to 'FValidation[j - 1]' with a single space in between each pair of
+    // them.
+    FValidationLengths: TValidationLengths;
+
+    //FPatternLengths: TPatternLengths;
+
+    // Array 'a' of minimum indices 'a[i]', such that all remaining validation numbers starting at index 'a[i] - 1'
+    // cannot fit into the remaining block patterns starting at 'FBlockPatterns[i]'.
+    FMinIndices: TIntegerArray;
+    // List 'a' of lists of damages in a block pattern. Each list of damages 'a[i]' contains exactly one entry for each
+    // block of consecutive damages characters in the i-th block pattern.
+    // For example, if the pattern is '?#.??##?#?..??', then 'FDamagesBlocks' would have 3 entries, which are lists of
+    // 1, 2, and 0 damages, respectively.
+    FDamagesBlocks: TDamagesBlocks;
+    procedure InitValidationLengths;
+
+    //// Returns an array 'a' of accumulated pattern block lengths. 'a[i]' denotes the combined length of consecutive
+    //// pattern blocks starting with 'FBlockPatterns[i]' and all following with a single space in between each pair of
+    //// them.
+    //function CalcPatternLengths: TPatternLengths;
+
+    procedure InitMinIndices;
+    function CalcCombinations(constref AIndices: TIntegerArray): Int64;
+    function CalcCombinationsSingleBlock(const APattern: string; constref ADamages: TDamages; const AStartIndex,
+      AStopIndex: Integer): Int64;
+    function CalcCombinationsSingleBlockSingleValidation(const APattern: string; constref ADamages: TDamages;
+      const AIndex: Integer): Int64;
+    function ParseDamages(const APattern: string): TDamages;
+  public
+    property BlockPatterns: TStringList read FBlockPatterns;
+    property Validation: TIntegerList read FValidation;
+    constructor Create;
+    destructor Destroy; override;
+    // Adds all non-empty, maximum-length parts of the pattern without operational springs.
+    procedure AddBlockPatterns(const APattern: string);
+    function GenerateBlockAssignments: Int64;
+  end;
+
   { THotSprings }
 
   THotSprings = class(TSolver)
-  private
-    FValidation: specialize TList<Integer>;
-    FSpringPattern: string;
-    procedure ExtendArrangement(const AArrangement: string; const ARemainingFreeOperationalCount, ACurrentValidationIndex:
-      Integer; var AArrangementCount: Int64);
-    function TryAppendOperationalChar(var AArrangement: string): Boolean;
-    function TryAppendValidationBlock(var AArrangement: string; const ALength: Integer): Boolean;
   public
-    constructor Create;
-    destructor Destroy; override;
     procedure ProcessDataLine(const ALine: string); override;
     procedure Finish; override;
     function GetDataFileName: string; override;
@@ -55,111 +121,379 @@ type
 
 implementation
 
-{ THotSprings }
+//{ TBlockAssignment }
+//
+//constructor TBlockAssignment.Create(const APattern: string; constref APrevious: TBlockAssignment);
+//begin
+//  FPrevious := APrevious;
+//  FPattern := APattern;
+//  FValidation := TIntegerList.Create;
+//end;
+//
+//destructor TBlockAssignment.Destroy;
+//begin
+//  FValidation.Free;
+//  inherited Destroy;
+//end;
+//
+//procedure TBlockAssignment.WriteDebug;
+//var
+//  i: Integer;
+//begin
+//  Write(FPattern, ' ', IntToStr(FValidation[0]));
+//  for i := 1 to FValidation.Count - 1 do
+//    Write(',', IntToStr(FValidation[i]));
+//  Write(' |');
+//end;
 
-procedure THotSprings.ExtendArrangement(const AArrangement: string; const ARemainingFreeOperationalCount,
+{ TConditionRecord }
-  ACurrentValidationIndex: Integer; var AArrangementCount: Int64);
+
+procedure TConditionRecord.InitValidationLengths;
 var
-  match: Boolean;
+  i, j: Integer;
-  temp: string;
 begin
-  if Length(AArrangement) = Length(FSpringPattern) then
+  SetLength(FValidationLengths, FValidation.Count + 1, FValidation.Count + 1);
-    Inc(AArrangementCount)
+  for i := 0 to FValidation.Count do
-  else begin
-    temp := AArrangement;
-    // Tries to append a dot (operational) to the current arrangement.
-    if (ARemainingFreeOperationalCount > 0) and TryAppendOperationalChar(temp) then
   begin
-      ExtendArrangement(temp, ARemainingFreeOperationalCount - 1, ACurrentValidationIndex, AArrangementCount);
+    FValidationLengths[i, i] := 0;
-    end;
+    for j := i + 1 to FValidation.Count do
-
+      if FValidationLengths[i, j - 1] <> 0 then
-    // Tries to append the current validation block (damaged) to the current arrangement.
+        FValidationLengths[i, j] := FValidationLengths[i, j - 1] + FValidation[j - 1] + 1
-    if ACurrentValidationIndex < FValidation.Count then
-    begin
-      temp := AArrangement;
-      match := TryAppendValidationBlock(temp, FValidation[ACurrentValidationIndex]);
-
-      // ... and the mandatory dot after the block, if it is not the last block.
-      if match
-      and (ACurrentValidationIndex < FValidation.Count - 1)
-      and not TryAppendOperationalChar(temp) then
-        match := False;
-
-      if match then
-        ExtendArrangement(temp, ARemainingFreeOperationalCount, ACurrentValidationIndex + 1, AArrangementCount);
-    end;
-  end;
-end;
-
-function THotSprings.TryAppendOperationalChar(var AArrangement: string): Boolean;
-begin
-  if FSpringPattern[Length(AArrangement) + 1] in COperationalPatternChars then
-  begin
-    AArrangement := AArrangement + COperationalChar;
-    Result := True;
-  end
       else
-    Result := False;
+        FValidationLengths[i, j] := FValidationLengths[i, j - 1] + FValidation[j - 1]
+  end;
 end;
 
-function THotSprings.TryAppendValidationBlock(var AArrangement: string; const ALength: Integer): Boolean;
+//function TConditionRecord.CalcPatternLengths: TPatternLengths;
+//var
+//  i: Integer;
+//begin
+//  SetLength(Result, FBlockPatterns.Count + 1);
+//  Result[FBlockPatterns.Count] := 0;
+//  Result[FBlockPatterns.Count - 1] := Length(FBlockPatterns[FBlockPatterns.Count - 1]);
+//  for i := FBlockPatterns.Count - 2 downto 0 do
+//    Result[i] := Result[i + 1] + 1 + Length(FBlockPatterns[i]);
+//end;
+
+procedure TConditionRecord.InitMinIndices;
 var
-  i, len: Integer;
+  i, j, patternsLength: Integer;
 begin
-  Result := True;
+  SetLength(FMinIndices, FBlockPatterns.Count - 1);
-  len := Length(AArrangement);
+  patternsLength := Length(FBlockPatterns[FBlockPatterns.Count - 1]);
-  for i := 1 to ALength do
+  j := FValidation.Count;
+  for i := FBlockPatterns.Count - 2 downto 0 do
   begin
-    if FSpringPattern[len + i] in CDamagedPatternChars then
+    while (j >= 0) and (FValidationLengths[j, FValidation.Count] <= patternsLength) do
-      AArrangement := AArrangement + CDamagedChar
+      Dec(j);
+    FMinIndices[i] := j + 1;
+    patternsLength := patternsLength + 1 + Length(FBlockPatterns[i]);
+  end;
+end;
+
+function TConditionRecord.CalcCombinations(constref AIndices: TIntegerArray): Int64;
+var
+  i: Integer;
+begin
+  for i in AIndices do
+    Write(i, ' ');
+  WriteLn;
+
+  Result := 1;
+  i := 0;
+  while (Result > 0) and (i < FBlockPatterns.Count) do
+  begin
+    Result := Result * CalcCombinationsSingleBlock(FBlockPatterns[i], FDamagesBlocks[i], AIndices[i], AIndices[i + 1] - 1);
+    Inc(i);
+  end;
+end;
+
+function TConditionRecord.CalcCombinationsSingleBlock(const APattern: string; constref ADamages: TDamages;
+  const AStartIndex, AStopIndex: Integer): Int64;
+var
+  i, j, k: Integer;
+  indices: TIntegerArray;
+begin
+  Write('    ', APattern, ' ');
+  for i := AStartIndex to AStopIndex do
+    Write(FValidation[i], ' ');
+  WriteLn;
+
+  // No validation number assigned to this block.
+  if AStartIndex > AStopIndex then
+  begin
+    if ADamages.Count = 0 then
+      Result := 1
+    else
+      Result := 0;
+  end
+  // One validation number assigned to this block.
+  else if AStartIndex = AStopIndex then
+    Result := CalcCombinationsSingleBlockSingleValidation(APattern, ADamages, AStartIndex)
+  // Multiple validation numbers assigned to this block.
   else begin
-      Result := False;
+    SetLength(indices, ADamages.Count);
+
+    Write('        min before: ');
+    for i := AStartIndex to AStopIndex do
+      Write(FValidationLengths[AStartIndex, i + 1] - FValidation[i], ' ');
+    WriteLn;
+    Write('        min after: ');
+    for i := AStartIndex to AStopIndex do
+      Write(FValidationLengths[i, AStopIndex + 1] - FValidation[i], ' ');
+    WriteLn;
+
+    ///////////////////////////////
+    for i := 0 to ADamages.Count - 1 do
+    begin
+      WriteLn('        damage: start ',ADamages[i].Start, ', length ', ADamages[i].Length, ', remain ', ADamages[i].CharsRemaining);
+      Write('          ');
+      for j := AStartIndex to AStopIndex do
+        // Enough space before damage for the other validation numbers?
+        if (FValidationLengths[AStartIndex, j + 1] - FValidation[j] < ADamages[i].Start)
+        // Enough space after damage for the other validation numbers?
+        and (FValidationLengths[j, AStopIndex + 1] - FValidation[j] <= ADamages[i].CharsRemaining)
+        // Damage itself small enough for this validation number?
+        and (FValidation[j] >= ADamages[i].Length) then
+          Write(j - AStartIndex, ' ');
+      WriteLn;
+    end;
+    ///////////////////////////////
+
+    Result := 9999;
+
+    // Assigns validation numbers to specific damages.
+    j := AStartIndex;
+    for i := 0 to ADamages.Count - 1 do
+    begin
+      while (j <= AStopIndex)
+      // Enough space before damage for the other validation numbers?
+      and ((FValidationLengths[AStartIndex, j + 1] - FValidation[j] >= ADamages[i].Start)
+      // Enough space after damage for the other validation numbers?
+      // TODO: Is this true? Once the following check is true for given j, increasing j will not make it false, so set Result := 0 and break.
+      or (FValidationLengths[j, AStopIndex + 1] - FValidation[j] > ADamages[i].CharsRemaining)
+      // Damage itself small enough for this validation number?
+      or (FValidation[j] < ADamages[i].Length)) do
+        Inc(j);
+
+      if (j > AStopIndex) then
+      begin
+        Result := 0;
         Break;
       end;
+
+      indices[i] := j;
+    end;
+
+    WriteLn('        validation number indices per damages:');
+    Write('          ');
+    for i := 0 to ADamages.Count - 1 do
+      Write(indices[i], ' ');
+    Write('( ');
+    for i := 0 to ADamages.Count - 1 do
+      Write(indices[i] - AStartIndex, ' ');
+    WriteLn(')');
+
+    // TODO: Iterate over all possible assignments of validation numbers to specific damages.
+  end;
+  WriteLn('        Result: ', Result);
+end;
+
+function TConditionRecord.CalcCombinationsSingleBlockSingleValidation(const APattern: string; constref ADamages:
+  TDamages; const AIndex: Integer): Int64;
+var
+  combinedDamagesLength: Integer;
+begin
+  if Length(APattern) < FValidation[AIndex] then
+    Result := 0
+  else if ADamages.Count = 0 then
+    Result := Length(APattern) - FValidation[AIndex] + 1
+  else begin
+    combinedDamagesLength := ADamages.Last.Start + ADamages.Last.Length - ADamages.First.Start;
+    if FValidation[AIndex] < combinedDamagesLength then
+      Result := 0
+    else begin
+      Result := Min(Min(Min(
+        ADamages.First.Start,
+        FValidation[AIndex] - combinedDamagesLength + 1),
+        Length(APattern) - FValidation[AIndex] + 1),
+        ADamages.Last.CharsRemaining + 1);
+    end;
   end;
 end;
 
-constructor THotSprings.Create;
+function TConditionRecord.ParseDamages(const APattern: string): TDamages;
+var
+  i, len: Integer;
+  damage: TDamage;
 begin
-  FValidation := specialize TList<Integer>.Create;
+  Result := TDamages.Create;
+  damage.Length := 0;
+  len := Length(APattern);
+  for i := 1 to len do
+    // The pattern must only contain damage and wildcard characters here.
+    if APattern[i] = CDamagedChar then
+    begin
+      if damage.Length = 0 then
+        damage.Start := i;
+      Inc(damage.Length);
+    end
+    else if damage.Length > 0 then
+    begin
+      damage.CharsRemaining := len - damage.Start - damage.Length + 1;
+      Result.Add(damage);
+      damage.Length := 0;
+    end;
+
+  if damage.Length > 0 then
+  begin
+    damage.CharsRemaining := 0;
+    Result.Add(damage);
+  end;
 end;
 
-destructor THotSprings.Destroy;
+constructor TConditionRecord.Create;
 begin
+  FBlockPatterns := TStringList.Create;
+  FValidation := TIntegerList.Create;
+  FDamagesBlocks := TDamagesBlocks.Create;
+end;
+
+destructor TConditionRecord.Destroy;
+begin
+  FBlockPatterns.Free;
   FValidation.Free;
+  FDamagesBlocks.Free;
   inherited Destroy;
 end;
 
-procedure THotSprings.ProcessDataLine(const ALine: string);
+procedure TConditionRecord.AddBlockPatterns(const APattern: string);
 var
   split: TStringArray;
-  i, j, val, maxFreeOperationalCount: Integer;
+  part: string;
 begin
-  FValidation.Clear;
+  split := APattern.Split([COperationalChar]);
-  split := ALine.Split([' ', ',']);
+  for part in split do
-  FSpringPattern := split[0];
+    if Length(part) > 0 then
-
-  maxFreeOperationalCount := Length(FSpringPattern) - Length(split) + 2;
-  for i := 1 to Length(split) - 1 do
     begin
-    val := StrToInt(split[i]);
+      FBlockPatterns.Add(part);
-    FValidation.Add(val);
+      FDamagesBlocks.Add(ParseDamages(part));
-    Dec(maxFreeOperationalCount, val);
+    end;
+end;
+
+function TConditionRecord.GenerateBlockAssignments: Int64;
+var
+  indices: array of Integer;
+  i, j, k, high: Integer;
+begin
+  // Each loop (each call to 'CalcCombinations') represents an independent set of arrangements, defined by 'indices',
+  // where specific validation numbers are assigned to specific block patterns.
+  //
+  // Here, 'indices[i]' denotes the index + 1 of the last validation number assigned to 'FBlockPattern[i]', and the
+  // index of the first validation number in 'FValidation' assigned to 'FBlockPattern[i + 1]'. If two consecutive values
+  // in 'indices' are the same, then the block in between has no numbers assigned to it.
+  //
+  // Note that 'indices[0] = 0' and 'indices[FBlockPatterns.Count] = FValidation.Count' are constant. Having these two
+  // numbers in the array simplifies the code a bit.
+  InitValidationLengths;
+  //FPatternLengths := CalcPatternLengths;
+  InitMinIndices;
+
+  SetLength(indices, FBlockPatterns.Count + 1);
+  high := Length(indices) - 2;
+  indices[0] := 0;
+  indices[high + 1] := FValidation.Count;
+
+  Result := 0;
+  k := 0;
+  repeat
+    i := k + 1;
+    while i <= high do
+    begin
+      ////j := indices[k];
+      //j := indices[i - 1];
+      //// TODO: FPatternLengths is only used to find the right j, so we should instead cache values to get j directly.
+      //while FValidationLengths[j, FValidation.Count] > FPatternLengths[i] do
+      //  Inc(j);
+      //indices[i] := j;
+      //WriteLn(j, ' ', FMinIndices[i - 1]);
+
+      indices[i] := Max(indices[i - 1], FMinIndices[i - 1]);
+      while FValidationLengths[indices[i - 1], indices[i]] > Length(FBlockPatterns[i - 1]) do
+      begin
+        Dec(i);
+        Inc(indices[i]);
       end;
 
-  ExtendArrangement('', maxFreeOperationalCount, 0, FPart1);
+      Inc(i);
-  WriteLn('Part 1: ', FPart1);
+    end;
 
+    //if FValidationLengths[indices[0], indices[1]] > Length(FBlockPatterns[0]) then
+    //  Break;
+
+    Result := Result + CalcCombinations(indices);
+
+    k := high;
+    while (k > 0)
+    and ((indices[k] = FValidation.Count)
+    or (FValidationLengths[indices[k - 1], indices[k] + 1] > Length(FBlockPatterns[k - 1]))) do
+      Dec(k);
+    Inc(indices[k]);
+  until k = 0;
+end;
+
+{ THotSprings }
+
+procedure THotSprings.ProcessDataLine(const ALine: string);
+var
+  conditionRecord1, conditionRecord2: TConditionRecord;
+  mainSplit, split: TStringArray;
+  part, unfolded: string;
+  i: Integer;
+begin
+  WriteLn(ALine);
+  WriteLn;
+
+  conditionRecord1 := TConditionRecord.Create;
+  conditionRecord2 := TConditionRecord.Create;
+
+  mainSplit := ALine.Split([' ']);
+
+  // Adds blocks for part 1.
+  conditionRecord1.AddBlockPatterns(mainSplit[0]);
+
+  // Adds blocks for part 2.
+  unfolded := mainSplit[0];
+  for i := 2 to CPart2Repetition do
+    unfolded := unfolded + CWildcardChar + mainSplit[0];
+  conditionRecord2.AddBlockPatterns(unfolded);
+
+  // Adds validation numbers.
+  split := mainSplit[1].Split([',']);
+  for part in split do
+    conditionRecord1.Validation.Add(StrToInt(part));
   for i := 1 to CPart2Repetition do
-  begin
+    conditionRecord2.Validation.AddRange(conditionRecord1.Validation);
-    FSpringPattern := FSpringPattern + CWildcardChar + split[0];
-    for j := 0 to Length(split) - 2 do
-      FValidation.Add(FValidation[j]);
-  end;
-  maxFreeOperationalCount := (CPart2Repetition + 1) * maxFreeOperationalCount;
 
-  ExtendArrangement('', maxFreeOperationalCount, 0, FPart2);
+  //for part in conditionRecord1.BlockPatterns do
-  WriteLn('Part 2: ', FPart2);
+  //  WriteLn(part);
+  //for i in conditionRecord1.Validation do
+  //  WriteLn(i);
+  //
+  //WriteLn;
+//
+//  for part in conditionRecord2.BlockPatterns do
+//    WriteLn(part);
+//  for i in conditionRecord2.Validation do
+//    WriteLn(i);
+//  WriteLn;
+  FPart2 := FPart2 + conditionRecord2.GenerateBlockAssignments;
+
+  conditionRecord1.Free;
+  conditionRecord2.Free;
+
+  WriteLn('------------------------');
+  WriteLn;
 end;
 
 procedure THotSprings.Finish;