diff --git a/basis/sorting/slots/authors.txt b/basis/sorting/slots/authors.txt new file mode 100644 index 0000000000..5674120196 --- /dev/null +++ b/basis/sorting/slots/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor new file mode 100644 index 0000000000..64d0a1efdf --- /dev/null +++ b/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" diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor new file mode 100644 index 0000000000..ab130d1eed --- /dev/null +++ b/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 diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor new file mode 100644 index 0000000000..02a11428f9 --- /dev/null +++ b/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 + + + +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 ;