aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--challenge-093/dave-jacoby/perl/ch-1.pl140
-rw-r--r--challenge-093/dave-jacoby/perl/ch-2.pl120
-rw-r--r--challenge-093/dave-jacoby/perl/ch-2b.pl118
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};
+}
generated by cgit (git 2.34.1) at 2026-07-03 23:19:52 +0000