spray some polymorphic stack effects on kernel, math, and sequences
Joe Groff
parent
1b1ccb71a4
commit
85f30987e2
|
|
@ -29,7 +29,7 @@ DEFER: if
|
|||
#! two literal quotations.
|
||||
rot [ drop ] [ nip ] if ; inline
|
||||
|
||||
: if ( ? true false -- ) ? call ;
|
||||
: if ( ..a ? true: ( ..a -- ..b ) false: ( ..a -- ..b ) -- ..b ) ? call ;
|
||||
|
||||
! Single branch
|
||||
: unless ( ? false -- )
|
||||
|
|
@ -39,7 +39,7 @@ DEFER: if
|
|||
swap [ call ] [ drop ] if ; inline
|
||||
|
||||
! Anaphoric
|
||||
: if* ( ? true false -- )
|
||||
: if* ( ..a ? true: ( ..a ? -- ..b ) false: ( ..a -- ..b ) -- ..b )
|
||||
pick [ drop call ] [ 2nip call ] if ; inline
|
||||
|
||||
: when* ( ? true -- )
|
||||
|
|
@ -49,7 +49,7 @@ DEFER: if
|
|||
over [ drop ] [ nip call ] if ; inline
|
||||
|
||||
! Default
|
||||
: ?if ( default cond true false -- )
|
||||
: ?if ( ..a default cond true: ( ..a cond -- ..b ) false: ( ..a default -- ..b ) -- ..b )
|
||||
pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
|
||||
|
||||
! Dippers.
|
||||
|
|
@ -171,16 +171,16 @@ UNION: boolean POSTPONE: t POSTPONE: f ;
|
|||
: most ( x y quot -- z ) 2keep ? ; inline
|
||||
|
||||
! Loops
|
||||
: loop ( pred: ( -- ? ) -- )
|
||||
: loop ( ... pred: ( ... -- ... ? ) -- ... )
|
||||
[ call ] keep [ loop ] curry when ; inline recursive
|
||||
|
||||
: do ( pred body -- pred body )
|
||||
dup 2dip ; inline
|
||||
|
||||
: while ( pred: ( -- ? ) body: ( -- ) -- )
|
||||
: while ( ... pred: ( ... -- ... ? ) body: ( ... -- ... ) -- ... )
|
||||
swap do compose [ loop ] curry when ; inline
|
||||
|
||||
: until ( pred: ( -- ? ) body: ( -- ) -- )
|
||||
: until ( ... pred: ( ... -- ... ? ) body: ( ... -- ... ) -- )
|
||||
[ [ not ] compose ] dip while ; inline
|
||||
|
||||
! Object protocol
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ ERROR: log2-expects-positive x ;
|
|||
: even? ( n -- ? ) 1 bitand zero? ;
|
||||
: odd? ( n -- ? ) 1 bitand 1 number= ;
|
||||
|
||||
: if-zero ( n quot1 quot2 -- )
|
||||
: 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
|
||||
|
|
@ -141,18 +141,18 @@ GENERIC: prev-float ( m -- n )
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: (each-integer) ( i n quot: ( i -- ) -- )
|
||||
: (each-integer) ( ... i n quot: ( ... i -- ... ) -- ... )
|
||||
[ iterate-step iterate-next (each-integer) ]
|
||||
[ 3drop ] if-iterate? ; inline recursive
|
||||
|
||||
: (find-integer) ( i n quot: ( i -- ? ) -- i )
|
||||
: (find-integer) ( ... i n quot: ( ... i -- ... ? ) -- ... i )
|
||||
[
|
||||
iterate-step
|
||||
[ [ ] ] 2dip
|
||||
[ iterate-next (find-integer) ] 2curry bi-curry if
|
||||
] [ 3drop f ] if-iterate? ; inline recursive
|
||||
|
||||
: (all-integers?) ( i n quot: ( i -- ? ) -- ? )
|
||||
: (all-integers?) ( ... i n quot: ( ... i -- ... ? ) -- ... ? )
|
||||
[
|
||||
iterate-step
|
||||
[ iterate-next (all-integers?) ] 3curry
|
||||
|
|
@ -171,7 +171,7 @@ PRIVATE>
|
|||
: all-integers? ( n quot -- ? )
|
||||
iterate-prep (all-integers?) ; inline
|
||||
|
||||
: find-last-integer ( n quot: ( i -- ? ) -- i )
|
||||
: find-last-integer ( ... n quot: ( ... i -- ... ? ) -- ... i )
|
||||
over 0 < [
|
||||
2drop f
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline
|
|||
|
||||
: empty? ( seq -- ? ) length 0 = ; inline
|
||||
|
||||
: if-empty ( seq quot1 quot2 -- )
|
||||
: if-empty ( ..a seq quot1: ( ..a -- ..b ) quot2: ( ..a seq -- ..b ) -- ..b )
|
||||
[ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
|
||||
|
||||
: when-empty ( seq quot -- ) [ ] if-empty ; inline
|
||||
|
|
@ -408,82 +408,82 @@ PRIVATE>
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: each ( seq quot -- )
|
||||
: each ( ... seq quot: ( ... x -- ... ) -- ... )
|
||||
(each) each-integer ; inline
|
||||
|
||||
: reduce ( seq identity quot -- result )
|
||||
: reduce ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... result )
|
||||
swapd each ; inline
|
||||
|
||||
: map-integers ( len quot exemplar -- newseq )
|
||||
[ over ] dip [ [ collect ] keep ] new-like ; inline
|
||||
|
||||
: map-as ( seq quot exemplar -- newseq )
|
||||
: map-as ( ... seq quot: ( ... x -- ... newx ) exemplar -- ... newseq )
|
||||
[ (each) ] dip map-integers ; inline
|
||||
|
||||
: map ( seq quot -- newseq )
|
||||
: map ( ... seq quot: ( ... x -- ... newx ) -- ... newseq )
|
||||
over map-as ; inline
|
||||
|
||||
: replicate-as ( len quot exemplar -- newseq )
|
||||
: replicate-as ( ... len quot: ( ... -- ... newx ) exemplar -- ... newseq )
|
||||
[ [ drop ] prepose ] dip map-integers ; inline
|
||||
|
||||
: replicate ( len quot -- newseq )
|
||||
: replicate ( ... len quot: ( ... -- ... newx ) -- ... newseq )
|
||||
{ } replicate-as ; inline
|
||||
|
||||
: map! ( seq quot -- seq )
|
||||
: map! ( ... seq quot: ( ... x -- ... x' ) -- ... seq )
|
||||
over [ map-into ] keep ; inline
|
||||
|
||||
: accumulate-as ( seq identity quot exemplar -- final newseq )
|
||||
: accumulate-as ( ... seq identity quot: ( ... prev elt -- ... next ) exemplar -- ... final newseq )
|
||||
[ (accumulate) ] dip map-as ; inline
|
||||
|
||||
: accumulate ( seq identity quot -- final newseq )
|
||||
: accumulate ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final newseq )
|
||||
{ } accumulate-as ; inline
|
||||
|
||||
: accumulate! ( seq identity quot -- final seq )
|
||||
: accumulate! ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final seq )
|
||||
(accumulate) map! ; inline
|
||||
|
||||
: 2each ( seq1 seq2 quot -- )
|
||||
: 2each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... )
|
||||
(2each) each-integer ; inline
|
||||
|
||||
: 2reverse-each ( seq1 seq2 quot -- )
|
||||
: 2reverse-each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... )
|
||||
[ [ <reversed> ] bi@ ] dip 2each ; inline
|
||||
|
||||
: 2reduce ( seq1 seq2 identity quot -- result )
|
||||
: 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
|
||||
[ -rot ] dip 2each ; inline
|
||||
|
||||
: 2map-as ( seq1 seq2 quot exemplar -- newseq )
|
||||
: 2map-as ( ... seq1 seq2 quot: ( ... x1 x2 -- ... newx ) exemplar -- ... newseq )
|
||||
[ (2each) ] dip map-integers ; inline
|
||||
|
||||
: 2map ( seq1 seq2 quot -- newseq )
|
||||
: 2map ( ... seq1 seq2 quot: ( ... x1 x2 -- ... newx ) -- ... newseq )
|
||||
pick 2map-as ; inline
|
||||
|
||||
: 2all? ( seq1 seq2 quot -- ? )
|
||||
: 2all? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? )
|
||||
(2each) all-integers? ; inline
|
||||
|
||||
: 3each ( seq1 seq2 seq3 quot -- )
|
||||
: 3each ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... ) -- ... )
|
||||
(3each) each-integer ; inline
|
||||
|
||||
: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq )
|
||||
: 3map-as ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... newx ) exemplar -- ... newseq )
|
||||
[ (3each) ] dip map-integers ; inline
|
||||
|
||||
: 3map ( seq1 seq2 seq3 quot -- newseq )
|
||||
: 3map ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... newx ) -- ... newseq )
|
||||
[ pick ] dip swap 3map-as ; inline
|
||||
|
||||
: find-from ( n seq quot -- i elt )
|
||||
: find-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
|
||||
[ (find-integer) ] (find-from) ; inline
|
||||
|
||||
: find ( seq quot -- i elt )
|
||||
: find ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
|
||||
[ find-integer ] (find) ; inline
|
||||
|
||||
: find-last-from ( n seq quot -- i elt )
|
||||
: find-last-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
|
||||
[ nip find-last-integer ] (find-from) ; inline
|
||||
|
||||
: find-last ( seq quot -- i elt )
|
||||
: find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
|
||||
[ [ 1 - ] dip find-last-integer ] (find) ; inline
|
||||
|
||||
: all? ( seq quot -- ? )
|
||||
: all? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
|
||||
(each) all-integers? ; inline
|
||||
|
||||
: push-if ( elt quot accum -- )
|
||||
: push-if ( ... elt quot: ( ... elt -- ... ? ) accum -- ... )
|
||||
[ keep ] dip rot [ push ] [ 2drop ] if ; inline
|
||||
|
||||
: selector-for ( quot exemplar -- selector accum )
|
||||
|
|
@ -492,19 +492,19 @@ PRIVATE>
|
|||
: selector ( quot -- selector accum )
|
||||
V{ } selector-for ; inline
|
||||
|
||||
: filter-as ( seq quot exemplar -- subseq )
|
||||
: filter-as ( ... seq quot: ( ... elt -- ... ? ) exemplar -- ... subseq )
|
||||
dup [ selector-for [ each ] dip ] curry dip like ; inline
|
||||
|
||||
: filter ( seq quot -- subseq )
|
||||
: filter ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq )
|
||||
over filter-as ; inline
|
||||
|
||||
: push-either ( elt quot accum1 accum2 -- )
|
||||
: push-either ( ... elt quot: ( ... elt -- ... ? ) accum1 accum2 -- ... )
|
||||
[ keep swap ] 2dip ? push ; inline
|
||||
|
||||
: 2selector ( quot -- selector accum1 accum2 )
|
||||
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
|
||||
|
||||
: partition ( seq quot -- trueseq falseseq )
|
||||
: partition ( ... seq quot: ( ... elt -- ... ? ) -- ... trueseq falseseq )
|
||||
over [ 2selector [ each ] 2dip ] dip [ like ] curry bi@ ; inline
|
||||
|
||||
: collector-for ( quot exemplar -- quot' vec )
|
||||
|
|
@ -513,16 +513,16 @@ PRIVATE>
|
|||
: collector ( quot -- quot' vec )
|
||||
V{ } collector-for ; inline
|
||||
|
||||
: produce-as ( pred quot exemplar -- seq )
|
||||
: produce-as ( ... pred: ( ... -- ... ? ) quot: ( ... -- ... obj ) exemplar -- ... seq )
|
||||
dup [ collector-for [ while ] dip ] curry dip like ; inline
|
||||
|
||||
: produce ( pred quot -- seq )
|
||||
: produce ( ... pred: ( ... -- ... ? ) quot: ( ... -- ... obj ) -- ... seq )
|
||||
{ } produce-as ; inline
|
||||
|
||||
: follow ( obj quot -- seq )
|
||||
: follow ( ... obj quot: ( ... prev -- ... result/f ) -- ... seq )
|
||||
[ dup ] swap [ keep ] curry produce nip ; inline
|
||||
|
||||
: each-index ( seq quot -- )
|
||||
: each-index ( ... seq quot: ( ... x i -- ... ) -- ... )
|
||||
(each-index) each-integer ; inline
|
||||
|
||||
: interleave ( seq between quot -- )
|
||||
|
|
@ -532,10 +532,10 @@ PRIVATE>
|
|||
3bi
|
||||
] if ; inline
|
||||
|
||||
: map-index ( seq quot -- newseq )
|
||||
: map-index ( ... seq quot: ( ... x i -- ... newx ) -- ... newseq )
|
||||
[ dup length iota ] dip 2map ; inline
|
||||
|
||||
: reduce-index ( seq identity quot -- )
|
||||
: reduce-index ( ... seq identity quot: ( ... prev x i -- ... next ) -- ... result )
|
||||
swapd each-index ; inline
|
||||
|
||||
: index ( obj seq -- n )
|
||||
|
|
@ -564,7 +564,7 @@ PRIVATE>
|
|||
: nths ( indices seq -- seq' )
|
||||
[ nth ] curry map ;
|
||||
|
||||
: any? ( seq quot -- ? )
|
||||
: any? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
|
||||
find drop >boolean ; inline
|
||||
|
||||
: member? ( elt seq -- ? )
|
||||
|
|
@ -626,7 +626,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: (filter!) ( quot: ( elt -- ? ) store scan seq -- )
|
||||
: (filter!) ( ... quot: ( ... elt -- ... ? ) store scan seq -- ... )
|
||||
2dup length < [
|
||||
[ move ] 3keep
|
||||
[ nth-unsafe pick call [ 1 + ] when ] 2keep
|
||||
|
|
@ -636,7 +636,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: filter! ( seq quot -- seq )
|
||||
: filter! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq )
|
||||
swap [ [ 0 0 ] dip (filter!) ] keep ; inline
|
||||
|
||||
: remove! ( elt seq -- seq )
|
||||
|
|
@ -771,7 +771,7 @@ PRIVATE>
|
|||
] keep like
|
||||
] if ;
|
||||
|
||||
: padding ( seq n elt quot -- newseq )
|
||||
: padding ( ... seq n elt quot: ( ... seq1 seq2 -- ... newseq ) -- ... newseq )
|
||||
[
|
||||
[ over length [-] dup 0 = [ drop ] ] dip
|
||||
[ <repetition> ] curry
|
||||
|
|
@ -810,7 +810,7 @@ PRIVATE>
|
|||
: halves ( seq -- first-slice second-slice )
|
||||
dup midpoint@ cut-slice ;
|
||||
|
||||
: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
|
||||
: binary-reduce ( ... seq start quot: ( ... elt1 elt2 -- ... newelt ) -- ... value )
|
||||
#! We can't use case here since combinators depends on
|
||||
#! sequences
|
||||
pick length dup 0 3 between? [
|
||||
|
|
@ -873,11 +873,11 @@ PRIVATE>
|
|||
: 2unclip-slice ( seq1 seq2 -- rest-slice1 rest-slice2 first1 first2 )
|
||||
[ unclip-slice ] bi@ swapd ; inline
|
||||
|
||||
: map-reduce ( seq map-quot reduce-quot -- result )
|
||||
: map-reduce ( ..a seq map-quot: ( ..a x -- ..b elt ) reduce-quot: ( ..b prev elt -- ..a next ) -- ..a result )
|
||||
[ [ unclip-slice ] dip [ call ] keep ] dip
|
||||
compose reduce ; inline
|
||||
|
||||
: 2map-reduce ( seq1 seq2 map-quot reduce-quot -- result )
|
||||
: 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a x1 x2 -- ..b elt ) reduce-quot: ( ..b prev elt -- ..a next ) -- ..a result )
|
||||
[ [ prepare-2map-reduce ] keep ] dip
|
||||
compose compose each-integer ; inline
|
||||
|
||||
|
|
@ -889,10 +889,10 @@ PRIVATE>
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: map-find ( seq quot -- result elt )
|
||||
: map-find ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt )
|
||||
[ find ] (map-find) ; inline
|
||||
|
||||
: map-find-last ( seq quot -- result elt )
|
||||
: map-find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt )
|
||||
[ find-last ] (map-find) ; inline
|
||||
|
||||
: unclip-last-slice ( seq -- butlast-slice last )
|
||||
|
|
@ -915,22 +915,22 @@ PRIVATE>
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: trim-head-slice ( seq quot -- slice )
|
||||
: trim-head-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
|
||||
(trim-head) tail-slice ; inline
|
||||
|
||||
: trim-head ( seq quot -- newseq )
|
||||
: trim-head ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
|
||||
(trim-head) tail ; inline
|
||||
|
||||
: trim-tail-slice ( seq quot -- slice )
|
||||
: trim-tail-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
|
||||
(trim-tail) head-slice ; inline
|
||||
|
||||
: trim-tail ( seq quot -- newseq )
|
||||
: trim-tail ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
|
||||
(trim-tail) head ; inline
|
||||
|
||||
: trim-slice ( seq quot -- slice )
|
||||
: trim-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
|
||||
[ trim-head-slice ] [ trim-tail-slice ] bi ; inline
|
||||
|
||||
: trim ( seq quot -- newseq )
|
||||
: trim ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
|
||||
[ trim-slice ] [ drop ] 2bi like ; inline
|
||||
|
||||
GENERIC: sum ( seq -- n )
|
||||
|
|
@ -942,15 +942,15 @@ M: object sum 0 [ + ] binary-reduce ; inline
|
|||
|
||||
: supremum ( seq -- n ) [ ] [ max ] map-reduce ;
|
||||
|
||||
: map-sum ( seq quot -- n )
|
||||
: map-sum ( ... seq quot: ( ... elt -- ... n ) -- ... n )
|
||||
[ 0 ] 2dip [ dip + ] curry [ swap ] prepose each ; inline
|
||||
|
||||
: count ( seq quot -- n ) [ 1 0 ? ] compose map-sum ; inline
|
||||
: count ( ... seq quot: ( ... elt -- ... ? ) -- ... n ) [ 1 0 ? ] compose map-sum ; inline
|
||||
|
||||
: cartesian-each ( seq1 seq2 quot -- )
|
||||
: cartesian-each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
|
||||
[ with each ] 2curry each ; inline
|
||||
|
||||
: cartesian-map ( seq1 seq2 quot -- newseq )
|
||||
: cartesian-map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq )
|
||||
[ with map ] 2curry map ; inline
|
||||
|
||||
: cartesian-product ( seq1 seq2 -- newseq )
|
||||
|
|
|
|||
Loading…
Reference in New Issue