diff --git a/extra/grouping/extras/extras-docs.factor b/extra/grouping/extras/extras-docs.factor new file mode 100644 index 0000000000..50f6d624c8 --- /dev/null +++ b/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\" \"!\" }" + } +} ; diff --git a/extra/grouping/extras/extras-tests.factor b/extra/grouping/extras/extras-tests.factor index 76ef71f627..d696f5f480 100644 --- a/extra/grouping/extras/extras-tests.factor +++ b/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 diff --git a/extra/grouping/extras/extras.factor b/extra/grouping/extras/extras.factor index b48806528c..fdac237e59 100644 --- a/extra/grouping/extras/extras.factor +++ b/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 ) [ ] 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 ;