2dup [ expired? ] either? [
[ expired? ] both?
] [
- [ alien-address ] 2apply =
+ [ alien-address ] bi@ =
] if
] [
2drop f
swap [ swapd set-at ] curry assoc-each ;
: union ( assoc1 assoc2 -- union )
- 2dup [ assoc-size ] 2apply + pick new-assoc
+ 2dup [ assoc-size ] bi@ + pick new-assoc
[ rot update ] keep [ swap update ] keep ;
: diff ( assoc1 assoc2 -- diff )
{ t f t } { f t f }
] [
{ t f t } >bit-array dup clone dup [ not ] change-each
- [ >array ] 2apply
+ [ >array ] bi@
] unit-test
[
: load-components ( -- )
"exclude" "include"
- [ get-global " " split [ empty? not ] subset ] 2apply
+ [ get-global " " split [ empty? not ] subset ] bi@
seq-diff
[ "bootstrap." prepend require ] each ;
members>> [ class< ] with all? ;\r
\r
: anonymous-complement< ( first second -- ? )\r
- [ class>> ] 2apply swap class< ;\r
+ [ class>> ] bi@ swap class< ;\r
\r
: (class<) ( first second -- -1/0/1 ) \r
{\r
M: mixin-instance equal?
{
{ [ over mixin-instance? not ] [ f ] }
- { [ 2dup [ mixin-instance-class ] 2apply = not ] [ f ] }
- { [ 2dup [ mixin-instance-mixin ] 2apply = not ] [ f ] }
+ { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
+ { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
{ [ t ] [ t ] }
} cond 2nip ;
[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-call ] unit-test
-[ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-call ] unit-test
+[ -10 -20 ] [ 10 20 -1 [ [ * ] curry bi@ ] compile-call ] unit-test
[ [ 5 2 - ] ] [ 5 [ [ 2 - ] curry ] compile-call >quotation ] unit-test
[ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-call >quotation ] unit-test
] unit-test
[ 12 13 ] [
- -12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-call
+ -12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
] unit-test
[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
[ 12 13 ] [
- -12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call
+ -12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
] unit-test
[ 1 ] [
M: immediate load-literal
over v>operand small-enough? [
- [ v>operand ] 2apply swap MOV
+ [ v>operand ] bi@ swap MOV
] [
v>operand load-indirect
] if ;
! Alien intrinsics
M: arm-backend %unbox-byte-array ( dst src -- )
- [ v>operand ] 2apply byte-array-offset ADD ;
+ [ v>operand ] bi@ byte-array-offset ADD ;
M: arm-backend %unbox-alien ( dst src -- )
- [ v>operand ] 2apply alien-offset <+> LDR ;
+ [ v>operand ] bi@ alien-offset <+> LDR ;
M: arm-backend %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
f fresh-object ;
M: ppc-backend %box-float ( dst src -- )
- [ v>operand ] 2apply %allot-float 12 MR ;
+ [ v>operand ] bi@ %allot-float 12 MR ;
: %allot-bignum ( #digits -- )
#! 1 cell header, 1 cell length, 1 cell sign, + digits
M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
M: immediate load-literal
- [ v>operand ] 2apply LOAD ;
+ [ v>operand ] bi@ LOAD ;
M: ppc-backend load-indirect ( obj reg -- )
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
>r v>operand r> loc>operand STW ;
M: ppc-backend %unbox-float ( dst src -- )
- [ v>operand ] 2apply float-offset LFD ;
+ [ v>operand ] bi@ float-offset LFD ;
M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
! Alien intrinsics
M: ppc-backend %unbox-byte-array ( dst src -- )
- [ v>operand ] 2apply byte-array-offset ADDI ;
+ [ v>operand ] bi@ byte-array-offset ADDI ;
M: ppc-backend %unbox-alien ( dst src -- )
- [ v>operand ] 2apply alien-offset LWZ ;
+ [ v>operand ] bi@ alien-offset LWZ ;
M: ppc-backend %unbox-f ( dst src -- )
drop 0 swap v>operand LI ;
] %allot
"end" get JMP
"f" resolve-label
- f [ v>operand ] 2apply MOV
+ f [ v>operand ] bi@ MOV
"end" resolve-label
] with-scope ;
0 cell, rc-absolute-cell rel-word ;
M: x86-backend %unbox-float ( dst src -- )
- [ v>operand ] 2apply float-offset [+] MOVSD ;
+ [ v>operand ] bi@ float-offset [+] MOVSD ;
-M: x86-backend %peek [ v>operand ] 2apply MOV ;
+M: x86-backend %peek [ v>operand ] bi@ MOV ;
M: x86-backend %replace swap %peek ;
! Alien intrinsics
M: x86-backend %unbox-byte-array ( dst src -- )
- [ v>operand ] 2apply byte-array-offset [+] LEA ;
+ [ v>operand ] bi@ byte-array-offset [+] LEA ;
M: x86-backend %unbox-alien ( dst src -- )
- [ v>operand ] 2apply alien-offset [+] MOV ;
+ [ v>operand ] bi@ alien-offset [+] MOV ;
M: x86-backend %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
: depth ( -- n ) datastack length ;
: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
- 2dup [ length ] 2apply min tuck tail >r tail r> ;
+ 2dup [ length ] bi@ min tuck tail >r tail r> ;
ERROR: relative-underflow stack ;
[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test
: assert-same-elements
- [ prune natural-sort ] 2apply assert= ;
+ [ prune natural-sort ] bi@ assert= ;
: dlist-push-all [ push-front ] curry each ;
{ [ dup not ] [ t ] }
{ [ over effect-terminated? ] [ t ] }
{ [ dup effect-terminated? ] [ f ] }
- { [ 2dup [ effect-in length ] 2apply > ] [ f ] }
- { [ 2dup [ effect-height ] 2apply = not ] [ f ] }
+ { [ 2dup [ effect-in length ] bi@ > ] [ f ] }
+ { [ 2dup [ effect-height ] bi@ = not ] [ f ] }
{ [ t ] [ t ] }
} cond 2nip ;
M: ds-loc operand-class* ds-loc-class ;
M: ds-loc set-operand-class set-ds-loc-class ;
M: ds-loc live-loc?
- over ds-loc? [ [ ds-loc-n ] 2apply = not ] [ 2drop t ] if ;
+ over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ;
! A retain stack location.
TUPLE: rs-loc n class ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
- over rs-loc? [ [ rs-loc-n ] 2apply = not ] [ 2drop t ] if ;
+ over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ;
UNION: loc ds-loc rs-loc ;
%move ;
: %move ( dst src -- )
- 2dup [ move-spec ] 2apply 2array {
+ 2dup [ move-spec ] bi@ 2array {
{ { f f } [ %move-bug ] }
{ { f unboxed-c-ptr } [ %move-bug ] }
{ { f unboxed-byte-array } [ %move-bug ] }
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
-: each-phantom ( quot -- ) phantoms rot 2apply ; inline
+: each-phantom ( quot -- ) phantoms rot bi@ ; inline
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
: fast-shuffle? ( live-locs -- ? )
#! Test if we have enough free registers to load all
#! shuffle inputs at once.
- T{ int-regs } free-vregs [ length ] 2apply <= ;
+ T{ int-regs } free-vregs [ length ] bi@ <= ;
: finalize-locs ( -- )
#! Perform any deferred stack shuffling.
: phantom&spec ( phantom spec -- phantom' spec' )
[ length f pad-left ] keep
- [ <reversed> ] 2apply ; inline
+ [ <reversed> ] bi@ ; inline
: phantom&spec-agree? ( phantom spec quot -- ? )
>r phantom&spec r> 2all? ; inline
swap lazy-load ;
: output-vregs ( -- seq seq )
- +output+ +clobber+ [ get [ get ] map ] 2apply ;
+ +output+ +clobber+ [ get [ get ] map ] bi@ ;
: clash? ( seq -- ? )
phantoms append [
M: hashtable equal?
over hashtable? [
- 2dup [ assoc-size ] 2apply number=
+ 2dup [ assoc-size ] bi@ number=
[ assoc= ] [ 2drop f ] if
] [ 2drop f ] if ;
dup heap-data clone swap
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
heap-data
- [ [ entry-key ] map ] 2apply
- [ natural-sort ] 2apply ;
+ [ [ entry-key ] map ] bi@
+ [ natural-sort ] bi@ ;
11 [
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test
M: literal-constraint equal?
over literal-constraint? [
2dup
- [ literal-constraint-literal ] 2apply eql? >r
- [ literal-constraint-value ] 2apply = r> and
+ [ literal-constraint-literal ] bi@ eql? >r
+ [ literal-constraint-value ] bi@ = r> and
] [
2drop f
] if ;
MATH: xyz
M: fixnum xyz 2array ;
M: float xyz
- [ 3 ] 2apply swapd >r 2array swap r> 2array swap ;
+ [ 3 ] bi@ swapd >r 2array swap r> 2array swap ;
[ [ xyz ] infer ] [ inference-error? ] must-fail-with
[ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
-[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] 2apply move-file ] unit-test
+[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] bi@ move-file ] unit-test
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
{ $subsection keep }
{ $subsection 2keep }
{ $subsection 3keep }
-{ $subsection 2apply }
-"A pair of utility words built from " { $link 2apply } ":"
+{ $subsection bi@ }
+"A pair of utility words built from " { $link bi@ } ":"
{ $subsection both? }
{ $subsection either? }
"A looping combinator:"
{ $values { "quot" "a quotation with stack effect " { $snippet "( x y z -- )" } } { "x" object } { "y" object } { "z" object } }
{ $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
-HELP: 2apply
+HELP: bi@
{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } { "x" object } { "y" object } }
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." } ;
: do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE>
-
-! Deprecated
-: 2apply bi@ ; inline
: random-interval ( -- interval )
1000 random dup 2 1000 random + +
- 1 random zero? [ [ neg ] 2apply swap ] when
+ 1 random zero? [ [ neg ] bi@ swap ] when
4 random {
{ 0 [ [a,b] ] }
{ 1 [ [a,b) ] }
0 pick interval-contains? over first { / /i } member? and [
3drop t
] [
- [ >r [ random-element ] 2apply ! 2dup . .
+ [ >r [ random-element ] bi@ ! 2dup . .
r> first execute ] 3keep
second execute interval-contains?
] if ;
: comparison-test
random-interval random-interval random-comparison
- [ >r [ random-element ] 2apply r> first execute ] 3keep
+ [ >r [ random-element ] bi@ r> first execute ] 3keep
second execute dup incomparable eq? [
2drop t
] [
: (interval-op) ( p1 p2 quot -- p3 )
2over >r >r
- >r [ first ] 2apply r> call
+ >r [ first ] bi@ r> call
r> r> [ second ] both? 2array ; inline
: interval-op ( i1 i2 quot -- i3 )
: interval-intersect ( i1 i2 -- i3 )
2dup and [
- [ interval>points ] 2apply swapd
+ [ interval>points ] bi@ swapd
[ swap endpoint> ] most
>r [ swap endpoint< ] most r>
make-interval
: interval-union ( i1 i2 -- i3 )
2dup and [
- [ interval>points 2array ] 2apply append points>interval
+ [ interval>points 2array ] bi@ append points>interval
] [
2drop f
] if ;
: interval-singleton? ( int -- ? )
interval>points
- 2dup [ second ] 2apply and
- [ [ first ] 2apply = ]
+ 2dup [ second ] bi@ and
+ [ [ first ] bi@ = ]
[ 2drop f ] if ;
: interval-length ( int -- n )
dup
- [ interval>points [ first ] 2apply swap - ]
+ [ interval>points [ first ] bi@ swap - ]
[ drop 0 ] if ;
: interval-closure ( i1 -- i2 )
- dup [ interval>points [ first ] 2apply [a,b] ] when ;
+ dup [ interval>points [ first ] bi@ [a,b] ] when ;
: interval-shift ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
[ min ] interval-op interval-closure ;
: interval-interior ( i1 -- i2 )
- interval>points [ first ] 2apply (a,b) ;
+ interval>points [ first ] bi@ (a,b) ;
: interval-division-op ( i1 i2 quot -- i3 )
>r 0 over interval-closure interval-contains?
: left-endpoint-< ( i1 i2 -- ? )
[ swap interval-subset? ] 2keep
[ nip interval-singleton? ] 2keep
- [ interval-from ] 2apply =
+ [ interval-from ] bi@ =
and and ;
: right-endpoint-< ( i1 i2 -- ? )
[ interval-subset? ] 2keep
[ drop interval-singleton? ] 2keep
- [ interval-to ] 2apply =
+ [ interval-to ] bi@ =
and and ;
: (interval<) over interval-from over interval-from endpoint< ;
] unit-test
: regression-2 ( x y -- x.y )
- [ p1 ] 2apply [
+ [ p1 ] bi@ [
[
rot
[ 2swap [ swapd * -rot p2 +@ ] 2keep ]
: post-process ( class interval node -- classes intervals )
dupd won't-overflow?
[ >r dup { f integer } member? [ drop fixnum ] when r> ] when
- [ dup [ 1array ] when ] 2apply ;
+ [ dup [ 1array ] when ] bi@ ;
: math-output-interval-1 ( node word -- interval )
dup [
] each
: intervals ( node -- i1 i2 )
- node-in-d first2 [ value-interval* ] 2apply ;
+ node-in-d first2 [ value-interval* ] bi@ ;
: math-output-interval-2 ( node word -- interval )
dup [
: removed-definitions ( -- definitions )
new-definitions old-definitions
- [ get first2 union ] 2apply diff ;
+ [ get first2 union ] bi@ diff ;
: smudged-usage ( -- usages referenced removed )
removed-definitions filter-moved keys [
: remove-breakpoints ( quot pos -- quot' )
over quotation? [
- 1+ cut [ (remove-breakpoints) ] 2apply
+ 1+ cut [ (remove-breakpoints) ] bi@
[ -> ] swap 3append
] [
drop
M: compose call dup 3 slot swap 4 slot slip call ;
M: wrapper equal?
- over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;
+ over wrapper? [ [ wrapped ] bi@ = ] [ 2drop f ] if ;
UNION: callable quotation curry compose ;
[ f ] [ { "a" "b" "c" } { "a" "b" "c" } mismatch ] unit-test
-[ V{ } V{ } ] [ { "a" "b" } { "a" "b" } drop-prefix [ >vector ] 2apply ] unit-test
+[ V{ } V{ } ] [ { "a" "b" } { "a" "b" } drop-prefix [ >vector ] bi@ ] unit-test
-[ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] 2apply ] unit-test
+[ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] bi@ ] unit-test
[ -1 1 "abc" <slice> ] must-fail
-[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test
+[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test
[ -1 ] [ "ab" "abc" <=> ] unit-test
[ 1 ] [ "abc" "ab" <=> ] unit-test
: change-nth ( i seq quot -- )
[ >r nth r> call ] 3keep drop set-nth ; inline
-: min-length ( seq1 seq2 -- n ) [ length ] 2apply min ; inline
+: min-length ( seq1 seq2 -- n ) [ length ] bi@ min ; inline
-: max-length ( seq1 seq2 -- n ) [ length ] 2apply max ; inline
+: max-length ( seq1 seq2 -- n ) [ length ] bi@ max ; inline
<PRIVATE
(2each) each-integer ; inline
: 2reverse-each ( seq1 seq2 quot -- )
- >r [ <reversed> ] 2apply r> 2each ; inline
+ >r [ <reversed> ] bi@ r> 2each ; inline
: 2reduce ( seq1 seq2 identity quot -- result )
>r -rot r> 2each ; inline
[ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
: sequence= ( seq1 seq2 -- ? )
- 2dup [ length ] 2apply number=
+ 2dup [ length ] bi@ number=
[ mismatch not ] [ 2drop f ] if ; inline
: move ( to from seq -- )
[ drop nip ]
[ 2drop first ]
[ >r drop first2 r> call ]
- [ >r drop first3 r> 2apply ]
+ [ >r drop first3 r> bi@ ]
} dispatch
] [
drop
>r >r halves r> r>
- [ [ binary-reduce ] 2curry 2apply ] keep
+ [ [ binary-reduce ] 2curry bi@ ] keep
call
] if ; inline
] if ; inline
: merge ( sorted1 sorted2 quot -- result )
- >r [ [ <iterator> ] 2apply ] 2keep r>
+ >r [ [ <iterator> ] bi@ ] 2keep r>
rot length rot length + <vector>
[ (merge) ] keep underlying ; inline
] if ;
: last-split1 ( seq subseq -- before after )
- [ <reversed> ] 2apply split1 [ reverse ] 2apply
+ [ <reversed> ] bi@ split1 [ reverse ] bi@
dup [ swap ] when ;
: (split) ( separators n seq -- )
[ f ] [
V{ 1 2 3 4 } dup clone
- [ underlying ] 2apply eq?
+ [ underlying ] bi@ eq?
] unit-test
[ 0 ] [
M: vocab-link equal?
over vocab-link?
- [ [ vocab-link-name ] 2apply = ] [ 2drop f ] if ;
+ [ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ;
M: vocab-link hashcode*
vocab-link-name hashcode* ;
pick 1 = [ <sphere> nip ] [ create-group ] if ;
: ss-point ( dx dy -- point )
- [ oversampling /f ] 2apply 0.0 3float-array ;
+ [ oversampling /f ] bi@ 0.0 3float-array ;
: ss-grid ( -- ss-grid )
oversampling [ oversampling [ ss-point ] with map ] map ;
: pixel-grid ( -- grid )
size reverse [
size [
- [ size 0.5 * - ] 2apply swap size
+ [ size 0.5 * - ] bi@ swap size
3float-array
] with map
] map ;
[ "c071aa7e007a9770b2fb4304f55a17e5" ] [\r
"extra/benchmark/reverse-complement/reverse-complement-test-in.txt"\r
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"\r
- [ resource-path ] 2apply\r
+ [ resource-path ] bi@\r
reverse-complement\r
\r
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"\r
: fast-truncate >fixnum >float ; inline
: eval-A ( i j -- n )
- [ >float ] 2apply
+ [ >float ] bi@
dupd + dup 1+ * 2 /f fast-truncate + 1+
recip ; inline
[ range>accessor ] map ;
: clear-range ( range -- num )
- first2 dupd + [ 2^ 1- ] 2apply bitnot bitor ;
+ first2 dupd + [ 2^ 1- ] bi@ bitnot bitor ;
: range>setter ( range -- quot )
[
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: relative-position ( self other -- v ) swap [ boid-pos ] 2apply v- ;
+: relative-position ( self other -- v ) swap [ boid-pos ] bi@ v- ;
: relative-angle ( self other -- angle )
over boid-vel -rot relative-position angle-between ;
2array ;
: compare-tables ( old new -- table )
- [ passing-benchmarks ] 2apply
+ [ passing-benchmarks ] bi@
[ benchmark-difference ] with map ;
: benchmark-deltas ( -- table )
- "../benchmarks" "benchmarks" [ eval-file ] 2apply
+ "../benchmarks" "benchmarks" [ eval-file ] bi@
compare-tables
sort-values ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: longer? ( seq seq -- ? ) [ length ] 2apply > ;
+: longer? ( seq seq -- ? ) [ length ] bi@ > ;
: maybe-tail* ( seq n -- seq )
2dup longer?
[ month>> +month ] keep
[ year>> +year ] keep ; inline
-: +slots [ 2apply + ] curry 2keep ; inline
+: +slots [ bi@ + ] curry 2keep ; inline
PRIVATE>
[ >gmt tuple-slots ] compare ;
: (time-) ( timestamp timestamp -- n )
- [ >gmt ] 2apply
- [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
- [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
+ [ >gmt ] bi@
+ [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
+ [ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ;
M: timestamp time-
#! Exact calendar-time difference
[\r
[ month>> month-abbreviations nth write ] keep bl\r
[ day>> number>string 2 32 pad-left write ] keep bl\r
- dup now [ year>> ] 2apply = [\r
+ dup now [ year>> ] bi@ = [\r
[ hour>> write-00 ] keep ":" write\r
minute>> write-00\r
] [\r
[ -> filenames CF>string-array ] [ drop f ] if ;
: split-path ( path -- dir file )
- "/" last-split1 [ <NSString> ] 2apply ;
+ "/" last-split1 [ <NSString> ] bi@ ;
: save-panel ( path -- paths )
<NSSavePanel> dup
: modulus-phi ( numbits -- n phi )
#! Loop until phi is not divisible by the public key.
dup rsa-primes [ * ] 2keep
- [ 1- ] 2apply *
+ [ 1- ] bi@ *
dup public-key gcd nip 1 = [
rot drop
] [
: byte-array>sha1-interleave ( string -- seq )
[ zero? ] left-trim
dup length odd? [ 1 tail ] when
- seq>2seq [ byte-array>sha1 ] 2apply
+ seq>2seq [ byte-array>sha1 ] bi@
swap 2seq>seq ;
: =line ( n loc -- newloc ) second 2array ;
-: lines-equal? ( loc1 loc2 -- ? ) [ first ] 2apply number= ;
+: lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ;
TUPLE: document locs ;
2over = [
3drop
] [
- >r [ first ] 2apply 1+ dup <slice> r> each
+ >r [ first ] bi@ 1+ dup <slice> r> each
] if ; inline
: start/end-on-line ( from to line# -- n1 n2 )
: (set-doc-range) ( newlines from to lines -- )
[ prepare-insert ] 3keep
- >r [ first ] 2apply 1+ r>
+ >r [ first ] bi@ 1+ r>
replace-slice ;
: set-doc-range ( string from to document -- )
: faq-sections, ( question-lists -- )
unclip question-list-seq length 1+ dupd
[ question-list-seq length + ] accumulate nip
- 0 -rot [ pick question-list>html [ , nl, ] 2apply 1+ ] 2each drop ;
+ 0 -rot [ pick question-list>html [ , nl, ] bi@ 1+ ] 2each drop ;
: faq>html ( faq -- div )
"div" [
{ { $link curry } { $snippet ": curry '[ , @ ] ;" } }\r
{ { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } }\r
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }\r
- { { $link 2apply } { $snippet ": 2apply tuck '[ , @ , @ ] call ;" } }\r
+ { { $link bi@ } { $snippet ": bi@ tuck '[ , @ , @ ] call ;" } }\r
} ;\r
\r
ARTICLE: "fry.philosophy" "Fried quotation philosophy"\r
: check-see-also ( word element -- )
nip \ $see-also swap elements [
- 1 tail dup prune [ length ] 2apply assert=
+ 1 tail dup prune [ length ] bi@ assert=
] each ;
: vocab-exists? ( name -- ? )
: query>assoc ( query -- assoc )
dup [
"&" split [
- "=" split1 [ dup [ url-decode ] when ] 2apply
+ "=" split1 [ dup [ url-decode ] when ] bi@
] H{ } map>assoc
] when ;
: binary-op ( quot -- ? )
>r get-cba r>
- swap >r >r [ reg-val ] 2apply swap r> call r>
+ swap >r >r [ reg-val ] bi@ swap r> call r>
set-reg f ; inline
: op1 ( opcode -- ? )
[ swap arr-val ] binary-op ;
: op2 ( opcode -- ? )
- get-cba >r [ reg-val ] 2apply r> reg-val set-arr f ;
+ get-cba >r [ reg-val ] bi@ r> reg-val set-arr f ;
: op3 ( opcode -- ? )
[ + >32bit ] binary-op ;
\ - [ + ] [ - ] define-math-inverse
\ * [ / ] [ / ] define-math-inverse
\ / [ * ] [ / ] define-math-inverse
-\ ^ [ recip ^ ] [ [ log ] 2apply / ] define-math-inverse
+\ ^ [ recip ^ ] [ [ log ] bi@ / ] define-math-inverse
\ ? 2 [
- [ assert-literal ] 2apply
+ [ assert-literal ] bi@
[ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
2curry
] define-pop-inverse
swap BIN: 11111111 bitand ;
: stream-write2 ( stream char1 char2 -- )
- rot [ stream-write1 ] curry 2apply ;
+ rot [ stream-write1 ] curry bi@ ;
: char>utf16be ( stream char -- )
dup HEX: FFFF > [
: check-datagram-send ( packet addrspec port -- )
dup check-datagram-port
- datagram-port-addr [ class ] 2apply assert=
+ datagram-port-addr [ class ] bi@ assert=
class byte-array assert= ;
M: inet6 inet-pton ( str addrspec -- data )
drop "::" split1
- [ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] 2apply
- 2dup [ length ]
2apply + 8 swap - 0 <array> swap 3append
+ [ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] bi@
+ 2dup [ length ]
bi@ + 8 swap - 0 <array> swap 3append
[ 2 >be ] map concat >byte-array ;
M: inet6 address-size drop 16 ;
close ;
M: unix-io move-file ( from to -- )
- [ normalize-pathname ] 2apply rename io-error ;
+ [ normalize-pathname ] bi@ rename io-error ;
M: unix-io delete-file ( path -- )
normalize-pathname unlink io-error ;
] with-disposal ;
M: unix-io copy-file ( from to -- )
- [ normalize-pathname ] 2apply
+ [ normalize-pathname ] bi@
[ (copy-file) ]
[ swap file-info file-info-permissions chmod io-error ]
2bi ;
1 _getstdfilex _fileno
2 _getstdfilex _fileno
] if [ f <win32-file> ] 3apply
- rot <reader> -rot [ <writer> ] 2apply
+ rot <reader> -rot [ <writer> ] bi@
] with-variable ;
open-append <win32-file> <writer> ;
M: windows-io move-file ( from to -- )
- [ normalize-pathname ] 2apply MoveFile win32-error=0/f ;
+ [ normalize-pathname ] bi@ MoveFile win32-error=0/f ;
M: windows-io delete-file ( path -- )
normalize-pathname DeleteFile win32-error=0/f ;
M: windows-io copy-file ( from to -- )
dup parent-directory make-directories
- [ normalize-pathname ] 2apply 0 CopyFile win32-error=0/f ;
+ [ normalize-pathname ] bi@ 0 CopyFile win32-error=0/f ;
M: windows-io make-directory ( path -- )
normalize-pathname
: sub-tunnel ( from to sements -- segments )
#! return segments between from and to, after clamping from and to to
#! valid values
- [ sequence-index-range [ clamp-to-range ] curry 2apply ] keep <slice> ;
+ [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
: nearer-segment ( segment segment oint -- segment )
#! return whichever of the two segments is nearer to the oint
terms get [ [ swap +@ ] assoc-each ] bind ;
: alt+ ( x y -- x+y )
- [ >alt ] 2apply [ (alt+) (alt+) ] with-terms ;
+ [ >alt ] bi@ [ (alt+) (alt+) ] with-terms ;
! Multiplication
: alt*n ( vec n -- vec )
] curry each ;
: duplicates? ( seq -- ? )
- dup prune [ length ] 2apply > ;
+ dup prune [ length ] bi@ > ;
: (wedge) ( n basis1 basis2 -- n basis )
append dup duplicates? [
] if ;
: wedge ( x y -- x.y )
- [ >alt ] 2apply [
+ [ >alt ] bi@ [
swap [
[
2swap [
] with map ;
: bigraded-betti ( u-generators z-generators -- seq )
- [ basis graded ] 2apply tensor bigraded-ker/im-d
+ [ basis graded ] bi@ tensor bigraded-ker/im-d
[ [ [ first ] map ] map ] keep
[ [ second ] map 2 head* { 0 0 } prepend ] map
1 tail dup first length 0 <array> add
] with map ;
: bigraded-laplacian ( u-generators z-generators quot -- seq )
- >r [ basis graded ] 2apply tensor bigraded-triples r>
+ >r [ basis graded ] bi@ tensor bigraded-triples r>
[ [ first3 ] swap compose map ] curry map ; inline
: bigraded-laplacian-betti ( u-generators z-generators -- seq )
TUPLE: lazy-cons car cdr ;
: lazy-cons ( car cdr -- promise )
- [ promise ] 2apply \ lazy-cons construct-boa
+ [ promise ] bi@ \ lazy-cons construct-boa
T{ promise f f t f } clone
[ set-promise-value ] keep ;
SYMBOL: costs
: init-d ( str1 str2 -- )
- [ length 1+ ] 2apply 2dup <matrix> d set
+ [ length 1+ ] bi@ 2dup <matrix> d set
[ 0 over ->d ] each
[ dup 0 ->d ] each ; inline
[
2dup init-d
2dup compute-costs
- [ length ] 2apply [
+ [ length ] bi@ [
[ levenshtein-step ] curry each
] with each
levenshtein-result
! Remove set-alien-cell, etc.
[
- drop [ accessor-words swap seq-diff ] keep [ length ] 2apply =
+ drop [ accessor-words swap seq-diff ] keep [ length ] bi@ =
] assoc-subset
! Remove trivial defs
: filter-symbols ( alist -- alist )
[
nip first dup def-hash get at
- [ first ] 2apply literalize = not
+ [ first ] bi@ literalize = not
] assoc-subset ;
M: sequence run-lint ( seq -- seq )
{ [ 2dup = ] [ 2drop t ] }
{ [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
{ [ 2dup [ sequence? ] both? ] [
- 2dup [ length ] 2apply =
+ 2dup [ length ] bi@ =
[ [ (match) ] 2all? ] [ 2drop f ] if ] }
{ [ 2dup [ tuple? ] both? ]
- [ [ tuple>array ] 2apply [ (match) ] 2all? ] }
+ [ [ tuple>array ] bi@ [ (match) ] 2all? ] }
{ [ t ] [ 2drop f ] }
} cond ;
M: real real-part ;
M: real imaginary-part drop 0 ;
-M: complex absq >rect [ sq ] 2apply + ;
+M: complex absq >rect [ sq ] bi@ + ;
: 2>rect ( x y -- xr yr xi yi )
- [ [ real-part ] 2apply ] 2keep
- [ imaginary-part ] 2apply ; inline
+ [ [ real-part ] bi@ ] 2keep
+ [ imaginary-part ] bi@ ; inline
M: complex number=
2>rect number= [ number= ] [ 2drop f ] if ;
>r - abs r> < ;
: ~rel ( x y epsilon -- ? )
- >r [ - abs ] 2keep [ abs ] 2apply + r> * < ;
+ >r [ - abs ] 2keep [ abs ] bi@ + r> * < ;
: ~ ( x y epsilon -- ? )
{
: arg ( z -- arg ) >float-rect swap fatan2 ; inline
: >polar ( z -- abs arg )
- >float-rect [ [ sq ] 2apply + fsqrt ] 2keep swap fatan2 ;
+ >float-rect [ [ sq ] bi@ + fsqrt ] 2keep swap fatan2 ;
inline
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
<PRIVATE
: 2pad-left ( p p n -- p p ) 0 [ pad-left swap ] 2keep pad-left swap ;
: 2pad-right ( p p n -- p p ) 0 [ pad-right swap ] 2keep pad-right swap ;
-: pextend ( p p -- p p ) 2dup [ length ] 2apply max 2pad-right ;
-: pextend-left ( p p -- p p ) 2dup [ length ] 2apply max 2pad-left ;
+: pextend ( p p -- p p ) 2dup [ length ] bi@ max 2pad-right ;
+: pextend-left ( p p -- p p ) 2dup [ length ] bi@ max 2pad-left ;
: unempty ( seq -- seq ) dup empty? [ drop { 0 } ] when ;
-: 2unempty ( seq seq -- seq seq ) [ unempty ] 2apply ;
+: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
PRIVATE>
: p= ( p p -- ? ) pextend = ;
: ptrim ( p -- p )
dup singleton? [ [ zero? ] right-trim ] unless ;
-: 2ptrim ( p p -- p p ) [ ptrim ] 2apply ;
+: 2ptrim ( p p -- p p ) [ ptrim ] bi@ ;
: p+ ( p p -- p ) pextend v+ ;
: p- ( p p -- p ) pextend v- ;
: n*p ( n p -- n*p ) n*v ;
! convolution
: pextend-conv ( p p -- p p )
#! extend to: p_m + p_n - 1
- 2dup [ length ] 2apply + 1- 2pad-right [ >vector ] 2apply ;
+ 2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ;
: p* ( p p -- p )
#! Multiply two polynomials.
: p/mod-setup ( p p -- p p n )
2ptrim
- 2dup [ length ] 2apply -
+ 2dup [ length ] bi@ -
dup 1 < [ drop 1 ] when
[ over length + 0 pad-left pextend ] keep 1+ ;
: /-last ( seq seq -- a )
#! divide the last two numbers in the sequences
- [ peek ] 2apply / ;
+ [ peek ] bi@ / ;
: (p/mod)
2dup /-last
] if ;
: pgcd ( p p -- p q )
- swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] 2apply ;
+ swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] bi@ ;
: pdiff ( p -- p' )
#! Polynomial derivative.
: ** conjugate * ; inline
-: 2q ( u v -- u' u'' v' v'' ) [ first2 ] 2apply ; inline
+: 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline
: q*a ( u v -- a ) 2q swapd ** >r * r> - ; inline
dup numerator swap denominator ; inline
: 2>fraction ( a/b c/d -- a c b d )
- [ >fraction ] 2apply swapd ; inline
+ [ >fraction ] bi@ swapd ; inline
<PRIVATE
dup zero? [
"Division by zero" throw
] [
- dup 0 < [ [ neg ] 2apply ] when
+ dup 0 < [ [ neg ] bi@ ] when
2dup gcd nip tuck /i >r /i r> fraction>
] if ;
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
! finds sigma((xi-mean(x))(yi-mean(y))
- 0 [ [ >r pick r> swap - ] 2apply * + ] 2reduce 2nip ;
+ 0 [ [ >r pick r> swap - ] bi@ * + ] 2reduce 2nip ;
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
* recip >r [ ((r)) ] keep length 1- / r> * ;
: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
- first2 [ [ [ mean ] 2apply ] 2keep ] 2keep [ std ] 2apply ;
+ first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;
: r ( {{x,y}...} -- r )
[r] (r) ;
: random-neighbour ( cell -- newcell ) choices random ;
: vertex ( pair -- )
- first2 [ 0.5 + line-width * ] 2apply glVertex2d ;
+ first2 [ 0.5 + line-width * ] bi@ glVertex2d ;
: (draw-maze) ( cell -- )
dup vertex
: parse-decimal ( str -- ratio )
"." split1
>r dup "-" head? [ drop t "0" ] [ f swap ] if r>
- [ dup empty? [ drop "0" ] when ] 2apply
+ [ dup empty? [ drop "0" ] when ] bi@
dup length
- >r [ string>number dup [ not-a-decimal ] unless ] 2apply r>
+ >r [ string>number dup [ not-a-decimal ] unless ] bi@ r>
10 swap ^ / + swap [ neg ] when ;
: DECIMAL:
] curry assoc-map ;
: sorted-methods ( alist -- alist' )
- [ [ first ] 2apply classes< ] topological-sort ;
+ [ [ first ] bi@ classes< ] topological-sort ;
: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
: demo-gadget-frustum ( -- -x x -y y near far )
FOV-RATIO NEAR-PLANE FOV / v*n
- first2 [ -+ ] 2apply NEAR-PLANE FAR-PLANE ;
+ first2 [ -+ ] bi@ NEAR-PLANE FAR-PLANE ;
: demo-gadget-set-matrices ( gadget -- )
GL_PROJECTION glMatrixMode
splitting words byte-arrays assocs combinators.lib ;
IN: opengl
-: coordinates [ first2 ] 2apply ;
+: coordinates [ first2 ] bi@ ;
-: fix-coordinates [ first2 [ >fixnum ] 2apply ] 2apply ;
+: fix-coordinates [ first2 [ >fixnum ] bi@ ] bi@ ;
: gl-color ( color -- ) first4 glColor4d ; inline
: unit-circle dup [ sin ] map swap [ cos ] map ;
-: adjust-points [ [ 1 + 0.5 * ] map ] 2apply ;
+: adjust-points [ [ 1 + 0.5 * ] map ] bi@ ;
: scale-points 2array flip [ v* ] with map [ v+ ] with map ;
] if ;
: string= ( str1 str2 ignore-case -- ? )
- [ [ >upper ] 2apply ] when sequence= ;
+ [ [ >upper ] bi@ ] when sequence= ;
: string-head? ( str head ignore-case -- ? )
2over shorter? [
nonempty-list-of { } succeed <|> ;
LAZY: surrounded-by ( parser start end -- parser' )
- [ token ] 2apply swapd pack ;
+ [ token ] bi@ swapd pack ;
: exactly-n ( parser n -- parser' )
swap <repetition> <and-parser> [ flatten ] <@ ;
>r >r hide r> r> hide 3seq [ first ] action ;
: surrounded-by ( parser begin end -- parser' )
- [ token ] 2apply swapd pack ;
+ [ token ] bi@ swapd pack ;
: 'digit' ( -- parser )
[ digit? ] satisfy [ digit> ] action ;
TUPLE: parse-result remaining ast ;
TUPLE: parser id compiled ;
-M: parser equal? [ id>> ] 2apply = ;
+M: parser equal? [ id>> ] bi@ = ;
C: <parser> parser
SYMBOL: ignore
: abc ( p q -- triplet )
[
2dup * , ! a = p * q
- [ sq ] 2apply 2dup - 2 / , ! b = (p² - q²) / 2
+ [ sq ] bi@ 2dup - 2 / , ! b = (p² - q²) / 2
+ 2 / , ! c = (p² + q²) / 2
] { } make natural-sort ;
dup even? [ 2 / ] [ 3 * 1+ ] if ;
: longest ( seq seq -- seq )
- 2dup [ length ] 2apply > [ drop ] [ nip ] if ;
+ 2dup [ length ] bi@ > [ drop ] [ nip ] if ;
PRIVATE>
: max-period ( seq -- elt n )
dup [ period-length ] map dup supremum
- over index [ swap nth ] curry 2apply ;
+ over index [ swap nth ] curry bi@ ;
PRIVATE>
: max-consecutive ( seq -- elt n )
dup [ first2 consecutive-primes ] map dup supremum
- over index [ swap nth ] curry 2apply ;
+ over index [ swap nth ] curry bi@ ;
PRIVATE>
10 99 [a,b] dup cartesian-product [ first2 < ] subset ;
: safe? ( ax xb -- ? )
- [ 10 /mod ] 2apply -roll = rot zero? not and nip ;
+ [ 10 /mod ] bi@ -roll = rot zero? not and nip ;
: ax/xb ( ax xb -- z/f )
- 2dup safe? [ [ 10 /mod ] 2apply 2nip / ] [ 2drop f ] if ;
+ 2dup safe? [ [ 10 /mod ] bi@ 2nip / ] [ 2drop f ] if ;
: curious? ( m n -- ? )
2dup / [ ax/xb ] dip = ;
dup 3 * 1- * 2 / ;
: sum-and-diff? ( m n -- ? )
- 2dup + -rot - [ pentagonal? ] 2apply and ;
+ 2dup + -rot - [ pentagonal? ] bi@ and ;
PRIVATE>
] { } make ;
: find-source ( seq -- elt )
- dup values swap keys [ prune ] 2apply seq-diff
+ dup values swap keys [ prune ] bi@ seq-diff
dup empty? [ "Topological sort failed" throw ] [ first ] if ;
: remove-source ( seq elt -- seq )
] if ;
: random-ratio ( -- ratio )
- 1000000000 dup [ random ] 2apply 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
+ 1000000000 dup [ random ] bi@ 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
: random-float ( -- float )
50% [ random-ratio ] [ special-floats get random ] if
: char-between?-quot ( ch1 ch2 -- quot )
ignore-case? get
- [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ]
+ [ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ]
[ [ between? ] ]
if 2curry ;
: char-between?-quot ( ch1 ch2 -- quot )
ignore-case? get
- [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ]
+ [ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ]
[ [ between? ] ]
if 2curry ;
{ -nrot 5 }\r
{ -roll 4 }\r
{ -rot 3 }\r
- { 2apply 1 }\r
+ { bi@ 1 }\r
{ 2curry 1 }\r
{ 2drop 1 }\r
{ 2dup 1 }\r
] if ;
: roman<= ( ch1 ch2 -- ? )
- [ 1string roman-digits index ] 2apply >= ;
+ [ 1string roman-digits index ] bi@ >= ;
: roman>n ( ch -- n )
1string roman-digits index roman-values nth ;
<PRIVATE
: 2roman> ( str1 str2 -- m n )
- [ roman> ] 2apply ;
+ [ roman> ] bi@ ;
: binary-roman-op ( str1 str2 quot -- str3 )
>r 2roman> r> call >roman ; inline
"charlie" create-node* "charlie" set
"gertrude" create-node* "gertrude" set
[ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test
- { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each
+ { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] bi@ parent-child ] each
[ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test
[ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test
[ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test
M: id hashcode* obj>> hashcode* ;
-M: id equal? over id? [ [ obj>> ] 2apply eq? ] [ 2drop f ] if ;
+M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
: add-object ( obj -- )
#! Add an object to the sequence of already serialized
: put-effect ( word -- )
dup word-name "-" split1
- [ >array [ 1string ] map ] 2apply
+ [ >array [ 1string ] map ] bi@
<effect> "declared-effect" set-word-prop ;
: in-shuffle ( -- ) in get ".shuffle" append set-in ;
: cell-contains? ( n x y i -- ? ) 3 /mod pair+ board> = ;
: box-contains? ( n x y -- ? )
- [ 3 /i 3 * ] 2apply
+ [ 3 /i 3 * ] bi@
9 [ >r 3dup r> cell-contains? ] contains?
>r 3drop r> ;
: header-checksum ( seq -- x )
148 cut-slice 8 tail-slice
- [ sum ] 2apply + 256 + ;
+ [ sum ] bi@ + 256 + ;
TUPLE: checksum-error ;
TUPLE: malformed-block-error ;
: score ( full fuzzy -- n )
dup [
- [ [ length ] 2apply - 15 swap [-] 3 /f ] 2keep
+ [ [ length ] bi@ - 15 swap [-] 3 /f ] 2keep
runs [
[ 0 [ pick score-1 max ] reduce nip ] keep
length * +
: complete ( full short -- score )
[ dupd fuzzy score ] 2keep
- [ <reversed> ] 2apply
+ [ <reversed> ] bi@
dupd fuzzy score max ;
: completion ( short candidate -- result )
sent-messages get
super-sent-messages get
- [ keys [ objc-methods get at dup ] H{ } map>assoc ] 2apply
+ [ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@
super-message-senders [ intersect ] change
message-senders [ intersect ] change
<rect> ;
: scale-rect ( rect vec -- loc dim )
- [ v* ] curry >r rect-bounds r> 2apply ;
+ [ v* ] curry >r rect-bounds r> bi@ ;
: average-rects ( rect1 rect2 weight -- rect )
tuck >r >r scale-rect r> r> { 1 1 } swap v- scale-rect
dup editor-caret-color gl-color
dup caret-loc origin get v+
swap caret-dim over v+
- [ { 0.5 -0.5 } v+ ] 2apply gl-line
+ [ { 0.5 -0.5 } v+ ] bi@ gl-line
] when ;
: line-translation ( n -- loc )
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 )
- [ rect-extent ] 2apply swapd ;
+ [ rect-extent ] bi@ swapd ;
: <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
[ { 100 200 } ] [
100x100
100x100
- [ 1array ] 2apply 2array <grid> pref-dim
+ [ 1array ] bi@ 2array <grid> pref-dim
] unit-test
[ ] [
100x100
100x100
- [ 1array ] 2apply 2array <grid> layout
+ [ 1array ] bi@ 2array <grid> layout
] unit-test
[ { 230 120 } { 100 100 } { 100 100 } ] [
2dup control-value = [ 2drop ] [ set-control-value ] if ;
: rect-min ( rect1 rect2 -- rect )
- >r [ rect-loc ] keep r> [ rect-dim ] 2apply vmin <rect> ;
+ >r [ rect-loc ] keep r> [ rect-dim ] bi@ vmin <rect> ;
: (scroll>rect) ( rect scroller -- )
[
: process-other-extend ( lines -- set )
[ "#" split1 drop ";" split1 drop trim-blank ] map
[ empty? not ] subset
- [ ".." split1 [ dup ] unless* [ hex> ] 2apply [a,b] ] map
+ [ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map
concat >set ;
: other-extend-lines ( -- lines )
grapheme-table nth nth not ;
: chars ( i str n -- str[i] str[i+n] )
- swap >r dupd + r> [ ?nth ] curry 2apply ;
+ swap >r dupd + r> [ ?nth ] curry bi@ ;
: find-index ( seq quot -- i ) find drop ; inline
: find-last-index ( seq quot -- i ) find-last drop ; inline
>upper >lower ;
: insensitive= ( str1 str2 -- ? )
- [ >case-fold ] 2apply = ;
+ [ >case-fold ] bi@ = ;
: lower? ( string -- ? )
dup >lower = ;
: (insert) ( seq n quot -- )
over 0 = [ 3drop ] [
- [ >r dup 1- rot [ nth ] curry 2apply r> 2apply > ] 3keep
+ [ >r dup 1- rot [ nth ] curry bi@ r> bi@ > ] 3keep
roll [ 3drop ]
[ >r [ dup 1- rot exchange ] 2keep 1- r> (insert) ] if
] if ; inline
1array split1 append ;
: 2remove-one ( seq seq obj -- seq seq )
- [ remove-one ] curry 2apply ;
+ [ remove-one ] curry bi@ ;
: symbolic-reduce ( seq seq -- seq seq )
2dup seq-intersect dup empty?
: <dimensioned> ( n top bot -- obj )
symbolic-reduce
- [ natural-sort ] 2apply
+ [ natural-sort ] bi@
dimensioned construct-boa ;
: >dimensioned< ( d -- n top bot )
{ dimensioned-top dimensioned-bot } get-slots ;
: check-dimensions ( d d -- )
- [ dimensions 2array ] 2apply =
+ [ dimensions 2array ] bi@ =
[ dimensions-not-equal ] unless ;
-: 2values [ dimensioned-value ] 2apply ;
+: 2values [ dimensioned-value ] bi@ ;
: <dimension-op
2dup check-dimensions dup dimensions 2swap 2values ;
{ } { } <dimensioned> ;
: d* ( d d -- d )
- [ dup number? [ scalar ] when ] 2apply
- [ [ dimensioned-top ] 2apply append ] 2keep
- [ [ dimensioned-bot ] 2apply append ] 2keep
+ [ dup number? [ scalar ] when ] bi@
+ [ [ dimensioned-top ] bi@ append ] 2keep
+ [ [ dimensioned-bot ] bi@ append ] 2keep
2values * dimension-op> ;
: d-neg ( d -- d ) -1 d* ;
over [ dupd update ] [ nip clone ] if ;
: import-keywords ( parent child -- )
- over >r [ rule-set-keywords ] 2apply ?update
+ over >r [ rule-set-keywords ] bi@ ?update
r> set-rule-set-keywords ;
: import-rules ( parent child -- )
projects / factor.git / commitdiff