Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?
 
PerlMonks  

Re: sugession for the filecreating

by ady (Deacon)
on Mar 24, 2008 at 09:34 UTC ( #675878=note: print w/replies, xml ) Need Help??


in reply to sugession for the filecreating

Hi,

If your problem is generating the alfabetic permutation for the filenames, that's not quite trivial. You can find a good discussion in the book Higher-Order Perl by Mark Jason Dominus.

Here's some (slightly adapted) code snippets from the book, that you may find useful :
#!/usr/bin/perl -w use strict; sub Iterator (&) { return $_[0] } sub NEXTVAL { $_[0]->() } ### ================================================================== ### permute (HOP1, 3.1) ### ================================================================== sub permute { my @items = @{ $_[0] }; my @perms = @{ $_[1] }; my $fun = $_[2] || sub { print "\t@{$_[0]}\n"; }; unless (@items) { $fun->(\@perms); } else { my (@newitems, @newperms, $i); foreach $i (0 .. $#items) { @newitems = @items; @newperms = @perms; # Remove #i item and prepend to perms; Permute new lists. unshift(@newperms, splice(@newitems, $i, 1)); permute([@newitems], [@newperms], $fun); } } } ### ================================================================== ### permute2 (HOP1 4,3.1) ### ================================================================== sub permute2 { my @items = @_; my @pattern = (0) x @items; return Iterator { return unless @pattern; my @result = pattern_to_permutation(\@pattern, \@items); @pattern = increment_pattern(@pattern); return @result; }; } sub increment_pattern { my @odometer = @_; my $wheel = $#odometer; # start at rightmost wheel until ($odometer[$wheel] < $#odometer-$wheel || $wheel < 0) { $odometer[$wheel] = 0; $wheel--; # next wheel to the left } if ($wheel < 0) { return; # fell off the left end; no more sequences } else { $odometer[$wheel]++; # this wheel now turns one notch return @odometer; } } sub pattern_to_permutation { my $pattern = shift; my @items = @{shift()}; my @r; for (@$pattern) { push @r, splice(@items, $_, 1); } @r; } ### ================================================================== ### permute_n (HOP1 4,3.1) ### ================================================================== sub permute_n { my @items = @_; my $n = 0; return Iterator { my @pattern = n_to_pat($n, scalar(@items)); my @result = pattern_to_permutation(\@pattern, \@items); $n++; return @result; }; } sub n_to_pat { my @odometer; my ($n, $length) = @_; for my $i (1 .. $length) { unshift @odometer, $n % $i; $n = int($n/$i); } return $n ? () : @odometer; } ### ================================================================== ### permute-flop (HOP1 4,3.1) ### ================================================================== sub permute_flop { my @items = @_; my $n = 0; return Iterator { $n++, return @items if $n==0; my $i; my $p = $n; for ($i=1; $i<=@items && $p%$i==0; $i++) { $p /= $i; } my $d = $p % $i; my $j = @items - $i; return if $j < 0; @items[$j+1..$#items] = reverse @items[$j+1..$#items]; @items[$j,$j+$d] = @items[$j+$d,$j]; $n++; return @items; }; } =cut ### ------------------------------------------------------- print "permute \n " . "-" x 40 . "\n"; my @col = [qw(white red orange yellow green blue violet black)]; my @res = []; my $start = time(); #permute(@col, []); permute(@col, [], sub { push @res, $_[0]; }); # print "@res\n"; #print Dumper( \@res ); print time() - $start . " sec.\n"; =cut ### ------------------------------------------------------- print "increment_pattern \n " . "-" x 40 . "\n"; my @items = ('A' .. 'D'); my @pattern = (0) x @items; while (@pattern = increment_pattern(@pattern) ) { print "@pattern\n"; #print Dumper( \@pattern ); } print "\npermute2 \n " . "-" x 40 . "\n"; my $pit = permute2('A' .. 'D'); while (my @p = NEXTVAL($pit)) { print "@p\n"; } $pit = permute2( qw(red orange yellow green blue violet) ); while (my @p = NEXTVAL($pit)) { print "@p\n"; } ### ------------------------------------------------------- print "permute_n \n " . "-" x 40 . "\n"; my $it_n = permute_n('A' .. 'D'); while (my @p = NEXTVAL($it_n)) { print "@p\n"; } ### ------------------------------------------------------- print "permute_flop \n " . "-" x 40 . "\n"; my $it_f = permute_flop('A' .. 'D'); while (my @p = NEXTVAL($it_f)) { print "@p\n"; }


Best regards,
Allan Dystrup

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://675878]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others imbibing at the Monastery: (3)
As of 2022-08-14 10:33 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?