Data commit

Task/Nonogram-solver/Raku/nonogram-solver-1.raku

@@ -0,0 +1,100 @@
+# 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" ),
+);

Task/Nonogram-solver/Raku/nonogram-solver-2.raku

@@ -0,0 +1,37 @@
+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.]>*$' )
+}