Permalink
Fetching contributors…
Cannot retrieve contributors at this time
executable file 184 lines (138 sloc) 4.33 KB
#!/usr/bin/env perl
# Copyright (c) 2015 Christian Jaeger, copying@christianjaeger.ch
# This is free software. See the file COPYING.md that came bundled
# with this file.
use strict; use warnings; use warnings FATAL => 'uninitialized';
# find modules from functional-perl working directory (not installed)
use Cwd 'abs_path';
our ($mydir, $myname); BEGIN {
my $location= (-l $0) ? abs_path ($0) : $0;
$location=~ /(.*?)([^\/]+?)_?\z/s or die "?";
($mydir, $myname)=($1,$2);
}
use lib "$mydir/../lib";
use Chj::TEST use=> "PadWalker";
use FP::List ":all";
use FP::Ops ":all";
use FP::Lazy ":all";
use FP::Stream ":all";
use Chj::Backtrace;
use Chj::repl;
# fibs :: [Integer]
# fibs = 1:1:zipWith (+) fibs (tail fibs)
# fib n = fibs!!n
our $fibs; $fibs=
cons 1, cons 1, lazy { stream_zip_with \&add, Keep($fibs), rest $fibs };
sub fib {
my ($n)=@_;
stream_ref Keep($fibs), $n
}
# The above code creates the sequence only once per program run and
# then keeps it around in the $fibs global; there's no provision to
# set $fibs again thus it has to be protected with Keep() from being
# deleted. While this works, and is arguably efficient since multiple
# calls to fib() do not need to recalculate the stream, it also means
# that the whole stream up to the highest $n ever calculated are kept
# in memory until program exit.
# Here is an alternative definition that doesn't keep the stream tied
# to a global, but instead returns a fresh copy each time fibs() is
# called:
sub fibs {
my $fibs; $fibs=
cons 1, cons 1, lazy { stream_zip_with *add, $fibs, rest $fibs };
$fibs
}
# Note that while it creates a reference cycle, it won't leak, as the
# cycle is broken by stream_zip_with weakening its arguments, which we
# don't protect here (we do not use a Keep() wrapper).
# Here's a variant that relies on self-referencing the subroutine (a
# package variable) instead of mutating a lexical variable:
sub fibs2 {
cons 1, cons 1, lazy { my $fibs= fibs2 ();
stream_zip_with *add, $fibs, rest $fibs };
}
# But it's less efficient: it recalculates parts multiple times, as
# can be seen with CPU timings, or with the number of times that it
# calls *add; you can check for the latter by replacing *add with
# *addc and look at $addc before and after the calculation:
my $addc=0;
sub addc {
$addc++;
$_[0]+$_[1]
}
TEST { $addc=0; local *add=*addc; [fibs->ref(80), $addc] }
['37889062373143906', 79];
TEST { $addc=0; local *add=*addc; [fibs2->ref(80), $addc] }
['37889062373143906', 3160]; # 3160 == 79*80/2
TEST { stream_to_array stream_take Keep($fibs), 10 }
[
1,
1,
2,
3,
5,
8,
13,
21,
34,
55
];
TEST { fib 30 }
1346269;
TEST { fibs->ref(30) }
1346269;
TEST { fibs2->ref(30) }
1346269;
# ------------------------------------------------------------------
# Alright, so there are not only the stupidly slow naive recursive and
# the above widespread O(n) algorithm (as well as the fibs2 variant
# which is inbetween), but also better ones:
# http://www.nayuki.io/page/fast-fibonacci-algorithms
# Thus if we wanted something really fast, we'd diverge from standard
# examples and instead implement the following:
# http://www.nayuki.io/res/fast-fibonacci-algorithms/fastfibonacci.hs
# (we're adding this for completeness and some perspective on the
# topic of performance, not as a demo of functional-perl)
sub _fib {
my ($n)=@_;
($n == 0) ? (0, 1)
: do {
my ($a,$b)= _fib(int $n / 2);
my $c= $a * ($b * 2 - $a);
my $d= $a * $a + $b * $b;
($n % 2) == 0 ? ($c, $d)
: ($d, $c + $d)
};
}
sub _fibonacci {
my ($n)=@_;
($n >= 0) ? (_fib $n)[0] : die "n < 0";
}
sub fibonacci {
my ($n)=@_;
_fibonacci $n + 1
}
TEST { fibonacci 30 }
1346269;
# With bigger inputs:
# we're not using a bignum library, thus we're restricted by Perl's
# floating point range and precision.
use Chj::time_this;
my $a= lazy{time_this{ fib (1400) } "fib"};
my $b= lazy{time_this{ fibonacci (1400) } "fibonacci"};
TEST {
# Hack: stringify to drop invisible but different digits
FORCE($a).""
}
"2.7682097123729e+292";
TEST {
# same hack
$a."" == FORCE($b).""
}
1;
TEST {
# same as above but more properly:
abs(($a - $b) / $b) < 1e-14
}
1;
perhaps_run_tests "main" or repl;