# -*- Mode: Python -*-
# These are Pythonic ports of programs from MJD's HOP.
# Acme::Pythonic needs to know this prototype.
sub Iterator(&);
use Test::More 'no_plan';
use Acme::Pythonic debug => 0;
use strict
use warnings
my ($it, $computed, $expected)
#
# ---[ Chapter 1: Recursion ]-------------------------------------------
#
# This is hanoi() from page 9 plus a variation of check_move from pages
# 10 and 11 that constructs a list for testing instead of printing
# messages.
my @position = ('', ('A') x 3) # Disks are all initially on peg A
sub check_move:
my $i
my ($disk, $start, $end) = @_
if $disk < 1 || $disk > $#position:
die "Bad disk number $disk. Should be 1..$#position.\n"
unless $position[$disk] eq $start:
die "Tried to move disk $disk from $start, but it is on peg $position[$disk].\n"
for $i in 1 .. $disk-1:
if $position[$i] eq $start:
die "Can't move disk $disk from $start because $i is on top of it.\n"
elsif $position[$i] eq $end:
die "Can't move disk $disk to $end because $i is already there.\n"
push @$computed, [$disk, $start, $end]
$position[$disk] = $end
sub hanoi:
my ($n, $start, $end, $extra, $move_disk) = @_
if $n == 1:
$move_disk->(1, $start, $end)
else:
hanoi($n-1, $start, $extra, $end, $move_disk)
$move_disk->($n, $start, $end)
hanoi($n-1, $extra, $end, $start, $move_disk)
hanoi(3, 'A', 'C', 'B', \&check_move)
is_deeply($computed, [[1, 'A', 'C'],
[2, 'A', 'B'],
[1, 'C', 'B'],
[3, 'A', 'C'],
[1, 'B', 'A'],
[2, 'B', 'C'],
[1, 'A', 'C']])
#
# ---[ Chapter 4: Iterators ]-------------------------------------------
#
# Defined on page 121
sub upto:
my ($mx, $nx) = @_
return sub:
return $mx <= $nx ? $mx++ : undef
$it = upto 2, 5
my $n = 2
while defined(my $val = $it->()):
is $val, $n++
is $n, 6
# Defined on page 122
sub NEXTVAL:
$_[0]->()
# Defined on page 123
sub Iterator(&):
return $_[0]
# Defined on page 160
sub imap(&$):
my ($transform, $it) = @_
return Iterator:
local $_ = NEXTVAL($it)
return unless defined $_
return $transform->()
$it = imap:
$_ *= 2
$_ += 1
$_
upto(2, 5)
$expected = [5, 7, 9, 11]
$computed = []
while my $val = NEXTVAL($it):
push @$computed, $val
is_deeply $expected, $computed
# Defined on page 160
sub igrep(&$):
my ($is_interesting, $it) = @_
return Iterator:
local $_
while defined($_ = NEXTVAL($it)):
return $_ if $is_interesting->()
return
$it = igrep:
$_ % 2
upto(2, 11)
$expected = [3, 5, 7, 9, 11]
$computed = []
while my $val = NEXTVAL($it):
push @$computed, $val
is_deeply $expected, $computed
# Defined on page 136
sub make_genes:
my $pat = shift
my @tokens = split /[()]/, $pat
for my $i = 1; $i < @tokens; $i += 2:
$tokens[$i] = [0, split(//, $tokens[$i])]
my $FINISHED = 0
return Iterator:
return if $FINISHED
my $finished_incrementing = 0
my $result = ""
for my $token in @tokens:
if ref $token eq "": # plain string
$result .= $token
else: # wildcard
my ($n, @c) = @$token
$result .= $c[$n]
unless $finished_incrementing:
if $n == $#c:
$token->[0] = 0
else:
$token->[0]++
$finished_incrementing = 1
$FINISHED = 1 unless $finished_incrementing
return $result
my $seq = "A(CGT)CGT"
$expected = [qw(ACCGT AGCGT ATCGT)]
$computed = []
my $gene_iter = make_genes $seq
while my $g = NEXTVAL($gene_iter):
push @$computed, $g
is_deeply($expected, $computed)
$seq = "A(CT)G(AC)"
$expected = [qw(ACGA ATGA ACGC ATGC)]
$computed = []
$gene_iter = make_genes $seq
while my $g = NEXTVAL($gene_iter):
push @$computed, $g
is_deeply($expected, $computed)
$seq = "(abc)(de)-(12)"
$expected = [qw(ad-1 bd-1 cd-1 ae-1 be-1 ce-1 ad-2 bd-2 cd-2 ae-2 be-2 ce-2)]
$computed = []
$gene_iter = make_genes $seq
while my $g = NEXTVAL($gene_iter):
push @$computed, $g
is_deeply($expected, $computed)
#
# --- [ Chapter 5: From Recursion to Iterators ] -----------------------
#
# Defined on page 210, with a fix for boundary conditions from page 211.
sub make_partitioner:
my ($n, $treasures) = @_
my @todo = $n ? [$n, $treasures, []] : [$n, [], []]
sub:
while @todo:
my $cur = pop @todo
my ($target, $pool, $share) = @$cur
my ($first, @rest) = @$pool
push @todo, [$target, \@rest, $share] if @rest
if $target == $first:
return [@$share, $first]
elsif $target > $first && @rest:
push @todo, [$target-$first, \@rest, [@$share, $first]]
return undef
my $mp = make_partitioner(5, [1, 2])
$expected = []
$computed = []
while my $p = NEXTVAL($mp):
push @$computed, $p
is_deeply($expected, $computed)
$mp = make_partitioner(5, [1, 2, 3])
$expected = [[2, 3]]
$computed = []
while my $p = NEXTVAL($mp):
push @$computed, $p
is_deeply($expected, $computed)
# Defined on pages 252-253.
sub fib:
my $n = shift
my ($s1, $return)
my $BRANCH = 0
my @STACK
while 1:
if $n < 2:
$return = $n
else:
if $BRANCH == 0:
push (@STACK, [ 1, 0, $n ]), $n -= 1 while $n >= 2
$return = $n
elsif $BRANCH == 1:
push @STACK, [ 2, $return, $n ]
$n -= 2
$BRANCH = 0
next
elsif $BRANCH == 2:
$return += $s1
return $return unless @STACK
($BRANCH, $s1, $n) = @{pop @STACK}
is fib(0), 0
is fib(1), 1
is fib(10), 55
is fib(21), 10946