: clump ( seq n -- array ) <clumps> { } like ;
-: monotonic? ( seq quot -- ? )
+: monotonic? ( seq quot: ( obj1 obj2 -- ? ) -- ? )
over length 2 < [ 2drop t ] [
over length 2 = [
[ first2-unsafe ] dip call
: carry-ns ( ns lengths -- )
0 (carry-n) ;
-
+
: product-iter ( ns lengths -- )
[ 0 over [ 1 + ] change-nth ] dip carry-ns ;
PRIVATE>
-M: product-sequence nth
+M: product-sequence nth
product@ nths ;
-:: product-each ( sequences quot -- )
+:: product-each ( sequences quot: ( seq -- ) -- )
sequences start-product-iter :> ( ns lengths )
lengths [ 0 = ] any? [
[ ns lengths end-product-iter? ]
[ ns sequences nths quot call ns lengths product-iter ] until
] unless ; inline
-:: product-map-as ( sequences quot exemplar -- sequence )
+:: product-map-as ( sequences quot: ( seq -- value ) exemplar -- sequence )
0 :> i!
sequences [ length ] [ * ] map-reduce exemplar
[| result |
result
] new-like ; inline
-: product-map ( sequences quot -- sequence )
+: product-map ( sequences quot: ( seq -- value ) -- sequence )
over product-map-as ; inline
-:: product-map>assoc ( sequences quot exemplar -- assoc )
+:: product-map>assoc ( sequences quot: ( seq -- key value ) exemplar -- assoc )
0 :> i!
sequences [ length ] [ * ] map-reduce { }
[| result |
] unless ; inline recursive
PRIVATE>
-: insertion-sort ( seq quot -- )
+: insertion-sort ( ... seq quot: ( ... elt -- ... elt' ) -- ... )
! quot is a transformation on elements
over length [ insert ] with with each-integer ; inline
] when execute-comparator
] with with map-find drop +eq+ or ;
-: sort-by-with ( seq sort-specs quot -- seq' )
+: sort-by-with ( seq sort-specs quot: ( obj -- key ) -- seq' )
swap '[ _ bi@ _ compare-slots ] sort ; inline
: sort-by ( seq sort-specs -- seq' ) [ ] sort-by-with ;
PRIVATE>
-: monotonic-split ( seq quot -- newseq )
+: monotonic-split ( seq quot: ( obj1 obj2 -- ? ) -- newseq )
over empty? [ 2drop { } ] [ (monotonic-split) ] if ; inline
<PRIVATE
PRIVATE>
-: monotonic-slice ( seq quot class -- slices )
+: monotonic-slice ( seq quot: ( obj1 obj2 -- ? ) class -- slices )
pick length {
{ 0 [ 2drop ] }
{ 1 [ nip [ 0 1 rot ] dip boa 1array ] }
: tset ( value key -- )
tnamespace set-at ;
-: tchange ( key quot -- )
+: tchange ( ..a key quot: ( ..a value -- ..b newvalue ) -- ..b )
[ tnamespace ] dip change-at ; inline
: threads ( -- assoc )
PRIVATE>
-: find-window ( quot -- world )
+: find-window ( quot: ( world -- ? ) -- world )
[ windows get values ] dip
'[ dup children>> [ ] [ nip first ] if-empty @ ]
find-last nip ; inline
: if-zero ( ..a n quot1: ( ..a -- ..b ) quot2: ( ..a n -- ..b ) -- ..b )
[ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline
-: when-zero ( n quot -- ) [ ] if-zero ; inline
+: when-zero ( ..a n quot: ( ..a -- ..b ) -- ..b ) [ ] if-zero ; inline
-: unless-zero ( n quot -- ) [ ] swap if-zero ; inline
+: unless-zero ( ..a n quot: ( ..a -- ..b ) -- ..b ) [ ] swap if-zero ; inline
UNION: integer fixnum bignum ;
: [-] ( x y -- z ) - 0 max ; inline
-: compare ( obj1 obj2 quot -- <=> ) bi@ <=> ; inline
+: compare ( obj1 obj2 quot: ( obj -- newobj ) -- <=> ) bi@ <=> ; inline
[ [ [ members ] map concat ] [ first ] bi set-like ]
if-empty ;
-: gather ( seq quot -- newseq )
+: gather ( ... seq quot: ( ... elt -- ... elt' ) -- ... newseq )
map concat members ; inline
: adjoin-at ( value key assoc -- )
PRIVATE>
-: sort ( seq quot -- sortedseq )
+: sort ( seq quot: ( obj1 obj2 -- <=> ) -- sortedseq )
[ <merge> ] dip
[ sort-pairs ] [ sort-loop ] [ drop accum>> underlying>> ] 2tri ;
inline
: natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
-: sort-with ( seq quot -- sortedseq )
+: sort-with ( seq quot: ( elt -- key ) -- sortedseq )
[ compare ] curry sort ; inline
-: inv-sort-with ( seq quot -- sortedseq )
+
+: inv-sort-with ( seq quot: ( elt -- key ) -- sortedseq )
[ compare invert-comparison ] curry sort ; inline
GENERIC: sort-keys ( obj -- sortedseq )
: split ( seq separators -- pieces )
[ [ member? ] curry split, ] { } make ;
-: split-when ( seq quot -- pieces )
+: split-when ( ... seq quot: ( ... elt -- ... ? ) -- ... pieces )
[ split, ] { } make ; inline
GENERIC: string-lines ( str -- seq )
[ pick props>> ?set-at >>props drop ]
[ nip remove-word-prop ] if ;
-: change-word-prop ( word prop quot -- )
+: change-word-prop ( ..a word prop quot: ( ..a value -- ..b newvalue ) -- ..b )
[ swap props>> ] dip change-at ; inline
: reset-props ( word seq -- ) [ remove-word-prop ] with each ;