Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

short sorts

by Lady_Aleena (Chaplain)
on Mar 28, 2012 at 05:52 UTC ( #962078=CUFP: print w/ replies, xml ) Need Help??

Some of you may know that I sort almost everything I use. One day I came upon an idea to put all the different ways I sort things into a subroutine. Those who know me know that I like to randomize things too, so I added a random sort into the mix if a sort type is not chosen.

sub short_sorts { my ($a,$b,$type) = @_; # Legend: # cs = case sensitive # ci = case insensitive # a = ascending # d = descending # r = reverse (right to left) # n = numbers # l = length of value # Note: # If you put $b from the main script into $a in this subroutine and +use descending, # you will actually get the list returned in ascending order. my %sorts = ( 'cs-a' => sub { $_[0] cmp $_[1] }, 'cs-a-r' => sub { reverse($_[0]) cmp reverse($_[1]) }, 'cs-d' => sub { $_[1] cmp $_[0] }, 'cs-d-r' => sub { reverse($_[1]) cmp reverse($_[0]) }, 'ci-a' => sub { uc $_[0] cmp uc $_[1] }, 'ci-a-r' => sub { uc reverse($_[0]) cmp uc reverse($_[1]) }, 'ci-d' => sub { uc $_[1] cmp uc $_[0] }, 'ci-d-r' => sub { uc reverse($_[1]) cmp uc reverse($_[0]) }, 'n-a' => sub { $_[0] <=> $_[1] }, 'n-d' => sub { $_[1] <=> $_[0] }, 'l-a' => sub { length($_[0]) <=> length($_[1]) }, 'l-d' => sub { length($_[1]) <=> length($_[0]) }, ); return $sorts{$type}->($a,$b) if $type; my $random_sort = (keys %sorts)[rand (keys %sorts)]; return $sorts{$random_sort}->($a,$b) if !$type; }

It is used as follows.

my @unsorted_array = qw(red yellow green cyan blue magenta); my @sorted_array = sort { short_sorts($a,$b,'ci-d-r") } @unsorted_arra +y; print "$_\n" for @sorted_array;

That will return the list case insensitively sorted in descending order with the values read in reverse (right to left).

yellow green cyan blue red magenta

This is just another snippet from my small collection of odd subroutines floating about my hard drive. There are two things: I am not sure that I like the hyphens, and can this be expanded further?

Have a cookie and a very nice day!
Lady Aleena

Comment on short sorts
Select or Download Code
Re: short sorts
by GrandFather (Cardinal) on Mar 28, 2012 at 10:12 UTC

    I'd turn things outside in a little and have the sub actually sort the list rather than just supply a compare function especially as the sub name implies that sorting is what it is likely to do. Consider:

    use strict; use warnings; my %sorts = ( 'case' => sub {return sort @_}, 'ignore' => sub {return sort {uc $a cmp uc $b} @_}, 'num' => sub {return sort {$a <=> $b} @_}, 'len' => sub {return sort {length $a <=> length $b} @_}, ); my $modeMatch = '(' . join ('|', keys %sorts) . ')'; sub shortSorts { my ($type, @list) = @_; my ($mode) = lc ($type) =~ $modeMatch; @list = map {scalar reverse $_} @list if $type =~ /\brev\b/i; @list = $sorts{$mode}->(@list); @list = map {scalar reverse $_} @list if $type =~ /\brev\b/i; @list = reverse @list if $type =~ /\bdesc\b/i; return @list; } my @unsorted_array = qw(Red yellow Green cyan Blue magenta); for my $sortType ('case rev desc', 'case desc', 'ignore') { print "$sortType:\n ", join (', ', shortSorts($sortType, @unsort +ed_array)), "\n"; }

    Prints:

    case rev desc: yellow, Green, cyan, Blue, Red, magenta case desc: yellow, magenta, cyan, Red, Green, Blue ignore: Blue, cyan, Green, magenta, Red, yellow
    True laziness is hard work
Re: short sorts
by tobyink (Abbot) on Mar 28, 2012 at 10:20 UTC

    If you add the following, right at the top of your sub (inside the curly braces, but before my ($a, $b, $type)...

    if (@_ == 2) { my ($type, $ref) = @_; $type =~ s/_/-/g; return sort { short_sorts($a, $b, $type) } @$ref; }

    Then it gives you an even shorter syntax for sorting:

    my @list = qw(red orange yellow green blue purple); my @sorted = short_sorts ci_a => \@list; print "@sorted\n"; # says "blue green orange purple red yellow"

    It's probably also worth adding something like this:

    croak "$type is not supported" if $type && !exists $sorts{$type};
    perl -E'sub Monkey::do{say$_,for@_,do{($monkey=[caller(0)]->[3])=~s{::}{ }and$monkey}}"Monkey say"->Monkey::do'

      I'm not certain how the first suggestion would work, so I haven't included it yet. I did use your idea for croak and added it to choroba's observation which I posted at Re^2: short sorts. Thanks! :)

      Have a cookie and a very nice day!
      Lady Aleena
Re: short sorts
by tobyink (Abbot) on Mar 28, 2012 at 11:07 UTC

    It's also worth looking at Sort::Key which adds a nicer sorting syntax to Perl.

    Instead of the usual:

    @sorted = sort { uc $a cmp uc $b } @list;

    You can just write:

    @sorted = keysort { uc } @list;

    You can even sort arrays in place:

    keysort_inplace { uc } @list; # And now @list itself is sorted. We don't # need to create a new array called @sorted.
    perl -E'sub Monkey::do{say$_,for@_,do{($monkey=[caller(0)]->[3])=~s{::}{ }and$monkey}}"Monkey say"->Monkey::do'
Re: short sorts
by choroba (Abbot) on Mar 28, 2012 at 11:40 UTC
    return $sorts{$type}->($a,$b) if $type; my $random_sort = (keys %sorts)[rand (keys %sorts)]; return $sorts{$random_sort}->($a,$b) if !$type;
    The last condition is not needed here: if you can get to the line, $type must be false. Otherwise, you would have returned already.

      Thank you for pointing that out to me. I changed the last lines of the subroutine to include tobyink's suggestion of croak above in Re: short sorts. So now I have a more explicit conditional just to keep things tidy. Thanks! :)

      if ($type) { croak "$type is not supported" if !exists $sorts{$type}; return $sorts{$type}->($a,$b); } else { my $random_sort = (keys %sorts)[rand (keys %sorts)]; return $sorts{$random_sort}->($a,$b); }

      Update

      Since the random sort is not acting as I expected, I decided to just let the subroutine die there.

      if ($type) { croak "$type is not supported" if !exists $sorts{$type}; return $sorts{$type}->($a,$b); } else { die "A sort type was not selected."; }
      Have a cookie and a very nice day!
      Lady Aleena
Re: short sorts
by Arunbear (Parson) on Mar 30, 2012 at 14:48 UTC
    Since you've already got ascending/descending options, passing in $a and $b seems redundant.

    The options could be simplified by mimicking the regex flags e.g. assuming case sensitivity as the default i.e. 'i' meaning case insensitive and no 'i' meaning case sensitive. And also leaving out the hyphens.

    It could be expanded by proving alternate equivalent options so you don't have to remember the order of them e.g. 'idr', 'rid' and 'dir' would all mean insensitive + descending + reversed.

    Example:
    #!/usr/bin/perl use strict; use feature qw(switch say); use List::Util qw(shuffle); sub short_sorter { my ($type) = @_; # Legend: # i = case insensitive # a = ascending # d = descending # r = reverse (right to left) # n = numbers # l = length of value my %sorter = ( 'a' => sub { $a cmp $b }, 'd' => sub { $b cmp $a }, ); given ($type) { when ([qw[dr rd]]) { $sorter{$type} = sub { reverse($b) cmp re +verse($a) }; } when ([qw[ar ra]]) { $sorter{$type} = sub { reverse($a) cmp re +verse($b) }; } when ([qw[ai ia]]) { $sorter{$type} = sub { uc $a cmp uc $b }; + } when ([qw[di id]]) { $sorter{$type} = sub { uc $b cmp uc $a }; + } when ([qw[an na]]) { $sorter{$type} = sub { $a <=> $b }; } when ([qw[nd dn]]) { $sorter{$type} = sub { $b <=> $a }; } when ([qw[la al]]) { $sorter{$type} = sub { length($a) <=> len +gth($b) }; } when ([qw[ld dl]]) { $sorter{$type} = sub { length($b) <=> len +gth($a) }; } when ([qw[air ari iar ira rai ria]]) { $sorter{$type} = sub { uc reverse($a) cmp uc reverse($b) } +; } when ([qw[dir dri idr ird rdi rid]]) { $sorter{$type} = sub { uc reverse($b) cmp uc reverse($a) } +; } } if ($type) { return $sorter{$type} or die 'AAARGH!!'; } else { return (shuffle values %sorter)[0]; } } my @unsorted = qw(red lilac yelloW green cyan blue magenta); my $criteria = short_sorter('dir'); my @sorted = sort $criteria @unsorted; print "$_\n" for @sorted; __DATA__ yelloW green cyan blue red lilac magenta

    Update

    The random option doesn't do the right thing in this version

    Update 2

    Corrected with respect to random option:

      Thank you for pointing out that the options should not be so rigid Arundear. I changed the dispatch table to include the option variations, even though I did not use switch like you did. I also kept case sensitive in because I like it. (I know that is not the best reason, but it is why case sensitivity is still there.)

      sub short_sorts { my ($a,$b,$type) = @_; # Legend: # s = case sensitive # i = case insensitive # a = ascending # d = descending # r = reverse (right to left) # n = numbers # l = length of value my %sorts; $sorts{$_} = sub { $_[0] cmp $_[1] } for qw(sa as); $sorts{$_} = sub { $_[1] cmp $_[0] } for qw(sd ds); $sorts{$_} = sub { uc $_[0] cmp uc $_[1] } for qw(ia ai); $sorts{$_} = sub { uc $_[1] cmp uc $_[0] } for qw(id di); $sorts{$_} = sub { $_[0] <=> $_[1] } for qw(na an); $sorts{$_} = sub { $_[1] <=> $_[0] } for qw(nd dn); $sorts{$_} = sub { reverse($_[0]) cmp reverse($_[1]) } for qw(sar sr +a asr ars rsa ras); $sorts{$_} = sub { reverse($_[1]) cmp reverse($_[0]) } for qw(sdr sr +d dsr drs rsd rds); $sorts{$_} = sub { uc reverse($_[0]) cmp uc reverse($_[1]) } for qw( +iar ira air ari ria rai); $sorts{$_} = sub { uc reverse($_[1]) cmp uc reverse($_[0]) } for qw( +idr ird dir dri rid rdi); $sorts{$_} = sub { reverse $_[0] <=> reverse $_[1] } for qw(nar nra +anr arn rna ran); $sorts{$_} = sub { reverse $_[1] <=> reverse $_[0] } for qw(ndr nrd +dnr drn rnd rdn); $sorts{$_} = sub { length($_[0]) <=> length($_[1]) } for qw(la al); $sorts{$_} = sub { length($_[1]) <=> length($_[0]) } for qw(ld dl); if ($type) { croak "$type is not supported" if !exists $sorts{$type}; return $sorts{$type}->($a,$b); } else { # A random sort was here, however, it was not acting as expected, +so the die is being used. die "A sort type was not selected."; } }

      I'm still passing $a and $b since there are times where I am sorting hashes by a key within a hash of hashes.

      (sort { short_sorts($master_list{$a}{members},$master_list{$b}{members},'nd' +) || short_sorts($a,$b,'ia') } keys %master_list)

      I am not sure how I am going to combine those just yet.

      Have a cookie and a very nice day!
      Lady Aleena

        In what way does the random sort not work?

        Just for fun, an example of going functional ;)
        #!/usr/bin/perl use strict; use Data::Dump qw(dd pp); use List::Util qw(reduce shuffle); # the composables sub Cmp { my ($x, $y) = @_; $x cmp $y } sub Ncmp { my ($x, $y) = @_; $x <=> $y } sub Reverse { map { scalar reverse $_ } @_ } sub Length { map { length $_ } @_ } sub Uc { map { uc $_ } @_ } sub Transpose { reverse @_ } sub Ab { ($a, $b) } # naive composer using evil # composes functions f, g, h into sub { f(g(h(@_))) } sub Compose { my $body = reduce { "$b($a)" } '@_', reverse @_; eval "sub { $body }" or die $@; } # special case for sort sub Compose_ab { Compose(@_, 'Ab') } sub sorter { my ($type, $src) = @_; # Legend: # i = case insensitive # a = ascending # d = descending # r = reverse (right to left) # n = numbers # l = length of value my %sorter = ( a => [qw/Cmp/], d => [qw/Cmp Transpose/], ai => [qw/Cmp Uc/], di => [qw/Cmp Uc Transpose/], an => [qw/Ncmp/], dn => [qw/Ncmp Transpose/], al => [qw/Ncmp Length/], dl => [qw/Ncmp Length Transpose/], ar => [qw/Cmp Reverse/], dr => [qw/Cmp Reverse Transpose/], air => [qw/Cmp Uc Reverse/], dir => [qw/Cmp Uc Reverse Transpose/], ); my @composed; if ($type) { $type = join '', sort split //, $type; # normalize @composed = @{ $sorter{$type} } or die "Unknown option: $type"; if ($src) { push @composed, $src; } } else { @composed = @{ (shuffle values %sorter)[0] }; warn 'random criteria: ' . pp @composed; } return Compose_ab(@composed); } my @unsorted = qw(red lilac yelloW Green cyan blue magenta); my $sort_type = shift; my $criteria = sorter($sort_type); dd sort $criteria @unsorted; my %master_list = ( alpha => { members => 1 }, beta => { members => 3 }, gamma => { members => 8 }, delta => { members => 5 }, ); # custom source for $a, $b sub Members { map { $master_list{$_}{members} } @_ } $criteria = sorter($sort_type, 'Members'); dd sort $criteria keys %master_list;

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://962078]
Approved by GrandFather
Front-paged by Arunbear
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others cooling their heels in the Monastery: (8)
As of 2014-07-28 06:59 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (192 votes), past polls