Вычисление рекуррентных соотношений на Perl

    Привет,
    в этом посте я расскажу рецепт добавления функциональности в Перл.

    Как уже стало понятно из названия, мы будем вычислять рекуррентные соотношения.
    Например, формулы для вычисления факториала выглядят вот так:
    f(0) = 1
    f(n) = n * f(n-1)
    


    Функциональные языки программирования позволяют определять такие функции достаточно просто, в Erlang это делается следующим образом:
    factorial(0) ->
        1;
    factorial(N) ->
        N * factorial(N-1).


    А теперь попробуем сделать нечто похожее, что позволяло бы нам писать код вида:
    #!/usr/bin/perl -I./lib
    use strict;
    use bigint;
     
    use Recurrent;
     
    recurrent fac => {
        arg(0) => lambda { my($n) = @_; return 1 },
        arg(n) => lambda { my($n) = @_; return $n * fac($n-1) },
    };
     
    print fac(100);

    Из примера видно, что у нас появились новые функции recurrent, arg, n и lambda. На самом деле, практическая польза есть только у recurrent, все остальные нужны лишь для получения более «красивого» кода.

    Давайте напишем модуль Recurrent.pm

    package Recurrent;
    our $VERSION = '0.01';
    use base qw(Exporter);
    
    use strict;
    use Carp qw(confess);
    
    our @EXPORT = qw(arg n lambda recurrent);
    
    sub arg       { shift } # возвращает первый аргумент
    sub n         { ''    } # возвращает пустую строку
    sub lambda(&) { shift } # alias для sub { }
    sub recurrent($$) { 
        my($name, $mapping) = @_;
        confess '$name should be a string'
            if ref($name) ne '' || $name !~ /^\p{XID_Start}\p{XID_Continue}*$/;
        confess '$mapping should be a hash reference'
            if ref($mapping) ne 'HASH';
        confess 'no parametric function in recurrent relation'
            if ref($mapping->{(n())}) ne 'CODE';
        {
            no strict 'refs';
            
            # создаем кеш и функцию $name
            my $mem = join('::', (caller())[0], "RECURRENT_CACHE_$name");
            my $fun = join('::', (caller())[0], "$name");
            
            *{$mem} = {};
            *{$fun} = sub {
                my($_n, $_mapping) = ($#_ ? $_[1] : $_[0], $mapping);
                
                confess "argument is required for $name(n)"
                    if !defined $_n;
                    
                # ищем значение в кеше, если нет то вычисляем
                defined(${*{$mem}}->{$_n})
                    ?  (${*{$mem}}->{$_n})
                    :  (${*{$mem}}->{$_n} =
                        defined($_mapping->{$_n})
                            ?  do { local $_ = $_n; $_mapping->{$_n}->($_n) }
                            :  do { local $_ = $_n; $_mapping->{(n)}->($_n) });
            };
        }
    }
    
    1;
    


    Теперь, можно написать что-то вроде.
    #!/usr/bin/perl -I./lib
    use strict;
    use bigint;
     
    use Recurrent;
     
    # | f(0) = 0
    # | f(1) = 1
    # | f(n) = f(n-1) + f(n-2)
    recurrent fib => {
        arg(0) => lambda { my($n) = @_; return 0 },
        arg(1) => lambda { my($n) = @_; return 1 },
        arg(n) => lambda { my($n) = @_; return fib($n-1) + fib($n-2) },
    };
     
    print fib(100);
     


    В качестве бонуса напишем левостороннюю свертку, известную как reduce или foldl
    sub reduce(&@) {
        my($f,$z,@x) = @_;
        map {
            local($a,$b) = ($_,$z);
            $z = $f->($a,$b);
        } @x;
        $z;
    }


    и посчитаем сумму чисел Фибоначчи от 1 до 100
    print reduce { $a + $b } map { fib($_) } 1..100;
    


    Update:
    появилась поддержка сокращенного синтаксиса
    #!/usr/bin/perl -I./lib
    use utf8;
     
    use strict;
    use bigint;
     
    use Recurrent;
     
    sub λ(&) { shift }
    # | ƒ(0) = 0
    # | ƒ(1) = 1
    # | ƒ(n) = ƒ(n-1) + ƒ(n-2)
    recurrent ƒ => {
        (0) => λ { 0 },
        (1) => λ { 1 },
        (n) => λ { ƒ($_-1) + ƒ($_-2) },
    };
     
    print ƒ(100);


    Поделиться публикацией
    AdBlock похитил этот баннер, но баннеры не зубы — отрастут

    Подробнее
    Реклама
    Комментарии 15
    • 0
      Лучше предусмотреть возможность использования модуля в ООП режиме. Хотя для учебного материала это не особо нужно :)
      • +1
        предусмотрел :)

        package MyMath;
        our $VERSION = '0.01';
        
        use strict;
        use bigint;
        
        use Recurrent;
        
        sub new {
            bless {}, shift;
        }
        
        recurrent 'fib' => {
            arg(0) => lambda { my($n) = @_; return 0 },
            arg(1) => lambda { my($n) = @_; return 1 },
            arg(n) => lambda { my($n) = @_; return fib($n-1) + fib($n-2) },
        };
        
        1;
        


        #!/usr/bin/perl -I./lib
        use strict;
        use bigint;
        
        use Test::More tests => 2;
        use MyMath;
        
        is(MyMath->new->fib(100), MyMath::fib(100), "two modes");
        is(MyMath->new->fib(100), 354224848179261915075, "fib(100)");
        


        ok 1 — two modes
        ok 2 — fib(100)

      • +1
        Магия
        • 0
          И все-таки лучше просто писать на Erlang.
          • +1
            почему?
            • +2
              минус — это аргументированный ответ
          • 0
            Я бы использовал confess, вместо croak, раз речь идёт и ловле ошибок программиста, а не юзера.
            Так же lambda вместо sub — это уже дело вкуса… Мне вполне нравится sub, кстати в perl 5.10 часто можно просто поставить скобки {}.

            Ещё, раз функция может быть от одной переменной, я бы использовал local $_, код тогда мог выглядеть так:

                arg(0) => sub { 0 },
                arg(1) => sub { 1 },
                arg(n) => sub { fib($_-1) + fib($_-2) },
            


            $_ удобна тем что многие встроенные функции можно вызывать с этим неявным аргументом — defined, /someregexp/ chomp итд.

            Передать $_ в функцию можно просто:
            $mycallback->() for ($myarg);
            

            • +1
              хорошая идея с $_ :)
              • 0
                сделал, спасибо
                • +1
                  можно еще так сделать
                  recurrent ƒ => {
                      (0) => λ { 0 },
                      (1) => λ { 1 },
                      (N) => λ { ƒ(n-1) + ƒ(n-2) },
                  };
                  


                  но не очень удобно будет что n и N различаются
                  sub N { '' }
                  sub n { $_ }
                  • 0
                    Можно сделать чтобы и там и там было n: перед вызовом лямбды переопределить n.
                    local *n = sub() {
                    ...
                    }
                    

              • +1
                Ещё из косметики — когда присваиваем глобу анонимную ф-цию, я обычно делаю такую штуку:

                use Sub::Name;
                *foo = subname foo => sub{};
                


                Очень помогает при отладке видеть, что упало не в некоей __ANON__, которых может быть 3-4 подряд по стеку, а именно в foo().
                • +1
                  use v5.14;
                  use Memoize;
                  use List::Util qw(sum reduce);
                  
                  memoize 'fib';
                  say sum map fib($_), 1..100; # "sum" is a "reduce { $a + $b }"
                  
                  sub fib {
                      my $n = shift;
                      return $n if $n < 2;
                      fib($n-1) + fib($n-2);
                  }
                  
                  • 0
                    Да, только хотел про Memoize написать :) Очень полезная штука.
                    • 0
                      если заюзать state и __SUB__, то можно так:

                      use v5.16;
                      use List::Util 'sum';
                      
                      say sum map {
                          state $fib = sub {
                              my $n = shift;
                              state $cache = [];
                              $cache->[$n] //= $n < 2 ? $n : __SUB__->($n-1) + __SUB__->($n-2);
                          };
                          $fib->($_);
                      } 1..100;
                      

                    Только полноправные пользователи могут оставлять комментарии. Войдите, пожалуйста.