diff --git a/extra/grouping/extras/extras-tests.factor b/extra/grouping/extras/extras-tests.factor new file mode 100644 index 0000000000..dc719e27b1 --- /dev/null +++ b/extra/grouping/extras/extras-tests.factor @@ -0,0 +1,20 @@ +USING: arrays tools.test ; +IN: grouping.extras + +{ { } } [ { 1 } [ 2array ] 2clump-map ] unit-test +{ { { 1 2 } } } [ { 1 2 } [ 2array ] 2clump-map ] unit-test +{ { { 1 2 } { 2 3 } } } [ { 1 2 3 } [ 2array ] 2clump-map ] unit-test +{ { { 1 2 } { 2 3 } { 3 4 } } } [ { 1 2 3 4 } [ 2array ] 2clump-map ] unit-test + +{ { } } [ { 1 } [ 3array ] 3clump-map ] unit-test +{ { } } [ { 1 2 } [ 3array ] 3clump-map ] unit-test +{ { { 1 2 3 } } } [ { 1 2 3 } [ 3array ] 3clump-map ] unit-test +{ { { 1 2 3 } { 2 3 4 } } } [ { 1 2 3 4 } [ 3array ] 3clump-map ] unit-test + +{ { } } [ { 1 } [ 4array ] 4 nclump-map ] unit-test +{ { } } [ { 1 2 } [ 4array ] 4 nclump-map ] unit-test +{ { { 1 2 3 4 } } } [ { 1 2 3 4 } [ 4array ] 4 nclump-map ] unit-test +{ { { 1 2 3 4 } { 2 3 4 5 } } } [ { 1 2 3 4 5 } [ 4array ] 4 nclump-map ] unit-test + +{ { "tail" "ail" "il" "l" } } [ "tail" tail-clump ] unit-test +{ { "h" "he" "hea" "head" } } [ "head" head-clump ] unit-test diff --git a/extra/grouping/extras/extras.factor b/extra/grouping/extras/extras.factor new file mode 100644 index 0000000000..557c3ab01d --- /dev/null +++ b/extra/grouping/extras/extras.factor @@ -0,0 +1,35 @@ +USING: accessors combinators fry grouping.private kernel macros +math math.ranges sequences sequences.generalizations +sequences.private ; + +IN: grouping.extras + +: 2clump-map ( seq quot: ( elt1 elt2 -- newelt ) -- seq' ) + [ dup 1 short tail-slice ] dip { } 2map-as ; inline + +: 3clump-map ( seq quot: ( elt1 elt2 elt3 -- newelt ) -- seq' ) + [ + dup [ 1 short tail-slice ] [ 2 short tail-slice ] bi + ] dip { } 3map-as ; inline + +MACRO: nclump-map ( seq quot n -- result ) + [ [1,b) [ [ short tail-slice ] curry ] map swap ] keep + '[ _ dup _ cleave _ { } _ nmap-as ] ; + +TUPLE: head-clumps seq ; +C: head-clumps +M: head-clumps length seq>> length ; +M: head-clumps nth-unsafe seq>> swap 1 + head-slice ; +INSTANCE: head-clumps immutable-sequence + +: head-clump ( seq -- array ) + [ ] [ [ like ] curry map ] bi ; + +TUPLE: tail-clumps seq ; +C: tail-clumps +M: tail-clumps length seq>> length ; +M: tail-clumps nth-unsafe seq>> swap tail-slice ; +INSTANCE: tail-clumps immutable-sequence + +: tail-clump ( seq -- array ) + [ ] [ [ like ] curry map ] bi ;