steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

grouping.extras: having some fun with clumps.

db4
John Benediktsson 2013-09-23 17:17:41 -07:00
parent 9b3fa8407b
commit cdb4d42dd6
2 changed files with 55 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
extra/grouping/extras/extras-tests.factor Normal file
View File

@ -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

35
extra/grouping/extras/extras.factor Normal file
View File

@ -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> 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 )
[ <head-clumps> ] [ [ like ] curry map ] bi ;
TUPLE: tail-clumps seq ;
C: <tail-clumps> 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 )
[ <tail-clumps> ] [ [ like ] curry map ] bi ;