Calculates the highest score possible from the letters given, taking into account any bonuses on the squares to be covered.

(Rudimentary tool that does not handle combinations with the words already on the board).

My local newspaper has a Scrabble-based game that involves simply finding the highest scoring word from seven letters and bonus tile positions provided. Note: quite often the highest scoring word according to the newspaper is not found in my words list :-(

Specify double- and triple-word bonuses with -dw and -tw, and double- and triple-letter bonuses with -dl=N and -tl=N where N is the letter position.

Examples:

$ perl scrabble.pl eoaprzn 
Found 13,699 1-7 letter strings in eoaprzn.
Found 57 words in eoaprzn.
zap : 14

$ perl scrabble.pl eoaprzn -dw
Found 13,699 1-7 letter strings in eoaprzn.
Found 57 words in eoaprzn.
zap : 28

$ perl scrabble.pl eoaprzn -tl=3
Found 13,699 1-7 letter strings in eoaprzn.
Found 57 words in eoaprzn.
raze : 33
[download]

use strict; use warnings; use feature 'say';
use Path::Tiny;
use Algorithm::Permute;
use Number::Format 'format_number';
use List::Util 'uniq';
use Getopt::Long;

my @dl;
my @tl;
my $dw;
my $tw;
my $debug;

GetOptions(
    'dl=i' => \@dl,
    'tl=i' => \@tl,
    'dw'   => \$dw,
    'tw'   => \$tw,
    'v'    => \$debug,
);

my $input       = shift or die 'Died: No input!';
my $length      = length $input;
my @input_chars = split '', $input;

my $words_file  = '/usr/share/dict/words';
my %words       = map { $_ => 1 } path( $words_file )->lines({chomp =>
+ 1});

my %worth = (
    a => 1, b => 3,  c => 3, d => 2, e => 1,
    f => 4, g => 2,  h => 4, i => 1, j => 8,
    k => 5, l => 1,  m => 3, n => 1, o => 1,
    p => 3, q => 10, r => 1, s => 1, t => 1,
    u => 1, v => 2,  w => 2, x => 8, y => 4, z => 10,
);

my @partials;

for (1 .. $length) {
    my $P = Algorithm::Permute->new( \@input_chars, $_ );
    
    while (my @res = $P->next) {
        push @partials, join '', @res;
    }
}

@partials = uniq @partials;

say sprintf 'Found %s 1-%s letter strings in %s.',
            format_number(scalar @partials), $length, $input;

my %found = map { $_ => calc_score($_) } grep { $words{$_} } @partials
+ ;

say sprintf 'Found %s words in %s.', format_number(scalar keys %found)
+, $input;

for ( sort { $found{$b} <=> $found{$a} } keys %found ) {
    say "$_ : $found{$_}";
    last if not $debug;
}

###############

sub calc_score {
    my $word = shift;
    my $val;
    $val += $worth{$_} for split '', $word;

    $val += 50 if length $word == 7;

    return $val + calc_bonus($word, $val);
}

sub calc_bonus {
    my ($word, $val) = @_;
    my @chars = split '', $word;

    my $bonus = 0;

    for (@dl) {
        $bonus += $worth{ $chars[$_ - 1] } if $chars[$_ - 1];
    }

    for (@tl) {
        $bonus += 2 * $worth{ $chars[$_ - 1] } if $chars[$_ - 1];
    }

    $bonus += $val if $dw;
    $bonus += 2 * $val if $tw;

    return $bonus;
}

__END__
[download]

did you heard the big news? WebPerl by haukex is here!

I smell it as the best thing happened to Perl since years (alongside with MCE ..) and I already used to produce PM examples: very useful and shining.

But as I'm really lazy I wrote the below snippet that try to automate the process of copying perl code to the page, creating input files, etc..

Imagine that you have simple_reader.pl as follow:

use strict;
use warnings;

open my $fh,'<', 'input1.txt' or die; 
while (<$fh>) {print if /b/}
[download]

and input1.txt containing:

aaa
bbb
ccc
[download]

then you can just run:

perl webperlizator.pl  -s simple_reader.pl -i input1.txt

https://webperl.zero-g.net/democode/perleditor.html#%7B%22script_fn%22
+%3A%22simple_reader.pl%22%2C%22script
%22%3A%22use%20strict%3B%5Cnuse%20warnings%3B%5Cn%5Cnopen%20my%20%24fh
+%2C%27%3C%27%2C%20%27input1.txt%27%20or
%20die%3B%20%5Cnwhile%20%28%3C%24fh%3E%29%20%7Bprint%20if%20%2Fb%2F%7D
+%22%2C%22inputs%22%3A%5B%7B%22text%22%3
A%22aaa%5Cnbbb%5Cnccc%5Cn%22%2C%22fn%22%3A%22input1.txt%22%7D%5D%2C%22
+cmdline%22%3A%22perl%20simple_reader.pl%22%7D
[download]

or even perl webperlizator.pl  -s simple_reader.pl -i input1.txt --browse to open it directly in the browser!

have fun and thanks haukex!!

update newer version, with more features, is on my github

use strict;
use warnings;
use URI::Escape;
use Getopt::Long;
use JSON::MaybeXS qw(encode_json);

my (@infiles, @outfiles, $script, $lineofcode, $browse, $help);
unless ( GetOptions (
                        "script=s" => \$script,
                        "line|oneliner|code|c=s" => \$lineofcode,
                        "inputfiles=s"   => \@infiles,
                        "outputfiles|o=s"  => \@outfiles,
                        "browse"         => \$browse,
                        "help"        => \$help
                    )) 
                        {
                            print "GetOpt::Long returned errors (see a
+bove), available options:\n\n".help();
                            exit;
                        }
if ($help){ print help(); exit 0;}

my $json = {};
if ($lineofcode){
    $$json{cmdline} = "perl $lineofcode";
}
elsif ($script){
    open my $fh, '<', $script or die "unable to read $script!";
    while (<$fh>){
        $$json{script} .= $_ ;
    }
    $$json{script_fn} = $script;
    $$json{cmdline} = "perl $script";
}
else{
    die "Please feed at least one script using -script or a line of pe
+rl code via -code\n\n".help();
}
if ( $infiles[0] ){
    $$json{inputs}=[];
}
foreach my $in (@infiles){
    open my $fh, '<', $in or die "unable to read $in!";
    my $file = { fn => $in};
    
    while (<$fh>){
        $$file{text}.=$_;
    }
    push @{$$json{inputs}},$file;    
}
if ( $outfiles[0]){
    $$json{outputs} = \@outfiles ;
}

my $url = 'https://webperl.zero-g.net/democode/perleditor.html#'.(uri_
+escape( encode_json( $json ) ));
if ($browse){
    if ($^O =~/mswin32/i) {exec "start $url"}
    else{ exec "xdg-open $url"}
}
else{
    print $url;
}
####
sub help{
    return <<EOH;
$0 USAGE:

    --script file|--code line [--inputfile file [--inputfile file] --o
+utputfile file [--outputfile file] --browse]
    
    $0 -script script.pl 
    $0 -script script.pl [ -inputfile file1.txt  -inputfile file2.txt 
+-outputfile file3.txt -browse]
    $0 -code "-e 'print qq(Hello WebPerl!)'"
    $0 -code "-e 'print qq(Hello WebPerl!)'" [ -i infile1.txt -i infil
+e2.txt  -o outfile3.txt -browse]    

    
    --script -s accept a perl program filename as only argument. 
        Both --script and --code make no sense: just specify one.
    
        --code -c is intended to be used to pass a oneliner. The execu
+table name, aka perl, will be
    prepended automatically. Any perl switch must be explicitly passed
+ also -e
    For example: 
    
    webperlizator.pl -code "-le 'print qq(Hello WebPerl!)'"
    webperlizator.pl -code "-lne 'print \"found a b\" if /b/' file1.tx
+t" -i file1.txt -b
    
    Pay attention on quotes suitable for you OS.
    
    --inputfiles -i is for input files; more than one can be feed
    
    --outputfiles -o is for output file and more than one can be passe
+d in
    
    --browse -b open the default browser, hopefully, pointing to the W
+ebPerl right page
    
    --help -h prints this help

    
EOH
}
[download]

L*

PS updated to handle onliners in a better way

Hello, fellow monks!

This isn't really all that cool, but I'm posting it just in case someone might be interested. I'm trying to get back to my QRP transmitter/receiver project and had just wanted to convince myself that Pi attenuators properly reduced to the expected input and output impedance. Rather than do a couple by hand, I went full nerd and wrote code to do it instead.

Essentially, the code lets you create a network of resistors (via the build_impedance() function) and pi_pads (via build_pad()) and attach them together via the named ports. Once you've got the network built, remove all named nodes you don't care about and then tell it to generate the simplified network.

The code, as it is now, should give you:

$ perl attenuator_pad.pl

**********************************************************************
+**********
10dB Attenuator terminated w/ 50 ohms
**********************************************************************
+**********
10dB Pad
   N: in_neg(1) in_pos(2) out_neg(3) out_pos(4)
   (1 3 0.05), (2 1 100), (2 4 75), (4 3 100)

50 ohm terminator
   N: in_neg(5) in_pos(6)
   (6 5 50)

10dB Pad + terminator
   N: in_neg(1) in_pos(2)
   (1 3 0.05), (2 1 100), (2 4 75), (4 3 50), (4 3 100)

Simplified network
   N: in_neg(1) in_pos(2)
   (1 2 52)


**********************************************************************
+**********
Two pads cascaded and terminated
**********************************************************************
+**********
PAD 10dB
   N: in_neg(1) in_pos(2) out_neg(3) out_pos(4)
   (1 3 0.05), (2 1 100), (2 4 75), (4 3 100)

PAD 20dB
   N: in_neg(5) in_pos(6) out_neg(7) out_pos(8)
   (5 7 0.05), (6 5 68), (6 8 270), (8 7 68)

TERM 50ohm
   N: in_neg(9) in_pos(10)
   (10 9 50)

PAD 20dB + TERM 50ohm
   N: in_neg(5) in_pos(6)
   (5 7 0.05), (6 5 68), (6 8 270), (8 7 50), (8 7 68)

PAD 10dB + PAD 20dB + TERM 50ohm
   N: in_neg(1) in_pos(2)
   (1 3 0.05), (2 1 100), (2 4 75), (3 7 0.05), (4 3 68), (4 3 100), (
+4 8 270), (8 7 50), (8 7 68)

RESULT!
   N: in_neg(1) in_pos(2)
   (1 2 52.5)
[download]

I just hardcode the commands to build the networks up front, and then let it do its thing.

Comments about my coding style are always welcome, as I'm typically the only person who ever reads my code. Questions about it are just as welcome.

...roboticus

When your only tool is a hammer, all problems look like your thumb.

class Population
{ 
        has @.population;

        method BUILD() {
                .population = <>;
        }

        method add($x) {
                push(.population, $x);
        }

}
[download]

use Population;

class DistributionPopulation is Population
{
        method BUILD() {

        }

        method Expectance() {

                my $e = 0.0;

                for .population -> $p {
                        $e += $p;
                }

                return $e / .population.length;
        }

        method Variance () {
                my $e = .Expectance();
                my $var = 0.0;

                for .population -> $p {
                        $var += ($p - $e) * ($p - $e);
                }

                return $var / (.population.length - 1);
        }


}
[download]

class Covariance {
  
        method Covariance($xpop,$ypop) {
                my $ex = $xpop.Expectance();
                my $ey = $ypop.Expectance();

                my $cov = 0.0;

                for $xpop.population, $ypop.population -> $p,$q {
                        $cov += ($p - $ex)  * ($q - $ey);
                }

                return $cov / $xpop.population.length;

        }
}
[download]

use Covariance;
  
role ThisCovariance { method cov($xpop,$ypop) {
        return Covariance().Covariance($xpop,$ypop);
}
}


class Correlation does ThisCovariance {
        method BUILD() {

        }

        method correlation($xpop,$ypop) { ### These are distribution a
+rgs

                my $varx = $xpop.Variance(), $vary = $ypop.Variance();
                my $cov = .cov($xpop, $ypop);

                return $cov / (sqrt($varx) * sqrt($vary));

        }
}
[download]

I was inspired by LanX's comment here:

You know, you could use this technology to build a training site for Perl with interactive programming challenges...

And I created a set of HTML pages that can be embedded into <iframe>s and run Perl!

WebPerl Code Demo Editor

Includes documentation, I hope it's clear, let me know if you have questions!

So I've been doing quite a bit of web development recently, and several of my HTML files use resources from CDNs, like jQuery or normalize.css. While I'm developing, I refresh pages quite often, and also usually use my browser's development tools to disable caching. This means that I hit the CDNs quite often, and aside from the speed and bandwidth usage, one of the CDNs actually started rate limiting me... oops. In other projects, I'd usually just pull those resources onto my local server, keep them there, and be done with it. But the stuff I'm currently working on is for distribution, so I'd like to keep the CDN URLs in the HTML, and not have to rewrite them by hand.

Enter git filters: Documented in the Git Book Chapter 8.2 and in gitattributes, they provide a way to pipe source code files through an external program on checkout, as well as on diff, checkin, and so on. This allows you to have one version of a file checked into the repository, but to use a filter to make changes to the files that actually end up in the working copy on your machine. These changes are also reversed by the filter and not checked back into the repository on checkin, and don't show up in any commands like git diff, git status, etc.

So in this case, the files I want to have in the repository will have lines that look something like this:

<link rel="stylesheet" href="https://example.com/example.css" />
<script src="https://example.com/example.js"></script>
[download]

but when I check these files out into my local working copy, they should get rewritten into something like this:

<link rel="stylesheet" href="_cache/example.css" />
<script src="_cache/example.js"></script>
[download]

Of course, Perl to the rescue!

So, your project is going fine, your codebase is groing fast. But now your have the problem that some of your processes have to communicate with each other. Maybe, some temperature sensor needs to report its sensor value every few seconds to the central heating system. Maybe the central heating system needs to know if the windows are open and close them before heating the house. Another process wants to count how many times the door has been opened and log the sum once a minute...

Net::Clacks to the rescue!

The Net::Clacks modules implement a client/server based interprocess messaging. Without going too much into the internals of the protocol, a client can either send notifications ("event xy has just happened") or values ("the reading for sensor xy is now 42"). Other clients may (or may not) choose to listen to those broadcasts.

Net::Clacks also implements Memcached-like value storage and retrieval. So instead of broadcasting, a value can be stored, read out, incremented, decremented and deleted.

A note on security: Currently, the system only implements a shared-secret type thing (all clients in a clacks network use the same username/password). This will get changed in the future. I'm planning to make it so that you can override the authentication checks with your own function and return which permissions the client has. But that is not yet implemented.

Let's do a simple example project: Server, chatclient, chatbot and a clock process to trigger some actions at the start of every minute.

I've been working quite a lot with ZPL compatible label printers (Zebra, TSC) the last few years. When working with complex forms or large graphics, printing can be quite slow, because the printer has to - basically - calculate everything pixel-by-pixel for every single label. Not to mention the fact that the standard ZPL image format is not... well "nice" to work with with standard open source tools.

ZPL has a way to store a rendered label, which it can reuse later quite a bit faster (in most cases). Basically, you load in the saved, pre-rendered label and then add you dynamic content.

Here is the Perl script to convert a PNG file to ZPL, including the "save" command. E.g. this generates the ZPL file to pre-render the image and save it to the printers flash memory.

#!/usr/bin/env perl

use strict;
use warnings;
use GD;
use Data::Dumper;

my $xoffs = 20;
my $yoffs = 20;
my $minwhite = 200;
my $verbose = 0;

my $image = GD::Image->new('examplelogo.png');
my $w = $image->width();
my $h = $image->height();

print "Image size: $w x $h\n";
open(my $ofh, '>', 'savelogo.zpl') or die($!);

# Start of form;
print $ofh "^XA\n";


for(my $x = 0; $x < $w; $x++) {
    for(my $y = 0; $y < $h; $y++) {

        my $index = $image->getPixel($x,$y);
        my ($r,$g,$b) = $image->rgb($index);
        if($r < $minwhite) {
            print "#" if $verbose;
            print $ofh '^FO' , ($x*1) + $xoffs, ',' , ($y*1) + $yoffs,
+ '^GB1,1,1,B,0^FS', "\n";
        } else {
            print " " if $verbose;
        }
    }
    print "\n" if $verbose;
}

# Save graphic to flash mem
print $ofh "^ISR:LOGO.GRF,Y\n";

# End of form
print $ofh "^XZ\n";

close $ofh;
[download]

$xoffs and $yoffs change the upper left starting point where the image is drawn and $minwhite sets the threshold of what is considered a white vs. black pixel. This generates ZPL code like this (abbreviated), setting one pixel black per line:

^XA
^FO55,74^GB1,1,1,B,0^FS
^FO55,75^GB1,1,1,B,0^FS
^FO55,76^GB1,1,1,B,0^FS
^FO55,77^GB1,1,1,B,0^FS
^FO55,78^GB1,1,1,B,0^FS
...
^FO561,126^GB1,1,1,B,0^FS
^FO561,127^GB1,1,1,B,0^FS
^FO561,128^GB1,1,1,B,0^FS
^ISR:LOGO.GRF,Y
^XZ
[download]

To actually save the image to the printer, on Linux you would run something like this if you run CUPS:

lpr -P yourprintername -o raw savelogo.zpl
[download]

Now you can use the saved image in a normal label print by loading it at the start:

^XA
^ILR:LOGO.GRF^FS
^FO110,140^FH\^A0N,50,50^FDXXCAPTIONXX^FS
^XZ
[download]

and then printing it:

lpr -P yourprintername -o raw label.zpl
[download]

Of course, this can trivially be used for dynamic content. But i leave it to the reader to figure out how to load label.zpl, replace XXCAPTIONXX with an increasing number, saving it to tmp.zpl and calling lpr...

You also can get the whole example (including a badly made example png) with Mercurial SCM:

hg clone https://cavac.at/public/mercurial/zpl_storedlogo/
[download]

Have fun!

In addition to Perl and PDL, one of my favourite topics is cryptography, specifically cryptanalysis.

One 'common' cryptanalytical attack, for which modern ciphers are designed against is differential cryptanalysis. Some older ciphers are vulnerable to this attack and various tutorials exist to teach differential cryptanalysis. One of these is by Jon King against the FEAL cipher and is located here.

One aspect of the differential cryptanalysis attack is to enumerate all potential differentials against the non-linear round function. The below code performs this analysis against the FEAL-4 cipher's round sub-function 'G'. It successfully identifies the two fixed input differentials.

Enjoy!

#!/usr/bin/env perl
use 5.020;
use warnings;
use autodie;
use PDL;
use PDL::NiceSlice;

# This code attempts to find all differential characteristics in the
# FEAL-4 cipher round subfunction 'G'.
#
# Reference: http://theamazingking.com/crypto-feal.php
#
#
# 'G' function is addition of a, b and x, then bitwise rotate left
# by 2 bits
# a, b, x and the final value are all 8 bits.
# For our purposes, x can be ignored, as it's constant 0 or 1
#
#        a
#        |
#  x -> [+] <- b
#        |
#      [<<<]
#        |
#       OUT
#

# Perform addition
my $G = sequence( byte, 256 ) + sequence( byte, 256 )->transpose;

# Bitwise rotation
$G = ( $G << 2 ) | ( $G >> 6 );

# At this point, $G contains all possible inputs for a and b, and
# the associated output value
#
# Now we wish to find all differentials throughout this function
#
# To do this, we need to find differentials between each possible
# inputs to 'a', and 'b' and observe the differential in the result
#
# There are two known differentials for this function.  A differential
# value of 0 and 0x80 (128) for 'a' will always return a constant
# differential output (0 and 2) respectively.

# Calculate the differential table
my $diffs = $G ^ $G ( (0) );

# Find the minimum and maximum value for each differential
my ( $min, $max ) = minmaxover($diffs);

# Print index of differentials where minimum and maximum value are
# equal.  As the index is also in the input value, this returns the
# actual differential:
print "Contant differentials for input differentials of: ",
  which( $min == $max ), "\n";
[download]

package cache {
    # no particular reason to use them,
    # but the syntax sugar is *so* sweet
    use experimental 'signatures';
    use base 'Storable';

    my %paths;

    sub new($class,$path) {
        my $self = eval { return Storable::retrieve($path) }
            || bless {}, $class;
        $paths{$self} = $path;
        return $self;
    }

    sub DESTROY($self) {
        $self->store($paths{$self});
    }
}
[download]

• create the object as you usually would: my $cache = cache::->new("store.db");
• anywhere you might find it useful to cache results in a hash between runs of a function, use defined-or assignment to retrieve the value if it's already cached: my $val = $cache->{$argument} //= func($argument);
• next time you run the script again the cached values are still there, no need to recalculate
• combine with memoization for best results

Here's a bit of random nonsense. Create a random number of lines with a random number of random words from a dictionary. Repeated words are acceptable.

use strict;
use warnings;

my @words = <DATA>;
chomp @words;

my $number_of_sentences = 3 + int( 10*rand() );

for (1..$number_of_sentences) {  
    my $sentence_length = 2 + int( 9*rand() );
    my @sentence = map {$words[int(rand($#words+1))]} 1..$sentence_len
+gth;
    $sentence[0] = ucfirst $sentence[0];
    print join(" ", @sentence), ".\n\n";
}

__DATA__
abnormal
blah
crazy
dolt
dolthead
doltish
doltishly
doltishness
eccentric
fallacious
galling
hapless
illogical
jabber
kooky
lame
misguided
nuisance
officious
pretense
questionable
resentful
shaky
tenuous
untenable
vague
warp
yawn
zombie
[download]

The output from a run was:

Doltishly yawn yawn.

Shaky warp yawn tenuous misguided illogical doltish.

Warp blah officious kooky dolthead untenable eccentric untenable offic
+ious.

Galling officious.

Abnormal doltish hapless tenuous.

Galling crazy.

Abnormal galling doltish.

Kooky crazy doltishly doltishness.

Eccentric blah fallacious galling.

Pretense untenable questionable abnormal kooky zombie dolt jabber.
[download]

I recently published a beta of WebPerl, and now I've written my first full web app with it: a browser-based regex tester.

Since WebPerl is a full build of Perl, you have the full power of core Perl at your disposal, and it runs entirely in the browser - unlike some other online regex testers, which either run perl on a server, or only support PCRE (Perl Compatible Regular Expressions). It should work in modern browsers like Firefox and Chrome (not tested in IE yet, it might have issues there). Try it out, and let me know what you think, and report any issues you might find. I'd also be happy to accept issues and patches on GitHub. Please consider it a beta.

http://webperl.zero-g.net/regex.html
(It may take a few seconds to load and initialize, WebPerl is currently a ~4MB download, but once it's in your cache it should be fine.)

You can even create URLs to examples, here I'll use that to show off some features:

• A basic example, showing the match highlighting and some generated Perl code that a user can easily copy and try out. Also try clicking the use re "debug"; button for debug output.
• With "preamble code", some Perl code that gets run before the regex.
• Multi-line input strings work too
• A somewhat more complex multi-line regex with some real-life data from one of my data-processing scripts.
• And finally, some lookaround wackyness: matching characters which happen exactly once (from here, thanks LanX; see also)

Type::Tiny is probably best known as a way of having Moose-like type constraints in Moo, but it can be used for so much more. This is the fifth in a series of posts showing other things you can use Type::Tiny for. This article along with the earlier ones in the series can be found on my blog and in the Cool Uses for Perl section of PerlMonks.

It's pretty common to do things like this:

   use Types::Standard qw( is_ArrayRef is_HashRef );
   use Carp qw( croak );
   
   sub process_data {
      my ($self, $data) = @_;
      if (is_ArrayRef($data)) {
         $self->_process_value($_) for @$data;
      }
      elsif (is_HashRef($data)) {
         $self->_process_value($_) for values %$data;
      }
      else {
         croak "Could not grok data";
      }
   }
[download]

Type::Utils provides a perhaps slightly neater way to do this:

   use Types::Standard qw( ArrayRef HashRef Any );
   use Type::Utils qw( match_on_type );
   use Carp qw( croak );
   
   sub process_data {
      my ($self, $data) = @_;
      match_on_type $data,
         ArrayRef, sub { $self->_process_value($_) for @$data },
         HashRef,  sub { $self->_process_value($_) for values %$data }
+,
         Any,      sub { croak "Could not grok data" };
   }
[download]

The match_on_type function takes a value and a set of type–coderef pairs, dispatching to the first coderef where the value matches the type constraint. This function is stolen from Moose::Util::TypeConstraints.

You can get an order of magnitude faster though by doing something similar to what Type::Params does — compiling the match once, then calling it as needed.

Let's look at a naïve (and wrong) way to do this first and examine the problems:

   use Types::Standard qw( ArrayRef HashRef Any );
   use Type::Utils qw( compile_match_on_type );
   use Carp qw( croak );
   
   sub process_data {
      my ($self, $data) = @_;
      state $matcher = compile_match_on_type
         ArrayRef, sub { $self->_process_value($_) for @$data },
         HashRef,  sub { $self->_process_value($_) for values %$data }
+,
         Any,      sub { croak "Could not grok data" };
      $matcher->($data);
   }
[download]

The big problem here is that the first time process_data is called, the matcher will close over $self and $data. Subsequent calls to $matcher will reuse the same closed over variables. Oops.

The simplest way of solving this is to take advantage of the fact that a compiled matcher (unlike match_on_type) can take a list of arguments, not just one. Only the first argument is used for the type matching, but all arguments are passed to the coderefs on dispatch.

   use Types::Standard qw( ArrayRef HashRef Any );
   use Type::Utils qw( compile_match_on_type );
   use Carp qw( croak );
   
   sub process_data {
      my ($self, $data) = @_;
      state $matcher = compile_match_on_type
         ArrayRef, sub { my ($d, $s) = @_; $s->_process_value($_) for 
+@$d },
         HashRef,  sub { my ($d, $s) = @_; $s->_process_value($_) for 
+values %$d },
         Any,      sub { croak "Could not grok data" };
      $matcher->($data, $self);
   }
[download]

Like many Type::Tiny interfaces that expect coderefs, compile_match_on_type also accepts strings of Perl code as an alternative, and is able to optimize things better if those are supplied:

   use Types::Standard qw( ArrayRef HashRef Any );
   use Type::Utils qw( compile_match_on_type );
   use Carp qw();
   
   sub process_data {
      my ($self, $data) = @_;
      state $matcher = compile_match_on_type
         ArrayRef, q{ my ($d, $s) = @_; $s->_process_value($_) for @$d
+ },
         HashRef,  q{ my ($d, $s) = @_; $s->_process_value($_) for val
+ues %$d },
         Any,      q{ Carp::croak("Could not grok data") };
      $matcher->($data, $self);
   }
[download]

The coderefs compiled by compile_match_on_type should be very efficient. The technique is very similar to how Type::Coercion compiles coercions.