diff options
| -rw-r--r-- | challenge-187/james-smith/README.md | 325 | ||||
| -rw-r--r-- | challenge-187/james-smith/blog.txt | 1 | ||||
| -rw-r--r-- | challenge-187/james-smith/perl/ch-1.pl | 31 | ||||
| -rw-r--r-- | challenge-187/james-smith/perl/ch-2.pl | 36 |
4 files changed, 143 insertions, 250 deletions
diff --git a/challenge-187/james-smith/README.md b/challenge-187/james-smith/README.md index 4bca52332b..b1fbbf2150 100644 --- a/challenge-187/james-smith/README.md +++ b/challenge-187/james-smith/README.md @@ -1,287 +1,112 @@ -[< Previous 185](https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-185/james-smith) | -[Next 187 >](https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-187/james-smith) +[< Previous 186](https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-186/james-smith) | +[Next 188 >](https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-188/james-smith) -# Ʈʯḗ Ŵꭂḵⱡʏ Chåɫleŋȅ 186 +# The Weekly Challenge 187 -Ỷȣ ʗầņ fɪƞẟ ḿồṛĕ ĩƞꬵõɽɯɑẖıọǹ ꬰƀȣƫ ðiŝ ŵꭂḵꭍ, ẚꬻḋ ṗʁeỽíȣẜ ẅꭂks cẗâỻɛŋɘṧ ẩṱ: +You can find more information about this weeks, and previous weeks challenges at: https://theweeklychallenge.org/ -Ïf ỿȣ ḁrẽ ṇọť aľɻəǻďƴ ẟƣŋ ðe ĉʮảꬸḽeŋḗ - íṯ ȉṥ ẫ ġỏoď plẵꭢ ʈⱺ ṗꭉaꬿŧiśe ɏỗůꭆ -**ƥěꭈⱡ** öṟ **ꭉakū**. Įƒ ȋt iȿ nóť **ṗḙɽl** oṙ **rakʊ** ẏȣ ƍȩvȅŀơƥ in - ỿȣ ĉẚṅ -ṡūḃꭑĭƫ šôȴuʈīoňẛ įṋ ẉɥḯċʯḝʋḕr ʟaŋʉaĝe ꭅȣ ꬵꭂⱡ cőmḟởrṯaƀłꬳ ẁið. +If you are not already doing the challenge - it is a good place to practise your +**perl** or **raku**. If it is not **perl** or **raku** you develop in - you can +submit solutions in whichever language you feel comfortable with. -Ȳȣ ɕañ ḟḭꬻḑ þe sȯḹȕțḭǫṋs ʯeɿe ốņ gɩʇḥùɓ ấţ: +You can find the solutions here on github at: -https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-186/james-smith +https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-187/james-smith -# Task 1 - Zip List +# Task 1 - Days Together -***You are given two list `@a` and `@b` of same size. Create a subroutine `sub zip(@a, @b)` that merge the two list as shown in the example below.*** +***Two friends, Foo and Bar gone on holidays seperately to the same city. You are given their schedule i.e. start date and end date.*** -## Solution - -This is a problem where perl signatures come into play. We use a signature so that we can -use arrays in call rather than references to arrays. The signature `(\@\@)` then converts -the arrays in the call into references. - -### Solution 1 - Simple code: +***To keep the task simple, the date is in the form DD-MM and all dates belong to the same calendar year i.e. between 01-01 and 31-12. Also the year is non-leap year and both dates are inclusive.*** -Rather using a loop variable and select out of the two arrays -we loop through 1 and use a pointer to loop through the -other. +***Write a script to find out for the given schedule, how many days they spent together in the city, if at all.*** -```perl -sub zip (\@\@) { - my $c = 0; - map { $_, $_[1][$c++] } @{$_[0]} -} -``` - -### Solution 2 - Using a pointer for both arrays: +## Solution -This is the naive version where we have a counter and use it to index both arrays. +A slightly contrived one liner, which uses *self-executing closures* to perform the calculations without the need for creating intermediate variables. -The plus is that it is a single line, no need for a variable. +We are used to using *closures* or *anonymous functions* as callbacks in various functions - like `sort`, `map`, `grep` etc, but we can also use them +as self executing functions `sub { ..code.. }->( ..data.. )`, this is similar to the approach used in javascript to alias methods/variables. -```perl -sub zipt (\@\@) { - map { $_[0][$_], $_[1][$_] } 0..@{$_[0]}-1; -} +e.g. +```php +(function($){ + $.fn.function_name = function(x){}; +})(jQuery); ``` -### Solution 3 - Golfed code: - -Now I couldn't go a week without putting in some golf code - which is slightly -off the wall! We loop through one array and shift off the other +Working inward to outward, and bottom to top... -As we are golfing we try and avoid new variables, we can therefore reuse/abuse `@_` -(if we are careful)... this is the reason for `local` which stops our changes -affecting the loop variable outside the function call. - -Not only does using `@_` avoid using `my` when we loop through the array as we -`shift` off the first entry we can use the bare `shift` as it assumes that the -array is `@_`... - -Finally we have to do `@{shift()}` as perl can't distinguish between this meaning -the variable `@shift` or `@{$_[-1]}`. +We: + * flatten the array refs into a single array; + * compute their year-day; + * from this we compute the last start & the first end; + * check to see if the last start < first end if so returns the value o/w returns 0. ```perl -sub zipx (\@\@) { - local($_,@_)=(shift,@{shift()}); - map{$_,shift}@$_ +sub days_together { + sub { $_[1]<$_[0] ? 0 : $_[1]-$_[0]+1 }->( + # *4* If start [0] > end[1] then return the difference + 1 otherwise return 0 + + sub { ( $_[2] > $_[0] ? $_[2] : $_[0], $_[3] < $_[1] ? $_[3] : $_[1] ) }->( + # *3* Calculate max start & min end... + # If bar->start [2] > foo->start [0] then overlap->start = bar->start else it's foo->start + # If bar->end [3] < foo->end [1] then overlap->end = bar->end else it's foo->end + + map { [ 0,0,31,59,90,120,151,181,212,243,273,304,334 ]->[ substr $_,3 ] + substr $_,0,2 } + # *2* Compute year day - array contains offsets for the start of each month [ there is a + # padding 0 so we don't have to adjust month by 1... + + map { @{$_} } + # *1* Flatten two arrays into one... could have written this as @{$_[0]}, @{$_[1]} to avoid + # the map. + + @_ + ) + ) } ``` -## Performance - -With out original tests of up to 10 entries in the array we came up -with an ordering of `zip`, `zipt`, `zipx` as faster to slowest - -although with only about a 10-15% difference between all 3. - -We then tried with a larger array (initially 1000) and sptted that -`zipx` is now the fastest, about 20% faster than `zip` and 50% faster -then `zipt`. - -The break even point is around `35` entries in each array. So the -`zipx` is probably a better method to use as if the size is small -all are lightning fast - around 1 micro-second, but as the array -gets larger this gets around the millisecond - which could well be -more significant. - -# Task 2 - Unicode Makeover - -***You are given a string with possible unicode characters. Create a subroutine `sub makeover($str)` that replace the unicode characters with ascii equivalent. For this task, let us assume it only contains alphabets.*** - -## Solution - -We could use packages/built in support for UTF-8. But where would be the fun in that... can we replicate this -in compact perl! - -We first need to define a data structure where we can define the mapping between unicode symbol and plain latin ASCII character. -We could use a straight hash. But as the blocks of letters are in Unicode 'code blocks' we can use this to define the arrays -more efficiently. - -`%blocks` is a hash whose key is the numeric value of the first character in the block `ord($ch)`. -the second is a series of letter substitutions for that block. If the value in array is `?` then we assume there is -no direct mapping. +and now without the comments: ```perl -%blocks = ( - 192 => [qw( - A A A A A A A C E E E E I I I I TH N O O O O O x O U U U U Y TH SS - ... - q ? ? dz ? dz ts ? tc ? ls lz ? ? h h)], - 7680 => [qw( - A a B b B b B b C c D d D d D d D d D d E e E e E e E e E e F f - ... - O o O o U u U u U u U u U u U u U u Y y Y y Y y Y y LL ll V v Y y)], - ... - 43824 => [qw( - a ae e e e f g l l l m n n ? ? c oe oe ee co co y r r r r r r r s n n - m m n x x x x x x x y ? ? ? ? ? lb ie ce uo a)], +sub days_together { + sub { $_>[1]<$_[0] ? 0 : $_[1]-$_[0]+1 }->( + sub { ( $_[2] > $_[0] ? $_[2] : $_[0], $_[3] < $_[1] ? $_[3] : $_[1] ) }->( + map { [ 0,0,31,59,90,120,151,181,212,243,273,304,334 ]->[ substr $_,3 ] + substr $_,0,2 } + map { @{$_} } + @_ + ) + ) } ``` -Now note we allow "ligatures" & "diagraphs" in the array so there is a potential -for a 1-many mapping. (Diagraphs may be written as two letters, but sometimes the -letters are merged into a ligature, e.g. oe as in Phoenix; ss; ll in welsh ...) - -And now `makeover` - this might be seen as nasty code! But we will explain below - -```perl -sub makeover { join '', map { my $t = ord $_; - ( grep( { $_ ne '?' } - map { $t >= $_ && $t-$_ < @{$blocks{$_}} - ? $blocks{$_}[$t-$_] : () } - keys %blocks - ), chr $t )[0] -} split //, shift } - -``` - -``` - shift -> split -> map -> join -``` - -Remember with nested blocks we work backwards. The outer map is simple, we -split the parameter, and then process each character in turn, and join them -together. We split the string into chunks we assume it is a UTF-8 string, and -not a byte string, as the examples are the perl code - we can guarantee that -as we `use utf8`, for file/command line - we can use *e.g.* - -```perl -binmode(STDIN, "encoding(UTF-8)"); -``` - -There are similar was to ensure that database results are UTF-8 - -``` - keys -> map -> grep -``` - -Now for the inner loop - We loop through each block and see if the character -would be in that block - if it is we grab the mapped version of the character -- this is the `map` portion. This `map` returns at most one character. -We then `grep` out any `?` character - -We then add the original symbol to the list... So the results of the outer -bracket will be an array with one or two values +# Task 2 - Split array - `[ mapped, original ]` or `[ original ]`. +***You are given a list of positive numbers, `@n`, having at least 3 numbers. Write a script to find the triplets `(a, b, c)` from the given list that satisfies the following rules.*** -So getting the zero-th element we have the mapped character if there is one or the original character if there isn't. - -We know output is going to be UTF-8 ans we changed the *binmode* -of STDOUT to be UTF-8. - -This is a bit messy and slow - so can we think of a different way of using our data structure: - -### A simpler solution!! - -Well we can convert the data structure into a hash... and see how the code works - this is an initial overhead -but each symbol is a lot quicker! - -```perl -my %map = map { - my $c = $_; - map { $_ eq '?' ? ($c++,$_) : ($c++) x 0 } - @{$blocks{$_}} -} keys %blocks; -``` - -This then gives us a `makeover` function of: - -```perl -sub makeover { join '', map { $map{ord $_}//$_ } split //, shift } -``` - -### Some examples and performance... - -Here are some examples.... - -``` - ÃÊÍÒÙ! => AEIOU! - âÊíÒÙ => aEiOU - Ƭȟȩ Ẇḕȅǩȴƴ Ćħąỻḝṅḡể => The Weekly Challenge -``` - -With these three examples the 2nd method is 4-5x faster than the previous method... Pre-computing is always the way to go, -if you have a complex function and not too much memory is required to store the mappings. - -## Now lets go the other way... - -This is interesting - but it was hard to write examples - so I thought why don't I go the other way and produce -the "decorated" code from the plain text - I find it weird calling it "`makeunder`" but as it is opposite over -`makeover` so be it. I think switching names would be more understandable. - -Now there are two ways we can do this - we can either just use the single character mappings or we can look to see if we -can include the ligatures/digraphs. - -We also add in a small random feature meaning we don't necessarily modify all characters... - -### Getting the mapping - -```perl -my @inv; -push @{$inv[length $map{$_}]{$map{$_}}},$_ for keys %map; -``` - -We have made this slightly more complex by splitting the mapping into two hashs - `$inv[1]` the mapping of characters and -`$inv[2]` the mapping of digraphs. - -### First pass no ligatures +## Solution -This one is relatively simple - lookup character in list - if is mappable map it - if not just copy it, and we use the -`join map split` mode... +This is a permutation challenge, so we loop through the values with 3 nested loops. -```perl -sub makeunder_nolig { - join '', map { - $inv[1]{$_} && 0.8 > rand ? chr $inv[1]{$_}[rand @{$inv[1]{$_}}] : $_ - } split //,$_[0]; -} -``` +By sorting we can make the assumption that `$a,$b,$c` are automatically sorted highest to lowest.. -### Now with ligatures +Each time through we use shift to get the first element of each loop until there are no values left. Note in this case we use `while` for the outer two loops... ```perl -sub makeunder { - my $res = ''; - my @T = split //,$_[0]; - while(@T) { - my $x = shift @T; - $res .= - @T && exists $inv[2]{$x.$T[0]} && 0.8 > rand - ? chr($inv[2]{$x.$T[0]}[rand @{$inv[2]{$x.$T[0]}}]).(shift @T)x 0 - : exists $inv[1]{$x} && 0.8 > rand - ? chr $inv[1]{$x}[rand @{$inv[1]{$x}}] - : $x +sub magical { + @_ = sort { $b <=> $a } @_; + my @max = (0); + while(@_>2) { + my($a,$b,@c)=@_; + while(@c) { + ($a+$b>$_) && ($b+$_>$a) && ($a+$_>$b) && ($a+$b+$_>$max[0]) && (@max=($a+$b+$_,$a,$b,$_)) for @c; + $b = shift @c; + } + shift; } - $res; + shift @max; + @max; } ``` - -We can't use the `join map split` model this time - as the `map` section is looking at one or two characters at a time. -So through the loop we first look for a ligature - if we have one we use that (OK - we might not with a random change). -If we don't we then try a single character, or if not fall through. - -**Notes:** We use our favourite `x 0` trick to shift the 2nd character from a digraph, without it affecting the output... - -Here is some output (this weeks challenges) you will already have seen some at the top of this document! - -``` -Ṫaṩḵ 1: Zįƥ Ḽiẛƭ -Ṧuɓṃïtŧȩƍ ḅꭅ: Ḿoḧǟmꭐaƌ Ṧ Ḁʼnẁẳr -Ỵồŭ äɺɞ ɡɪʌȅṅ țẅồ ƚīṧẖ @à ãɴḓ @b ōf ṥąꬺⱻ ṥĩȥe. - -Čʁeꭤťꬲ a ṧuɓꭆȣtȋñḛ ẜȕƃ ẕĩṗ(@ḁ, @ɓ) ðằṫ ṃềrĝe ðɚ ʈẇợ -łıẛƫ aṣ ẜhowṇ ɪn ðⱻ ềẋaꭑpɭȇ ḃʚꬸȯw. - -Ṭẫꭍḳ 2: Ʊꬼıꭄȡɜ Ṁắƙẹȱỽėȓ -ſȗḇɯïţⱦɜȡ bʏ: Ṁổɦẩɰṃåḋ S Ấꬼwǡɾ -Ÿȣ äꭋe ǥiṿȩȵ ȃ śẖȑḭnĝ ẁịʇḧ ṕȱṣẝɨḇlé uņĩꭄdě ċȟắꭇäȼṱḕȓȿ. - -Çɹḛaƭe ậ ẝửḃꭊôuṫiꭎḗ ṩṳƃ ɯắkeṓỽeꭆ($ṩẖꭋ) ðat rȩpḷāče ƫḣẹ -uꭎịʗɔdē cḫắɾȁḉțễꭈʂ ẁĭð aẜḉɨĭ ɘɋữǐṿaļėꭎť. Ƒỏꭊ ðis ṯꭤśk, -ḷeƭ ǘʂ aʂṣụɯȩ ḯŧ ȭṉḹꭅ ꭄṋʈấïṋș alṕẗǎƀeʦ. -``` diff --git a/challenge-187/james-smith/blog.txt b/challenge-187/james-smith/blog.txt new file mode 100644 index 0000000000..027b0a1a9e --- /dev/null +++ b/challenge-187/james-smith/blog.txt @@ -0,0 +1 @@ +https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-187/james-smith diff --git a/challenge-187/james-smith/perl/ch-1.pl b/challenge-187/james-smith/perl/ch-1.pl new file mode 100644 index 0000000000..320dfc1da2 --- /dev/null +++ b/challenge-187/james-smith/perl/ch-1.pl @@ -0,0 +1,31 @@ +#!/usr/local/bin/perl + +use strict; + +use warnings; +use feature qw(say); +use Test::More; +use Benchmark qw(cmpthese timethis); +use Data::Dumper qw(Dumper); + +my @TESTS = ( + [ ['12-01','20-01'], ['15-01','18-01'], 4 ] , + [ ['02-03','12-03'], ['13-03','14-03'], 0 ], + [ ['02-03','12-03'], ['11-03','15-03'], 2 ], + [ ['30-03','05-04'], ['28-03','02-04'], 4 ], +); + +is( days_together($_->[0],$_->[1]), $_->[2] ) foreach @TESTS; + +done_testing(); + +sub days_together { + sub { $_[1]<$_[0] ? 0 : $_[1]-$_[0]+1 }->( + sub { ( $_[2]>$_[0]?$_[2]:$_[0], $_[3]<$_[1]?$_[3]:$_[1] ) }->( + map { [ 0,0,31,59,90,120,151,181,212,243,273,304,334 ]->[substr $_,3] + substr$_,0,2 } + map { @{$_} } + @_ + ) + ) +} + diff --git a/challenge-187/james-smith/perl/ch-2.pl b/challenge-187/james-smith/perl/ch-2.pl new file mode 100644 index 0000000000..e08218ad26 --- /dev/null +++ b/challenge-187/james-smith/perl/ch-2.pl @@ -0,0 +1,36 @@ +#!/usr/local/bin/perl + +use strict; + +use warnings; +use feature qw(say); +use Test::More; +use Benchmark qw(cmpthese timethis); +use Data::Dumper qw(Dumper); + +my @TESTS = ( + [ [1,2,3,2], '3 2 2' ], + [ [1,3,2], '' ], + [ [1,1,2,3], '' ], + [ [2,4,3], '4 3 2' ], +); + +is( "@{[magical(@{$_->[0]})]}", $_->[1] ) foreach @TESTS; + +done_testing(); + +sub magical { + @_ = sort { $b <=> $a } @_; + my @max = (0); + while(@_>2) { + my($a,$b,@c)=@_; + while(@c) { + ($a+$b>$_) && ($b+$_>$a) && ($a+$_>$b) && ($a+$b+$_>$max[0]) && (@max=($a+$b+$_,$a,$b,$_)) for @c; + $b = shift @c; + } + shift; + } + shift @max; + @max; +} + |