Actions from James Curtis-Smith Movable Type Pro 4.38 2021-03-26T22:26:28Z http://blogs.perl.org/mt/mt-cp.cgi?__mode=feed&_type=actions&blog_id=0&id=5073 Posted Perl weekly challenge 105 to James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10157 2021-03-26T22:26:28Z 2021-03-26T23:01:21Z Here are solutions to this weeks challenges from the Perl Weekly Challenge. You can find my full code on Github Nth root You are given positive numbers \$N and \$k. Write a script to find out the \$Nth root of... James Curtis-Smith http://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3569&id=5073 Here are solutions to this weeks challenges from the Perl Weekly Challenge.

You can find my full code on Github

### Nth root

You are given positive numbers \$N and \$k.

Write a script to find out the \$Nth root of \$k.

#### The solution

I decided that I would not go the easy way this week and just use the power function `**` i.e. `return \$k**(1/\$N)`.

Instead for integer values of \$N, solve this with only using the simple mathematical operators `+, /, *, -, <, >`

To do this we will use a divide and conquer solution, starting at the two ends of the interval we calculate the values of x^N, and then iterate reducing the interval in half - choosing the interval where the value of x^N is less than k at the left hand end & x^N is greater than k.

To do this we store the value of the ends of the interval as l and r respectively and computer the Nth power of each (ln & rn).

We then do the same for the midpoint m = (l+r)/2

We replace the left values with the new mid values if m^N > k, and if not replace the right values with the mid values

The interval halves in size each time - so repeat until the gap is small..

``````sub nth_root {
my( \$n, \$k ) = @_;
sub pow {
my \$res = 1;
\$res *= \$_ foreach 1..\$_;
return \$res;
}
my \$l = 0;
my \$r = '1'.'0'x (1+ int(length(int \$k)/\$n) );
\$r = \$k if \$r>\$k;
my \$m; # This is the midpoint...
my(\$ln,\$rn) = (1, pow(\$r,\$n));
while( \$r-\$l > 1e-10) {
my \$mn = pow(\$m = (\$r+\$l)/2,\$n);
if(\$mn<\$k) {
(\$l,\$ln) = (\$m,\$mn);
next;
}
(\$r,\$rn) = (\$m,\$mn);
}
return sprintf '%0.8f',\$m;
}``````

You will note a quirky bit of code that defines the initial r - rather than choosing the right hand side of the interval we note that we can guess a better r based purely on the length of the string. e.g. when N = 5, we know that if k < 100_000 then the Nth route must be less than 10, if k < 10_000_000_000 then the Nth root is less than 100.

We can extrapolate this by dividing the length of the string representation of k by N to get the approximate max value represented by 1 and a number of 0s.

### The name game

I will leave you to read the description on the challenge itself or the wiki page https://en.wikipedia.org/wiki/The_Name_Game

The simple rule states that if your name starts with a consonant that is stripped and substituted in different places,

There are special rules for b, f, m,

If the word starts with vowels, you strip the vowels and the first consonant

There are also rules defined that you remove the first syllable - but as finding syllables is difficult I will avoid this.

We will use 2 nice features of Perl this week

• The one I use quite a lot which is the regex modifier to return the replaced string
But note \$1 etc are defined as when doing a match so you can still use them, in this case we use it to handle the special cases where the letter removed is one of b, f or m.
• sprintf - with `%1\$...` substitutions.
Normally we just use `%s` to specify where to insert each entry in the parameters into the substitution string - but you can specify which parameter goes where by add int n between the % and the definition.
This allows us repeat substitution strings without duplicating them in the list passed in, and/or change the order of the substitution. This is really useful if you have a series of templates you wish to choose from.
``````
my \$TEMPLATE = '%1\$s, %1\$s, bo-%3\$s%2\$s
Bonana-fanna fo-%4\$s%2\$s
Fee fi mo-%5\$s%2\$s
%1\$s!
';
my \$REGEX = '^[aeiou]*([bcdfghjklmnpqrstvwxyz])';

print map { the_name_game( \$_ ) }
qw(Katie Lucy James Bob
Fred Mike Aaron Abel);

``````sub the_name_game {
return sprintf \$TEMPLATE,
\$_, \$_=~s{\$REGEX}{}ri,
map { \$_ eq lc \$1?'':\$_ } qw(b f m);
}
``````

]]> Posted Perl weekly challenge 104 to James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10138 2021-03-16T04:53:21Z 2021-03-20T23:09:54Z Here are solutions to this weeks challenges from the Perl Weekly Challenge. You can find my full code on Github Task 1: FUSC sequence Write a script to generate first 50 members of FUSC Sequence. Please refer to OEIS for... James Curtis-Smith http://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3569&id=5073 Here are solutions to this weeks challenges from the Perl Weekly Challenge.

You can find my full code on Github

### Task 1: FUSC sequence

Write a script to generate first 50 members of FUSC Sequence. Please refer to OEIS for more information.

The sequence defined as below:

```fusc(0) = 0
fusc(1) = 1
for n > 1:
when n is even: fusc(n) = fusc(n / 2),
when n is odd:  fusc(n) = fusc((n-1)/2) + fusc((n+1)/2)
```

#### Solution

I will show you 4 versions of the code below - they essentially non-cached/cached versions of recursive (naive) code to get an individual element, and a non-recursive version to compute the whole sequence.

``````sub fusc {
my \$n = shift;
return \$n<2 ? \$n : fusc(\$n>>1) + ( \$n&1 ? fusc(1+\$n>>1) : 0 );
}``````

Notes:

• Rather than using arithmetic operators here - we use binary operators - as we are checking for even (last bit set) or dividing by 2 (right it shift)

• \$n & 1 is faster than \$n%2

• By using bit shift operators here rather than divide by 2 - the code is faster and also avoids the need for adding an additional `int` as the bit-shift operator drops the last bit anyway!

• We can split the numbers into one of 3 cases:

• n < 2 - Then the return value is just n;

• n is even - this is just the entry at index n/2 - which we can also think of as floor( n/2 );

• n is odd - this is just the sum of entries at index (n-1)/2 & (n+1)/2- which we can also think of as floor( n/2 ) + 1 + floor( n/2 );

• We can write this as nested ternary operators - but note we can re-phrase the last two cases as floor(n/2) plus, if n is odd 1+floor(n/2).

To add caching in this case we just use a state variable which contains all the values - as the index is numeric we can use an array here rather than a hash.

``````sub fusc_cache {
my \$n = shift;
state @cache;
return \$cache[\$n] ||= \$n<2 ? \$n :
fusc_cache(\$n>>1) + ( \$n&1 ? fusc_cache(1+\$n>>1) : 0 );
}``````

#### Non-recursive

In all these cases we wish to avoid the overhead of recursion - even with caching there is a great overhead in the stack management of the function calls - it isn't always possible - but it is in this case.

In this example we store the sequence in an array and push the subsequence fusc numbers on to the end of it.

• We note we have two ways of extending the list odd and even - so we can right logic to work out which one we are needing - or we can realise that we can push 2 values at a time, one for the next odd element and one for the next even element, this simplifies the code somewhat...
• Because we push 2 at a time - we only need to run through the loop half the numbers of times - from 1 .. n/2-1
• We do need to specify and extra seed value (for n=2)
• When n is even we generate an extra entry - so we just remove it with a `pop` at the end.
``````sub fusc_seq {
my \$n = shift;
return 0..\$n-1 if \$n<2;
my   @seq = (0,1,1);
push @seq, \$seq[\$_]+\$seq[\$_+1], \$seq[\$_+1] foreach 1..\$n/2-1;
pop  @seq unless \$n&1;
return @seq;
}``````

The cached version is similar - we just make the variable `@seq` a `state` variable and it is remembered between calls, we then only need to start at the top of the cache and add new elements on -- we start at `@seq/2` rather than `1` like in the code above.

The cache now may be much larger than the sequence length we want, so we just use an array slice to return the parts we want

``````sub fusc_seq_cache {
my \$n = shift;
state  @seq = (0,1,1);
push   @seq, \$seq[\$_]+\$seq[\$_+1], \$seq[\$_+1] foreach @seq/2..\$n/2-1;
return @seq[0..\$n-1];
}``````

### Task 2: NIM Game

Write a script to simulate the NIM Game.

It is played between 2 players. For the purpose of this task, let assume you play against the machine.

There are 3 simple rules to follow:

1. You have 12 tokens
2. Each player can pick 1, 2 or 3 tokens at a time
3. The player who picks the last token wins the game

#### The solution

There is some flexibility in this weeks challenge - as to how to simulate the game. I'm going to write two versions, one where the computer plays randomly - and one where it plays the optimal solution.

Rather than having human interaction - I'm also playing the human player randomly...

``````sub simulate {
my(\$tokens,\$player,\$n) = (12,1,'');
while(1) {
\$n = 1 + int rand 3;
last if \$n >= \$tokens;
\$tokens-=\$n;
say "Player \$player takes \$n token(s) and leaves \$tokens token(s)";
\$player = 3-\$player;
}
say "Player \$player takes the last \$n token(s) and wins...\n";
}``````

Notes:

• We use a `while(1)` loop with `last` as it simplifies the logic.

• To flip the player number from 1 to 2 and v.v. then we just subtract it from 3 - a classic coding trick so we don't need the ternary `\$player = \$player==1 ? 2 : 1`

#### Optimal solution (computer always wins!)

In some ways the optimal player 2 solution is easier as it doesn't need to keep track of players.. Basically whatever player 1 (human) does player 2 (computer) takes tokens so that there are a multiple of 4 left. Human takes n computer takes 4-n.

``````sub simulate_player2 {
my \$tokens = 12;
while(1) {
my \$n = 1 + int rand 3;
\$tokens -= \$n;
say "Player 1 takes \$n token(s) and leaves \$tokens token(s)";
\$n = 4-\$n;
print "Player 2 takes \$n token(s) and ";
\$tokens -= \$n;
last unless \$tokens;
say "leaves \$tokens tokens";
}
say "wins...\n";
}``````

]]>
Posted Perl weekly challenge 103 to James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10127 2021-03-12T23:35:58Z 2021-03-13T00:14:00Z Here are solutions to this weeks challenges from the Perl Weekly Challenge. You can find my full code on Github Task 1: Chinese zodiac You are given a year \$year. The animal cycle: Rat, Ox, Tiger, Rabbit, Dragon, Snake, Horse,... James Curtis-Smith http://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3569&id=5073 Here are solutions to this weeks challenges from the Perl Weekly Challenge.

You can find my full code on Github

### Task 1: Chinese zodiac

You are given a year \$year.

The animal cycle: Rat, Ox, Tiger, Rabbit, Dragon, Snake, Horse, Goat, Monkey, Rooster, Dog, Pig.

The element cycle: Wood, Fire, Earth, Metal, Water.

Additionally there is a two year cycle between Yin & Yang

This challenge is a relatively simple challenge - and one perl is well suited:

``````sub year_name {
return join q( ),
qw( Yang   Yin                             )[  \$_    %  2 ],
qw( Metal  Water   Wood   Fire  Earth      )[ (\$_/2) %  5 ],
qw( Monkey Rooster Dog    Pig   Rat   Ox
Tiger  Rabbit  Dragon Snake Horse Goat )[  \$_    % 12 ];
}``````

As the names cycle then we can use the modulus operator `%`. The the animal is a 12 year cycle, the Yin/Yang is a two year cycle (actually it's part of a 10 year cycle when you combine it with the elements).

The trick to make the code shorter is to realise you need to rotate the lists so they start with the values that year "0" would have - then it is just a simple modulus operator - rather than having to do a shift first `\$y%12` rather than the less clean `(\$x-8)%12`.

### TASK #2 › What’s playing?

A slightly longer task (to read), you have a track/episode list which contains the length of each track in milliseconds. This will loop continuously. Given a start time, and an end time - which track was the last you were looking at...

``````sub position {
my (\$start, \$now, \$filename ) = @_;
my \$tot_duration  = 0;
open my \$fh, q(<), \$filename;
\$tot_duration += \$_->
foreach my @episodes = map { [split m{,?"}] } <\$fh>; #"fix colour
close \$fh;
my \$position =  1000 * (\$now-\$start) % \$tot_duration;
foreach( @episodes )  {
return sprintf '%s @ %02d:%02d:%02d',
\$_->,
int( \$position/3600000 )     ,
int( \$position/  60000 ) % 60,
int( \$position/   1000 ) % 60  if \$position < \$_->;
\$position -= \$_->;
}
}``````

The first part of the task was to slurp in csv file. Now we know the format as a file - so we cheat a little bit, we know we need to cut the string at '`,"`' and '`"`. Rather than load in a CSV module to do this we can just use split to do that - we
do that in one line by using `map {...} <..>`.

OK - so I must admit a slight gold trick here... We can in the same statement add up the values of the lengths for each track (we will need this again shortly).

Rather than looping through until we get to the finish time, we can short cut the first loops by using the same `%` modulus sign above to work out where through the list we are in the last loop. Then it is a simple loop through the episodes to work out in which one we finish.

Finally it's just a case of using `sprintf` to format everything as required.

]]>
Posted Perl weekly challenge 102 to James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10115 2021-03-04T07:06:22Z 2021-03-04T13:44:16Z Here are solutions to this weeks challenges from the Perl Weekly Challenge. You can find my full code on Github Task 1: Rare Numbers You are given a positive integer \$N. Write a script to generate all Rare numbers of... James Curtis-Smith http://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3569&id=5073 Here are solutions to this weeks challenges from the Perl Weekly Challenge.

You can find my full code on Github

### Task 1: Rare Numbers

You are given a positive integer \$N. Write a script to generate all Rare numbers of size \$N if exists. Please checkout the page for more information about it.

#### Examples:

• 2 digits: 65
• 6 digits: 621,770
• 9 digits: 281,089,082

#### The solution

There is a very naive solution to this problem.

``````#!/usr/local/bin/perl

use strict;

use warnings;
use feature qw(say);
use Test::More;

my @rare_ends = ( [2,], [4,], [6,[0,5]], [8,[2,3,7,8]] );

is( "@{[ rare_numbers( 2  ) ]}", '65' );
is( "@{[ rare_numbers( 6  ) ]}", '621770' );
is( "@{[ rare_numbers( 9  ) ]}", '281089082' );

done_testing();

``````sub rare_numbers {
my \$size = shift;
my @ret;
my \$y;
foreach( 10**(\$size-1) .. 10**\$size - 1 ) {
\$y = reverse \$_;
push @ret, \$_ if \$_ > \$y
&& (\$_-\$y) == (int sqrt(\$_-\$y))**2
&& (\$_+\$y) == (int sqrt(\$_+\$y))**2;
}
return @ret;
}``````

This naive approach though takes around 5 minutes on my linux box to run {most of the time is the loop through 10 billion numbers to get the answer for 9 digits...}

This really is impractical even for 10 digits - taking roughly and hour and (I'm guessing) 5 or 6 days to get the next number (with 12 digits), going up to 2 months, and 2 years for the answers for 13 and 14 digits...

We need to scale this back down to a reasonable number..

There are a number of different rules that drive both the first and last digits, and subsequently the second and penultimate digits.

If we encode this into the code we reduce the search space considerably.

On top of that it has been proven that the digit sum has to be 9, or rewriting that the number itself modulo 9 has to be zero;

Finally we can optimize the square check as we know squares must end in either 0, 1, 2, 4, 5, 6 or 9, and also cache the value of the this check as there will be numerous cases where we know that the difference between the two numbers will be the same. This leads us to the following code...

``````#!/usr/local/bin/perl

use strict;

use warnings;
use feature qw(say state);
use Test::More;

is( "@{[ rare_numbers( 2  ) ]}", '65' );
is( "@{[ rare_numbers( 6  ) ]}", '621770' );
is( "@{[ rare_numbers( 9  ) ]}", '281089082' );
is( "@{[ rare_numbers( 10 ) ]}", "2022652202 2042832002" );

done_testing();

sub rare_numbers {
my \$size = shift;
return () if \$size < 2; ## No solutions for size <2 as the
## as the number is the reverse
## of itself so will fail the \$x!=\$y
## constraint
## List of start/end values
my @rare_ends = ( [2,], [4,], [6,[0,5]], [8,[2,3,7,8]] );
my @F=(0,1,0,1,1,0,1,1,0); ## rare_numbers have a digit sum
## (value mod 9) of either 9/0,2,5 or 8
sub is_rare {
sub is_sq {
state %cache;
return \$cache{\$_} if exists \$cache{\$_};
return \$cache{\$_} = \$_ =~ m{\$} &&
\$_ == (int sqrt \$_)**2;
}

my \$x = shift;
return () if \$F[\$x%9]; ## Digit sum is wrong...
my \$y = reverse \$x;
return () if \$x == \$y; ## Musn't be the same back and forth
return \$y if \$x<\$y && is_sq(\$x+\$y) && is_sq(\$y-\$x);
## Check both ways round!
return \$x if \$y<\$x && is_sq(\$x+\$y) && is_sq(\$x-\$y);
return ();
}

my %res;
my \$low  = \$size <= 4 ? '' : '0' x (\$size-4);
my \$high = \$size <= 4 ? '' : '9' x (\$size-4);
foreach my \$tup ( @rare_ends ) {
my \$s = \$tup->;             ## first digit has to be even 2,4,6,8
foreach my \$e (@{\$tup->}) { ## second digit has to be in list
## at start...
if( \$size == 2 ) {           ## As our method really starts at 4
## let us deal with 2 & 3 cases first
## as the optimized code is for
## numbers of length 4 or more
\$res{\$_}=1 foreach is_rare("\$s\$e");
next;
}
if( \$size == 3 ) {
\$res{\$_}=1 foreach map { is_rare("\$s\$_\$e") } 0..9;
next;
}

``````      ## Now we need to do the next group....
foreach my \$b (0..9) {    ## These are filters to apply
foreach my \$f (0..9) {  ## for each group of numbers....
next if \$s==2 && \$b!=\$f
|| \$s==4 && (\$b-\$f)%2
|| \$s==6 && ! (\$b-\$f)%2
|| \$s==8 && (
\$e==2 && \$b+\$f!=9
|| \$e==3 && \$b-\$f!=7 && \$f-\$b !=3
|| \$e==7 && \$b+\$f!=1 && \$b+\$f !=11
|| \$e==8 && \$b!=\$f
);
## Now we try all additional numbers....
## The sequence '000' .. '999' gives all 3 digit numbers.... !
\$res{\$_}=1 foreach map { is_rare("\$s\$b\$_\$f\$e") } \$low..\$high;
}
}
}
}
return sort keys %res;
}``````

#### Notes

• Rather than having to do a `sprintf` to get a sequence of numbers of length n we can use the "string" version of the range to go from "000.." to "999.."

• We can write the inner loop in a single line given that the is_rare function returns either an empty array of the rare number themselves.

• Finally we don't use the array - as we may return the same rare numbers twice, show use the hash key trick to weed out duplicates.

### Task 2: Hash-counting String

Write a script to produce Hash-counting string of that length.

The definition of a hash-counting string is as follows:

• the string consists only of digits 0-9 and hashes, ‘#’
• there are no two consecutive hashes: ‘##’ does not appear in your string
• the last character is a hash
• the number immediately preceding each hash (if it exists) is the position of that hash in the string, with the position being counted up from 1

It can be shown that for every positive integer N there is exactly one such length-N string.

#### Examples:

• "#" is the counting string of length 1
• "2#" is the counting string of length 2
• "#3#" is the string of length 3
• "#3#5#7#10#" is the string of length 10
• "2#4#6#8#11#14#" is the string of length 14

#### The solution

Usually challenge 1 is the easiest solution but this week I think is an exception - although there is an easy solution to challenge 1 - the faster (optimized) one needs extra work.

With many of these problems there are two ways to solve this - we can start at one end or the other.

If we go forward we occasionally get to a point where we have to make a decision both sequences consisting of n `9`s and a `1` and n `9`s are valid at certain points.
So for length 9 we have "`#3#5#7#9#`" and length 10 we have "`#3#5#7#10#`"... Having to continue along two paths is always going to make things harder.

If we go backwards we don't have the same problem - we know the location of the "`#`" so we have no branching point. As we add the "n`#`" to the end of the string - then the remainder of the string is just the solution for n-1-length of n, with 1 exception if n is 1 - we just don't include the n. This leads to thoughts or recursion - or a simple loop. We though want to avoid the overhead of recursion if we can....

This reduces to something quite simple. We repeat until we get to the case we can't add "n`#`" anymore. One of the nice features of Perl is being able to modify more than one variable at a time with `(\$a,\$b)=(\$c,\$d)`. We can use this here to reduce the loop to a single line. At the end of the loop we get to the case when n is 0 or 1 - in the latter case we just need to prefix a "`#`" we could use a ternary `?:` but in this case we can simplify the code down by using string multiplication `x`. As we need one copy of `#` if n is 1 and none if it is 0.

``````sub hash_count_string {
my ( \$s, \$n ) = ( '',      @_            );
( \$s, \$n ) = ( "\$n#\$s", \$n-1-length\$n ) while \$n > 1;
return '#'x\$n.\$s;
}``````
]]>
Posted Perl weekly challenge 101 to James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10102 2021-02-23T05:20:05Z 2021-02-27T14:05:58Z Here are solutions to this weeks challenges from the Perl Weekly Challenge. You can find my full code on Github Task 1: Pack a Spiral You are given an array @A of items (integers say, but they can be anything).... James Curtis-Smith http://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3569&id=5073 Here are solutions to this weeks challenges from the Perl Weekly Challenge.

You can find my full code on Github

### Task 1: Pack a Spiral

You are given an array @A of items (integers say, but they can be anything).

Your task is to pack that array into an MxN matrix spirally counterclockwise, as tightly as possible.

‘Tightly’ means the absolute value |M-N| of the difference has to be as small as possible.

```(1..4)  ->  4 3
1 2
(1..6)  ->  6 5 4   5 4
1 2 3   6 3
1 2

(1..12) ->  9  8  7  6    8  7  6
10 11 12  5    9 12  5
1  2  3  4   10 11  4
1  2  3
```

#### The solution

No attempting at real golfing this week - but still want to keep it "minimalist"...

Our `pack_spiral` routine starts by finding the largest factor of the size of the list below sqrt of the size of the list. The two dimensions we will need are this (`\$rows`) and `\$cols`. Just for compactness when printing we chose it so that `\$rows < \$cols`.

To compute the number of rows (\$rows) this is the largest number < sqrt of the number of elements (N) which is a factor of N. We can use grep to get all factors - if we reverse this the highest factor is the first element of the list...

``````sub pack_spiral {
my( \$rows )               = reverse grep { ! (@_ % \$_) } 1 .. sqrt @_;
my( \$cols, \$r, \$c, @out ) = ( @_/\$rows, \$rows-1, -1 );

``````  while( @_ ) {                                      # do until empty
\$out[ \$r ][ ++\$c ] = shift foreach 1 .. \$cols--; # >>
\$out[ --\$r ][ \$c ] = shift foreach 1 .. --\$rows; # ^^
last                       unless  @_;           # exit if empty
\$out[ \$r ][ --\$c ] = shift foreach 1 .. \$cols--; # <<
\$out[ ++\$r ][ \$c ] = shift foreach 1 .. --\$rows; # vv
}
return \@out;
}``````

We work around the spiral starting bottom left - and then work our way right `++\$c`, up `--\$r`, left `--\$c` & down `++\$r`. Each time when we draw one less column (when going left or right) and one less row (when going up or down) - hence the `\$cols--` & `--\$rows`.

Notes: `shift` by itself shifts off the magic "@_" array - so in our cases takes the next item of the list...

You can see the progress below:

```       [__]  [__]  [__]  [__]

[__]  [__]  [__]  [__]

(st)  [__]  [__]  [__]  [__]

\$rows = 3; \$cols = 4; \$r = 2; \$c = -1; @_=12;
\$out[ \$r ][ ++\$c ] = shift foreach 1 .. \$cols--;
< 4 >
[__]  [__]  [__]  [__]

[__]  [__]  [__]  [__]

st ->[_1]->[_2]->[_3]->(_4)

\$rows = 3; \$cols = 3; \$r = 2; \$c = 3; @_=8;
\$out[ --\$r ][ \$c ] = shift foreach 1 .. --\$rows;
< 2 >
[__]  [__]  [__]  (_6)
^^
[__]  [  ]  [  ]  [_5]
^^
st   [_1]->[_2]->[_3]->[_4]

\$rows = 2; \$cols = 3; \$r = 0; \$c = 3;  @_=6;
\$out[ \$r ][ ++\$c ] = shift foreach 1 .. \$cols--;
< 3 >
(_9)<-[_8]<-[_7]<-[_6]
^^
[__]  [  ]  [  ]  [_5]
^^
st   [_1]->[_2]->[_3]->[_4]

\$rows = 2; \$cols = 2; \$r = 0; \$c = 0;  @_=3;
\$out[ ++\$r ][ \$c ] = shift foreach 1 .. --\$rows;
< 1 >

[_9]<-[_8]<-[_7]<-[_6]
vv                ^^
(10)  [  ]  [  ]  [_5]
^^
st   [_1]->[_2]->[_3]->[_4]

\$rows = 1; \$cols = 2; \$r = 1; \$c = 0;  @_=1;
\$out[ \$r ][ ++\$c ] = shift foreach 1 .. \$cols--;
< 2 >
[_9]<-[_8]<-[_7]<-[_6]
vv                ^^
->->(12)  [_5]
^^
st   [_1]->[_2]->[_3]->[_4]

\$rows = 1; \$cols = 1; \$r = 1; \$c = 2;  @_=0;
\$out[ --\$r ][ \$c ] = shift foreach 1 .. --\$rows; # does nothing..
< 0 >

[_9]<-[_8]<-[_7]<-[_6]
vv                ^^
->->(12)  [_5]
^^
st   [_1]->[_2]->[_3]->[_4]```

### Task 2: Origin-containing Triangle

You are given three points in the plane, as a list of six co-ordinates: A=(x1,y1), B=(x2,y2) and C=(x3,y3).

Write a script to find out if the triangle formed by the given three co-ordinates contain origin (0,0).

Print 1 if found otherwise 0.

```Input: A=(0,1) B=(1,0)  C=(2,2)   Output: 0
Input: A=(1,1) B=(-1,1) C=(0,-3)  Output: 1
Input: A=(0,1) B=(2,0)  C=(-6,0)  Output: 1
```

#### The solution

One of the uses I put my degree to at work was to use "Winding numbers" to replicate image maps in web pages {we needed to implement drag features and click feature on an image}... So winding numbers are what I will use here...

Winding number - imagine you are a dalek standing at the origin - and you trace around the triangle with your gunstick... If your head turns a full 360 either way then you are in the triangle - if it does not you are outside the triangle! This extends to any shape - you are inside the shape if you take an odd number of turns - outside if you take an even number. The following code is a quick way to compute the winding number.

To include each line - we start with the last point and join it to the first... and then first to second until we finally get back to the line between the last two points.

``````sub winding_number {
my ( \$a, \$b, \$wn ) = @_[ -2, -1 ], 0;

``````  while( my(\$x,\$y) = splice @_, 0, 2 ) {
\$wn += \$a<=0 ? \$y>0  && \$a*\$y-\$x*\$b >  0 ?  1 : 0
: \$y<=0 && \$a*\$y-\$x*\$b <= 0 ? -1 : 0;
(\$a,\$b)=(\$x,\$y);
}
return \$wn%2;
}``````

]]>
Posted Perl weekly challenge 100 to James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10095 2021-02-16T12:56:25Z 2021-02-17T06:11:15Z We are finally here - we have hit week 100 of Manwar's Perl Weekly Challenges, and here are solutions to this weeks challenges from the Perl Weekly Challenge. You can find my full code on Github Task 1: Fun time... James Curtis-Smith http://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3569&id=5073 We are finally here - we have hit week 100 of Manwar's Perl Weekly Challenges, and here are solutions to this weeks challenges from the Perl Weekly Challenge.

You can find my full code on Github

### Task 1: Fun time

You are given a time (12 hour / 24 hour). Write a script to convert the given time from 12 hour format to 24 hour format and vice versa. Ideally we expect a one-liner.
```Example 1: Input: 05:15 pm or 05:15pm -> Output: 17:15
Example 2: Input: 19:15               -> Output: 07:15 pm or 07:15pm
```

#### The solution

Firstly I have to thank Manwar for asking for a one line solution as this is my modus operandi.... So we will look at this and see how we can get a simple yet compact solution... well here goes.... {code is 110 bytes, within the functions curly braces there are just 102 bytes of code}
``````
sub ft{pop=~s/(.+)(:..)\s*(.m|)/sprintf'%02d%s%s',
(\$1%12||(12*!\$3))+12*('pm'eq\$3),\$2,\$3?'':\$1<12?'am':'pm'/re}
``````

Let me try and explain the logic in this.

Firstly what is the smallest regex we can use to distinguish between 12 hour and 24 hour clock times (assuming that the value is either)

First pass we try /\A(\d\d):(\d\d)\s*([ap]m)?\Z/.

How can we simplify this?

• We don't need to anchor the ends so we can remove the \A and \Z
• ** /(\d\d):(\d\d)\s*([ap]m)?/
• We don't need to know that the numbers are numbers just they are of the form something-something-:-something-something, and we only need to know that we have something-m at the end if 12 hour clock
• ** /(.+):(..)\s*([ap]m)?/
• For later it would be useful if we captured the : with the minutes saves us a byte in the sprintf.
• ** /(.+)(:..)\s*([ap]m)?/
• Finally again for later we want don't want to check whether or not \$3 exists we can re-write (.m)? as (.m|) to achieve this.
• ** /(.+)(:..)\s*(.m|)/

So we end up with: /(.+)(:..)\s*(.m|)/

Now for the replace logic.

• For the hours: If 24 hour clock we reduce the number modulo 12 (but if it is 0 we use 12 instead)
We user "||" for this as if the first value is 0 we use the 2nd values...
\$1%12||(12*!\$3)
• For the hours: If 12 hour clock we reduce the number module 12 (and add 12 if it is pm)
(\$1%12)+12*('pm'eq\$3)
We use a yoda condition to shorten the perl by putting the constant before the eq and the variable after we don't need a space between the variable name and the eq.
• For the minutes: Minutes stay the same
• For the suffix: If 12 hour clock we do nothing
• For the suffix: If < 12 we return am o/w we return pm

Other things

• We use s///er to both evaluate a function based on the matches and return the replaced string
• One minor thing - rather than using shift to get the parameter passed we use pop as this is two bytes shorter
``````sub fun_time {
return pop =~
## Note the nasty hack we pop rather than shift - that saves 2 bytes
## in our golfdom....
s/
## Split into 3 parts, \$1 - hours, \$2 - minutes & \$3 - am/pm
(.+) (:..) \s* ( .m | )
## We assume all strings are valid - so we don't have to anchor
## at both ends or worry what the 12hr clock sufficies are
## am/pm and .m is shorter than [ap]m
##
## We assume that the time will always have a : followed
## 2 digits...
##
## Note if we right (.m)? the 3rd capture variable \$3 is
## sometimes undefined - better is to use (.m|) which
## matches the same way but \$3 is now an empty string not
## undefined when we have a 24 hour clock time
/
sprintf '%02d%s%s',
( \$1 % 12 || ( 12 * ! \$3 ) ) + 12 * ( 'pm' eq \$3 ),
## Get hour modulo 12..
## From 24hr to 12hr clock we need to convert 00:?? to 12:??
## From 12hr to 24hr clock it is pm we then need to add 12...
## Note we use the "yoda condition" for the equals
##   'pm'eq\$3
## as this is a byte shorter than the more usual way of
## writing inequalitys
##   \$3 eq'pm'
## as we don't need a space between the \$3 & the eq...
\$2,
## The minutes is the easy bit just copy..
\$3 ? '' : \$1 < 12 ? 'am' : 'pm'
## If we are converting from 12hr clock the third string is
## empty - if not and the time is <12 we return am o/w  pm
/rex;
}
``````

#### Some notes on golfing

1. Doing everything inside the regex using `/re` modifiers... `/e` most people will know is "execute", `/r` is return the replacement - not replace in place.
2. Normally we would use `shift` to get the parameter of the subroutine, but in this case we know we have one parameter so we can use `pop` instead - saves 2 characters!
3. The regex isn't specific - we aren't really using it to match we are using it to extract characters from the parameter
4. `!\$var` - returns `1` if the `\$var` is `''`/`undef`/`0`, `0` otherwise - in this case if we are converting to 12hr clock we don't tend to write 0:01am but 12:01am so we need to add `12` if the first number is `0` & match var `\$3` is empty...
5. Talking of match var 3 most people would write `(.m|)` as `(.m)?` but if you are running under `use strict`/`use warnings` this throws an undefined variable warning... as `\$3` is undefined if you don't match - on the other hand `(.m|)` returns a match or the empty string!
6. "`'pm'eq\$3`" - a "yoda condition" - use it we do - to save a byte. If we wrote it the way you would expect to use "`\$3 eq 'pm'`" you have to have a space between the "`3`" and the "`eq`" by writing it as a yoda condition you don't as you don't need a space between "`'`" and "`eq`" and "`eq`" and "`\$`"
7. We could use another ternary here as well `('pm'eq\$3?12:0)` but that would be longer... but we know the match returns `1` (true) or `0` (false) so we can just multiply...

There will some more "golf" tricks in task 2.... Just a little note - if you are golfing then it is good to use TDD (Test Driven Design) and define tests so that you can make sure that the little tweaks - the removal of a symbol here or the tweak of the way a comparison is done - doesn't change the result. I use `Test::More` to define the tests.

### Task 2: Triangle sum

You are given triangle array. Write a script to find the minimum path sum from top to bottom. When you are on index i on the current row then you may move to either index i or index i + 1 on the next row.
```Example 1:
Input: Triangle = [ , [2,4], [6,4,9], [5,1,7,2] ]
Output: 8

Explanation: The given triangle

1
2 4
6 4 9
5 1 7 2

The minimum path sum from top to bottom:  1 + 2 + 4 + 1 = 8


  4
6  9
5  7 2
Example 2:
Input: Triangle = [ , [3,1], [5,2,3], [4,3,1,3] ]
Output: 7

Explanation: The given triangle

3
3 1
5 2 3
4 3 1 3

The minimum path sum from top to bottom: 3 + 1 + 2 + 1 = 7


3  
5  3
4 3  3
```

#### The solution

There are literally two directions you can go with this problem, quite literally up and down.

The first thought is to go down - there is a relatively simple recursive solution and another which tries all paths - but these are effectively O(n2^n) complexity.

Then we can look at going up... We take off the last row of the triangle and merge it into the line before - adding to it the minimum of it's two "children". Repeating until we only have one cell. this is O(n^2) complexity.

Even for the examples here there is a considerable (4 fold) gain over the descent methods.

``````sub triangle_sum {
## Make a deep copy as code is destructive
my @tri = map { @{\$_} } @_;
while(@tri>1) {
## Strip off base of triangle...
my \$b = pop @tri;
## Update new last line by adding smallest of it's "children"
\$tri[-1][\$_] += \$b->[\$b->[\$_]<\$b->[\$_+1]?\$_:\$_+1] for 0..@tri-1;
}
return \$tri;
}``````

#### Golfing the script

Can we write this with less lines... yes - we can 'golf' this one - but as we weren't asked to - I thought I would add this as an aside...

To make this a 1 liner we will need a couple of "golf" tricks..

1. We need to convert the inner `for` to a `map`
2. We need remove the separate `\$b = pop @tri` - we can move it into the `while` clause.
3. Here is a cool Perl fact - `\$a` & `\$b` can both be used with or without "`my`" in code even under use stricts - this is because they are "local" special variables - the two comparison variables used in `sort` blocks.

The code becomes:

``````sub triangle_sum_1point5_liner {
@_ = map { @{\$_} } @_;
@{\$_[-1]} = map {
\$_[-1][\$_] + \$b->[ \$b->[\$_] < \$b->[\$_+1] ? \$_ : \$_+1 ]
} 0..@_-1 while @{\$b=pop @_}>1;
\$b->;
}``````

Note as we do the pop in the `while` clause we need to use `\$b` rather than `\$_` (which no longer exists as we've already popped it off)

#### Aside 2 - Displaying the path

Although not asked it would be good to see if we could see the path through the triangle...

This is just really an extension of what we did in the first case - but as well as keeping the lowest total for each cell - we also keep a list of the nodes which generated that minimal sum.

As the code to get the route is destructive we first have to take a deep copy of the triangle passed in. The triangle can nicely be drawn in a single statement, by nested maps (note we do have to copy the outer loop `\$_` into another variable - again we use the local special variables `\$a`... We set it in the first part of the map array - in such a way it is hidden from the print.

Rather than concatenate - we just allow print to automatically concatenate all the strings. But there is a gotcha here - as we wrap the `map` in parentheses and `print` is a function, print will only display the contents of the parentheses, and ignore anything that follows.. To avoid this we need to make sure that the first symbol after the `print` is not an open parenthesis. To avoid this we start with the crucial `'',`. Other ways of doing this is, for a scalar is either `q().` or `0+` depending if you are returning a string or a number...

``````sub display_sum {
my @tri = map{ [@{\$_}] } @_; ## Deep copy the triangle as the
## search is destructive

my @route; ## For each node in the "current" bottom row, the route
## is the list of indices of the child nodes that make
## up the "optimal" path
## We use the implicit my on \$b

while(@{\$b = pop @tri}>1) {
(\$tri[-1][\$_],\$route[\$_]) = \$b->[\$_]<\$b->[\$_+1]
? ( \$tri[-1][\$_] + \$b->[\$_],   [\$_,  @{\$route[\$_  ]||[]}] )
: ( \$tri[-1][\$_] + \$b->[\$_+1], [\$_+1,@{\$route[\$_+1]||[]}] )
foreach 0..@tri-1;
}

@route = (0,@{\$route}); ## We need to add the top node index
## (always 0), at the same time we can
##  just take the first (only)
## path out of the 2d route matrix;

print ## Assume all cell numbers are single digits...
'',
( map {
'  ' x (@_-(\$a=\$_)), ## use implicit my on \$a;
( map {
sprintf \$route[\$a]==\$_ ? '[%d] ': ' %d  ' , \$_[\$a][\$_]
} 0..\$a ),
"\n"
} 0..@_-1 ),
"\nMinimum path: ",(join ' -> ', map {
\$_[\$_][\$route[\$_]] } 0..@_-1 ),' ; Total: ',\$b->,"\n\n";

````}````

Here is the output from the examples:

```        
  4
6    9
5    7   2

Minimum path: 1 -> 2 -> 4 -> 1 ; Total: 8


3  
5    3
4   3    3

Minimum path: 3 -> 1 -> 2 -> 1 ; Total: 7


  1
  8   9
4    1   3

Minimum path: 3 -> 3 -> 3 -> 3 ; Total: 12
```

The final one demonstrates that the minimal route does not always take the smallest value from each row. In the 2nd & 4th rows the chosen node is not the smallest - as to choose that you would also mean you would have to include the large 8 or 9 from the 3rd row.

]]>
Posted Perl weekly challenge 99 to James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10092 2021-02-12T11:55:48Z 2021-02-12T23:26:21Z Here are solutions to this weeks challenges from the Perl Weekly Challenge. You can find my full code on Github Challenge 1 You are given a string \$S and a pattern \$P. Write a script to check if given pattern... James Curtis-Smith http://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3569&id=5073 Here are solutions to this weeks challenges from the Perl Weekly Challenge.

You can find my full code on Github

### Challenge 1

You are given a string \$S and a pattern \$P.

Write a script to check if given pattern validate the entire string. Print 1 if pass otherwise 0.

The patterns can also have the following characters:

• ? - Match any single character.
• * - Match any sequence of characters.

#### Example 1:

```Input:  \$S = "abcde" \$P = "a*e"
Output: 1
```

#### Solution

This challenge is relatively simple - converting "file name" wildcards into perl regular expressions. the "*" wildcard is the same as ".*" in perl, "?" is the same as "." in perl.

So we replace them in the regex (and remembering we are tied to the ends of the string).

``````
my \$regex  = '\A' . ( \$pattern =~ s{[*]}{.*}r =~ s{[.]}{?}r ).'\Z';
``````

A few notes about generating the regex - First we use the `r` modifier to return the value of the regex rather than editing in place - secondly we use `\A` & `\Z` just out of habit rather than `^` & `\$`.

### Challenge 2

You are given two strings `\$S` and `\$T`.

Write a script to find out count of different unique subsequences matching `\$T` without changing the position of characters.

#### Example 1

```Input: \$S = "littleit', \$T = 'lit'
Output: 5

1: [lit] tleit
2: [li] t [t] leit
3: [li] ttlei [t]
4: litt [l] e [it]
5: [l] ittle [it]
```

#### Solution

This week's second problem was harder (especially as I thought my code wasn't working as this example was wrong)....

I'll outline the 3 solution functions that I created - two work out the number of sequences (one with memoization), and then a third actually returns the sequences.

The approach to all 3 is to split the string into chunks up until the occurrence of the current first letter of `\$T`.

``````sub uniq_subseq {
my( \$result, \$haystack, \$first, \$needle )
= ( 0, \$_, \$_ =~ m{(.)(.*)} );
return scalar @{[ \$haystack =~ m{\$first}g ]}
if \$needle eq q();
\$result += uniq_subseq( \$haystack, \$needle )
while \$haystack=~s{.*?\$first}{};
return \$result;
}
``````

A bit of a nasty initiliaser - to initialise all the variables we need

• \$result - the count of matches

• \$haystack - the string we are searching in

• \$first - the first character of the needle

• \$needle - the rest of the needle

We need to a regex to split the needle into the two parts!

We then split the code ( a slight optimization ) - if we have reached the end of the needle - then we just need to count the occurances of the needle left {saves some function calls}

We then just strip of the characters of the string (haystack) up to each occurance of our search letter - and use recursion to call the function again - but this time with the remainder of the string (and the shortened needle), and them up and that is our value to return.

Our second function just adds memoization, by using a cache (using state variables inside the function) to remember the results of calling `uniq_subseq` as, as the string gets longer you will end up repeating this call over and over again.

Note: the second line of the function is used to clear the cache for performance testing {repeatedly running the method for benchmarking will always return the cached value on subsequent calls. We have to do it with a special call of the function as we are using a state variables for the cache - and this is only accessible inside the function itself.

For the simple examples we don't see much gain from the cache - but if you find a more complex problem... with lots of solutions this function works much better - the example we tested showed a speed gain of around 100x.

``````sub uniq_subseq_cache {
state \$cache = {};
return \$cache={} if \$_ eq '---'; ## Clear the cache to examine speed
## Can't clear state cookie from
## outside function....

my( \$result, \$cache_key, \$haystack, \$first, \$needle )
= ( 0, "\$_-\$_", \$_, \$_ =~ m{(.)(.*)} );

``````  return \$cache->{\$cache_key}
if exists \$cache->{\$cache_key};
return \$cache->{\$cache_key} = scalar @{[ \$haystack =~ m{\$first}g ]}
if \$needle eq q();
\$result += uniq_subseq_cache( \$haystack, \$needle )
while \$haystack=~s{.*?\$first}{};
return \$cache->{\$cache_key} = \$result;
}
``````

The final function returns the "annotated" string showing each solution. We use a similar stripping approach - but it adds some complexity - mainly in remembering what we have stripped off the string - while we look for the parts of the needle. See code for comments.

``````sub display_uniq_subseq {
my( \$haystack, \$prev, \$regexp, \$needle, @result ) = (
\$_,          ## haystack (first string)
@_>2?\$_:q(), ## previous string (3rd parameter if it exists)
\$_ =~ m{(.)(.*)} ? ('\A(.*?)('.\$1.')',\$2) : (q(),q()),
## The regex for finding matches + the remainder of needle
## Slightly more complex than the previous version as we
## remove the "optimization" step in the other two functions
);

## If we have exhausted the substring we return the previous part
## along with what is left of the haystack.
## Note individual mapped letters are surrounded by individual
## brackets - to collapse these down to clusters of matched
## characters - We collapse adjacent []s by stripping "][".
## We again use the "r" modifier to just return the result
## of the replacement.
return (\$prev =~s{\]\[}{}gr).\$haystack if \$regexp eq q();

``````  ## regex collects anything before the matched letter &
## the matched letter
while( \$haystack =~ s{\$regexp}{} ) {
my( \$pre_match, \$match ) = (\$1,\$2);
push @result, display_uniq_subseq(
\$haystack, \$needle, \$prev.\$pre_match.'['.\$match.']',
);
## add the match onto the previous string, and
## continue to the next match
\$prev .= \$pre_match.\$match;
}
return @result;
}
``````

and without comments:

``````sub display_uniq_subseq {
my( \$haystack, \$prev, \$regexp, \$needle, @result ) = (
\$_, @_>2?\$_:q(),
\$_ =~ m{(.)(.*)} ? ('\A(.*?)('.\$1.')',\$2) : (q(),q()) );

return (\$prev =~s{\]\[}{}gr).\$haystack if \$regexp eq q();

``````  while( \$haystack =~ s{\$regexp}{} ) {
my( \$pre_match, \$match ) = (\$1,\$2);
push @result, display_uniq_subseq(
\$haystack, \$needle, \$prev.\$pre_match.'['.\$match.']' );
\$prev .= \$pre_match.\$match;
}
return @result;
}
``````

]]>
Commented on Perl weekly challenge 98 in James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10073#1810737 2021-02-02T17:01:05Z James Curtis-Smith Dave - the reason I pointed out not using a state variable is that is only useable by a single function.

In the example I include some clean-up and diagnostic functions which were/are useful - but would have needed access to the handler hash. Limiting the ability to use a state variable declaration.

Obviously this is one of those cases where an OO approach may have been a cleaner approach to keep everything in a "closed" container...

]]>
Posted Perl weekly challenge 98 to James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10073 2021-02-02T14:47:38Z 2021-02-02T15:24:17Z Here are solutions to this weeks challenges from the Perl Weekly Challenge. You can find my full code on Github Challenge 1 You are given file \$FILE. Create subroutine readN(\$FILE, \$number) returns the first n-characters and moves the pointer to... James Curtis-Smith http://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3569&id=5073 Here are solutions to this weeks challenges from the Perl Weekly Challenge.

You can find my full code on Github

### Challenge 1

You are given file \$FILE.

Create subroutine readN(\$FILE, \$number) returns the first n-characters and moves the pointer to the (n+1)th character.

#### Solution

Rather than turning this into an object which was the first idea - I decided to keep the code clean by making it a function call, and to also make it work with multiple file handles open simultaneously.

To achieve this without an object - we will need to use a global hash to contain the opened file handles - so that when we re-call the function we don't re-open the file.

Aside - note if we were only reading these files once in a while - an alternative approach would be to keep an array of file-positions rather than file-handles, and then at each invocation - re-open the file - seek to the location and return the bytes before closing it again - this would cut down the resources associated with the script.

We could use a state variable declaration here {but that would mean that we couldn't add extra code to be able to clean up data later}.

In our function we use one of the "lower-level" file functions, read, which reads a given number of bytes into a scalar variable - note it has to be initialised before the function call.

If read returns "false" then that means that there was no content in the file at that point.

``````
sub readN {
my( \$fn, \$bytes ) = @_;

## Create a file handle if we don't already have one
unless( exists \$handles{\$fn} ) {
open \$handles{\$fn}, '<', \$fn;
}

## Create a buffer for the return value
my \$t = '';

## Use "read" to read the \$bytes bytes - these are put into 2nd parameter
## If read returns undef it means it has reached the end of the file...
warn "Reached end of file \$fn\n" unless read \${\$handles{\$fn}}, \$t, \$bytes;

``````  ## Return string
return \$t;
}
``````

The additional cleanup code is used to forcibly close the file handles before the end of the script - this is why we could not rely on using state variables.

``````
sub cleanup {
## For neatness close all handles
## delete returns the value of the has deleted
## if filenames are passed then only those are cleaned up
close delete \$handles{\$_} foreach @_ ? grep { exists \$handles{\$_} } @_ : keys %handles;
}

``````sub show_open {
## Return a list of open filenames
return keys %handles;
}
``````

### Challenge 2

You are given a sorted array of distinct integers @N and a target \$N.

Write a script to return the index of the given target if found otherwise place the target in the sorted array and return the index.

#### Solution

This is a much simpler problem than the previous one - we have to find the index of the number (or where to insert it)

Once we know where that is we check to see if we need to insert or not (using the 4 parameter version of splice) and to return the value.

``````
sub insert_pos {
my( \$t, \$l, \$val ) = (0,@_);

## Repeat unless we have got to end of list or the new entry is greater than val
\$t++ while \$t < @{\$l} && \$l->[\$t] < \$val;

## If we are after the end of the list (to avoid warning) OR
## If we haven't found the entry then we use splice to insert it
splice @{\$l},\$t,0,\$val if \$t == @{\$l} || \$l->[\$t] != \$val;

## Warn to show splice has worked...
warn ">> \$t ( @{\$l} )\n"; ## Demonstrate splice

``````  ## Return the index of the number!
return \$t;
}
``````

If we aren't interested in doing the actual insert into the list then we can avoid the splice and so the code reduces to this.

``````
sub insert_pos {
my( \$t, \$l, \$val ) = (0,@_);
\$t++ while \$t < @{\$l} && \$l->[\$t] < \$val;
return \$t;
}
``````

You could easily run this code with simpler function...

``````
sub insert_pos {
my( \$l, \$val ) = @_;
return scalar grep { \$_ < \$val } @{\$l};
}
``````

But using our own loop is "optimal" if the number being inserted is near the start of the list - as the numbers increase numerically then we only need to check up to (or as far) as the number itself rather than the whole list. {you could use firstidx from List::MoreUtils}

]]>
Posted Perl weekly challenge 97 to James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10063 2021-01-30T04:42:31Z 2021-02-13T17:34:33Z Here are solutions to this weeks challenges from the Perl Weekly Challenge. You can find my full code on Github Challenge 1 You are given string \$S containing alphabets A..Z only and a number \$N. Write a script to encrypt... James Curtis-Smith http://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3569&id=5073 Here are solutions to this weeks challenges from the Perl Weekly Challenge.

You can find my full code on Github

### Challenge 1

You are given string \$S containing alphabets A..Z only and a number \$N. Write a script to encrypt the given string \$S using Caesar Cipher with left shift of size \$N.

#### Solution

``````
sub caesar {
return \$_ =~ s{([A-Z])}{chr 65+(-65-\$_+ord\$1)%26}regex;
}
``````

This is a simple one liner - but has some neat features - other than using "regex" for the switches, although most are important...

• r - return value rather than substitute in original string
• e - evaluate replace rather than use string
• g - repeat over all characters
• x - not needed (comments in match) - but looks good!

In the evaled replacement code - there is some clever ordering of values to reduce the need for brackets...

• 65 is at the front of the chr block as needing the bracket for the %26 - it would be evaluated as the bracket wrapping the parameters for chr .. so would evaluate as:
• ( chr(-65-\$_+ord\$1) ) %26+65
• -65 is at the start of the bracket - to allow us to not use brackets for the ord - if it was at the beginning you would need ord as it would evaluate ord \$1 - 65 - \$_ as
• ord( \$1 - 65 - \$_ )

### Binary Substrings

You are given a binary string \$B and an integer \$S.

Write a script to split the binary string \$B of size \$S and then find the minimum number of flips required to make it all the same.

#### Solution

As the first problem was a good one for applying "Golfing" techniques to it - I thought I would play along and try the second one....

``````
sub min_flips {
return [
local \$/ = length(\$_),
local \$\ = \$/ / \$_,
map { \$/ = \$_ < \$/ ? \$_ : \$/     }
map { ( \$_ ^ \$_ ) =~ y/\1/\1/ }
map { \$_ x \$\                    }
map { substr \$_, \$_ * \$_, \$_ }
0 .. \$\ - 1
]->[ -1 ];
}
``````

Notes

This was designed to serve as an example of perl idioms that other programmers may find difficult to understand - and so I tried to put as many of them in a relatively short function.... a discussion thread on the Perl programmers facebook group.

• One statement functions are a "lovely" perl concept - even if they can get a bit difficult to read....
• In perl there are special variables which give you information about the current process, or allow us to alter the functionality. To avoid creating variables I use these in the function. If you change these you can change how the code works - but here we use "local" copies - so that when we return from the function (block) they revert to their normal values - so we don't introduce any side-effects of our code
• \$/ - normally the input record separator - we will use for the minimum value
• \$\ - normally the output record separator - we will use for the number of chunks
• @_ - the list of parameters passed to a function - in this case \$_ is the string and \$_ is the block size
• Chained maps - we can simplify the maps by chaining them together, here we break it down into 5 separate stages - remember we have to read the code backwards. So we will look at the separate blocks of code working upwards...
• 0..\$\-1 - this returns a list of indices for the substrings
• map { \$_*\$_ } - this converts those indices into start locations (\$_ is the value of the element of variable that the map function is processing
• map { substr\$_,\$_,\$_ } - this grabs the substring for the nth block - but keeps the start location as we will need it later...
• map { \$_ x \$\ } - this maps the string we just have to have the same length as our original string - by performing a perl "string multiplication" x
• map { ( \$_ ^ \$_ ) =~ y/\1/\1/ } - count the flips. Two perlisms here - we can use xor operator ^ on strings to xor the binary values of each character. y/../../ - the translate operator returns the number of substitutions it makes - in this case we are substituting the ASCII character with decimal value of "1"... when the strings are same the byte value of the xor is 0 or "\0" and when they are different the value is 1 or "\1"
• map { \$/ = \$_ < \$/ ? \$_ : \$/ } - finally we keep the running total of the minimum value - We initialize \$/ to the length of the string (as the value must be less than or equal to that) we could have used the List::Util function min - but I try and avoid using external modules if I can...
• The list is the running minimums so we have to get the last element off the list - we do this with by wrapping the list in [ ] to make it an arrayref and then taking its last value [{list}]->[-1] perl indexes the last element as -1.
• And we return this value (implicit return)
• As the statement ends before the closing curly brace we don't need a semicolon {we aren't really sticking to PBP here anyway...!}

Just for the golf connoisseurs amongst you - here is the solution written as a single line {each line is 60 characters long}

``````sub mf_3{[local\$/=length\$_,local\$\=\$//\$_,map{\$/=\$_<\$/?
\$_:\$/}map{(\$_^\$_)=~y/\1/\1/}map{\$_ x\$\}map{substr\$_,\$_
,\$_}map{\$_*\$_}0..\$\-1]->[-1]}
``````

In fact we can shorten it further by combining some of the maps - but the code is not as easy to understand - as multiple steps are taken at once..., for golf aficionados - here is the code reduced (I think to a minimum unless you can prove otherwise).... each line is just 40 characters long....

``````
sub mf{((\$a,\$b)=@_,\$/=length\$a,\$\=\$//\$b,
map{\$/=\$_<\$/?\$_:\$/}map{(\$a^substr(\$a,\$_*
\$b,\$b)x\$\)=~y/\1//}0..\$\-1)[-1]}
``````

This just as 104 symbols between the two curly braces

• I have introduced potential side effects by removing the "local"s from the definitions of \$/ & \$\)
• I copy @_ into the special variables (\$a & \$b) which don't need "my"ing even under use strict - they are used in sort comparisons.
• The y/\1/\1/ is just convention - you can just drop the \1 in the replace to make the code shorter.
]]>
Posted Perl weekly challenge 96 to James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10058 2021-01-21T22:23:39Z 2021-01-22T09:49:53Z This week we had contrasting challenges. Challenge 1 - Reverse Words Take a string of words {with arbitrary white space around the words} and reverse the order of the words in the string and removing any redundant white space. This... James Curtis-Smith http://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3569&id=5073 This week we had contrasting challenges.

### Challenge 1 - Reverse Words

Take a string of words {with arbitrary white space around the words} and reverse the order of the words in the string and removing any redundant white space.

This is a classic example of a 1-liner....

``````
join q( ), reverse grep {\$_} split m{\s+}, \$_;
``````

### Challenge 2 - Edit Distance

I will provide 2 solutions here... one a less optimal solution which at the same time gives us a nice way of rendering the alignment - and then an more efficient "boiling down" of the first algorithm to just return the distance...

I'm just going to add "Another day job challenge!"

To be able to make "nicer" output - rather than just keeping track of the edit distance of substrings - we will actually keep the alignment of the two words as a string of "operations" whether they be Indels or SNPs.

One of my background is working with genomic data and this can be thought of as a simple alignment algorithm - and so I think of the three operations as Indels {inserts/deletes - remembering an insert into one sequence is just the same as a delete from the other} and SNPs - or single nucleotide polymorphisms.

The simple alignment string representation we will use consists of:

```
'|' - the letters are the same;
'v' - insert
'^' - delete
' ' - SNP/modify
```

We can convert this to an edit distance by counting all the non-"|"s In perl we do this with tr/^v /^v / which returns the number of matches in scalar form. See {_edit_dist - function}

Finally we include a nice way to render the alignment {edits} By showing the two words with appropriate inserts in each word and indicate where the letters match in each word via a the alignment string in the middle. See {render_alighnment function}

```  kitten-    sunday    boat rid-ing
||| |v      ||||    |^||||||v|||
sitting    monday    b-at ridding
```

Additional note - we "memoise" the alignment function - as it will be called with the same subseq of letters following different paths through the two sequences. This increases performance...

From a "genomic" point of view this is known as the basis of the Smith-Waterman local alignment algorithm. Although Smith-Waterman has other features - including variable "penalties" for each type of edit {inserts, deletes, modifications}. Even having different penalties for certain changes {this is also similar to how typing correction software works - with assuming adjacent key typos are more likely.

See:
* https://en.wikipedia.org/wiki/Smith%E2%80%93Waterman_algorithm

#### Solution

We solve the recursively (stripping letters from one or both words each time). We have a number of options.

* Either of the words has no-letters - so the alignment is either a set of inserts/deletes from the other string.
* If the first character of each word is the same - we continue to the next letters {and an alignment is marked between the two words}
* If they are not the same - we look to see which of the options insert, delete or snp makes has the lowest score...

The other two helper functions render this string (given the two sequences) showing the gaps and alignments; and work out the edit distance from the alignment.

``````
sub alignment_string {
my( \$s, \$t ) = @_;
\$calls++;
my \$key = "\$s\t\$t";
return \$cache{\$key} if exists \$cache{\$key};
\$misses++;
## Both strings are empty so reached end!
return \$cache{\$key}||=''              if \$t eq q() && \$s eq q();
## Exhausted t so all edits are now deletes...
return \$cache{\$key}||='^' x length \$s if \$t eq q();
## Exhausted s so all edits are now inserts...
return \$cache{\$key}||='v' x length \$t if \$s eq q();
## First letters are the same so we just prepend the
## match symbol (|) and continue...
return \$cache{\$key}||='|'.alignment_string(substr(\$s,1),substr(\$t,1))
if ord \$s == ord \$t;

## We now have three choices - "insert", "delete" or "SNP"
my(\$d,\$i,\$m) = (
'^'.alignment_string( substr(\$s,1), \$t           ),
'v'.alignment_string( \$s,           substr(\$t,1) ),
' '.alignment_string( substr(\$s,1), substr(\$t,1) ),
);
return  \$cache{\$key}||=
_edit_dist( \$d ) < _edit_dist( \$i )
? ( _edit_dist( \$d ) < _edit_dist( \$m ) ? \$d : \$m )
: ( _edit_dist( \$i ) < _edit_dist( \$m ) ? \$i : \$m );
}

sub edit_distance {
return _edit_dist( alignment_string( @_ ) );
}

sub _edit_dist { ## Count inserts(v), deletes(^) & mis-matches( )
return \$_ =~ tr/^v /^v /;
}

``````sub render_alignment {
my( \$s, \$t ) = @_;
my \$a = alignment_string( \$s, \$t );
my( \$top, \$bot ) = ( '','' );
foreach ( split m{}, \$a ) {
\$top .= \$_ eq 'v' ? '-' : substr \$s, 0, 1, '';
\$bot .= \$_ eq '^' ? '-' : substr \$t, 0, 1, '';
}
return sprintf "%s\n%s (%d)\n%s\n",
\$top, \$a, _edit_dist(\$a), \$bot;
}
``````

If we are not interested in the "alignment" diagram we can simplify the code:

``````
sub edit_distance_simple {
my( \$s, \$t ) = @_;
return \$cache_x{"\$s\t\$t"}||=
\$t eq q()          ? length \$s
: \$s eq q()          ? length \$t
: (ord \$s == ord \$t) ? edit_distance(substr(\$s,1),substr(\$t,1))
:                      1+(sort { \$a <=> \$b }
edit_distance(substr(\$s,1),\$t),
edit_distance(\$s,substr\$t,1),
edit_distance(substr(\$s,1),substr \$t,1)
)
;
}
``````

Note re-caches - these memoize the function - from trials the approximate hit is 50% - this matches up with the non recursive solution.

]]>
Commented on Perl weekly challenge 95 in James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10051#1810723 2021-01-19T11:27:55Z James Curtis-Smith Two things about the first comment:

1. Perl best practises recommends that you explicitly return from any function - rather than miss the return out as it makes things easier to read.
2. The challenge requested a return of 1 or 0 from a function, I think
3. ``````
\$a ? 1 : 0

easier to read than

+\$a

in these situations {and it avoids any potential side effects}

``````

As for the second one - yes if you treat this purely as a string based problem then it will work for any string - but then it is just proving strings are palindromic... Little to do with whether or not they are numbers. So I felt it was a bit of a "cop-out" to just use the palindromic property of a string....

The second solution was to look at this as a number based problem - so I could experiment with other bases [2,3,4,5,...,1001,...)

The solution works in whatever base you feel fit to choose. Yes it will tell you 1002 is palindromic base 1001 if you want to check.

]]>
Posted Perl weekly challenge 95 to James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10051 2021-01-15T09:27:56Z 2021-01-15T09:44:15Z Palindromic numbers You are given a number \$N. Write a script to figure out if the given number is Palindrome. Print 1 if true otherwise 0. There is an easy solution to this - to use "reverse" in string context... James Curtis-Smith http://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3569&id=5073 Palindromic numbers

You are given a number `\$N`. Write a script to figure out if the given number is Palindrome. Print 1 if true otherwise 0.

There is an easy solution to this - to use "reverse" in string context to reverse the number and comparing the two strings:

``````
sub is_palindrome_rev {
return ( \$_ eq reverse \$_) ? 1 : 0;
}
``````

But this just seems a touch too easy - so let's see if we can find an alternative solution. Something that will potentially work in any base - not just base 10!

``````
sub is_palindrome_array {
my(\$n,\$radix) = @_;
\$radix||=10;
return 0 if \$n < 0;
my @digits  = \$n%\$radix;
push @digits, \$n%\$radix while \$n = int (\$n/\$radix);
while( @digits>1 ) {
return 0 if shift @digits != pop @digits;
}
return 1;
}
``````
• Bail out if the number is negative;
• Chop the number of digits (in our "base").
• Push the number (module the radix) onto an array of digits, repeatedly dividing by the radix until we have nothing left.
• Technically this returns the digits in the reverse order (push is more efficient than unshift), but as we are interested in palindromes that isn't an issue.
• Then we work through the array and seeing if the first and last digits are the same {if the array has only 1 entry then the first and the last digits are the same!}. Use pop/shift to return the numbers and take them from the array...

### Stack

This is a simple case of creating a Stack object - basic OO coding. As this is a stack though we don't need to use a hashref as we would normally use - we can just bless an arrayref

Just a few notes on this one - mainly about good practice

• We wish to use the standard names push/pop for the stack - but these are built-ins for clarity in the code we use CORE::push & CORE::pop to make certain we are using the built-in push and pop commands
• Care needs to be taken as we may have an empty stack when making calls so should check for this in cases such as pop/min/top...

You can see my code on github at:

• https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-095/james-smith/
]]>
Posted Perl weekly challenge 94 to James Curtis-Smith tag:blogs.perl.org,2021:/users/james_curtis-smith//3569.10042 2021-01-09T14:47:41Z 2021-01-09T21:11:29Z The two challenges this week were a nice introduction to the new year. Challenge 1 - Group words into groups of anagrams. This is a nice hash or "arrayref"s question - a Perl staple. For each group we need to... James Curtis-Smith http://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3569&id=5073 The two challenges this week were a nice introduction to the new year.

### Challenge 1 - Group words into groups of anagrams.

This is a nice hash or "arrayref"s question - a Perl staple. For each group we need to generate a key, and put every anagram into this bin.

The simplest key is just to sort the letters into alphabetical order:

``join q(), sort split m{}``

This means the meat of the method can be written as a one liner.

``````sub group_anagrams {
my \$anagrams = {};
push @{ \$anagrams->{join q(),sort split m{}} }, \$_ foreach @_;
return \$anagrams;
}``````

### Challenge 2 - Flattening Trees & Linked Lists

Again with simple Tree and LinkedList classes this becomes a good
example of simple OO coding.

]]>
Posted Perl weekly challenge 93 to James Curtis-Smith tag:blogs.perl.org,2020:/users/james_curtis-smith//3569.10004 2020-12-28T12:00:49Z 2020-12-28T13:04:52Z These are some answers to the Week 93 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Spoiler Alert: This weekly challenge deadline is due in a few days (January 3, 2021). This blog post offers some solutions to... James Curtis-Smith http://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3569&id=5073 These are some answers to the Week 93 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a few days (January 3, 2021). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

I'm not a great blogger - but I will try and explain my solutions to the Perl weekly challenge each week. I always try and look for interesting solutions to the problems at hand.

# Part 1

Not sure on the correct way to do this... I first looked at all the pairs of points - and looked to see what the direction was between the points. For those where the y-coordinates are different you can just use (x1-x2)/(y1-y2) to represent the slope. We also that flipping the order of the points gives the same value. For those canses where y is the same - the slop can be represented by an "infinity value" in my case i use "-"

We now keep a list keyed by points and directions, with the value being the number of times that point/direction combination has been seen

Finding the solution is simply finding the largest value in this list - this gives the max-number of points colinear to a single points

The answer is then this value + 1

```
sub most_points_in_line {
my @nodes = @_;
my %lines;
foreach my \$i (0..(@nodes-2)) {
foreach my \$j ((\$i+1)..(@nodes-1)) {
my \$dir = \$nodes[\$i] == \$nodes[\$j]  ## Y values the same so division will fail
? '-'                             ## use "-" to represent infintiy.
:  (\$nodes[\$i]-\$nodes[\$j])/(\$nodes[\$i]-\$nodes[\$j]);
\$lines{\$i.':'.\$dir}++; ## Add 1 to both the two nodes { as swapping the nodes over
\$lines{\$j.':'.\$dir}++; ## makes no difference we don't need to compute twice
}
}
my \$max = 0; ## Now we just need to find the maximum value.
foreach (values %lines) {
\$max = \$_ if \$_ > \$max;
}
return \$max+1;
}
```

Note: - this "trick" will fail if the direction calculation has rounding errors - in the examples this isn't the case - but care should be taken.

If we take the assumption from the examples that all the points on the plane are in fact integers - we can remove some of the issues with rounding errors by returning a slope as a ratio of integers. We do this by computing the gcd of the two values, and dividing dx & dy by this value.

``````
sub most_points_in_line {
my @nodes = @_;
my %lines;
foreach my \$i (0..(@nodes-2)) {
foreach my \$j ((\$i+1)..(@nodes-1)) {
my \$dir = '-';
my( \$dx,\$dy) = ( \$nodes[\$i]-\$nodes[\$j], \$nodes[\$i]-\$nodes[\$j] );
if( \$dx && \$dy ) {
my \$gcd = gcd( \$dx,\$dy );
\$dir = \$dx/\$gcd.'-'.\$dy/\$gcd;
} else {
\$dir = \$dx ? '-' : '|';
}
\$lines{\$i.':'.\$dir}++;
\$lines{\$j.':'.\$dir}++;
}
}
my \$max = 0;
foreach (values %lines) {
\$max = \$_ if \$_ > \$max;
}
return \$max+1;
}

``````## Note this gcd function works when n & m can have -ve values
## We convert them to positive values and remember the sign of
## the differences.
sub gcd {
my( \$n,\$m,\$s ) = (@_,1);
(\$n,\$m) = (-\$n,-\$m) if \$n < 0;
if( \$m < 0 ) {
\$s = -1;
\$m = -\$m;
}
(\$n,\$m) = (\$m,\$n) if \$m>\$n;
(\$n,\$m) = ( \$m, \$n % \$m ) while \$n % \$m;
return \$m*\$s;
}
``````

# Part 2

Like last week I think Part 2 is easier than Part 1.

Not really sure what the input should be - but will by representing the tree as a series of nodes:

• Each node is an array consisting of up to 3 values;
• The value of the node
• The left and right sub-trees if they exists

So for example 1 we have:

```  [ 1,
[ 2,
[ 3 ],
[ 4 ],
],
];
```

and for example 2 we have:

```  [ 1,
[ 2,
[ 4 ],
]
[ 3,
[ 5 ],
[ 6 ],
],
];
```

To compute the sum of each route through the tree we start at the top, and work our way down the tree using recursion to find the sum of the sub-trees. As we work our way down the tree we remember the sum of the nodes that we have traversed through:

So in example 1.

• Start at node (1) - the sum of ancestors is 0
• We then look at the child trees (2) - the sum of it's ancestors is 1
• Then we look at the leaves (3) & (4) - the value they contribute are 6 and 7 respectively [the ancestor node total is 3 {1+2}]

This is relatively easy to convert to a simple algorithm:

``````
sub tree_sum {
my ( \$node,\$sum ) = @_;
\$sum||=0;
return \$node-> + \$sum if @{\$node} < 2; ## This is a leaf!
return tree_sum( \$node->, \$node-> + \$sum ) + ## Left tree total
( @{\$node} == 3 ? tree_sum( \$node->, \$node-> + \$sum ) : 0 );
## + right tree total if exists
}
``````

]]>