use strict;
use warnings;
package Sort::ByExample 0.008;
# ABSTRACT: sort lists to look like the example you provide

#pod =head1 SYNOPSIS
#pod
#pod   use Sort::ByExample
#pod    cmp    => { -as => 'by_eng',   example => [qw(first second third fourth)] },
#pod    sorter => { -as => 'eng_sort', example => [qw(first second third fourth)] };
#pod
#pod   my @output = eng_sort(qw(second third unknown fourth first));
#pod   # --> first second third fourth unknown
#pod
#pod   # ...or...
#pod
#pod   my @output = sort by_eng qw(second third unknown fourth first);
#pod   # --> first second third fourth unknown
#pod
#pod   # ...or...
#pod
#pod   my $sorter = Sort::ByExample::sbe(\@example);
#pod   my @output = $sorter->( qw(second third unknown fourth first) );
#pod   # --> first second third fourth unknown
#pod
#pod   # ...or...
#pod
#pod   my $example = [ qw(charlie alfa bravo) ];
#pod   my @input   = (
#pod     { name => 'Bertrand', codename => 'bravo'   },
#pod     { name => 'Dracover', codename => 'zulu',   },
#pod     { name => 'Cheswick', codename => 'charlie' },
#pod     { name => 'Elbereth', codename => 'yankee'  },
#pod     { name => 'Algernon', codename => 'alfa'    },
#pod   );
#pod
#pod   my $fallback = sub {
#pod     my ($x, $y) = @_;
#pod     return $x cmp $y;
#pod   };
#pod
#pod   my $sorter = sbe(
#pod     $example,
#pod     {
#pod       fallback => $fallback,
#pod       xform    => sub { $_[0]->{codename} },
#pod     },
#pod   );
#pod
#pod   my @output = $sorter->(@input);
#pod
#pod   # --> (
#pod   #       { name => 'Cheswick', codename => 'charlie' },
#pod   #       { name => 'Algernon', codename => 'alfa'    },
#pod   #       { name => 'Bertrand', codename => 'bravo'   },
#pod   #       { name => 'Elbereth', codename => 'yankee'  },
#pod   #       { name => 'Dracover', codename => 'zulu',   },
#pod   #     );
#pod
#pod =head1 DESCRIPTION
#pod
#pod Sometimes, you need to sort things in a pretty arbitrary order.  You know that
#pod you might encounter any of a list of values, and you have an idea what order
#pod those values go in.  That order is arbitrary, as far as actual automatic
#pod comparison goes, but that's the order you want.
#pod
#pod Sort::ByExample makes this easy:  you give it a list of example input it should
#pod expect, pre-sorted, and it will sort things that way.  If you want, you can
#pod provide a fallback sub for sorting unknown or equally-positioned data.
#pod
#pod =cut

use Params::Util qw(_HASHLIKE _ARRAYLIKE _CODELIKE);
use Sub::Exporter -setup => {
  exports => {
    sbe    => undef,
    cmp    => \'_build_cmp',
    sorter => \'_build_sorter',
  },
};

#pod =method sorter
#pod
#pod   my $sorter = Sort::ByExample->sorter($example, $fallback);
#pod   my $sorter = Sort::ByExample->sorter($example, \%arg);
#pod
#pod The sorter method returns a subroutine that will sort lists to look more like
#pod the example list.
#pod
#pod C<$example> may be a reference to an array, in which case input will be sorted
#pod into the same order as the data in the array reference.  Input not found in the
#pod example will be found at the end of the output, sorted by the fallback sub if
#pod given (see below).
#pod
#pod Alternately, the example may be a reference to a hash.  Values are used to
#pod provide sort orders for input values.  Input values with the same sort value
#pod are sorted by the fallback sub, if given.
#pod
#pod If given named arguments as C<%arg>, valid arguments are:
#pod
#pod   fallback - a sub to sort data
#pod   xform    - a sub to transform each item into the key to sort
#pod
#pod If no other named arguments are needed, the fallback sub may be given in place
#pod of the arg hashref.
#pod
#pod The fallback sub should accept two inputs and return either 1, 0, or -1, like a
#pod normal sorting routine.  The data to be sorted are passed as parameters.  For
#pod uninteresting reasons, C<$a> and C<$b> can't be used.
#pod
#pod The xform sub should accept one argument and return the data by which to sort
#pod that argument.  In other words, to sort a group of athletes by their medals:
#pod
#pod   my $sorter = sbe(
#pod     [ qw(Gold Silver Bronze) ],
#pod     {
#pod       xform => sub { $_[0]->medal_metal },
#pod     },
#pod   );
#pod
#pod If both xform and fallback are given, then four arguments are passed to
#pod fallback:
#pod
#pod   a_xform, b_xform, a_original, b_original
#pod
#pod =method cmp
#pod
#pod   my $comparitor = Sort::ByExample->cmp($example, \%arg);
#pod
#pod This routine expects the same sort of arguments as C<L</sorter>>, but returns a
#pod subroutine that behaves like a C<L<sort|perlfunc/sort>> comparitor.  It will
#pod take two arguments and return 1, 0, or -1.
#pod
#pod C<cmp> I<must not> be given an C<xform> argument or an exception will be
#pod raised.  This behavior may change in the future, but because a
#pod single-comparison comparitor cannot efficiently perform a L<Schwartzian
#pod transform|http://en.wikipedia.org/wiki/Schwartzian_transform>, using a
#pod purpose-build C<L</sorter>> is a better idea.
#pod
#pod =head1 EXPORTS
#pod
#pod =head2 sbe
#pod
#pod C<sbe> behaves just like C<L</sorter>>, but is a function rather than a method.
#pod It may be imported by request.
#pod
#pod =head2 sorter
#pod
#pod The C<sorter> export builds a function that behaves like the C<sorter> method.
#pod
#pod =head2 cmp
#pod
#pod The C<cmp> export builds a function that behaves like the C<cmp> method.
#pod Because C<sort> requires a named sub, importing C<cmp> can be very useful:
#pod
#pod   use Sort::ByExample
#pod    cmp    => { -as => 'by_eng',   example => [qw(first second third fourth)] };
#pod
#pod   my @output = sort by_eng qw(second third unknown fourth first);
#pod   # --> first second third fourth unknown
#pod
#pod =cut

sub sbe { __PACKAGE__->sorter(@_) }

sub __normalize_args {
  my ($self, $example, $arg) = @_;

  my $score = 0;
  my %score = _HASHLIKE($example)  ? %$example
            : _ARRAYLIKE($example) ? (map { $_ => $score++ } @$example)
            : Carp::confess "invalid example data given to Sort::ByExample";

  my $fallback;
  if (_HASHLIKE($arg)) {
    $fallback = $arg->{fallback};
  } else {
    $fallback = $arg;
    $arg = {};
  }

  Carp::croak "invalid fallback routine"
    if $fallback and not _CODELIKE($fallback);

  return (\%score, $fallback, $arg);
}

sub __cmp {
  my ($self, $score, $fallback, $arg) = @_;

  return sub ($$) {
    my ($a, $b) = @_;
      (exists $score->{$a} && exists $score->{$b})
        ? ($score->{$a} <=> $score->{$b}) || ($fallback ? $fallback->($a, $b) : 0)
    : exists $score->{$a}                        ? -1
    : exists $score->{$b}                        ? 1
    : ($fallback ? $fallback->($a, $b) : 0)
  };
}

sub cmp {
  my ($self, $example, $rest) = @_;

  my ($score, $fallback, $arg) = $self->__normalize_args($example, $rest);

  Carp::confess "you may not build a transformation into a comparitor"
    if $arg->{xform};

  $self->__cmp($score, $fallback, $arg);
}

sub sorter {
  my ($self, $example, $rest) = @_;

  my ($score, $fallback, $arg) = $self->__normalize_args($example, $rest);

  if (my $xf = $arg->{xform}) {
    return sub {
      map  { $_->[1] }
      sort {
        (exists $score->{$a->[0]} && exists $score->{$b->[0]})
          ? ($score->{$a->[0]} <=> $score->{$b->[0]})
            || ($fallback ? $fallback->($a->[0], $b->[0], $a->[1], $b->[1]) : 0)
      : exists $score->{$a->[0]}                        ? -1
      : exists $score->{$b->[0]}                        ? 1
      : ($fallback ? $fallback->($a->[0], $b->[0], $a->[1], $b->[1]) : 0)
      } map { [ $xf->($_), $_ ] } @_;
    }
  }

  my $cmp = $self->__cmp($score, $fallback, $arg);

  sub { sort { $cmp->($a, $b) } @_ }
}

sub _build_sorter {
  my ($self, $name, $arg) = @_;
  my ($example) = $arg->{example};
  local $arg->{example};

  $self->sorter($example, $arg);
}

sub _build_cmp {
  my ($self, $name, $arg) = @_;
  my ($example) = $arg->{example};
  local $arg->{example};

  $self->cmp($example, $arg);
}

#pod =head1 TODO
#pod
#pod =for :list
#pod * provide a way to say "these things occur after any unknowns"
#pod
#pod =cut

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Sort::ByExample - sort lists to look like the example you provide

=head1 VERSION

version 0.008

=head1 SYNOPSIS

  use Sort::ByExample
   cmp    => { -as => 'by_eng',   example => [qw(first second third fourth)] },
   sorter => { -as => 'eng_sort', example => [qw(first second third fourth)] };

  my @output = eng_sort(qw(second third unknown fourth first));
  # --> first second third fourth unknown

  # ...or...

  my @output = sort by_eng qw(second third unknown fourth first);
  # --> first second third fourth unknown

  # ...or...

  my $sorter = Sort::ByExample::sbe(\@example);
  my @output = $sorter->( qw(second third unknown fourth first) );
  # --> first second third fourth unknown

  # ...or...

  my $example = [ qw(charlie alfa bravo) ];
  my @input   = (
    { name => 'Bertrand', codename => 'bravo'   },
    { name => 'Dracover', codename => 'zulu',   },
    { name => 'Cheswick', codename => 'charlie' },
    { name => 'Elbereth', codename => 'yankee'  },
    { name => 'Algernon', codename => 'alfa'    },
  );

  my $fallback = sub {
    my ($x, $y) = @_;
    return $x cmp $y;
  };

  my $sorter = sbe(
    $example,
    {
      fallback => $fallback,
      xform    => sub { $_[0]->{codename} },
    },
  );

  my @output = $sorter->(@input);

  # --> (
  #       { name => 'Cheswick', codename => 'charlie' },
  #       { name => 'Algernon', codename => 'alfa'    },
  #       { name => 'Bertrand', codename => 'bravo'   },
  #       { name => 'Elbereth', codename => 'yankee'  },
  #       { name => 'Dracover', codename => 'zulu',   },
  #     );

=head1 DESCRIPTION

Sometimes, you need to sort things in a pretty arbitrary order.  You know that
you might encounter any of a list of values, and you have an idea what order
those values go in.  That order is arbitrary, as far as actual automatic
comparison goes, but that's the order you want.

Sort::ByExample makes this easy:  you give it a list of example input it should
expect, pre-sorted, and it will sort things that way.  If you want, you can
provide a fallback sub for sorting unknown or equally-positioned data.

=head1 PERL VERSION

This library should run on perls released even a long time ago.  It should work
on any version of perl released in the last five years.

Although it may work on older versions of perl, no guarantee is made that the
minimum required version will not be increased.  The version may be increased
for any reason, and there is no promise that patches will be accepted to lower
the minimum required perl.

=head1 METHODS

=head2 sorter

  my $sorter = Sort::ByExample->sorter($example, $fallback);
  my $sorter = Sort::ByExample->sorter($example, \%arg);

The sorter method returns a subroutine that will sort lists to look more like
the example list.

C<$example> may be a reference to an array, in which case input will be sorted
into the same order as the data in the array reference.  Input not found in the
example will be found at the end of the output, sorted by the fallback sub if
given (see below).

Alternately, the example may be a reference to a hash.  Values are used to
provide sort orders for input values.  Input values with the same sort value
are sorted by the fallback sub, if given.

If given named arguments as C<%arg>, valid arguments are:

  fallback - a sub to sort data
  xform    - a sub to transform each item into the key to sort

If no other named arguments are needed, the fallback sub may be given in place
of the arg hashref.

The fallback sub should accept two inputs and return either 1, 0, or -1, like a
normal sorting routine.  The data to be sorted are passed as parameters.  For
uninteresting reasons, C<$a> and C<$b> can't be used.

The xform sub should accept one argument and return the data by which to sort
that argument.  In other words, to sort a group of athletes by their medals:

  my $sorter = sbe(
    [ qw(Gold Silver Bronze) ],
    {
      xform => sub { $_[0]->medal_metal },
    },
  );

If both xform and fallback are given, then four arguments are passed to
fallback:

  a_xform, b_xform, a_original, b_original

=head2 cmp

  my $comparitor = Sort::ByExample->cmp($example, \%arg);

This routine expects the same sort of arguments as C<L</sorter>>, but returns a
subroutine that behaves like a C<L<sort|perlfunc/sort>> comparitor.  It will
take two arguments and return 1, 0, or -1.

C<cmp> I<must not> be given an C<xform> argument or an exception will be
raised.  This behavior may change in the future, but because a
single-comparison comparitor cannot efficiently perform a L<Schwartzian
transform|http://en.wikipedia.org/wiki/Schwartzian_transform>, using a
purpose-build C<L</sorter>> is a better idea.

=head1 EXPORTS

=head2 sbe

C<sbe> behaves just like C<L</sorter>>, but is a function rather than a method.
It may be imported by request.

=head2 sorter

The C<sorter> export builds a function that behaves like the C<sorter> method.

=head2 cmp

The C<cmp> export builds a function that behaves like the C<cmp> method.
Because C<sort> requires a named sub, importing C<cmp> can be very useful:

  use Sort::ByExample
   cmp    => { -as => 'by_eng',   example => [qw(first second third fourth)] };

  my @output = sort by_eng qw(second third unknown fourth first);
  # --> first second third fourth unknown

=head1 TODO

=over 4

=item *

provide a way to say "these things occur after any unknowns"

=back

=head1 AUTHOR

Ricardo SIGNES <cpan@semiotic.systems>

=head1 CONTRIBUTORS

=for stopwords Olaf Alders Ricardo Signes

=over 4

=item *

Olaf Alders <olaf@wundersolutions.com>

=item *

Ricardo Signes <rjbs@semiotic.systems>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2007 by Ricardo SIGNES.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut