grouping.extras: new word group-by, like sql GROUP BY but is order-preserving

extra/grouping/extras/extras-docs.factor

@@ -0,0 +1,14 @@
+USING: help.markup help.syntax sequences splitting strings ;
+
+IN: grouping.extras
+
+HELP: group-by
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( ... elt -- ... key )" } } { "groups" "a new assoc" } }
+{ $description "Groups the elements by the key received by applying quot to each element in the sequence." }
+{ $examples
+  { $example
+    "USING: grouping.extras unicode.data ;"
+    "\"THis String Has  CasE!\" [ category ] group-by [ last >string ] map ."
+    "{ \"TH\" \"is\" \" \" \"S\" \"tring\" \" \" \"H\" \"as\" \"  \" \"C\" \"as\" \"E\" \"!\" }"
+  }
+} ;

extra/grouping/extras/extras-tests.factor

@@ -1,4 +1,4 @@
-USING: arrays tools.test ;
+USING: arrays kernel math math.functions sequences tools.test ;
 IN: grouping.extras
 
 { { } } [ { 1 } [ 2array ] 2clump-map ] unit-test
@@ -21,3 +21,21 @@ IN: grouping.extras
 
 { { B{ 97 115 } B{ 100 102 } } } [ "asdf" 2 B{ } group-as ] unit-test
 { { { 97 115 } { 115 100 } { 100 102 } } } [ "asdf" 2 { } clump-as ] unit-test
+
+[
+    {
+        { 0 { 0 1 2 } }
+        { 1 { 3 4 5 } }
+        { 2 { 6 7 8 } }
+        { 3 { 9 } } }
+] [
+    10 iota [ 3 / floor ] group-by
+] unit-test
+
+[
+    { { t { 0 1 2 3 4 5 6 7 8 9 } } }
+] [ 10 iota [ drop t ] group-by ] unit-test
+
+[
+    { }
+] [ { } [ drop t ] group-by ] unit-test

extra/grouping/extras/extras.factor

@@ -1,4 +1,4 @@
-USING: accessors combinators fry grouping kernel macros math
+USING: accessors arrays combinators fry grouping kernel macros math
 math.ranges sequences sequences.generalizations
 sequences.private ;
 
@@ -48,3 +48,13 @@ INSTANCE: tail-clumps immutable-sequence
 
 : group-as ( seq n exemplar -- array )
     [ <groups> ] dip [ like ] curry map ;
+
+: (group-by-loop) ( elt key groups -- groups' )
+    2dup [ nip empty? ] [ ?last ?first = not ] 2bi or [
+        -rot swap 1array
+    ] [
+        nip unclip-last rot [ first2 ] dip suffix
+    ] if 2array suffix ;
+
+: group-by ( seq quot: ( elt -- key ) -- groups )
+    '[ dup _ call( x -- y ) rot (group-by-loop) ] { } swap reduce ;