Nonogram solver
Translation of Go
# 20220401 Raku programming solution
sub reduce(\a, \b) {
my \countRemoved = $ = 0;
for ^+a -> \i {
my \commonOn = @ = True xx b.elems;
my \commonOff = @ = False xx b.elems;
a[i].map: -> \candidate { commonOn <<?&=>> candidate ;
commonOff <<?|=>> candidate }
# remove from b[j] all candidates that don't share the forced values
for ^+b -> \j {
my (\fi,\fj) = i, j;
for ((+b[j])^...0) -> \k {
my \cnd = b[j][k];
if (commonOn[fj] ?& !cnd[fi]) ?| (!commonOff[fj] ?& cnd[fi]) {
b[j][k..*-2] = b[j][k+1..*-1];
b[j].pop;
countRemoved++
}
}
return -1 if b[j].elems == 0
}
}
return countRemoved
}
sub genSequence(\ones, \numZeros) {
if ( my \le = ones.elems ) == 0 { return [~] '0' xx numZeros }
my @result;
loop ( my $x = 1; $x < ( numZeros -le+2); $x++ ) {
my @skipOne = ones[1..*];
for genSequence(@skipOne, numZeros -$x) -> \tail {
@result.push: ( '0' x $x )~ones[0]~tail
}
}
return @result
}
# If all the candidates for a row have a value in common for a certain cell,
# then it's the only possible outcome, and all the candidates from the
# corresponding column need to have that value for that cell too. The ones
# that don't, are removed. The same for all columns. It goes back and forth,
# until no more candidates can be removed or a list is empty (failure).
sub reduceMutual(\cols, \rows) {
return -1 if ( my \countRemoved1 = reduce(cols, rows) ) == -1 ;
return -1 if ( my \countRemoved2 = reduce(rows, cols) ) == -1 ;
return countRemoved1 + countRemoved2
}
# collect all possible solutions for the given clues
sub getCandidates(@data, \len) {
return gather for @data -> \s {
my \sumBytes = [+] (my @a = s.ords)>>.&{ $_ - 'A'.ord + 1 }
my @prep = @a.values.map: { [~] '1' xx ($_ - 'A'.ord + 1) }
take ( gather for genSequence(@prep, len -sumBytes+1) -> \r {
my \bits = r.substr(1..*).ords;
take ( bits.values.map: *.chr == '1' ).Array
} ).Array
}
}
sub newPuzzle (@data) {
my (@rowData,@colData) := @data.map: *.split: ' ' ;
my \rows = getCandidates(@rowData, @colData.elems);
my \cols = getCandidates(@colData, @rowData.elems);
loop {
my \numChanged = reduceMutual(cols, rows);
given (numChanged) { when -1 { say "No solution" andthen return }
when 0 { last } }
}
for rows -> \row {
for ^+cols -> \k { print row[0][k] ?? '# ' !! '. ' }
print "\n"
}
print "\n"
}
newPuzzle $_ for (
( "C BA CB BB F AE F A B", "AB CA AE GA E C D C" ),
( "F CAC ACAC CN AAA AABB EBB EAA ECCC HCCC",
"D D AE CD AE A DA BBB CC AAB BAA AAB DA AAB AAA BAB AAA CD BBA DA" ),
( "CA BDA ACC BD CCAC CBBAC BBBBB BAABAA ABAD AABB BBH "
~"BBBD ABBAAA CCEA AACAAB BCACC ACBH DCH ADBE ADBB DBE ECE DAA DB CC",
"BC CAC CBAB BDD CDBDE BEBDF ADCDFA DCCFB DBCFC ABDBA BBF AAF BADB DBF "
~"AAAAD BDG CEF CBDB BBB FC" ),
( "E BCB BEA BH BEK AABAF ABAC BAA BFB OD JH BADCF Q Q R AN AAN EI H G",
"E CB BAB AAA AAA AC BB ACC ACCA AGB AIA AJ AJ "
~"ACE AH BAF CAG DAG FAH FJ GJ ADK ABK BL CM" ),
);
Translation of Perl
for './nonogram_problems.txt'.IO.lines.rotor(3, :partial) {
my (@rpats,@cpats) := @_[0,1]>>.&makepatterns;
my @rows = ( '.' x +@cpats ) xx +@rpats ;
loop (my $prev = ''; $prev ne ~@rows; ) {
$prev = ~@rows;
try(@rows, @rpats);
my @cols = (^+@cpats).map: { [~] @rows.map: { ~ s/.// } }
try(@cols, @cpats);
@rows = (^+@rpats).map: { [~] @cols.map: { ~ s/.// } }
}
say();
@rows ~~ /\./ ?? say "Failed" !! say TR/01/.@/ for @rows
}
sub try(@lines, @patterns) {
for ^+@lines -> $i {
my $pos = 0;
while ( @lines[$i] ~~ m:g/\./ and $pos < @lines[$i].chars ) {
for 0, 1 -> $try {
with @lines[$i] { S:pos($pos)/\./$try/ ~~ /<{@patterns[$i]}>/ or
s:pos($pos)/./{ 1 - $try }/ }
}
$pos++;
}
}
}
sub makepatterns($input) {
$input ==> split( ' ' )
==> map( *.comb )
==> map( *>>.&{ .ord - 64 } )
==> map( '<[1.]>**' <<~<< * )
==> map( *.join: '<[0.]>+' )
==> map( '^<[0.]>*' ~ * ~ '<[0.]>*$' )
}
Last updated