Weighted Random

На протяжении многих лет время от времени приходилось использовать код, выбирающий из списка случайные элементы. При этом в большинстве случаев желательно было учитывать веса. Но поскольку требование о взвешивании было желательно, а не обязательно, то лень побеждала, тем более, что эти требования были моими. :-)

Но вот настал момент, когда я наконец-то победил лень и написал подпрограмму, которая создает замыкание, возвращающие случайный элемент из списка с учетом весов элементов:

 sub wrand($) {
  my $data = shift;
 
  my $total = 0;
  $total += $_ foreach values %$data;
 
  my @dist = ();
  while (my ($value, $weight) = each %$data) {
   push @dist, [$value, $weight / $total];
  }
 
  return sub {
   my $rand = rand;
   foreach (@dist) {
    return $$_[0] if ($rand -= $$_[1]) < 0;
   }
   return $dist[-1][0];
  }
 }

Пример использования:

 my %foo = (
  # value => weight 
  "one"   => 3,
  "two"   => 2,
  "three" => 1,
 );
 
 my $wrand = wrand(\%foo);
 print $wrand->(), "\n" for 1 .. 10;

Если веса являются целыми числами, то можно использовать более быструю версию:

 sub iwrand($) {
  my $data = shift;
  my %dist = ();
  while (my ($value, $weight) = each %$data) {
   $dist{keys %dist} = $value foreach 1 .. $weight;
  }
  return sub {
   $dist{int rand keys %dist};
  };
 }

Смотрите также модуль Math::Random - Random Number Generators.

Светлая и темная стороны силы Perl

"Существует множество способов сделать это", и в каждой конкретной ситуации следует предпочесть наиболее простой, ясный и оптимальный вариант. Вот это белая сторона силы Perl.

На темной же стороне те "Just another Perl Hackers", кто, используя мощь Perl, делает простые вещи сложными в угоду своему самолюбию.

"Сегодня без..." - точка, превратившаяся в запятую

Чтобы диалектически соединить на новом витке последнюю заметку (Сегодня без того - не знаю чего) с первыми из цикла заметок "Сегодня без...", написал нижеприведенный код.

 sub sum(&$@);
 sub sum(&$@) {
  my $sub = shift;
  my ($sum, $h, @t) = @_;
  if (defined $h) {
   sum { $sub->(@_) } $sum + $h, @t;
  } else {
   $sub->($sum);
  }
 }
 
 my @vector = 1 .. 5;
 sum { print shift } 0, @vector;

Вот только эта точка, поставленная в конце цикла заметок "Сегодня без...", превратилась в запятую!

each и return - опасное соседство

 keys %foo;
 while (my ($k, $v) = each %foo) {
  ...
  return ...;
 }

Для вышеприведенного кода, если while вызывается более чем один раз за время существования хеша %foo, не следует забывать о сбросе итератора each при помощи keys.

Я вот забыл, так как практически не использую each, и потратил время на поиски причины, почему код выдает неверный результат. Хорошо, что сразу написал тест и увидел, что есть ошибка.

Прототипы и аргументы из списка

Вызывая подпрограмму

 sub foo($$$$) { }

Так хочется вместо, например,

 foo(1, $foo{1}, $foo{3}, $foo{5});

Написать

 foo(1, @foo{qw(1 3 5)});

Но нельзя, так как Perl ругается, что недостаточно аргументов. :-(

PSGI и SpeedyCGI

Благодаря Алексею Капранову узнал о появлении PSGI/Plack. PSGI - cпецификация интерфейса между Perl web приложениями и web серверами. Plack - реализация.

Интересно, а SpeedyCGI (PersistentPerl) часто используют для HTTP? Для тех кто не знает: SpeedyCGI можно использовать не только для HTTP при помощи mod_speedycgi из под Apache, а как полноценный PersistentPerl для любых Perl приложений.

Reduced map

Как известно в Perl 6 имеются гипер- и редакшноператоры
(заметка о них http://laziness-impatience-hubris.blogspot.com/2009/01/perl6.html).

Но что же делать в Perl 5?

Для замены редакшноператоров можно воспользоваться подпрограммой reduce из модуля List::Util или
воспользоваться "reduced map" (rmap) из нижеприведенного модуля (List::Rmap).
Замена же гипероператоров осуществляется при помощи "hyper map" (hmap) того же модуля.

Рассмотрим примеры.

 use strict;
 use warnings;
 
 use List::Rmap qw(reduce rmap hmap);
 
 my @a = (1, 2, 3);
 my @b = (4, 5, 6);
 
 print           reduce { $a + $b } @a;
 # Бyдет напечатано 6
 # Это в Perl6 эквивалентно [+] @x
 print "\n";
 
 # reduced map
 print join " ", rmap   { $a + $b } @a;
 # Бyдет напечатано 1 3 6
 # Это в Perl6 эквивалентно [\+] @x
 print "\n";

 # hyper map
 print join " ", hmap   { $a + $b } @a, @b;
 # Бyдет напечатано 5 7 9
 # Это в Perl6 эквивалентно @x >>+<< @y

А вот содержимое вышеупомянутого модуля List::Rmap:

 # Reduced map
 
 package List::Rmap;
 
 use strict;
 use warnings;
 
 no strict qw(refs);
 
 use Exporter;
 our @EXPORT_OK = qw(reduce rmap hmap);
 
 
 sub import {
 
  # Avoid "Name "..." used only once" warnings for $a and $b.
  my $caller = caller;
  local *{"${caller}::a"};
  local *{"${caller}::b"};
 
  goto &Exporter::import
 }
 
 
 
 sub reduce (&@) {
  my $code = shift;
 
  my $caller = caller;
  local *{"${caller}::a"} = \ my $a;
  local *{"${caller}::b"} = \ my $b;
 
  $a = shift;
  foreach (@_) {
   $b = $_;
   $a = &{$code}();
  }
 
  return $a;
 }
 
 
 
 sub rmap (&@) {
  my $code = shift;
 
  my $caller = caller;
  local *{"${caller}::a"} = \ my $a;
  local *{"${caller}::b"} = \ my $b;
 
  my @r = ($a = shift);
  foreach (@_) {
   $b = $_;
   push @r, $a = &{$code}();
  }
 
  return @r;
 }
 
 
 
 sub hmap (&\@\@) {
  my $code = shift;
  my ($ra, $rb) = @_;
 
  @$ra == @$rb or die "Different length of lists.";
 
  my $caller = caller;
  local *{"${caller}::a"} = \ my $a;
  local *{"${caller}::b"} = \ my $b;
 
  my @r = ();
  foreach ($[ .. $#$ra) {
   $a = $$ra[$_];
   $b = $$rb[$_];
   push @r, &{$code}();
  }
 
  return @r;
 }
 
 
 1;