sorting.extras: adding compare-with.

This compares a sequence of quotations, returning early if any quotation
produces +lt+ or +gt+, but continuing to the next if it returns +eq+.

diff --git a/extra/sorting/extras/extras-tests.factor b/extra/sorting/extras/extras-tests.factor
index b15b2849a2b95ff9fedb0239c648643f37a8db4a..78dadb6fe12578f772af80dea47645cff119766b 100644 (file)
--- a/extra/sorting/extras/extras-tests.factor
+++ b/extra/sorting/extras/extras-tests.factor
@@ -31,3 +31,9 @@ IN: sorting.extras
     10 <iota> >array randomize
     [ swap insort-right! ] each
 ] unit-test
+
+{ +gt+ } [ "lady" "bug" { [ length ] [ first ] } compare-with ] unit-test
+{ +lt+ } [ "bug" "lady" { [ length ] [ first ] } compare-with ] unit-test
+{ +eq+ } [ "bat" "bat" { [ length ] [ first ] } compare-with ] unit-test
+{ +lt+ } [ "bat" "cat" { [ length ] [ first ] } compare-with ] unit-test
+{ +gt+ } [ "fat" "cat" { [ length ] [ first ] } compare-with ] unit-test

diff --git a/extra/sorting/extras/extras.factor b/extra/sorting/extras/extras.factor
index 949c54885bd9b3ad8c9b1139847a08444e351c37..06b9e53b6d70c08d146804099d43cca416dce94b 100644 (file)
--- a/extra/sorting/extras/extras.factor
+++ b/extra/sorting/extras/extras.factor
@@ -35,3 +35,8 @@ IN: sorting.extras
 
 : insort-right! ( obj seq -- seq )
     [ bisect-right ] 2keep swapd [ insert-nth! ] keep ;
+
+MACRO: compare-with ( quots -- <=> )
+    [ '[ _ bi@ <=> ] ]
+    [ '[ _ 2keep rot dup +eq+ eq? [ drop @ ] [ 2nip ] if ] ]
+    map-reduce ;