basis/sorting/human/human.factor

   1 ! Copyright (C) 2008, 2010 Doug Coleman, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors fry kernel make math math.order math.parser
   4 sequences sorting.functor strings unicode.case
   5 unicode.categories unicode.collation ;
   6 IN: sorting.human
   7
   8 : cut-find ( sequence pred -- before after )
   9     [ drop ] [ find drop ] 2bi dup [ cut ] when ; inline
  10
  11 : cut3 ( sequence pred -- first mid last )
  12     [ cut-find ] keep [ not ] compose cut-find ; inline
  13
  14 : find-sequences ( sequence pred quot -- sequences )
  15     '[
  16         [
  17             _ cut3 [
  18                 [ , ]
  19                 [ [ @ , ] when* ] bi*
  20             ] dip dup
  21         ] loop drop
  22     ] { } make ; inline
  23
  24 : find-numbers ( sequence -- sequence' )
  25     [ digit? ] [ string>number ] find-sequences ;
  26
  27 ! For comparing integers or sequences
  28 TUPLE: alphanum obj ;
  29
  30 : <alphanum> ( obj -- alphanum )
  31     alphanum new
  32         swap >>obj ; inline
  33
  34 : <alphanum-insensitive> ( obj -- alphanum )
  35     alphanum new
  36         swap dup string? [ w/collation-key ] when >>obj ; inline
  37
  38 M: alphanum <=>
  39     [ obj>> ] bi@
  40     2dup [ integer? ] bi@ xor [
  41         drop integer? +lt+ +gt+ ?
  42     ] [
  43         <=>
  44     ] if ;
  45
  46 << "human" [ find-numbers [ <alphanum> ] map ] define-sorting >>
  47 << "humani" [ find-numbers [ <alphanum-insensitive> ] map ] define-sorting >>