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 1c7392901b3857f394d2bc2da96c0fe2aa7f7978..9e311ca03ac2500705453b84b93f829f42605e77 100644 (file)
--- a/basis/sorting/human/human.factor
+++ b/basis/sorting/human/human.factor
@@ -1,22 +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: peg.ebnf math.parser kernel assocs sorting fry
-math.order sequences ascii splitting.monotonic ;
+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<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
+: cut3 ( sequence pred -- first mid last )
+    [ cut-find ] keep [ not ] compose cut-find ; inline
 
-: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
+: find-sequences ( sequence pred quot -- sequences )
+    '[
+        [
+            _ cut3 [
+                [ , ]
+                [ [ @ , ] when* ] bi*
+            ] dip dup
+        ] loop drop
+    ] { } make ; inline
 
-: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ;
+: find-numbers ( sequence -- sequence' )
+    [ digit? ] [ string>number ] find-sequences ;
 
-: human-sort ( seq -- seq' ) [ human<=> ] sort ;
+! For comparing integers or sequences
+TUPLE: alphanum obj ;
 
-: human-sort-keys ( seq -- sortedseq )
-    [ [ first ] human-compare ] sort ;
+: <alphanum> ( obj -- alphanum )
+    alphanum new
+        swap >>obj ; inline
 
-: human-sort-values ( seq -- sortedseq )
-    [ [ second ] human-compare ] sort ;
+: <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 >>