Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

Cool Uses for Perl

( [id://1044]=superdoc: print w/replies, xml ) Need Help??

This section is the place to post useful code ‐ anything from one-liners to full-blown frameworks and apps. (Perl poetry and obfuscated code should be posted in those respective sections.)

CUFP's
Consolidate ranges (quick and dirty with a cool regexp)
2 direct replies — Read more / Contribute
by gpvos
on Oct 29, 2024 at 17:46
    While editing Musicbrainz, I wanted to check something and at one point needed a quick script to munge data like this:
    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
    into this:
    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

    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/;

    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"'
XS to make n-dimensional data into Perl array-refs etc
No replies — Read more | Post response
by etj
on Sep 11, 2024 at 01:17
    While working on the "Intensity Landscape" code, I happened to use unpdl on a (3,72000) ndarray. It took about 45 seconds to run. That's because it uses the dog method, which is fabulously slow for ndarrays with a large top dimension (a known problem: see https://github.com/PDLPorters/pdl/issues/421). I decided I would write an XS version, based on the already-existing listref_c code:
    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
    The bit I thought was quite neat is the logic to keep making new AVs when it wraps dimensions (the n-dimension walking code was already there, but this was new). While this is quite PDL-specific, the concepts should be applicable for any n-dimensional mapping.
"Intensity Landscape" with PDL
No replies — Read more | Post response
by etj
on Sep 11, 2024 at 01:05
    Looking at the screw-generating code reminded me of a coding challenge that defeated me 10 years ago, when I was first using PDL. In gimp-perl (the plugin for GIMP allowing Perl scripts as filters etc) there are various scripts contributed by people, nearly all before I ever came along. One of them is a fun one called "Intensity Landscape", which treats the (e.g.) red values of an image as intensity (i.e. height), then "looks at it from the side and above", and makes an image of what it sees (extracted and cut down from https://gitlab.gnome.org/GNOME/gimp-perl/-/blob/master/examples/iland):
    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]");

    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]");
Heatmap in PDL
No replies — Read more | Post response
by etj
on Aug 14, 2024 at 20:24
    As part of working on a PDL version of Animated Heatmap, it was necessary to make PDL able to turn a field of floating-point numbers into a heatmap, like Imager::Heatmap's draw method does. Cue PDL::Graphics::ColorSpace!
    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);
Sound from Scratch
2 direct replies — Read more / Contribute
by haj
on Aug 14, 2024 at 05:23

    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.

PDL animation of bouncing ball
No replies — Read more | Post response
by etj
on Aug 13, 2024 at 20:05
    I was looking at Animated Heatmap, with a view to making a PDL version. It has animation, which I remembered adding to PDL::IO::Pic, with a fun demo script making a bouncing ball, visible at https://metacpan.org/pod/PDL::IO::Pic#wmpeg:
    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
    Running this with:
    perl scriptname.pl && animate bounce.gif
Tree::RB::XS now doubles as a LRU cache
No replies — Read more | Post response
by NERDVANA
on Jul 08, 2024 at 04:59

    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:

    Results:
Net::Clacks for IPC (2024 tutorial)
No replies — Read more | Post response
by cavac
on Jul 05, 2024 at 07:15

    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)

Example of PDL dataflow to implement 3D space calculations
1 direct reply — Read more / Contribute
by etj
on Jun 30, 2024 at 10:20
    This (from the PDL::Dataflow doc, not yet updated to CPAN) is a complete, working example that demonstrates the use of enduring flowing relationships to model 3D entities, through a few transformations:
    {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} }
    This is the class, heavily inspired by Math::3Space, and following discussions on interoperation between that and PDL (see https://github.com/nrdvana/perl-Math-3Space/pull/8). The basis and origin members are "subscribed" to both their own local basis and origin, and their parent's if any. The basis_update and origin_move methods only update the local members, both in terms of previous values.

    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] # ]
Impress your children with Perl
4 direct replies — Read more / Contribute
by Anonymous Monk
on May 21, 2024 at 04:46
    Every child in America, and several other countries, have access to an Apple Mac. Tell them to open Finder, then open Applications, then open Utilites, then open Terminal and type this:
    perl -MHTTP::Tiny -e 'eval HTTP::Tiny->new->get(shift)->{content}' htt +ps://www.perlmonks.org/?node_id=176043;displaytype=displaycode
    Hit return and wow kid genius you just wrote a computer program that downloads another program that runs and looks super cool! What else can this thing do? Type: perldoc perlintro

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

Parsing Ada Based Constants
No replies — Read more | Post response
by RonW
on May 06, 2024 at 07:27
    A while back, the materials lab got some surplus instruments for materials testing. Interestingly, the data files produced have a mix of base 10, base 16 and base 2 numbers in Ada based numeric constant format:

    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)

Marching Squares (for contouring) with a PDL convolution
No replies — Read more | Post response
by etj
on May 05, 2024 at 12:12
    This implements a partial Marching Squares algorithm (see https://en.wikipedia.org/wiki/Marching_squares). Limitations:
    • 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.
    If you change the if (0) to 1, it shows you its lookup table instead of drawing contours.
    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> "; <>;
AI in Perl...
No replies — Read more | Post response
by The_Dj
on Apr 18, 2024 at 10:59
    Nowadays AIs tend to use TensorFlow.
    Sadly Perl's AI::TensorFlow module can't create new models. It can only load pre-trained models. (Well, it probably can if you know all the deepest magic of Tensorflow, C, MX and Libtensorflow.pm. I don't)

    AI::MXNet was a perfectly good solution until cuda 12 broke the entire build- and tool chains and Apache retired the MXNet project.

    So visit this node for a Dockerfile that builds and runs AI::MXNet and get Perl to create your next AI!

    best of luck!
Runtime::Debugger New Release
No replies — Read more | Post response
by Timka
on Mar 30, 2024 at 15:44
"Terminal Velocity", a better Linux terminal graphics demo
4 direct replies — Read more / Contribute
by cavac
on Feb 18, 2024 at 07:36

    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"

    PerlMonks XP is useless? Not anymore: XPD - Do more with your PerlMonks XP

Add your CUFP
Title:
CUFP:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Domain Nodelet?
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this?Last hourOther CB clients
    Other Users?
    Others browsing the Monastery: (4)
    As of 2024-11-12 16:01 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      chatterbot is...






      Results (39 votes). Check out past polls.