user
A nonogram is a puzzle that provides
numeric clues used to fill in a grid of cells,
establishing for each cell whether it is filled or not.
The puzzle solution is typically a picture of some kind.

Each row and column of a rectangular grid is annotated with the lengths
of its distinct runs of occupied cells.
Using only these lengths you should find one valid configuration
of empty and occupied cells, or show a failure message.

Example

```
Problem:                 Solution:

. . . . . . . .  3       . # # # . . . .  3
. . . . . . . .  2 1     # # . # . . . .  2 1
. . . . . . . .  3 2     . # # # . . # #  3 2
. . . . . . . .  2 2     . . # # . . # #  2 2
. . . . . . . .  6       . . # # # # # #  6
. . . . . . . .  1 5     # . # # # # # .  1 5
. . . . . . . .  6       # # # # # # . .  6
. . . . . . . .  1       . . . . # . . .  1
. . . . . . . .  2       . . . # # . . .  2
1 3 1 7 5 3 4 3          1 3 1 7 5 3 4 3
2 1 5 1                  2 1 5 1
```

The problem above could be represented by two lists of lists:

```
x = [[3], [2,1], [3,2], [2,2], [6], [1,5], [6], [1], [2]]
y = [[1,2], [3,1], [1,5], [7,1], [5], [3], [4], [3]]
```

A more compact representation of the same problem uses strings,
where the letters represent the numbers, A=1, B=2, etc:

```
x = "C BA CB BB F AE F A B"
y = "AB CA AE GA E C D C"
```

Task

For this task, try to solve the 4 problems below, read from a “nonogram\_problems.txt” file that has this content
(the blank lines are separators):

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

**Extra credit**: generate nonograms with unique solutions, of desired height and width.
  
  
This task is the problem n.98 of the "99 Prolog Problems" (archived) by Werner Hett (also thanks to Paul Singleton for the idea and the examples).

Related tasks

* Nonoblock.

See also

* Arc Consistency Algorithm
* http://www.haskell.org/haskellwiki/99\_questions/Solutions/98 (Haskell)
* http://twanvl.nl/blog/haskell/Nonograms (Haskell)
* http://picolisp.com/5000/!wiki?99p98 (PicoLisp)
assistant
### Translation of Go

**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

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

```