RogerBW's Blog

Perl Weekly Challenge 64: summing paths and breaking words 10 June 2020

I’ve been doing the Perl Weekly Challenges. The latest involved searching for paths through a grid and breaking a word into tokens.

Given an m × n matrix with non-negative integers, write a script to find a path from top left to bottom right which minimizes the sum of all numbers along its path. You can only move either down or right at any point in time.

Another week, another breadth-first search with a FIFO buffer. Each buffer entry consists of the x,y coordinates of the current/next position, followed by the trail to date..

my @l=([0,0]);

my $s;
my @p;

while (@l) {
  my $t=shift @l;
  my @xy=splice @{$t},0,2;

Add to the trail the value of the current cell.

  push @{$t},$in[$xy[0]][$xy[1]];

If this is the bottom right cell…

  if ($t->[-1] == $in[-1][-1]) {

Here's the big inefficiency; I could keep the sum-to-date in that buffer too rather than calculating the whole thing each time.

    my $sa=sum(@{$t});

But if that sum is less than the lowest sum found so far (or we haven't found one yet), set the lowest sum to this, and log the trail. (We only need one lowest-value trail, not all of them.)

    if (!defined $s || $sa < $s) {
      $s=$sa;
      @p=@{$t};
    }
  }

In any case, if (x+1,y) lies inside the array, try that later.

  if ($xy[0] < $#in && $xy[1] <= $#{$in[$xy[0]+1]}) {
    push @l,[$xy[0]+1,$xy[1],@{$t}];
  }

If (x,y+1) lies inside the array, try that later too.

  if ($xy[1] < $#{$in[$xy[0]]}) {
    push @l,[$xy[0],$xy[1]+1,@{$t}];
  }
}

Then print the output in the desired form.

binmode STDOUT,':utf8';
print "$s ( ".join(' → ',@p)." )\n";

I decided to beat Raku until it behaved.

my @l=((0,0),);

my $s='';
my @p;

while (@l) {

For once, flat seems to be enough.

  my @t=(shift @l).flat;
  my @xy=splice @t,0,2;
  push @t,@in[@xy[0]][@xy[1]];

This is of course a much cleaner syntax than $in[-1][-1] that we used in Perl.

  if (@t[@t.end] == @in[@in.end][@in[@in.end].end]) {
    my $sa=sum(@t);
    if ($s eq '' || $sa < $s) {
      $s=$sa;
      @p=@t;
    }
  }

And the maps get the array-squashing job done.

  if (@xy[0] < @in.end && @xy[1] <= @in[@xy[0]+1].end) {
    push @l,(@xy[0]+1,@xy[1],map {$_},@t);
  }
  if (@xy[1] < @in[@xy[0]].end) {
    push @l,(@xy[0],@xy[1]+1,map {$_},@t);
  }
}

say "$s ( " ~ join(' → ',@p) ~ " )";

You are given a string $S and an array of words @W.

Write a script to find out if $S can be split into sequence of one or more words as in the given @W.

Print the all the words if found otherwise print 0.

There's no word-splitting here, just an attempt to construct the longer string from the shorter ones. And guess what, it's another breadth-first search with a FIFO buffer.

my $sl=length($S);

my @l;
my $done=0;

while (!$done) {
  my $c=[];
  if (@l) {
    $c=shift @l;
  }

$c is the list of words used thus far; $cc is their concatenation.

  my $cc=join('',@{$c});
  foreach my $wc (@W) {

$ccw is the concatenation of $cc with the candidate word, and $ccwl is its length.

    my $ccw=$cc.$wc;
    my $ccwl=length($ccw);

So if $ccw is longer than the source string, it can be discarded. If it's exactly the same length and it matches, we have a solution. If it's shorter and it matches, add this sequence to the buffer for later extension.

    if ($ccwl <= $sl) {
      if (index($S,$ccw)==0) {
        push @l,[@{$c},$wc];
        if ($ccwl == $sl) {
          $done=1;
          last;
        }
      }
    }
  }
  unless (@l) {
    last;
  }
}

The solution is in the last entry in @l.

if (@l) {
  print join(', ',map {'"' . $_ . '"'} @{$l[-1]}),"\n";
} else {
  print "0\n";
}

Raku needs a bit more tweaking… chars instead of length, mostly, but also a two-stage test of index (because it now returns Nil rather than -1 when there's no match, which generates a warning if you use it in a numeric comparison)

    if ($ccwl <= $sl) {
      with index($S,$ccw) -> $i {

And then there's a whole intermediate variable needed in order to get the right structure pushed into the buffer.

        if ($i==0) {
          my @q=@c;
          push @q,$wc;
          push @l,@q;
          if ($ccwl == $sl) {
            $done=1;
            last;
          }
        }

The more Raku I write, the more I realise there is basically no project in which I'd choose to use it rather than any other language I know. The neat bits of syntax, while very neat indeed, are not for me sufficient compensation for the loss of CPAN when moving from Perl, and it's dog-slow to boot.

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 food garmin drive gazebo 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 humour 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 quantum rail ranting raspberry pi reading reading boardgames social real life restaurant reviews romance rpg a day rpgs 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