PERL WEEKLY CHALLENGE – 050

This is my 20th week participating into the weekly challenge.


Merge Intervals


Write a script to merge the given intervals where ever possible.

[2,7], [3,9], [10,12], [15,19], [18,22]

The script should merge [2, 7] and [3, 9] together to return [2, 9]. Similarly it should also merge [15, 19] and [18, 22] together to return [15, 22].

The final result should be something like below:

[2, 9], [10, 12], [15, 22]


I made a few assumptions about this.

1) We’re merging left to right
2) We can recursively merge.

I didn’t want to brute for the problem so I just modelled the array using the min and max values. I then checked these values with the next list and if they over lapped that the smallest and largest values to form a new list.

Perl 5 solution

#!/usr/bin/perl
# Test: ./ch-1.pl "[2,7], [3,9], [10,12], [15,19], [18,22]"
use strict;
use warnings;
use feature qw /say/;
use List::Util qw /min max /;

my $arg_string = join '', @ARGV;
$arg_string =~ s/[\s\[\]]//g;
my @values = split (',', $arg_string);
my @lists;

# Create the lists
while (@values) {
	my $min = shift @values;
	my $max = shift @values;
	push @lists, [$min, $max];
}

my $i = 0;
while ($i < scalar(@lists) - 1) {
	if ( $lists[$i]->[1] >= $lists[$i+1]->[0] &&
	     $lists[$i]->[0] <= $lists[$i+1]->[1]) {
		my $new_min = min($lists[$i]->[0], $lists[$i+1]->[0]);
		my $new_max = max($lists[$i]->[1], $lists[$i+1]->[1]);
		splice ( @lists, $i, 2, [$new_min, $new_max] );
	} else {
		$i++;
	}
}

say join ', ',
    map { '[' . $_->[0] . ', ' . $_->[1] . ']'}
    @lists;

Output

[2, 9], [10, 12], [15, 22]

Raku solution

# Test: perl6 ch-1.p6 "[2,7], [3,9], [10,12], [15,19], [18,22]"

sub MAIN(Str $lists) {
	my @values =
		$lists.subst(/<[\s\[\]]>/, '', :g).split(',')>>.Int;
	my $i = 0;

	# Loop through the list items
	while ($i < @values.elems - 3) {
		# Compare the last element of the list to the
		# first element of the next list
		if ( @values[$i+1] >= @values[$i+2] &&
		     @values[$i]   <= @values[$i+3] ) {
			# Create new list indexes
			my @new_list = (
				min(@values[$i], @values[$i+2]),
				max(@values[$i+1], @values[$i+3])
			);
			@values.splice($i, 4, @new_list);
		} else {
			$i = $i + 2;
		}
	}

	# Print the values
	$i = 0;
	my @v_string;
	while ($i < @values) {
		@v_string.push(
			'[' ~ @values[$i++] ~ ', ' ~
			      @values[$i++] ~ "]"
		);
	}
	say join ', ', @v_string;
}

Output

[2, 9], [10, 12], [15, 22]

Task 2

Noble Integer


You are given a list, @L, of three or more random integers between 1 and 50. A Noble Integer is an integer N in @L, such that there are exactly N integers greater than N in @L. Output any Noble Integer found in @L, or an empty list if none were found.

An interesting question is whether or not there can be multiple Noble Integers in a list.

For example,

Suppose we have list of 4 integers [2, 6, 1, 3].

Here we have 2 in the above list, known as Noble Integer, since there are exactly 2 integers in the list i.e.3 and 6, which are greater than 2.

Therefore the script would print 2.


First, there will never be multiple Noble integers (Assuming we don’t check duplicate integers). This becomes apparent when you sort the list. If noble numbers were described as exactly N integers less than N then we can have multiple Noble numbers

So I tackled this problem by creating a sorted list and and just counting the number of items remaining in the list. Then comparing it with the noble number candidate.

It’s interesting to note that duplications can exist. For example:
[1 , 2, 2, 3 , 4].

I solved the duplication problem by just checking the last 2 vs the remaining total of the list.

Perl 5 solution

#!/usr/bin/perl
# Test: ./ch-2.pl
use strict;
use warnings;
use feature qw /say/;

# Create @L
my @L = sort { $a <=> $b } map { int(rand(50) + 1) } ( 1 .. 50 );
my $i = 0;
my $total = scalar(@L);

# Output the list
say "List: " . join ', ', @L;

# Loop through each number
while ($i < $total) {
	# Skip duplicates
	if ($i + 1 < $total && $L[$i] != $L[$i + 1]) {
		say "Noble number found: " . $L[$i]
			if ($L[$i] == $total - $i - 1);
	}
	$i++;
}

Output

List: 2, 7, 7, 7, 8, 8, 9, 11, 13, 16, 18, 20, 20, 21, 22, 22, 24, 24, 26, 27, 27, 27, 27, 31, 31, 32, 32, 32, 32, 33, 34, 35, 35, 37, 37, 38, 38, 40, 41, 41, 41, 42, 43, 44, 44, 44, 46, 47, 49, 50
Noble number found: 27

Raku solution

# Test: perl6 ch-2.p6
use v6.d;

sub MAIN() {
	my $list_size = 50;

	# Create @L
	my @L = ((1 .. 50).roll: $list_size) ;

	# Output the list
	say 'List: ' ~ @L.perl;

	# Find Noble number
	my $noble =
		@L.sort.pairs.grep(
			{.key == $list_size - .value}
		)>>.value;

	# Output it if found
	say "Noble found: " ~ $noble
		if ($noble);
}

Output

List: [8, 23, 17, 35, 25, 43, 41, 20, 34, 29, 12, 22, 36, 15, 20, 47, 24, 35, 10, 43, 2, 42, 17, 40, 8, 19, 1, 13, 48, 38, 5, 50, 19, 33, 7, 1, 45, 40, 30, 25, 22, 7, 22, 4, 29, 12, 18, 47, 9, 42]
Noble found: 24

One thought on “PERL WEEKLY CHALLENGE – 050

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s