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