Sorting by sequences of accessor/comparator pairs

basis/sorting/slots/authors.txt

@@ -0,0 +1,2 @@
+Doug Coleman
+Slava Pestov

basis/sorting/slots/slots-docs.factor

@@ -0,0 +1,42 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations math.order
+sequences ;
+IN: sorting.slots
+
+HELP: compare-slots
+{ $values
+     { "sort-specs" "a sequence of accessor/comparator pairs" }
+     { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
+}
+{ $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ;
+
+HELP: sort-by-slots
+{ $values
+     { "seq" sequence } { "sort-specs" "a sequence of accessor/comparator pairs" }
+     { "seq'" sequence }
+}
+{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a slot accessor and a comparator." }
+{ $examples
+    "Sort by slot c, then b descending:"
+    { $example
+        "USING: accessors math.order prettyprint sorting.slots ;"
+        "IN: scratchpad"
+        "TUPLE: sort-me a b ;"
+        "{"
+        "    T{ sort-me f 2 3 } T{ sort-me f 3 2 }"
+        "    T{ sort-me f 4 3 } T{ sort-me f 2 1 }"
+        "}"
+        "{ { a>> <=> } { b>> >=< } } sort-by-slots ."
+        "{\n    T{ sort-me { a 2 } { b 3 } }\n    T{ sort-me { a 2 } { b 1 } }\n    T{ sort-me { a 3 } { b 2 } }\n    T{ sort-me { a 4 } { b 3 } }\n}"
+    }
+} ;
+
+ARTICLE: "sorting.slots" "Sorting by slots"
+"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
+"Comparing two objects by a sequence of slots:"
+{ $subsection compare-slots }
+"Sorting a sequence by a sequence of slots:"
+{ $subsection sort-by-slots } ;
+
+ABOUT: "sorting.slots"

basis/sorting/slots/slots-tests.factor

@@ -0,0 +1,50 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math.order sorting.slots tools.test
+sorting.human ;
+IN: sorting.literals.tests
+
+TUPLE: sort-test a b c ;
+
+[
+    {
+        T{ sort-test { a 1 } { b 3 } { c 9 } }
+        T{ sort-test { a 1 } { b 1 } { c 10 } }
+        T{ sort-test { a 1 } { b 1 } { c 11 } }
+        T{ sort-test { a 2 } { b 5 } { c 2 } }
+        T{ sort-test { a 2 } { b 5 } { c 3 } }
+    }
+] [
+    {
+        T{ sort-test f 1 3 9 }
+        T{ sort-test f 1 1 10 }
+        T{ sort-test f 1 1 11 }
+        T{ sort-test f 2 5 3 }
+        T{ sort-test f 2 5 2 }
+    } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
+] unit-test
+
+[
+    {
+        T{ sort-test { a 1 } { b 3 } { c 9 } }
+        T{ sort-test { a 1 } { b 1 } { c 10 } }
+        T{ sort-test { a 1 } { b 1 } { c 11 } }
+        T{ sort-test { a 2 } { b 5 } { c 2 } }
+        T{ sort-test { a 2 } { b 5 } { c 3 } }
+    }
+] [
+    {
+        T{ sort-test f 1 3 9 }
+        T{ sort-test f 1 1 10 }
+        T{ sort-test f 1 1 11 }
+        T{ sort-test f 2 5 3 }
+        T{ sort-test f 2 5 2 }
+    } { { a>> human-<=> } { b>> human->=< } { c>> <=> } } sort-by-slots
+] unit-test
+
+[
+    { }
+] [
+    { }
+    { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
+] unit-test

basis/sorting/slots/slots.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit fry kernel macros math.order
+sequences words sorting ;
+IN: sorting.slots
+
+<PRIVATE
+
+: slot-comparator ( accessor comparator -- quot )
+    '[ [ _ execute ] bi@ _ execute dup +eq+ eq? [ drop f ] when ] ;
+
+PRIVATE>
+
+MACRO: compare-slots ( sort-specs -- <=> )
+    #! sort-spec: { accessor comparator }
+    [ first2 slot-comparator ] map '[ _ 2|| +eq+ or ] ;
+
+: sort-by-slots ( seq sort-specs -- seq' )
+    '[ _ compare-slots ] sort ;