This is my response to the Perl Weekly Challenge #086.
@N and an integer $A.
$A.
1 if exists otherwise 0.
Input: @N = (10, 8, 12, 15, 5) and $A = 7
Output: 1 as 15 - 8 = 7
Input: @N = (1, 5, 2, 9, 7) and $A = 6
Output: 1 as 7 - 1 = 6
Input: @N = (10, 30, 20, 50, 40) and $A = 15
Output: 0
This challenge resembles «Triplet Sum» from last week's challenge.
See my article Two Triplets with Raku and Perl for details.
Obtaining pairwise combinations from an array is easy with
combinations(2), where 2 is the number of items
in each combination. Here with the values from the first example:
> say (10, 8, 12, 15, 5).combinations(2);
((10 8) (10 12) (10 15) (10 5) (8 12) (8 15) (8 5) (12 15) (12 5) (15 5))
See
docs.raku.org/routine/combinations
for more information about combinations.
Obtaining the difference instead of the pairwise
numbers can be done with map and the Reduction Metaoperator [],
which applies to a list insert the operator between each value. In this case the operator
is - (minus):
> say (10, 8, 12, 15, 5).combinations(2).map({ ([-] @$_) })
(2 -2 -5 5 -4 -7 3 -3 7 10)
It is possible to access the two elements directly, with normal subtraction:
> say (10, 8, 12, 15, 5).combinations(2).map({ @$_[0] - @$_[1] })
(2 -2 -5 5 -4 -7 3 -3 7 10)
But I like the first one better, as it can be extended to lists of more than two elements.
The difference is reported as negativce for some of the pairs. That is wrong, and we could swap the left and right side of the operator. But it is easier to remove the sign:
> say (10, 8, 12, 15, 5).combinations(2).map({ abs ([-] @$_) })
(2 2 5 5 4 7 3 3 7 10)
Note that we get duplicates when we remove the,
sign, as the combinations gave us both (10, 8) (-> 2) and (8, 10)
(-> -2). But this does not really matter in practice.
The nwe can check for the difference of 7, with an any Junction:
> say (any (10, 8, 12, 15, 5).combinations(2).map({ abs ([-] @$_) }) ) == 7
any(False, False, False, False, False, True, False, False, True, False)
The result is a Junction, telling us that we have a match (actually two) somewhere.
See
docs.raku.org/routine/any for
more information about any, and
docs.raku.org/type/Junction for
more information about Junctions.
so operator: This will give us True if any of the values
are True.
> say so (any (10,8,12,15,5).combinations(2).map({ abs ([-] @$_) }) ) == 7
True
See
docs.raku.org/routine/so
for more information about the so operator.
The challenge wanted the numbers 1 instead of
True, and 0 instead of False. We can achieve that by coercing
the Boolean value to a number with the + operator:
> say + so (any (10,8,12,15,5).combinations(2).map({ abs ([-] @$_) }) ) == 7
1
See
docs.raku.org/routine/+
for more information about the Numeric Context Operator +.
Then the program:
File: pair-difference
unit sub MAIN (Int $A, *@N where @N.elems >= 2 && all(@N) ~~ Int);
say + so any( @N.combinations(2).map({ abs([-] @$_) }) ) == $A;
We ensure that all the arguments are integers, and thate there are at least two in the list. Note that we simply take the first value as the sum.
Running it on the examples:
$ ./pair-difference 7 10 8 12 15 5
1
$ ./pair-difference 6 1 5 2 9 7
1
$ ./pair-difference 15 10 30 20 50 40
0
We can add verbose mode, to show us what is going on:
File: pair-difference-verbose
unit sub MAIN (Int $A, *@N where @N.elems >= 2 && all(@N) ~~ Int,
:v(:$verbose));
{ say ": " ~ @$_ ~ " -> " ~ abs([-] @$_) for @N.combinations(2) } if $verbose;
say + so any( @N.combinations(2).map({ abs([-] @$_) }) ) == $A;
Note the prefix if. You have seen it
after a single statement, but a block works just as well. (And parens instead of the
curlies will also work, but they may make you brain go curly.)
Running it:
$ ./pair-difference-verbose -v 7 10 8 12 15 5
: 10 8 -> 2
: 10 12 -> 2
: 10 15 -> 5
: 10 5 -> 5
: 8 12 -> 4
: 8 15 -> 7
: 8 5 -> 3
: 12 15 -> 3
: 12 5 -> 7
: 15 5 -> 10
1
$ ./pair-difference-verbose -v 6 1 5 2 9 7
: 1 5 -> 4
: 1 2 -> 1
: 1 9 -> 8
: 1 7 -> 6
: 5 2 -> 3
: 5 9 -> 4
: 5 7 -> 2
: 2 9 -> 7
: 2 7 -> 5
: 9 7 -> 2
1
$ ./pair-difference-verbose -v 15 10 30 20 50 40
: 10 30 -> 20
: 10 20 -> 10
: 10 50 -> 40
: 10 40 -> 30
: 30 20 -> 10
: 30 50 -> 20
: 30 40 -> 10
: 20 50 -> 30
: 20 40 -> 20
: 50 40 -> 10
0
all Junction used to verify the argument type.)
File: pair-difference-perl
#! /usr/bin/env perl
use strict;
use feature 'say';
use Getopt::Long;
use List::Util qw(all sum);
use Algorithm::Combinatorics 'combinations';
die "At least 3 values" unless @ARGV > 2;
die "Integers only" unless all { $ ~= /^\d+$/ } @ARGV;
my $A = shift(@ARGV);
for my $combination (combinations(\@ARGV, 2))
{
my $sum = @$combination[0] - @$combination[1];
if (abs($sum) == $A)
{
say 1;
exit;
}
}
say 0;
Running it on the examples:
$ $ ./pair-difference-perl 7 10 8 12 15 5
1
$ ./pair-difference-perl 6 1 5 2 9 7
1
$ ./pair-difference-perl 15 10 30 20 50 40
0
[ _ _ _ 2 6 _ 7 _ 1 ]
[ 6 8 _ _ 7 _ _ 9 _ ]
[ 1 9 _ _ _ 4 5 _ _ ]
[ 8 2 _ 1 _ _ _ 4 _ ]
[ _ _ 4 6 _ 2 9 _ _ ]
[ _ 5 _ _ _ 3 _ 2 8 ]
[ _ _ 9 3 _ _ _ 7 4 ]
[ _ 4 _ _ 5 _ _ 3 6 ]
[ 7 _ 3 _ 1 8 _ _ _ ]
[ 4 3 5 2 6 9 7 8 1 ]
[ 6 8 2 5 7 1 4 9 3 ]
[ 1 9 7 8 3 4 5 6 2 ]
[ 8 2 6 1 9 5 3 4 7 ]
[ 3 7 4 6 8 2 9 1 5 ]
[ 9 5 1 7 4 3 6 2 8 ]
[ 5 1 9 3 2 6 8 7 4 ]
[ 2 4 8 9 5 7 1 3 6 ]
[ 7 6 3 4 1 8 2 5 9 ]
[ 4 3 5 ] [ 2 6 9 ] [ 7 8 1 ]
[ 6 8 2 ] [ 5 7 1 ] [ 4 9 3 ]
[ 1 9 7 ] [ 8 3 4 ] [ 5 6 2 ]
[ 8 2 6 ] [ 1 9 5 ] [ 3 4 7 ]
[ 3 7 4 ] [ 6 8 2 ] [ 9 1 5 ]
[ 9 5 1 ] [ 7 4 3 ] [ 6 2 8 ]
[ 5 1 9 ] [ 3 2 6 ] [ 8 7 4 ]
[ 2 4 8 ] [ 9 5 7 ] [ 1 3 6 ]
[ 7 6 3 ] [ 4 1 8 ] [ 2 5 9 ]
I started by placing the example puzzle in a file «sample-sudoku.txt», on the
given form. (I generally do not like the start and end brackets ([)
and (]) in input like this, as they are redundant. The line breaks
has the relevent information. But I have kept them, this time.)
Then I declared a custom type with the legal values (the digits 1..9 and _), and ignore all other characetrs in the input. That takes care of the brackets:
> subset LegalChar where /^<[1..9_]>$/;
> my @sudoku = 'sample1.txt'.IO.lines.map( *.words.grep(LegalChar) );
Note that it will also accept files without the brackets starting and ending the rows.
I have chosen to put the values in a two dimentional array. We can access e.g. the top left value like this:
> say @sudoku[0][0]; # -> _
We are going to fill in the blanks, so to speak. Let us try:
> @sudoku[0][0] = 4
Cannot modify an immutable Str (_)
Oops!
The problem is that the array assignment (assigning to a variable with a@ sigil)
did not quite work out:
> say @sudoku.WHAT; # -> (Array)
> say @sudoku[0].WHAT; # -> (Seq)
The top level is indeed an Array, but the rows are Sequences, which are read only. (We will
get the same result (and problem) if we ignore the brackets, and simplify the code to
$sudoku.IO.lines>>.words.)
The solution? Ensure that the rows are Arrays (with the Array
method):
> my @sudoku = 'sample1.txt'.IO.lines.map( *.words.grep(LegalChar) )>>.Array;
See
docs.raku.org/routine/Array for more
information about the Array method.
> say @sudoku[0].WHAT; # -> (Array)
Assignment works now:
> @sudoku[0][0] = 4;
The first index is the row, on the form 0..8, and the second is the column, also on the form 0..8.
Then we can talk strategy.
Every cell in the puzzle is part of three groups; a row, a column, and a square. We iterate over all the positions, looking for an underscore character. Then we obtain the values from all the groups, together, looking for missing values. If there is exactly one missing value, we replace the underscore with it. When we have reached the end, we start at the top again.
The technique mentioned above is called «Sole Candidate». There are many more, that can be applied if the first one does not fill in all the blanks. See e.g. www.kristanix.com/sudokuepic/sudoku-solving-techniques.php for details.
Then the program. First we read in the puzzle, checking that it has the right syntax:
File: sudoku-solver (partial)
#! /usr/bin/env raku
subset LegalChar where /^<[1..9_]>$/;
subset SudokuDigit where /^<[1..9]>$/;
unit sub MAIN ($sudoku where $sudoku.IO.f
&& $sudoku.IO.r = 'sample-sudoku.txt', # [1]
:vv(:$very-verbose),
:v(:$verbose) = $very-verbose);
my @sudoku = $sudoku.IO.lines.map( *.words.grep(LegalChar) )>>.Array; # [2]
die "Must be 9 rows" unless @sudoku.elems == 9; # [3]
die "Must be 9 columns" unless @sudoku[0].elems == 9; # [4]
die "Must be 9 columns" unless [==] @(@sudoku)>>.elems; # [5]
die "0-9_ only" unless all( @sudoku>>.List.flat ) ~~ LegalChar; # [6]
[1] Note the default filename.
[2] Read the suduko puzzle, remove the brackets (and any other illegalities), and place the result in a two-dimentional array. As an array, so that we can change the values later on
[3] Ensure 9 rows,
[4] and 9 columns (on the first row),
[5] and that all the rows have the same length (9, see above).
[6] and that we only have legal characters («1» to «9» and «_»).
We need the number of unknown values (the underscores), so that we can keep track of the progress. (Or the lack thereof.)
File: sudoku-solver (partial)
my $unknown = count-unknowns;
say ": Unknown values: $unknown" if $verbose;
sub count-unknowns
{
@sudoku>>.List.flat.grep( { $_ eq "_" } ).elems; # [7]
}
[7] Turn the matrix into a one dimentional array, keep the underscores only, and count them.
Then we can look at the helper procedures that gives us the 9 values for the row, column or box:
File: sudoku-solver (partial)
sub get-row ($row, $col)
{
return @sudoku[$row]; # [8]
}
sub get-col ($row, $col)
{
return (0..8).map({ @sudoku[$_][$col] }); # [9]
}
sub get-box ($row, $col) # [10]
{
my $row-actual = $row div 3 * 3; # [10a]
my $col-actual = $col div 3 * 3; # [10a]
return |@sudoku[$row-actual ][$col-actual .. $col-actual+2],
|@sudoku[$row-actual+1][$col-actual .. $col-actual+2],
|@sudoku[$row-actual+2][$col-actual .. $col-actual+2];
}
[8] The row is easy.
[9] The column is harder. I have chosen to pick the values one at a time, in a
map. The result is a list that we can return as is, so we do not
have to wrap it up in a temporary variable.
[10] The box is even harder. It adjusts the
coordinates to get the upper left corner of the box that the current cell belongs
to. It returns three cells from each row, starting from the specified location.
Note the Flattening Operator | that flattens the array slices, so
that we get a (single) list of values - an not a list of lists.
Then we can implement the strategy, that relies on the fact that the puzzle is solvable with the one (and easy) rule I presented above.
File: sudoku-solver (partial)
my $pass = 1;
{ say ":: { @$_ }" for @sudoku } if $very-verbose;
LOOP: loop
{
say ": Pass: { $pass++ } with $unknown unknowns" if $verbose;
for 0 .. 8 -> $row
{
for 0 .. 8 -> $col
{
last LOOP if $unknown == 0;
next unless @sudoku[$row][$col] eq "_";
my @row = get-row($row, $col).grep(SudokuDigit);
my @col = get-col($row, $col).grep(SudokuDigit);
my @box = get-box($row, $col).grep(SudokuDigit);
if $very-verbose
{
say ":: [$row,$col] Row: { @row.sort.join(", ") }";
say ":: [$row,$col] Col: { @col.sort.join(", ") }";
say ":: [$row,$col] Box: { @box.sort.join(", ") }";
}
my @all = ( @row (|) @col (|) @box ).keys.sort;
my @missing = ( (1..9) (-) @all>>.Int ).keys.sort;
say ":: all: @all[]" if $very-verbose;
say ": Pos[$row, $col] - missing: @missing[]" if $verbose;
if @missing.elems == 1
{
$unknown--;
say ":: [$row,$col] => @missing[0] (replacing unknown { $unknown })"
if $very-verbose;
@sudoku[$row][$col] = @missing[0];
{ say ":: { @$_ }" for @sudoku } if $very-verbose;
}
}
}
}
say @$_ for @sudoku;
The program is indeed able to solve the puzzle:
$ ./sudoku-solver
[4 3 5 2 6 9 7 8 1]
[6 8 2 5 7 1 4 9 3]
[1 9 7 8 3 4 5 6 2]
[8 2 6 1 9 5 3 4 7]
[3 7 4 6 8 2 9 1 5]
[9 5 1 7 4 3 6 2 8]
[5 1 9 3 2 6 8 7 4]
[2 4 8 9 5 7 1 3 6]
[7 6 3 4 1 8 2 5 9]
Note that the «Sole Candidate» technique was suffient for solving this puzzle. We did not have to use other techniques, so we can silently ignore them. (This means that the program will come up short for some perfectly solveable puzzles, but that is not our problem…
With verbose mode:
$ ./sudoku-solver -v
: Unknown values: 45
: Pass: 1
: Pos[0, 0] - missing: 3 4 5
: Pos[0, 1] - missing: 3
: Pos[0, 2] - missing: 5
: Pos[0, 5] - missing: 9
: Pos[0, 7] - missing: 8
: Pos[1, 2] - missing: 2
: Pos[1, 3] - missing: 5
: Pos[1, 5] - missing: 1
: Pos[1, 6] - missing: 3 4
: Pos[1, 8] - missing: 3
: Pos[2, 2] - missing: 7
: Pos[2, 3] - missing: 8
: Pos[2, 4] - missing: 3
: Pos[2, 7] - missing: 6
: Pos[2, 8] - missing: 2
: Pos[3, 2] - missing: 6
: Pos[3, 4] - missing: 9
: Pos[3, 5] - missing: 5 7
: Pos[3, 6] - missing: 3
: Pos[3, 8] - missing: 5 7
: Pos[4, 0] - missing: 3
: Pos[4, 1] - missing: 1 7
: Pos[4, 4] - missing: 8
: Pos[4, 7] - missing: 1 5
: Pos[4, 8] - missing: 5 7
: Pos[5, 0] - missing: 9
: Pos[5, 2] - missing: 1
: Pos[5, 3] - missing: 4 7
: Pos[5, 4] - missing: 4
: Pos[5, 6] - missing: 6
: Pos[6, 0] - missing: 2 5
: Pos[6, 1] - missing: 1 6
: Pos[6, 4] - missing: 2
: Pos[6, 5] - missing: 6
: Pos[6, 6] - missing: 1 8
: Pos[7, 0] - missing: 2
: Pos[7, 2] - missing: 8
: Pos[7, 3] - missing: 7 9
: Pos[7, 5] - missing: 7
: Pos[7, 6] - missing: 1
: Pos[8, 1] - missing: 6
: Pos[8, 3] - missing: 4 9
: Pos[8, 6] - missing: 2
: Pos[8, 7] - missing: 5
: Pos[8, 8] - missing: 9
: Pass: 2
: Pos[0, 0] - missing: 4
: Pos[1, 6] - missing: 4
: Pos[3, 5] - missing: 5
: Pos[3, 8] - missing: 7
: Pos[4, 1] - missing: 7
: Pos[4, 7] - missing: 1
: Pos[4, 8] - missing: 5
: Pos[5, 3] - missing: 7
: Pos[6, 0] - missing: 5
: Pos[6, 1] - missing: 1
: Pos[6, 6] - missing: 8
: Pos[7, 3] - missing: 9
: Pos[8, 3] - missing: 4
[4 3 5 2 6 9 7 8 1]
[6 8 2 5 7 1 4 9 3]
[1 9 7 8 3 4 5 6 2]
[8 2 6 1 9 5 3 4 7]
[3 7 4 6 8 2 9 1 5]
[9 5 1 7 4 3 6 2 8]
[5 1 9 3 2 6 8 7 4]
[2 4 8 9 5 7 1 3 6]
[7 6 3 4 1 8 2 5 9]
But what if it had not been able to solve it? The program would have run forever, because of the loop. We should handle the problem, and the easiest way is to abort. We have a counter for the number of passes (the times we start at the top left corner), and we can bail out if the number of unknown characters is the same as the last iteration in the loop.
Note that the program does not check if the given (partial) puzzle satisfies the rules. We can use that fact to create a puzzle that cannot be solved:
File: sample-sudoku-error.txt
[ _ _ _ 2 6 _ 7 _ 1 ]
[ 6 1 _ _ 7 _ _ 9 _ ]
[ 1 9 _ _ _ 4 5 _ _ ]
[ 8 2 _ 1 _ _ _ 4 _ ]
[ _ _ 4 6 _ 2 9 _ _ ]
[ _ 5 _ _ _ 3 _ 2 8 ]
[ _ _ 9 3 _ _ _ 7 4 ]
[ _ 4 _ _ 5 _ _ 3 6 ]
[ 7 _ 3 _ 1 8 _ _ _ ]
$ ./sudoku-solver sample-sudoku-error.txt
^C
Yes, it will run forever.
The fix:
File: sudoku-solver-exit (partial)
my $pass = 1;
my $unknown-prev = Inf;
{ say ":: { @$_ }" for @sudoku } if $very-verbose;
LOOP: loop
{
if $unknown-prev == $unknown
{
say "Unsolvable Sudoku (by this program)";
exit;
}
$unknown-prev = $unknown;
say ": Pass: { $pass++ } with $unknown unknowns" if $verbose;
Running it on the unsolvable puzzle:
$ ./sudoku-solver-exit sample-sudoku-error.txt
Unsolvable Sudoku (by this program)
This is a translation of the Raku version, with some parts rewritten:
#! /usr/bin/env perl
use strict;
use feature 'say';
use feature 'signatures';
use Getopt::Long;
use List::MoreUtils qw(uniq singleton);
no warnings qw(experimental::signatures);
my $verbose = 0;
my $very_verbose = 0;
GetOptions("verbose" => \$verbose,
"vv" => \$very_verbose);
$verbose = 1 if $very_verbose;
my $filename = shift(@ARGV) || die "Please specify a sudoku file";
my @sudoku;
my $rows = 0;
open my $in, $filename or die "$filename: $!";
while (my $line = <$in>)
{
my @values = split(/\s+/, $line);
shift @values if $values[0] eq "[";
pop @values if $values[@values-1] eq "]";
my $cols = @values;
die "Wrong number of columns: $cols. Should have been 9" unless $cols == 9;
$sudoku[$rows++] = \@values;
}
close $in;
die "Wrong number of lines $rows" unless $rows == 9;
my $unknown = count_unknowns();
say ": Unknown values: $unknown" if $verbose;
sub count_unknowns
{
my $unknown = 0;
for my $row (0 .. 8)
{
for my $col (0 .. 8)
{
$unknown++ if $sudoku[$row][$col] eq "_";
}
}
return $unknown;
}
sub get_row ($row, $col)
{
return map { $sudoku[$row][$_] } (0..8);
}
sub get_col ($row, $col)
{
return map { $sudoku[$_][$col] } (0..8);
}
sub get_box ($row, $col)
{
my $row_actual = int($row / 3) * 3;
my $col_actual = int($col / 3) * 3;
return $sudoku[$row_actual ][$col_actual ],
$sudoku[$row_actual ][$col_actual+1],
$sudoku[$row_actual ][$col_actual+2],
$sudoku[$row_actual+1][$col_actual ],
$sudoku[$row_actual+1][$col_actual+1],
$sudoku[$row_actual+1][$col_actual+2],
$sudoku[$row_actual+2][$col_actual ],
$sudoku[$row_actual+2][$col_actual+1],
$sudoku[$row_actual+2][$col_actual+2];
}
my $pass = 1;
my $unknown_prev = 999;
if ($very_verbose) { say ":: ", join(" ", @$_) for @sudoku; }
LOOP: while (1)
{
if ($unknown_prev == $unknown)
{
say "Unsolvable Sudoku (by this program)";
exit;
}
$unknown_prev = $unknown;
say ": Pass: $pass with $unknown unknowns" if $verbose;
$pass++;
for my $row (0 .. 8)
{
for my $col (0 .. 8)
{
last LOOP if $unknown == 0;
next unless $sudoku[$row][$col] eq "_";
my @row = sort grep { /^[1-9]$/ } get_row($row, $col);
my @col = sort grep { /^[1-9]$/ } get_col($row, $col);
my @box = sort grep { /^[1-9]$/ } get_box($row, $col);
if ($very_verbose)
{
say ":: [$row,$col] Row: ", join(", ", sort @row);
say ":: [$row,$col] Col: ", join(", ", sort @col);
say ":: [$row,$col] Box: ", join(", ", sort @box);
}
my @all = uniq sort ( @row, @col, @box );
my @missing = singleton (@all, 1..9);
say ":: all: ", join(" ", @all) if $very_verbose;
say ": Pos[$row, $col] - missing: ", join(" ", @missing) if $verbose;
if (@missing.elems == 1)
{
$unknown--;
say ":: [$row,$col] => @missing[0] (replacing unknown $unknown)"
if $very_verbose;
$sudoku[$row][$col] = $missing[0];
if ($very_verbose) { say ":: ", join(" ", @$_) for @sudoku; }
}
}
}
}
say "[", join(" ", @$_), "]" for @sudoku;
Running it gives the same result as the Raku version, including the verbose output:
$ ./sudoku-solver-exit -v sample-su doku.txt > raku-v
$ ./sudoku-solver-perl -verbose sample-sudoku.txt > perl-v
$ diff raku-v perl-v
And the very verbose output as well:
$ ./sudoku-solver-exit -vv sample-sudoku.txt > raku-vv
$ ./sudoku-solver-perl -vv sample-sudoku.txt > perl-vv
$ diff raku-vv perl-vv
And that's it.