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]

Try it out!

Last week i released a simple graphics demo for the Linux terminal (Fun with terminal color).

The low framerate and the mostly static graphics bothered me a bit. So, i , uhm did it yet again. Another demo, this time using Inline::CPP and massaged versions of tinyraytracer and tinyraycaster to provide some actual graphical content. As a matter of fact, Inline::CPP didn't work for my borrowed(*) code, and my understanding of CPP is a 20 years out of date. So i override the Inline::CPP RecDescent module to ignore my bugs. Hey, it's not production code, just a demo...

As in the last demo, your Terminal needs to support full RGB colors and have a size of at least 270x60 in size (characters, not pixels). SDL is sort-of-optional this time; the demo will run without sound if it can't load SDL. And as said above, you'll need to install Inline::CPP as well.

Here's the mercurial repository: https://cavac.at/public/mercurial/demos/terminalvelocity/

And the YouTube video: https://www.youtube.com/watch?v=MWcuI2SXA-A. OBS and YT compression did munge the quality a bit, though. Probably my fault for not understanding the OBS settings...

(*) "but with every intention of giving it back"

use warnings::colored;
warn "warning";  # yellow
system "non-existant-command";  # red
say "test";  # none
eval { die "caught" };  # none
say $@;  # none
die "died";  # red
[download]

Yesterday i thought i might fix some bugs in my imagecat routine (printing images to the terminal). But somehow i, uhm, improved things a little too far. If you're now thinking "Oh no, he did it again!", i'm afraid, yes, i did.

This time, i made a 3 minute animated demo with sound, running at (some) FPS in a Linux terminal.

You can find a download of the current version as a tarball or you could clone my public mercurial repo if you prefer that. (Edit: Link to mercurial has changed/updated)

$subject came up at $work.

The following minimal example appears to work:

#!/usr/bin/perl

use Modern::Perl '2021';
use Net::Amazon::S3::Client;

# edit these
my $aws_access_key_id = '...';
my $aws_secret_access_key = '...';
my $host = '...';
my $bucket_name = '...';
my $secure = 1;

my $client = Net::Amazon::S3::Client->new (
    host                  => $host,
    aws_access_key_id     => $aws_access_key_id,
    aws_secret_access_key => $aws_secret_access_key,
    secure                => $secure,
    retry                 => 1,
);

my $bucket = $client->bucket( name => $bucket_name );

my $object = $bucket->object( key => $ARGV[0] );

$object->get_callback(sub {
    my $s = length($_[0]);
    print STDERR "Got chunk size $s\n";
    # do something with $_[0]
});
[download]

This is applicable if you want to serve a file from an S3 compatible storage via an async backend.

The get_callback method is not documented (it is mentioned in passing only in Net::Amazon::S3::Client::Object::Range), but in the end it works.

Shotgun.pl

Shoots Holes in Files

Have you ever had a file you just wanted to blast with a shotgun? Now you can!

Can play audio files via aplay or mpv (tested on Ubuntu). Or use -quiet to run with no sound effects.