diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor new file mode 100644 index 0000000000..2a404ff892 --- /dev/null +++ b/extra/sequences/extras/extras-tests.factor @@ -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 diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor index 5256bea5ce..ccf41154fa 100644 --- a/extra/sequences/extras/extras.factor +++ b/extra/sequences/extras/extras.factor @@ -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 ; \ No newline at end of file +: 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] [ ] 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 ] 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 ; +