diff --git a/UCommon.pas b/UCommon.pas index 0e674d9..00961f0 100644 --- a/UCommon.pas +++ b/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; + implementation end. diff --git a/solvers/UHotSprings.pas b/solvers/UHotSprings.pas index 3244dd6..e155e57 100644 --- a/solvers/UHotSprings.pas +++ b/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]; - CDamagedPatternChars = [CDamagedChar, CWildcardChar]; - CPart2Repetition = 4; + //COperationalPatternChars = [COperationalChar, CWildcardChar]; + //CDamagedPatternChars = [CDamagedChar, CWildcardChar]; + 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; + + 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; + TDamagesBlocks = specialize TObjectList; + + { 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; - 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, - ACurrentValidationIndex: Integer; var AArrangementCount: Int64); +{ TConditionRecord } + +procedure TConditionRecord.InitValidationLengths; var - match: Boolean; - temp: string; + i, j: Integer; begin - if Length(AArrangement) = Length(FSpringPattern) then - Inc(AArrangementCount) + SetLength(FValidationLengths, FValidation.Count + 1, FValidation.Count + 1); + for i := 0 to FValidation.Count do + begin + FValidationLengths[i, i] := 0; + for j := i + 1 to FValidation.Count do + if FValidationLengths[i, j - 1] <> 0 then + FValidationLengths[i, j] := FValidationLengths[i, j - 1] + FValidation[j - 1] + 1 + else + FValidationLengths[i, j] := FValidationLengths[i, j - 1] + FValidation[j - 1] + end; +end; + +//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, j, patternsLength: Integer; +begin + SetLength(FMinIndices, FBlockPatterns.Count - 1); + patternsLength := Length(FBlockPatterns[FBlockPatterns.Count - 1]); + j := FValidation.Count; + for i := FBlockPatterns.Count - 2 downto 0 do + begin + while (j >= 0) and (FValidationLengths[j, FValidation.Count] <= patternsLength) do + 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 - temp := AArrangement; - // Tries to append a dot (operational) to the current arrangement. - if (ARemainingFreeOperationalCount > 0) and TryAppendOperationalChar(temp) then + 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 - ExtendArrangement(temp, ARemainingFreeOperationalCount - 1, ACurrentValidationIndex, AArrangementCount); + 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; - // Tries to append the current validation block (damaged) to the current arrangement. - if ACurrentValidationIndex < FValidation.Count then - begin - temp := AArrangement; - match := TryAppendValidationBlock(temp, FValidation[ACurrentValidationIndex]); + 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(')'); - // ... 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; + // TODO: Iterate over all possible assignments of validation numbers to specific damages. + end; + WriteLn(' Result: ', Result); +end; - if match then - ExtendArrangement(temp, ARemainingFreeOperationalCount, ACurrentValidationIndex + 1, AArrangementCount); +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; -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; -end; - -function THotSprings.TryAppendValidationBlock(var AArrangement: string; const ALength: Integer): Boolean; +function TConditionRecord.ParseDamages(const APattern: string): TDamages; var i, len: Integer; + damage: TDamage; begin - Result := True; - len := Length(AArrangement); - for i := 1 to ALength do - begin - if FSpringPattern[len + i] in CDamagedPatternChars then - AArrangement := AArrangement + CDamagedChar - else begin - Result := False; - Break; + 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; -constructor THotSprings.Create; +constructor TConditionRecord.Create; begin - FValidation := specialize TList.Create; + FBlockPatterns := TStringList.Create; + FValidation := TIntegerList.Create; + FDamagesBlocks := TDamagesBlocks.Create; end; -destructor THotSprings.Destroy; +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 := ALine.Split([' ', ',']); - FSpringPattern := split[0]; + split := APattern.Split([COperationalChar]); + for part in split do + if Length(part) > 0 then + begin + FBlockPatterns.Add(part); + FDamagesBlocks.Add(ParseDamages(part)); + end; +end; - maxFreeOperationalCount := Length(FSpringPattern) - Length(split) + 2; - for i := 1 to Length(split) - 1 do - begin - val := StrToInt(split[i]); - FValidation.Add(val); - Dec(maxFreeOperationalCount, val); - 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; - ExtendArrangement('', maxFreeOperationalCount, 0, FPart1); - WriteLn('Part 1: ', FPart1); + 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; + + Inc(i); + 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 - FSpringPattern := FSpringPattern + CWildcardChar + split[0]; - for j := 0 to Length(split) - 2 do - FValidation.Add(FValidation[j]); - end; - maxFreeOperationalCount := (CPart2Repetition + 1) * maxFreeOperationalCount; + conditionRecord2.Validation.AddRange(conditionRecord1.Validation); - ExtendArrangement('', maxFreeOperationalCount, 0, FPart2); - WriteLn('Part 2: ', FPart2); + //for part in conditionRecord1.BlockPatterns do + // 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;