您当前算法的问题是您正试图摆脱死胡同——特别是，当您的 @letters 和 @numbers 数组（在 @numbers 的初始洗牌之后）产生相同的单元格时不止一次。这种方法在矩阵很小的情况下有效，因为它不需要太多尝试就可以找到可行的重新洗牌。但是，当列表很大时，它是一个杀手。即使您可以更有效地寻找替代方案——例如，尝试排列而不是随机洗牌——这种方法也可能注定要失败。
您可以通过对现有矩阵进行小的修改来解决问题，而不是打乱整个列表。
例如，让我们从您的示例矩阵开始（称为 M1）。随机选择一个单元格进行更改（例如，A1）。此时矩阵处于非法状态。我们的目标是以最少的编辑次数来修复它——特别是再编辑 3 次。您通过在矩阵周围“走动”来实现这 3 个额外的编辑，每次修复一行或一列都会产生另一个要解决的问题，直到您走完一整圈（err ... 全长方形）。
例如将A1从0改为1后，下一次修复有3种行走方式：A3、B1、C1。让我们决定第一次编辑应该修复行。所以我们选择A3。在第二次编辑中，我们将修复该列，因此我们有选择：B3 或 C3（例如 C3）。最后的修复只提供了一个选择（C1），因为我们需要回到我们原来编辑的那一列。最终结果是一个新的有效矩阵。
Orig Change A1 Change A3 Change C3 Change C1
M1 M2
1 2 3 1 2 3 1 2 3 1 2 3 1 2 3
----- ----- ----- ----- -----
A | 0 0 1 1 0 1 1 0 0 1 0 0 1 0 0
B | 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0
C | 1 0 0 1 0 0 1 0 0 1 0 1 0 0 1
如果编辑路径导致死胡同，您将原路返回。如果所有修复路径都失败，则可以拒绝初始编辑。
这种方法将快速生成新的有效矩阵。它不一定会产生随机结果：M1 和 M2 仍然高度相关，随着矩阵大小的增长，这一点将变得更加明显。
如何增加随机性？您提到大多数单元格（99% 或更多）都是零。一个想法是这样进行：对于矩阵中的每个 1，将其值设置为 0，然后使用上述 4 编辑方法修复矩阵。实际上，您会将所有这些移动到新的随机位置。
这是一个插图。这里可能有进一步的速度优化，但这种方法在我的 Windows 机器上在 30 秒左右以 0.5% 的密度产生了 10 个新的 600x600 矩阵。不知道够不够快。
use strict;
use warnings;
# Args: N rows, N columns, density, N iterations.
main(@ARGV);
sub main {
my $n_iter = pop;
my $matrix = init_matrix(@_);
print_matrix($matrix);
for my $n (1 .. $n_iter){
warn $n, "\n"; # Show progress.
edit_matrix($matrix);
print_matrix($matrix);
}
}
sub init_matrix {
# Generate initial matrix, given N of rows, N of cols, and density.
my ($rows, $cols, $density) = @_;
my @matrix;
for my $r (1 .. $rows){
push @matrix, [ map { rand() < $density ? 1 : 0 } 1 .. $cols ];
}
return \@matrix;
}
sub print_matrix {
# Dump out a matrix for checking.
my $matrix = shift;
print "\n";
for my $row (@$matrix){
my @vals = map { $_ ? 1 : ''} @$row;
print join("\t", @vals), "\n";
}
}
sub edit_matrix {
# Takes a matrix and moves all of the non-empty cells somewhere else.
my $matrix = shift;
my $move_these = cells_to_move($matrix);
for my $cell (@$move_these){
my ($i, $j) = @$cell;
# Move the cell, provided that the cell hasn't been moved
# already and the subsequent edits don't lead to a dead end.
$matrix->[$i][$j] = 0
if $matrix->[$i][$j]
and other_edits($matrix, $cell, 0, $j);
}
}
sub cells_to_move {
# Returns a list of non-empty cells.
my $matrix = shift;
my $i = -1;
my @cells = ();
for my $row (@$matrix){
$i ++;
for my $j (0 .. @$row - 1){
push @cells, [$i, $j] if $matrix->[$i][$j];
}
}
return \@cells;
}
sub other_edits {
my ($matrix, $cell, $step, $last_j) = @_;
# We have succeeded if we've already made 3 edits.
$step ++;
return 1 if $step > 3;
# Determine the roster of next edits to fix the row or
# column total upset by our prior edit.
my ($i, $j) = @$cell;
my @fixes;
if ($step == 1){
@fixes =
map { [$i, $_] }
grep { $_ != $j and not $matrix->[$i][$_] }
0 .. @{$matrix->[0]} - 1
;
shuffle(\@fixes);
}
elsif ($step == 2) {
@fixes =
map { [$_, $j] }
grep { $_ != $i and $matrix->[$_][$j] }
0 .. @$matrix - 1
;
shuffle(\@fixes);
}
else {
# On the last edit, the column of the fix must be
# the same as the column of the initial edit.
@fixes = ([$i, $last_j]) unless $matrix->[$i][$last_j];
}
for my $f (@fixes){
# If all subsequent fixes succeed, we are golden: make
# the current fix and return true.
if ( other_edits($matrix, [@$f], $step, $last_j) ){
$matrix->[$f->[0]][$f->[1]] = $step == 2 ? 0 : 1;
return 1;
}
}
# Failure if we get here.
return;
}
sub shuffle {
my $array = shift;
my $i = scalar(@$array);
my $j;
for (@$array ){
$i --;
$j = int rand($i + 1);
@$array[$i, $j] = @$array[$j, $i] unless $i == $j;
}
}