#!/usr/bin/perl
use strict;
use warnings;
use Math::Pari qw/:int factorint divisors/;

for ( 1 .. 7000 ) {
    print "$_\n" if is_vamp( $_ );
}

sub is_vamp {
    my $num = shift;
    my @factors = grep {$_ !~ /[^$num]/} divisors(factorint($num)) =~ 
+/(?<=\d)\D+(\d+)(?=\D+\d+)/g;

    return 0 if @factors < 2;
    my $srt = join '', sort split //, $num;
    my $iter = combo( 2, @factors );
    while ( my ($x, $y) = $iter->() ) {
        next if length $x != length $y || (join '', sort split //, $x 
+. $y) ne $srt;
        return 1 if $x * $y == $num;
    }
    return 0;
}

sub combo {
    my $by = shift;
    return sub { () } if ! $by || $by =~ /\D/ || @_ < $by;
    my @list = @_;

    my @position = (0 .. $by - 2, $by - 2);
    my @stop     = @list - $by .. $#list;
    my $end_pos  = $#position;
    my $done     = undef;

    return sub {
        return () if $done;
        my $cur = $end_pos;
        {
            if ( ++$position[ $cur ] > $stop[ $cur ] ) {
                $position[ --$cur ]++;
                redo if $position[ $cur ] > $stop[ $cur ];
                my $new_pos = $position[ $cur ];
                @position[ $cur .. $end_pos ] = $new_pos .. $new_pos +
+ $by;
            }
        }
        $done = 1 if $position[0] == $stop[0];
        return @list[ @position ];
    }
}
[download]