sequences.extras: adding all-subseqs, each-subseq, longest-subseq, and generalized minimum/maximum words.

db4
John Benediktsson 2012-04-15 10:31:06 -07:00
parent 1c66fbf086
commit c6bd2313ba
2 changed files with 72 additions and 2 deletions
extra/sequences/extras

View File

@ -0,0 +1,23 @@
USING: make sequences sequences.extras tools.test ;
IN: sequences.extras.tests
[ 1 ] [ 1 2 [ ] min-by ] unit-test
[ 2 ] [ 1 2 [ ] max-by ] unit-test
[ "12345" ] [ "123" "12345" [ length ] max-by ] unit-test
[ "123" ] [ "123" "12345" [ length ] min-by ] unit-test
[ 4 ] [ 5 iota [ ] maximum ] unit-test
[ 0 ] [ 5 iota [ ] minimum ] unit-test
[ { "foo" } ] [ { { "foo" } { "bar" } } [ first ] maximum ] unit-test
[ { "bar" } ] [ { { "foo" } { "bar" } } [ first ] minimum ] unit-test
[ { "a" "b" "c" "d" "ab" "bc" "cd" "abc" "bcd" "abcd" } ] [ "abcd" all-subseqs ] unit-test
[ { "a" "ab" "abc" "abcd" "b" "bc" "bcd" "c" "cd" "d" } ]
[ [ "abcd" [ , ] each-subseq ] { } make ] unit-test
[ "" ] [ "abc" "def" longest-subseq ] unit-test
[ "abcd" ] [ "abcd" "abcde" longest-subseq ] unit-test
[ "foo" ] [ "foo" "foobar" longest-subseq ] unit-test
[ "foo" ] [ "foobar" "foo" longest-subseq ] unit-test

View File

@ -1,5 +1,8 @@
USING: arrays kernel locals math sequences ;
USING: arrays grouping kernel locals math math.order math.ranges
sequences ;
IN: sequences.extras
: reduce1 ( seq quot -- result ) [ unclip ] dip reduce ; inline
:: reduce-r
@ -18,4 +21,48 @@ IN: sequences.extras
: find-all ( seq quot -- elts ) [ [ length iota ] keep ] dip
[ dupd call( a -- ? ) [ 2array ] [ 2drop f ] if ] curry 2map [ ] filter ; inline
: insert-sorted ( elt seq -- seq ) 2dup [ < ] with find drop over length or swap insert-nth ;
: insert-sorted ( elt seq -- seq ) 2dup [ < ] with find drop over length or swap insert-nth ;
: max-by ( obj1 obj2 quot: ( obj -- n ) -- obj1/obj2 )
[ bi@ [ max ] keep eq? not ] curry most ; inline
: min-by ( obj1 obj2 quot: ( obj -- n ) -- obj1/obj2 )
[ bi@ [ min ] keep eq? not ] curry most ; inline
: maximum ( seq quot: ( ... elt -- ... x ) -- elt )
[ keep 2array ] curry
[ [ first ] max-by ] map-reduce second ; inline
: minimum ( seq quot: ( ... elt -- ... x ) -- elt )
[ keep 2array ] curry
[ [ first ] min-by ] map-reduce second ; inline
: all-subseqs ( seq -- seqs )
dup length [1,b] [ <clumps> ] with map concat ;
:: each-subseq ( ... seq quot: ( ... x -- ... ) -- ... )
seq length [0,b] [
:> from
from seq length (a,b] [
:> to
from to seq subseq quot call( x -- )
] each
] each ;
:: longest-subseq ( seq1 seq2 -- subseq )
seq1 length :> len1
seq2 length :> len2
0 :> n!
0 :> end!
len1 1 + [ len2 1 + 0 <array> ] replicate :> table
len1 [1,b] [| x |
len2 [1,b] [| y |
x 1 - seq1 nth
y 1 - seq2 nth = [
y 1 - x 1 - table nth nth 1 + :> len
len y x table nth set-nth
len n > [ len n! x end! ] when
] [ 0 y x table nth set-nth ] if
] each
] each end n - end seq1 subseq ;