perl - ~matubara/ChangeLog →移動しました

■ use utf8 より $KCODE='UTF8' のほうが速い [ruby][perl]

#! /usr/bin/env ruby
$KCODE='UTF8'
require 'moji'

DAKUON = Hash[*('ウヴカガキギクグケゲコゴサザシジスズセゼソゾタダチヂツヅテデトドハバヒビフブヘベホボ'.split //)]
HANDAK = Hash[*('ハパヒピフプヘペホポ'.split //)]
DAKUON_ORIGIN = DAKUON.keys.join
HANDAK_ORIGIN = HANDAK.keys.join
LATIN_ORIGIN0 = (0x01..0xFF).map{|x| x.chr}.join
LATIN_ORIGIN  = LATIN_ORIGIN0.sub(/\\/, '\\\\\\\\').sub(/-/, '\\-')
LATIN_ZENKAKU = Moji.han_to_zen(LATIN_ORIGIN0)
KATAKANA_ZENKAKU = 'ァィゥェォャュョッアイウエオカキクケコサシスセソタチツテトナニヌネノハヒフヘホマミムメモヤユヨラリルレロワヲン゛゜'
KATAKANA_HANKAKU = Moji.zen_to_han(KATAKANA_HANKAKU)

while gets
  $_.tr!(KATAKANA_HANKAKU, KATAKANA_ZENKAKU)
  $_.gsub! /[(#{DAKUON_ORIGIN})]゛/, "#{DAKUON[$1]}"
  $_.gsub! /[(#{HANDAK_ORIGIN})]゜/, "#{HANDAK[$1]}"
  $_.tr! ' ', '　'
  $_.tr!(LATIN_ORIGIN, LATIN_ZENKAKU)
  print $_
end

#! /usr/bin/env perl
use utf8;
use Readonly;
use Encode;
use Unicode::Japanese qw[unijp];
Readonly my %dakuon => map {$_} split //, 'ウヴカガキギクグケゲコゴサザシジスズセゼソゾタダチヂツヅテデトドハバヒビフブヘベホボ';
Readonly my %handakuon => map {$_} split //, 'ハパヒピフプヘペホポ';
Readonly my $dakuon_origin => join q{}, keys %dakuon;
Readonly my $handakuon_origin => join q{}, keys %handakuon;
Readonly my $keywordlist_encoding => q{utf-8};

while(<>){
  $_ = decode_utf8 $_;
  chomp;
  trr/ｧｨｩｪｫｬｭｮｯｱｲｳｴｵｶｷｸｹｺｻｼｽｾｿﾀﾁﾂﾃﾄﾅﾆﾇﾈﾉﾊﾋﾌﾍﾎﾏﾐﾑﾒﾓﾔﾕﾖﾗﾘﾙﾚﾛﾜｦﾝﾞﾟ/ァィゥェォャュョッアイウエオカキクケコサシスセソタチツテトナニヌネノハヒフヘホマミムメモヤユヨラリルレロワヲン゛゜/;
  s/([$dakuon_origin])゛/$dakuon{$1}/g;
  s/([$handakuon_origin])゜/$handakuon{$1}/g;
  tr/ \-~/　−〜/;
  tr[\x{01}-\x{FF}][\x{FEE1}-\x{FFDF}];
  print encode_utf8 $_;
  print "\n";
}

ruby 1.8.5 (2006-08-25)
perl, v5.8.8

ruby t.rb < <(head -n1000 x.txt) > /dev/null 0.20s user 0.00s system 82% cpu 0.251 total
perl t.pl < <(head -n1000 x.txt) > /dev/null 0.88s user 0.02s system 95% cpu 0.947 total

まとめ
- utf8フラグを立てたら負け
- オブジェクトを作ったら負け

■ tr, s のほうが Unicode Japanese より速い [perl]

#! /usr/bin/env perl

use utf8;
use Benchmark;
use Unicode::Japanese qw[unijp];
use Readonly;
use Encode;

Readonly my %dakuon => map {$_} split //, 'ウヴカガキギクグケゲコゴサザシジスズセゼソゾタダチヂツヅテデトドハバヒビフブヘベホボ';
Readonly my %handakuon => map {$_} split //, 'ハパヒピフプヘペホポ';
Readonly my $dakuon_origin => join q{}, keys %dakuon;
Readonly my $handakuon_origin => join q{}, keys %handakuon;
Readonly my $keywordlist_encoding => q{utf-8};

my $str = '今日はxxx@gmail.comにﾎﾟｽﾄしておいて！!!';
my %h = (
         'tr' => sub{
           my $x = shift || $_;
           $x =~ tr/ｧｨｩｪｫｬｭｮｯｱｲｳｴｵｶｷｸｹｺｻｼｽｾｿﾀﾁﾂﾃﾄﾅﾆﾇﾈﾉﾊﾋﾌﾍﾎﾏﾐﾑﾒﾓﾔﾕﾖﾗﾘﾙﾚﾛﾜｦﾝﾞﾟ/ァィゥェォャュョッアイウエオカキクケコサシスセソタチツテトナニヌネノハヒフヘホマミムメモヤユヨラリルレロワヲン゛゜/;
           $x =~ s/([$dakuon_origin])゛/$dakuon{$1}/g;
           $x =~ s/([$handakuon_origin])゜/$handakuon{$1}/g;

           $x =~ tr/ /　/;
           $x =~ tr[\x{01}-\x{FF}][\x{FEE1}-\x{FFDF}];
           return $x;
         },
         'uj' => sub{
           return unijp(shift || $_)->h2z->getu
          });

print encode_utf8 $h{tr}->($str). "\n";
print encode_utf8 $h{uj}->($str), "\n";

$_ = join '', <DATA>;
timethese(50000, \%h);
$_ = join '', <>;
timethese(5, \%h);

今日はｘｘｘ＠ｇｍａｉｌ．ｃｏｍにポストしておいて！！！
今日はｘｘｘ＠ｇｍａｉｌ．ｃｏｍにポストしておいて！！！
Benchmark: timing 50000 iterations of tr, uj...
        tr: 1 wallclock secs ( 0.64 usr + 0.00 sys = 0.64 CPU) @ 78125.00/s (n=50000)
        uj: 3 wallclock
secs ( 2.66 usr + 0.02 sys = 2.68 CPU) @ 18656.72/s (n=50000)

■ オブジェクトをキーとしたハッシュ [perl]

Perl の組込みのハッシュは、いろいろな点で java.util.Map (Java) とか std::map (C++) と違うので、
同じような動作を期待するとはまることが多い。

Perl の組込みのハッシュは文字列をキーとしたハッシュなので、
bless されたリファレンスはたとえば 「クラス名=HASH(0xXXXXXX)」のような文字列として扱われる。
キーの同値性検査も、その文字列をつかって行われる。
したがって、
・アドレスが一致しないとキーが一致したとみなされない
・文字列からもとのオブジェクトへの参照はないので、ハッシュが生きていても、元のオブジェクトが破壊されていることがある。

  そもそも、文字列からもとのオブジェクトを復元する手段がない。

対処はいくつかあって、

1. キーにしたいクラスで overload q{""} => sub {ユニークな表現を返す}

若干自由度が高くなる。
あまり深く考えたくないときは、シリアライズモジュール FreezeThawや Storableを使うと良さげ。
もとのオブジェクトを復元するのに、freeze, thaw を使う必要がある。

2. Tie::Hash::StructKeyed

自動的にリファレンスの中身をYAML形式にダンプしてキーに使う。
復元も可能。

$hash{yaml化されたキー} = [キー, 値]

を

$hash{キー} = 値

のように見せている。
アクセスのたびにyaml化をするので、けっこう重い。

3. 自作モジュール

std::tr1::unordered_map をラップしてPerlモジュール作成。
コンストラクタにハッシュ値関数と比較関数を渡すとかで。
でも、ハッシュ関数をPerlで書かせるのなら、
コード量の割に速度向上の恩恵が少ないような気がする。

2と3は、標準的なPerlだけでは動かないというのが問題といえば問題。


4. Tie::RefHash

常にアドレスの一致だけで同値性を判定し、文字列化しない（ようにみえる）ハッシュは
Tie::RefHashとして標準モジュールに入っているけれど、
最終的にはアドレス値を文字列として比較しなければならないのが、どうしても気持ち悪い。

404 Blog Not Found:perl

■ Perl Critic [perl][net]

<http://perlcritic.com/>

Some Ways Are Better Than Others

Perl のスタイルチェッカー

■ 2ch板の全レスダウンロード [perl]

perl -Mstrict -MWWW::2ch -e'my $bbs=WWW::2ch->new(url => $ARGV[0], cache=>q{/tmp/www2ch-cache}); $bbs->load_setting; $bbs->load_subject; print map $_->url."\n", $bbs->subject->threads' http://academy5.2ch.net/gengo/ | xargs wget -w 1 -m

■ thread2dat.pl [perl]

perl -pe' s{^(http://.*?)/.*/(.*?)/(\d{10}).*$}{$1/$2/$3.dat\n}'

■ Gaussian Process で滑らかな関数を発生させる [perl][stat]

Gaussian Process は関数空間上の確率変数の一種。

#! /usr/bin/env perl
use strict;
use warnings;
use Math::Random qw/:all/;

my @xs = map { ($_/30) } (0..20);  # 関数への入力値列
my $n = scalar @xs;
my @v = map { my $x=$_; [map {exp -1/2*( ($x-$_)**2 )} @xs]} @xs; # カーネル
#my @v = map { [map 1, @xs] } @xs;
my @m = ((0)x$n);
print map join(qq{\n}, @$_).qq{\n\n},
  random_multivariate_normal(2, @m, @v); # 2個の出力値列が得られる。各列は入力値列に対応する。

入力値の刻みを細かくしたり、入力値の数を増やそうとすると破綻する。
たぶん、浮動小数点の誤差が問題になっている。

もっと細かく値をとりたいときは、
逆関数法で random_multivariate_normal
を実装するか、R使っとけと。

use bignum して exp を 0 周辺でテイラー展開するとか、
covariance matrix が対称行列になるように対象位置の値はコピーで作るとか、
やってみたが無効だった。

GPML pp.13--14 辺りを見て実装した。
# ちなみに入力を多次元化するときは、カーネルの$x-$_に square root 距離をかませればいいらしい。
GP が滑らかな関数を発生させる理由は、
カーネル関数の値、つまり入力値同士の「類似度」を covariance に指定しているから。
遠い入力値に対応する出力値同士は covariance が小さいので相関がないが、
近い場合は相関が強くて、
結果として、滑らかっぽい関数が出来上がる。
「前後の点の座標値とあまり離れない」という意味での滑らかさではなく、
「入力値が近ければ出力値が近い」という意味

■ Math::Random で 多次元正規分布に従う乱数を発生させる [perl][stat]

random_multivariate_normal(N, mean_vector, covariance_matrix)

で、N 個のサンプルが帰ってくる。
mean_vector, covariance_matrix は配列へのリファレンスではなく、配列である必要がある。

perl -M'Math::Random qw/:all/' -e'print map join(qq{\t}, map {int($_ * 2) } @$_)."\n", random_multivariate_normal(100000,@m=(0,0),@v=([1,0],[0,1]))' | sort -g | uniq -c

インストール時、su していないと make install が通らなかった。

look Math::Random

して Makefile の /usr を ${HOME} に書き換えるとインストールできた。

■ nesugi.net - swigの使い方のメモ書き [ruby][perl][cxx][net]

<http://www.nesugi.net/hiki/?swig%A4%CE%BB%C8%A4%A4%CA%FD%A4%CE%A5%E1%A5%E2%BD%F1%A4%AD>

   1. moduleにしたいプログラムのsource(*.cppとか)を持ってくる
   2. cppファイル毎に*.iを書く ← これがswig語
   3. swigコマンドで*.iを各スクリプト言語用のwrapper(c++で書かれてる)に変換
   4. Makefile.PLやextconf.rbのような、スクリプト言語用のMakefileの元になるファイルを書く
   5. 通常のモジュールと同じようにmakeする

■ Syntax-Highlight-Universal [perl][net]

<http://search.cpan.org/~palant/Syntax-Highlight-Universal/Universal.pm>
はてなのスーパーpreらしい

■ changelog count [perl]

#! /usr/bin/env perl
use strict;
use warnings;
my %count;

my $print_line_num = 0;
use Getopt::Long;
GetOptions('line-num' => \$print_line_num);

my @lines = <>;
my $count = $print_line_num ?
  sub { $_[1] - $_[0] } :
  sub { scalar grep /^\t\* /, @lines[$_[0] .. $_[1]] };
$. = 0;
my $last_line = 1;
my $date;
my $writer;
foreach (@lines) {
  ++$.;
  chomp;
  if ( m/^(\d{4}-\d{2}-\d{2})\s+(.*)/ ) {
    my $n = $count->($last_line, $.);
    print "$date\t$writer\t$n\t", q{#}x($n) ,"\n" if $n > 0;
    ($date, $writer, $last_line) = ($1, $2, $.);
    $date =~ tr/-/\t/;
    $writer = sprintf '%.18s', $writer;
  }
}

■ なぜ Perl を使うのか [perl]

CPAN があるからだと思う。

Python Cheese Shop : Home
Ruby Application Archive
CPAN

■ XHTML を XML に逆変換 [markup][perl]

#! /usr/bin/env perl
use warnings;
use strict;
use WWW::Mechanize;
use WWW::Mechanize::Link;
use URI::URL;
use URI::file;
use URI::Escape;
use Getopt::Long;
use Pod::Usage;
use XML::Simple;
use Data::Dumper;
use Encode;
use encoding qw/utf8/;
use open OUT => ':utf8';
use open qw/:std/;
$XML::Simple::PREFERRED_PARSER = 'XML::Parser';

sub xml_in_decoding($$) {
  my($xml_simple, $http_response) = @_;
  my $content = $http_response->content;
  
  if ( join(' ',$http_response->headers->content_type) =~ m/charset=(\w+)/ ) {
    $content = decode($1, $content);
  }
  $content =~ s{"Shift_JIS"}{"UTF-8"};

  #tidy
  {
    my $tmp = '/tmp/tidyresult';
    {
      open my $f, '>:encoding(utf-8)', $tmp or die "$!: $tmp";
      print $f $content;
      close $f;
    }
    system qq{tidy -modify -utf8 $tmp 2>/dev/null};
    {
      open my $f, '<:encoding(utf-8)', $tmp or die "$!: $tmp";
      $content = join '', <$f>;
      close $f;
    }
  }
  return $xml_simple->xml_in($content);
}

# get arguments
my $wait_seconds = 3;
my $verbose = 0;
my $input_encoding = '';
GetOptions(
           'wait=i'     => \$wait_seconds,
           'verbose'    => \$verbose,
           'encoding=s' => \$input_encoding,
           'help'       => sub{pod2usage(0)}
          );
my $url = shift @ARGV;

my $m = WWW::Mechanize->new();
my $xs = XML::Simple->new(ForceArray => 1,
                          KeyAttr => []);

# get a village
my %village;
$m->get($url); # assuming this as prologue
exit 1  unless ( $m->success );
{
  my @a;
  foreach my $link ( $m->find_all_links( url_regex => qr{_progress_\d+} ) ) {
    $link->url =~ m/_progress_(\d+)/;
    my $n = $1;
    next if defined $a[$n];
    print STDERR "waiting $wait_seconds seconds before retrieving ".$link->url."...\n" if $verbose;
    sleep $wait_seconds;
    $m->follow_link(url => $link->url);
    $a[$n] = xml_in_decoding($xs, $m->response);
  }
  $village{progresses} = \@a;
}

print STDERR "waiting $wait_seconds seconds before retrieving 'party'...\n" if $verbose;
if ( $m->follow_link( url => q{_party_} ) ) {
  sleep $wait_seconds;
  $village{epilogue} = $m->ct;
}
print $xs->xml_out(\%village);

#my $log = Parse::RecDescent->new($grammar)->parse($text);
#print Dumper($log);

__END__

=head1 NAME

  ninjin_crawl.pl - Jinro BBS crawler

=head1 SYNOPSIS

  crawler.pl [options] URL

=head1 OPTIONS

  --encoding      URL
                  auto-detect if not specified
  --help          shows this help
  --wait          waiting time between requests [3]

=head1 DESCRIPTION

  ninjin_crawl.pl retrieves and parse a whole log
  of the villlage specified in the argument.
  And put the result to the standard output as a XML.

=head1 SEE ALSO

L<WWW::Mechanize>

=cut

■ crawler.pl [perl]

wget は CGIパラメタが違うだけのURLを区別してくれないっぽい。
もっと攻撃的なクローラがほしかったので書きました。
無条件(ホストだけは合わせるけど)で2段階のリンクを踏んでとってくるクローラ：

#! /usr/bin/env perl
use warnings;
use strict;
use WWW::Mechanize;
use WWW::Mechanize::Link;
use URI::URL;
use URI::Escape;
use Getopt::Long;
use Pod::Usage;

my $max_follow_links = 2;
my $wait_seconds = 3;
my $verbose = 0;
my $dest_dir = '';
GetOptions(
   'level=i' => \$max_follow_links,
   'wait=i'  => \$wait_seconds,
   'dest_dir=i'  => \$dest_dir,
   'verbose' => \$verbose,
   'help' => sub{pod2usage(-exitstatus => 0)}
  );
my $url = shift @ARGV;
$dest_dir = uri_escape $url if $dest_dir eq '';


my $m = WWW::Mechanize->new();
my %links;
my $collect_links;
$collect_links = sub($$) {
  my($url, $dep)=@_;
  if ( $dep <= 0 ) {
    return;
  }
  print STDERR "waiting $wait_seconds seconds ... \n" if $verbose;
  sleep $wait_seconds;

  # GET and save
  my $res = $m->get($url);
  my $local_path = $dest_dir . '/'. uri_escape $url;
  open F, '>', $local_path or die "$!: $local_path";
  print F $res->as_string;
  close F;
  
  my @links = map $_->URI, $m->links($url);
  foreach (@links) {
    print STDERR $_, "\n" if $verbose;
    $links{$_->abs} = $_;
  }
  print STDERR "collected ".(scalar keys %links)." links in total\n" if $verbose;
  if ( $dep >= 2 ) {
    $collect_links->($_,$dep-1) foreach @links;
  }
};

mkdir uri_escape $url;
$collect_links->(URI::URL->new($url), $max_follow_links);

__END__

=head1 NAME

  crawler.pl - Simple Web Crawler

=head1 SYNOPSIS

  crawler.pl [options] URL

  Options:
   --level      max follow depth [2]
   --dest_dir   destination directory [URL]
   --help       shows this help

=head1 DESCRIPTION

B<crawler.pl> is a simple crawler which follows the links on a specified URL
within a specified link depth.

=head1 SEE ALSO

L<WWW::Mechanize>

=cut

とってきたファイルは URI escape した名前で保存する。

■ Perl で HTTP::Request [perl]

perl -MLWP::UserAgent -MHTTP::Request -e'print LWP::UserAgent->new()->get(q{http://www.yahoo.com})->as_string()'
perl -MLWP::UserAgent -MHTTP::Request -e'print LWP::UserAgent->new()->request(HTTP::Request->new('GET', q{http://www.yahoo.com}, {}))->as_string()'

wget とか curl とか、環境によっては lwp-rget と同様。

■ ChangeLog parser with Parse/RecDescent [perl][chalow]

<http://blogger.main.jp/changelog/2004-07-28-2.html>
改造した。

いわゆる一つの再帰下降型構文解析。
ループと分岐と関数呼び出しで書く例のやつです。
[src]
#! perl -w
# Parse ChangeLog
# Copyright: (C) Project PaoPei with zuihu 2004 JAPAN
# $Id: remoteclog.txt,v 1.2 2004/12/06 08:58:45 zuihu Exp $

# modified 2006-11-27, for chalow, cf. http://kerolin.jspeed.jp/2006/10/03/

package ParseChangeLog;
use strict;
use Parse::RecDescent;
use Data::Dumper;
$Parse::RecDescent::skip = '[\r\f\n]*';

    my $grammar = q(
        parse: entry(s)
        {[{entry => $item[1]}]}

        entry: entryheader item(s)
         

        entryheader: /^(\d{4}-\d{2}-\d{2})\s+(.+) \s+\<(.+)\>/
        {@{$return}{qw(date user mail)} = ($1,$2,$3)}

        item: itemheader itembody(s)
        {
            my $body = join ("\n", @{$item[2]});
@{$return}{qw(title tag body)} = ($item[1]->[0], $item[1]->[1], $body)
        }

        itemheader: /^\t\* ([^\[]*)(\[.*\]):/
        {[$1,$2]}

        itembody: /^(?!(\t\* .+?:|\d{4}-\d\d\-\d\d))(.*)/
        {($2)}
    );


my $text;
{
  local $/ = undef;
  $text = <STDIN>;
}
my $log = Parse::RecDescent->new($grammar)->parse($text);
print Dumper($log);
[src]

■ Parse-RecDescent Tutorial [perl][net]

<http://www.perl.com/pub/a/2001/06/13/recdecent.html>

■ HTTP::Proxy [perl][net]

<http://search.cpan.org/~book/HTTP-Proxy-0.20/lib/HTTP/Proxy.pm>

■ カエルチュウイホウ - PlaggerでChangeLogを扱う(2) [perl][chalow][net]

<http://kerolin.jspeed.jp/Computer/Linux/Meadowger060611.html>

package Plagger::Plugin::CustomFeed::ChangeLog;
use strict;
use warnings;
use base qw( Plagger::Plugin );
use Parse::RecDescent;
use Text::Markdown 'markdown';

$Parse::RecDescent::skip = '[ \r\f\n]*'; 

sub register {
    my($self, $context) = @_;
    $context->register_hook(
        $self,
        'subscription.load' => \&load,
    );
}

sub load {
    my($self, $context) = @_;

    my $feed = Plagger::Feed->new;
    $feed->aggregator(sub { $self->aggregate(@_) });
    $context->subscription->add($feed);
}

sub aggregate {
    my($self, $context, $args) = @_;

    my $file = $self->conf->{changelog_file};

    $context->log(info => "Load $file");

    open my $fh, $file
        or return $context->log(error => "$file: $!");

    my $text;    
    {
	local $/ = undef;
	$text = <$fh>;
    }

    my $feed = Plagger::Feed->new;
    $feed->title("ChangeLog");
    $feed->type('ChangeLog');

    my $grammar = q(
        parse: entry(s)
        {@{$return}{entry} = @item[1]}

	 entry: entryheader item(s)
	 {@{$return}{qw(header item)} = @item[1..2]}

        entryheader: /^(\d{4}-\d{2}-\d{2})\s+(.+) \s+\<(.+)\>/
        {@{$return}{qw(date user mail)} = ($1,$2,$3)}

        item: itemheader itembody(s)
        {
            my $body = join ("\n", @{$item[2]});
	    @{$return}{qw(tag title body)} = ($item[1]->[0], $item[1]->[1], $body)
        }

        itemheader: /^\t\* (.*):\s+(.+)/
        {[$1,$2]}

        itembody: /^\t(?!\*)(.*)/
        {($1)}
    );

    my $data = Parse::RecDescent->new($grammar)->parse($text);

    for my $datelog (@{$data->{entry}}){
	for my $item (@{$datelog->{item}}){
	    my $entry = Plagger::Entry->new;
	    $entry->title($item->{title});
	    $entry->author($datelog->{user});
	    $entry->date($datelog->{date});
            my $htmlized_body = markdown($item->{body});
	    $entry->body($htmlized_body);
	    $feed->add_entry($entry);
	}
    }

    $context->update->add($feed);
}

1;
__END__

■ 名づけのない再帰 fixed-point combinator [perl][fp]

p.65 Types and Programming Languages より。

afact は、引数に階乗関数を渡されたとき階乗関数になる関数。
つまり、階乗関数に適用すると階乗関数が帰ってくる関数。

#! /usr/bin/env perl
use strict;
use warnings;
use integer;
my $afact = sub { my $f = shift;
                  sub { my $n = shift; print "*$n\n";
                        $n == 0 ? 1 : $n * $f->($n - 1); } };
# afact = L[f]. L[n]. n==0 ? 1 : n * f (n-1)

my $fix = sub { my $f = shift;
                my $f1 = sub { my $x = shift;
                               $f->( sub { my $y = shift;
                                           $x->( $x )->( $y );  } ) };
                $f1->($f1); };
# fix = L[f]. f1 f1   where f1 = L[x]. f ( L[y]. x x y )

my $fact = $fix->($afact);
# fact = fix afact
#   -> f1 f1  where f1 = L[x]. afact( L[y]. x x y )
#   -> afact( L[y]. f1 f1 y )    where f1 = L[x]. afact( L[y]. x x y )
#   <-*- afact( L[y]. fact y ) = afact( fact )
print $fact->(4), "\n";

上記のコードでも名前を使ってはいるが、
どの名前も、実体と置き換えて消去できるので、
再帰に使ってるわけではない。
# 再帰に使う名前は、置き換えを無限に続けられる

消去すると、こうなる。

print 
    sub { my $f = shift;
  my $f1 = sub { my $x = shift;
                 $f->( sub { my $y = shift;
                             $x->( $x )->( $y );  } ) };
  $f1->($f1); } ->
    (
     sub { my $f = shift;
   sub { my $n = shift; print "*$n\n";
         $n == 0 ? 1 : $n * $f->($n - 1); } }
    )->(4), "\n";

再帰を含む処理を1文で書けました。

$f1 も消せるけど、あまりに可読性が低くなるので、消さずにおいた。

sub { my $x = shift;

は、lambda x のこと。
これは名前にカウントしないことにする。