diff options
| -rw-r--r-- | challenge-214/james-smith/README.md | 159 | ||||
| -rw-r--r-- | challenge-214/james-smith/blog.txt | 1 | ||||
| -rw-r--r-- | challenge-214/james-smith/perl/ch-1.pl | 59 | ||||
| -rw-r--r-- | challenge-214/james-smith/perl/ch-2.pl | 94 |
4 files changed, 280 insertions, 33 deletions
diff --git a/challenge-214/james-smith/README.md b/challenge-214/james-smith/README.md index 453d499639..babc174789 100644 --- a/challenge-214/james-smith/README.md +++ b/challenge-214/james-smith/README.md @@ -1,7 +1,7 @@ -[< Previous 212](https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-212/james-smith) | -[Next 214 >](https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-214/james-smith) +[< Previous 213](https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-213/james-smith) | +[Next 215 >](https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-215/james-smith) -# The Weekly Challenge 213 - Another one rides the bus! +# The Weekly Challenge 214 - Another one rides the bus! You can find more information about this weeks, and previous weeks challenges at: @@ -15,55 +15,148 @@ You can find the solutions here on github at: https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-214/james-smith -# Task 1: Fun Sort +# TASK #1: Rank Score -***You are given a list of positive integers. Write a script to sort the all even integers first then all odds in ascending order.*** +***You are given a list of scores (>=1). Write a script to rank each score in descending order. First three will get medals i.e. G (Gold), S (Silver) and B (Bronze). Rest will just get the ranking number.*** ## Solution ```perl -sub fun_sort { - sort { $a%2 <=> $b%2 || $a <=> $b } @_ +sub rank { + map { ['','G','S','B']->[$_] || $_ } + map { //; 1 + grep { $_ > $' } @_ } + @_ } ``` -This was a simple challenge this week - firstly to sort odd from even we look at the last bit of the string - if even it is `0`, if odd `1`. So to get the even numbers before the odds we just sort on `$a%2 <=> $b%2` - we complete the sort by then sorting numerically. +Simple solution we get the rank for each value by counting the number of elements greater than it and then coverting 1,2,3 to GSB -This is faster than splitting the numbers into two lists and sorting separately and recombining... and much shorter. +## Complex solution -# Task 2: Shortest Route +```perl +sub rank2 { + my $pos=0; + @_ = sort { $b->[0] <=> $a->[0] } + map { [$_,$pos++,1] } + @_; + $_[$_][2] = $_[$_][0] == $_[$_-1][0] + ? $_[$_-1][2] + : $_ + 1 for 1..$#_; + map { ['','G','S','B']->[$_->[2]] || $_->[2] } + sort { $a->[1] <=> $b->[1] } + @_ +} +``` + +We effectively use a modified schwartzian transform. But instead of computing one index and sorting by it we then use 2nd index and sort by it. -***You are given a list of bidirectional routes defining a network of nodes, as well as source and destination node numbers. Write a script to find the route from source to destination that passes through fewest nodes.*** + * Add to each element and attribute which is additional position & a second which is going to be used for rank {we initialise as 1}; + * Sort based on value so highest is first; + * Set the rank column - based on order; + * The first rank is 1 - subsequent ranks are the position in the list if different from the previous number OR the rank of the previous number. + * Sort again but this time on original position + * to put numbers back where they were; + * Finally extract the rank from the triple and map 1,2,3 to G,S,B + +# TASK #2: Collect Points + +***You are given a list of numbers. You will perform a series of removal operations. For each operation, you remove from the list N (one or more) equal and consecutive numbers, and add to your score N × N. Determine the maximum possible score.*** ## Solution -We use a graph walking algorithm. We start by generating a graph of all the nodes in the tree storing their neighbours. +A brute force approach is the easiet here - we look for sequences of digits - remove from the list and add the "collect" call on the list with the sequence removed.. And we collect the best score. But this is not particularly fast especially as the list grows. + +```perl +sub collect { ## We will use recursion here. we take out each number in + ## turn and pass it back to the function + return 0 unless @_; ## The score for an empty list is 0 + my $m = 0; ## Create a variable for the max value + for ( my $e = my $o = 0; $o<@_; ) { ## Loop from start to finish - + ## there is no inc as the $o = $e at + ## the does the same think + my $e = $o; ## Reset the end of the list to the start + $e++ while $_[$o]==$_[$e]; ## Increment until we get to a different value + sub { $m=$_[0] if $m<$_[0] }->( ## Use and IIFE to collect max value + ($e-$o)**2 + ## Add square of elements to value + collect( @_[ 0..$o-1, $e..$#_ ] ## for the reduced list + ), $o = $e; + } + $m; +} +``` + +## Cacheing -We then need to try out all paths. +By simply caching the result we can get a significant improvement in the examples we see around a 20-25x improvement, better improvements happen with larger examples, until at some point the cache will start eating into swap.. And things will tail off dramatically! -Note in this solution we walk backwards (this is due to the golf trick in line which creates the initial queue element as -a wrapper round the end node - can't do this with the start node as `my(@q,$e)` would put all values in `@q`. +```perl +sub collect { ## We will use recursion here. we take out each number in + ## turn and pass it back to the function + return 0 unless @_; ## The score for an empty list is 0 + my $k = "@_"; ##+++ Generate key for cache + return $cache->{$k} if exists $cache->{$k}; ##+++ Return cache value if exists + my $m = 0; ## Create a variable for the max value + for ( my $e = my $o = 0; $o<@_; ) { ## Loop from start to finish - + ## there is no inc as the $o = $e at + ## the does the same think + my $e = $o; ## Reset the end of the list to the start + $e++ while $_[$o]==$_[$e]; ## Increment until we get to a different value + sub { $m=$_[0] if $m<$_[0] }->( ## Use and IIFE to collect max value + ($e-$o)**2 + ## Add square of elements to value + collect( @_[ 0..$o-1, $e..$#_ ] ## for the reduced list + ), $o = $e; + } + $cache->{$k} = $m ##+++ Cache value & return +} +``` -So we start with a list of length 0 ($e), we then look to all neighbough's and compute the lists of length for the neighbours 1. At any point if we reach the start node then we return the list. +## Improving the algorithm -The nice thing with this solution is that the code is `O(n^2)` +Here we work out a minimum best score - removing all numbers except for the most frequent and that leaves us with the best score of `f * f + ( n - f)`. +We also at each stage work out the possible maximum score - this is `score + sum(f*f)` over the remaining frequences. If this is lower than the +current max score we do not progress any futher... ```perl -sub shortest_route { - my( $s, @q, %n, %d ) = ( shift, [my $e = shift] ); ## Get start end, and initialize queue - return $s if $s eq $e; ## special case - as the soln only - ## returns list of length 1 or more - for my $r (@_) { ## Compute neighbour map. - $n{ $r->[$_-1] }{ $r->[$_] } = ## We need to walk both ways along the - $n{ $r->[$_] }{ $r->[$_-1] } = 1 for 1..$#$r; ## route - so we start from the 2nd - } ## so we don't fall off the LH end - while( my $p = shift @q ) { ## For each queue - $d{$p->[0]}=1; ## mark element as seen.. - $_ eq $s ? return ($_,@{$p}) : $push @q, [$_,@{$p}] ## For each new node. If it is the - for grep{ !$d{$_} } keys %{$n{$p->[0]}}; ## start we return the list, o/w push - } ## it to the find all neighbours of - ## the current point we haven't - ## already seen - () ## Empty list - as no route +sub _collect_fast { + my $s = shift; + return $s unless @_; ## Empty list return score + + ## same digits. + for ( my $e = my $o = 0; $o<@_; ) { ## We loop through + my $e = $o; ## the list for each + $e++ while $_[$o]==$_[$e]; ## sequence of same no. + + ## Compute the score so far $s + length of seq^2 + ## Compute max poss. score this + sum of squared + ## counts of other number frequencies + + my $ms = my $ts = $s + ($e-$o)**2; + my %f = ($_[$o] => $o-$e); + $f{$_}++ for @_; + $ms += $_ ** 2 for values %f; + + ## If the max possible score is > $m we compute + ## actual score and update max if > $m + + if($ms>$m) { + $ts = _collect_fast( $ts, @_[ 0..$o-1, $e..$#_ ] ); + ## And if it is greater than $m we update $m + $m = $ts if $ts > $m; + } + $o = $e; + } +} + +sub collect_fast { + return 0 unless @_; + my %f; + $m=0; + $f{$_}++ for @_; ## compute freq + $_>$m && ( $m=$_ ) for values %f; ## find largest + $m = $m*$m + @_-$m; ## Compute minimum-maximum + ## square of max freq - + ## count of remaining + _collect_fast(0,@_); ## Now do the real work + $m ## Return max (global variable) } ``` diff --git a/challenge-214/james-smith/blog.txt b/challenge-214/james-smith/blog.txt new file mode 100644 index 0000000000..d10008ded1 --- /dev/null +++ b/challenge-214/james-smith/blog.txt @@ -0,0 +1 @@ +https://github.com/manwar/perlweeklychallenge-club/blob/master/challenge-213/james-smith/blog.txt diff --git a/challenge-214/james-smith/perl/ch-1.pl b/challenge-214/james-smith/perl/ch-1.pl new file mode 100644 index 0000000000..57d1c70cb5 --- /dev/null +++ b/challenge-214/james-smith/perl/ch-1.pl @@ -0,0 +1,59 @@ +#!/usr/local/bin/perl + +use strict; +use warnings; +use feature qw(say); +use Test::More; + +my @TESTS = ( + [ [1,2,4,3,5], '5 4 S B G' ], + [ [8,5,6,7,4], 'G 4 B S 5' ], + [ [3,5,4,2], 'B G S 4' ], + [ [2,5,2,1,7,5,1], '4 S 4 6 G S 6' ], + [ [9,17,13,15,17,6,2,7,18,12,16,18,15,19,3,14,4,14,18,19,11,13,5,15,7,8,1,9,20,13,10,17,17,19,8,14,4,1,18,7], + '26 9 20 14 9 33 38 30 5 23 13 5 14 S 37 17 35 17 5 S 24 20 34 14 30 28 39 26 G 20 25 9 9 S 28 17 35 39 5 30' ], +); + + +## First a "one-liner" - we get the rank of each node as +## the number of entries with a score greater than value +## (+1)... +## We then just map 1,2,3 to G S B using the arrayref +## defaults to "n" if it is not 1/2/3. + +sub rank { + map { ['','G','S','B']->[$_] || $_ } + map { //; 1 + grep { $_ > $' } @_ } + @_ +} + +## Faster solution - +## (1) We sort the numbers into order - BUT +## keep a track of their position, and add a rank +## column +## (2) We loop through each element of the array, +## the rank is the position in the array (+1) if +## the number is different from the previous number +## otherwise it is the rank of the previous number! +## (3) We now have to revert this back the correct +## order - we do this by sorting on the position +## index we created in (1)... We then map 1,2,3 to +## G,S,B as above... + +sub rank2 { + my $pos = 0; + @_ = sort { $b->[0] <=> $a->[0] } + map { [$_,$pos++,1] } + @_; + $_[$_][2] = $_[$_][0] == $_[$_-1][0] + ? $_[$_-1][2] + : $_ + 1 for 1..$#_; + map { ['','G','S','B']->[$_->[2]] || $_->[2] } + sort { $a->[1] <=> $b->[1] } + @_ +} + + +is( "@{[rank( @{$_->[0]} )]}", $_->[1] ) for @TESTS; +is( "@{[rank2( @{$_->[0]} )]}", $_->[1] ) for @TESTS; +done_testing(); diff --git a/challenge-214/james-smith/perl/ch-2.pl b/challenge-214/james-smith/perl/ch-2.pl new file mode 100644 index 0000000000..1cd0bfdb3d --- /dev/null +++ b/challenge-214/james-smith/perl/ch-2.pl @@ -0,0 +1,94 @@ +#!/usr/local/bin/perl + +use strict; +use warnings; +use feature qw(say); +use Test::More; + +my @TESTS = ( + [ [2,4,3,3,3,4,5,4,2], 23 ], + [ [1,2,2,2,2,1], 20 ], + [ [1], 1 ], + [ [2,2,2,1,1,2,2,2], 40 ], + [ [2,1,2,1,2,1,2,1,2,1,2,1,2,1,2], 1 ], +); + +my($cache,$m); + +sub collect { + return 0 unless @_; + my $m = 0; + for ( my $e = my $o = 0; $o<@_; ) { + my $e = $o; + $e++ while $_[$o]==$_[$e]; + sub { $m=$_[0] if $m<$_[0] }->( + ($e-$o)**2 + + collect( @_[ 0..$o-1, $e..$#_ ] ) + ); + $o = $e + } + $m +} + +sub collect_cache { + return 0 unless @_; + my $k = "@_"; + return $cache->{$k} if exists $cache->{$k}; + my $m = 0; + for ( my $e = my $o=0; $o<@_; ) { + my $e = $o; + $e++ while $_[$o]==$_[$e]; + my $s = ($e-$o)**2 + collect_cache( @_[ 0..$o-1, $e..$#_ ] ); + $m = $s if $s > $m; + $o = $e; + } + $cache->{$k} = $m; +} + +sub _collect_fast { + my $s = shift; + return $s unless @_; ## Empty list return score + + ## same digits. + for ( my $e = my $o = 0; $o<@_; ) { ## We loop through + my $e = $o; ## the list for each + $e++ while $_[$o]==$_[$e]; ## sequence of same no. + + ## Compute the score so far $s + length of seq^2 + ## Compute max poss. score this + sum of squared + ## counts of other number frequencies + + my $ms = my $ts = $s + ($e-$o)**2; + my %f = ($_[$o] => $o-$e); + $f{$_}++ for @_; + $ms += $_ ** 2 for values %f; + + ## If the max possible score is > $m we compute + ## actual score and update max if > $m + + if($ms>$m) { + $ts = _collect_fast( $ts, @_[ 0..$o-1, $e..$#_ ] ); + ## And if it is greater than $m we update $m + $m = $ts if $ts > $m; + } + $o = $e; + } +} + +sub collect_fast { + return 0 unless @_; + my %f; + $m=0; + $f{$_}++ for @_; ## compute freq + $_>$m && ( $m=$_ ) for values %f; ## find largest + $m = $m*$m + @_-$m; ## Compute minimum-maximum + ## square of max freq - + ## count of remaining + _collect_fast(0,@_); ## Now do the real work + $m ## Return max (global variable) +} + + is( collect( @{$_->[0]} ), $_->[1] ) for @TESTS; + is( collect_fast( @{$_->[0]} ), $_->[1] ) for @TESTS; +$cache={},is( collect_cache( @{$_->[0]} ), $_->[1] ) for @TESTS; +done_testing(); |