gmane.comp.lang.perl.qotw.discuss

[QUIZ] Perl 'Hard' Quiz of the Whatever #2008-03-28 - Solving Kakuro

Shlomi Fish — 2008-03-27T22:38:08

IMPORTANT: Please do not post solutions, hints, or other spoilers until at least 60 hours after the date of this message. Thanks. Kakuro (a.k.a Cross-sums) is a kind of puzzle game: http://en.wikipedia.org/wiki/Kakuro In it, one fills in squares in a crossword-like grid that sum to their sums. One can fill in the digits from 1 to 9, and no digit can be repeated twice. Your object is that given a Kakuro board in a text format described below, then output the final solution. You can find some sample layouts from kakuro.com here: http://www.shlomifish.org/Files/files/text/kakuro.com-layouts/ and there's a new daily puzzle everyday there. (Requires Flash) There are also some more layouts googleable or on the wikipedia page. The layout has the following format: 1. It consists of $Height lines. 2. Each line has $Width squares. Whitespace inside each line is ignored. 3. Each square starts with [ and ends with ]. 4. A square that contains a \ is a blocked square (i.e: a square that cannot have any digit). If a number appears to the left of the \ it is the sum of the digits below the square. If a number appears to the right of the \ it is the sum of the digits to the right of the square. 5. A square that contains a single digit is filled with this digit. Such digits may be used in the solutions or for hints. ------------------- The examples on http://www.shlomifish.org/Files/files/text/kakuro.com-layouts/ should be the most illustrative. The output should be the same with all the non-blocked square containing digits. Bonus points for: 1. Intermediate solutions. 2. Reasonings. Good luck! Shlomi Fish --------------------------------------------------------------------- Shlomi Fish shlomif-ik1l9ssToec+JF/nGntIXQ< at >public.gmane.org Homepage: http://www.shlomifish.org/ I'm not an actor - I just play one on T.V.

Re: [QUIZ] Perl 'Medium' Quiz of the Whatever #2008-02-28 - Kakuro Digit Sums

Martijn Lievaart — 2008-03-07T08:34:14

[ Haven't got the original mail, so piggying here ] "Any programming problem can be solved by adding another layer of indirection". Here's my solution. Run this program to produce a program which satisfies the requirements. I also expect this solution to be the fastest around.... :-) Regards, M4 #!/usr/bin/perl use strict; use warnings; sub get_digits_sum { my ($sum, $num_places) = < at >_; return [solve($sum, $num_places, 0, 0)]; } sub solve { my ($sum, $places_left, $running, $previous, < at >partial) = < at >_; return map solve($sum, $places_left-1, $running+$_, $_, < at >partial, $_), ($previous+1..($sum - $running > 9 ? 9 : $sum - $running)) if $places_left; return $sum == $running ? [< at >partial] : (); } print <<'EOT'; #!/usr/bin/perl use strict; use warnings; use Test::More tests => 8; my %sol = ( EOT use Data::Dumper; for my $sum (1..45) { print "$sum => {\n"; for my $places (1..9) { my $answer = get_digits_sum($sum, $places); if (< at >$answer) { print " $places => \n"; my $t = Dumper($answer); $t =~ s/\$VAR1\s*=\s*/\t/; $t =~ s/;/,/; print "$t\n"; } } print "},\n\n"; } print <<'EOT'; ); sub get_digits_sum { my ($sum, $num_places) = < at >_; return exists $sol{$sum} && exists $sol{$sum}{$num_places} ? $sol{$sum}{$num_places} : []; } my < at >tests = ( [5,1, [[5]], "5 over 1"], [15,1, [], "15 over 1"], [3,2, [[1,2]], "3 over 2"], [7,3, [[1,2,4]], "7 over 3"], [15,5, [[1,2,3,4,5]], "15 over 5"], [25,5, [ [1,2,5,8,9], [1,2,6,7,9], [1,3,4,8,9], [1,3,5,7,9], [1,3,6,7,8], [1,4,5,6,9], [1,4,5,7,8], [2,3,4,7,9], [2,3,5,6,9], [2,3,5,7,8], [2,4,5,6,8], [3,4,5,6,7], ], "25 over 5", ], [14,2, [[5,9],[6,8],], "14 over 2",], [99,2, [], "99 over 2",], ); for (< at >tests) { my ($sum, $digits, < at >x) = < at >$_; my $got = get_digits_sum($sum, $digits); is_deeply($got, < at >x); } EOT

Re: [QUIZ] Perl 'Medium' Quiz of the Whatever #2008-02-28 - Kakuro Digit Sums

Greg Bacon — 2008-03-06T14:44:52

In Haskell, FWIW: get_digits_sum _ 0 = [] get_digits_sum 0 _ = [] get_digits_sum goal n = find goal n [1..9] where find _ _ [] = [] find goal n (d:ds) | n == 1 && d == goal = [[d]] | otherwise = with ++ find goal n ds where with = map (d:) $ find (goal - d) (n - 1) ds Greg

Re: [QUIZ] Perl 'Medium' Quiz of the Whatever #2008-02-28 - Kakuro Digit Sums

2008-03-06T10:05:11

Here's my solution. It, too, is recursive, but unlike M. Fish's, I've used a secondary accumulator parameter. -- michael. -- #!perl use strict; sub get_digits_sum { my ($sum, $left, $soln, < at >ns) = < at >_; return if $sum == 0; return [get_digits_sum($sum, $left, [], 1..9)] if !defined $soln; return (grep {$sum==$_} < at >ns) ? [< at >$soln, $sum] : () if $left == 1; my < at >rv; for my $n (< at >ns) { return < at >rv if $n > $sum; # rest won't work either push < at >rv, get_digits_sum($sum-$n, $left-1, [< at >$soln, $n], ($n+1)..9); } return < at >rv; } my ($sum, $places) = < at >ARGV; my $rv = get_digits_sum($sum, $places); print join " ", < at >$_, "\n" for < at >$rv;

Re: [QUIZ] Perl 'Medium' Quiz of the Whatever #2008-02-28 - KakuroDigit Sums

Premysl Anydot Hruby — 2008-03-03T17:25:03

my recursive solution: 8<----8< #!/usr/bin/perl use warnings; use strict; use Data::Dumper; sub get_digits_sum { my ($sum, $num, $start) = < at >_; my $max = ($sum < 10 ? $sum : 9); $start = 1 unless $start; return [] unless $num; return [] if $sum <= 0; return [] if $max < $start; return [[$sum]] if $num == 1; my < at >result; for my $current ($start..$max) { push < at >result, map [$current, < at >$_], < at >{get_digits_sum($sum - $current, $num - 1, $current + 1)}; } return \< at >result; } die ("run with sum and number of cell's") unless < at >ARGV == 2; print Dumper(get_digits_sum(< at >ARGV)); 8<----8<

Re: [QUIZ] Perl 'Medium' Quiz of the Whatever #2008-02-28 - Kakuro Digit Sums

Shlomi Fish — 2008-03-03T15:04:36

Here is my solution, which is recursive: <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< use strict; use warnings; use Test::More tests => 5; my $max_digit = 9; my $min_digit = 1; sub _digits_sum_from { my ($start, $sum, $num_places) = < at >_; if ($num_places == 1) { if (($sum >= $start) && ($sum <= $max_digit)) { return [[$sum]]; } else { return []; } } my < at >results; FIRST_LOOP: foreach my $first ($start .. $max_digit) { if ($sum-$first <= 0) { last FIRST_LOOP; } push < at >results, (map { [$first,< at >$_] } < at >{_digits_sum_from($first+1, $sum-$first, $num_places-1)} ); } return \< at >results; } sub get_digits_sum { my ($sum, $num_places) = < at >_; return _digits_sum_from($min_digit, $sum, $num_places); } # TEST is_deeply(get_digits_sum(3,2), [[1,2]], "3 over 2"); # TEST is_deeply(get_digits_sum(7,3), [[1,2,4]], "7 over 3"); # TEST is_deeply(get_digits_sum(15,5), [[1,2,3,4,5]], "15 over 5"); # TEST is_deeply(get_digits_sum(25,5), [ [1,2,5,8,9], [1,2,6,7,9], [1,3,4,8,9], [1,3,5,7,9], [1,3,6,7,8], [1,4,5,6,9], [1,4,5,7,8], [2,3,4,7,9], [2,3,5,6,9], [2,3,5,7,8], [2,4,5,6,8], [3,4,5,6,7], ], "25 over 5", ); # TEST is_deeply(get_digits_sum(14,2), [[5,9],[6,8],], "14 over 2",); --------------------------------------------------------------------- Shlomi Fish shlomif-ik1l9ssToec+JF/nGntIXQ< at >public.gmane.org Homepage: http://www.shlomifish.org/ I'm not an actor - I just play one on T.V.

Re: [QUIZ] Perl 'Hard' Quiz of the Whatever #2008-12-28 - Symmetric Sokoban

Ron Isaacson — 2008-01-06T04:17:12

Oops, and I found a bug in that logic. It's not just an optimization; some kind of state cache is necessary to avoid just pushing the same block back and forth forever. However, the cache currently ignores the position of the player. THAT is an optimization; given these two boards: A) ####### B) ####### # # # # # $ $ # # $ # # ### # $ ### # ..# # ..# ######### ######### There are multiple sets of pushes that will get you from A to B, and no reason to try more than one set that gets you to the same result. No matter where the player is once you've entered state B, the possible future moves from there are all the same. HOWEVER, if you take blocking into account: C) ##### D) ##### # # # # # #$# # #$# # # ### # # ### # $< at >..# #< at >$ ..# ####### ####### States C and D are NOT equivalent -- one is solvable, and one isn't! So if you ignore the position of the player entirely, that leads to some valid (and possibly essential) moves being ignored. I tried a quick fix, to add the player position to the state cache, but that adds an order of magnitude to both the time and the number of pushes in the solution. What you really want is to consider C above equivalent to E below: E) ##### # # # #$# # #< at >### # $ ..# ####### because the available pushes from there are the same, but you don't want to consider C or E equivalent to D. -- Ron Isaacson Morgan Stanley ron.isaacson-/PgpppG8B+R7qynMiXIxWgC/G2K4zDHf< at >public.gmane.org / (212) 276-1144

Re: [QUIZ] Perl 'Hard' Quiz of the Whatever #2008-12-28 - Symmetric Sokoban

Ron Isaacson — 2008-01-06T02:47:10

[NB: Sorry if anyone is getting multiple copies of this. The mail server seems to keep rejecting my mail due to attachment content type, so the program is now included in the message.] Jurgen Pletinckx wrote: Same here, on both counts. :-) I just finished mine, and haven't looked at either of the two posted solutions yet, so I'm not sure how they compare. My general approach is pretty simple: - Find all valid pushes from the current spot - For each push: - Do it - Recurse - If the puzzle is solved, exit - Undo it The puzzle is always stored and used as a list of lists, with $puzzle->[$row]->[$col] containing the actual ASCII character, and it's never converted into any other representation. Nor is it ever rotated or transformed in any other way (other than making moves & then reversing them). The "find all valid pushes" piece was easier than I originally made it out to be. I eventually settled on a non-recursive version of the "flood fill" algorithm to radiate outward from the current point, looking for all spots from which a box can be pushed, and storing the path I took to get to each one. I currently make no attempt to minimize either the number of pushes or the total number of moves. My program is guaranteed to find a solution if one exists, but it will almost definitely not be the minimal solution. It also moves in a predictable order (left/right/up/down), and will find the same solution every time, unless given the -r command-line option (to randomize moves). There are a few minor optimizations made at each step, like not putting the puzzle into any state it's been in before, and not going any further once the puzzle has been made unsolveable. Determining "solvable" is where the real speed gains can be made. My test is fairly simple -- just make sure each box has a position from which it can be pushed. A more comprehensive approach would be to test for all of the "trap" positions under SOKOBAN'S IMPOSSIBLE MOVES at: http://www.geocities.com/erimsever/sokoban1.htm This would allow entire move sets to be pruned fairly quickly. Anyway, code is below, with copious comments throughout. It supports a few command-line arguments, mostly related to the display. If you watch it move (the default), you'll see lots of unsolveable positions it gets itself into, especially in -r mode. Run with -q (the fastest option), it solves the given puzzle in about 7.2 seconds on my 3.4 GHz Linux desktop. But it takes 1192 moves / 352 pushes, which can definitely be reduced. Just to make sure it worked, I also ran puzzle #1 from the "standard" collection: ##### # # #$ # ### $## # $ $ # ### # ## # ###### # # ## ##### ..# # $ $ ..# ##### ### #< at >## ..# # ######### ####### It finished this one in 2.65s, using 432 moves / 161 pushes. For fun, I tried puzzle #2 from that collection: ############ #.. # ### #.. # $ $ # #.. #$#### # #.. < at > ## # #.. # # $ ## ###### ##$ $ # # $ $ $ $ # # # # ############ But after about 12 hours, I Ctrl-C'ed it. :-) I think the additional "unsolvable" conditions would need to be added to solve this one in a reasonable amount of time. -- Ron Isaacson Morgan Stanley ron.isaacson-/PgpppG8B+R7qynMiXIxWgC/G2K4zDHf< at >public.gmane.org / (212) 276-1144 -----8<-----8<-----8<-----8<-----8<-----8<-----8<-----8<-----8<-----8<----- #!/usr/bin/perl use strict; use Getopt::Long; use POSIX; use Term::Cap; use Time::HiRes qw(time sleep); use List::Util qw(shuffle); # Constants our ($LEFT, $RIGHT, $UP, $DOWN) = (-1, 1, -2, 2); our ($WALL, $BOX, $TARGET, $FTARGET, $PLAYER, $EMPTY) = split //, '#$.X< at > '; our %MOVE = ( $LEFT => 'l', $RIGHT => 'r', $UP => 'u', $DOWN => 'd', ); # Globals our $TERM; our $QUIET = 0; our $DELAY = 0.1; our $RANDOM = 0; ###### ## ## Terminal control ## ###### sub init_term { # From Term::Cap docs my $termios = POSIX::Termios->new; $termios->getattr; my $ospeed = $termios->getospeed; $TERM = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed }; $TERM->Trequire (qw(UP md me)); } sub move_up { my ($lines) = < at >_; print $TERM->Tgoto ('UP', undef, $lines); } sub highlight { my ($char) = < at >_; return ($TERM->Tputs ('md') . $char . $TERM->Tputs ('me')); } ###### ## ## Puzzle management ## ###### # Read puzzle from file sub read_puzzle { my ($file) = < at >_; my $puzzle = []; open FILE, $file or return; while () { chomp; push < at >$puzzle, [split //, $_]; } close FILE; return $puzzle; } # Find player's initial position sub starting_point { my ($puzzle) = < at >_; for my $row (0..$#{$puzzle}) { for my $col (0..$#{$puzzle->[$row]}) { if ($puzzle->[$row]->[$col] eq $PLAYER) { $puzzle->[$row]->[$col] = $EMPTY; return ($row, $col); } } } return; } # Make sure puzzle has enough targets for all of the free boxes sub has_enough_targets { my ($puzzle) = < at >_; my %count; for my $row (0..$#{$puzzle}) { for my $col (0..$#{$puzzle->[$row]}) { $count{$puzzle->[$row]->[$col]}++; } } return ($count{$TARGET} >= $count{$BOX}); } # String representation of puzzle's current state sub puzzle_state { my ($puzzle) = < at >_; my $state = join "\n", map { join "", < at >$_ } < at >$puzzle; return $state; } # Check to see if the puzzle is solved sub puzzle_solved { my ($puzzle) = < at >_; for my $row (0..$#{$puzzle}) { for my $col (0..$#{$puzzle->[$row]}) { return if $puzzle->[$row]->[$col] eq $TARGET; } } return 1; } # Display puzzle, possibly including the current number of pushes # (stack depth) on the first line, then reposition the cursor at the # top for a redisplay sub show_puzzle { my ($puzzle, $player_row, $player_col, $pushes) = < at >_; for my $row (0..$#{$puzzle}) { my $line; for my $col (0..$#{$puzzle->[$row]}) { $line .= (($row == $player_row and $col == $player_col) ? $PLAYER : $puzzle->[$row]->[$col]); } # Draw boxes & targets in bold to make them stand out $line =~ s|([$BOX$TARGET$FTARGET]+)|highlight ($1)|ge; if ($row == 0) { $line .= sprintf " %-10d", $pushes if $pushes; } print "$line\n"; } move_up (scalar < at >$puzzle); } # Move the cursor back down to the bottom of the puzzle, show a # message and exit sub final_msg { my ($puzzle, $msg, $code) = < at >_; print "\n" x scalar < at >$puzzle; print "\n$msg\n\n"; exit $code; } ###### ## ## Motion ## ###### # Position state checks sub is_pushable { $_[0] eq $BOX or $_[0] eq $FTARGET } sub is_occupiable { $_[0] eq $EMPTY or $_[0] eq $TARGET } # Make sure we don't leave the puzzle. The playing area should be # surrounded by walls, but we never actually verify that. sub out_of_bounds { my ($puzzle, $row, $col) = < at >_; return ($row < 0 or $row >= $#{$puzzle} or $col < 0 or $col >= $#{$puzzle->[$row]}); } # Get the piece at a certain spot sub get_piece { my ($puzzle, $row, $col) = < at >_; return (out_of_bounds ($puzzle, $row, $col) ? undef : $puzzle->[$row]->[$col]); } # Given a starting point and a direction, find the next two pieces in # that direction. Return the row/column index and the current piece in # each position. sub move_data { my ($puzzle, $row, $col, $move) = < at >_; my ($row1, $col1); my ($row2, $col2); # If the move is 2 or -2, we're going vertically, otherwise # horizontally if ($move % 2 == 0) { my $nmove = $move / 2; $row1 = $row + $nmove; $col1 = $col; $row2 = $row + ($nmove * 2); $col2 = $col; } else { $row1 = $row; $col1 = $col + $move; $row2 = $row; $col2 = $col + ($move * 2); } my $piece1 = get_piece ($puzzle, $row1, $col1); my $piece2 = get_piece ($puzzle, $row2, $col2); return ($row1, $col1, $piece1, $row2, $col2, $piece2); } # Check to see if a certain move would result in a valid box push sub can_push { my ($puzzle, $row, $col, $move) = < at >_; my ($row1, $col1, $piece1, $row2, $col2, $piece2) = move_data ($puzzle, $row, $col, $move); # The piece must be pushable, and the spot it's going must be # occupiable return (is_pushable ($piece1) and is_occupiable ($piece2)); } # Check to see if a box is "stuck", meaning that it can never be # pushed sub is_stuck { my ($puzzle, $row, $col) = < at >_; # If a box can be pushed now, then it's not stuck and we're done. # But if a box is blocked in by other boxes, then it's only stuck if # all of those boxes are stuck too. Otherwise a push on one of those # might make this one on-stuck. # # We'll use a standard "flood-fill" algorithm to efficiently find # all boxes touching the current box. As soon as we find one that's # pushable, we're done. my < at >queue; my %seen; push < at >queue, [$row, $col]; while (< at >queue) { my $next = shift < at >queue; my ($row, $col) = < at >$next; # Mark the boxes we've already checked so we don't go backwards $seen{$row,$col} = $WALL; # Go one spot in each direction, and see if the box can be pushed # from there for my $move ($LEFT, $RIGHT, $UP, $DOWN) { my ($row1, $col1) = move_data ($puzzle, $row, $col, $move); my $piece1 = $seen{$row1,$col1} || $puzzle->[$row1]->[$col1]; # To push back on the piece we just left, we'll try the OPPOSITE # move of the one we made to get here, which is easily done by # negating $move return if (is_occupiable ($piece1) and can_push ($puzzle, $row1, $col1, -$move)); push < at >queue, [$row1, $col1] if ($piece1 eq $BOX); } } # We can't push this box or any of its neighbors, so it must be # stuck return 1; } # Check to ensure the puzzle is solvable sub is_solvable { my ($puzzle) = < at >_; # If there are any stuck boxes (see above), the puzzle is unsolvable for my $row (0..$#{$puzzle}) { for my $col (0..$#{$puzzle->[$row]}) { next unless ($puzzle->[$row]->[$col] eq $BOX); return if is_stuck ($puzzle, $row, $col); } } # Note that this doesn't guarantee that the puzzle is solvable -- # there are still other conditions that can make it unsolvable. # Adding more checks will probably make the program faster. return 1; } # Find all pushes that can be made from the current position sub find_pushes { my ($puzzle, $row, $col) = < at >_; # We're starting out in empty space, and looking for all of the # reachable positions from which a box can be pushed. As in # is_stuck, we'll use the "flood-fill" algorithm to find all # neighboring empty space, and in each position, check all four # directions to see if there's a pushable box in that direction. # # Unlike in is_stuck, we're building up a list of ALL pushes we can # make from here, so don't stop until we've searched all reachable # empty space. # # While we're at it, we'll build up a path to each push, which will # allow us to present a complete set of moves at the end. # # Note that neither the set of pushes nor the set of moves is likely # to be minimal. The set of moves could be reduced by applying # Dijkstra's algorithm on the empty space maps once the exact set of # pushes is found. my < at >pushes; my < at >queue; my %seen; push < at >queue, [$row, $col]; while (< at >queue) { my $next = shift < at >queue; my ($row, $col, < at >prev) = < at >$next; # Mark the spaces we've already been to so we don't go backwards $seen{$row,$col} = $WALL; # In each direction, we might find a box we can push, or more # empty space we can walk into my < at >moves = ($LEFT, $RIGHT, $UP, $DOWN); < at >moves = shuffle < at >moves if $RANDOM; for my $move (< at >moves) { # Can we push in this direction? push < at >pushes, [$row, $col, $move, < at >prev] if can_push ($puzzle, $row, $col, $move); # Can we walk in this direction? my ($row1, $col1) = move_data ($puzzle, $row, $col, $move); my $piece1 = $seen{$row1,$col1} || $puzzle->[$row1]->[$col1]; push < at >queue, [$row1, $col1, < at >prev, $move] if is_occupiable ($piece1); } } return < at >pushes; } # Try to push a box. If successful, return the new position (and a way # to undo the push, which we'll need later) -- otherwise return # nothing. # # Note that we assume all moves we're given have already passed the # can_push test, so we're looking for other conditions that would make # this push invalid. sub do_push { my ($puzzle, $states, $row, $col, $move) = < at >_; my ($row1, $col1, $piece1, $row2, $col2, $piece2) = move_data ($puzzle, $row, $col, $move); # Push the box first, and undo it later if something goes wrong $puzzle->[$row1]->[$col1] = $piece1 eq $FTARGET ? $TARGET : $EMPTY; $puzzle->[$row2]->[$col2] = $piece2 eq $TARGET ? $FTARGET : $BOX; my $undo = sub { $puzzle->[$row1]->[$col1] = $piece1; $puzzle->[$row2]->[$col2] = $piece2; }; # Make sure we didn't just make the puzzle unsolveable unless (is_solvable ($puzzle)) { $undo->(); return; } # The puzzle should be in a new state that it hasn't been in before. # Otherwise, we might just push one box back and forth forever. my $state = puzzle_state ($puzzle); if (exists $states->{$state}) { $undo->(); return; } # Ok, push successful return ($row1, $col1, $undo); } ###### ## ## Solver ## ###### # Recursive solver sub solve_recursive { my ($puzzle, $row, $col, $states, $pushes) = < at >_; # Simple brute-force algorithm: # # - Find all valid pushes from the current spot # - For each push: # - Do it # - Recurse # - Undo it my < at >available_pushes = find_pushes ($puzzle, $row, $col); for my $push (< at >available_pushes) { my ($row, $col, $move, < at >prev) = < at >$push; my ($new_row, $new_col, $undo) = do_push ($puzzle, $states, $row, $col, $move) or next; push < at >$pushes, $push; # Save the state, to make sure we don't end up back here again my $state = puzzle_state ($puzzle); $states->{$state} = 1; # Check to wee if we're done my $solved = puzzle_solved ($puzzle); if ($solved or not $QUIET) { show_puzzle ($puzzle, $new_row, $new_col, scalar < at >$pushes); return 1 if $solved; sleep $DELAY if $DELAY; } # Down we go... solve_recursive ($puzzle, $new_row, $new_col, $states, $pushes) and return 1; # Oops, didn't work out pop < at >$pushes; $undo->(); } return; } # Entry point sub solve_puzzle { my ($puzzle, $row, $col) = < at >_; my $states = {}; my $pushes = []; my $start = time; my $solved = solve_recursive ($puzzle, $row, $col, $states, $pushes); my $end = time; return unless $solved; return (1, $end - $start, $pushes); } # Create a complete list of moves from a list of pushes sub list_moves { my (< at >pushes) = < at >_; my < at >moves; for my $push (< at >pushes) { my ($row, $col, $move, < at >prev) = < at >$push; push < at >moves, map { $MOVE{$_} } < at >prev; push < at >moves, uc $MOVE{$move}; } return < at >moves; } ############################################################################### my $usage = <] [-r] puzzlefile -q Quick mode -- don't show solutions in progress -d Sleep for seconds between frames (0 or decimal ok) -r Move randomly, instead of always left/right/up/down USAGE GetOptions ( 'q' => \$QUIET, 'd=s' => \$DELAY, 'r' => \$RANDOM, ) or die $usage; my $puzzle_file = shift or die $usage; init_term; my $puzzle = read_puzzle ($puzzle_file) or die "Error reading $puzzle_file: $!\n"; is_solvable ($puzzle) or die "Puzzle started out unsolvable\n"; has_enough_targets ($puzzle) or die "Puzzle doesn't contain enough targets\n"; my ($row, $col) = starting_point ($puzzle) or die "Puzzle contains no starting point\n"; show_puzzle ($puzzle, $row, $col); my ($solved, $time, $pushes) = solve_puzzle ($puzzle, $row, $col); if (not $solved) { final_msg ($puzzle, "No solution found", 1); } my < at >moves = list_moves (< at >$pushes); my $result = sprintf ("Solved in %d pushes (%d moves), %.2fs\n", scalar < at >$pushes, scalar < at >moves, $time); while (my < at >line = splice < at >moves, 0, 70, ()) { $result .= "\n"; $result .= join "", < at >line; } final_msg ($puzzle, $result, 0);

Re: [QUIZ] Perl 'Hard' Quiz of the Whatever #2008-12-28 - Symmetric Sokoban

Shlomi Fish — 2008-01-04T17:13:16

Hi all! OK, my complete solution to the QOTW can be found here: http://www.shlomifish.org/Files/files/code/perl/qotw/Shlomif-Sokoban-Solver-0.01.tar.gz It includes some tests (though, not for the solving algorithm itself), a module and some tests. My scheme was: 1. Store the board as a vector of 2-bits, and the states as 2 bits (locations of the boxes and the space accessible to the player). vec() was used for the bit-fiddling. 2. Make use of the symmetry by only storing and looking up the least-valued rotated board. This makes it unsuitable for general Sokoban solutions, at least until I adapt the code to detect a possible symmetry. 3. Use a BFS search to find the solution, and a BFS search to find the accessible places for a player to go. ------------------ There's still room for many optimisations and many dead ends are not detected soon enough. The program runs in just under two minutes on my Mandriva Cooker system on a P4-2.4GHz machine. I'm including here the code of my main module which implements almost all of the logic of the solver. Regards, Shlomi Fish <<<<<<<<<<<<<<<<<<<<<<<<< package Shlomif::Sokoban::Solver::Board; use strict; use warnings; =head1 NAME Shlomif::Sokoban::Solver::Board - a board for the sokosolver. =head1 SYNOPSIS For internal use by the Sokoban solver. See the test files. =cut use List::Util qw(max); use Object::Tiny qw/ height width _collect _data _dests _init_state _queue /; my $dest_place_bits = 0x1; my $wall_bits = 0x2; my $box_bits = 0x1; my $reachable_bits = 0x2; =head1 METHODS =head2 load($board) Loads a board in standard Sokoban notation. =cut sub _calc_offset { my ($self, $x, $y) = < at >_; return $y*$self->width()+$x; } sub load { my ($pkg, $contents) = < at >_; # Remove trailing whitespace. $contents =~ s{(\s*\n)+\z}{}ms; # Remove trailing whitespace from lines. $contents =~ s{\s+$}{}gms; my < at >lines = (map { [ split(//, $_) ] } split(/\n/, $contents)); my $data = ""; my $init_state = ""; my $init_pos; my $self = $pkg->new( height => scalar(< at >lines), width => max(map { scalar(< at >$_) } < at >lines), _data => \$data, _dests => [], _init_state => \$init_state, _collect => +{}, _queue => [], ); foreach my $y (0 .. $#lines) { my $l = $lines[$y]; foreach my $x (0 .. $#$l) { my $offset = $self->_calc_offset($x, $y); # Initialise the init_state block to the default. vec($init_state, $offset, 2) = 0; if ($l->[$x] eq "#") { vec(${$self->_data()}, $offset, 2) = $wall_bits; } elsif ($l->[$x] eq ".") { vec(${$self->_data()}, $offset, 2) = $dest_place_bits; push < at >{$self->_dests()}, [$x, $y]; } else { vec(${$self->_data()}, $offset, 2) = 0; if ($l->[$x] eq '$') { vec($init_state, $offset, 2) = $box_bits; } elsif ($l->[$x] eq '< at >') { $init_pos = [$x, $y]; } } } } if (!defined($init_pos)) { die "The initial position of the player was not defined."; } $self->_mark_reachable(\$init_state, < at >$init_pos); return $self; } =head2 $board->is_wall($x,$y) Returns if the block at the position $x,$y is a wall. =cut sub is_wall { my ($self, $x, $y) = < at >_; return (vec(${$self->_data()}, $self->_calc_offset($x,$y), 2) == $wall_bits); } =head2 $board->is_dest($x,$y) Returns if the block at the position $x,$y is a destination block. =cut sub is_dest { my ($self, $x, $y) = < at >_; return (vec(${$self->_data()}, $self->_calc_offset($x,$y), 2) == $dest_place_bits ); } =head2 $board->is_box($s_ref, $x, $y) Is ($x,$y) in the state referenced by $s_ref a box? =cut sub is_box { my ($self, $s_ref, $x, $y) = < at >_; return (vec($$s_ref, $self->_calc_offset($x,$y), 2) == $box_bits); } =head2 $board->is_reachable($s_ref, $x, $y) Is ($x,$y) in the state referenced by $s_ref reachable by the player? =cut sub is_reachable { my ($self, $s_ref, $x, $y) = < at >_; return (vec($$s_ref, $self->_calc_offset($x,$y), 2) == $reachable_bits); } sub _mark_reachable { my ($self, $s_ref, $start_x, $start_y) = < at >_; # Breadth-first search to find all the reachable positions in the board. my < at >to_check =([$start_x, $start_y]); while (my $pos = shift(< at >to_check)) { # Mark as reachable. vec($$s_ref, $self->_calc_offset(< at >$pos), 2) = $reachable_bits; foreach my $offset ([-1,0],[1,0],[0,-1],[0,1]) { my < at >new_pos = ($pos->[0]+$offset->[0], $pos->[1]+$offset->[1]); if ( ($new_pos[0] >= 0) && ($new_pos[1] >= 0) && ($new_pos[0] < $self->width()) && ($new_pos[1] < $self->height()) && (! $self->is_wall(< at >new_pos)) && (! $self->is_box($s_ref, < at >new_pos)) && (! $self->is_reachable($s_ref, < at >new_pos)) ) { push < at >to_check, \< at >new_pos; } } } return; } sub _rotate { my ($self, $s_ref) = < at >_; my $ret = ""; my $width = $self->width()-1; my $height = $self->height()-1; for my $x (0 .. $width) { for my $y (0 .. $height) { vec($ret, $self->_calc_offset($y, $width-$x), 2) = vec($$s_ref, $self->_calc_offset($x,$y), 2); } } return \$ret; } # Get the minimal rotation permutation sub _get_min_rot_perm { my ($self, $s_ref) = < at >_; # Find the minimal board by its rotation permutations. my $min_rot_times = 0; my $min_rot_board = $s_ref; foreach my $r (1 .. 3) { my $new = $self->_rotate($s_ref); if ($$new lt $$min_rot_board) { $min_rot_times = $r; $min_rot_board = $new; } $s_ref = $new; } return ($min_rot_times, $min_rot_board); } sub _derive { my ($self, $state_ref, $box_xy, $push_to_xy) = < at >_; my $new_state = ""; for my $y (0 .. $self->height()-1) { for my $x (0 .. $self->width()-1) { my $offset = $self->_calc_offset($x, $y); if ($self->is_box($state_ref, $x, $y)) { vec($new_state, $offset, 2) = $box_bits; } else { vec($new_state, $offset, 2) = 0; } } } # Move the new box. vec($new_state, $self->_calc_offset(< at >$box_xy), 2) = 0; vec($new_state, $self->_calc_offset(< at >$push_to_xy), 2) = $box_bits; # Mark the reachable bits. $self->_mark_reachable(\$new_state, < at >$box_xy); return \$new_state; } sub _output { my ($self, $s_ref) = < at >_; for my $y (0 .. ($self->height()-1)) { for my $x (0 .. ($self->width()-1)) { print $self->is_wall($x, $y) ? "#" : $self->is_box($s_ref, $x, $y) ? '$' : $self->is_dest($x, $y) ? "." : " " ; } print "\n"; } print "\n"; } sub _is_final { my ($self, $s_ref) = < at >_; foreach my $d (< at >{$self->_dests()}) { if (! $self->is_box($s_ref, < at >$d)) { return 0; } } return 1; } sub _try_to_move_box { my ($self, $state_ref, $x, $y) = < at >_; for my $offset ([-1,0],[1,0],[0,-1],[0,1]) { my < at >push_to = ($x+$offset->[0], $y+$offset->[1]); my < at >push_from = ($x-$offset->[0], $y-$offset->[1]); if ( (! $self->is_wall(< at >push_to)) && (! $self->is_box($state_ref, < at >push_to)) && $self->is_reachable($state_ref, < at >push_from) ) { # We can push. my $new_state_ref = $self->_derive($state_ref, [$x, $y], \< at >push_to) ; # Print it - this is temporary for debugging. # (Now commented out.) # $self->_output($new_state_ref); # Else - register it and proceed. my ($rot_idx, $rot_state) = $self->_get_min_rot_perm($new_state_ref); if (exists($self->_collect()->{$$rot_state})) { # Do nothing } else { $self->_collect()->{$$rot_state} = { r => (($rot_idx+$self->_collect()->{$$state_ref}->{r})%4), p => $state_ref }; if ($self->_is_final($rot_state)) { return $rot_state; } push < at >{$self->_queue()}, $rot_state; } } } return; } sub _trace_solution { my ($self, $final_state) = < at >_; my < at >solution; { my $state = $final_state; while (defined($state)) { push < at >solution, $state; $state = $self->_collect->{$$state}->{p}; } } foreach my $state (reverse(< at >solution)) { my $r = $self->_collect->{$$state}->{r}; # Normalize the state from its rotated position. my $rot_state = $state; while ($r%4 != 0) { $rot_state = $self->_rotate($rot_state); $r++; } $self->_output($rot_state); } } =head2 $board->solve() Actually solve the board. =cut sub solve { my $self = shift; my $s_ref = $self->_init_state(); my ($rot_idx, $rot_state) = $self->_get_min_rot_perm($s_ref); $self->_collect()->{$$rot_state} = { r => $rot_idx, p => undef() }; push < at >{$self->_queue()}, $rot_state; my $w = $self->width()-1; my $h = $self->height()-1; while (my $state_ref = pop(< at >{$self->_queue()})) { for my $y (0 .. $h) { for my $x (0 .. $w) { if ($self->is_box($state_ref, $x, $y)) { my $final = $self->_try_to_move_box($state_ref, $x, $y); if (defined($final)) { $self->_trace_solution($final); return $final; } } } } } } =head2 width() Returns the width of the board. =head2 height() Returns the height of the board. =cut 1; --------------------------------------------------------------------- Shlomi Fish shlomif-ik1l9ssToec+JF/nGntIXQ< at >public.gmane.org Homepage: http://www.shlomifish.org/ I'm not an actor - I just play one on T.V.

RE: [QUIZ] Perl 'Hard' Quiz of the Whatever #2008-12-28 - Symmetric Sokoban

Jurgen Pletinckx — 2008-01-04T14:44:15

Shlomi Fish public.gmane.org> mailed on 28 December 2007 12:31: | IMPORTANT: Please do not post solutions, hints, or other spoilers | until at least 60 hours after the date of this message. Thanks. | | I was told the "What does this code do?" quizzes were not as good as a new | programming task, so here's a more traditional QOTW that I came up with. In | this quiz you'll try to solve the following Sokoban ( | http://en.wikipedia.org/wiki/Sokoban ) puzzle using Perl: | | {{{{{{{{{{{{{{ | #### | # # | # #### | ###$.$ # | # .< at >. # | # $.$### | #### # | # # | #### | }}}}}}}}}}}}}} Well past the spoiler line now ... (I do prefer these tasks to "WDTCD?" quizzes. *And* I had some tuits over the holidays. Anyone else out there?) I've tried not to be too clever. * Standard breadth-first search, no heuristics * tree is stored in a hash, as child => parent pairs * sparse tree (I only record the fastest way to get to a state) * the text representation of a board state is used for both move detection and for storing * subroutine 'move' checks whether the sokoban can move to the right, and what the result would be. By all rights it should be simple and elegant code. Instead, it's a workmanlike hack. Emphasis is on 'works', however. * subroutine 'moves' finds all possible descendants of a given board state by presenting consecutive rotated board states to sub move There are gains to be made by taking advantage of the fourfold rotational symmetry here. But that would be clever. Also, this text representation (xsb format) is highly compressible, and it might be worthwhile to store the board states that way. This is a small puzzle (25 pos- itions, 4 boxes - only 25*24*23*22*21/4*3*2*1 = 265650 board states possible). I get a solution (77 steps) in slighly over three min- utes on this box (WinXP, single CPU, 3GHz). ############################################## #!/perl use strict; use warnings; # use Devel::Size qw(total_size); my $puzzle =<<'EOP'; #### # # # #### ###$.$ # # .< at >. # # $.$### #### # # # #### EOP solve($puzzle); sub move { my $puzzle = shift; my $pos = index($puzzle, '< at >'); my $tar0 = my $tar1 = 0; if ($pos == -1) { $pos = index($puzzle, '+'); $tar0 = 1; } my $next = substr($puzzle,$pos+1,1); if ($next eq ' ') { substr($puzzle, $pos+1, 1, '< at >'); substr($puzzle, $pos, 1, $tar0 ? '.' : ' '); return $puzzle; } elsif ($next eq '.') { substr($puzzle, $pos+1, 1, '+'); substr($puzzle, $pos, 1, $tar0 ? '.' : ' '); return $puzzle; } elsif ($next eq '#') { return undef; } # only boxes left $tar1 = 1 if $next eq '*'; die "expecting a box (*\$), found '$next' in \n$puzzle\n" unless $next eq '$' or $tar1; $next = substr($puzzle,$pos+2,1); if ($next eq ' ') { substr($puzzle, $pos+2, 1, '$'); substr($puzzle, $pos+1, 1, $tar1 ? '+' : '< at >'); substr($puzzle, $pos, 1, $tar0 ? '.' : ' '); return $puzzle; } elsif ($next eq '.') { substr($puzzle, $pos+2, 1, '*'); substr($puzzle, $pos+1, 1, $tar1 ? '+' : '< at >'); substr($puzzle, $pos, 1, $tar0 ? '.' : ' '); return $puzzle; } return undef; } sub rotate { my $puzzle = shift; my < at >lines = split /\n/, $puzzle; my $maxl = 0; for (< at >lines) { my $l = length; $maxl = $l if $l > $maxl; } my < at >newlines; for my $j (0..$#lines) { my $l = length $lines[$j]; for my $i (0..$maxl-1) { my $char; if ($i >= $l) { $char = ' '; } else { $char = substr($lines[$j],$i,1); } $newlines[$maxl-$i-1] .= $char; } } my $newpuzzle = (join "\n", < at >newlines) . "\n"; return $newpuzzle; } sub moves { my $puzzle = shift; my < at >moves; my $move = move($puzzle); push < at >moves, $move if defined $move; my $rot = rotate($puzzle); $move = move($rot); push < at >moves, rotate(rotate(rotate($move))) if defined $move; $rot = rotate($rot); $move = move($rot); push < at >moves, rotate(rotate($move)) if defined $move; $rot = rotate($rot); $move = move($rot); push < at >moves, rotate($move) if defined $move; return < at >moves; } sub is_solved { my $puzzle = shift; return 0 if $puzzle =~ /\./; return 0 if $puzzle =~ /\+/; if ($puzzle =~ /\$/) { die "Apparently more boxes than targets in \n$puzzle\n"; } return 1; } sub solve { my $puzzle = shift; my %adjacency = ($puzzle => 'START'); my < at >queue = ($puzzle); my $maxsize = 0; while (1) { my $state = shift < at >queue; for my $cand (moves($state)) { next if exists $adjacency{$cand}; $adjacency{$cand} = $state; if (is_solved($cand)) { print_sol($cand, \%adjacency); #my $size = total_size(\%adjacency) + total_size(\< at >queue); #print "Tree contains $size bytes.\n"; return; } push < at >queue, $cand; } # print join "\t", scalar(keys %adjacency), scalar < at >queue, "\n"; } die "Unsolvable?"; } sub print_sol { my $solution = shift; my $href = shift; my < at >steps; while ($solution ne 'START') { unshift < at >steps, $solution; $solution = $href->{$solution}; } print join "---\n", < at >steps; print "---\n... and it took me only ".(time - $^T)." seconds!"; }

[QUIZ] Perl 'Hard' Quiz of the Whatever #2008-12-28 - Symmetric Sokoban

Shlomi Fish — 2007-12-28T11:31:02

IMPORTANT: Please do not post solutions, hints, or other spoilers until at least 60 hours after the date of this message. Thanks. I was told the "What does this code do?" quizzes were not as good as a new programming task, so here's a more traditional QOTW that I came up with. In this quiz you'll try to solve the following Sokoban ( http://en.wikipedia.org/wiki/Sokoban ) puzzle using Perl: {{{{{{{{{{{{{{ #### # # # #### ###$.$ # # .< at >. # # $.$### #### # # # #### }}}}}}}}}}}}}} If you're not familiar with the notation, then "#" are walls, "$" are the initial positions of the boxes to be moved, "." are the destinations and "< at >" is the initial position of the player. This level is the Microban level No. 142 in the levels collection of KSokoban. You may want to solve it yourself before using Perl to do so. You can load it into a Sokoban clone by saving it into a file and then using the "load" command. Good luck and happy new year! Regards, Shlomi Fish --------------------------------------------------------------------- Shlomi Fish shlomif-ik1l9ssToec+JF/nGntIXQ< at >public.gmane.org Homepage: http://www.shlomifish.org/ I'm not an actor - I just play one on T.V.

[QUIZ] Perl 'What does this code do?' Quiz

Shlomi Fish — 2007-10-28T17:06:31

Hi all! Here's another "What does this code do?" Quiz. I obfuscated the names of the variable names to prevent hinting their purpose, but the code itself is not obfuscated. You have to guess what the "m2()" function does. Good luck! Please post spoilers as response to this post with "SPOILER". Regards, Shlomi Fish <<<<<<<<<<<<<<<<<<<<< use strict; use warnings; sub m2 { my $c = shift; my $d = sub { my $e = shift; return +(ref($e) eq "ARRAY") ? $e->[1] : $e; }; my $f = sub { my $e = shift; return +(ref($e) eq "ARRAY") ? $e->[0] : 1; }; my $g; $g = sub { my ($h, $i, $j) = < at >_; if (($h == < at >$c) && ($j == 0)) { return (); } elsif ($j == 0) { return $g->($h+1, $d->($c->[$h]), $f->($c->[$h]) ); } else { return ($i, $g->($h, $i, $j-1)); } }; return [ $g->(0, 0, 0) ]; } 1; Regards, Shlomi Fish --------------------------------------------------------------------- Shlomi Fish shlomif-ik1l9ssToec+JF/nGntIXQ< at >public.gmane.org Homepage: http://www.shlomifish.org/ If it's not in my E-mail it doesn't happen. And if my E-mail is saying one thing, and everything else says something else - E-mail will conquer. -- An Israeli Linuxer

Re: [QUIZ] Perl 'What does this code do?' Quiz

Rob Kinyon — 2007-07-02T04:10:31

WALKMETH is a P6 thing (described in Apocalypse 12 http://dev.perl.org/perl6/doc/design/apo/A12.html) that generates a list of all methods that will respond to that invocation. My answer wasn't quite correct - the implementation of CALLALL described in A12 is the closer analog to the code provided. The "mostly complete" bit had to do with a few missing paranoia bits in the P5 as well as the fact that CALLALL does a take as opposed to executing the method right away (lazy vs. immediate). Personally, I prefer lazy evaluation as the default, but that's not really possible in P5 without breaking encapsulation or doing crazy things like Contextual::Return and the like that completely blow your runtime performance. Rob

Re: [QUIZ] Perl 'What does this code do?' Quiz

Greg Matheson — 2007-07-01T15:08:35

Is this the answer? DB<54> use Crypt::Rot13 DB<55> $c = Crypt::Rot13->new DB<56> $c->charge('xbmlnfui') DB<57> x $c->rot13(25) 0 'walkmeth' But I don't know what 'walkmeth' is.

Re: SPOILER: 'What does this code do?' Quiz

Shlomi Fish — 2007-07-01T12:49:11

That's right. Well, the thing is that it is very unlikely, I will create a different glob with the name "$mn", which will be different than a subroutine. But point taken. If it returns anything except an array ref, then I'd like to know about it. So I can assume that the contract of the function will be that, and that the functions of those names will be dedicated for them. As for the origin: this code is originally based on a concept that Damian Conway introduced in Class::Std ( http://search.cpan.org/dist/Class-Std/ ) - the "CUMULATIVE" methods. I believe I read about it in his Perl Best Practices book. I later implemented this feature in a somewhat different way in Test::Run (without making use of any of Damian's original Class::Std code), and this code here is based on the Test::Run code. Regards, Shlomi Fish --------------------------------------------------------------------- Shlomi Fish shlomif-ik1l9ssToec+JF/nGntIXQ< at >public.gmane.org Homepage: http://www.shlomifish.org/ If it's not in my E-mail it doesn't happen. And if my E-mail is saying one thing, and everything else says something else - E-mail will conquer. -- An Israeli Linuxer

Re: [QUIZ] Perl 'What does this code do?' Quiz

Shlomi Fish — 2007-07-01T12:37:09

What is XBMLNFUI? I don't get it. Regards, Shlomi Fish --------------------------------------------------------------------- Shlomi Fish shlomif-ik1l9ssToec+JF/nGntIXQ< at >public.gmane.org Homepage: http://www.shlomifish.org/ If it's not in my E-mail it doesn't happen. And if my E-mail is saying one thing, and everything else says something else - E-mail will conquer. -- An Israeli Linuxer

Re: SPOILER: 'What does this code do?' Quiz

Peter Scott — 2007-06-27T21:29:26

Yeah, yeah, yeah, exercise for the reader, etc, etc :-) See, the answer was within you all the time ;-)

Re: SPOILER: 'What does this code do?' Quiz

Ron Isaacson — 2007-06-27T20:42:59

Good catch, but of course you wouldn't want to actually do that... what if $m->($self) is very expensive, or has side effects? There's also a race condition: how can you be sure that an arrayref return from the first invocation of $m->($self) guarantees an arrayref return (whether or not the same data) from the second invocation? my $result = $m->($self); push < at >r, < at >$result if (ref $result eq 'ARRAY'); -- Ron Isaacson Morgan Stanley ron.isaacson-/PgpppG8B+R7qynMiXIxWgC/G2K4zDHf< at >public.gmane.org / (212) 762-1950

Re: [QUIZ] Perl 'What does this code do?' Quiz

Rob Kinyon — 2007-06-27T20:22:14

Nice. An mostly complete implementation of XBMLNFUI* in P5. Rob * 13x simpler than rot13 ...

SPOILER: 'What does this code do?' Quiz

Peter Scott — 2007-06-27T20:14:06

$object_or_class->z( { mn => 'funcname' } ) will return a reference to an array of all the list-context results of calling the 'funcname' method in the class of $object_or_class and its ancestors in parental order, assuming that each such method returns an arrayref, and that the above code is present in or inherited by the class of $object_or_class. However, it checks to see only if the glob 'funcname' is defined, not whether there is a subroutine of that name. It will generate a warning if another slot in the glob is used instead. I would rewrite the **** line above as my $m = *{$i . "::$mn"}{CODE}; and to be on the safe side, rewrite the %%%% line as push < at >r, < at >{ ref $m->($self) eq 'ARRAY' ? $m->($self) : [] };

[QUIZ] Perl 'What does this code do?' Quiz

Shlomi Fish — 2007-06-27T19:05:53

Hi all! Here's another "What does this code do?" Quiz. I obfuscated the names of the variable names to provide hinting on their purpose, but the code itself is not obfuscated. You have to guess what the "z()" function does. Good luck! Please post spoilers as response to this post with "SPOILER". Regards, Shlomi Fish <<<<<<<<<<<<<<<<<<<<< use strict; use warnings; use List::MoreUtils (qw(uniq)); our %_t = (); sub t { my $c = shift; if (exists($_t{$c})) { return $_t{$c}; } no strict 'refs'; my < at >h = $c; my < at >d = < at >{$c. '::ISA'}; while (my $p = shift(< at >d)) { push < at >h, $p; push < at >d, < at >{$p. '::ISA'}; } my < at >u = uniq(< at >h); return $_t{$c} = [ sort { $a->isa($b) ? -1 : $b->isa($a) ? +1 : 0 } < at >u ]; } sub z { my ($self, $args) = < at >_; my $mn = $args->{mn}; my $c = ((ref($self) eq "") ? $self : ref($self)); my $h= t($c); my < at >r; foreach my $i (< at >$h) { no strict 'refs'; my $m = ${$i . "::"}{$mn}; if (defined($m)) { push < at >r, < at >{$m->($self)}; } } return \< at >r; } Regards, Shlomi Fish --------------------------------------------------------------------- Shlomi Fish shlomif-ik1l9ssToec+JF/nGntIXQ< at >public.gmane.org Homepage: http://www.shlomifish.org/ If it's not in my E-mail it doesn't happen. And if my E-mail is saying one thing, and everything else says something else - E-mail will conquer. -- An Israeli Linuxer