use strict; use warnings; my @sets = qw{ AAAAADDDDDEFFGMMSSTVVVVV AADDDEEEEFFFFGGMMMMMMMMMMSTV }; foreach my $set ( @sets ) { print qq{$set\n}; my @tuples; while ( length $set >= 4 ) { if ( $set =~ m{^(.)\1{3}} ) { push @tuples, substr $set, 0, 4, q{}; } else { my @boundaries = ( 0 ); push @boundaries, pos $set while $set =~ m{(.)(?=.)(?!\1)}g; last if scalar @boundaries < 3; push @tuples, join q{}, reverse map substr( $set, $_, 1, q{} ), reverse @boundaries[ 0 .. 3 ]; } } print qq{ $_\n} for @tuples; print qq{ Left over: $set\n} if $set; } #### AAAAADDDDDEFFGMMSSTVVVVV AAAA ADEF DDDD FGMS MSTV VVVV AADDDEEEEFFFFGGMMMMMMMMMMSTV ADEF ADEF DEFG EFGM MMMM MMMM MSTV