swap [ = nip ] curry assoc-find 2drop ;
: search-alist ( key alist -- pair i )
- [ first = ] curry* find swap ; inline
+ [ first = ] with find swap ; inline
M: sequence at*
search-alist [ second t ] [ f ] if ;
: union-class< ( cls1 cls2 -- ? )
[ flatten-union-class ] 2apply keys
- [ nip [ (class<) ] curry* contains? ] curry assoc-all? ;
+ [ nip [ (class<) ] with contains? ] curry assoc-all? ;
: (class<) ( class1 class2 -- ? )
{
: largest-class ( seq -- n elt )
dup [
[ 2dup class< >r swap class< not r> and ]
- curry* subset empty?
+ with subset empty?
] curry find [ "Topological sort failed" throw ] unless* ;
PRIVATE>
[ dupd classes-intersect? ] subset dup empty? [
2drop f
] [
- tuck [ class< ] curry* all? [ peek ] [ drop f ] if
+ tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ;
GENERIC: reset-class ( class -- )
! class<map
: bigger-classes ( class -- seq )
- classes [ (class<) ] curry* subset ;
+ classes [ (class<) ] with subset ;
: bigger-classes+ ( class -- )
[ bigger-classes [ dup ] H{ } map>assoc ] keep
: hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets
- [ case>quot ] curry* map ;
+ [ case>quot ] with map ;
: hash-dispatch-quot ( table -- quot )
[ length 1- [ fixnum-bitand ] curry ] keep
: notify-definition-observers ( assoc -- )
definition-observers get
- [ definitions-changed ] curry* each ;
+ [ definitions-changed ] with each ;
: changed-vocabs ( assoc -- vocabs )
[ drop word? ] assoc-subset
: clash? ( seq -- ? )
phantoms append [
dup cached? [ cached-vreg ] when swap member?
- ] curry* contains? ;
+ ] with contains? ;
: outputs-clash? ( -- ? )
output-vregs append clash? ;
all-words [
"methods" word-prop keys
swap [ key? ] curry contains?
- ] curry* subset ;
+ ] with subset ;
: implementors ( class -- seq )
dup associate implementors* ;
num-tags get [
vtable-class
[ swap first classes-intersect? ] curry subset
- ] curry* map ;
+ ] with map ;
: build-type-vtable ( alist-seq -- alist-seq )
dup length [
graph get [ drop H{ } clone ] cache ;
: add-vertex ( vertex edges graph -- )
- [ [ dupd nest set-at ] curry* each ] if-graph ; inline
+ [ [ dupd nest set-at ] with each ] if-graph ; inline
: remove-vertex ( vertex edges graph -- )
- [ [ graph get at delete-at ] curry* each ] if-graph ; inline
+ [ [ graph get at delete-at ] with each ] if-graph ; inline
SYMBOL: previous
local-recursive-state at ;
: recursive-quotation? ( quot -- ? )
- local-recursive-state [ first eq? ] curry* contains? ;
+ local-recursive-state [ first eq? ] with contains? ;
TUPLE: inference-error rstate major? ;
] H{ } make-assoc ; inline
: (infer-branches) ( last branches -- list )
- [ infer-branch ] curry* map
+ [ infer-branch ] with map
dup unify-effects unify-dataflow ; inline
: infer-branches ( last branches node -- )
: inlined? ( quot word -- ? )
swap dataflow optimize
- [ node-param eq? ] curry* node-exists? not ;
+ [ node-param eq? ] with node-exists? not ;
GENERIC: mynot ( x -- y )
M: #call-label calls-label* node-param eq? ;
: calls-label? ( label node -- ? )
- [ calls-label* ] curry* node-exists? ;
+ [ calls-label* ] with node-exists? ;
: recursive-label? ( node -- ? )
dup node-param swap calls-label? ;
swap node-classes at object or ;
: node-input-classes ( node -- seq )
- dup node-in-d [ node-class ] curry* map ;
+ dup node-in-d [ node-class ] with map ;
: node-input-intervals ( node -- seq )
- dup node-in-d [ node-interval ] curry* map ;
+ dup node-in-d [ node-interval ] with map ;
: node-class-first ( node -- class )
dup node-in-d first node-class ;
: nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
-: >le ( x n -- str ) [ nth-byte ] curry* "" map-as ;
+: >le ( x n -- str ) [ nth-byte ] with "" map-as ;
: >be ( x n -- str ) >le dup reverse-here ;
: d>w/w ( d -- w1 w2 )
[
dup string?
[ tuck path+ directory? 2array ] [ nip ] if
- ] curry* map
+ ] with map
[ first special-directory? not ] subset ;
: directory ( path -- seq )
<PRIVATE
: append-path ( path files -- paths )
- [ path+ ] curry* map ;
+ [ path+ ] with map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
{ $subsection curry }
{ $subsection 2curry }
{ $subsection 3curry }
-{ $subsection curry* }
+{ $subsection with }
{ $subsection compose }
{ $subsection 3compose }
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "."
{ $description "Outputs a " { $link callable } " which pushes " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } ", and then calls " { $snippet "quot" } "." }
{ $notes "This operation is efficient and does not copy the quotation." } ;
-HELP: curry*
+HELP: with
{ $values { "param" object } { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( param elt -- ... )" } } { "obj" object } { "curry" curry } }
{ $description "Partial application on the left. The following two lines are equivalent:"
{ $code "swap [ swap A ] curry B" }
- { $code "[ A ] curry* B" }
+ { $code "[ A ] with B" }
}
{ $notes "This operation is efficient and does not copy the quotation." }
{ $examples
- { $example "2 { 1 2 3 } [ - ] curry* map ." "{ 1 0 -1 }" }
+ { $example "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
} ;
HELP: compose
: 3curry ( obj1 obj2 obj3 quot -- curry )
curry curry curry ; inline
-: curry* ( param obj quot -- obj curry )
+: with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline
: compose ( quot1 quot2 -- curry )
M: mirror >alist ( mirror -- alist )
>mirror<
- [ [ slot-spec-offset slot ] curry* map ] keep
+ [ [ slot-spec-offset slot ] with map ] keep
[ slot-spec-reader ] map swap 2array flip ;
M: mirror assoc-size mirror-slots length ;
: partial-eval? ( #call -- ? )
dup node-param "foldable" word-prop [
- dup node-in-d [ node-literal? ] curry* all?
+ dup node-in-d [ node-literal? ] with all?
] [
drop f
] if ;
: literal-in-d ( #call -- inputs )
- dup node-in-d [ node-literal ] curry* map ;
+ dup node-in-d [ node-literal ] with map ;
: partial-eval ( #call -- node )
dup literal-in-d over node-param 1quotation
: p3 drop 3 ;
: regression-0
- [ 2drop ] curry* assoc-find ;
+ [ 2drop ] with assoc-find ;
[ t ] [
- [ [ 2drop ] curry* assoc-find ] kill-set
+ [ [ 2drop ] with assoc-find ] kill-set
[ 2drop ] swap member?
] unit-test
rot
[ 2swap [ swapd * -rot p2 +@ ] 2keep ]
assoc-each 2drop
- ] curry* assoc-each
+ ] with assoc-each
] H{ } make-assoc p3 ;
[ { t t t t t } ] [
rot
[ 2swap [ swapd * -rot p2 +@ ] 2keep ]
assoc-each 2drop
- ] curry* assoc-each
+ ] with assoc-each
]
}
\ regression-2 word-def kill-set
used-by empty? ;
: uses-values ( node seq -- )
- [ def-use get [ ?push ] change-at ] curry* each ;
+ [ def-use get [ ?push ] change-at ] with each ;
: defs-values ( seq -- )
#! If there is no value, set it to a new empty vector,
: math-closure ( class -- newclass )
{ fixnum integer rational real }
- [ class< ] curry* find nip number or ;
+ [ class< ] with find nip number or ;
: fits? ( interval class -- ? )
"interval" word-prop dup
dup forward-reference? [
drop
dup use get
- [ at ] curry* map [ ] subset
+ [ at ] with map [ ] subset
[ forward-reference? not ] find nip
[ ] [ forward-error ] ?if
] [
POSTPONE: delimiter
POSTPONE: inline
POSTPONE: foldable
- } [ declaration. ] curry* each ;
+ } [ declaration. ] with each ;
: pprint-; \ ; pprint-word ;
dup members [
hard line-break
\ INSTANCE: pprint-word pprint-word pprint-word
- ] curry* each block> block> ;
+ ] with each block> block> ;
M: predicate-class see-class*
<colon \ PREDICATE: pprint-word
natural-sort [ nl see ] each ;
: see-implementors ( class -- seq )
- dup implementors [ 2array ] curry* map ;
+ dup implementors [ 2array ] with map ;
: see-class ( class -- )
dup class? [
swap block-sections [ line-break? not ] subset
unclip pprint-section [
dup rot call pprint-section
- ] curry* each ; inline
+ ] with each ; inline
M: block short-section ( block -- )
[ advance ] pprint-sections ;
2dup 1- swap ?nth prev set
2dup 1+ swap ?nth next set
swap nth dup split-before dup , split-after
- ] curry* each
+ ] with each
] { } make { t } split [ empty? not ] subset ;
: break-group? ( seq -- ? )
] keep { } like ; inline
: index ( obj seq -- n )
- [ = ] curry* find drop ;
+ [ = ] with find drop ;
: index* ( obj i seq -- n )
rot [ = ] curry find* drop ;
: last-index ( obj seq -- n )
- [ = ] curry* find-last drop ;
+ [ = ] with find-last drop ;
: last-index* ( obj i seq -- n )
rot [ = ] curry find-last* drop ;
find drop >boolean ; inline
: member? ( obj seq -- ? )
- [ = ] curry* contains? ;
+ [ = ] with contains? ;
: memq? ( obj seq -- ? )
- [ eq? ] curry* contains? ;
+ [ eq? ] with contains? ;
: remove ( obj seq -- newseq )
- [ = not ] curry* subset ;
+ [ = not ] with subset ;
: cache-nth ( i seq quot -- elt )
pick pick ?nth dup [
: flip ( matrix -- newmatrix )
dup empty? [
dup [ length ] map infimum
- [ <column> dup like ] curry* map
+ [ <column> dup like ] with map
] unless ;
: sequence-hashcode-step ( oldhash newpart -- newhash )
: sequence-hashcode ( n seq -- x )
0 -rot [
hashcode* >fixnum sequence-hashcode-step
- ] curry* each ; inline
+ ] with each ; inline
2dup define-reader define-writer ;
: define-slots ( class specs -- )
- [ define-slot ] curry* each ;
+ [ define-slot ] with each ;
: reader-word ( class name vocab -- word )
>r >r "-" r> 3append r> create ;
rot rot simple-writer-word over set-slot-spec-writer ;
: simple-slots ( class slots base -- specs )
- over length [ + ] curry* map
+ over length [ + ] with map
[ >r >r dup r> r> simple-slot ] 2map nip ;
: slot-of-reader ( reader specs -- spec/f )
- [ slot-spec-reader eq? ] curry* find nip ;
+ [ slot-spec-reader eq? ] with find nip ;
: slot-of-writer ( writer specs -- spec/f )
- [ slot-spec-writer eq? ] curry* find nip ;
+ [ slot-spec-writer eq? ] with find nip ;
: reshape-tuple ( oldtuple permutation -- newtuple )
>r tuple>array 2 cut r>
- [ [ swap ?nth ] [ drop f ] if* ] curry* map
+ [ [ swap ?nth ] [ drop f ] if* ] with map
append (>tuple) ;
: reshape-tuples ( class newslots -- )
: old-slots ( class newslots -- seq )
swap "slots" word-prop 1 tail-slice
- [ slot-spec-name swap member? not ] curry* subset ;
+ [ slot-spec-name swap member? not ] with subset ;
: forget-slots ( class newslots -- )
dupd old-slots [
2dup
slot-spec-reader 2array forget
slot-spec-writer 2array forget
- ] curry* each ;
+ ] with each ;
: check-shape ( class newslots -- )
over tuple-class? [
} reset-props ;
M: object get-slots ( obj slots -- ... )
- [ execute ] curry* each ;
+ [ execute ] with each ;
M: object set-slots ( ... obj slots -- )
<reversed> get-slots ;
: words-named ( str -- seq )
dictionary get values
- [ vocab-words at ] curry* map
+ [ vocab-words at ] with map
[ ] subset ;
: child-vocab? ( prefix name -- ? )
[ 2drop t ] [ swap CHAR: . add head? ] if ;
: child-vocabs ( vocab -- seq )
- vocab-name vocabs [ child-vocab? ] curry* subset ;
+ vocab-name vocabs [ child-vocab? ] with subset ;
TUPLE: vocab-link name root ;
[ pick word-props ?set-at swap set-word-props ]
[ nip remove-word-prop ] if ;
-: reset-props ( word seq -- ) [ remove-word-prop ] curry* each ;
+: reset-props ( word seq -- ) [ remove-word-prop ] with each ;
: lookup ( name vocab -- word ) vocab-words at ;
alarms get-global push ;
: remove-alarm ( alarm -- )
- alarms get-global remove alarms set-global ;
+ alarms get-global delete ;
: handle-alarm ( alarm -- )
dup delegate {
: expired-alarms ( -- seq )
now alarms get-global
- [ alarm-time <=> 0 > ] curry* subset ;
+ [ alarm-time <=> 0 > ] with subset ;
: unexpired-alarms ( -- seq )
now alarms get-global
- [ alarm-time <=> 0 <= ] curry* subset ;
+ [ alarm-time <=> 0 <= ] with subset ;
: call-alarm ( alarm -- )
alarm-quot spawn drop ;
: center-i ( -- i ) width> 2 / >fixnum ;
-: center-line ( -- line ) center-i width> [ = 1 0 ? ] curry* map ;
+: center-line ( -- line ) center-i width> [ = 1 0 ? ] with map ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
} nth ;
: encode3 ( seq -- seq )
- be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] curry* map ;
+ be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] with map ;
: decode4 ( str -- str )
[ base64>ch ] map 0 [ swap 6 shift bitor ] reduce 3 >be ;
dup [
360 * swap 1+ / sat val
3array hsv>rgb first3 scale-rgb
- ] curry* map ;
+ ] with map ;
: iter ( c z nb-iter -- x )
over absq 4.0 >= over zero? or
standard-table-style [
functions [
[ tuck execute pprint-cell pprint-cell ] with-row
- ] curry* each
+ ] with each
] tabular-output ;
: partial-sums-main 2500000 partial-sums ;
[ oversampling /f ] 2apply 0.0 3float-array ;
: ss-grid ( -- ss-grid )
- oversampling [ oversampling [ ss-point ] curry* map ] map ;
+ oversampling [ oversampling [ ss-point ] with map ] map ;
: ray-grid ( point ss-grid -- ray-grid )
[
- [ v+ normalize { 0.0 0.0 -4.0 } swap <ray> ] curry* map
- ] curry* map ;
+ [ v+ normalize { 0.0 0.0 -4.0 } swap <ray> ] with map
+ ] with map ;
: ray-pixel ( scene point -- n )
ss-grid ray-grid 0.0 -rot
- [ [ swap cast-ray + ] curry* each ] curry* each ;
+ [ [ swap cast-ray + ] with each ] with each ;
: pixel-grid ( -- grid )
size reverse [
size [
[ size 0.5 * - ] 2apply swap size
3float-array
- ] curry* map
+ ] with map
] map ;
: pgm-header ( w h -- )
: pgm-pixel ( n -- ) 255 * 0.5 + >fixnum , ;
: ray-trace ( scene -- pixels )
- pixel-grid [ [ ray-pixel ] curry* map ] curry* map ;
+ pixel-grid [ [ ray-pixel ] with map ] with map ;
: run ( -- string )
levels { 0.0 -1.0 0.0 } 1.0 create ray-trace [
[ ":" split1 string>number [ dup length ] unless* ] { } map>assoc ;
: define-slots ( prefix names quots -- )
- >r [ "-" swap 3append create-in ] curry* map r>
+ >r [ "-" swap 3append create-in ] with map r>
[ define-compound ] 2each ;
: define-accessors ( classname slots -- )
<--&& ;
: cohesion-neighborhood ( self -- boids )
- boids> [ within-cohesion-neighborhood? ] curry* subset ;
+ boids> [ within-cohesion-neighborhood? ] with subset ;
: cohesion-force ( self -- force )
dup cohesion-neighborhood
<--&& ;
: separation-neighborhood ( self -- boids )
- boids> [ within-separation-neighborhood? ] curry* subset ;
+ boids> [ within-separation-neighborhood? ] with subset ;
: separation-force ( self -- force )
dup separation-neighborhood
<--&& ;
: alignment-neighborhood ( self -- boids )
-boids> [ within-alignment-neighborhood? ] curry* subset ;
+boids> [ within-alignment-neighborhood? ] with subset ;
: alignment-force ( self -- force )
alignment-neighborhood
[
[ 1+ print-day ] keep
1+ + 7 mod zero? [ nl ] [ bl ] if
- ] curry* each nl ;
+ ] with each nl ;
: print-year ( year -- )
- 12 [ 1+ print-month nl ] curry* each ;
+ 12 [ 1+ print-month nl ] with each ;
: pad-00 number>string 2 CHAR: 0 pad-left write ;
: strip-tease ( data -- seq )
dup third length 1 - [
2 + (strip-tease)
- ] curry* map ;
+ ] with map ;
: STRIP-TEASE:
parse-definition strip-tease [ parsed ] each ; parsing
: method-arg-types ( method -- args )
dup method_getNumberOfArguments
- [ method-arg-type parse-objc-type ] curry* map ;
+ [ method-arg-type parse-objc-type ] with map ;
: method-return-type ( method -- ctype )
#! Undocumented hack! Apple does not support this feature!
MACRO: ncurry ( n -- ) [ curry ] n*quot ;
-MACRO: ncurry* ( quot n -- )
+MACRO: nwith ( quot n -- )
tuck 1+ dup
[ , -nrot [ , nrot , call ] , ncurry ]
bake ;
! each-with
-: each-withn ( seq quot n -- ) ncurry* each ; inline
+: each-withn ( seq quot n -- ) nwith each ; inline
-: each-with ( seq quot -- ) curry* each ; inline
+: each-with ( seq quot -- ) with each ; inline
: each-with2 ( obj obj list quot -- ) 2 each-withn ; inline
! map-with
-: map-withn ( seq quot n -- newseq ) ncurry* map ; inline
+: map-withn ( seq quot n -- newseq ) nwith map ; inline
-: map-with ( seq quot -- ) curry* map ; inline
+: map-with ( seq quot -- ) with map ; inline
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
: patch-counts ( authors -- assoc )
dup prune
- [ dup rot [ = ] curry* count ] curry*
+ [ dup rot [ = ] with count ] with
{ } map>assoc ;
: contributors ( -- )
FUNCTION: void CFRelease ( void* cf ) ;
: CF>array ( alien -- array )
- dup CFArrayGetCount [ CFArrayGetValueAtIndex ] curry* map ;
+ dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
: <CFArray> ( seq -- alien )
[ f swap length f CFArrayCreateMutable ] keep
: make-w ( str -- )
#! compute w, steps a-b of RFC 3174, section 6.1
- 16 [ nth-int-be w get push ] curry* each
+ 16 [ nth-int-be w get push ] with each
16 80 dup <slice> [ sha1-W w get push ] each ;
: init-letters ( -- )
word-size get group [ be> ] map block-size get 0 pad-right
dup 16 64 dup <slice> [
process-M-256
- ] curry* each ;
+ ] with each ;
: ch ( x y z -- x' )
[ bitxor bitand ] keep bitxor ;
H get clone vars set
prepare-message-schedule block-size get [
T1 T2 update-vars
- ] curry* each vars get H get [ w+ ] 2map H set ;
+ ] with each vars get H get [ w+ ] 2map H set ;
: seq>string ( n seq -- string )
[ swap [ >be % ] curry each ] "" make ;
: remove-loc document-locs delete ;
: update-locs ( loc document -- )
- document-locs [ set-model ] curry* each ;
+ document-locs [ set-model ] with each ;
: doc-line ( n document -- string ) model-value nth ;
C: <faq> faq
: html>faq ( div -- faq )
- unclip swap { "h3" "ol" } [ tags-named ] curry* map
+ unclip swap { "h3" "ol" } [ tags-named ] with map
first2 >r f add* r> [ html>question-list ] 2map <faq> ;
: header, ( faq -- )
{ 3 }
] [
H{ { "n" "3" } } { { "n" v-number } }
- [ action-param drop ] curry* map
+ [ action-param drop ] with map
] unit-test
: foo ;
] [
nip
] if*
- ] curry* map ;
+ ] with map ;
: expire-sessions ( -- )
sessions get-global
: dot ( quadric i -- ) 2dup rim inner ;
-: golden-section ( quadric -- ) 720 [ dot ] curry* each ;
+: golden-section ( quadric -- ) 720 [ dot ] with each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: set-hash-stack ( value key seq -- )
- dupd [ key? ] curry* find-last nip set-at ;
+ dupd [ key? ] with find-last nip set-at ;
[ dup ] [ [ article-parent ] keep ] [ ] unfold nip 1 tail ;
: set-article-parents ( parent article -- )
- article-children [ set-article-parent ] curry* each ;
+ article-children [ set-article-parent ] with each ;
: xref-article ( topic -- )
dup >link xref dup set-article-parents ;
}
{ $subheading "Performance" }
{ $list
- { "The " { $link curry } " word now runs in constant time, and curried quotations can be called from compiled code; this allows for abstractions and idioms which were previously impractical due to performance issues. In particular, words such as " { $snippet "each-with" } " and " { $snippet "map-with" } " are gone; " { $snippet "each-with" } " can now be written as " { $snippet "curry* each" } ", and similarly for other " { $snippet "-with" } " combinators." }
+ { "The " { $link curry } " word now runs in constant time, and curried quotations can be called from compiled code; this allows for abstractions and idioms which were previously impractical due to performance issues. In particular, words such as " { $snippet "each-with" } " and " { $snippet "map-with" } " are gone; " { $snippet "each-with" } " can now be written as " { $snippet "with each" } ", and similarly for other " { $snippet "-with" } " combinators." }
"Improved generational promotion strategy in garbage collector reduces the amount of junk which makes its way into tenured space, which in turn reduces the frequency of full garbage collections."
"Faster generic word dispatch and union membership testing."
{ "Alien memory accessors (" { $link "reading-writing-memory" } ") are compiled as intrinsics where possible, which improves performance in code which iteroperates with C libraries." }
GENERIC: elements* ( elt-type element -- )
-M: simple-element elements* [ elements* ] curry* each ;
+M: simple-element elements* [ elements* ] with each ;
M: object elements* 2drop ;
M: array elements*
- [ [ elements* ] curry* each ] 2keep
+ [ [ elements* ] with each ] 2keep
[ first eq? ] keep swap [ , ] [ drop ] if ;
: elements ( elt-type element -- seq ) [ elements* ] { } make ;
<td "top" =valign swap table-style =style td>
>string write-html
</td>
- ] curry* each </tr>
- ] curry* each </table>
+ ] with each </tr>
+ ] with each </table>
] with-stream* ;
M: html-stream make-cell-stream ( style stream -- stream' )
] map ;
: find-by-id ( id vector -- vector )
- [ tag-attributes "id" swap at = ] curry* subset ;
+ [ tag-attributes "id" swap at = ] with subset ;
: find-by-class ( id vector -- vector )
- [ tag-attributes "class" swap at = ] curry* subset ;
+ [ tag-attributes "class" swap at = ] with subset ;
: find-by-name ( str vector -- vector )
>r >lower r>
- [ tag-name = ] curry* subset ;
+ [ tag-name = ] with subset ;
: find-first-name ( str vector -- i/f tag/f )
>r >lower r>
- [ tag-name = ] curry* find ;
+ [ tag-name = ] with find ;
: find-matching-close ( str vector -- i/f tag/f )
>r >lower r>
- [ [ tag-name = ] keep tag-closing? and ] curry* find ;
+ [ [ tag-name = ] keep tag-closing? and ] with find ;
: find-by-attribute-key ( key vector -- vector )
>r >lower r>
- [ tag-attributes at ] curry* subset
+ [ tag-attributes at ] with subset
[ ] subset ;
: find-by-attribute-key-value ( value key vector -- vector )
>r >lower r>
- [ tag-attributes at over = ] curry* subset nip
+ [ tag-attributes at over = ] with subset nip
[ ] subset ;
: find-first-attribute-key-value ( value key vector -- i/f tag/f )
>r >lower r>
- [ tag-attributes at over = ] curry* find rot drop ;
+ [ tag-attributes at over = ] with find rot drop ;
: find-between ( i/f tag/f vector -- vector )
pick integer? [
! : find-last-tag ( name vector -- index tag )
! [
! dup tag-matched? [ 2drop f ] [ tag-name = ] if
- ! ] curry* find-last ;
+ ! ] with find-last ;
! : find-last-tag* ( name n vector -- tag )
! 0 -rot <slice> find-last-tag ;
<PRIVATE
: append-path ( path files -- paths )
- [ path+ ] curry* map ;
+ [ path+ ] with map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
[ natural-sort ] keep [ index ] curry map ;
: (inversions) ( n seq -- n )
- [ > ] curry* subset length ;
+ [ > ] with subset length ;
: inversions ( seq -- n )
0 swap [ length ] keep [
] map [ ] subset 2nip ;
: basis ( generators -- seq )
- natural-sort dup length 2^ [ nth-basis-elt ] curry* map ;
+ natural-sort dup length 2^ [ nth-basis-elt ] with map ;
: (tensor) ( seq1 seq2 -- seq )
[
[ swap append natural-sort ] curry map
- ] curry* map concat ;
+ ] with map concat ;
: tensor ( graded-basis1 graded-basis2 -- bigraded-basis )
- [ [ swap (tensor) ] curry map ] curry* map ;
+ [ [ swap (tensor) ] curry map ] with map ;
! Computing cohomology
: (op-matrix) ( range quot basis-elt -- row )
over first length [
>r 2dup r> spin (bigraded-ker/im-d)
] map 2nip
- ] curry* map ;
+ ] with map ;
: bigraded-betti ( u-generators z-generators -- seq )
[ basis graded ] 2apply tensor bigraded-ker/im-d
] [
nullspace [
[ [ wedge (alt+) ] 2each ] with-terms
- ] curry* map
+ ] with map
] if ;
: graded-triple ( seq n -- triple )
- 3 [ 1- + ] curry* map swap [ ?nth ] curry map ;
+ 3 [ 1- + ] with map swap [ ?nth ] curry map ;
: graded-triples ( seq -- triples )
- dup length [ graded-triple ] curry* map ;
+ dup length [ graded-triple ] with map ;
: graded-laplacian ( generators quot -- seq )
>r basis graded graded-triples [ first3 ] r> compose map ;
over first length [
>r 2dup r> spin bigraded-triple
] map 2nip
- ] curry* map ;
+ ] with map ;
: bigraded-laplacian ( u-generators z-generators quot -- seq )
>r [ basis graded ] 2apply tensor bigraded-triples r>
} nth >r 4 * dup 4 + r> subseq ;
: lcd-row ( num row -- )
- swap [ CHAR: 0 - swap lcd-digit write ] curry* each ;
+ swap [ CHAR: 0 - swap lcd-digit write ] with each ;
: lcd ( digit-str -- )
- 3 [ lcd-row nl ] curry* each ;
+ 3 [ lcd-row nl ] with each ;
: lcd-demo ( -- ) "31337" lcd ;
IN: levenshtein
: <matrix> ( m n -- matrix )
- [ drop 0 <array> ] curry* map ; inline
+ [ drop 0 <array> ] with map ; inline
: matrix-> nth nth ; inline
: ->matrix nth set-nth ; inline
: compute-costs ( str1 str2 -- )
swap [
- [ = 0 1 ? ] curry* { } map-as
+ [ = 0 1 ? ] with { } map-as
] curry { } map-as costs set ; inline
: levenshtein-step ( i j -- )
2dup compute-costs
[ length ] 2apply [
[ levenshtein-step ] curry each
- ] curry* each
+ ] with each
levenshtein-result
] with-scope ;
M: callable lint ( quot -- seq )
def-hash-keys get [
swap subseq/member?
- ] curry* subset ;
+ ] with subset ;
M: word lint ( word -- seq )
word-def dup callable? [ lint ] [ drop f ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: && ( obj seq -- ? ) [ call ] curry* all? ;
+: && ( obj seq -- ? ) [ call ] with all? ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: local-index ( obj args -- n )
- [ dup quote? [ quote-local ] when eq? ] curry* find drop ;
+ [ dup quote? [ quote-local ] when eq? ] with find drop ;
: read-local ( obj args -- quot )
local-index 1+
} ; inline
: gamma-z ( x n -- seq )
- [ + recip ] curry* map 1.0 0 pick set-nth ;
+ [ + recip ] with map 1.0 0 pick set-nth ;
: (gamma-lanczos6) ( x -- log[gamma[x+1]] )
#! log(gamma(x+1)
dup 1000003 < [
0 primes-under-million seq>list swap [ <= ] curry lwhile
] [
- <erato> 2 [ drop next-prime ] curry* lfrom-by [ ] lwhile
+ <erato> 2 [ drop next-prime ] with lfrom-by [ ] lwhile
] if ;
math.functions kernel splitting ;
IN: math.fft
-: n^v ( n v -- w ) [ ^ ] curry* map ;
+: n^v ( n v -- w ) [ ^ ] with map ;
: even ( seq -- seq ) 2 group 0 <column> ;
: odd ( seq -- seq ) 2 group 1 <column> ;
DEFER: fft
: identity-matrix ( n -- matrix )
#! Make a nxn identity matrix.
- dup [ [ = 1 0 ? ] curry* map ] curry map ;
+ dup [ [ = 1 0 ? ] with map ] curry map ;
! Matrix operations
: mneg ( m -- m ) [ vneg ] map ;
-: n*m ( n m -- m ) [ n*v ] curry* map ;
+: n*m ( n m -- m ) [ n*v ] with map ;
: m*n ( m n -- m ) [ v*n ] curry map ;
-: n/m ( n m -- m ) [ n/v ] curry* map ;
+: n/m ( n m -- m ) [ n/v ] with map ;
: m/n ( m n -- m ) [ v/n ] curry map ;
: m+ ( m m -- m ) [ v+ ] 2map ;
: m* ( m m -- m ) [ v* ] 2map ;
: m/ ( m m -- m ) [ v/ ] 2map ;
-: v.m ( v m -- v ) flip [ v. ] curry* map ;
+: v.m ( v m -- v ) flip [ v. ] with map ;
: m.v ( m v -- v ) [ v. ] curry map ;
: m. ( m m -- m ) flip [ swap m.v ] curry map ;
: unique-primes ( numbits n -- seq )
#! generate two primes
over 5 < [ "not enough primes below 5 bits" throw ] when
- [ [ drop random-prime ] curry* map ] [ all-unique? ] generate ;
+ [ [ drop random-prime ] with map ] [ all-unique? ] generate ;
dup length 1 <= [
drop 0
] [
- [ [ mean ] keep [ - sq ] curry* sigma ] keep
+ [ [ mean ] keep [ - sq ] with sigma ] keep
length 1- /
] if ;
: vneg ( u -- v ) [ neg ] map ;
: v*n ( u n -- v ) [ * ] curry map ;
-: n*v ( n u -- v ) [ * ] curry* map ;
+: n*v ( n u -- v ) [ * ] with map ;
: v/n ( u n -- v ) [ / ] curry map ;
-: n/v ( n u -- v ) [ / ] curry* map ;
+: n/v ( n u -- v ) [ / ] with map ;
: v+ ( u v -- w ) [ + ] 2map ;
: v- ( u v -- w ) [ - ] 2map ;
: choices ( cell -- seq )
{ { -1 0 } { 1 0 } { 0 -1 } { 0 1 } }
- [ v+ ] curry* map
+ [ v+ ] with map
[ unvisited? ] subset ;
: random-neighbour ( cell -- newcell ) choices random ;
line-width 2 - glLineWidth
line-width 2 - glPointSize
1.0 1.0 1.0 1.0 glColor4d
- dup [ drop t <array> ] curry* map visited set
+ dup [ drop t <array> ] with map visited set
GL_LINE_STRIP glBegin
{ 0 0 } dup vertex (draw-maze)
glEnd ;
: deactivate-model ( model -- )
dup unref-model zero? [
dup model-dependencies
- [ dup deactivate-model remove-connection ] curry* each
+ [ dup deactivate-model remove-connection ] with each
] [
drop
] if ;
M: model update-model drop ;
: notify-connections ( model -- )
- dup model-connections [ model-changed ] curry* each ;
+ dup model-connections [ model-changed ] with each ;
: set-model ( value model -- )
dup model-locked? [
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: add-methods ( class seq -- ) 2 group [ first2 add-method ] curry* each ;
+: add-methods ( class seq -- ) 2 group [ first2 add-method ] with each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[\r
dup odbc-number-of-columns [\r
1+ odbc-get-field field-value ,\r
- ] curry* each \r
+ ] with each \r
] { } make ;\r
\r
: (odbc-get-all-rows) ( statement -- )\r
: adjust-points [ [ 1 + 0.5 * ] map ] 2apply ;
-: scale-points 2array flip [ v* ] curry* map [ v+ ] curry* map ;
+: scale-points 2array flip [ v* ] with map [ v+ ] with map ;
: circle-points ( loc dim steps -- points )
circle-steps unit-circle adjust-points scale-points ;
: result>seq ( -- seq )
query-res get [ PQnfields ] keep PQntuples
- [ swap [ query-res get -rot PQgetvalue ] curry* map ] curry* map ;
+ [ swap [ query-res get -rot PQgetvalue ] with map ] with map ;
: print-table ( seq -- )
[ [ write bl ] each "\n" write ] each ;
: probabilities ( weights -- probabilities ) dup sum [ / ] curry map ;
: layers ( probabilities -- layers )
-dup length 1+ [ head ] curry* map 1 tail [ sum ] map ;
+dup length 1+ [ head ] with map 1 tail [ sum ] map ;
: random-weighted ( weights -- elt )
probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ;
: init-mt-rest ( seq -- )
mt-n 1 head* [
[ init-mt-formula ] 2keep 1+ swap set-nth
- ] curry* each ;
+ ] with each ;
: mt-temper ( y -- yt )
dup -11 shift bitxor
[ children>string ] [ f ] if* ;
: any-tag-named ( tag names -- tag-inside )
- f -rot [ tag-named nip dup ] curry* find 2drop ;
+ f -rot [ tag-named nip dup ] with find 2drop ;
TUPLE: feed title link entries ;
<PRIVATE
: translate-string ( n alphabet out-len -- seq )
- [ drop /mod ] curry* map nip ;
+ [ drop /mod ] with map nip ;
: map-alphabet ( alphabet seq[seq] -- seq[seq] )
- [ [ swap nth ] curry* map ] curry* map ;
+ [ [ swap nth ] with map ] with map ;
: exact-number-strings ( n out-len -- seqs )
[ ^ ] 2keep [ translate-string ] 2curry map ;
: number-strings ( n max-length -- seqs )
- 1+ [ exact-number-strings ] curry* map concat ;
+ 1+ [ exact-number-strings ] with map concat ;
PRIVATE>
: exact-strings ( alphabet length -- seqs )
: object-id ( obj -- id )
#! Return the id of an already serialized object
- serialized get [ eq? ] curry* find [ drop f ] unless ;
+ serialized get [ eq? ] with find [ drop f ] unless ;
USE: prettyprint
first2 "-" swap 3append >string ;
: make-shuffles ( max-out max-in -- shuffles )
- [ 1+ dup rot strings [ 2array ] curry* map ]
- curry* map concat ;
+ [ 1+ dup rot strings [ 2array ] with map ]
+ with map concat ;
: shuffle>quot ( shuffle -- quot )
[
- first2 2dup [ - ] curry* map
+ first2 2dup [ - ] with map
reverse [ , \ npick , \ >r , ] each
swap , \ ndrop , length [ \ r> , ] times
] [ ] make ;
in-shuffle over length make-shuffles [
[ shuffle>string create-in ] keep
shuffle>quot dupd define-compound put-effect
- ] curry* each out-shuffle ;
+ ] with each out-shuffle ;
: SHUFFLE:
scan scan string>number define-shuffles ; parsing
! Send the half of the snake in a random direction
-nodes> 10 [ swap nth ] curry* map
-nodes> 10 [ 19 + swap nth ] curry* map append
+nodes> 10 [ swap nth ] with map
+nodes> 10 [ 19 + swap nth ] with map append
100 random -50 + 100 random 100 + { -1 1 } random * 2array
[ swap set-node-vel ] curry
each ;
] [
drop f
] if
- ] curry* map [ ] subset dup length 0 > [
+ ] with map [ ] subset dup length 0 > [
" where " %
" and " join %
] [
[ db-field-slot slot ] keep ! statement value field
db-field-bind-name swap ! statement name value
>r dupd r> sqlite-bind-text-by-name
- ] curry* each drop ;
+ ] with each drop ;
: bind-for-select ( statement tuple -- )
#! Bind the fields in the tuple to the fields in the
] [
2drop
] if
- ] curry* each drop ;
+ ] with each drop ;
: bind-for-update ( statement tuple -- )
#! Bind the fields in the tuple to the fields in the
TUPLE: board width height rows ;
: make-rows ( width height -- rows )
- [ drop f <array> ] curry* map ;
+ [ drop f <array> ] with map ;
: <board> ( width height -- board )
2dup make-rows board construct-boa ;
2dup block-in-bounds? [ block-free? ] [ 2drop f ] if ;
: piece-valid? ( board piece -- ? )
- piece-blocks [ location-valid? ] curry* all? ;
+ piece-blocks [ location-valid? ] with all? ;
: row-not-full? ( row -- ? ) f swap member? ;
over tetris-rows + swap set-tetris-rows ;
: lock-piece ( tetris -- )
- [ dup tetris-current-piece piece-blocks [ add-block ] curry* each ] keep
+ [ dup tetris-current-piece piece-blocks [ add-block ] with each ] keep
dup new-current-piece dup check-rows score-rows ;
: can-rotate? ( tetris -- ? )
[ [ advance-timer ] keep timer-object tick ] [ 2drop ] if ;
: do-timers ( -- )
- millis timers values [ do-timer ] curry* each ;
+ millis timers values [ do-timer ] with each ;
dup empty? [
drop
] [
- swap [ "." swap 3append ] curry* map
+ swap [ "." swap 3append ] with map
] if ;
: vocabs-in-dir ( root name -- )
dupd (all-child-vocabs) [
2dup vocab-dir? [ 2dup swap >vocab-link , ] when
vocabs-in-dir
- ] curry* each ;
+ ] with each ;
: sane-vocab-roots "." vocab-roots get remove ;
[ vocab-root not ] subset
[
vocab-name swap ?head CHAR: . rot member? not and
- ] curry* subset
+ ] with subset
[ vocab ] map ;
: all-child-vocabs ( prefix -- assoc )
sane-vocab-roots [
dup pick dupd (all-child-vocabs)
- [ swap >vocab-link ] curry* map
+ [ swap >vocab-link ] with map
] { } map>assoc
f rot unrooted-child-vocabs 2array add ;
runs [
[ 0 [ pick score-1 max ] reduce nip ] keep
length * +
- ] curry* each
+ ] with each
] [
2drop 0
] if ;
: rank-completions ( results -- newresults )
sort-keys <reversed>
[ 0 [ first max ] reduce 3 /f ] keep
- [ first < ] curry* subset
+ [ first < ] with subset
[ second ] map ;
: complete ( full short -- score )
over empty? [
nip [ first ] map
] [
- >r >lower r> [ completion ] curry* map rank-completions
+ >r >lower r> [ completion ] with map rank-completions
] if ;
: string-completions ( short strs -- seq )
: (method-usage) ( word generic -- methods )
tuck methods
- [ second quot-uses key? ] curry* subset
+ [ second quot-uses key? ] with subset
0 <column>
swap [ 2array ] curry map ;
: method-usage ( word seq -- methods )
- [ generic? ] subset [ (method-usage) ] curry* map concat ;
+ [ generic? ] subset [ (method-usage) ] with map concat ;
: compound-usage ( words -- seq )
[ generic? not ] subset ;
[
[ word-props strip-assoc f assoc-like ] keep
set-word-props
- ] curry* each ;
+ ] with each ;
: retained-props ( -- seq )
[
"factor-nt.dll"
} [
dup resource-path -rot path+ copy-file
- ] curry* each ;
+ ] with each ;
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dlls
IN: temporary
: randomize-numeric-splay-tree ( splay-tree -- )
- 100 [ drop 100 random swap at drop ] curry* each ;
+ 100 [ drop 100 random swap at drop ] with each ;
: make-numeric-splay-tree ( n -- splay-tree )
<splay> [ [ dupd set-at ] curry each ] keep ;
: parse-slot-writer ( tuple -- slot-setter )
scan dup "}" = [ 2drop f ] [
1 head* swap class "slots" word-prop
- [ slot-spec-name = ] curry* find nip slot-spec-writer
+ [ slot-spec-name = ] with find nip slot-spec-writer
] if ;
: parse-slots ( accum tuple -- accum tuple )
] cache-nth nip ;
M: freetype-renderer string-width ( open-font string -- w )
- 0 -rot [ char-width + ] curry* each ;
+ 0 -rot [ char-width + ] with each ;
M: freetype-renderer string-height ( open-font string -- h )
drop font-height ;
>r >r world get font-sprites first2 r> r> (draw-string) ;
: run-char-widths ( open-font string -- widths )
- [ char-width ] curry* { } map-as
+ [ char-width ] with { } map-as
dup 0 [ + ] accumulate nip swap 2 v/n v+ ;
M: freetype-renderer x>offset ( x open-font string -- n )
- dup >r run-char-widths [ <= ] curry* find drop
+ dup >r run-char-widths [ <= ] with find drop
[ r> drop ] [ r> length ] if* ;
T{ freetype-renderer } font-renderer set-global
M: book layout*
dup rect-dim swap gadget-children
- [ set-layout-dim ] curry* each ;
+ [ set-layout-dim ] with each ;
M: book focusable-child* current-page ;
\ first-visible-line get [
editor get dup editor-color gl-color
dup visible-lines
- [ draw-line 1 translate-lines ] curry* each
+ [ draw-line 1 translate-lines ] with each
] with-editor-translation ;
: selection-start/end ( editor -- start end )
dup gadget-visible? [ intersects? ] [ 2drop f ] if ;
: (pick-up) ( point gadget -- gadget )
- dupd children-on [ inside? ] curry* find-last nip ;
+ dupd children-on [ inside? ] with find-last nip ;
: pick-up ( point gadget -- child/f )
2dup (pick-up) dup
: set-gadget-delegate ( gadget tuple -- )
over [
- dup pick [ set-gadget-parent ] curry* each-child
+ dup pick [ set-gadget-parent ] with each-child
] when set-delegate ;
: construct-control ( model gadget class -- control )
: draw-grid-lines ( gaps orientation -- )
grid get rot grid-positions grid get rect-dim add [
grid-line-from/to gl-line
- ] curry* each ;
+ ] with each ;
M: grid-lines draw-boundary
origin get [
>r first r> second 2array ;
: pair-up ( horiz vert -- dims )
- [ [ (pair-up) ] curry map ] curry* map ;
+ [ [ (pair-up) ] curry map ] with map ;
: add-gaps ( gap seq -- newseq )
- [ v+ ] curry* map ;
+ [ v+ ] with map ;
: gap-sum ( gap seq -- newseq )
dupd add-gaps dim-sum v+ ;
TUPLE: pack align fill gap ;
: packed-dim-2 ( gadget sizes -- list )
- [ over rect-dim over v- rot pack-fill v*n v+ ] curry* map ;
+ [ over rect-dim over v- rot pack-fill v*n v+ ] with map ;
: packed-dims ( gadget sizes -- seq )
2dup packed-dim-2 swap orient ;
{ 0 0 } [ v+ over v+ ] accumulate 2nip ;
: aligned-locs ( gadget sizes -- seq )
- [ >r dup pack-align swap rect-dim r> v- n*v ] curry* map ;
+ [ >r dup pack-align swap rect-dim r> v- n*v ] with map ;
: packed-locs ( gadget sizes -- seq )
over pack-gap over gap-locs >r dupd aligned-locs r> orient ;
2dup node-value swap offset-rect [
drop 2dup
[ node-value rect-loc v+ ] keep
- node-children [ draw-selection ] curry* each
+ node-children [ draw-selection ] with each
] if-fits 2drop ;
M: pane draw-gadget*
dup gadget-selection? [
dup pane-selection-color gl-color
origin get over rect-loc v- swap selected-children
- [ draw-selection ] curry* each
+ [ draw-selection ] with each
] [
drop
] if ;
(fast-children-on) ;
M: gadget sloppy-pick-up*
- gadget-children [ inside? ] curry* find-last drop ;
+ gadget-children [ inside? ] with find-last drop ;
M: f sloppy-pick-up*
2drop f ;
: do-wrap ( paragraph quot -- dim )
[
swap dup init-wrap
- [ wrap-step ] curry* each-child wrap-dim
+ [ wrap-step ] with each-child wrap-dim
] with-scope ; inline
M: paragraph pref-dim*
] if ;
: each-gesture ( gesture seq -- )
- [ handle-gesture drop ] curry* each ;
+ [ handle-gesture drop ] with each ;
: hand-gestures ( new old -- )
drop-prefix <reversed>
] if ;
: modifier ( mod modifiers -- seq )
- [ second swap bitand 0 > ] curry* subset
+ [ second swap bitand 0 > ] with subset
0 <column> prune dup empty? [ drop f ] [ >array ] if ;
: drag-loc ( -- loc )
SYMBOL: operations
: object-operations ( obj -- operations )
- operations get [ operation-predicate call ] curry* subset ;
+ operations get [ operation-predicate call ] with subset ;
: find-operation ( obj quot -- command )
>r object-operations r> find-last nip ; inline
dup string? [
string-height
] [
- [ string-height ] curry* map sum
+ [ string-height ] with map sum
] if ;
: text-width ( open-font text -- n )
dup string? [
string-width
] [
- 0 -rot [ string-width max ] curry* each
+ 0 -rot [ string-width max ] with each
] if ;
: text-dim ( open-font text -- dim )
2dup { 0 0 } draw-string
>r open-font r> string-height
0.0 swap 0.0 glTranslated
- ] curry* each
+ ] with each
] with-translation
] if ;
: search-gesture ( gesture live-search -- operation/f )
search-value object-operations
- [ operation-gesture = ] curry* find nip ;
+ [ operation-gesture = ] with find nip ;
M: live-search handle-gesture* ( gadget gesture delegate -- ? )
drop over search-gesture dup [
M: gadget tool-scroller drop f ;
: find-tool ( class workspace -- index tool )
- workspace-book gadget-children [ class eq? ] curry* find ;
+ workspace-book gadget-children [ class eq? ] with find ;
: show-tool ( class workspace -- tool )
[ find-tool swap ] keep workspace-book gadget-model
[ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
: unregister-window ( handle -- )
- windows global [ [ first = not ] curry* subset ] change-at ;
+ windows global [ [ first = not ] with subset ] change-at ;
: raised-window ( world -- )
- windows get-global [ second eq? ] curry* find drop
+ windows get-global [ second eq? ] with find drop
windows get-global [ length 1- ] keep exchange ;
: focus-gestures ( new old -- )
: find-window ( quot -- world )
windows get values
- [ gadget-child swap call ] curry* find-last nip ; inline
+ [ gadget-child swap call ] with find-last nip ; inline
SYMBOL: ui-hook
: supported-type? ( atom -- ? )
{ "UTF8_STRING" "STRING" "TEXT" }
- [ x-atom = ] curry* contains? ;
+ [ x-atom = ] with contains? ;
: clipboard-for-atom ( atom -- clipboard )
{
: disconnect ( class1 class2 -- ) 0 set-table ;
: connect-before ( class classes -- )
- [ connect ] curry* each ;
+ [ connect ] with each ;
: connect-after ( classes class -- )
[ connect ] curry each ;
: break-around ( classes1 classes2 -- )
- [ [ 2dup disconnect swap disconnect ] curry* each ] curry each ;
+ [ [ 2dup disconnect swap disconnect ] with each ] curry each ;
: make-grapheme-table ( -- )
CR LF connect
[ { f f t t f t t f f t } ] [ CHAR: A {
blank? letter? LETTER? Letter? digit?
printable? alpha? control? uncased? character?
-} [ execute ] curry* map ] unit-test
+} [ execute ] with map ] unit-test
[ "Nd" ] [ CHAR: 3 category ] unit-test
[ CHAR: ! ] [ UNICHAR: exclamation-mark ] unit-test
[ "ab\u0323\u0302cd" ] [ "ab\u0302" "\u0323cd" string-append ] unit-test
pick [ between? ] [ 3drop f ] if ;
: range ( from to -- seq )
- 1+ over - [ + ] curry* map ;
+ 1+ over - [ + ] with map ;
! Loading data from UnicodeData.txt
"extra/unicode/UnicodeData.txt" resource-path data ;
: (process-data) ( index data -- newdata )
- [ [ nth ] keep first swap 2array ] curry* map
+ [ [ nth ] keep first swap 2array ] with map
[ second empty? not ] subset
[ >r hex> r> ] assoc-map ;
[
2dup swap at
[ (chain-decomposed) ] [ 1array nip ] ?if
- ] curry* map concat ;
+ ] with map concat ;
: chain-decomposed ( hash -- newhash )
dup [ swap (chain-decomposed) ] curry assoc-map ;
category# categories nth ;
: >category-array ( categories -- bitarray )
- categories [ swap member? ] curry* map >bit-array ;
+ categories [ swap member? ] with map >bit-array ;
: as-string ( strings -- bit-array )
concat "\"" tuck 3append parse first ;
swap [ [
dup hangul? [ hangul>jamo % drop ]
[ dup rot call [ % ] [ , ] ?if ] if
- ] curry* each ] "" make*
+ ] with each ] "" make*
dup reorder
] if ; inline
: articles-for-tag ( tag -- seq )
[ tag-name ] keep tag-hostname all-articles [
tags-for-article member?
- ] curry* subset ;
+ ] with subset ;
: fetch-blogroll ( blogroll -- entries )
dup 0 <column>
swap [ ?fetch-feed ] parallel-map
- [ [ <posting> ] curry* map ] 2map concat ;
+ [ [ <posting> ] with map ] 2map concat ;
: sort-entries ( entries -- entries' )
[ [ entry-pub-date ] compare ] sort <reversed> ;
: check-source-path ( path -- ? )
{ "vm/" "core/" "extra/" "misc/" }
- [ head? ] curry* contains? ;
+ [ head? ] with contains? ;
: source-responder ( path mime-type -- )
drop
: attr@ ( key alist -- index {key,value} )
>r assure-name r> attrs-alist
- [ first names-match? ] curry* find ;
+ [ first names-match? ] with find ;
M: attrs at*
attr@ nip [ second t ] [ f f ] if* ;
: assemble-data ( tag -- 3array )
{ "URL" "snippet" "title" }
- [ tag-named children>string ] curry* map ;
+ [ tag-named children>string ] with map ;
: parse-result ( xml -- seq )
"resultElements" deep-tag-named "item" tags-named
: tag-named ( tag name/string -- matching-tag )
! like get-name-tag but only looks at direct children,
! not all the children down the tree.
- assure-name swap [ tag-named? ] curry* find nip ;
+ assure-name swap [ tag-named? ] with find nip ;
: tags-named ( tag name/string -- tags-seq )
- tags@ swap [ tag-named? ] curry* subset ;
+ tags@ swap [ tag-named? ] with subset ;
: tag-with-attr? ( elem attr-value attr-name -- ? )
rot dup tag? [ at = ] [ 3drop f ] if ;
: parse-modes-tag ( tag -- modes )
H{ } clone [
- swap child-tags [ parse-mode-tag ] curry* each
+ swap child-tags [ parse-mode-tag ] with each
] keep ;
: load-catalog ( -- modes )
] [
3drop
] if
- ] curry* each ;
+ ] with each ;
: finalize-rule-set ( ruleset -- )
dup rule-set-finalized? {
: parse-begin/end-tags
[
! XXX: handle position attrs on span tag itself
- child-tags [ parse-begin/end-tag ] curry* each
+ child-tags [ parse-begin/end-tag ] with each
] , ;
: init-span-tag [ drop init-span ] , ;
: parse-rules-tag ( tag -- rule-set )
dup (parse-rules-tag) [
dup rule-set-ignore-case? ignore-case? [
- swap child-tags [ parse-rule-tag ] curry* each
+ swap child-tags [ parse-rule-tag ] with each
] with-variable
] keep ;
] H{ } map>assoc
swap "PROPS" tag-named [
parse-props-tag over values
- [ merge-rule-set-props ] curry* each
+ [ merge-rule-set-props ] with each
] when* ;
: parse-mode ( stream -- rule-sets )
init-from-tag dup
] keep
tag-children [ tag? ] subset
- [ parse-employee-tag ] curry* each ;
+ [ parse-employee-tag ] with each ;
[
T{ company f
: parse-yahoo ( xml -- seq )
"Result" deep-tags-named [
{ "Title" "Url" "Summary" }
- [ tag-named children>string ] curry* map
+ [ tag-named children>string ] with map
first3 <result>
] map ;
projects / factor.git / commitdiff