RogerBW's Blog

Perl Weekly Challenge 86: Sudoku Difference 12 November 2020

I’ve been doing the Perl Weekly Challenges. The latest involved list searches and combinatorial explosions. (Note that this is open until 15 November 2020.)

Task #1 › Pair Difference

You are given an array of integers @N and an integer $A.

Write a script to find find if there exists a pair of elements in the array whose difference is $A.

Print 1 if exists otherwise 0.

This looks to me like a "see whether this element exists" problem, and for those I reach for my hashes.

sub pd {
  my $n=shift;
  my $a=shift;

Make the %n hash of all the input values.

  my %n=map {$_ => 1} @{$n};

Then for each candidate value ($a plus each value in %n) see whether it exists.

  foreach my $p (map {$_+$a} keys %n) {
    if (exists $n{$p}) {
      return 1;
    }
  }
  return 0;
}

Raku works similarly, but has the Set type.

sub pd(@n,$a) {
  my $n=Set.new(@n);
  for map {$_+$a},$n.keys -> $p {
    if ($n{$p}:exists) {
      return 1;
    }
  }
  return 0;
}

So does Python. (I don't like that reuse of in for two moderately different things.)

def pti(n,a):
    ns=set(n)
    for x in n:
        if x+a in ns:
            return 1
    return 0

And Ruby, with an external though standard library for sets.

def pti(n,a)
  ns=Set.new(n)
  n.each do |x|
    if ns.include?(x+a)
      return 1
    end
  end
  return 0
end

And because these have been being quite easy, I thought I'd try it in Rust too. There's probably a neater way of using an iterator to populate the HashMap all in one go, but I'm still very much finding my way in Rust.

use std::collections::HashMap;

fn pti(n: Vec<i32>, a: i32) -> i8 {
    let mut tab=HashMap::new();
    for x in n.clone() {
        tab.insert(x,1);
    }
    for x in n {
        if tab.contains_key(&(x+a)) {
            return 1;
        }
    }
    return 0;
}

Task #2 › Sudoku Puzzle

You are given Sudoku puzzle (9x9).

Write a script to complete the puzzle (etc.)

To do this properly is quite hard work. However, the example puzzle can be solved with simple elimination (find a cell that has only one possible value, set it to that value, and repeat). I went one step further, but explicitly not to the point of an exhaustive backtracking search – this is not a general Sudoku solver, though it'll do many simple examples. I also did this one only in Perl.

my @symbols=('1'..'9');
my $order=3;

my $sqo=$order*$order;
my $sqo1=$sqo-1;
my @p;
my $ss=join('',@symbols);
my @r;

@p gets the puzzle loaded into it. @r, with corresponding indices, contains candidate values as a hash. (Which starts at all of 1-9 for blank cells.)

open I,'<',($ARGV[0] || 'puzzle');
while (<I>) {
  chomp;
  s/[ \[\]]+//g;
  push @p,[map {if (/[$ss]/) {$_} else {''} } split '',$_];
  my @ra;
  foreach (0..$#{$p[-1]}) {
    if ($p[-1][$_] eq '') {
      push @ra,{map {$_ => 1} @symbols};
    } else {
      push @ra,{$p[-1][$_] => 1};
    }
  }
  push @r,\@ra;
}

Build the coordinate sets (csets). Each cset is a list of coordinates defining a group with exclusive values: so in this order-(3,3) puzzle there are nine csets corresponding to the rows, nine to the columns, and nine to the 3×3 boxes. (This way I can apply any algorithm cleanly to each cset, rather than having three separate calls from different loops.)

my @cset;
foreach my $ri (0..$sqo1) {
  push @cset,[map {[$ri,$_]} (0..$sqo1)];
}
foreach my $ci (0..$sqo1) {
  push @cset,[map {[$_,$ci]} (0..$sqo1)];
}
for (my $rb=0;$rb<$sqo1;$rb+=$order) {
  for (my $cb=0;$cb<$sqo1;$cb+=$order) {
    my @c;
    foreach my $ri ($rb..$rb+$order-1) {
      foreach my $ci ($cb..$cb+$order-1) {
        push @c,[$ri,$ci];
      }
    }
    push @cset,\@c;
  }
}

while (!solved(\@p)) {
  my $dirty=0;

While the puzzle is unsolved, do single eliminations.

  foreach my $c (@cset) {
    $dirty+=eliminate_1(\@p,\@r,$c);
  }

If that didn't produce any change, try open tuples.

  unless ($dirty) {
    foreach my $c (@cset) {
      $dirty+=eliminate_open_tuple(\@p,\@r,$c);
    }
  }

More techniques would be added here. In the real world I'd use Games::Sudoku::General which is already in CPAN (and which I already use to generate order-(4,4) sudoku puzzles for a friend who got to enjoy them when they were trendy and likes to keep doing them now that they aren't), but that would seem to be missing the point of this exercise.

If we tried everything without getting any changes, give up. Otherwise, loop back to see if one of the changes has made the puzzle susceptible to a simpler technique.

  unless ($dirty) {
    warn "I give up\n";
    last;
  }
}

Print the final grid.

foreach my $r (@p) {
  print join(' ',map {$_ eq ''?'_':$_} @{$r}),"\n";
}

Test for the grid being solved: are there any blanks in it?

sub solved {
  my @p=@{$_[0]};
  foreach my $r (@p) {
    foreach my $c (@{$r}) {
      if ($c eq '') {
        return 0;
      }
    }
  }
  return 1;
}

Single elimination. Within a given cset, remove each known cell value from the list of possible values for other cells. If this leaves a cell with only one possible value, set it.

sub eliminate_1 {
  my $p=shift;
  my $r=shift;
  my $c=shift;
  my %rm;
  my $dirty=0;
  foreach my $cp (@{$c}) {
    if ($p->[$cp->[0]][$cp->[1]] ne '') {
      $rm{$p->[$cp->[0]][$cp->[1]]}=1;
    }
  }
  if (%rm) {
    foreach my $cp (@{$c}) {
      if ($p->[$cp->[0]][$cp->[1]] eq '') {
        map {delete $r->[$cp->[0]][$cp->[1]]{$_}} keys %rm;
        if (scalar keys %{$r->[$cp->[0]][$cp->[1]]}==1) {
          $p->[$cp->[0]][$cp->[1]]=(keys %{$r->[$cp->[0]][$cp->[1]]})[0];
          $dirty=1;
        }
      }
    }
  }
  return $dirty;
}

Open tuples. If there are (say) two cells in the cset with possible values "2, 4", then one of them is definitely 2 and the other is definitely 4; so we can eliminate 2 and 4 from all other cells in the cset. Again, if this leaves a cell with only one possible velue, set it. (Similarly for groups of 3, 4, etc.)

sub eliminate_open_tuple {
  my $p=shift;
  my $r=shift;
  my $c=shift;
  my $dirty=0;
  my %pa;
  foreach my $i (0..$#{$c}) {
    my $cp=$c->[$i];
    my $s=join('',sort keys %{$r->[$cp->[0]][$cp->[1]]});
    if (length($s)>1) {
      $pa{$s}{$i}=1;
    }
  }
  foreach my $tuple (keys %pa) {
    if (scalar keys %{$pa{$tuple}}==length($tuple)) {
      my @t=split '',$tuple;
      foreach my $i (0..$#{$c}) {
        my $cp=$c->[$i];
        unless (exists $pa{$tuple}{$i}) {
          foreach my $x (@t) {
            if (delete $r->[$cp->[0]][$cp->[1]]{$x}) {
              $dirty=1;
            }
          }
          if (scalar keys %{$r->[$cp->[0]][$cp->[1]]}==1) {
            $p->[$cp->[0]][$cp->[1]]=(keys %{$r->[$cp->[0]][$cp->[1]]})[0];
          }
        }
      }
    }
  }
  return $dirty;
}

Full code on github.


  1. Posted by RogerBW at 05:07pm on 17 November 2020

    Looking at others' blogs:

    There only seems to be one way to do part 1, though some people didn't use the hash. (It's still O(n²) but looking up Perl hashes is pretty fast.) I quite like the idea of generating the differences of each pair of numbers and then seeing if the necessary one is present. If I were doing this in earnest in a non-Perl language, where I don't know how ferociously optimised the hash lookups are, I might try other approaches and see what came out fastest.

    For part 2 most people didn't bother with a generalised solver (it's a fair old effort) but there was an interesting array of approaches to the problem. About half the solutions flattened the row/column/box constraints into a single sort of thing, which seems to me the obvious approach (it avoids triplicating code).

Add A Comment

Your Name
Your Email
Your Comment

Your submission will be ignored if any field is left blank, but your email address will not be displayed. Comments will be processed through markdown.

Search
Archive
Tags 1920s 1930s 1940s 1950s 1960s 1970s 1980s 1990s 2000s 2010s 3d printing action aeronautics aikakirja anecdote animation anime army astronomy audio audio tech base commerce battletech beer boardgaming book of the week bookmonth chain of command children chronicle church of no redeeming virtues cold war comedy computing contemporary cornish smuggler cosmic encounter coup covid-19 cycling dead of winter doctor who documentary drama driving drone ecchi economics espionage essen 2015 essen 2016 essen 2017 essen 2018 essen 2019 existential risk falklands war fandom fanfic fantasy feminism film firefly first world war flash point flight simulation food garmin drive gazebo genesys geodata gin gurps gurps 101 harpoon historical history horror hugo 2014 hugo 2015 hugo 2016 hugo 2017 hugo 2018 hugo 2019 hugo 2020 hugo-nebula reread in brief avoid instrumented life kickstarter learn to play leaving earth linux lovecraftiana mecha men with beards museum mystery naval non-fiction one for the brow opera perl perl weekly challenge photography podcast politics powers prediction privacy project woolsack pyracantha python quantum rail raku ranting raspberry pi reading reading boardgames social real life restaurant reviews romance rpg a day rpgs ruby rust science fiction scythe second world war security shipwreck simutrans smartphone south atlantic war squaddies stationery steampunk stuarts suburbia superheroes suspense television the resistance thirsty meeples thriller tin soldier torg toys trailers travel type 26 type 31 type 45 vietnam war war wargaming weather wives and sweethearts writing about writing x-wing young adult
Special All book reviews, All film reviews
Produced by aikakirja v0.1