initial commit

[urisagit/Sort-Maker.git] / paper / field_sort.pl

#!/usr/local/bin/perl

use strict;

# L. Rosler, January 10, 1999
# Interface modeled after
http://www.effectiveperl.com/recipes/sorting.html
# by Joseph Hall.
# @sorted = fieldsort( ['optional split pattern as string',]
# [ anon array of specifiers (strings or optionally signed integers)
# including, in any order:
# optional '-' for reverse sort order,
# required integer for field number (1 = first),
# optional letter for field type:  none = string;
# 'sN' = first N chars of string; 'n' = optionally signed integer;
# 'u' = unsigned integer; 'f' = optionally signed floating-point number
],
# @data);

sub fieldsort {
    my ($col, $cols, @len);
    my $sep = !ref $_[0] && shift;
    ref($cols = shift) eq 'ARRAY' or
        die "Field specifiers must be in an anon array.\n";
    my @cols = map { /^-(\d+)$|^(\d+)-$/ ? $+ : () } @$cols;
    if (@cols) {    # Preprocess variable-width negated string sorts.
        @len = (0) x @$cols;
        my $split = sub { length $sep ? split m{$sep} : split };
        foreach (@_) {
            my @a = $split->();
            foreach $col (@cols) {
                $len[$col - 1] = length $a[$col - 1]
                    if $len[$col - 1] < length $a[$col - 1];
            }
        }
    }
    my ($fixed, @packcode, @packargs) = 0;
    for (@$cols) {
        my ($col) = /(\d+)/ or die "No field specifier in $_.\n";
        my ($let) = /([a-z])/;
        unless ($let) {           # variable-length string
            push @packcode, 'A*x';
            push @packargs,
                "\$a[$col - 1]" . (/-/ && qq{ ^ "\\xFF" x $len[$col -
1]});
            $fixed = -1;
        } elsif ($let eq 's') {   # fixed-length string or substr
            my ($len) = /(\d+)$/ or die "No length specified for field
$col.\n";
            push @packcode, "A$len";
            push @packargs, "\$a[$col - 1]" . (/-/ && qq{ ^ "\\xFF" x
$len});
            $fixed += $len if $fixed > -1;
        } elsif ($let eq 'u') {   # unsigned integer
            push @packcode, 'N';
            push @packargs, (/-/ && '-') . "\$a[$col - 1]";
            $fixed += 4 if $fixed > -1;
        } elsif ($let eq 'n') {   # signed integer
            push @packcode, 'N';
            push @packargs, (/-/ && '-') . "\$a[$col - 1] ^ (1 << 31)";
            $fixed += 4 if $fixed > -1;
        } elsif ($let eq 'f') {   # floating-point number
            push @packcode, 'A8';
            push @packargs, '_float_sort(' . (/-/ && '-') . "\$a[$col -
1])";
            $fixed += 8 if $fixed > -1;
        } else { die "Unrecognized type specifier $let in field $col.\n"
}
    }
    eval 'map substr($_, ' . ($fixed < 0 ? '1 + rindex $_, "\0"' :
$fixed) .
        '), sort map { my @a = split' . (length $sep > 0 && " m{$sep}o")
.
        ";\npack '" . join("", @packcode) .
            ($fixed < 0 && substr($packcode[-1], -1) ne 'x' && 'x') .
            join(",\n", "A*'", @packargs, '$_') . '} @_'
}

BEGIN {
    my $big_endian = pack('N', 1) eq pack('L', 1);
    sub _float_sort {
        (($big_endian ? pack 'd', $_[0] : reverse pack 'd', $_[0]) ^
            ($_[0] < 0 ? "\xFF" x 8 : "\x80" . "\x00" x 7)) . $_[0]
    }
}


#         Example usage:

my (@data, @sorted);
@data = ('abc  2  zzz',  'abc  10  zzz',  'def  2  zzz');
print q{@sorted = fieldsort [2, 1], @data}, "\n";
@sorted = fieldsort [2, 1], @data;
{ local $" = '|'; print "@sorted\n"; }
@data = qw(abc+2+zzz abc+10+zzz abc+2+aaxx abc+2+ab def+2+zzz
abc+-1+zzz);
print q{@sorted = fieldsort '\\+', ['3s2', '-2n', -1], @data}, "\n";
@sorted = fieldsort '\\+', ['3s2', '-2n', -1], @data;
print "@sorted\n";
@data = qw(abc:2:zzz abc:10:zzz abc:2:aaaa def:2:zzz abc:-1:zzz);
print q{@sorted = fieldsort ':', ['2n', -1], @data}, "\n";
@sorted = fieldsort ':', ['2n', -1], @data;
print "@sorted\n";
print q{@sorted = fieldsort ':', ['-2f', -1, '3-'], @data}, "\n";
@sorted = fieldsort ':', ['-2f', -1, '3-'], @data;
print "@sorted\n";
print q{@sorted = fieldsort ':', ['-2n', '-1s3'], @data}, "\n";
@sorted = fieldsort ':', ['-2n', '-1s3'], @data;
print "@sorted\n";
print q{@sorted = fieldsort ':', ['-2n', -1], @data}, "\n";
@sorted = fieldsort ':', ['-2n', -1], @data;
print "@sorted\n";