Permalink
Browse files

import Memoize 0.03 from CPAN

git-cpan-module:   Memoize
git-cpan-version:  0.03
git-cpan-authorid: MJD
git-cpan-file:     authors/id/M/MJ/MJD/Memoize-0.03.tar.gz
  • Loading branch information...
1 parent 15b1846 commit f64745c6c8ee244612b96913a3a59fb2f21d0513 @mjdominus committed with schwern Feb 5, 1998
Showing with 240 additions and 27 deletions.
  1. +2 −0 MANIFEST
  2. +1 −1 Makefile.PL
  3. +57 −14 Memoize.pm
  4. +10 −12 demo.pl
  5. +116 −0 t/correctness.t
  6. +54 −0 t/speed.t
View
@@ -3,3 +3,5 @@ demo.pl
demo2.pl
Makefile.PL
MANIFEST
+t/correctness.t
+t/speed.t
View
@@ -1,7 +1,7 @@
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'Memoize',
- VERSION => '0.02',
+ VERSION => '0.03',
# 'linkext' => {LINKTYPE => ''},
'dist' => {COMPRESS => 'gzip', SUFFIX => 'gz'},
);
View
@@ -8,10 +8,10 @@
# same terms as Perl iteself. If in doubt, write to mjd@pobox.com
# for a license.
#
-# Version 0.02 alpha $Revision: 1.2 $ $Date: 1998/02/04 22:04:03 $
+# Version 0.03 alpha $Revision: 1.2 $ $Date: 1998/02/04 22:04:03 $
package Memoize;
-$VERSION = '0.02';
+$VERSION = '0.03';
=head1 NAME
@@ -198,7 +198,11 @@ Some day.
Memoization is not a cure-all:
-=item Do not memoize a function whose behavior depends on program
+=over 4
+
+=item *
+
+Do not memoize a function whose behavior depends on program
state other than its own arguments, such as global variables, the time
of day, or file input. These functions whill not produce correct
results when memoized. For a particularly easy example:
@@ -215,7 +219,9 @@ course, and the memoized version of this function will read STDIN once
to get a string from the user, and it will return that same string
every time you call it after that.
-=item Do not memoize a function with side effects.
+=item *
+
+Do not memoize a function with side effects.
sub f {
my ($a, $b) = @_;
@@ -231,7 +237,9 @@ expect the first time you ask it to prnit the sum of 2 and 3, but
subsequent calls will return the number 11 (the return value of
C<print>) without actually printing anything.
-=item Do not memoize a function that returns a data structure that is
+=item *
+
+Do not memoize a function that returns a data structure that is
modified by its caller.
Consider these functions: C<getusers> returns a list of users somehow,
@@ -261,13 +269,20 @@ this time the list has already had its head removed; C<main> will
erroneously remove another element from it. The list will get shorter
and shorter every time you call C<main>.
+
+=back
+
=head1 TO DO
=over 4
-=item There should be an C<unmemoize> function.
+=item *
+
+There should be an C<unmemoize> function.
-=item We should extend the benchmarking module to allow
+=item *
+
+We should extend the benchmarking module to allow
timethis(main, MEMOIZED => [ suba, subb ])
@@ -284,13 +299,32 @@ large effect on the performance of C<main>. But if there was a big
difference, you would know that C<suba> or C<subb> was a good
candidate for optimization if you needed to make C<main> go faster.
-=item There was some other stuff, but I forget.
+=item *
+
+There was some other stuff, but I forget.
+
+=item *
-=item Maybe a tied-hash interface to the memo-table, which a hook to
+Maybe a tied-hash interface to the memo-table, which a hook to
automatically populate an entry if no value is there yet?
=back
+=head1 AUTHOR
+
+=begin text
+Mark-Jason Dominus (C<mjd-perl-memoize@plover.com>), Plover Systems co.
+
+See the C<Memoize.pm> Page at http://www.plover.com/~mjd/perl/Memoize
+for news and upgrades.
+=end text
+
+=begin html
+<p>Mark-Jason Dominus (<a href="mailto:mjd-perl-memoize@plover.com"><tt>mjd-perl-memoize@plover.com</tt></a>), Plover Systems co.</p>
+<p>See <a href="http://www.plover.com/~mjd/perl/Memoize/">The <tt>Memoize.pm</tt> Page</a> for news and upgrades.</p>
+
+=end html
+
=cut
@@ -304,6 +338,7 @@ use Carp;
use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(memoize);
+use strict;
my %memotable;
@@ -312,20 +347,22 @@ sub memoize {
my $options = shift || {};
unless (defined($fn)) {
- croak "Usage: memoize functionname|coderef {OPTIONS}\n";
+ croak "Usage: memoize 'functionname'|coderef {OPTIONS}";
}
my $uppack = caller;
my $cref; # Code reference to original function
+ my $name;
- if (ref $fn eq CODE) {
+ if (ref $fn eq 'CODE') {
$cref = $fn;
} elsif (! ref $fn) {
if ($fn =~ /::/) {
$name = $fn;
} else {
$name = $uppack . '::' . $fn;
}
+ no strict;
$cref = *{$name}{CODE}; # Magic
} else {
croak "Usage: argument 1 to `memoize' must be a function name or reference.\n";
@@ -345,14 +382,16 @@ sub memoize {
MEMOS => { }, # Memo table
};
- $install_name = $options{INSTALL} || $name;
+ my $install_name = $options->{INSTALL} || $name;
if (defined $install_name) {
$install_name = $uppack . '::' . $install_name
unless $install_name =~ /::/;
+ no strict;
+ local($) = 0; # ``Subroutine $install_name redefined at ...''
*{$install_name} = $wrapper; # Install memoized version
}
- $cref; # Return memoized version
+ $wrapper; # Return memoized version
}
# This is the function that manages the memo tables.
@@ -364,11 +403,15 @@ sub _memoizer {
# We should probably do this at memoize time instead of at call time
unless (ref $normalizer) {
unless ($normalizer =~ /::/) {
+ no strict;
$normalizer = *{$info->{PACKAGE} . '::' . $normalizer}{CODE};
}
}
- my $argstr = &{$normalizer}(@_);
+ my $argstr;
+ { no strict;
+ $argstr = &{$normalizer}(@_);
+ }
if (exists $info->{MEMOS}{$argstr}) {
return $info->{MEMOS}{$argstr};
}
View
22 demo.pl 100644 → 100755
@@ -1,24 +1,18 @@
+#!/usr/bin/perl
use Memoize;
use Benchmark;
$CALLS = 0;
-my $a = shift;
+my $a = shift || 20;
-memoize('fibo2');
-
-timethese(100, unmemoized => sub { &
-sub fibo1 {
+sub fibo {
my ($n) = @_;
+ $CALLS++;
if ($n < 2) { return $n }
- &fibo1($n-1) + &fibo1($n-2);
+ &fibo($n-1) + &fibo($n-2);
}
-sub fibo2 {
- my ($n) = @_;
- $CALLS++;
- &fibo2($n-1) + &fibo2($n-2);
-}
$CALLS = 0;
$start = time;
@@ -39,4 +33,8 @@ sub fibo2 {
$elapsed3 = time - $start;
$CALLS3 = $CALLS;
-print "($CALLS1, $elapsed1) => ($CALLS2, $elapsed2) => ($CALLS3, $elapsed3)\n";
+print <<EOM;
+Unmemoized: $CALLS1 calls, $elapsed1 sec elapsed
+Memoized, first pass: $CALLS2 calls, $elapsed2 sec elapsed
+Memoized, second pass: $CALLS3 calls, $elapsed3 sec elapsed
+EOM
View
@@ -0,0 +1,116 @@
+#!/usr/bin/perl
+
+use lib '..';
+use Memoize;
+
+print "1..22\n";
+
+print "Basic\n";
+
+# A function that should only be called once.
+{ my $COUNT = 0;
+ sub no_args {
+ $FAIL++ if $COUNT++;
+ 11;
+ }
+}
+
+#
+memoize('no_args');
+
+$c1 = &no_args();
+print (($c1 == 11) ? "ok 1\n" : "not ok 1\n");
+$c2 = &no_args();
+print (($c2 == 11) ? "ok 2\n" : "not ok 2\n");
+print $FAIL ? "not ok 3\n" : "ok 3\n"; # Was it really memoized?
+
+$FAIL = 0;
+$f = do { my $COUNT = 0; sub { $FAIL++ if $COUNT++; 12 } };
+$fm = memoize($f);
+
+$c1 = &$fm();
+print (($c1 == 12) ? "ok 4\n" : "not ok 4\n");
+$c2 = &$fm();
+print (($c2 == 12) ? "ok 5\n" : "not ok 5\n");
+print $FAIL ? "not ok 6\n" : "ok 6\n"; # Was it really memoized?
+
+$f = do { my $COUNT = 0; sub { $FAIL++ if $COUNT++; 13 } };
+$fm = memoize($f, {INSTALL => 'another'});
+
+$c1 = &another(); # Was it really installed?
+print (($c1 == 13) ? "ok 7\n" : "not ok 7\n");
+$c2 = &another();
+print (($c2 == 13) ? "ok 8\n" : "not ok 8\n");
+print $FAIL ? "not ok 9\n" : "ok 9\n"; # Was it really memoized?
+$c3 = &$fm(); # Call memoized version through returned ref
+print (($c3 == 13) ? "ok 10\n" : "not ok 10\n");
+print $FAIL ? "not ok 11\n" : "ok 11\n"; # Was it really memoized?
+$c4 = &$f(); # Call original version again
+print (($c4 == 13) ? "ok 12\n" : "not ok 12\n");
+print $FAIL ? "ok 13\n" : "not ok 13\n"; # Did we get the original?
+
+print "Fibonacci\n";
+
+sub mt1 { # Fibonacci
+ my $n = shift;
+ return $n if $n < 2;
+ mt1($n-1) + mt2($n-2);
+}
+sub mt2 {
+ my $n = shift;
+ return $n if $n < 2;
+ mt1($n-1) + mt2($n-2);
+}
+
+@f1 = map { mt1($_) } (0 .. 15);
+@f2 = map { mt2($_) } (0 .. 15);
+memoize('mt1');
+@f3 = map { mt1($_) } (0 .. 15);
+@f4 = map { mt1($_) } (0 .. 15);
+@arrays = (\@f1, \@f2, \@f3, \@f4);
+$n = 13;
+for ($i=0; $i<3; $i++) {
+ for ($j=$i+1; $j<3; $j++) {
+ $n++;
+ print ((@{$arrays[$i]} == @{$arrays[$j]}) ? "ok $n\n" : "not ok $n\n");
+ $n++;
+ for ($k=0; $k < @{$arrays[$i]}; $k++) {
+ (print "not ok $n\n", next) if $arrays[$i][$k] != $arrays[$j][$k];
+ }
+ print "ok $n\n";
+ }
+}
+
+
+
+print "Normalizers\n";
+
+sub fake_normalize {
+ return '';
+}
+
+sub f1 {
+ return shift;
+}
+sub f2 {
+ return shift;
+}
+sub f3 {
+ return shift;
+}
+&memoize('f1');
+&memoize('f2', {NORMALIZER => 'fake_normalize'});
+&memoize('f3', {NORMALIZER => \&fake_normalize});
+@f1r = map { f1($_) } (1 .. 10);
+@f2r = map { f2($_) } (1 .. 10);
+@f3r = map { f3($_) } (1 .. 10);
+$n++;
+print (("@f1r" eq "1 2 3 4 5 6 7 8 9 10") ? "ok $n\n" : "not ok $n\n");
+$n++;
+print (("@f2r" eq "1 1 1 1 1 1 1 1 1 1") ? "ok $n\n" : "not ok $n\n");
+$n++;
+print (("@f3r" eq "1 1 1 1 1 1 1 1 1 1") ? "ok $n\n" : "not ok $n\n");
+
+print "$n tests in all.\n";
+
+
Oops, something went wrong.

0 comments on commit f64745c

Please sign in to comment.