找出所有组合

pony2001mx

大家好，
我有一个难题，请教高人指点。对于每个ID(第一列)，找出所有首尾相连（从1连到100）的组合。非常谢谢您的帮助！！

a   1-30      A
a   9-30      B
a   31-70    D
a   31-100  F
a   71-100  U
b   1-50      J
b   1-90      K
b   51-100   JK
c   1-20      ll
c   21-99     L


理想的输出结果是：
a    1-30,31-70,71-100   ADU
a    1-30,31-100            AF
b    1-50, 51-100           JJK

pony2001mx

有没有高手帮我一下，我万分感激！是我的问题表述不太清楚吗？我的目的是找出所有首尾相连（从1连到100）的组合，比如1-30，31-70，71-100这个组合。 谢谢！

xiumu2280

1. use strict;
   
2. use warnings;
   
3. use Storable qw(dclone);
   
4. 
   
5. my @data = map {[$_->[0],[[$_->[1],$_->[2]]],[$_->[3]]]}map {chomp;[split /\s+|-/,$_]}<DATA>;
   
6. 
   
7. for my $f (@data) {
   
8.         next if $f->[1][0][0] ne 1;
   
9.         all_result($f,\@data);
   
10. }
    
11. 
    
12. sub all_result {
    
13.         my ($ori_o,$data) = @_;
    
14.         my $ori = dclone($ori_o);
    
15.         for my $s (@{$data}) {
    
16.                 if ($ori_o->[0] eq $s->[0] && ($ori_o->[1][-1][1]+1) eq $s->[1][0][0]) {
    
17.                         push @{$ori->[1]},$s->[1][0];
    
18.                         push @{$ori->[2]},@{$s->[2]};
    
19.                         all_result($ori,$data);
    
20.                         $ori = dclone($ori_o);
    
21.                 }
    
22.         }
    
23.         if ($ori_o->[1][-1][1] eq 100) {
    
24.                 my @mm;
    
25.                 for my $m (@{$ori_o->[1]}) {
    
26.                         push @mm,join "-",@$m;
    
27.                 }
    
28.                 my $m_l = join ",",@mm;
    
29.                 my $e_l = join "",@{$ori_o->[-1]};
    
30.                 print "$ori_o->[0]\t$m_l\t$e_l\n";
    
31.                 return;
    
32.         }
    
33. }
    
34. __DATA__
    
35. a   1-30      A
    
36. a   9-30      B
    
37. a   31-70    D
    
38. a   31-100  F
    
39. a   71-100  U
    
40. b   1-50      J
    
41. b   1-90      K
    
42. b   51-100   JK
    
43. c   1-20      ll
    
44. c   21-99     L

复制代码

写的比较绕，不过应该可以实现

huang6894

回复 3# xiumu2280


    大神，dclone是干啥的？

清泉一边

同问~~~~~~

xiumu2280

对引用进行复制 @清泉一边 回复 4# huang6894


   

pony2001mx

xiumu2280，非常谢谢您的perl程序，但是我运行您的脚本为什么不出任何结果？我正在钻研您的脚本，还不太明白next if $f->[1][0][0] ne 1的意思（我觉得next if $f->[1] ne 1容易理解些，后边[0][0]不太明白）。请给我回复，也欢迎大家的建议，谢谢！！

xiumu2280

$f是一个3层数组，你用use Data:umper; 看看数据结构就明白了

把代码复制进去会没有结果？
还是你改了之后 才没结果
回复 7# pony2001mx


   

pony2001mx

xiumu2280，，可以了，谢谢！我正在研究您的脚本，有问题还要请教您，谢谢！

pony2001mx

回复 8# xiumu2280

您好，我研究了半天，请问第20行$ori = dclone($ori_o);是不是可以省略？谢谢！