#! perl -slw use strict; sub mapNM (&@) { my $code = shift; map{ local( *a, *b ) = \( @_[ 0, 1 ] ); $code->(shift); # } 0 .. @_ - 2 } 0 .. @_ - 1 } sub strcmp{ my( $p, $b ) = ( $_[2]||0, 0 ); $p++ until $b = substr( $_[ 0 ], $p, 1 ) cmp substr( $_[ 1 ], $p, 1 ); $p * $b; }; my @names = sort map{ join' ', map{ $_ = ucfirst } split '[^a-z0-9]+', lc } ; my %abbrev; print "@$_" for mapNM{ if( defined $b ) { my $n = 0; while( exists $abbrev{ $a->[ 0 ] } or $a->[ 0 ] eq $b->[ 0 ] ) { $n = strcmp $a->[ 1 ], $b->[ 1 ], abs($n)+1; if( $n ) { $a->[ 0 ] .= substr( $a->[ 1 ], abs $n, 1 ); $b->[ 0 ] .= substr( $b->[ 1 ], abs $n, 1 ); } } } $abbrev{ $a->[ 0 ] } = undef; $a } sort{ $a->[ 0 ] cmp $b->[ 0 ] } map{ [ join('', m[([A-Z])]g), $_ ] #} @names, 'ZZZZZZZZZZZZ'; } @names;