basis/sorting/slots/slots.factor

   1 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays fry kernel math.order sequences sorting ;
   4 IN: sorting.slots
   5
   6 : execute-comparator ( obj1 obj2 word -- <=>/f )
   7     execute( obj1 obj2 -- <=> ) dup +eq+ eq? [ drop f ] when ;
   8
   9 : execute-accessor ( obj1 obj2 word -- obj1' obj2' )
  10     '[ _ execute( tuple -- value ) ] bi@ ;
  11
  12 : compare-slots ( obj1 obj2 sort-specs -- <=> )
  13     ! sort-spec: { accessors comparator }
  14     [
  15         dup array? [
  16             unclip-last-slice
  17             [ [ execute-accessor ] each ] dip
  18         ] when execute-comparator
  19     ] 2with map-find drop +eq+ or ;
  20
  21 : sort-by-with ( seq sort-specs quot: ( obj -- key ) -- seq' )
  22     swap '[ _ bi@ _ compare-slots ] sort ; inline
  23
  24 : sort-by ( seq sort-specs -- seq' ) [ ] sort-by-with ;
  25
  26 : sort-keys-by ( seq sort-seq -- seq' ) [ first ] sort-by-with ;
  27
  28 : sort-values-by ( seq sort-seq -- seq' ) [ second ] sort-by-with ;