--- /dev/null
+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\" \"!\" }"
+ }
+} ;
-USING: arrays tools.test ;
+USING: arrays kernel math math.functions sequences tools.test ;
IN: grouping.extras
{ { } } [ { 1 } [ 2array ] 2clump-map ] unit-test
{ { 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
-USING: accessors combinators fry grouping kernel macros math
+USING: accessors arrays combinators fry grouping kernel macros math
math.ranges sequences sequences.generalizations
sequences.private ;
: 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 ;