basis/sorting/human/human.factor

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