2005-09-07 17:21:11 -04:00
|
|
|
! Copyright (C) 2005 Slava Pestov.
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
2005-09-10 18:27:31 -04:00
|
|
|
IN: sequences-internals
|
2005-09-11 20:46:55 -04:00
|
|
|
USING: arrays generic kernel kernel-internals math vectors ;
|
2005-09-07 17:21:11 -04:00
|
|
|
|
2005-09-10 18:27:31 -04:00
|
|
|
: (map) ( quot seq i -- quot seq value )
|
|
|
|
pick pick >r >r swap nth-unsafe swap call r> r> rot ; inline
|
|
|
|
|
|
|
|
: (2each) ( quot seq seq i -- quot seq seq i )
|
|
|
|
[ 2nth-unsafe rot dup slip ] 3keep ; inline
|
|
|
|
|
|
|
|
: (2map) ( quot seq seq i -- quot seq seq value )
|
|
|
|
pick pick >r >r 2nth-unsafe rot dup slip
|
|
|
|
swap r> swap r> swap ; inline
|
|
|
|
|
|
|
|
: (monotonic) ( quot seq i -- ? )
|
|
|
|
2dup 1 + swap nth-unsafe >r swap nth-unsafe r> rot call ;
|
|
|
|
inline
|
|
|
|
|
|
|
|
IN: sequences
|
|
|
|
|
2005-09-07 17:21:11 -04:00
|
|
|
G: each ( seq quot -- | quot: elt -- )
|
|
|
|
[ over ] standard-combination ; inline
|
|
|
|
|
|
|
|
M: object each ( seq quot -- )
|
|
|
|
swap dup length [
|
2005-09-10 18:27:31 -04:00
|
|
|
[ swap nth-unsafe swap call ] 3keep
|
2005-09-07 17:21:11 -04:00
|
|
|
] repeat 2drop ;
|
|
|
|
|
|
|
|
: each-with ( obj seq quot -- | quot: obj elt -- )
|
|
|
|
swap [ with ] each 2drop ; inline
|
|
|
|
|
|
|
|
: reduce ( seq identity quot -- value | quot: x y -- z )
|
|
|
|
swapd each ; inline
|
|
|
|
|
|
|
|
G: find ( seq quot -- i elt | quot: elt -- ? )
|
|
|
|
[ over ] standard-combination ; inline
|
|
|
|
|
|
|
|
: find-with ( obj seq quot -- i elt | quot: elt -- ? )
|
|
|
|
swap [ with rot ] find 2swap 2drop ; inline
|
|
|
|
|
|
|
|
: collect ( n generator -- vector | quot: n -- value )
|
2005-09-11 20:46:55 -04:00
|
|
|
#! Primitive mapping out of an integer sequence into an
|
|
|
|
#! array. Used by map and 2map. Don't call, use map
|
2005-09-07 17:21:11 -04:00
|
|
|
#! instead.
|
2005-09-11 20:46:55 -04:00
|
|
|
>r [ <array> ] keep r> swap [
|
|
|
|
[ rot >r [ swap call ] keep r> set-array-nth ] 3keep
|
2005-09-07 17:21:11 -04:00
|
|
|
] repeat drop ; inline
|
|
|
|
|
|
|
|
G: map [ over ] standard-combination ; inline
|
|
|
|
|
|
|
|
M: object map ( seq quot -- seq )
|
|
|
|
swap [ dup length [ (map) ] collect ] keep like 2nip ;
|
|
|
|
|
|
|
|
: map-with ( obj list quot -- list | quot: obj elt -- elt )
|
|
|
|
swap [ with rot ] map 2nip ; inline
|
|
|
|
|
|
|
|
: accumulate ( list identity quot -- values | quot: x y -- z )
|
|
|
|
rot [ pick >r swap call r> ] map-with nip ; inline
|
|
|
|
|
|
|
|
: nmap ( seq quot -- seq | quot: elt -- elt )
|
2005-09-10 18:27:31 -04:00
|
|
|
over length
|
|
|
|
[ [ swap change-nth-unsafe ] 3keep ] repeat 2drop ;
|
2005-09-07 17:21:11 -04:00
|
|
|
inline
|
|
|
|
|
2005-09-07 18:56:42 -04:00
|
|
|
: min-length ( seq seq -- n )
|
|
|
|
swap length swap length min ; flushable
|
|
|
|
|
2005-09-07 17:21:11 -04:00
|
|
|
: 2each ( seq seq quot -- )
|
|
|
|
#! Don't use with lists.
|
2005-09-07 18:56:42 -04:00
|
|
|
-rot 2dup min-length [ (2each) ] repeat 3drop ; inline
|
2005-09-07 17:21:11 -04:00
|
|
|
|
|
|
|
: 2reduce ( seq seq identity quot -- value | quot: e x y -- z )
|
|
|
|
#! Don't use with lists.
|
|
|
|
>r -rot r> 2each ; inline
|
|
|
|
|
|
|
|
: 2map ( seq seq quot -- seq )
|
|
|
|
#! Don't use with lists.
|
2005-09-07 18:56:42 -04:00
|
|
|
-rot
|
|
|
|
[ 2dup min-length [ (2map) ] collect ] keep like
|
|
|
|
>r 3drop r> ; inline
|
2005-09-07 17:21:11 -04:00
|
|
|
|
|
|
|
: find* ( i seq quot -- i elt )
|
|
|
|
pick pick length >= [
|
|
|
|
3drop -1 f
|
|
|
|
] [
|
2005-09-10 18:27:31 -04:00
|
|
|
3dup >r >r >r >r nth-unsafe r> call [
|
|
|
|
r> dup r> nth-unsafe r> drop
|
2005-09-07 17:21:11 -04:00
|
|
|
] [
|
|
|
|
r> 1 + r> r> find*
|
|
|
|
] ifte
|
|
|
|
] ifte ; inline
|
|
|
|
|
|
|
|
: find-with* ( obj i seq quot -- i elt | quot: elt -- ? )
|
|
|
|
-rot [ with rot ] find* 2swap 2drop ; inline
|
|
|
|
|
|
|
|
M: object find ( seq quot -- i elt )
|
|
|
|
0 -rot find* ;
|
|
|
|
|
|
|
|
: contains? ( seq quot -- ? )
|
|
|
|
find drop -1 > ; inline
|
|
|
|
|
|
|
|
: contains-with? ( obj seq quot -- ? )
|
|
|
|
find-with drop -1 > ; inline
|
|
|
|
|
|
|
|
: all? ( seq quot -- ? )
|
|
|
|
#! ForAll(P in X) <==> !Exists(!P in X)
|
|
|
|
swap [ swap call not ] contains-with? not ; inline
|
|
|
|
|
|
|
|
: all-with? ( obj seq quot -- ? | quot: elt -- ? )
|
|
|
|
swap [ with rot ] all? 2nip ; inline
|
|
|
|
|
|
|
|
: subset ( seq quot -- seq | quot: elt -- ? )
|
|
|
|
#! all elements for which the quotation returned a value
|
|
|
|
#! other than f are collected in a new list.
|
|
|
|
swap [
|
|
|
|
dup length <vector> -rot [
|
|
|
|
rot >r 2dup >r >r swap call [
|
|
|
|
r> r> r> [ push ] keep swap
|
|
|
|
] [
|
|
|
|
r> r> drop r> swap
|
|
|
|
] ifte
|
|
|
|
] each drop
|
|
|
|
] keep like ; inline
|
|
|
|
|
|
|
|
: subset-with ( obj seq quot -- seq | quot: obj elt -- ? )
|
|
|
|
swap [ with rot ] subset 2nip ; inline
|
|
|
|
|
|
|
|
: monotonic? ( seq quot -- ? | quot: elt elt -- ? )
|
|
|
|
#! Eg, { 1 2 3 4 } [ < ] monotonic? ==> t
|
|
|
|
#! { 1 3 2 4 } [ < ] monotonic? ==> f
|
|
|
|
#! Don't use with lists.
|
|
|
|
swap dup length 1 - [
|
|
|
|
pick pick >r >r (monotonic) r> r> rot
|
|
|
|
] all? 2nip ; inline
|