Неограниченные списки в Perl

© Copyright 1997 The Perl Journal.

Hamming's Problem

 2i3j5k

         1 2 3 4 5 6 8 9 10 12 15 16 18 ...

Потоки

 
 head  tail        head  tail        head  tail
 +-----+-----+     +-----+-----+     +-----+-----+
 |     |     |     |     |     |     |     |     |
 | foo |  *-------}|  3  |  *-------}| bar |  *------} . . .
 |     |     |     |     |     |     |     |     |
 +-----+-----+     +-----+-----+     +-----+-----+

                                                         ____________
 +-----+-----+     +-----+-----+     +-----+-----+    /           /\
 |     |     |     |     |     |     |     |     |    |I'll do it |/
 | foo |  *-------}|  3  |  *-------}| bar |  *------}|when and if|
 |     |     |     |     |     |     |     |     |    |you need it|
 +-----+-----+     +-----+-----+     +-----+-----+    |           |
                                                         | Love, Perl|
                                                         _|__________ |
                                                         \___________\/

         $promise = sub { EXPRESSION };

         $value = &$promise;             # Evaluate EXPRESSION

         if (ref $something eq CODE) { # It's a promise... }

        package Stream;
 
         sub new {
           my ($package, $head, $tail) = @_;
           bless { h => $head, t => $tail } => $package;
         }
 

         sub head { $_[0]{h} }

 
        sub tail {
           my $tail = $_[0]{t};
           if (ref $tail eq CODE) {          # It's a promise
             $_[0]{t} = &$tail();            # Collect on the promise
           }
           $_[0]{t};
         }
 

          sub empty {
           my $pack = ref(shift()) || Stream;
           bless {e => 'I am empty.'} => $pack;
         }
 

         sub is_empty { exists $_[0]{e} }

         sub tabulate {
           my $f = shift;
           my $n = shift;
           Stream->new(&$f($n),
                       sub { &tabulate($f, $n+1) }
                      )
         }
 

         sub square { $_[0] * $[0] }
         $squares = &tabulate( \&square,  1);
 

         $squares->show;
                 1 4 9 16 25 36 49 64 81 100
 

         1 3 5 7 9 11 13 15 17 ...

        1 4 9 16 25 36 ...

        1 3 4 5 7 9 11 13 15 16 17 19 ...
 
 sub merge {
         my $s1 = shift;
         my $s2 = shift;
         return $s2 if $s1->is_empty;
         return $s1 if $s2->is_empty;
         my $h1 = $s1->head;
         my $h2 = $s2->head;
         if ($h1 > $h2) {
         Stream->new($h2, sub { &merge($s1, $s2->tail) });
         } elsif ($h1 < $h2) {
         Stream->new($h1, sub { &merge($s1->tail, $s2) });
         } else {                      # heads are equal
         Stream->new($h1, sub { &merge($s1->tail, $s2->tail) });
           }
         }
 

Решение проблемы Hamming

 
        1  2  3  4   5   6  8   9  10   12  15  16   18 ...

         2  4  6  8  10  12 16  18  20   24  30  32   36 ...

         # Multiply every number in a stream `$self' by a constant factor `$n'
         sub scale {
           my $self = shift;
           my $n = shift;
           return &empty if $self->is_empty;
           Stream->new($self->head * $n,
                       sub { $self->tail->scale($n) });
         }
 

         # Construct the stream of Hamming's numbers.
         sub hamming {
 1          my $href = \1;           # Dummy reference
 2          my $hamming = Stream->new(
 3                  1,
 4                  sub { &merge($$href->scale(2),
 5                        &merge($$href->scale(3),
 6                               $$href->scale(5))) });
 7          $href = \$hamming;      # Reference is no longer a dummy
 8          $hamming;
         }
 

         &hamming()->show(20);
                  1 2 3 4 5 6 8 9 10 12 15 16 18 20 24 25 30 32 36 40
 

 #!D:/install/perl/bin/perl
 #
 # Stream.pm
 #
 # Sample implementation of lazy, infinite streams with memoization
 #
 # Copyright 1997 M-J. Dominus (mjd@pobox.com)
 #
 #    This program is free software; you can redistribute it and/or modify
 #    it under the terms of any of:
 #       1. Version 2 of the GNU General Public License as published by
 #          the Free Software Foundation;
 #       2. Any later version of the GNU public license, or
 #       3. The Perl `Artistic License'
 #
 #    This program is distributed in the hope that it will be useful,
 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 #    GNU General Public License for more details.
 #
 #    You should have received a copy of the Artistic License with this
 #    Kit, in the file named "Artistic".  If not, I'll be glad to provide one.
 #
 #    You should also have received a copy of the GNU General Public License
 #    along with this program; if not, write to the Free Software
 #    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 #
 
 
 package Stream;
 
 use Exporter;
 @ISA = (Exporter);
 @EXPORT = qw(new iterate tabulate upto iota filter
 	     primes merge hamming stats rand list2stream
 	     iterate_chop chop_if mingle squares_from hailstones);
 
 ### Basic functions
 
 &hamming()->show(2000);
 
 ## Manufacture a new stream node with given head and tail.
 sub new {
   my $what = shift;
   my $pack = ref($what) || $what;
   my ($h, $t) = @_;
   bless { h => $h, t => $t } => $pack;
 }
 
 ## Return the head of a stream 
 sub head {
   $_[0]{h};
 }
 
 ## return the tail of a stream, collecting on a promise
 ## if necessary
 sub tail {
   my $t = $_[0]{t};
   if (ref $t eq CODE) {		# It is a promise
     $_[0]{t} = &$t;
   }
   $_[0]{t};
 }
 
 ## Construct an empty stream
 sub empty {
   my $pack = ref(shift()) || Stream;
   bless {e => q{Yes, I'm empty.}} => $pack;
 }
 
 ## Is this stream the empty stream?
 sub is_empty {
   exists $_[0]{e};
 }
 
 ### Tools
 
 ## Compute f(n), f(n+1), f(n+2) ...
 sub tabulate {
   my $f = shift;
   my $n = shift;
   Stream->new(&$f($n), sub { &tabulate($f, $n+1) });
 }
 
 ## Compute i, f(i), f(f(i)), f(f(f(i))), ...
 sub iterate {
   my $f = shift;
   my $i = shift;
   Stream->new($i, sub { &iterate($f, &$f($i)) });
 }
 
 ## Compute list of first n elements of stream.
 sub take {
   my $s = shift;
   my $n = shift;
   my @r;
   while ($n-- && !$s->is_empty) {
     push @r, $s->head;
     $s = $s->tail;
   }
   @r;
 }
 
 ## Return new stream of elements of $s with first
 ## $n elements skipped.
 sub drop {
   my $s = shift;
   my $n = shift;
   while ($n-- && !$s->is_empty) {
     $s = $s->tail;
   }
   $s;
 }
 
 ## Actually modify $s to discard first $n elements.
 ## Return undef if $s was exhausted.
 sub discard {
   my $s = shift;
   my $n = shift;
   my $d = $s->drop($n);
   if ($d->is_empty) {
     $s->{e} = q{Empty.};
     delete $s->{h};
     delete $s->{t};
   } else {
     $s->{h} = $d->{h};
     $s->{t} = $d->{t};
   }
   $s;
 }
 
 ## Display first few elements of a stream
 $SHOWLENGTH = 10;		# Default number of elements to show
 sub show {
   my $s = shift;
   my $len = shift;
   my $showall = $len eq ALL;
   $len ||= $SHOWLENGTH;
   for ($n = 0; $showall || $n < $len; $n++) {
     if ($s->is_empty) {
       print "\n";
       return;
     }
     print $s->head, " ";
     $s = $s->tail;
   }
   print "\n";
 }
 
 ## $f, $f+1, $f+2, ... $t-1, $t.
 sub upto {
   my $f = shift;
   my $t = shift;
   return Stream->empty if $f > $t;
   Stream->new($f, sub { &upto($f+1, $t) });
 }
 
 ## 1, 2, 3, 4, 5, ... 
 sub iota {
   &tabulate(sub {$_[0]}, 1);  # Tabulate identity function
 }
 
 ## Return a stream of all the elements of s for which predicate p is true.
 sub filter {
   my $s = shift;
    
   # Second argument is a predicate function that returns true 
   # only when passed an interesting element of $s.
   my $predicate = shift; 
 
   # Look for next interesting element	
   until ( $s->is_empty ||  &$predicate($s->head)) {
     $s = $s->tail;
   }
 
   # If we ran out of stream, return the empty stream.
   return $s->empty if $s->is_empty;
 
   # Construct new stream with the interesting element at its head
   # and the rest of the stream, appropriately filtered,
   # at its tail.
   Stream->new($s->head,
               sub { $s->tail->filter($predicate) }
              );
 }
 
 
 
 ## Given a stream s1, s2, s3, ... return f(s1), f(s2), f(s3), ...
 sub transform {
   my $s = shift;
   return $s->empty if $s->is_empty;
   
   my $map_function = shift;
   Stream->new(&$map_function($s->head),
               sub { $s->tail->transform($map_function) }
              );
 }
 
 # Emit elements of a stream s, chopping it off at the first element
 # for which `$predicate' is true
 sub chop_when {
   my $s = shift;
   my $predicate = shift;
   return $s->empty if $s->is_empty || &$predicate($s->head);
   Stream->new($s->head, sub {$s->tail->chop_when($predicate)});
 }
 
 # Return first element $h of $s, and sieve out
 # subsequent elements, discarding those that are divisible by $h.
 sub prime_filter {
   my $s = shift;
   my $h = $s->head;
   Stream->new($h, sub { $s->tail
                           ->filter(sub { $_[0] % $h })
                           ->prime_filter() 
                       });
 }
 
 # Multiply every element of a stream $s by a constant $n.
 sub scale {
   my $s = shift;
   my $n = shift;
   $s->transform(sub { $_[0] * $n });
 }
 
 # Merge two streams of numbers in ascending order, discarding duplicates
 sub merge {
   my $s1 = shift;
   my $s2 = shift;
   return $s2 if $s1->is_empty;
   return $s1 if $s2->is_empty;
   my $h1 = $s1->head;
   my $h2 = $s2->head;
   if ($h1 > $h2) {
     Stream->new($h2, sub { &merge($s1, $s2->tail) });
   } elsif ($h1 < $h2) {
     Stream->new($h1, sub { &merge($s1->tail, $s2) });
   } else {			# heads are equal
     Stream->new($h1, sub { &merge($s1->tail, $s2->tail) });
   }
 }
 
 # Given two streams s1, s2, s3, ... and t1, t2, t3, ...
 # construct s1, t1, s2, t2, s3, t3, ...
 sub mingle {
   my $s = shift;
   my $t = shift;
   
   return $t if $s->is_empty;
   return $s if $t->is_empty;
   Stream->new($s->head, sub {&mingle($t, $s->tail)});
 }
 
 
 
 # This is not a very good way to do it.
 sub hamming_slow {
   my $n = shift;
   Stream->new($n,
       sub { &merge(&hamming_slow(2*$n),
 		   &merge(&hamming_slow(3*$n),
 			  &hamming_slow(5*$n),
 			  ))
 	      });
 }
 
 # This is the good one.
 #
 # The article says it takes a few minutes to compute 3,000 numbers on
 # the dinky machine.  That turns out to be not because the dinky
 # machine was slow, but because it had so little memory.  With an
 # extra 24 MB of memory, computing 3,000 numbers takes just under 20
 # seconds of CPU time.
 #
 sub hamming {
   my $href = \1;		# Dummy reference
   my $hamming = 
       Stream->new(1, 
 	  sub { &merge($$href->scale(2),
 		       &merge($$href->scale(3),
 			      $$href->scale(5)
 			      ))
 		  }
           );
   $href = \$hamming;      # Reference is no longer a dummy
   $hamming;
 }
 
 # Rujith S. de Silva points out that the `dummy reference' hack
 # is unneccesary.  This version is easier to understand and probably
 # faster than the `hamming' above:
 #
 sub hamming_r {
   my $hamming;
   $hamming =
       Stream->new(1, 
 	  sub { &merge($hamming_r->scale(2),
 		&merge($hamming_r->scale(3),
 		       $hamming_r->scale(5)
 		       ))
 		  }
       );
 }
 
 sub squares_from {
   my $n = shift;
   print STDERR "SQUARES_FROM($n)\n" if $DEBUG;
   Stream->new($n*$n, 
 	      sub { &squares_from($n+1) });
 }
 
 # Hailstone number iterator
 sub next_hail {
   my $n = shift;
   ($n % 2 == 0) ? $n/2 : 3*$n + 1;
 } 
 
 # Return the Collatz 3n+1 sequence starting from n.
 sub hailstones {
   my $n = shift;
   &iterate(\&next_hail, $n);
 }
 
 
 # Example random number generator from ANSI C standard
 sub next_rand { int(($_[0] * 1103515245 + 12345) / 65536) % 32768 }
 
 # Stream of random numbers, seeded by $seed.
 sub rand { 
   my $seed = shift;
   &iterate(\&next_rand, &next_rand($seed));
 }
 
 # Auxiliary function for &iterate_chop
 sub iter_pairs {
   my $s = shift;
   my $ss = shift;
   return $s->empty if $s->is_empty;
   Stream->new([$s->head, $ss->head],
 	      sub {&iter_pairs($s->tail, $ss->tail->tail)}
 	);
 }
 
 # Given a stream of numbers generated by `iterate',
 # chop it off before it repeats.
 # Not guaranteed to do anything useful if applied to a stream that was
 # not produced by `iterate'
 sub iterate_chop {
    my $s = shift;
    return $s->empty if $s->is_empty;
    &iter_pairs($s, $s->tail)
        ->chop_when(sub {$_[0][0] == $_[0][1]})
 	   ->transform(sub {$_[0][0]});
 }
 
 
 
 # Given a regular list of values, produce a finite stream
 sub list2stream {
   return Stream->empty unless @_;
   my @list = @_;
   my $h = shift @list;
 #  print STDERR "list2stream @_\n"; 
   return Stream->new($h, sub{&list2stream(@list)});
 }
 
 ## Turn a stream into a regular Perl array
 ## Caution--only works on finite streams
 sub stream2list {
   my $s = shift;
   my @r;
   while (! $s->is_empty) {
     push @r, $s->head;
     $s = $s->tail;
   }
   @r;
 }
 
 
 ## Compute length of given stream
 sub length {
   my $s = shift;
   my $n = 0;
   while (! $s->is_empty) {
     $s = $s->tail;
     $n++;
   }
   $n;
 }
 
 1;
    

Оставьте свой комментарий !
Ваше имя: Комментарий: Оба поля являются обязательными  Автор   Комментарий к данной статье