Merge pull request #9667 from jo-37/glpk

Solutions to challenges 216 and 219 in Perl

4 files changed, 207 insertions, 0 deletions

diff --git a/challenge-216/jo-37/blog.txt b/challenge-216/jo-37/blog.txt
new file mode 100644
index 0000000000..2d4bfc89b3
--- /dev/null
+++ b/challenge-216/jo-37/blog.txt
@@ -0,0 +1 @@
+https://github.sommrey.de/the-bears-den/2024/02/27/ch-216.html
diff --git a/challenge-216/jo-37/perl/ch-2.pl b/challenge-216/jo-37/perl/ch-2.pl
new file mode 100755
index 0000000000..b7981c2770
--- /dev/null
+++ b/challenge-216/jo-37/perl/ch-2.pl
@@ -0,0 +1,96 @@
+#!/usr/bin/perl -s
+
+use v5.24;
+use Test2::V0 '!float';
+use PDL;
+use PDL::Opt::GLPK;
+
+our ($tests, $examples, $verbose);
+
+run_tests() if $tests || $examples;	# does not return
+
+die <<EOS unless @ARGV > 1;
+usage: $0 [-examples] [-tests] [-verbose]  [TARGET STICKER...]
+
+-examples
+    run the examples from the challenge
+ 
+-tests
+    run some tests
+
+-verbose
+    show the required stickers instead of their count and print
+    the underlying linear program to "ch-2.lp" in CPLEX LP format
+
+TARGET
+    the word to be build from the given stickers
+
+STICKER
+    a list of stickers
+
+EOS
+
+
+### Input and Output
+
+main: {
+    my ($selection, $count) = min_stickers(@ARGV);
+    if ($verbose) {
+        say "@$selection";
+    } else {
+        say $count;
+    }
+}
+
+
+### Implementation
+
+sub min_stickers {
+    my $target = long map ord, split //, shift;
+    my $stickers = long map [map ord, split //, $_], @_;
+
+    my ($b, $required) = $target->qsort->rle;
+    my $a = ($required->dummy(0)->dummy(0) == $stickers)->sumover;
+    my $c = ones($a->dim(1));
+
+    my $xopt = null;
+    my $fopt = null;
+    my $status = null;
+
+    eval {
+        glpk($c, $a, $b, zeros($c), inf($c),
+            GLP_LO * ones($b), GLP_IV * ones($c), GLP_MIN,
+            $xopt, $fopt, $status,
+            {save_pb => $verbose, save_fn => 'ch-2.lp'});
+        1;
+    } || return ([], 0);
+
+    ([map +($_[$_]) x $xopt->at($_), 0 .. $#_], $fopt);
+}
+
+
+### Examples and tests
+
+sub run_tests {
+    SKIP: {
+        skip "examples" unless $examples;
+
+        is scalar(min_stickers('peon' => 'perl','raku','python')), 2,
+            'example 1';
+        is scalar(min_stickers('goat' => 'love','hate','angry')), 3,
+            'example 2';
+        is scalar(min_stickers('accomodation' => 'come','nation','delta')), 4,
+            'example 3';
+        is scalar(min_stickers('accomodation' => 'come','country','delta')), 0,
+            'example 4';
+    }
+
+    SKIP: {
+        skip "tests" unless $tests;
+
+        is scalar(min_stickers('feo' => 'fee', 'foo')), 2, 'integer solution';
+	}
+
+    done_testing;
+    exit;
+}
diff --git a/challenge-219/jo-37/perl/blog.txt b/challenge-219/jo-37/perl/blog.txt
new file mode 100644
index 0000000000..457174aac7
--- /dev/null
+++ b/challenge-219/jo-37/perl/blog.txt
@@ -0,0 +1 @@
+https://github.sommrey.de/the-bears-den/2024/02/27/ch-219.html
diff --git a/challenge-219/jo-37/perl/ch-2.pl b/challenge-219/jo-37/perl/ch-2.pl
new file mode 100755
index 0000000000..7572744852
--- /dev/null
+++ b/challenge-219/jo-37/perl/ch-2.pl
@@ -0,0 +1,109 @@
+#!/usr/bin/perl -s
+
+use v5.24;
+use Test2::V0 '!float';
+use PDL;
+use PDL::NiceSlice;
+use PDL::Opt::GLPK;
+use experimental 'signatures';
+
+our ($tests, $examples, $duration, $price, $verbose);
+
+run_tests() if $tests || $examples;	# does not return
+
+die <<EOS unless $price && @ARGV;
+usage: $0 [-examples] [-tests] [-verbose] [-duration=DURATION]
+    [-price=PRICE] [DAY...]
+
+-examples
+    run the examples from the challenge
+ 
+-tests
+    run some tests
+
+-verbose
+    explain the solution as in the examples
+
+-duration=DURATION
+    list of card durations. Default: 1, 7, 30
+
+-price=PRICE
+    list of card prices
+
+DAY...
+    list of travel days
+
+EOS
+
+
+### Input and Output
+
+main: {
+    my @duration = $duration ? split /[, ] */, $duration : (1, 7, 30);
+    my @price = split /[, ] */, $price;
+
+    die "duration and price have different sizes" if @duration != @price;
+    my @cards = map [$duration[$_], $price[$_]], 0 .. $#duration;
+
+    my ($selection, $cost) = travel_cost(\@cards, \@ARGV);
+    
+    if ($verbose) {
+        printf "On day %d, we buy a %3\$d-day pass for %2\$d.\n", @$_
+            for @$selection;
+        say "total cost: $cost";
+    } else {
+        say $cost;
+    }
+
+}
+
+
+### Implementation
+
+sub travel_cost ($crd, $dy) {
+    my $cards = long @$crd;
+    my $days = long $dy;
+    my $from = $days->dummy(1);
+    my $to = $from + $cards((0))->dummy(0);
+    my $valid = ($days->dummy(1) >= $from->dummy(0)) &
+        ($days->dummy(1) < $to->dummy(0));
+
+    my $a = $valid->clump(1,2)->xchg(0,1);
+    my $b = ones($days);
+    my $c = $cards((1))->dummy(0,$days->dim(0))->clump(-1);
+
+    my $xopt = null;
+    my $fopt = null;
+    my $status = null;
+
+    glpk($c, $a, $b, zeros($c), zeros($c), GLP_LO * ones($b),
+        GLP_BV * ones($c), GLP_MIN, $xopt, $fopt, $status);
+
+    my $selection = $xopt->reshape($to->dims);
+    my $solution = whichND $selection;
+
+    ($days->dice($solution((0)))->dummy(0)
+        ->glue(0, $cards->dice('X', $solution((1))))->qsortvec->unpdl, $fopt);
+}
+
+
+### Examples and tests
+
+sub run_tests {
+    SKIP: {
+        skip "examples" unless $examples;
+        is scalar(travel_cost([[1, 2], [7, 7], [30, 25]], [1, 5, 6, 7, 9, 15])),
+            11, 'example 1';
+
+        is scalar(travel_cost([[1, 2], [7, 7], [30, 25]],
+            [1, 2, 3, 5, 7, 10, 11, 12, 14, 20, 30, 31])),
+            20, 'example 2';
+    }
+
+    SKIP: {
+        skip "tests" unless $tests;
+	}
+
+    done_testing;
+    exit;
+}