Perl Weekly Challenge 101.

My solutions (task 1 and task 2) to the The Weekly Challenge - 101.

Task 1: Pack a Spiral

Submitted by: Stuart Little

You are given an array @A of items (integers say, but they can be anything).

Your task is to pack that array into an MxN matrix spirally counterclockwise, as tightly as possible.

‘Tightly’ means the absolute value M-N of the difference has to be as small as possible.

Example 1:

Input: @A = (1,2,3,4)

Output:

    4 3
    1 2

Since the given array is already a 1x4 matrix on its own, but that’s not as tight as possible. Instead, you’d spiral it counterclockwise into

4 3
1 2

Example 2:

Input: @A = (1..6)

Output:

    6 5 4
    1 2 3

or

5 4
6 3
1 2

Either will do as an answer, because they’re equally tight.

Example 3:

Input: @A = (1..12)

Output:

       9  8  7 6
      10 11 12 5
       1  2  3 4

or

 8  7 6
 9 12 5
10 11 4
 1  2 3

There is an ambiguity in the task. Should empty slots be allowed? Or should all available places in the rectangular array be used? In other terms, should M and N divide the size of the array @A exactly or is it allowed to use M and N such that MxN> size of @A? I’ll assume that they have to be exact divisors. Then I can choose M to be largest divisor below the sqrt and N the smallest divisor above the sqrt. I assume all the input data is contained in @ARGV.

First I load the usual packages and define a simple usage sub.

# Perl weekly challenge 101
# Task 1: Pack a spiral
#
# See https://wlmb.github.io/2021/02/22/PWC101/#task-1-pack-a-spiral
use strict;
use warnings;
use v5.12;
use POSIX qw(floor);
use List::Util qw(first);

sub usage {
    say "./ch-1.pl item1 item2...\nArranges items in spiral";
    exit 1;
}

Now I find out how to best factor the number of elements of the array, and I initialize a few variables.

my $M=first {@ARGV%$_==0} reverse(1..sqrt @ARGV); #Highest divisor below sqrt
my $N=@ARGV/$M; #smallest divisor above sqrt
my $result=[[]]; #
my @current_coords=(0,-1); # starting position, left of first array element

Now comes the fun part. To build the spiral one has to store succesive values along a line until the border of the array is hit. Then the direction of motion is modified and the process continues. The border where it is disallowed to store values shrinks after each motion. All motions are similar. They only differ in the coordinate (x or y) that is affected, and in the way it is modified (increasing or decreasing) and the next direction to try after hitting the border. Thus I make a builder of motion routines parametrized by these parameters. The last parameter to this routine is the motion to try next in the order right, up, left, down and right again. Thus, to build $right I need $up, and to build $up I need $left, for $left I need $down and for $down I need $right. To break this vicious circle I use double indirection, where I use a reference to a reference to the subroutine. This allows initializations with routines that have not been built yet.

my $right;
my $down= build_moves(0,-1,  0, \$right);
my $left= build_moves(1,-1, -1, \$down);
my $up=   build_moves(0, 1, $N, \$left);
$right=   build_moves(1, 1, $M, \$up);
my $next_move=$right; # First move to try

The program just iterates over all the array elements putting them in their final place and then prints the results.

usage() unless @ARGV; #At least some argument is required
for(@ARGV){
    &$next_move();
    $result->[$current_coords[0]][$current_coords[1]]=$_;
}
say join " ", "Input:", @ARGV;
say join "\n", "Output:", reverse map {join "\t", @$_} @$result;

This is the tricky subroutine that builds the motion subs from a few parameters.

sub build_moves {
    my $index=shift; # which coordinate to affect
    my $delta=shift; # increment
    my $border=shift; # current position of border
    my $next=shift;  # next direction to try.
    sub {
	if($current_coords[$index]+$delta==$border){
	    $next_move=$$next;
	    $border= $border-$delta;
	    $next_move->();
	} else {
	    $current_coords[$index]+=$delta;
	}
    }
}

Example 1:

./ch-1.pl 1 2 3 4

Input: 1 2 3 4
Output:
4	3
1	2

Example 2:

./ch-1.pl 1 2 3 4 5 6

Input: 1 2 3 4 5 6
Output:
5	4
6	3
1	2

Example 3:

./ch-1.pl 1 2 3 4 5 6 7 8 9 10 11 12

Input: 1 2 3 4 5 6 7 8 9 10 11 12
Output:
8	7	6
9	12	5
10	11	4
1	2	3

Other examples:

./ch-1.pl a b c d e f g h i
./ch-1.pl a b c d e f g h i j
./ch-1.pl a b c d e f g h i j k
./ch-1.pl a b c d e f g h i j k l

Input: a b c d e f g h i
Output:
g	f	e
h	i	d
a	b	c
Input: a b c d e f g h i j
Output:
g	f
h	e
i	d
j	c
a	b
Input: a b c d e f g h i j k
Output:
k
j
i
h
g
f
e
d
c
b
a
Input: a b c d e f g h i j k l
Output:
h	g	f
i	l	e
j	k	d
a	b	c

Another solution could be obtained by using the power of the Perl Data Language to build the array. The first part of the program would be almost identical.

# Perl weekly challenge 101
# Task 1: Pack a spiral PDL solution
#
# See https://wlmb.github.io/2021/02/22/PWC101/#task-1-pack-a-spiral
use strict;
use warnings;
use v5.12;
use List::Util qw(first);
use PDL;
use PDL::NiceSlice;

sub usage {
    say "./ch-1.pl item1 item2...\nArranges items in spiral";
    exit 1;
}
my $total=@ARGV;
my $M=first {@ARGV%$_==0} reverse(1..sqrt @ARGV); #Highest divisor below sqrt
my $N=@ARGV/$M; #smallest divisor above sqrt

I use the spiral subroutine (below) to make a pdl with indices. I use these indices to print the final array.

my $m=zeroes($M, $N);
spiral($m,0);
say "Input: ", join " ", @ARGV;
say "Output:";
for my $r(reverse 0..$N-1){
    print $ARGV[$m->at($_, $r)], "\t" for (0..$M-1);
    say "";
}

Now I build a spiral of indices. To get a spiral with N rows and M columns I make a row of M elements, organize recursively the remaining elements in a spiral of M rows and N-1 columns, and I rotate that spiral counterclockwise to join to the first row.

sub spiral { # receive a pdl to store result and the starting value
    my ($m, $start)=@_;
    $m(,(0)).=sequence($m->dim(0))+$start;
    return $m if $m->dim(1)==1;
    spiral($m->transpose->(1:-1,-1:0), $start+$m->dim(0));
}

Example 1:

./ch-1a.pl 1 2 3 4

Input: 1 2 3 4
Output:
4	3
1	2

Example 2:

./ch-1a.pl 1 2 3 4 5 6

Input: 1 2 3 4 5 6
Output:
5	4
6	3
1	2

Example 3:

./ch-1a.pl 1 2 3 4 5 6 7 8 9 10 11 12

Input: 1 2 3 4 5 6 7 8 9 10 11 12
Output:
8	7	6
9	12	5
10	11	4
1	2	3

Other examples:

./ch-1a.pl a b c d e f g h i
./ch-1a.pl a b c d e f g h i j
./ch-1a.pl a b c d e f g h i j k
./ch-1a.pl a b c d e f g h i j k l

Input: a b c d e f g h i
Output:
g	f	e
h	i	d
a	b	c
Input: a b c d e f g h i j
Output:
g	f
h	e
i	d
j	c
a	b
Input: a b c d e f g h i j k
Output:
k
j
i
h
g
f
e
d
c
b
a
Input: a b c d e f g h i j k l
Output:
h	g	f
i	l	e
j	k	d
a	b	c

Task 2: Origin-containing Triangle

Submitted by: Stuart Little

You are given three points in the plane, as a list of six co-ordinates: A=(x1,y1), B=(x2,y2) and C=(x3,y3).

Write a script to find out if the triangle formed by the given three co-ordinates contain origin (0,0).

Print 1 if found otherwise 0.

Example 1:

Input: A=(0,1), B=(1,0) and C=(2,2)

Output: 0

because that triangle does not contain (0,0).

Example 2:

Input: A=(1,1), B=(-1,1) and C=(0,-3)

Output: 1 because that triangle contains (0,0) in its interior.
Example 3:
Input: A=(0,1), B=(2,0) and C=(-6,0)

Output: 1

because (0,0) is on the edge connecting B and C.

If the origin is within the triangle, the sign of the vector products of consecutive vectors traversed in a cyclically doesn’t change. This allows almost-one-liner solutions

Example 1:

perl -MList::Util=pairs -E 'sub c {($a,$b,$c,$d)=(@{$_[0]},@{$_[1]}); return $a*$d-$b*$c;}
($A,$B,$C)=pairs @ARGV;
$r=(c($A,$B)>=0&& c($B,$C)>=0 && c($C,$A)>=0)||(c($A,$B)<=0 && c($B,$C)<=0 && c($C,$A)<=0)?1:0;
say "Output: $r"' 0 1 1 0 2 2

Output: 0

Example 2:

perl -MList::Util=pairs -E 'sub c {($a,$b,$c,$d)=(@{$_[0]},@{$_[1]}); return $a*$d-$b*$c;}
($A,$B,$C)=pairs @ARGV;
$r=(c($A,$B)>=0&& c($B,$C)>=0 && c($C,$A)>=0)||(c($A,$B)<=0 && c($B,$C)<=0 && c($C,$A)<=0)?1:0;
say "Output: $r"' 1 1 -1 1 0 -3

Output: 1

Example 3:

perl -MList::Util=pairs -E 'sub c {($a,$b,$c,$d)=(@{$_[0]},@{$_[1]}); return $a*$d-$b*$c;}
($A,$B,$C)=pairs @ARGV;
$r=(c($A,$B)>=0&& c($B,$C)>=0 && c($C,$A)>=0)||(c($A,$B)<=0 && c($B,$C)<=0 && c($C,$A)<=0)?1:0;
say "Output: $r"'  0 1 2 0 -6 0

Output: 1

A full program would only add some checks.

# Perl weekly challenge 101
# Task 2: Origin containing triangle
#
# See https://wlmb.github.io/2021/02/22/PWC101/#task-2-origin-containing-triangle
use strict;
use warnings;
use v5.12;
use POSIX qw(floor);
use List::Util qw(all any pairs);
use Scalar::Util qw(looks_like_number);

sub usage {
    say "./ch-2.pl x1 y1 x2 y2 x3 y3\nChecks if origin in triangle (x1,y1)(x2,y2)(x3,y3)";
    exit 1;
}

sub cross {
    my ($A, $B)=@_;
    return $A->[0]*$B->[1]-$A->[1]*$B->[0];
}
usage() unless @ARGV==6 and all {looks_like_number $_} @ARGV;
my ($A, $B, $C)=pairs @ARGV;
my ($AB, $BC, $CA)=(cross($A,$B), cross($B,$C), cross($C,$A));
my $clockwise=all {$_>=0} ($AB, $BC, $CA);
my $counterclockwise=all {$_<=0} ($AB, $BC, $CA);
my $result=($clockwise||$counterclockwise)?1:0;
my $edge=any {$_==0} ($AB, $BC, $CA);
say "Input: ", join " ", map {"($_->[0],$_->[1])"} ($A, $B, $C);
say "Output: $result";
say "Since (0,0) is within the triangle" if $result and !$edge;
say "Since (0,0) is within an edge" if $result and $edge;
say "Since (0,0) is not within the triangle" unless $result;

Example 1:

./ch-2.pl 0 1 1 0 2 2

Input: (0,1) (1,0) (2,2)
Output: 0
Since (0,0) is not within the triangle

Example 2:

./ch-2.pl 1 1 -1 1 0 -3

Input: (1,1) (-1,1) (0,-3)
Output: 1
Since (0,0) is within the triangle

Example 3:

./ch-2.pl 0 1 2 0 -6 0

Input: (0,1) (2,0) (-6,0)
Output: 1
Since (0,0) is within an edge
Written on February 22, 2021