Perl Weekly Challenge 27: Intersection Point and Historical Values
These are some answers to the Week 27 of the Perl Weekly Challenge organized by Mohammad S. Anwar.
Challenge # 1: Intersection of Two Lines
Write a script to find the intersection of two straight lines. The co-ordinates of the two lines should be provided as command line parameter. For example:
The two ends of Line 1 are represented as co-ordinates (a,b) and (c,d).
The two ends of Line 2 are represented as co-ordinates (p,q) and (r,s).
The script should print the co-ordinates of point of intersection of the above two lines.
This is really elementary math, but, as I haven't used any linear algebra for many years, I needed about 10 to 15 minutes with a pencil and a piece of paper to work out how to find the equation of a straight line going through two points and how to compute the intersection of two lines. For the benefits of those of you in the same situation, let me briefly summarize how this works. You may jump to the next section if you don't need any refresher on these subjects.
The equation of a straight line is usually written as y = ax + b (or, in some countries, y = mx + b or y = mx + c, but it's just the name of the coefficients changing), where x and y are the coordinates of any point belonging to the line, a is the slope (or gradient, i.e. how steep the line is) of the line, and b the y-intercept (the value of y when x is zero, or the place where the line crosses the Y axis). The slope is the change in y divided by the change in x. For finding the slope of a line going through two points with coordinates x1, y1 and x2, y2, the slope a is the ordinate (y) difference of the points divided by their abscissa (x) difference:
a = (y2 - y1) / (x2 - x1)
Of course, we have a division by zero problem if x2 equals x1 (i.e. the line is vertical, at least in an orthonormal base or Cartesian plane), but we'll come back to that special edge case later.
For finding the y-intercept (b), you just need to reformulate y = ax + b as b = y - ax, and to replace a by the slope found with the above formula, and y and x by the coordinates of any of the two points.
For finding the intersection point of two lines y = a1 * x + b1 and y = a2 * x + b2, you need to figure out that it is the point of the lines for which the ordinate (y) is the same for an equal value of the abscissa (x), i.e. write the following equations:
a1 * x + b1 = a2 * x + b2
<=>
(a1 - a2) *x = b2 - b1
<=>
x = (b2 - b1) / (a1 - a2) # (if a1 != a2)
Once the abscissa x of the intersection has been found, it is easy to find its ordinate y using the equation of any of the two lines.
If the lines' slopes are equal, then the equation above has a division by zero problem, which reflects the fact that the line segments defined by the point pairs are parallel or colinear, meaning that the problem has no solution (there is no intersection point).
Intersection Point in Perl 5
With the above knowledge secured, it is fairly easy to write a Perl 5 program computing the intersection point of two lines defined by two point pairs.
We use the find_line subroutine twice (once for every point pair) to find the slope and y-intercept of each line and the find-intersect subroutine to find the coordinates of the point where the two lines intersect.
There is one slight complication, though: if one (and only one) of the point pairs have points with the same abscissa, we cannot write a linear equation for that pair of points, but the straight line is nonetheless well defined (provided the ordinates are different): it is a vertical line where all point have the same abscissa (x value). We cannot write an equation for such a line, but may still find the intersection point with the other line: it is the point of that other line having this abscissa. This pesky edge case accounts for a good chunk (20 code lines) of the code below.
#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
sub find_line {
my ($x1, $y1, $x2, $y2) = @_;
my $slope = ($y2 - $y1) / ($x2 - $x1);
# find b for y1 = slope * x1 + b
my $b = $y1 - $slope * $x1;
return $slope, $b;
}
sub find_intersect {
my ($a1, $b1, $a2, $b2) = @_;
# solve y = ax + b for a1, b1 and a2, b2
# i.e.: a1 x + b1 = a2 x + b2 <=> x (a1 - a2) = b2 - b1
die "The segments are parallel or colinear, no intersection point!" if ($a1 == $a2);
my $abscissa = ($b2 - $b1) / ($a1 - $a2);
say "x = $abscissa";
my $ordinate = $a1 * $abscissa + $b1;
return $abscissa, $ordinate;
}
my ($a1, $b1, $a2, $b2);
if (@ARGV == 8) {
die "The two segments are vertical, no intersection point"
if $ARGV[0] == $ARGV[2] and $ARGV[4] == $ARGV[6];
if ($ARGV[0] == $ARGV[2]) {
#First segment is vertical
my $abscissa = $ARGV[0];
($a2, $b2) = find_line @ARGV[4..7];
my $ordinate = $a2 * $abscissa + $b2;
say "Intersection point: $abscissa, $ordinate";
exit 0;
}
if ($ARGV[4] == $ARGV[6]) {
# Second segment is vertical
my $abscissa = $ARGV[4];
($a1, $b1) = find_line @ARGV[0..3];
my $ordinate = $a1 * $abscissa + $b1;
say "Intersection point: $abscissa, $ordinate";
exit 0;
}
($a1, $b1) = find_line @ARGV[0..3];
($a2, $b2) = find_line @ARGV[4..7];
} else {
# default test values if arguments are missing or insufficient
($a1, $b1) = find_line 3, 1, 5, 3;
($a2, $b2) = find_line 3, 3, 6, 0;
}
say "a1: $a1";
say "b1: $b1";
say "a2: $a2";
say "b2: $b2";
my ($x, $y) = find_intersect ($a1, $b1, $a2, $b2);
say "Intersection point abscissa: $x";
say "Intersection point ordinate: $y";
Note that, in a real-life program, we should really check that the points of each pair are distinct (to properly define a straight line), but I did not want to clutter the code with even more edge cases: I'll assume that the user knows what she or he is doing and will pass arguments making sense. We'll do more of these argument checks in the Perl 6 version.
With no argument, the program uses the default values and duly prints the following:
$ perl intersection.pl
a1: 1
b1: -2
a2: -1
b2: 6
x = 4
Intersection point abscissa: 4
Intersection point ordinate: 2
These are a few example runs on edge cases:
$ perl intersection.pl 3 4 3 6 7 8 9 10
Intersection point: 3, 4
$ perl intersection.pl 3 4 3 6 8 8 9 10
Intersection point: 3, -2
$ perl intersection.pl 3 4 3 6 3 3 6 0
Intersection point: 3, 3
$ perl intersection.pl 4 4 4 6 3 3 6 0
Intersection point: 4, 2
$ perl intersection.pl 3 1 5 3 3 3 3 0
Intersection point: 3, 1
Intersection Point in Perl 6
We could simply translate the P5 program in Perl 6, but this type of problem calls for object-oriented programming. So, we will define a Point type and a Segment class (with two Point attributes) providing the slope and y-intercept methods to compute the equation of a line passing through the two points. The Point role also provides a gist method enabling pretty printing of the point coordinates when using the say built-in function on a Point instance.
use v6;
role Point {
has $.x;
has $.y;
method gist {
return "\n- Abscissa: $.x\n- Ordinate: $.y.";
}
}
class Segment {
has Point $.start;
has Point $.end;
method slope {
return ($.end.y - $.start.y) / ($.end.x - $.start.x);
}
method y-intercept {
my $slope = self.slope;
return $.start.y - $slope * $.start.x;
}
method line-coordinates { # used only for debugging purpose
return self.slope, self.y-intercept;
}
}
sub compute-intersection (Segment $s1, Segment $s2) {
my $abscissa = ($s2.y-intercept - $s1.y-intercept) /
($s1.slope - $s2.slope);
my $ordinate = $s1.slope * $abscissa + $s1.y-intercept;
my $intersection = Point.new( x => $abscissa, y => $ordinate);
}
multi MAIN ( $a1, $b1, # start of line segment 1
$a2, $b2, # end of line segment 1
$a3, $b3, # start of line segment 2
$a4, $b4 # end of line segment 2
) {
my $segment1 = Segment.new(
start => Point.new(x => $a1, y => $b1),
end => Point.new(x => $a2, y => $b2)
);
my $segment2 = Segment.new(
start => Point.new(x => $a3, y => $b3),
end => Point.new(x => $a4, y => $b4)
);
say "Coordinates of intersection point: ",
compute-intersection $segment1, $segment2;
}
multi MAIN () {
say "Using default input values for testing. ";
say "Should display point (2, 4).";
my $segment1 = Segment.new(
start => Point.new(x => 3, y => 1),
end => Point.new(x => 5, y => 3)
);
my $segment2 = Segment.new(
start => Point.new(x => 3, y => 3),
end => Point.new(x => 6, y => 0)
);
# say "Segment 1: ", $segment1.line-coordinates;
# say "Segment 2: ", $segment2.line-coordinates;
say "Coordinates of intersection point: ",
compute-intersection $segment1, $segment2;
}
This is a sample run of the program:
$ perl6 intersection.p6 3 1 5 3 3 3 6 0
Coordinates of intersection point:
- Abscissa: 4
- Ordinate: 2.
As it is, this program isn't doing any validation on its arguments. So we will add a valid-args subroutine for that purpose and also check that the computed segments are not parallel.
use v6;
role Point {
has $.x;
has $.y;
method gist {
return "\n- Abscissa: $.x\n- Ordinate: $.y.";
}
}
class Segment {
has Point $.start;
has Point $.end;
method slope {
return ($.end.y - $.start.y) / ($.end.x - $.start.x);
}
method y-intercept {
my $slope = self.slope;
return $.start.y - $slope * $.start.x;
}
method line-coordinates {
return self.slope, self.y-intercept;
}
}
sub compute-intersection (Segment $s1, Segment $s2) {
my $abscissa = ($s2.y-intercept - $s1.y-intercept) /
($s1.slope - $s2.slope);
my $ordinate = $s1.slope * $abscissa + $s1.y-intercept;
my $intersection = Point.new( x => $abscissa, y => $ordinate);
}
multi MAIN ( $a1, $b1, # start of line segment 1
$a2, $b2, # end of line segment 1
$a3, $b3, # start of line segment 2
$a4, $b4 # end of line segment 2
) {
exit unless valid-args |@*ARGS;
my $segment1 = Segment.new(
start => Point.new(x => $a1, y => $b1),
end => Point.new(x => $a2, y => $b2)
);
my $segment2 = Segment.new(
start => Point.new(x => $a3, y => $b3),
end => Point.new(x => $a4, y => $b4)
);
say "Segments are parallel or colinear." and exit
if $segment1.slope == $segment2.slope;
say "Coordinates of intersection point: ",
compute-intersection $segment1, $segment2;
}
multi MAIN () {
say "Using default input values for testing. Should display poinr (2, 4).";
my $segment1 = Segment.new(
start => Point.new(x => 3, y => 1),
end => Point.new(x => 5, y => 3)
);
my $segment2 = Segment.new(
start => Point.new(x => 3, y => 3),
end => Point.new(x => 6, y => 0)
);
say "Coordinates of intersection point: ",
compute-intersection $segment1, $segment2;
}
sub valid-args ( $a1, $b1, # start of line segment 1
$a2, $b2, # end of line segment 1
$a3, $b3, # start of line segment 2
$a4, $b4 # end of line segment 2
) {
unless @*ARGS.all ~~ /<[\d]>+/ {
say "Non numeric argument. Can't continue.";
return False;
}
if $a1 == $a2 and $b1 == $b2 {
say "The first two points are the same. Cannot draw a line.";
return False;
}
if $a3 == $a4 and $b3 == $b4 {
say "The last two points are the same. Cannot draw a line.";
return False;
}
if $a1 == $a2 and $a3 == $a4 {
say "The two segments are vertical. No intersection.";
return False;
}
if $a1 == $a2 {
# First segment is vertical but not the second one
my $segment2 = Segment.new(
start => Point.new(x => $a3, y => $b3),
end => Point.new(x => $a4, y => $b4)
);
my $ordinate = $segment2.slope
* $a1 + $segment2.y-intercept;
my $interception = Point.new(x => $a1, y => $ordinate);
say "Coordinates of intersection point: ", $interception;
return False;
}
if $a3 == $a4 {
# Second segment is vertical but not the first one
my $segment1 = Segment.new(
start => Point.new(x => $a1, y => $b1),
end => Point.new(x => $a2, y => $b2)
);
my $ordinate = $segment1.slope
* $a3 + $segment1.y-intercept;
my $interception = Point.new(x => $a3, y => $ordinate);
say "Coordinates of intersection point: ", $interception;
return False;
}
return True;
}
Running the program with some examples of valid or invalid arguments displays the following:
$ perl6 intersection.p6 3 1 5 3 3 3 n 0
Non numeric argument. Can't continue.
$ perl6 intersection.p6 3 1 5 3 3 3 5.4 0
Coordinates of intersection point:
- Abscissa: 3.888889
- Ordinate: 1.888889.
$ perl6 intersection.p6 3 1 5 3 3 3 6.0 0
Coordinates of intersection point:
- Abscissa: 4
- Ordinate: 2.
$ perl6 intersection.p6 3 1 5 3 6 2 10 6
Segments are parallel or colinear.
$ perl6 intersection.p6 3 1 3 1 3 3 6 0
The first two points are the same. Cannot draw a line.
$ perl6 intersection.p6 3 1 3 2 3 5 3 0
The two segments are vertical. Cannot find an intersection.
Challenge # 2: Displaying Historical Values
Write a script that allows you to capture/display historical data. It could be an object or a scalar. For example:
my $x = 10; $x = 20; $x -= 5;
This week was very busy for me and I'm running a bit out of time. My answers to this task will be somewhat minimalist.
Displaying Historical Values in Perl 5
I do not know whether it is possible to override the = operator in Perl 5 and have no time to find out. Another possibility might be to use the tie function or something similar to associate a value with an object, but I have used it only very rarely and have very limited experience with it, and I also don't have enough time to experiment with it. Therefore, I'll cheat a little bit and use an $assign code reference for assigning new values to a watched variable. The create_watched_value subroutine acts as a watched variable constructor and is a function factory that returns three closures, $assign, $get_past_values, and $get_current_values. The main code then uses these code references to perform various assignments and output.
#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
sub create_watched_value {
my $value = shift;
my @past_values;
my $assign = sub {
my $new_val = shift;
push @past_values, $value;
$value = $new_val;
};
my $get_past_values = sub {
return "@past_values";
};
my $get_current_value = sub {
return $value;
};
return $assign, $get_past_values, $get_current_value;
}
my ($assign, $get_past, $get_current) = create_watched_value 10;
say "Current: ", $get_current->();
$assign->(15);
say "Current: ", $get_current->();
$assign->(20);
say "Current: ", $get_current->();
$assign->(5);
say "Current: ", $get_current->();
say "Past: ", $get_past->();
This program runs fine and displays the following output:
$ perl watched-values.pl
Current: 10
Current: 15
Current: 20
Current: 5
Past: 10 15 20
Displaying Historical Values in Perl 6
I initially tried to redefine the = assignment operator but that appears to be impossible:
Cannot override infix operator '=', as it is a special form handled directly by the compiler
So, I decided to create my own =:= assignment operator for watched variables. Besides that, the program uses the WatchedValue class to enable the storing of current and past values.
use v6;
class WatchedValue {
has Int $.current-value is rw;
has @.past-values = ();
method get-past-values {
return @.past-values;
}
}
multi sub infix:<=:=> (WatchedValue $y, Int $z) {
push $y.past-values, $y.current-value;
$y.current-value = $z;
}
my $x = WatchedValue.new(current-value => 10);
say "Current: ", $x.current-value;
$x =:= 15;
say "Current: ", $x.current-value;
$x =:= 5;
say "Current: ", $x.current-value;
$x =:= 20;
say "Current: ", $x.current-value;
say "Past values: ", $x.get-past-values;
When running the program; I get warnings for each assignment:
Useless use of "=:=" in expression "$x =:= 15" in sink context (line 18)
I do not know how to suppress these warnings (it seems that the no warnings ... pragma isn't implemented yet), but the program otherwise runs correctly and displays the successive values:
Current: 10
Current: 15
Current: 5
Current: 20
Past values: [10 15 5]
Wrapping up
The next week Perl Weekly Challenge is due to start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on Sunday, October 6. And, please, also spread the word about the Perl Weekly Challenge if you can.
I am the author of the "Think Perl 6" book (O'Reilly, 2017) and I blog about the Perl 5 and Raku programming languages.
Leave a comment