Извлечь уникальные интервалы из двух массивов в perl?

Question

Я пытаюсь извлечь неперекрывающиеся интервалы из двух файлов с интервалами (уникальными). Вот так:

file1.txt

Start End 
1 3 
5 9 
13 24 
34 57 

file2.txt

Start End 
6 7 
10 12 
16 28 
45 68 

Ожидаемый результат: массив, имеющий те интервалы с элементов, присутствующих только в одном файле:

1-3 , 10-12 

Вот и все ... спасибо вам заблаговременно!

Answer 1

Обработка файлов по строкам. Если нет совпадений, сообщите об этом интервале, который начинается раньше и продвигает его файл. В случае перекрытия, продвигайте оба файла.

#!/usr/bin/perl 
use warnings; 
use strict; 

use Data::Dumper; 

my @F; 
open $F[0], '<', 'file1.txt' or die $!; 
open $F[1], '<', 'file2.txt' or die $!; 

# Skip headers. 
readline $_ for @F; 

my @boundaries; 
my @results; 

sub earlier { 
    my ($x, $y) = @_; 
    if (! @{ $boundaries[$y] } 
     or $boundaries[$x][1] < $boundaries[$y][0] 
    ) { 
     push @results, $boundaries[$x]; 
     $boundaries[$x] = [ split ' ', readline $F[$x] ]; 
     return 1 
    } 
    return 0 
} 

sub overlap { 
    my ($x, $y) = @_; 
    if ($boundaries[$x][1] < $boundaries[$y][1]) { 
     do { $boundaries[$x] = [ split ' ', readline $F[$x] ] } 
      until ! @{ $boundaries[$x] } 
      or $boundaries[$x][0] > $boundaries[$y][1]; 
     $boundaries[$y] = [ split ' ', readline $F[$y] ]; 
     return 1 
    } 
    return 0 
} 

sub advance_both { 
    @boundaries = map [ split ' ', readline $_ ], @F; 
} 

# init. 
advance_both(); 
while (grep defined, @{ $boundaries[0] }, @{ $boundaries[1] }) { 

    earlier(0, 1) 
    or earlier(1, 0) 
    or overlap(0, 1) 
    or overlap(1, 0) 
    or advance_both(); 
} 

print join(' , ', map { join '-', @$_ } @results), "\n"; 

Answer 2

Эта программа делает, как вы просите. Он загружает все диапазоны в @pairs (нет необходимости различать содержимое file1 и file2) и копирует этот список в массив @unique. Затем каждую возможную комбинацию из двух диапазонов тестируют, чтобы увидеть, перекрываются ли они, и оба диапазона удаляются с @unique, если это так.

Оставшееся содержимое @unique - это список диапазонов, который требуется. Я отобразил его, используя Data::Dump, в случае, если вам нужно обработать результат дальше и с помощью print, чтобы вы могли видеть, что результат соответствует требуемому результату в вашем вопросе.

use strict; 
use warnings; 

our @ARGV = qw/ file1.txt file2.txt /; 

my @ranges; 

while (<>) { 
    my @pair = /\d+/g; 
    next unless @pair == 2; 
    push @ranges, \@pair; 
} 

my @unique = @ranges; 

for my $i (0 .. $#unique) { 
    for my $j ($i+1 .. $#unique) { 
    if ($unique[$i][0] <= $unique[$j][1] and $unique[$i][1] >= $unique[$j][0]) { 
     ++$unique[$_][2] for $i, $j; 
    } 
    } 
} 

@unique = grep { not $_->[2] } @unique; 


use Data::Dump; 
dd \@unique; 

print join(', ', map join('-', @$_), @unique), "\n"; 

выход

[[1, 3], [10, 12]] 
1-3, 10-12 

---

Обновление

Используя данные из @Choroba (благодаря) на выходе теперь

[[1, 3], [1000, 1001], [10, 12]] 
1-3, 1000-1001, 10-12 

который я считаю правильным.