Merge pull request #3104 from jacoby/master

Challenge 93

3 files changed, 378 insertions, 0 deletions

diff --git a/challenge-093/dave-jacoby/perl/ch-1.pl b/challenge-093/dave-jacoby/perl/ch-1.pl
new file mode 100644
index 0000000000..576d85141a
--- /dev/null
+++ b/challenge-093/dave-jacoby/perl/ch-1.pl
@@ -0,0 +1,140 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+use Algorithm::Permute;
+
+my @examples;
+push @examples, [ 1, [ [ 1, 1 ], [ 2, 2 ], [ 3, 3 ] ] ];
+push @examples, [ 2, [ [ 1, 1 ], [ 2, 2 ], [ 3, 1 ], [ 1, 3 ], [ 5, 3 ] ] ];
+push @examples,
+    [
+    3,
+    [ [ 1, 1 ], [ 2, 2 ], [ 3, 1 ], [ 1, 3 ], [ 3, 3 ], [ 4, 4 ], [ 5, 3 ] ]
+    ];
+push @examples, [ 4, [ [ 1, 2 ], [ 2, 4 ], [ 3, 6 ], [ 4, 8 ] ] ];
+
+# here we go through every example set and create output
+# like in the instructions
+for my $example (@examples) {
+    my @points = $example->[1]->@*;
+    say qq{EXAMPLE $example->[0]};
+    say '';
+    plot_points(@points);
+    my $output = max_points( \@points );
+
+    say 'Input:  ' . join ', ',
+        map { "($_)" } map { join ',', $_->@* } $example->[1]->@*;
+    say 'Output: ' . $output;
+    say '';
+}
+
+# if we have two points, we have a line, so the minimum
+# covered here is 2. perhaps a test for a set with one point?
+
+# but anyway, we pull out every three-point subset and
+# test that, and if that works fine, we go to the four-point
+# subsets and so on. a problem is that we use Algoritm::Permute
+# which means for the set 1,2,3, we cover it six times, but
+# it cleanly avoids all the headaches of putting together the
+# subsets yourself, and is very fast.
+
+# we test every subset, and if we fine a positive, that 
+# means there is a line of this length, and then we go onto 
+# the next length, because we don't care how many i-length
+# lines there are; we just need one.
+sub max_points ( $set ) {
+    my $max = 2;
+    my $len = scalar $set->@*;
+
+OUTER: for my $i ( 3 .. $len ) {
+        my $ap = Algorithm::Permute->new( $set, $i );
+        while ( my @res = $ap->next ) {
+            my $t = test_area(@res);
+            if ($t) {
+                $max = $i;
+                last OUTER;
+            }
+        }
+    }
+    return $max;
+}
+
+# break up to triangles, which makes the area math easier
+# and test every triangle for area 0, which would indicate
+# a line. If we only get area 0, they're all on the line.
+
+# first pass, I used Algorithm::Permute to go through all
+# possible combinations, but no. Take a five-point set.
+# we first test the first three. If there's a line there,
+# there's a line. 
+#
+#   1 2 3 4 5
+#   ^ ^ ^
+#
+# then we look at the second, third and fourth, and if the 
+# fourth is in line with the second and third, it's in line 
+# with the first.
+#
+#   1 2 3 4 5
+#     ^ ^ ^
+#
+# and so on to the fifth.
+#
+#   1 2 3 4 5
+#       ^ ^ ^
+#
+# which means that the subroutine is simpler and shorter than 
+# the comment explaining it
+sub test_area( @set ) {
+    my $passes = 0;
+    my $loops  = 0;
+    for my $i ( 2 .. -1 + scalar @set ) {
+        my @subset = map { $set[$_] } $i - 2, $i - 1, $i;
+        my $t = collinear(@subset);
+        $loops++;
+        $passes++ if $t;
+    }
+    return 1 if $loops == $passes;
+    return 0;
+}
+
+# finds area of a triangle, which would be zero if they're
+# on the same line
+sub collinear ( $p1, $p2, $p3 ) {
+    my $area =
+        $p1->[0] * ( $p2->[1] - $p3->[1] ) +
+        $p2->[0] * ( $p3->[1] - $p1->[1] ) +
+        $p3->[0] * ( $p1->[1] - $p2->[1] );
+    return $area == 0 ? 1 : 0;
+}
+
+# helper function to turn the array ref with the x and y
+# values into a string like "x,y"
+sub xy ( $point ) {
+    return join ',', $point->@*;
+}
+
+# this simply finds the highest x or y value, uses that 
+# as the graph size, and draws the graph and plots the points
+sub plot_points( @set ) {
+    my %xy = map { $_ => 1 } map { join ',', $_->@* } @set;
+    my @max;
+    for my $point (@set) {
+        push @max, $point->@*;
+    }
+    my ($max) = reverse sort @max;
+    $max++;
+    for my $y ( reverse 1 .. $max ) {
+        print '|';
+        for my $x ( 1 .. $max ) {
+            my $xy = join ',', $x, $y;
+            print $xy{$xy} ? ' X' : '  ';
+        }
+        say '';
+    }
+    say join ' ', '+', map { '-' } 0 .. $max;
+}
diff --git a/challenge-093/dave-jacoby/perl/ch-2.pl b/challenge-093/dave-jacoby/perl/ch-2.pl
new file mode 100644
index 0000000000..5f87aa9619
--- /dev/null
+++ b/challenge-093/dave-jacoby/perl/ch-2.pl
@@ -0,0 +1,120 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+# separate blocks so I can copy and paste a bit more
+# without the compiler barking at me
+{
+    my %hash = map { $_ => Node->new($_) } 1 .. 4;
+    $hash{1}->left( $hash{2} );
+    $hash{2}->left( $hash{3} );
+    $hash{2}->right( $hash{4} );
+    say 'EXAMPLE 1';
+    my @headers = qw{ sum value leaf };
+    say join "\t", '', @headers;
+    say join "\t", '', map { '=' x length $_ } @headers;
+    my $output = sum_paths( $hash{1} );
+    say qq{OUTPUT: $output};
+    say '';
+}
+
+{
+    my %hash = map { $_ => Node->new($_) } 1 .. 6;
+    $hash{1}->left( $hash{2} );
+    $hash{2}->left( $hash{4} );
+    $hash{1}->right( $hash{3} );
+    $hash{3}->left( $hash{5} );
+    $hash{3}->right( $hash{6} );
+    say 'EXAMPLE 2';
+    my @headers = qw{ sum value leaf };
+    say join "\t", '', @headers;
+    say join "\t", '', map { '=' x length $_ } @headers;
+    my $output = sum_paths( $hash{1} );
+    say qq{OUTPUT: $output};
+    say '';
+}
+
+exit;
+
+sub sum_paths ( $node ) {
+
+    # initial setup
+    my $left  = $node->left;
+    my $right = $node->right;
+
+    # is leaf
+    if ( !defined $left && !defined $right ) {
+
+        # we sum back to the root by copying the
+        # node (so we don't get lost), adding the
+        # value to the sum, and going a level to
+        # the root
+        my $n   = $node;
+        my $sum = $n->value;
+        while ( !$n->is_root ) {
+            $n = $n->parent;
+            $sum += $n->value;
+        }
+        say join "\t", '', $node->value, $sum, $node->is_leaf;
+        return $sum;
+    }
+
+    # then we go left, go right and return the sum we have
+    my $sum = 0;
+    $sum += sum_paths($left)  if defined $left;
+    $sum += sum_paths($right) if defined $right;
+    say join "\t", '', $node->value, $sum, $node->is_leaf;
+    return $sum;
+}
+
+# trees from my challenge 57, with the slightest revision
+
+package Node;
+
+sub new ( $class, $value = 0 ) {
+    my $self = {};
+    $self->{value}  = $value;
+    $self->{left}   = undef;
+    $self->{right}  = undef;
+    $self->{parent} = undef;
+    return bless $self, $class;
+}
+
+sub value ( $self ) {
+    return $self->{value};
+}
+
+sub is_root ( $self ) {
+    return defined $self->{parent} ? 0 : 1;
+}
+
+sub is_leaf ( $self ) {
+    return !defined $self->{left} && !defined $self->{right} ? 1 : 0;
+}
+
+sub left ( $self, $node = undef ) {
+    if ( defined $node ) {
+        $self->{left}   = $node;
+        $node->{parent} = $self;
+    }
+    else {
+        return $self->{left};
+    }
+}
+
+sub right ( $self, $node = undef ) {
+    if ( defined $node ) {
+        $self->{right}  = $node;
+        $node->{parent} = $self;
+    }
+    else {
+        return $self->{right};
+    }
+}
+
+sub parent ($self ) {
+    return $self->{parent};
+}
diff --git a/challenge-093/dave-jacoby/perl/ch-2b.pl b/challenge-093/dave-jacoby/perl/ch-2b.pl
new file mode 100644
index 0000000000..883320b09d
--- /dev/null
+++ b/challenge-093/dave-jacoby/perl/ch-2b.pl
@@ -0,0 +1,118 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+# I always forget that trees are not hard, especially if you can
+# keep track of the nodes outside of a tree. Here we create the
+# nodes as part of a hash, connect the children as appropriate,
+# then make an array of all the nodes, which know who their
+# neighbors are and thus can be used to navigate through the tree
+
+# this therefore doesn't do much with the
+
+my @nodes;
+{
+    my %hash = map { $_ => Node->new($_) } 1 .. 4;
+    $hash{1}->left( $hash{2} );
+    $hash{2}->left( $hash{3} );
+    $hash{2}->right( $hash{4} );
+    @nodes = values %hash;
+    say 'EXAMPLE 1';
+    sum_paths(@nodes);
+    say '';
+}
+
+{
+    my %hash = map { $_ => Node->new($_) } 1 .. 6;
+    $hash{1}->left( $hash{2} );
+    $hash{1}->right( $hash{3} );
+    $hash{2}->left( $hash{4} );
+    $hash{3}->left( $hash{5} );
+    $hash{3}->right( $hash{6} );
+    @nodes = values %hash;
+    say 'EXAMPLE 2';
+    sum_paths(@nodes);
+    say '';
+}
+
+exit;
+
+sub sum_paths ( @array ) {
+    my $sum = 0;    # we have no values yet
+
+    # headers: a good suggestion
+    my @headers = ( '', 'sum', 'value', 'leaf' );
+    say join "\t", @headers;
+    say join "\t", map { '=' x length $_ } @headers;
+
+    # check every node, but we only care if it's a leaf
+    for my $node (@array) {
+        if ( $node->is_leaf ) {
+
+            # if it IS a node, we copy the address and start
+            # from there, going down to the root, and adding
+            # the values of the nodes along the way
+            my $n = $node;
+            $sum += $n->value;
+            while ( !$n->is_root ) {
+                $n = $n->parent;
+                $sum += $n->value;
+            }
+
+        }
+        say join "\t", '', $sum, $node->value, $node->is_leaf;
+    }
+    say qq{OUTPUT: $sum};
+}
+
+# trees from my challenge 57, with the slightest revision
+
+package Node;
+
+sub new ( $class, $value = 0 ) {
+    my $self = {};
+    $self->{value}  = $value;
+    $self->{left}   = undef;
+    $self->{right}  = undef;
+    $self->{parent} = undef;
+    return bless $self, $class;
+}
+
+sub value ( $self ) {
+    return $self->{value};
+}
+
+sub is_root ( $self ) {
+    return defined $self->{parent} ? 0 : 1;
+}
+
+sub is_leaf ( $self ) {
+    return !defined $self->{left} && !defined $self->{right} ? 1 : 0;
+}
+
+sub left ( $self, $node = undef ) {
+    if ( defined $node ) {
+        $self->{left}   = $node;
+        $node->{parent} = $self;
+    }
+    else {
+        return $self->{left};
+    }
+}
+
+sub right ( $self, $node = undef ) {
+    if ( defined $node ) {
+        $self->{right}  = $node;
+        $node->{parent} = $self;
+    }
+    else {
+        return $self->{right};
+    }
+}
+
+sub parent ($self ) {
+    return $self->{parent};
+}