Merge branch 'master' of git://factorcode.org/git/factor

phildawes · Aug 3, 2009 · 961c49a · 961c49a
2 parents d1479ea + 09b2acb
commit 961c49a
Show file tree

Hide file tree

Showing 21 changed files with 44 additions and 29 deletions.
diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor
@@ -365,7 +365,7 @@ M: character-type (<fortran-result>)
     ] bi* ;
 
 : (fortran-in-shuffle) ( ret par -- seq )
-    [ [ second ] bi@ <=> ] sort append ;
+    [ second ] sort-with append ;
 
 : (fortran-out-shuffle) ( ret par -- seq )
     append ;

diff --git a/basis/compiler/cfg/ssa/interference/interference.factor b/basis/compiler/cfg/ssa/interference/interference.factor
@@ -58,7 +58,7 @@ PRIVATE>
 : sort-vregs-by-bb ( vregs -- alist )
     defs get
     '[ dup _ at ] { } map>assoc
-    [ [ second pre-of ] compare ] sort ;
+    [ second pre-of ] sort-with ;
 
 : ?last ( seq -- elt/f ) [ f ] [ last ] if-empty ; inline
 

diff --git a/basis/heaps/heaps-tests.factor b/basis/heaps/heaps-tests.factor
@@ -52,7 +52,7 @@ IN: heaps.tests
 ] each
 
 : sort-entries ( entries -- entries' )
-    [ [ key>> ] compare ] sort ;
+    [ key>> ] sort-with ;
 
 : delete-test ( n -- obj1 obj2 )
     [

diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor
@@ -115,7 +115,7 @@ TUPLE: result title href ;
     load-index swap >lower
     '[ [ drop _ ] dip >lower subseq? ] assoc-filter
     [ swap result boa ] { } assoc>map
-    [ [ title>> ] compare ] sort ;
+    [ title>> ] sort-with ;
 
 : article-apropos ( string -- results )
     "articles.idx" offline-apropos ;

diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor
@@ -46,7 +46,7 @@ PRIVATE>
     array>> [ value ] map ;
 
 : <interval-map> ( specification -- map )
-    all-intervals [ [ first second ] compare ] sort
+    all-intervals [ first second ] sort-with
     >intervals ensure-disjoint interval-map boa ;
 
 : <interval-set> ( specification -- map )

diff --git a/basis/splitting/monotonic/monotonic.factor b/basis/splitting/monotonic/monotonic.factor
@@ -64,6 +64,6 @@ TUPLE: upward-slice < slice ;
             drop
             [ downward-slices ]
             [ stable-slices ]
-            [ upward-slices ] tri 3append [ [ from>> ] compare ] sort
+            [ upward-slices ] tri 3append [ from>> ] sort-with
         ]
     } case ;
diff --git a/basis/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor
@@ -65,7 +65,7 @@ M: ---- <menu-item>
 : <operations-menu> ( target hook -- menu )
     over object-operations
     [ primary-operation? ] partition
-    [ reverse ] [ [ [ command-name ] compare ] sort ] bi*
+    [ reverse ] [ [ command-name ] sort-with ] bi*
     { ---- } glue <commands-menu> ;
 
 : show-operations-menu ( gadget target hook -- )

diff --git a/basis/ui/tools/inspector/inspector.factor b/basis/ui/tools/inspector/inspector.factor
@@ -57,7 +57,7 @@ M: object make-slot-descriptions
     make-mirror [ <slot-description> ] { } assoc>map ;
 
 M: hashtable make-slot-descriptions
-    call-next-method [ [ key-string>> ] compare ] sort ;
+    call-next-method [ key-string>> ] sort-with ;
 
 : <inspector-table> ( model -- table )
     [ make-slot-descriptions ] <arrow> inspector-renderer <table>

diff --git a/basis/vocabs/prettyprint/prettyprint.factor b/basis/vocabs/prettyprint/prettyprint.factor
@@ -14,7 +14,7 @@ IN: vocabs.prettyprint
 <PRIVATE
 
 : sort-vocabs ( seq -- seq' )
-    [ [ vocab-name ] compare ] sort ;
+    [ vocab-name ] sort-with ;
 
 : pprint-using ( seq -- )
     [ "syntax" vocab = not ] filter

diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
@@ -207,7 +207,7 @@ M: anonymous-complement (classes-intersect?)
     [ "Topological sort failed" throw ] unless* ;
 
 : sort-classes ( seq -- newseq )
-    [ [ name>> ] compare ] sort >vector
+    [ name>> ] sort-with >vector
     [ dup empty? not ]
     [ dup largest-class [ over delete-nth ] dip ]
     produce nip ;

diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor
@@ -12,6 +12,8 @@ $nl
 "Sorting a sequence with a custom comparator:"
 { $subsection sort }
 "Sorting a sequence with common comparators:"
+{ $subsection sort-with }
+{ $subsection inv-sort-with }
 { $subsection natural-sort }
 { $subsection sort-keys }
 { $subsection sort-values } ;
@@ -20,16 +22,24 @@ ABOUT: "sequences-sorting"
 
 HELP: sort
 { $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
-{ $description "Sorts the elements into a new array using a stable sort." }
+{ $description "Sorts the elements of " { $snippet "seq" } " into a new array using a stable sort." }
 { $notes "The algorithm used is the merge sort." } ;
 
+HELP: sort-with
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( object -- key )" } } { "sortedseq" "a new sorted sequence" } }
+{ $description "Sorts the elements of " { $snippet "seq" } " by applying " { $link compare } " with " { $snippet "quot" } " to each pair of elements in the sequence." } ;
+
+HELP: inv-sort-with
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( object -- key )" } } { "sortedseq" "a new sorted sequence" } }
+{ $description "Sorts the elements of " { $snippet "seq" } " by applying " { $link compare } " with " { $snippet "quot" } " to each pair of elements in the sequence and inverting the results." } ;
+
 HELP: sort-keys
 { $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }
-{ $description "Sorts the elements comparing first elements of pairs using the " { $link <=> } " word." } ;
+{ $description "Sorts the elements of " { $snippet "seq" } " comparing first elements of pairs using the " { $link <=> } " word." } ;
 
 HELP: sort-values
 { $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }
-{ $description "Sorts the elements comparing second elements of pairs using the " { $link <=> } " word." } ;
+{ $description "Sorts the elements of " { $snippet "seq" } " comparing second elements of pairs using the " { $link <=> } " word." } ;
 
 HELP: natural-sort
 { $values { "seq" "a sequence of real numbers" } { "sortedseq" "a new sorted sequence" } }
@@ -43,4 +53,4 @@ HELP: midpoint@
 { $values { "seq" "a sequence" } { "n" integer } }
 { $description "Outputs the index of the midpoint of " { $snippet "seq" } "." } ;
 
-{ <=> compare natural-sort sort-keys sort-values } related-words
+{ <=> compare natural-sort sort-with inv-sort-with sort-keys sort-values } related-words
diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor
@@ -155,8 +155,13 @@ PRIVATE>
 
 : natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
 
-: sort-keys ( seq -- sortedseq ) [ [ first ] compare ] sort ;
+: sort-with ( seq quot -- sortedseq )
+    [ compare ] curry sort ; inline
+: inv-sort-with ( seq quot -- sortedseq )
+    [ compare invert-comparison ] curry sort ; inline
 
-: sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
+: sort-keys ( seq -- sortedseq ) [ first ] sort-with ;
+
+: sort-values ( seq -- sortedseq ) [ second ] sort-with ;
 
 : sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor
@@ -7,7 +7,7 @@ IN: source-files.errors
 TUPLE: source-file-error error asset file line# ;
 
 : sort-errors ( errors -- alist )
-    [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ;
+    [ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ;
 
 : group-by-source-file ( errors -- assoc )
     H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;

diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor
@@ -10,7 +10,7 @@ MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: sort-largest-first ( seq -- seq ) [ [ length ] compare ] sort reverse ;
+: sort-largest-first ( seq -- seq ) [ length ] sort-with reverse ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor
@@ -23,7 +23,7 @@ IN: fuel.xref
     dup dup >vocab-link where normalize-loc 4array ;
 
 : sort-xrefs ( seq -- seq' )
-    [ [ first ] dip first <=> ] sort ;
+    [ first ] sort-with ;
 
 : format-xrefs ( seq -- seq' )
     [ word? ] filter [ word>xref ] map ;

diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor
@@ -73,7 +73,7 @@ TUPLE: multi-index-range
 C: <multi-index-range> multi-index-range
 
 TUPLE: index-elements
-    { ptr gpu-data-ptr read-only }
+    { ptr read-only }
     { count integer read-only }
     { index-type index-type read-only } ;
 
@@ -422,7 +422,7 @@ SYNTAX: UNIFORM-TUPLE:
     [ [ length ] [ >int-array ] bi glDrawBuffers ] if ;
 
 : bind-named-output-attachments ( program-instance framebuffer attachments -- )
-    rot '[ [ first _ swap output-index ] bi@ <=> ] sort [ second ] map
+    rot '[ first _ swap output-index ] sort-with [ second ] map
     bind-unnamed-output-attachments ;
 
 : bind-output-attachments ( program-instance framebuffer attachments -- )

diff --git a/extra/pair-methods/pair-methods.factor b/extra/pair-methods/pair-methods.factor
@@ -21,7 +21,7 @@ ERROR: no-pair-method a b generic ;
 
 : sorted-pair-methods ( word -- alist )
     "pair-generic-methods" word-prop >alist
-    [ [ first method-sort-key ] bi@ >=< ] sort ;
+    [ first method-sort-key ] inv-sort-with ;
 
 : pair-generic-definition ( word -- def )
     [ sorted-pair-methods [ first2 pair-method-cond ] map ]

diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor
@@ -83,7 +83,7 @@ M: comment entity-url
     >>comments ;
 
 : reverse-chronological-order ( seq -- sorted )
-    [ [ date>> ] compare invert-comparison ] sort ;
+    [ date>> ] inv-sort-with ;
 
 : validate-author ( -- )
     { { "author" [ v-username ] } } validate-params ;

diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor
@@ -59,7 +59,7 @@ TUPLE: paste < entity annotations ;
 
 : pastes ( -- pastes )
     f <paste> select-tuples
-    [ [ date>> ] compare ] sort
+    [ date>> ] sort-with
     reverse ;
 
 TUPLE: annotation < entity parent ;

diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
@@ -56,11 +56,11 @@ posting "POSTINGS"
 
 : blogroll ( -- seq )
     f <blog> select-tuples
-    [ [ name>> ] compare ] sort ;
+    [ name>> ] sort-with ;
 
 : postings ( -- seq )
     posting new select-tuples
-    [ [ date>> ] compare invert-comparison ] sort ;
+    [ date>> ] inv-sort-with ;
 
 : <edit-blogroll-action> ( -- action )
     <page-action>
@@ -99,7 +99,7 @@ posting "POSTINGS"
     [ '[ _ <posting> ] map ] 2map concat ;
 
 : sort-entries ( entries -- entries' )
-    [ [ date>> ] compare invert-comparison ] sort ;
+    [ date>> ] inv-sort-with ;
 
 : update-cached-postings ( -- )
     blogroll fetch-blogroll sort-entries 8 short head [

diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
@@ -66,7 +66,7 @@ M: revision feed-entry-date date>> ;
 M: revision feed-entry-url id>> revision-url ;
 
 : reverse-chronological-order ( seq -- sorted )
-    [ [ date>> ] compare invert-comparison ] sort ;
+    [ date>> ] inv-sort-with ;
 
 : <revision> ( id -- revision )
     revision new swap >>id ;
@@ -307,7 +307,7 @@ M: revision feed-entry-url id>> revision-url ;
 
         [
             f <article> select-tuples
-            [ [ title>> ] compare ] sort
+            [ title>> ] sort-with
             "articles" set-value
         ] >>init