factor: trim using lists

[factor.git] / basis / sorting / human / human.factor

diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor
index b3dae45a9b87d26fd94d46ed04e9439be96a1ebd..9e311ca03ac2500705453b84b93f829f42605e77 100644 (file)
--- a/basis/sorting/human/human.factor
+++ b/basis/sorting/human/human.factor
@@ -1,9 +1,46 @@
-! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! Copyright (C) 2008, 2010 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math.parser peg.ebnf sorting.functor ;
+USING: accessors kernel make math math.order math.parser
+sequences sorting.functor strings unicode ;
 IN: sorting.human
 
-: find-numbers ( string -- seq )
-    [EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
+: cut-find ( sequence pred -- before after )
+    [ drop ] [ find drop ] 2bi dup [ cut ] when ; inline
 
-<< "human" [ find-numbers ] define-sorting >>
+: cut3 ( sequence pred -- first mid last )
+    [ cut-find ] keep [ not ] compose cut-find ; inline
+
+: find-sequences ( sequence pred quot -- sequences )
+    '[
+        [
+            _ cut3 [
+                [ , ]
+                [ [ @ , ] when* ] bi*
+            ] dip dup
+        ] loop drop
+    ] { } make ; inline
+
+: find-numbers ( sequence -- sequence' )
+    [ digit? ] [ string>number ] find-sequences ;
+
+! For comparing integers or sequences
+TUPLE: alphanum obj ;
+
+: <alphanum> ( obj -- alphanum )
+    alphanum new
+        swap >>obj ; inline
+
+: <alphanum-insensitive> ( obj -- alphanum )
+    alphanum new
+        swap dup string? [ collation-key/nfd drop ] when >>obj ; inline
+
+M: alphanum <=>
+    [ obj>> ] bi@
+    2dup [ integer? ] bi@ xor [
+        drop integer? +lt+ +gt+ ?
+    ] [
+        <=>
+    ] if ;
+
+<< "human" [ find-numbers [ <alphanum> ] map ] define-sorting >>
+<< "humani" [ find-numbers [ <alphanum-insensitive> ] map ] define-sorting >>