1package Data::Range::Compare; 2 3use strict; 4use warnings; 5use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); 6use overload '""'=>\¬ation ,fallback=>1; 7 8require Exporter; 9$VERSION='1.031'; 10 11@ISA=qw(Exporter); 12 13use constant key_helper => 0; 14use constant key_start => 1; 15use constant key_end => 2; 16use constant key_generated => 3; 17use constant key_missing => 4; 18use constant key_data => 5; 19 20@EXPORT_OK=qw( 21 key_helper 22 key_start 23 key_end 24 key_generated 25 key_missing 26 key_data 27 28 add_one 29 sub_one 30 cmp_values 31 32 sort_largest_range_end_first 33 sort_largest_range_start_first 34 sort_smallest_range_start_first 35 sort_smallest_range_end_first 36 sort_in_consolidate_order 37 sort_in_presentation_order 38 39 HELPER_CB 40); 41 42%EXPORT_TAGS=( 43 KEYS=>[qw( 44 key_helper 45 key_start 46 key_end 47 key_generated 48 key_missing 49 key_data 50 )] 51 52 ,ALL=>\@EXPORT_OK 53 54 ,HELPER_CB=>[qw(HELPER_CB)] 55 ,HELPER=>[qw(add_one sub_one cmp_values)] 56 ,SORT=>[qw( 57 sort_largest_range_end_first 58 sort_largest_range_start_first 59 sort_smallest_range_start_first 60 sort_smallest_range_end_first 61 sort_in_consolidate_order 62 sort_in_presentation_order 63 )] 64); 65 66sub new { 67 my $s=shift @_; 68 bless [@_],$s; 69} 70 71sub helper_cb { my ($s,$key,@args)=@_; $s->[key_helper]->{$key}->(@args) } 72 73sub range_start () { $_[0]->[key_start] } 74sub range_end () { $_[0]->[key_end] } 75 76sub notation { 77 my $notation=join ' - ',$_[0]->range_start,$_[0]->range_end; 78 $notation; 79} 80sub helper_hash () { $_[0]->[key_helper] } 81sub missing () {$_[0]->[key_missing] } 82sub generated () {$_[0]->[key_generated] } 83 84sub data () { 85 my ($s)=@_; 86 return $s->[key_data] if ref($s->[key_data]); 87 $s->[key_data]={}; 88 $s->[key_data] 89} 90 91sub overlap ($) { 92 my ($range_a,$range_b)=@_; 93 return 1 if 94 $range_a->cmp_range_start($range_b)!=1 95 && 96 $range_a->cmp_range_end($range_b)!=-1; 97 return 1 if 98 $range_a->helper_cb( 99 'cmp_values' 100 ,$range_a->range_start 101 ,$range_b->range_end 102 )!=1 103 && 104 $range_a->helper_cb( 105 'cmp_values' 106 ,$range_a->range_end 107 ,$range_b->range_end 108 )!=-1; 109 110 return 1 if 111 $range_b->cmp_range_start($range_a)!=1 112 && 113 $range_b->cmp_range_end($range_a)!=-1; 114 115 return 1 if 116 #$range_b->range_start <=$range_a->range_end 117 $range_a->helper_cb( 118 'cmp_values' 119 ,$range_b->range_start 120 ,$range_a->range_end 121 )!=1 122 && 123 $range_a->helper_cb( 124 'cmp_values' 125 ,$range_b->range_end 126 ,$range_a->range_end 127 )!=-1; 128 129 undef 130} 131 132sub grep_overlap ($) { [ grep {$_[0]->overlap($_) } @{$_[1]} ] } 133sub grep_nonoverlap ($) { [ grep { $_[0]->overlap($_) ? 0 : 1 } @{$_[1]} ] } 134 135sub contains_value ($) { 136 my ($s,$cmp)=@_; 137 return 0 if $s->helper_cb('cmp_values',$s->range_start,$cmp)==1; 138 return 0 if $s->helper_cb('cmp_values',$cmp,$s->range_end)==1; 139 1 140} 141 142sub next_range_start () { $_[0]->helper_cb('add_one',$_[0]->range_end) } 143sub previous_range_end () { $_[0]->helper_cb('sub_one',$_[0]->range_start) } 144 145sub cmp_range_start($) { 146 my ($s,$cmp)=@_; 147 $s->helper_cb('cmp_values',$s->range_start,$cmp->range_start) 148} 149 150sub cmp_range_end($) { 151 my ($s,$cmp)=@_; 152 $s->helper_cb('cmp_values',$s->range_end,$cmp->range_end) 153} 154 155sub contiguous_check ($) { 156 my ($cmp_a,$cmp_b)=@_; 157 $cmp_a->helper_cb( 158 'cmp_values' 159 ,$cmp_a->next_range_start 160 ,$cmp_b->range_start 161 )==0 162} 163 164sub cmp_ranges ($) { 165 my ($range_a,$range_b)=@_; 166 my $cmp=$range_a->cmp_range_start($range_b); 167 if($cmp==0) { 168 return $range_a->cmp_range_end($range_b); 169 } 170 return $cmp; 171} 172 173sub HELPER_CB () { 174 add_one=>\&add_one 175 ,sub_one=>\&sub_one 176 ,cmp_values=>\&cmp_values 177} 178 179sub add_one { $_[0] + 1 } 180sub sub_one { $_[0] -1 } 181sub cmp_values { $_[0] <=> $_[1] } 182 183sub get_common_range { 184 my ($class,$helper,$ranges)=@_; 185 186 my ($range_start)=sort sort_largest_range_start_first @$ranges; 187 my ($range_end)=sort sort_smallest_range_end_first @$ranges; 188 189 new($class, 190 $helper 191 ,$range_start->range_start 192 ,$range_end->range_end 193 ); 194} 195 196sub get_overlapping_range { 197 my ($class,$helper,$ranges,%opt)=@_; 198 199 my ($range_start)=sort sort_smallest_range_start_first @$ranges; 200 my ($range_end)=sort sort_largest_range_end_first @$ranges; 201 202 my $obj=new($class,$helper,$range_start->range_start,$range_end->range_end); 203 $obj->[key_generated]=1; 204 $obj; 205} 206 207sub sort_in_presentation_order ($$) { 208 my ($cmp_a,$cmp_b)=@_; 209 $cmp_a->cmp_ranges($cmp_b); 210} 211 212sub sort_in_consolidate_order ($$) { 213 my ($range_a,$range_b)=@_; 214 $range_a->cmp_range_start($range_b) 215 || 216 $range_b->cmp_range_end($range_a); 217} 218 219sub sort_largest_range_end_first ($$) { 220 my ($range_a,$range_b)=@_; 221 $range_b->cmp_range_end($range_a) 222} 223 224sub sort_smallest_range_start_first ($$) { 225 my ($range_a,$range_b)=@_; 226 $range_a->cmp_range_start($range_b) 227} 228 229sub sort_smallest_range_end_first ($$) { 230 my ($range_a,$range_b)=@_; 231 $range_a->cmp_range_end($range_b) 232 233} 234 235sub sort_largest_range_start_first ($$) { 236 my ($range_a,$range_b)=@_; 237 $range_b->cmp_range_start($range_a) 238} 239 240sub consolidate_ranges { 241 my ($class,$helper,$ranges,%opt)=@_; 242 @$ranges=sort sort_in_consolidate_order @$ranges; 243 my $cmp=shift @$ranges; 244 my $return_ref=[]; 245 while( my $next=shift @$ranges) { 246 if($cmp->overlap($next)) { 247 my $overlap=$cmp->cmp_ranges($next)==0 ? 248 $cmp 249 : 250 $class->get_overlapping_range($helper,[$cmp,$next]); 251 $cmp=$overlap; 252 253 } else { 254 push @$return_ref,$cmp; 255 $cmp=$next; 256 } 257 258 } 259 push @$return_ref,$cmp; 260 $return_ref; 261} 262 263sub fill_missing_ranges { 264 my ($class,$helper,$ranges,%args)=@_; 265 %args=(consolidate_ranges=>0,%args); 266 267 $ranges=consolidate_ranges($helper,$ranges) if $args{consolidate_ranges}; 268 my $return_ref=[]; 269 270 my $cmp=shift @$ranges; 271 while(my $next=shift @$ranges) { 272 push @$return_ref,$cmp; 273 unless($cmp->contiguous_check($next)) { 274 my $missing=new($class, 275 $helper 276 ,$cmp->next_range_start 277 ,$next->previous_range_end); 278 $missing->[key_missing]=1; 279 push @$return_ref,$missing; 280 } 281 $cmp=$next; 282 } 283 284 push @$return_ref,$cmp; 285 286 $return_ref; 287} 288 289sub range_start_end_fill { 290 my ($class,$helper,$ranges,%opt)=@_; 291 292 my ($range_start)=sort sort_smallest_range_start_first 293 map { $_->[0] } @$ranges; 294 $range_start=$range_start->range_start; 295 my ($range_end)=sort sort_largest_range_end_first 296 map { $_->[$#{$_}] } @$ranges; 297 $range_end=$range_end->range_end; 298 299 foreach my $ref (@$ranges) { 300 my $first_range=$ref->[0]; 301 my $last_range=$ref->[$#{$ref}]; 302 303 if($first_range->helper_cb( 304 'cmp_values' 305 ,$first_range->range_start 306 ,$range_start 307 )!=0) { 308 my $new_range=new($class, 309 $helper 310 ,$range_start 311 ,$first_range->previous_range_end 312 ); 313 unshift @$ref,$new_range; 314 $new_range->[key_missing]=1; 315 $new_range->[key_generated]=1; 316 } 317 318 if($last_range->helper_cb('cmp_values' 319 ,$last_range->range_end 320 ,$range_end)!=0 321 ) { 322 my $new_range=new($class, 323 $helper 324 ,$last_range->next_range_start 325 ,$range_end 326 ); 327 push @$ref,$new_range; 328 $new_range->[key_missing]=1; 329 $new_range->[key_generated]=1; 330 } 331 } 332 333 334 $ranges; 335} 336 337sub range_compare { 338 my ($class,$helper,$list_of_ranges,%args)=@_; 339 340 %args=(consolidate_ranges=>1,%args); 341 342 if($args{consolidate_ranges}) { 343 my $ref=[]; 344 while(my $ranges=shift @$list_of_ranges) { 345 $ranges=$class->consolidate_ranges($helper,$ranges); 346 push @$ref,$ranges; 347 } 348 $list_of_ranges=$ref; 349 } 350 my ($row,$column_ids); 351 my $next=1; 352 sub { 353 return () unless $next; 354 if($column_ids) { 355 ($row,$column_ids,$next)=$class->compare_row( 356 $helper 357 ,$list_of_ranges 358 ,$row,$column_ids 359 ); 360 } else { 361 ($row,$column_ids,$next)=$class->init_compare_row( 362 $helper 363 ,$list_of_ranges 364 ); 365 } 366 @$row; 367 }; 368} 369 370sub init_compare_row { 371 my ($class,$helper,$data)=@_; 372 373 my $next=0; 374 my $cols=[]; 375 my $row=[]; 376 377 my @list=map { $_->[0] } @$data; 378 my ($first)=sort sort_smallest_range_start_first @list; 379 380 for(my $id=0;$id<=$#$data;++$id) { 381 my $range=$data->[$id]->[0]; 382 if($range->cmp_range_start($first)==0) { 383 push @$row,$range; 384 $cols->[$id]=0; 385 ++$next if $#{$data->[$id]}>0; 386 } else { 387 $cols->[$id]=-1; 388 push @$row,new($class, 389 $helper 390 ,$first->range_start 391 ,$range->previous_range_end 392 ,1 393 ,1 394 ); 395 ++$next; 396 } 397 } 398 return $row,$cols,$next; 399} 400 401sub compare_row { 402 my ($class,$helper,$data,$row,$cols)=@_; 403 404 # if we don't have our column list then we need to build it 405 my ($last)=sort sort_smallest_range_end_first @$row; 406 my ($end)=sort sort_largest_range_end_first 407 map { $_->[$#$_] } @$data; 408 409 my $total=1 + ($#$data); 410 my $ok=$total; 411 my $missing_count=0; 412 for(my $id=0;$id<=$#$data;++$id) { 413 my $range=$row->[$id]; 414 415 my $current=$cols->[$id]; 416 my $next=1 + $current; 417 if($#{$data->[$id]} < $next) { 418 $next=undef; 419 } 420 421 if($last->cmp_range_end($range)==0) { 422 if(defined($next)) { 423 my $next_range=$data->[$id]->[$next]; 424 425 if($range->contiguous_check($next_range)) { 426 $cols->[$id]=$next; 427 $row->[$id]=$next_range; 428 } else { 429 $row->[$id]=new($class, 430 $helper 431 ,$range->next_range_start 432 ,$next_range->previous_range_end 433 ,1 434 ,1 435 ); 436 } 437 } else { 438 $row->[$id]=new($class, 439 $helper 440 ,$range->next_range_start 441 ,$end->range_end 442 ,1 443 ,1 444 ); 445 } 446 } 447 ++$missing_count if $row->[$id]->missing; 448 --$ok if $row->[$id]->cmp_range_end($end)>=0; 449 } 450 return $class->compare_row($helper,$data,$row,$cols) 451 if $ok and $missing_count==$total; 452 ($row,$cols,$ok) 453} 454 4551; 456