Adding stack effects.
parent
f6b6e17b00
commit
3c1356bf69
|
@ -99,7 +99,7 @@ INSTANCE: sliced-clumps abstract-clumps
|
|||
|
||||
: 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
|
||||
|
|
|
@ -34,7 +34,7 @@ M: product-sequence length lengths>> product ;
|
|||
|
||||
: carry-ns ( ns lengths -- )
|
||||
0 (carry-n) ;
|
||||
|
||||
|
||||
: product-iter ( ns lengths -- )
|
||||
[ 0 over [ 1 + ] change-nth ] dip carry-ns ;
|
||||
|
||||
|
@ -46,17 +46,17 @@ M: product-sequence length lengths>> product ;
|
|||
|
||||
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 |
|
||||
|
@ -64,10 +64,10 @@ M: product-sequence nth
|
|||
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 |
|
||||
|
|
|
@ -11,6 +11,6 @@ IN: sorting.insertion
|
|||
] 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
|
||||
|
|
|
@ -18,7 +18,7 @@ IN: sorting.slots
|
|||
] 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 ;
|
||||
|
|
|
@ -18,7 +18,7 @@ IN: splitting.monotonic
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: monotonic-split ( seq quot -- newseq )
|
||||
: monotonic-split ( seq quot: ( obj1 obj2 -- ? ) -- newseq )
|
||||
over empty? [ 2drop { } ] [ (monotonic-split) ] if ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
@ -36,7 +36,7 @@ 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 ] }
|
||||
|
|
|
@ -75,7 +75,7 @@ sleep-entry ;
|
|||
: 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 )
|
||||
|
|
|
@ -142,7 +142,7 @@ SYMBOL: ui-thread
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: find-window ( quot -- world )
|
||||
: find-window ( quot: ( world -- ? ) -- world )
|
||||
[ windows get values ] dip
|
||||
'[ dup children>> [ ] [ nip first ] if-empty @ ]
|
||||
find-last nip ; inline
|
||||
|
|
|
@ -76,9 +76,9 @@ ERROR: log2-expects-positive x ;
|
|||
: 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 ;
|
||||
|
||||
|
|
|
@ -45,4 +45,4 @@ M: object max [ after? ] most ; inline
|
|||
|
||||
: [-] ( x y -- z ) - 0 max ; inline
|
||||
|
||||
: compare ( obj1 obj2 quot -- <=> ) bi@ <=> ; inline
|
||||
: compare ( obj1 obj2 quot: ( obj -- newobj ) -- <=> ) bi@ <=> ; inline
|
||||
|
|
|
@ -121,7 +121,7 @@ M: sequence cardinality
|
|||
[ [ [ 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 -- )
|
||||
|
|
|
@ -148,16 +148,17 @@ TUPLE: merge
|
|||
|
||||
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 )
|
||||
|
|
|
@ -68,7 +68,7 @@ PRIVATE>
|
|||
: 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 )
|
||||
|
|
|
@ -31,7 +31,7 @@ M: word definition def>> ;
|
|||
[ 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 ;
|
||||
|
|
Loading…
Reference in New Issue