1: # Have you ever had to sort a list of lists by a value in the middle of the lower lists?
   2: # The Shwartzian transform will do this, but i was concerned about the speed of the operation.
   3: # This module came about from implementing such a sort on the different possible groups on a
   4: # unix system so that the sysadmin can choose which group to put a new user into (using
   5: # a tk menu if he/she so desires).  The end result is an n log n sort technique that doesn't
   6: # have to look at all of the values of the array it's sorting (relatively)...
   7: # In fact, the `sort' call takes the most time of anything
   8: #
   9: # jynx
  10: 
  11: # Formats:                                              #
  12: #       AnonSort(\@array, $val_to_sort_by, $is_string)  #
  13: #   where $is_string is either 1 or 0.  1 if it is.     #
  14: #                                                       #
  15: #       binsrch(\@array, $val_to_sort_by, $is_string)   #
  16: #                                                       #
  17: #        -or if you want just a portion organized-      #
  18: #                                                       #
  19: #  binsrch(\@ar, $val, $is_string, $hi_mark, $lo_mark)  #
  20: #                                                       #
  21: #   NOTE: The value to sort by is the index NUMBER in   #
  22: #         the anonymous arrays that you want to be the  #
  23: #         pivotal position for sorting.  So for instance#
  24: #         if you want the 3rd position to be sorted by, #
  25: #         put 3.                                        #
  26: 
  27: 
  28: package AnonSort;
  29: use strict;
  30: require Exporter;
  31: our @ISA       = qw(Exporter);
  32: our @EXPORT    = qw(AnonSort);
  33: our @EXPORT_OK = qw(binsrch);
  34: our $VERSION   = 1.0;
  35: 
  36: sub AnonSort {
  37:    my ($anon, $val, $str);
  38:    ($anon, $val, $str) = @_;
  39: 
  40: # pull out the values to sort by and sort
  41:    my (@st, @temp);
  42:    foreach (@{ $anon }) { push @st, $_->[$val] }
  43:    @st = sort @st;
  44: 
  45: # now arrange the original array of arrays...
  46: #
  47: # a little note:  since this is a closed set we can sift through until we get
  48: #   the first spot into where it's supposed to be because we don't have to
  49: #   worry about accidently not having an element.  also, as opposed to the
  50: #   bubble sort, we have a secondary list that's already sorted, so we binary
  51: #   search on that until we have the right entry for a spot.  THEN and only
  52: #   then step to the next spot.  then find the right entry for that spot and
  53: #   so on and so forth...
  54: #
  55:    for (my $i = 0; $i <= $#{ $anon }; $i++) {
  56:    until (($str)?($anon->[$i][$val] eq $st[$i]):($anon->[$i][$val] == $st[$i]) ){
  57:       my $j = &binsrch(\@st, $anon->[$i][$val], $str);
  58:       if ($i != $j) {
  59:          @temp = @{ $anon->[$j] };
  60:          @{ $anon->[$j] } = @{ $anon->[$i] };
  61:          @{ $anon->[$i] } = @temp;
  62:       }
  63:    }		## end while loop.
  64:    }		## end of for loop
  65: 
  66: # return the (now sorted) reference to the original array
  67: return $anon;
  68: }
  69:          
  70: #
  71: # i have to define these for the use strict...
  72: my ($s, $val, $str, $hi, $lo, $mid);
  73: 
  74: #
  75: # this is a binary search through arrays.  it returns -1 if not found
  76: #   or the palce where the value is.
  77: #
  78: sub binsrch {
  79:    ($s, $val, $str, $hi, $lo, $mid) = @_;
  80: 
  81: # because of a bug, return the last element if val's in the last element...
  82: # Also, the trinary operator makes the if statement bail.  Don't even think
  83: # about it (i don't know why it bails, but it does)
  84:    if ($str) {
  85:       return $#{ $s } if ($val eq $s->[$#{ $s }]);
  86:    } else {
  87:       return $#{ $s } if ($val == $s->[$#{ $s }]);
  88:    }
  89: 
  90: # if $hi and $lo aren't defined (read: first iteration), define them
  91:    $hi = $#{ $s } unless defined $hi;
  92:    $lo = 0   unless defined $lo;
  93:    return -1 if ($lo == $hi);
  94: 
  95: # set mid and do the search.  recursion's ok, i'm throwing around references...
  96:    $mid = int ( ($hi + $lo) / 2 );
  97:    if ($str) {
  98:     return $mid if ($s->[$mid] eq $val);
  99:     ($hi = $mid and binsrch($s, $val, $str, $hi, $lo) ) if ($s->[$mid] gt $val);
 100:     ($lo = $mid and binsrch($s, $val, $str, $hi, $lo) ) if ($s->[$mid] lt $val);
 101:    } else {
 102:     return $mid if ($s->[$mid] == $val);
 103:     ($hi = $mid and binsrch($s, $val, $str, $hi, $lo) ) if ($s->[$mid] > $val);
 104:     ($lo = $mid and binsrch($s, $val, $str, $hi, $lo) ) if ($s->[$mid] < $val);
 105:    }
 106: 
 107: # return -1 if the value we're looking for isn't where it's supposed to be
 108: # The trinary operator makes this if statement bail as well.  By bail i mean it
 109: # won't even compile!
 110:    if ($str) {
 111:       return -1 if ($val ne $s->[$mid]);
 112:    } else {
 113:       return -1 if ($val != $s->[$mid]);
 114:    }
 115: 
 116: # otherwise return the value (to previous level)
 117:    return $mid;
 118: }
 119: 
 120: 
 121: 1;
 122: 
 123: 
 124: # stop scolling, isn't that enough work?
 125: #
 126: # Sorry if this double posts, but the line wrapping got screwed up on the
 127: # first one so this version is better for the cut and paste