# Nonogram solver

### Translation of Go

```perl
# 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

```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.]>*$' )
}
```


---

# Agent Instructions: Querying This Documentation

If you need additional information that is not directly available in this page, you can query the documentation dynamically by asking a question.

Perform an HTTP GET request on the current page URL with the `ask` query parameter:

```
GET https://trizen.gitbook.io/perl6-rosettacode/programming_tasks/n/nonogram_solver.md?ask=<question>
```

The question should be specific, self-contained, and written in natural language.
The response will contain a direct answer to the question and relevant excerpts and sources from the documentation.

Use this mechanism when the answer is not explicitly present in the current page, you need clarification or additional context, or you want to retrieve related documentation sections.