aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--challenge-118/polettix/blog.txt1
-rw-r--r--challenge-118/polettix/blog1.txt1
-rw-r--r--challenge-118/polettix/ch-1.input14
-rw-r--r--challenge-118/polettix/perl/ch-1.pl17
-rw-r--r--challenge-118/polettix/perl/ch-2.pl288
-rw-r--r--challenge-118/polettix/raku/ch-1.raku12
-rw-r--r--challenge-118/polettix/raku/ch-2.raku69
7 files changed, 388 insertions, 14 deletions
diff --git a/challenge-118/polettix/blog.txt b/challenge-118/polettix/blog.txt
new file mode 100644
index 0000000000..153c51bdc2
--- /dev/null
+++ b/challenge-118/polettix/blog.txt
@@ -0,0 +1 @@
+https://github.polettix.it/ETOOBUSY/2021/06/23/pwc118-binary-palindrome/
diff --git a/challenge-118/polettix/blog1.txt b/challenge-118/polettix/blog1.txt
new file mode 100644
index 0000000000..2ed6d851c6
--- /dev/null
+++ b/challenge-118/polettix/blog1.txt
@@ -0,0 +1 @@
+https://github.polettix.it/ETOOBUSY/2021/06/24/pwc118-adventure-of-knight/
diff --git a/challenge-118/polettix/ch-1.input b/challenge-118/polettix/ch-1.input
deleted file mode 100644
index 5b9d9ab1ce..0000000000
--- a/challenge-118/polettix/ch-1.input
+++ /dev/null
@@ -1,14 +0,0 @@
-11, Line Eleven
-1, Line one
-9, Line Nine
-13, Line Thirteen
-2, Line two
-6, Line Six
-8, Line Eight
-10, Line Ten
-7, Line Seven
-4, Line Four
-14, Line Fourteen
-3, Line three
-15, Line Fifteen
-5, Line Five
diff --git a/challenge-118/polettix/perl/ch-1.pl b/challenge-118/polettix/perl/ch-1.pl
new file mode 100644
index 0000000000..ec9462cb5a
--- /dev/null
+++ b/challenge-118/polettix/perl/ch-1.pl
@@ -0,0 +1,17 @@
+#!/usr/bin/env perl
+use 5.024;
+use warnings;
+use experimental qw< postderef signatures >;
+no warnings qw< experimental::postderef experimental::signatures >;
+
+sub binary_palindrome ($N) {
+ die "invalid $N (positive integers are OK)\n"
+ if $N !~ m{\A [1-9]\d* \z}mxs;
+ return unless $N % 2;
+ my ($M, $n) = (0, $N);
+ ($M, $n) = (($M << 1) | ($n & 1), $n >> 1) while $n > 0;
+ return $M == $N;
+}
+
+my @args = @ARGV ? @ARGV : 1 .. 31;
+say $_, ' -> ', binary_palindrome($_) ? 1 : 0 for @args;
diff --git a/challenge-118/polettix/perl/ch-2.pl b/challenge-118/polettix/perl/ch-2.pl
new file mode 100644
index 0000000000..d079d7d3a4
--- /dev/null
+++ b/challenge-118/polettix/perl/ch-2.pl
@@ -0,0 +1,288 @@
+#!/usr/bin/env perl
+use 5.024;
+use warnings;
+use experimental qw< postderef signatures >;
+no warnings qw< experimental::postderef experimental::signatures >;
+use List::Util qw< sum >;
+
+my $input = shift // do {
+ my $default = <<'END';
+ a b c d e f g h
+ 8 N * * * * * * * 8
+ 7 * * * * * * * * 7
+ 6 * * * * x * * * 6
+ 5 * * * * * * * * 5
+ 4 * * x * * * * * 4
+ 3 * x * * * * * * 3
+ 2 x x * * * * * * 2
+ 1 * x * * * * * * 1
+ a b c d e f g h
+END
+ \$default;
+};
+print_solution(adventure_of_knight(parse_input($input)));
+
+sub adventure_of_knight ($input) {
+
+ # First, analyze the setup to find the minimum distance/path from
+ # every location on the board to every other location, accounting for
+ # the knight way of moving
+ my $max_X = $input->{row_names}->$#*;
+ my $max_Y = $input->{col_names}->$#*;
+ my $analysis = floyd_warshall(
+ distance => sub { 1 },
+ identifier => sub ($node) { join ',', $node->@* },
+ start => $input->{knight},
+ successors => sub ($node) {
+ my ($x, $y) = $node->@*;
+ my @succs;
+ for my $long (-2, +2) {
+ for my $short (-1, +1) {
+ for my $p ([$long, $short], [$short, $long]) {
+ my ($X, $Y) = ($x + $p->[0], $y + $p->[1]);
+ push @succs, [$X, $Y]
+ if ($X >= 0) && ($X <= $max_X)
+ && ($Y >= 0) && ($Y <= $max_Y);
+ }
+ }
+ }
+ return @succs;
+ },
+ );
+
+ # Second, evaluate the total distance over all possible sequencing of
+ # treasures, keeping the path with the shorter distance. This is not
+ # optimal as the number of treasures grows, but for a fixed number of
+ # treasures at 6 it means that only 720 permutations have to be
+ # considered, which is fair.
+ my $pit = permutations_iterator(items => $input->{treasures});
+ my ($min_distance, @min_path);
+ while (my @path = $pit->()) {
+ unshift @path, $input->{knight};
+ my $distance = sum map {
+ $analysis->{distance}->(@path[$_ - 1, $_]);
+ } 1 .. $#path;
+ ($min_distance, @min_path) = ($distance, @path)
+ if ! defined($min_distance) || $distance < $min_distance;
+ }
+
+ # Last, adapt our finding to provide an array of path sections that
+ # have to be walked in sequence. This is the main part of our output.
+ my @sections = map {
+ my @section = $analysis->{path}->(@min_path[$_ - 1, $_]);
+ shift @section;
+ \@section;
+ } 1 .. $#min_path;
+ return {
+ $input->%*,
+ sections => \@sections,
+ };
+}
+
+sub print_solution ($solution) {
+ my $position_for = sub ($x, $y) {
+ $solution->{col_names}[$x] . $solution->{row_names}[$y];
+ };
+ my @stops = (
+ $position_for->($solution->{knight}->@*) . '.N',
+ map {
+ my @section = map {$position_for->($_->@*)} $_->@*;
+ $section[-1] = $section[-1] . '.x';
+ @section;
+ } $solution->{sections}->@*,
+ );
+ say join ' ', @stops;
+ say scalar(@stops) - 1, ' moves';
+}
+
+sub parse_input ($fof) {
+ my $fh = ref($fof) eq 'GLOB' ? $fof
+ : (! ref($fof) && ($fof eq '-')) ? \*STDIN
+ : do { open my $x, '<', $fof or die 'file...'; $x };
+ my ($knight, @treasures, @row_names, @col_names);
+ while (<$fh>) {
+ s{\A\s+|\s+\z}{}gmxs;
+ my @row = split m{\s+}mxs;
+
+ if (m{\A \s* \d}mxs) {
+ my $i = @row_names;
+ push @row_names, shift @row;
+ pop @row;
+
+ for my $j (0 .. $#row) {
+ my $char = $row[$j];
+ if ($char eq 'N') {
+ die "too many knights\n" if defined $knight;
+ $knight = [$j, $i];
+ }
+ elsif ($char eq 'x') {
+ push @treasures, [$j, $i];
+ }
+ elsif ($char ne '*') {
+ die "invalid character '$char'\n";
+ }
+ }
+ }
+ elsif (! @col_names) {
+ @col_names = @row;
+ }
+ }
+ return {
+ knight => $knight,
+ treasures => \@treasures,
+ row_names => \@row_names,
+ col_names => \@col_names,
+ };
+}
+
+sub floyd_warshall {
+ my %args = (@_ && ref($_[0])) ? %{$_[0]} : @_;
+ my @reqs = qw< distance successors >;
+ exists($args{$_}) || die "missing parameter '$_'" for @reqs;
+ my ($dist, $scs) = @args{@reqs};
+ my $id_of = $args{identifier} || sub { return "$_[0]" };
+ my @q = exists($args{starts}) ? @{$args{starts}}
+ : exists($args{start}) ? ($args{start})
+ : die "missing parameter 'starts' or 'start'";
+ my (%d, %p, %nf); # distances, predecessors
+ while (@q) { # initialization
+ next if exists $nf{my $vi = $id_of->(my $v = shift @q)};
+ for my $w ($scs->($nf{$vi} = $v)) {
+ next if $vi eq (my $wi = $id_of->($w)); # avoid self-edges
+ ($d{$vi}{$wi}, $p{$vi}{$wi}) = ($dist->($v, $w), $vi);
+ push @q, $w unless exists $nf{$wi};
+ }
+ $d{$vi}{$vi} = 0;
+ }
+ my @vs = keys %nf;
+ for my $vi (@vs) {
+ for my $vv (@vs) {
+ next unless exists $p{$vv}{$vi};
+ for my $vw (@vs) {
+ next if (!exists $d{$vi}{$vw}) || (exists($d{$vv}{$vw})
+ && ($d{$vv}{$vw} <= $d{$vv}{$vi} + $d{$vi}{$vw}));
+ $d{$vv}{$vw} = $d{$vv}{$vi} + $d{$vi}{$vw};
+ $p{$vv}{$vw} = $p{$vi}{$vw};
+ }
+ return if $d{$vv}{$vv} < 0; # negative cycle, bail out
+ }
+ }
+ return {
+ has_path => sub {
+ my ($vi, $wi) = map { $id_of->($_) } @_[0, 1];
+ return exists($d{$vi}) && exists($d{$vi}{$wi});
+ },
+ distance => sub {
+ my ($vi, $wi) = map { $id_of->($_) } @_[0, 1];
+ return unless exists($d{$vi}) && exists($d{$vi}{$wi});
+ return $d{$vi}{$wi};
+ },
+ path => sub {
+ my ($fi, $ti) = map { $id_of->($_) } @_[0, 1];
+ return unless exists($d{$fi}) && exists($d{$fi}{$ti});
+ my @path;
+ while ($ti ne $fi) {
+ unshift @path, $nf{$ti};
+ $ti = $p{$fi}{$ti};
+ }
+ unshift @path, $nf{$ti};
+ return wantarray ? @path : \@path;
+ },
+ };
+}
+
+sub permutations_iterator {
+ my %args = (@_ && ref($_[0])) ? %{$_[0]} : @_;
+ my $items = $args{items} || die "invalid or missing parameter 'items'";
+ my $filter = $args{filter} || sub { wantarray ? @_ : [@_] };
+ my @indexes = 0 .. $#$items;
+ my @stack = (0) x @indexes;
+ my $sp = undef;
+ return sub {
+ if (! defined $sp) { $sp = 0 }
+ else {
+ while ($sp < @indexes) {
+ if ($stack[$sp] < $sp) {
+ my $other = $sp % 2 ? $stack[$sp] : 0;
+ @indexes[$sp, $other] = @indexes[$other, $sp];
+ $stack[$sp]++;
+ $sp = 0;
+ last;
+ }
+ else {
+ $stack[$sp++] = 0;
+ }
+ }
+ }
+ return $filter->(@{$items}[@indexes]) if $sp < @indexes;
+ return;
+ }
+}
+
+package PriorityQueue; # Adapted from https://algs4.cs.princeton.edu/24pq/
+use strict;
+
+sub contains { return $_[0]->contains_id($_[0]{id_of}->($_[1])) }
+sub contains_id { return exists $_[0]{item_of}{$_[1]} }
+sub is_empty { return !$#{$_[0]{items}} }
+sub item_of { exists($_[0]{item_of}{$_[1]}) ? $_[0]{item_of}{$_[1]} : () }
+sub new; # see below
+sub dequeue { return $_[0]->_remove_kth(1) }
+sub enqueue; # see below
+sub remove { return $_[0]->remove_id($_[0]{id_of}->($_[1])) }
+sub remove_id { return $_[0]->_remove_kth($_[0]{pos_of}{$_[1]}) }
+sub size { return $#{$_[0]{items}} }
+sub top { return $_[0]->size ? $_[0]{items}[1] : () }
+sub top_id { return $_[0]->size ? $_[0]{id_of}->($_[0]{items}[1]) : () }
+
+sub new {
+ my $package = shift;
+ my $self = bless {((@_ && ref($_[0])) ? %{$_[0]} : @_)}, $package;
+ $self->{before} ||= sub { return $_[0] < $_[1] };
+ $self->{id_of} ||= sub { return ref($_[0]) ? "$_[0]" : $_[0] };
+ my $items = $self->{items} || [];
+ @{$self}{qw< items pos_of item_of >} = (['-'], {}, {});
+ $self->enqueue($_) for @$items;
+ return $self;
+} ## end sub new
+
+sub enqueue { # insert + update in one... DWIM
+ my ($is, $id) = ($_[0]{items}, $_[0]{id_of}->($_[1]));
+ $_[0]{item_of}{$id} = $_[1]; # keep track of this item
+ my $k = $_[0]{pos_of}{$id} ||= do { push @$is, $_[1]; $#$is };
+ $_[0]->_adjust($k);
+ return $id;
+} ## end sub enqueue
+
+sub _adjust { # assumption: $k <= $#$is
+ my ($is, $before, $self, $k) = (@{$_[0]}{qw< items before >}, @_);
+ $k = $self->_swap(int($k / 2), $k)
+ while ($k > 1) && $before->($is->[$k], $is->[$k / 2]);
+ while ((my $j = $k * 2) <= $#$is) {
+ ++$j if ($j < $#$is) && $before->($is->[$j + 1], $is->[$j]);
+ last if $before->($is->[$k], $is->[$j]); # parent is OK
+ $k = $self->_swap($j, $k);
+ }
+ return $self;
+} ## end sub _adjust
+
+sub _remove_kth {
+ my ($is, $self, $k) = ($_[0]{items}, @_);
+ die 'no such item' if (!defined $k) || ($k <= 0) || ($k > $#$is);
+ $self->_swap($k, $#$is);
+ my $r = CORE::pop @$is;
+ $self->_adjust($k) if $k <= $#$is; # no adjust for last element
+ my $id = $self->{id_of}->($r);
+ delete $self->{$_}{$id} for qw< item_of pos_of >;
+ return $r;
+} ## end sub _remove_kth
+
+sub _swap {
+ my ($self, $i, $j) = @_;
+ my ($items, $pos_of, $id_of) = @{$self}{qw< items pos_of id_of >};
+ my ($I, $J) = @{$items}[$i, $j] = @{$items}[$j, $i];
+ @{$pos_of}{($id_of->($I), $id_of->($J))} = ($i, $j);
+ return $i;
+} ## end sub _swap
+
+1;
diff --git a/challenge-118/polettix/raku/ch-1.raku b/challenge-118/polettix/raku/ch-1.raku
new file mode 100644
index 0000000000..3d3e17ee8a
--- /dev/null
+++ b/challenge-118/polettix/raku/ch-1.raku
@@ -0,0 +1,12 @@
+#!/usr/bin/env raku
+use v6;
+sub binary-palindrome (Int:D $N where * > 0 --> Bool) {
+ return False if $N %% 2;
+ my ($M, $n) = (0, $N);
+ ($M, $n) = (($M +< 1) +| ($n +& 1), $n +> 1) while $n > 0;
+ return so $M == $N;
+}
+sub MAIN (*@args is copy) {
+ @args = 1 .. 31;
+ put $_, ' -> ', binary-palindrome($_) ?? 1 !! 0 for @args;
+}
diff --git a/challenge-118/polettix/raku/ch-2.raku b/challenge-118/polettix/raku/ch-2.raku
new file mode 100644
index 0000000000..1ea79168aa
--- /dev/null
+++ b/challenge-118/polettix/raku/ch-2.raku
@@ -0,0 +1,69 @@
+#!/usr/bin/env raku
+use v6;
+
+my $knight = (0, 0);
+my @treasures = < 4 2 2 4 1 5 0 6 1 6 1 7 >.map({($^a, $^b)});
+my $optimal = @*ARGS ?? True !! False;
+
+my @path = adventure-of-knight($knight, @treasures, $optimal).flat;
+@path.join(' ').put;
+put @path.end, ' moves';
+
+sub adventure-of-knight ($knight, @treasures, $optimal = False) {
+ sub pos-to-pos ($p) {
+ state @rows = (1..8).reverse;
+ state @cols = 'a' .. 'h';
+ return @cols[$p[0]] ~ @rows[$p[1]];
+ }
+ sub permutation-pass ($knight is copy, @treasures) {
+ return gather {
+ for @treasures -> $treasure {
+ take path-between($knight, $treasure);
+ $knight = $treasure;
+ }
+ }
+ }
+ my ($min_distance, @min_path);
+ for permutations(@treasures) -> @perm {
+ my @path = permutation-pass($knight, @perm).flat;
+ my $distance = @path.map({$_.end}).sum;
+ ($min_distance, @min_path) = ($distance, @path.Slip)
+ if ! defined($min_distance) || $distance < $min_distance;
+ last unless $optimal;
+ }
+ return gather {
+ take pos-to-pos($knight) ~ '.N';
+ for @min_path -> $sequence {
+ my ($first, @rest) = @$sequence; # $first will be ignored
+ my $treasure = @rest.pop;
+ @rest.map({take pos-to-pos($_)});
+ take pos-to-pos($treasure) ~ '.x';
+ }
+ }
+}
+
+sub path-between ($start, $stop) {
+ sub same { ($^a <<->> $^b).map({$_²}).sum == 0 };
+ return () if same($start, $stop);
+ my $visited = SetHash.new();
+ my @queue = (($start,),);
+ while @queue.elems {
+ my $subpath = @queue.shift;
+ my ($x, $y) = @$subpath[*-1];
+ for -2, 2 -> $long {
+ for -1, 1 -> $short {
+ for ($long, $short), ($short, $long) -> $pair {
+ my ($X, $Y) = ($x + $pair[0], $y + $pair[1]);
+ next unless (0 <= $X <= 7) && (0 <= $Y <= 7);
+ my $pos = "$X,$Y";
+ next if $visited{$pos};
+ $visited.set($pos);
+ my $newpath = ($subpath.Slip, ($X, $Y));
+ return $newpath if same(($X, $Y), $stop);
+ push @queue, $newpath;
+ }
+ }
+ }
+ }
+ die 'no way';
+}
generated by cgit (git 2.34.1) at 2026-07-02 16:49:00 +0000