#!/usr/bin/perl -l
use warnings;
use strict;
use Algorithm::Loops 'NestedLoops';
use Data::Dumper;
$Data::Dumper::Indent = 0;


my $set = {
'key1' => 
['A -4 A','A -1 C','C -4 D','D -4 B','B -3 C','C -2 B','B -1 E'],
'key2' => ['A -4 B','B -4 C','C -4 A','A -4 B'],
'key3' => ['A -4 C','C -4 B','B -4 A','A -2 C','C -3 B'],
};

my $delim   = 'A -3 C -4 B';
my $delim2  = 'A -4 B';

get_region($delim,$set);

sub get_region
{
   my ($delim,$set) = @_;

    OUT:
    foreach  my $setkey ( sort keys %{$set}  )
    {
        print "$setkey\n";

        no warnings q/uninitialized/;  
        # Do you know how can I remove warning
        # from the code below?

        my @delim = decomp_str2aoa($delim);
        my @data  = decomp_a2aoa($set->{$setkey});

        my $N = $#data;
        my $D = $#delim;

        my @intervals  =  
        NestedLoops(
                    [    [0    .. $N],  sub {[$_ .. $N]},
                      ( sub {[$_+1 .. $N]}, sub {[$_ .. $N]} ) x $D
                    ],

            { OnlyWhen => sub {

                for my $d (0 .. $D) {
                    if ($data[ $_[ $d*2     ] ][0] ne $delim[$d][0]
                    or $data[ $_[ $d*2 + 1 ] ][2] ne $delim[$d][2])
                    {
                        return 0;
                    }
                }
                return 1;
            } },
            
            sub {
                return [ 
                  map { [@data[ $_[2*$_] .. $_[2*$_+1] ]] } 0 .. $D 
                      ];
            }
         );
         
          # As per your suggestion, I do want to use deep
          # interval, because later I want to test each $interval  
          # with certain condition and then do "next OUT"            
          #  ---- as speed-up heuristic

            foreach  my $int (@intervals )
            {
                if (@{$int->[0]})
                {
                    print join " / ", 
                    map { 
                       my $range = $_; join " ", map "[@$_]", @$range 
                        } @{$int};
                    my $numtpl = num_of_tupl($int);
                    #next OUT if ($numtpl >= 5);
                } 
            }    
       
       print "\n";
    }               
          
    return ;
}    

sub num_of_tupl
{
    # Just a simple code, counting
    # how many tuples (e.g.["A", -3, "C"] ) contain in AoA
    my    $ar    = shift;
    my $count;
    
    foreach  my $lvl1 ( @{$ar}  )
    {
        my $sizein = scalar(@{$lvl1});
        $count += $sizein;
    }  

    return $count;
}    


# These two subroutines
# split the string token into pure array, as you suggested
sub decomp_str2aoa 
{
    return decomp_a2aoa([$_[0] =~ /(?=([a-z]\s*(?:\S+\s*){2}))\S+\s*/g
+i ]);
}

sub decomp_a2aoa
{
    my    $arr    = shift;
    return map{ [split(" ",$_)] }@{$arr};
}
[download]