使用Perl确定不重叠的位置

时间:2011-01-07 16:18:57

标签: perl combinatorics

我有一组位置 - 这是数据结构的一个例子。

my $locations =
{
  loc_1 =>
  {
    start => 1,
    end   => 193,
  },
  loc_2 =>
  {
    start => 180,
    end   => 407,
  },
  loc_3 =>
  {
    start => 329,
    end   => 684,
  },
  loc_4 =>
  {
    start => 651,
    end   => 720,
  },
};

确定非重叠位置的每种可能组合的最佳方法是什么?这个例子的答案看起来像这样。请记住,可能有一个或多个位置,这些位置可能重叠也可能不重叠。

my $non_overlapping_locations =
[
  {
    loc_1 =>
    {
      start => 1,
      end   => 193,
    },
    loc_3 =>
    {
      start => 329,
      end   => 684,
    },
  },
  {
    loc_1 =>
    {
      start => 1,
      end   => 193,
    },
    loc_4 =>
    {
      start => 651,
      end   => 720,
    },
  },
  {
    loc_2 =>
    {
      start => 180,
      end   => 407,
    },
    loc_4 =>
    {
      start => 651,
      end   => 720,
    },
  }
];

更新ysth的回复让我看到了我的措辞存在缺陷。我想我对//每个可能//非重叠位置的组合都不感兴趣,我只对那些不是其他解决方案子集的解决方案感兴趣。

4 个答案:

答案 0 :(得分:1)

我不是CS人,所以我并没有使用所有最好的算法,但我想知道是否有更好的方法:

my @location_keys = keys %{$locations};
while (my $key_for_checking = (shift @location_keys) {
    foreach my $key_to_compare (@location_keys) {
        if ( do_not_overlap($locations->{$key_for_checking}, 
                            $locations->{$key_to_compare} ) {
            add_to_output($key_for_checking, $key_to_compare);
        }
    }
}

do_not_overlapadd_to_output合适定义。

如果你想知道检查重叠......这非常简单。 如果出现以下情况,A和B不会重叠:

( (A->start < B->start) && (A->end < B->start) ) ||
( (A->start > B->end)   && (A->end > B->end) )

您可能需要根据共享边界是否构成重叠进行调整。此外,如果您知道A和B是否以某种方式(从开始或结束)排序,您可以简化此操作。

答案 1 :(得分:1)

首先,我将收集所有单独的点(每个位置的开始和结束),对它们进行排序并将它们保存在列表中。在你的情况下:

1,180,193,329,407,651,684,720. 

对于该列表中的每个间隔,找出与其重叠的段数。在你的情况下,这将是:

1, 180 -> 1
180, 193 -> 2
193, 329 -> 1
329, 407 -> 2
407, 651 -> 1
651, 684 -> 2
684, 720 -> 1

并循环哪些段有多于1个(在这种情况下有3个)。因此,案例总数为2 x 2 x 2 = 8个解决方案(您只能在解决方案中选择一个加工多个区间的段)。

我们发现了2,2,2(或2,3,4)。将它们保存在一个数组中并从最后一个开始。递减直到达到0.当达到1时,递减前一个数字并将第一个数字设置为初始值减去1.

假设我们已经对初始段进行了编号:(在本例中为1,2,3,4,5,6)。重叠的细分中将包含以下细分[1,2], [2,3], [3,4]。所以我们有3个重叠的部分。现在我们开始一个选择/消除的递归过程: 在每个步骤中,我们都在查看具有多个段的重叠段。我们迭代选择,并且对于每个选择,我们做两件事:从每个后续重叠段中消除我们现在没有选择的段,并且在每个后续重叠段中强制当前段选择作为可能性。变为非重叠的每个段都将被视为新选择。搜索下一个多项选择并递归。一旦我们找不到选择,我们就会有部分解决方案。我们需要添加不涉及任何重叠的段。打印出来。

在这种情况下它会是这样的:第一步:

we are here [1,2], [2,3], [3,4]:
  chose 1 -> // eliminate 2 from rest and force 1 (3 is a single choice so we do the same)
      [1], [3], [3] -> [1, 3] solution 
  chose 2 -> // eliminate 1 from the rest and force 2 (2 single choice so we do the same). 
      [2], [2], [4] -> [2, 4] solution

这应该正常工作。

现在实现这个的代码(它不是我假设的最漂亮的perl代码,但我真的不是一个perl人):

#!/bin/perl

use strict;
use warnings;
use 5.010;
use Data::Dumper;

my $locs = {
  loc_1 => {
    start => 1,
    end   => 193,
  },
  loc_2 => {
    start => 180,
    end   => 407,
  },
  loc_3 => {
    start => 329,
    end   => 684,
  },
  loc_4 => {
            start => 651,
    end   => 720,
  }
};

my (%starts, %ends);
map {
        my ($start, $end) = ($locs->{$_}->{start}, $locs->{$_}->{end});

        push @{ $starts{$start} }, $_;
        push @{ $ends{$end} }, $_;
} keys %$locs;

my @overlaps, my %tmp;

map {
        map { $tmp{$_} = 1 } @{$starts{$_}};
        map { delete $tmp{$_} } @{$ends{$_}};

        my @segs = keys %tmp;
        push @overlaps, \@segs if 1 < @segs
} sort (keys %starts, keys %ends);

sub parse_non_overlapping {
  my ($array,$pos)=($_[0], $_[1]);

  my @node = @{$array->[$pos]};
  foreach my $value ( @node ) {

    my @work = map { [@$_] } @$array;
    $work[$pos] = [ $value ];

    my ($removed, $forced) = ( {}, {$value => 1});
    map { $removed->{$_} = 1 if $_ ne $value } @node;

    my ($i, $new_pos) = (0, -1);
    for ( $i = $pos + 1; $i <= $#work; $i++ ) {
        $_ = $work[$i];

        #apply map
        @$_ = grep { not defined($removed->{$_}) } @$_;
        if ( $#$_ == 0 ) { $forced->{@$_[0]} = 1 }

        #apply force
            my @tmp = grep { defined $forced->{$_} } @$_;
        if ( $#tmp == 0 ) {
             map { $removed->{$_} = 1 if $tmp[0] ne $_ } @$_;
             @$_ = @tmp;
        }

        if ( $#$_ > 0 && $new_pos == -1 ) {
                $new_pos = $i;
        }

        $work[$i] = $_;
    }

    if ( $new_pos != -1 ) {
      parse_non_overlapping(\@work, $new_pos);
    } else {
      print Dumper \@work
       # @work has the partial solution minux completely non overlapping segments.
    }
  }
}    

parse_non_overlapping(\@overlaps, 0);

答案 2 :(得分:1)

use strict;
use warnings;

my $locations =
{
  loc_1 =>
  {
    start => 1,
    end   => 193,
  },
  loc_2 =>
  {
    start => 180,
    end   => 407,
  },
  loc_3 =>
  {
    start => 329,
    end   => 684,
  },
  loc_4 =>
  {
    start => 651,
    end   => 720,
  },
};
my $non_overlapping_locations = [];
my @locations = sort keys %$locations;

get_location_combinations( $locations, $non_overlapping_locations, [], @locations );

use Data::Dumper;
print Data::Dumper::Dumper($non_overlapping_locations);

sub get_location_combinations {
    my ($locations, $results, $current, @remaining) = @_;

    if ( ! @remaining ) {
        if ( not_a_subset_combination( $results, $current ) ) {
            push @$results, $current;
        }
    }
    else {
        my $next = shift @remaining;
        if (can_add_location( $locations, $current, $next )) {
            get_location_combinations( $locations, $results, [ @$current, $next ], @remaining );
        }
        get_location_combinations( $locations, $results, [ @$current ], @remaining );
    }
}

sub can_add_location {
    my ($locations, $current, $candidate) = @_;

    # not clear if == is an overlap; modify to use >=  and <= if so.
    0 == grep $locations->{$candidate}{end} > $locations->{$_}{start} && $locations->{$candidate}{start} < $locations->{$_}{end}, @$current;
}

sub not_a_subset_combination {
    my ($combinations, $candidate) = @_;

    for my $existing (@$combinations) {
        my %candidate;
        @candidate{@$candidate} = ();
        delete @candidate{@$existing};
        if ( 0 == keys %candidate ) {
            return 0;
        }
    }
    return 1;
}

一个相对简单的优化是按开始排序@locations然后结束并预先计算并存储在每个位置的哈希(或仅位于$ locations-&gt; {foo}中)以下多少位置发生冲突与该位置。然后在can_add ...的情况下,在递归之前将该数字从@remaining中拼接出来。

或者为每个位置预先计算冲突的所有后续位置的哈希值,并在递归之前用grep将它们全部删除。 (尽管采用这种方法,剩余的哈希开始变得更有意义。)

更新:解决方案的另一种方法是建立一个要排除的位置树,其中叶子代表解决方案,内部节点代表仍然存在冲突的组合;顶部节点是所有位置,并且每个节点都有子节点,表示删除剩余的冲突位置之一(在某些任意排序方案中)比父节点删除的位置(如果有的话)更大。

答案 3 :(得分:0)

(真实的入侵 - 道歉,我会写一个解释 - 并获得那些空的阵列,虽然这是相当微不足道的 - 稍后!)

#! /usr/bin/perl
use strict;
use warnings;
use 5.010;
use List::MoreUtils qw(any);
use Data::Dumper;

my $locations = {
    loc_1 => {
        start => 1,
        end   => 193,
    },
    loc_2 => {
        start => 180,
        end   => 407,
    },
    loc_3 => {
        start => 329,
        end   => 684,
    },
    loc_4 => {
        start => 651,
        end   => 720,
    },
};

my @keys = keys %$locations;

my %final;

for my $key (@keys) {
    push @{ $final{$key} }, map {
        if (   $locations->{$key}->{start} >= $locations->{$_}->{start}
            && $locations->{$key}->{start} <= $locations->{$_}->{end}
            or $locations->{$key}->{end} >= $locations->{$_}->{start}
            && $locations->{$key}->{end} <= $locations->{$_}->{end} )
        {
            ();
        }
        else {
            my $return = [ sort $key, $_ ];
            if ( any { $return ~~ $_ } @{ $final{$_} }, @{ $final{$key} } ) {
                ();
            }
            else { $return; }
        }
    } grep { $_ ne $key } keys %$locations;
}

say Dumper \%final;