From 8fdb3bb27aeb1969315585630d8d6c5c9caeba89 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 3 Apr 2009 19:43:10 -0500
Subject: [PATCH] define a sort-by to take a sequence of comparators without
 slots

---
 basis/sorting/slots/slots-tests.factor | 18 +++++++++++++++++-
 basis/sorting/slots/slots.factor       | 14 ++++++++++++--
 2 files changed, 29 insertions(+), 3 deletions(-)

diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor
index 46824c6fdb..83900461c3 100644
--- a/basis/sorting/slots/slots-tests.factor
+++ b/basis/sorting/slots/slots-tests.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors math.order sorting.slots tools.test
-sorting.human arrays sequences kernel assocs multiline ;
+sorting.human arrays sequences kernel assocs multiline
+sorting.functor ;
 IN: sorting.literals.tests
 
 TUPLE: sort-test a b c tuple2 ;
@@ -76,6 +77,9 @@ TUPLE: tuple2 d ;
 [ { } ]
 [ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
 
+[ { } ]
+[ { } { } sort-by-slots ] unit-test
+
 [
     {
         T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
@@ -143,3 +147,15 @@ TUPLE: tuple2 d ;
         T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
     } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
 ] unit-test
+
+
+[ { "a" "b" "c" } ] [ { "b" "c" "a" } { <=> <=> } sort-by ] unit-test
+[ { "b" "c" "a" } ] [ { "b" "c" "a" } { } sort-by ] unit-test
+
+<< "length-test" [ length ] define-sorting >>
+
+[ { { 1 } { 1 2 3 } { 1 3 2 } { 3 2 1 } } ]
+[
+    { { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
+    { length-test<=> <=> } sort-by
+] unit-test
diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor
index bce9442e44..4b6743af5c 100644
--- a/basis/sorting/slots/slots.factor
+++ b/basis/sorting/slots/slots.factor
@@ -7,6 +7,9 @@ IN: sorting.slots
 
 <PRIVATE
 
+: short-circuit-comparator ( word -- quot )
+    '[ _ execute dup +eq+ eq? [ drop f ] when ] ; inline
+
 : slot-comparator ( seq -- quot )
     [
         but-last-slice
@@ -20,11 +23,18 @@ PRIVATE>
 
 MACRO: compare-slots ( sort-specs -- <=> )
     #! sort-spec: { accessors comparator }
-    '[ _ [ slot-comparator ] map 2|| +eq+ or ] ;
+    [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
 
-: sort-by-slots ( seq sort-specs -- seq' )
+: sort-by-slots ( seq sort-specs -- sortedseq )
     '[ _ compare-slots ] sort ;
 
+MACRO: compare-seq ( seq -- quot )
+    [ short-circuit-comparator ] map '[ _ 2|| +eq+ or ] ;
+
+: sort-by ( seq sort-seq -- sortedseq )
+    '[ _ compare-seq ] sort ;
+
+
 MACRO: split-by-slots ( accessor-seqs -- quot )
     [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
     '[ [ _ 2&& ] slice monotonic-slice ] ;