Many years ago I took this sudoku generator and started writing a Sudoku program using Tk. Every once in a while I'd pull it out and make some changes, add some features, fix some bugs. It has recently reached a fairly feature complete state so I'm posting it here. Some of the features I've added I don't use too often so they may have some bugs yet. Enjoy!

Recently, i've been battling with a few modules made by a former co-worker that are, how should i put it politely, garbage. The modules call a third party web API that could block up to a minute in a cyclic executive that is supposed the have a cycle time of under a second. So he used fork (via the "forks" module), that messes up all kinds of other things (open handles and stuff).

All i needed was a very simple HTTP(s) client that runs a single GET or POST call, non-blocking (except the initial TCP/SSL connect), single-threaded, with just frequent cyclic calls for processing. I couldn't find something that fit my requirements, so i spent a couple of hours writing my own. It's not fully finished and tested yet (haven't tested non-encrypted connection at all), but here it is so you can play with the code:

(Edit: Put the main code in readmore tags because of the length)

It's part of my PageCamel framework. Don't worry about the $self->{reph}->debuglog() calls, that's just the (rather complex) reporting handler i use for my stuff. The relevant function "debuglog" is easy to simulate. Here's the test program:

#/usr/bin/env perl

use v5.40;
use strict;
use warnings;
our $VERSION = 4.6;

# Simulate the PageCamel reporting handler without all the PostgreSQL 
+and Net::Clacks stuff
package Reporting;
sub new($proto, %config) {
    my $class = ref($proto) || $proto;
    
    my $self = bless \%config, $class;

    return $self;
} 

sub debuglog($self, @data) {
    print join('', @data), "\n";
    return;
}

# Test program here
package main;
use Data::Dumper;
use PageCamel::Helpers::AsyncUA;
use Time::HiRes qw(sleep);
use Carp;

my $reph = Reporting->new();

my $ua = PageCamel::Helpers::AsyncUA->new(host => 'cavac.at', use_ssl 
+=> 1, ua => 'PageCamel_AsyncUA/' . $VERSION, reph => $reph);

if(1){
    # Call the sleeptest with GET, this should return a json after a f
+ew seconds artificial delay
    print "############################## GET ########################
+\n";
    if(!$ua->get('/guest/sleeptest/asdjkhfashdflkahsdflhasas7d8687asd6
+f')) {
        croak("Failed to start request");
    }

    while(!$ua->finished()) {
        print "Do something else...\n";
        sleep(0.05);
    }

    my ($status, $headers, $body) = $ua->result();
    print "Return code: $status\n";
    #print Dumper($headers);
    print Dumper($body);
}

if(1){
    # Call the sleeptest with POST, this should return a our post data
+ in reverse ('dlroW olleH') after a few seconds artificial delay
    print "############################## POST #######################
+#\n";
    if(!$ua->post('/guest/sleeptest/asdjkhfashdflkahsdflhasas7d8687asd
+6f', 'application/octed-stream', 'Hello World')) {
        croak("Failed to start request");
    }

    while(!$ua->finished()) {
        print "Do something else...\n";
        sleep(0.05);
    }

    my ($status, $headers, $body) = $ua->result();
    print "Return code: $status\n";
    #print Dumper($headers);
    print Dumper($body);
}
[download]

I'm not sure this will be of use to anyone, but if it is, you're free to "borrow" it Captain Jack Sparrow style for your own purposes.

A really nice article:

"Perl Tone The approach described here will set up a new software-defined MIDI device which will proxy events from our hardware, while applying any number of filters to events before they are forwarded. These examples will make use of Perl bindings to RtMidi."

Attacca Quartet:1,2,3,4,5,6,7,8,10,11,12,13,14,15,16,17,18,19,20,22,23
+,24,25,26,27,28
John Patitucci:1,2,3,5,8,11,12,13,14,15,16,17,19,25,26,27,28
Roomful of Teeth:1,3,5,7,9,12,14,16,19,21,24,26,28
Sō Percussion:1,3,4,5,6,7,8,11,12,13,14,15,16,18,19,21,22,23,24,2
+5,26,27,28
[download]

Attacca Quartet:1-8,10-20,22-28
John Patitucci:1-3,5,8,11-17,19,25-28
Roomful of Teeth:1,3,5,7,9,12,14,16,19,21,24,26,28
Sō Percussion:1,3-8,11-16,18-19,21-28
[download]

So I thought: Perl must have an easy way to find consecutive numbers inside a regex. And indeed it does!

Here is my script, which was originally a one-liner. It consolidates ranges in text using the (??{code}) construct in the search pattern to find consecutive numbers, and leaves everything intact that doesn't look like a number range.

It passes all the tests I threw at it, as long as the ranges are sane, non-overlapping and sorted in ascending order. I made it so that it can handle pre-existing ranges in the input, since I needed some of that code anyway and now it looks cool and has some nice internal symmetry. It does not merge duplicate ranges, nor does it try to handle whitespace. So it is basically only useful if the input data for this stage is generated by your own code (or your own data manipulations in Vim, as in my case). Definitely don't use it for processing arbitrary user input, there are good modules for that!

#!/usr/bin/perl -wp
1 while s/-(\d+),(??{1+$1})-/-/
    or s/-(\d+),((??{1+$1}))\b/-$2/
    or s/\b(\d+),(??{1+$1})-/$1-/
    or s/\b(\d+),((??{1+$1}))\b/$1-$2/;
[download]

This was an interesting learning experience to use the (??{code}) construct! Note that I put capturing parentheses around the (?{...}) items only where it was necessary.

If you want to sort your data before consolidating the ranges, you could first do something like this, but note that this does not ignore extra text:

perl -pe 'chomp; $_ = join(",", sort { $a <=> $b } split /,/) . "\n"'
[download]

static inline SV *pdl2avref(pdl *x, char flatten) {
  int stop = 0, badflag = (x->state & PDL_BADVAL) > 0;
  volatile PDL_Anyval pdl_val = { PDL_INVALID, {0} }; /* same reason a
+s below */
  volatile PDL_Anyval pdl_badval = { PDL_INVALID, {0} };
  if (badflag) {
    if (!(x->has_badvalue && x->badvalue.type != x->datatype)) {
      if (x->has_badvalue)
        pdl_badval = x->badvalue;
      else {
#define X(datatype, ctype, ppsym, ...) \
         pdl_badval.type = datatype; pdl_badval.value.ppsym = PDL.bval
+s.ppsym;
        PDL_GENERICSWITCH(PDL_TYPELIST_ALL, x->datatype, X, )
#undef X
      }
    }
    if (pdl_badval.type < 0) barf("Error getting badvalue, type=%d", p
+dl_badval.type);
  }
  pdl_barf_if_error(pdl_make_physvaffine( x ));
  if (!x->nvals) return newRV_noinc((SV *)newAV());
  void *data = PDL_REPRP(x);
  PDL_Indx ind, inds[!x->ndims ? 1 : x->ndims];
  AV *avs[(flatten || !x->ndims) ? 1 : x->ndims];
  if (flatten || !x->ndims) {
    inds[0] = 0;
    avs[0] = newAV();
    av_extend(avs[0], flatten ? x->nvals : 1);
    if (flatten) for (ind=1; ind < x->ndims; ind++) inds[ind] = 0;
  } else
    for (ind=x->ndims-1; ind >= 0; ind--) {
      inds[ind] = 0;
      avs[ind] = newAV();
      av_extend(avs[ind], x->dims[ind]);
      if (ind < x->ndims-1) av_store(avs[ind+1], 0, newRV_noinc((SV *)
+avs[ind]));
    }
  PDL_Indx *incs = PDL_REPRINCS(x), offs = PDL_REPROFFS(x), lind = 0;
  while (!stop) {
    pdl_val.type = PDL_INVALID;
    PDL_Indx ioff = pdl_get_offset(inds, x->dims, incs, offs, x->ndims
+);
    if (ioff >= 0)
      ANYVAL_FROM_CTYPE_OFFSET(pdl_val, x->datatype, data, ioff);
    if (pdl_val.type < 0) croak("Position out of range");
    SV *sv;
    if (badflag) {
      /* volatile because gcc optimiser otherwise won't recalc for com
+plex double when long-double code added */
      volatile int isbad = ANYVAL_ISBAD(pdl_val, pdl_badval);
      if (isbad == -1) croak("ANYVAL_ISBAD error on types %d, %d", pdl
+_val.type, pdl_badval.type);
      if (isbad)
        sv = newSVpvn( "BAD", 3 );
      else {
        sv = newSV(0);
        ANYVAL_TO_SV(sv, pdl_val);
      }
    } else {
      sv = newSV(0);
      ANYVAL_TO_SV(sv, pdl_val);
    }
    av_store( avs[0], flatten ? lind++ : inds[0], sv );
    stop = 1;
    char didwrap[x->ndims];
    for (ind = 0; ind < x->ndims; ind++) didwrap[ind] = 0;
    for (ind = 0; ind < x->ndims; ind++) {
      if (++(inds[ind]) < x->dims[ind]) {
        stop = 0; break;
      }
      inds[ind] = 0;
      didwrap[ind] = 1;
    }
    if (stop) break;
    if (flatten) continue;
    for (ind=x->ndims-2; ind >= 0; ind--) { /* never redo outer so -2 
+*/
      if (!didwrap[ind]) continue;
      avs[ind] = newAV();
      av_extend(avs[ind], x->dims[ind]);
      av_store(avs[ind+1], inds[ind+1], newRV_noinc((SV *)avs[ind]));
    }
  }
  return newRV_noinc((SV *)avs[(flatten || !x->ndims) ? 0 : x->ndims-1
+]);
}

# ...
MODULE = PDL::Core     PACKAGE = PDL

SV *
unpdl(x)
  pdl *x
CODE:
  RETVAL = pdl2avref(x, 0);
OUTPUT:
  RETVAL
[download]

use strict;
use warnings;
use PDL;

# user params
my $floor = 100;
my $component = 0;
my $delta = 6;
my $elevation = 2;
my $camerapos = -1;
$| = 1;

my $alpha = 0;
my $srcdata = rpic($ARGV[0]);
my $destdata = $srcdata->zeroes; # "filled" with black
my (undef, $width, $height) = $srcdata->dims;
my $relord = $width / 255;
$delta = 1 if $delta < 1;

for (my $y = 0; $y < $height; $y++) {
  my $row = $srcdata->slice('', '', "($y)");
  my $drow = $destdata->slice('', '', "($y)");
  my $red = $row->slice("($component)");
  my $dred = $drow->slice("(0)");
  my $dgreen = $drow->slice("(1)");
  my $dblue = $drow->slice("(2)");
  $drow->slice(3) .= 255 if $alpha;
  for (my $x = 0; $x < $width; $x++) {
print "." unless $x%10;
    my $r = at($red, $x);
    next if $r <= $floor;
    my $remain = $r;
    my $currentx = $width - $r * $relord + ($x / $elevation);
    #Apply elevation following the x offset in original picture
    while ($remain > 0 && $currentx < $width) {
      if ($remain > 150) {
        set ($dred, $currentx, 0);
        set ($dgreen, $currentx, $remain);
        set ($dblue, $currentx, $remain);
      }
      if ($remain < 150 && $remain > 50) {
        set ($dred, $currentx, 0);
        set ($dgreen, $currentx, $remain + 55);
        set ($dblue, $currentx, 0);
      }
      if ($remain < 50) {
        set ($dred, $currentx, 0);
        set ($dgreen, $currentx, 0);
        set ($dblue, $currentx, $remain + 200);
      }
      $remain -= $delta;
      $currentx++;
    }
  }
print "\n";#  Gimp::Progress->update($y / $height);
}

$destdata->wpic("OUT$ARGV[0]");
[download]

The script worked and made interesting pictures, but it was terribly slow (15 secs+ for a 300x300 image). This is largely because it's written like C, and Perl-loops over all X and Y coordinates, reading each pixel value, etc. I knew (sort of) that PDL could be used to do better, but for a long time I didn't really have any clue how.

Encouraged by the screw thingy, and realising the similarity of problem might mean the approach for one could be applied to the other, I dug back into it. This is the more PDL-idiomatic version, which now runs in <4sec, and is actually shorter:

use strict;
use warnings;
use PDL;

# user params
my $floor = 100;
my $component = 0;
my $delta = 6;
my $elevation = 2;
my $camerapos = -1;
$| = 1;

my $alpha = 0;
my $srcdata = rpic($ARGV[0]);
my $destdata = $srcdata->zeroes; # "filled" with black
$destdata->slice(3) .= 255 if $alpha;
my $destmv = $destdata->mv(0,-1); # x y rgb
my (undef, $width, $height) = $srcdata->dims;
my $relord = $width / 255;
$delta = 1 if $delta < 1;

my $quant = ($srcdata->slice("($component)")->max / $delta)->floor->sc
+lr;
return if $quant <= 0;
for my $x (0..$width-1) {
  my $col = $srcdata->slice("($component),($x)");
  my $exceed_floor = ($col > $floor);
  my $r = $col->where($exceed_floor); # nvals
  my $destx = ($width - $r * $relord + ($x / $elevation))->long; # nva
+ls
  #Apply elevation following the x offset in original picture
  my $remain_s = zeroes(long, 3, $quant, $r->dim(0)); # xyr quant nval
+s
  my $yslice = $remain_s->slice("(1)") .= $exceed_floor->which->dummy(
+0); # quant nvals
  my $xslice = $remain_s->slice("(0)") .= $yslice->xvals + $destx->dum
+my(0); # quant nvals
  my $rslice = $remain_s->slice("(2)") .= $yslice->xlinvals(0,-1) * $q
+uant*$delta + $r->dummy(0); # quant nvals
  $rslice->whereND($xslice >= $width) .= -1;
  my $gt150_ind = whichND($rslice > 150);
  my $btwn_ind = whichND(($rslice <= 150) & ($rslice >= 50));
  my $lt50_ind = whichND(($rslice < 50) & ($rslice > 0));
  $destmv->slice(',,1:2')->indexND(cat(map $_->indexND($gt150_ind), $x
+slice, $yslice)->mv(-1,0)) .= $rslice->indexND($gt150_ind) if $gt150_
+ind->nelem;
  $destmv->slice(',,1')->indexND(cat(map $_->indexND($btwn_ind), $xsli
+ce, $yslice)->mv(-1,0)) .= $rslice->indexND($btwn_ind) + 55 if $btwn_
+ind->nelem;
  $destmv->slice(',,2')->indexND(cat(map $_->indexND($lt50_ind), $xsli
+ce, $yslice)->mv(-1,0)) .= $rslice->indexND($lt50_ind) + 200 if $lt50
+_ind->nelem;
#  Gimp::Progress->update($x / $height);
}

$destdata->wpic("OUT$ARGV[0]");
[download]

use PDL;
use PDL::Graphics::Simple;
use PDL::Graphics::ColorSpace;
sub as_heatmap {
  my ($d) = @_;
  my $max = $d->max;
  die "as_heatmap: can't work if max == 0" if $max == 0;
  $d /= $max; # negative OK
  my $hue   = (1 - $d)*240;
  $d = cat($hue, pdl(1), pdl(1));
  (hsv_to_rgb($d->mv(-1,0)) * 255)->byte->mv(0,-1);
}
imag as_heatmap(rvals 300,300);
[download]

A sequencer and a synthesizer in Perl? Why not?

This is a side project from a side project, but it turned out to be a lot of fun so that I'll probably continue to spend some of my spare time on it.

It started with my interest for the Corinna project to bring "modern" object orientation into the core of the Perl programming language.

Then I noticed (a few years ago) that my favourite editor Emacs does not understand newer Perl syntax, and as a side project I added missing stuff to CPerl mode. So, upcoming Emacs 30 will understand Perl syntax including Perl 5.40.

While working on this I noticed that - as could be expected - there is not much code out there in the wild which already uses the new Perl syntax. So, to get some test and practice, I had to write my own. The stuff I wrote would not need to serve any practical purpose, but exercise lots of syntactical variations.

So this project was started to test CPerl mode and at the same time have fun. For the Perl code this means that it isn't very consistent in its style intentionally because I needed CPerl mode to cover different coding styles. The repository also contains some dead code and many undocumented features. Sorry for that. I also use Feature::Compat::Class instead of use feature 'class' because that way I can debug the objects by using "older" Perl versions which fall back to Object::Pad.

Part of this work was the specification of a file format which I could use to test the audio software: It should be easy to write for humans (unlike MIDI). This spec is now here, but unfortunately GitHub's POD rendering clobbers Unicode characters in Code sections. Also, HTML rendering of musical note symbols looks worse than I expected even when correctly decoded, so perhaps I'll drop that.

The `eg` directory has a few examples of music roll files which can be played with the program `bin/mrt_play`. This needs the `sox` program to be on your path.

Two of the samples created by mrt_play (~300kB, ~30 seconds each) are at https://haraldjoerg.github.io/i/entertainer.ogg and https://haraldjoerg.github.io/i/lvb_27_2.ogg.

The code is on GitHub.

use strict; use warnings;
use PDL;
use PDL::IO::Pic;
my ($width, $height, $framecount, $xvel, $maxheight, $ballsize) = (320
+, 80, 100, 15, 60, 8);
my $frames = zeros byte, $width, $height, $framecount;
my $coords = yvals(3, $framecount); # coords for drawing ball, all val
+=frameno
my ($xcoords, $ycoords) = map $coords->slice($_), 0, 1;
$xcoords *= $xvel; # moves $xvel pixels/frame
$xcoords .= $width - abs(($xcoords % (2*$width)) - $width); # back and
+ forth
my $sqrtmaxht = sqrt $maxheight;
$ycoords .= indx($maxheight - ((($ycoords % (2*$sqrtmaxht)) - $sqrtmax
+ht)**2));
my $val = pdl(byte,250);  # start with white
$frames->range($coords, [$ballsize,$ballsize,1], 't') .= $val;
$frames = $frames->dummy(0, 3)->copy; # now make the movie
$frames->wmpeg('bounce.gif');  # or bounce.mp4, ffmpeg deals OK
[download]

perl scriptname.pl && animate bounce.gif
[download]

So, I was experimenting with LRU caches (where the least-recently-used elements get discarded if the cache is full) and realized I could implement it much more efficiently inside of my Red/Black Tree module, and at almost no extra cost. (well, 16 bytes per tree node, but they were already big)

The short version is that there is now an optional linked list running through the tree nodes in the order of insertion, and you may also omit nodes from that list (if you want them to persist in the cache) and you may re-order the list however you like.

I'm currently using it for marking positions within a log file, where I parse the timestamp at a given address while performing a binary search of the log, and write down the timestamps and addresses in the cache to speed up later seeks. This problem requires a tree so that I can say "what is the timestamp address before and after my desired timestamp", followed by a binary search of the records in that range.

Meanwhile, you can also insert duplicates for things like statistical tracking over time, such as inserting IP addresses who are abusing your system, and then answer queries about how many violations they've had in the cache's time window (maybe causing you to add them to a firewall blacklist), then expire the events individually. Being a tree, you can also sum up the violations for arbitrary subnets in Log(N) time.

My implementation fares rather excellently vs. the other LRU cache implementations benchmarked by the script in Hash::Ordered.
Benchmark code:

Intro

IPC (inter-process communication) is a large part of most application i maintain, and so is in-memory caching (key/value store). To do this in a way i like, i created Net::Clacks. In fact, in 2018 i wrote a simple tutorial on PerlMonks: Interprocess messaging with Net::Clacks, but i guess a more up-to-date version could be useful for someone out there.

Before we start with the code, i'll have to explain a few concepts. The protocol has two different way to handle data. The first thing is "somewhat real time" messaging, the other is to provide an in-memory key/value store. Everything is based on, what boils to, named variables. You can name the variables pretty much anything, as long as they don't contain spaces and equal signs. Altough i highly suggest you avoid Unicode, as this not not well tested. In my programs, i usually use "fake perl classnames" ("PerlMonks::Chatterbot::messagecount"), but that's just a convention for my own stuff. You can be as boring or creative as you like with this stuff.

Real-time messages come in two different flavours: NOTIFY ("some event has happened") and SET ("this is the new value for a thing"). To receive those messages from the server, you have to LISTEN to them.

The key/value part of this is just like what it says on the label. You can STORE, RETRIEVE, REMOVE, INCREMENT and DECREMENT them. Other clients will not get automatically notified, you will have to do that yourself. One exception (for the case i use most) is the SETANDSTORE command, which stores a variable and broadcasts it to other clients, all in one go.

Most commands are fire-and-forget commands (the client doesn't have to wait for the server to process them). The exception is where the clients actively retrieves data from the server.

To optimize network efficiency, commands are buffered in memory. You have to call doNetwork() on the client side to trigger a send/receive cycle.

To better check for timeouts (including clients that don't disconnect but hang in some other way), the client has to regularly send PING commands, but it can temporarily disable this requirement by sending a NOPING command.

If you have to handle a lot of clients, or clients on multiple servers, you can run clacks servers in master/slave mode. This uses an expanded set of commands to implement what i call "interclacks mode", which includes cache sync and simple time offset calculations. But this is a bit outside this tutorial...

The last thing to note is that the clacks server can use a persistance file for the in-memory key/value store. So it can (mostly) restart-protect the data. This isn't perfectly real-time, so if you store a value and then immediately kill the server, those changes may or may not be available when the server is started again.

It's also possible to configure a few caching timeframes, that say how often stale entries are purged from the key/value store, how long entries are kept if they are not accessed in any way (default=1 day) and how long the server(s) remember that a key was deleted (for the purpose of interclacks resync). But again, advanced topic. I recommend leaving the defaults unless you run into problems.

Net::Clacks requires at least Perl 5.36 at the time of writing, because a) i switched to sub-signatures and b) i generally don't support completely outdated Perl versions. (If you want to run Net::Clacks on a completely outdated RedHat box, you might have to add some money to RedHats pay-to-win "Enterprise" racket so they can make you a broken, backported version.)

(Info for newbies to PerlMonks: Click on the "Read more" link below to see the rest of the article)

{package PDL::3Space;
use PDL;
sub new { my ($class, $parent) = @_;
  my $self = bless {basis_local=>identity(3), origin_local=>zeroes(3)}
+, $class;
  if (defined $parent) {
    $self->{parent} = $parent;
    $self->{basis} = $self->{basis_local}->flowing x $parent->{basis}-
+>flowing;
    $self->{origin} = ($self->{origin_local}->flowing x $self->{basis}
+->flowing)->flowing + $parent->{origin}->flowing;
  } else {
    $self->{basis} = $self->{basis_local};
    $self->{origin} = $self->{origin_local}->flowing x $self->{basis}-
+>flowing;
  }
  $self;
}
use overload '""' => sub {$_[0]{basis}->glue(1,$_[0]{origin}).''};
sub basis_update { $_[0]{basis_local} .= $_[1] x $_[0]{basis_local} }
sub origin_move { $_[0]{origin_local} += $_[1] }
sub local { my $local = PDL::3Space->new; $local->{$_} .= $_[0]{$_} fo
+r qw(basis_local origin_local); $local}
}
[download]

The demonstrating code has a boat, and a bird within its frame of reference. Note that the "local" origin still gets affected by its local basis.

The basis and origin are always in global coordinates, and thanks to dataflow, are only recalculated on demand.

$rot_90_about_z = PDL->pdl([0,1,0], [-1,0,0], [0,0,1]);

$boat = PDL::3Space->new;
print "boat=$boat";
$bird = PDL::3Space->new($boat);
print "bird=$bird";
# boat=
# [
#  [1 0 0]
#  [0 1 0]
#  [0 0 1]
#  [0 0 0]
# ]
# bird=
# [
#  [1 0 0]
#  [0 1 0]
#  [0 0 1]
#  [0 0 0]
# ]

$boat->basis_update($rot_90_about_z);
print "after boat rot:\nboat=$boat";
print "bird=$bird";
# after boat rot:
# boat=
# [
#  [ 0  1  0]
#  [-1  0  0]
#  [ 0  0  1]
#  [ 0  0  0]
# ]
# bird=
# [
#  [ 0  1  0]
#  [-1  0  0]
#  [ 0  0  1]
#  [ 0  0  0]
# ]

$boat->origin_move(PDL->pdl(1,0,0));
print "after boat move:\nboat=$boat";
print "bird=$bird";
print "bird local=".$bird->local;
# after boat move:
# boat=
# [
#  [ 0  1  0]
#  [-1  0  0]
#  [ 0  0  1]
#  [ 0  1  0]
# ]
# bird=
# [
#  [ 0  1  0]
#  [-1  0  0]
#  [ 0  0  1]
#  [ 0  1  0]
# ]
# bird local=
# [
#  [1 0 0]
#  [0 1 0]
#  [0 0 1]
#  [0 0 0]
# ]

$bird->basis_update($rot_90_about_z);
$bird->origin_move(PDL->pdl(1,0,1));
print "after bird rot and move:\nbird=$bird";
print "bird local=".$bird->local;
# after bird rot and move:
# bird=
# [
#  [-1  0  0]
#  [ 0 -1  0]
#  [ 0  0  1]
#  [-1  1  1]
# ]
# bird local=
# [
#  [ 0  1  0]
#  [-1  0  0]
#  [ 0  0  1]
#  [ 0  1  1]
# ]

$boat->basis_update(PDL::MatrixOps::identity(3) * 2);
print "after boat expand:\nboat=$boat";
print "bird=$bird";
# after boat expand:
# boat=
# [
#  [ 0  2  0]
#  [-2  0  0]
#  [ 0  0  2]
#  [ 0  2  0]
# ]
# bird=
# [
#  [-2  0  0]
#  [ 0 -2  0]
#  [ 0  0  2]
#  [-2  2  2]
# ]
[download]

perl -MHTTP::Tiny -e 'eval HTTP::Tiny->new->get(shift)->{content}' htt
+ps://www.perlmonks.org/?node_id=176043;displaytype=displaycode
[download]

(tinyurl.com/spiraling-quine links the source of the amazing spiraling quine)

10#86# 16#FA61# 2#10010110#

After they tried using LabView and Excel to covert the numbers, they came to us software engineers.

My (3/32 baked) solution was using a regular expression to parse out the base and number, then convert using hex and oct as appropriate.

While this worked fine for what was needed, some one asked "Why didn't you make a proper implementation?" My reply, of course, was "This serves our needs" and left it as is. For about a week. My thoughts kept drifting back to it, so I gave in and said "Challenge accepted."

So, I made the "proper implementation" per the Ada standard, including floating point conversion. There is a base converter in CPAN I might have used, but Horner's Method is simple and efficient - and almost habitual to use. I haven't tested whether using a hash or using index (with lc or uc) would be more efficient. I used a hash.

Looking at the CPAN listings, I think Language::Ada is the right namespace. (Though I noticed that C, for example, is top level, rather than Language::C)

• It doesn't do the linear interpolation bit, because I couldn't figure a lazy way of getting it to do that. Probably doubling the coordinate offsets and using those as index offsets would work.
• Making a bunch of individual line-segments and drawing each one is very slow in PGS. Joining them into polylines is possible with the not-yet-released next version of PDL (there's a path_join which allows this), which goes much quicker.

use strict; use warnings;
use PDL;
use PDL::Image2D;
use PDL::Graphics::Simple;

my $LOOKUP = pdl(
  # relative to cell, x1,y1,x2,y2 for each line; 0 is invalid: lines s
+tart edge
  [[   0,   0,   0,   0],[   0, 0,   0,   0]], # 0
  [[-0.5,   0,   0,-0.5],[   0, 0,   0,   0]],
  [[   0,-0.5, 0.5,   0],[   0, 0,   0,   0]], # 2
  [[-0.5,   0, 0.5,   0],[   0, 0,   0,   0]],
  [[   0, 0.5, 0.5,   0],[   0, 0,   0,   0]], # 4
  [[   0,-0.5, 0.5,   0],[-0.5, 0,   0, 0.5]],
  [[   0,-0.5,   0, 0.5],[   0, 0,   0,   0]], # 6
  [[-0.5,   0,   0, 0.5],[   0, 0,   0,   0]],
  [[-0.5,   0,   0, 0.5],[   0, 0,   0,   0]], # 8
  [[   0,-0.5,   0, 0.5],[   0, 0,   0,   0]],
  [[-0.5,   0,   0,-0.5],[   0, 0.5, 0.5, 0]], # 10
  [[   0, 0.5, 0.5,   0],[   0, 0,   0,   0]],
  [[-0.5,   0, 0.5,   0],[   0, 0,   0,   0]], # 12
  [[   0,-0.5, 0.5,   0],[   0, 0,   0,   0]],
  [[-0.5,   0,   0,-0.5],[   0, 0,   0,   0]], # 14
  [[   0,   0,   0,   0],[   0, 0,   0,   0]],
);

sub marching_squares {
  my ($c, $data, $points) = @_;
  my $kernel = pdl q[4 8; 2 1];
  my $contcells = conv2d($data < $c, $kernel)->slice(':-2,:-2');
  my $segs = $LOOKUP->slice([],[],$contcells->flat)->clump(1..2);
  my $segsinds = $segs->orover;
  my $segsmask = $segsinds->dummy(0,4);
  my $contcoords = +($contcells->ndcoords->inflateN(1,2)->dupN(2) + 0.
+5)->clump(1,2);
  my $segscoords = ($segs + $contcoords)->whereND($segsmask);
  $segscoords->splitdim(0,4)->clump(1,2);
}

if (0) {
my $win = pgswin(multi=>[4,4]);
my $xrange = [-0.5,0.5]; my $yrange = [-0.5,0.5];
my $i = 0;
for my $lines ($LOOKUP->dog) {
  $win->plot(
    (map +(with=>'lines', $_->splitdim(0,2)->mv(0,-1)->dog), $lines->d
+og),
    {xrange=>$xrange,yrange=>$yrange,j=>1,title=>$i++},
  );
}
print "ret> "; <>;
exit;
}

my $SIZE = 50;
my $vals = rvals($SIZE,$SIZE)->divide($SIZE/12.5)->sin;
my $cntr_cnt = 9;
my @cntr_threshes = zeroes($cntr_cnt+2)->xlinvals($vals->minmax)->list
+;
@cntr_threshes = @cntr_threshes[1..$#cntr_threshes-1];
my $win = pgswin();
my $xrange = [0,$vals->dim(0)-1]; my $yrange = [0,$vals->dim(1)-1];
$win->plot(with=>'image', $vals, {xrange=>$xrange,yrange=>$yrange,j=>1
+},);
for my $thresh (@cntr_threshes) {
  my $segscoords = marching_squares($thresh, $vals);
  $win->oplot(
    (map +(with=>'lines', $_->splitdim(0,2)->mv(0,-1)->dog), $segscoor
+ds->splitdim(0,4)->clump(1,2)->dog),
    {xrange=>$xrange,yrange=>$yrange,j=>1},
  );
}
print "ret> "; <>;
[download]