PERL WEEKLY CHALLENGE – 036

This is my sixth week participating into the weekly challenge.


Easy Challenge

“Write a program to validate given Vehicle Identification Number (VIN). For more information, please checkout wikipedia.”

I didn’t want to spend too much time on this challenge as it could possibly be solved using a CPAN module like:

https://metacpan.org/pod/Data::Validate::VIN

I got a few real vins from this site for testing:
https://randomvin.com/

I checked using regexes and applied what I think are the appropriate rules for each region. The Wiki is a bit dodgy on the details but I hope I got most of it.

The most interesting bit was testing the check digit verification, which was basically a poor man’s checksum.


Perl 5 solution

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

# Check a bunch of different world VIN's
# These should be valid
for my $vin (
	'SCFFDAAM4EGA15321', 'JTHBA30G355101885',
	'1D7HA18P57J602071', 'WA1LFAFP7EA118600',
	'1NXBU40E39Z155675', '3VWSK69MX5M058145',
	'JS3TY92V534101150', 'WDDHF5KBXEA837164') {

	check_vin($vin);
}

# These should be invalid
for my $vin (
	'SCFFDAAM4EGA1$321', 'JTHBA30G3Z5101885',
	'1D7HA18P57J602072', '1NXBU40E79Z15567x',) {

	check_vin($vin);
}

# Check vin
sub check_vin {
	my $vin = shift;

	if (_check_vin($vin)) {
		say "$vin is valid.";
	} else {
		say "$vin is not valid.";
	};
}

# Check vin (the guts)
sub _check_vin {
	my $vin = uc(shift);
	my $vin_re = '[A-HJ-NPR-Z0-9]';

	# Check for valid World Vin
	return undef unless ($vin =~ /
		^             # Start of string
		($vin_re{3})  # World identification number
		($vin_re{6})  # Vehicle descriptor section
		($vin_re{8})  # Vehicle identifier section
		$             # End of string
	/x);

	# Capture parts of the vin
	my $win = $1; # World identification number
	my $vds = $2; # Vehicle descriptor section
	my $vis = $3; # Vehicle identifier section

	# 1st digit of the VIS can'test be a U, Z or 0
	return undef if ($vis =~ /^[UZ0]/);

	# Need to validate check digit
	# compulsory for vehicles
	# in North America and China,
	if ($win =~ /^[1-5L]/) {
		return unless check_digit($vin);
	}

	# In america and china the last 5
	# digits of the vis is numeric
	if ($win =~ /^[1-5L]/) {
		return undef unless ($vis =~ /
			^           # Start of string
			$vin_re{3}  # First 3
			\d{5}       # Last 5 digits
			$           # End of string
		/x);
	}

	return 1;
}

# Calculate the check digit
sub check_digit {
	my $vin = shift;
	my $products = 0;

	# Transliterate
	my %translate = (
		A => 1, B => 2, C => 3,
		D => 4, E => 5, F => 6,
		G => 7, H => 8, J => 1,
		K => 2, L => 3, M => 4,
		N => 5, P => 7, R => 9,
		S => 2, T => 3, U => 4,
		V => 5, W => 6, X => 7,
		Y => 8, Z => 9);

	# Weights
	my @weights = (
	  8,7,6,5,4,3,2,10,0,
	  9,8,7,6,5,4,3,2
	);

	# Calculate the check digit
	my $x = 0;
	foreach my $char (split //, $vin) {
		my $val = $translate{$char} ?
			$translate{$char} :
			$char;
			$products += $val * $weights[$x++];
	}

	# Calculate the check digit
	my $mod = $products % 11;
	$mod = 'X' if $mod == 10;

	# Check the digit
	my $check_digit = substr $vin, 8, 1;
	return $mod eq $check_digit;
}

Output

SCFFDAAM4EGA15321 is valid.
JTHBA30G355101885 is valid.
1D7HA18P57J602071 is valid.
WA1LFAFP7EA118600 is valid.
1NXBU40E39Z155675 is valid.
3VWSK69MX5M058145 is valid.
JS3TY92V534101150 is valid.
WDDHF5KBXEA837164 is valid.
SCFFDAAM4EGA1$321 is not valid.
JTHBA30G3Z5101885 is not valid.
1D7HA18P57J602072 is not valid.
1NXBU40E79Z15567x is not valid.

Raku solution

# Test: perl6 ch1.p6
use v6.d;

sub MAIN() {
	# Check a bunch of different world VIN's
	# These should be valid
	for ( 'SCFFDAAM4EGA15321', 'JTHBA30G355101885',
	      '1D7HA18P57J602071', 'WA1LFAFP7EA118600',
	      '1NXBU40E39Z155675', '3VWSK69MX5M058145',
	      'JS3TY92V534101150', 'WDDHF5KBXEA837164') -> $vin {
		check-vin($vin.uc);
	}

	# These should be invalid
	for ( 'SCFFDAAM4EGA1$321', 'JTHBA30G3Z5101885',
	      '1D7HA18P57J602072', '1NXBU40E79Z15567x') -> $vin {
		check-vin($vin.uc);
	}
}

# Check vin
sub check-vin(Str $vin) {
	if (_check-vin($vin)) {
		say "$vin is valid.";
	} else {
		say "$vin is not valid.";
	};
}

# Check vin (the guts)
sub _check-vin(Str $vin) {
	my $vin_re = /<[A..HJ..NPR..Z0..9]>/;

	# Check for valid World Vin
	return Nil unless ($vin ~~ /
		^^              # Start of string
		($vin_re ** 3)  # World identification number
		($vin_re ** 6)  # Vehicle descriptor section
		($vin_re ** 8)  # Vehicle identifier section
		$$              # End of string
	/);

	# Capture parts of the vin
	my $win = $0; # World identification number
	my $vds = $1; # Vehicle descriptor section
	my $vis = $2; # Vehicle identifier section

	# 1st digit of the VIS can't be a U, Z or 0
	return Nil if ($vis ~~ /^^<[UZ0]>/);

	# Need to validate check digit
	# compulsory for vehicles
	# in North America and China,
	if ($win ~~ /^^<[1..5L]>/) {
		return Nil unless check-digit($vin);
	}

	# In america and china the last 5
	# digits of the vis is numeric
	if ($win ~~  /^^<[1..5L]>/) {
		return Nil unless ($vis ~~ /
			^^             # Start of string
			$vin_re ** 3   # First 3
			\d  ** 5       # Last 5 digits
			$$             # End of string
		/);
	}

	return 1;
}

# Calculate the check digit
sub check-digit(Str $vin) {
	my $products = 0;

	# Transliterate
	my %translate = (
		A => 1, B => 2, C => 3,
		D => 4, E => 5, F => 6,
		G => 7, H => 8, J => 1,
		K => 2, L => 3, M => 4,
		N => 5, P => 7, R => 9,
		S => 2, T => 3, U => 4,
		V => 5, W => 6, X => 7,
		Y => 8, Z => 9 );

	# Weights
	my @weights = (
	  8,7,6,5,4,3,2,10,0,
	  9,8,7,6,5,4,3,2
	);

	# Calculate the check digit
	my $x = 0;
	my @chars = $vin.comb;

	for (0 .. @chars.end) -> $i {
		my $val = %translate{@chars[$i]} ??
			%translate{@chars[$i]} !! @chars[$i];
			$products += $val * @weights[$i];
	}

	# Calculate the check digit
	my $mod = ($products % 11).Str;
	$mod = 'X' if $mod == 10;

	# Check the digit
	my $check_digit = substr $vin, 8, 1;
	return $mod eq $check_digit;
}

Output

SCFFDAAM4EGA15321 is valid.
JTHBA30G355101885 is valid.
1D7HA18P57J602071 is valid.
WA1LFAFP7EA118600 is valid.
1NXBU40E39Z155675 is valid.
3VWSK69MX5M058145 is valid.
JS3TY92V534101150 is valid.
WDDHF5KBXEA837164 is valid.
SCFFDAAM4EGA1$321 is not valid.
JTHBA30G3Z5101885 is not valid.
1D7HA18P57J602072 is not valid.
1NXBU40E79Z15567X is not valid.

Hard Challenge

“Write a program to solve Knapsack Problem.”

There are 5 color coded boxes with varying weights and amounts in GBP. Which boxes should be choosen to maximize the amount of money while still keeping the overall weight under or equal to 15 kgs?

R: (weight = 1 kg, amount = £1)
B: (weight = 1 kg, amount = £2)
G: (weight = 2 kg, amount = £2)
Y: (weight = 12 kg, amount = £4)
P: (weight = 4 kg, amount = £10)
Bonus task, what if you were allowed to pick only 2 boxes or 3 boxes or 4 boxes? Find out which combination of boxes is the most optimal?

This is an interesting problem as the knapsack problem is quite well known in computer science.

I tackled this version my creating a meta attribute which i called value and defined it as amount/weight.

Then I sorted the boxes by value, then by weight. Then iterating through the boxes with highest value first and trying to put as many of them into the knapsack without going over the weight or maximum box allowance.

Perl 5 solution

#!/usr/bin/perl
# Test: ./ch2.pl
use strict;
use warnings;

# Box configurations
my $boxes = {
	R => { weight => 1,  amount => 1  },
	B => { weight => 1,  amount => 2  },
	G => { weight => 2,  amount => 2  },
	Y => { weight => 12, amount => 4  },
	P => { weight => 4,  amount => 10 },
};

# knapsack with unlimited boxes and 15 kg max
knapsack($boxes, 15, 0);

# knapsack with 2 3 4 boxes and 15kg max
knapsack($boxes, 15, 2);
knapsack($boxes, 15, 3);
knapsack($boxes, 15, 4);

sub knapsack {
	my ($boxes, $max_weight, $max_boxes) = @_;
	my $total_weight = 0;
	my $total_boxes  = 0;
	my $total_amount = 0;
	my $set_of_boxes;

	# Order the boxes by which
	# gives the most value, followed by weight.
	for my $key ( sort sort_value_weight keys %$boxes ) {
		my $box = $boxes->{$key};

		# While there is space or weight left
		while (1) {
			# Check for space or weight
			last unless
				$total_weight + $box->{weight} <=
				$max_weight;

			last unless
				!$max_boxes ||
				($max_boxes && $total_boxes + 1 <=
				 $max_boxes);

			$total_boxes++;
			$set_of_boxes .= $key;
			$total_weight += $box->{weight};
			$total_amount += $box->{amount};
		}
	}

	print 'Max weight: ' . $max_weight;
	print ', max boxes: ' . $max_boxes
		if ($max_boxes);
	print '. Boxes in knapsack: ' .
		$set_of_boxes;
	print ' ' . $total_weight . 'kg ';
	print '£' . $total_amount . "\n";
}

# Sort function to sort by value then weight
sub sort_value_weight {
	my $value_a =
		$boxes->{$::a}->{amount} /
		$boxes->{$::a}->{weight};
			
	my $value_b =
		$boxes->{$::b}->{amount} /
		$boxes->{$::b}->{weight};

	my $weight_a =
		$boxes->{$::a}->{weight};

	my $weight_b =
		$boxes->{$::b}->{weight};

	if ( $value_b > $value_a ) {
		return 1;
	} elsif ( $value_b == $value_a ) {
		return ($weight_b > $weight_a) ? 1 : -1;
	} else {
		return -1;
	}
}

Output

Max weight: 15. Boxes in knapsack: PPPBBB 15kg £36
Max weight: 15, max boxes: 2. Boxes in knapsack: PP 8kg £20
Max weight: 15, max boxes: 3. Boxes in knapsack: PPP 12kg £30
Max weight: 15, max boxes: 4. Boxes in knapsack: PPPB 13kg £32

Raku solution

# Test: perl6 ch2.p6
use v6.d;

# Box configurations
my %boxes = (
	R => { weight => 1,  amount => 1  },
	B => { weight => 1,  amount => 2  },
	G => { weight => 2,  amount => 2  },
	Y => { weight => 12, amount => 4  },
	P => { weight => 4,  amount => 10 },
);

sub MAIN () {
	# knapsack with unlimited boxes and 15 kg max
	knapsack(%boxes, 15, Inf);

	# knapsack with 2 3 4 boxes and 15kg max
	knapsack(%boxes, 15, 2);
	knapsack(%boxes, 15, 3);
	knapsack(%boxes, 15, 4);
}

sub knapsack (%boxes, Int $max_weight, Num() $max_boxes) {
	my $total_weight = 0;
	my $total_boxes  = 0;
	my $total_amount = 0;
	my $set_of_boxes = '';

	for %boxes.keys.sort(&sort-value-weight) -> $key {
		my $box = %boxes.{$key};

		# While there is space or weight left
		while (1) {
			# Check for space or weight
			last unless
				$total_weight + $box.{'weight'} <=
				$max_weight;

			last unless
				!$max_boxes ||
				($max_boxes && $total_boxes + 1 <=
				 $max_boxes);

			$total_boxes++;
			$set_of_boxes ~= $key;
			$total_weight += $box.{'weight'};
			$total_amount += $box.{'amount'};
		}
	}

	say 'Max weight: ' ~ $max_weight ~
	    ', max boxes: ' ~ $max_boxes ~
	    '. Boxes in knapsack: ' ~
	    $set_of_boxes ~
	    ' ' ~ $total_weight ~ 'kg ' ~
	    '£' ~ $total_amount;
}

# Sort function to sort by value then weight
sub sort-value-weight {	
	my $value_a =
		%boxes.{$^a}.{'amount'} /
		%boxes.{$^a}.{'weight'};

	my $value_b =
		%boxes.{$^b}.{'amount'} /
		%boxes.{$^b}.{'weight'};

	my $weight_a =
		%boxes.{$^a}.{'weight'};

	my $weight_b =
		%boxes.{$^b}.{'weight'};

	if ( $value_b > $value_a ) {
		return 1;
	} elsif ( $value_b == $value_a ) {
		return ($weight_b > $weight_a) ?? 1 !! -1;
	} else {
		return -1;
	}
}

Output

Max weight: 15, max boxes: Inf. Boxes in knapsack: PPPBBB 15kg £36
Max weight: 15, max boxes: 2. Boxes in knapsack: PP 8kg £20
Max weight: 15, max boxes: 3. Boxes in knapsack: PPP 12kg £30
Max weight: 15, max boxes: 4. Boxes in knapsack: PPPB 13kg £32

One thought on “PERL WEEKLY CHALLENGE – 036

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