Rename 2apply to bi@
parent
db7939d68c
commit
c22af5c7a6
|
@ -39,7 +39,7 @@ M: alien equal?
|
||||||
2dup [ expired? ] either? [
|
2dup [ expired? ] either? [
|
||||||
[ expired? ] both?
|
[ expired? ] both?
|
||||||
] [
|
] [
|
||||||
[ alien-address ] 2apply =
|
[ alien-address ] bi@ =
|
||||||
] if
|
] if
|
||||||
] [
|
] [
|
||||||
2drop f
|
2drop f
|
||||||
|
|
|
@ -115,7 +115,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
||||||
swap [ swapd set-at ] curry assoc-each ;
|
swap [ swapd set-at ] curry assoc-each ;
|
||||||
|
|
||||||
: union ( assoc1 assoc2 -- union )
|
: union ( assoc1 assoc2 -- union )
|
||||||
2dup [ assoc-size ] 2apply + pick new-assoc
|
2dup [ assoc-size ] bi@ + pick new-assoc
|
||||||
[ rot update ] keep [ swap update ] keep ;
|
[ rot update ] keep [ swap update ] keep ;
|
||||||
|
|
||||||
: diff ( assoc1 assoc2 -- diff )
|
: diff ( assoc1 assoc2 -- diff )
|
||||||
|
|
|
@ -21,7 +21,7 @@ IN: bit-arrays.tests
|
||||||
{ t f t } { f t f }
|
{ t f t } { f t f }
|
||||||
] [
|
] [
|
||||||
{ t f t } >bit-array dup clone dup [ not ] change-each
|
{ t f t } >bit-array dup clone dup [ not ] change-each
|
||||||
[ >array ] 2apply
|
[ >array ] bi@
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
|
|
|
@ -23,7 +23,7 @@ SYMBOL: bootstrap-time
|
||||||
|
|
||||||
: load-components ( -- )
|
: load-components ( -- )
|
||||||
"exclude" "include"
|
"exclude" "include"
|
||||||
[ get-global " " split [ empty? not ] subset ] 2apply
|
[ get-global " " split [ empty? not ] subset ] bi@
|
||||||
seq-diff
|
seq-diff
|
||||||
[ "bootstrap." prepend require ] each ;
|
[ "bootstrap." prepend require ] each ;
|
||||||
|
|
||||||
|
|
|
@ -67,7 +67,7 @@ C: <anonymous-complement> anonymous-complement
|
||||||
members>> [ class< ] with all? ;
|
members>> [ class< ] with all? ;
|
||||||
|
|
||||||
: anonymous-complement< ( first second -- ? )
|
: anonymous-complement< ( first second -- ? )
|
||||||
[ class>> ] 2apply swap class< ;
|
[ class>> ] bi@ swap class< ;
|
||||||
|
|
||||||
: (class<) ( first second -- -1/0/1 )
|
: (class<) ( first second -- -1/0/1 )
|
||||||
{
|
{
|
||||||
|
|
|
@ -47,8 +47,8 @@ TUPLE: mixin-instance loc class mixin ;
|
||||||
M: mixin-instance equal?
|
M: mixin-instance equal?
|
||||||
{
|
{
|
||||||
{ [ over mixin-instance? not ] [ f ] }
|
{ [ over mixin-instance? not ] [ f ] }
|
||||||
{ [ 2dup [ mixin-instance-class ] 2apply = not ] [ f ] }
|
{ [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
|
||||||
{ [ 2dup [ mixin-instance-mixin ] 2apply = not ] [ f ] }
|
{ [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
|
||||||
{ [ t ] [ t ] }
|
{ [ t ] [ t ] }
|
||||||
} cond 2nip ;
|
} cond 2nip ;
|
||||||
|
|
||||||
|
|
|
@ -10,7 +10,7 @@ IN: compiler.tests
|
||||||
[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test
|
[ 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
|
[ 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
|
||||||
[ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-call >quotation ] unit-test
|
[ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-call >quotation ] unit-test
|
||||||
|
|
|
@ -72,13 +72,13 @@ unit-test
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 12 13 ] [
|
[ 12 13 ] [
|
||||||
-12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-call
|
-12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
|
[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
|
||||||
|
|
||||||
[ 12 13 ] [
|
[ 12 13 ] [
|
||||||
-12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call
|
-12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 1 ] [
|
[ 1 ] [
|
||||||
|
|
|
@ -63,7 +63,7 @@ M: arm-backend load-indirect ( obj reg -- )
|
||||||
|
|
||||||
M: immediate load-literal
|
M: immediate load-literal
|
||||||
over v>operand small-enough? [
|
over v>operand small-enough? [
|
||||||
[ v>operand ] 2apply swap MOV
|
[ v>operand ] bi@ swap MOV
|
||||||
] [
|
] [
|
||||||
v>operand load-indirect
|
v>operand load-indirect
|
||||||
] if ;
|
] if ;
|
||||||
|
@ -322,10 +322,10 @@ M: arm-backend fp-shadows-int? ( -- ? ) f ;
|
||||||
|
|
||||||
! Alien intrinsics
|
! Alien intrinsics
|
||||||
M: arm-backend %unbox-byte-array ( dst src -- )
|
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 -- )
|
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 -- )
|
M: arm-backend %unbox-f ( dst src -- )
|
||||||
drop v>operand 0 MOV ;
|
drop v>operand 0 MOV ;
|
||||||
|
|
|
@ -33,7 +33,7 @@ IN: cpu.ppc.allot
|
||||||
f fresh-object ;
|
f fresh-object ;
|
||||||
|
|
||||||
M: ppc-backend %box-float ( dst src -- )
|
M: ppc-backend %box-float ( dst src -- )
|
||||||
[ v>operand ] 2apply %allot-float 12 MR ;
|
[ v>operand ] bi@ %allot-float 12 MR ;
|
||||||
|
|
||||||
: %allot-bignum ( #digits -- )
|
: %allot-bignum ( #digits -- )
|
||||||
#! 1 cell header, 1 cell length, 1 cell sign, + digits
|
#! 1 cell header, 1 cell length, 1 cell sign, + digits
|
||||||
|
|
|
@ -71,7 +71,7 @@ M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap ;
|
||||||
M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
|
M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
|
||||||
|
|
||||||
M: immediate load-literal
|
M: immediate load-literal
|
||||||
[ v>operand ] 2apply LOAD ;
|
[ v>operand ] bi@ LOAD ;
|
||||||
|
|
||||||
M: ppc-backend load-indirect ( obj reg -- )
|
M: ppc-backend load-indirect ( obj reg -- )
|
||||||
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
|
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
|
||||||
|
@ -138,7 +138,7 @@ M: ppc-backend %replace
|
||||||
>r v>operand r> loc>operand STW ;
|
>r v>operand r> loc>operand STW ;
|
||||||
|
|
||||||
M: ppc-backend %unbox-float ( dst src -- )
|
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 ;
|
M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
|
||||||
|
|
||||||
|
@ -291,10 +291,10 @@ M: ppc-backend %unbox-small-struct
|
||||||
|
|
||||||
! Alien intrinsics
|
! Alien intrinsics
|
||||||
M: ppc-backend %unbox-byte-array ( dst src -- )
|
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 -- )
|
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 -- )
|
M: ppc-backend %unbox-f ( dst src -- )
|
||||||
drop 0 swap v>operand LI ;
|
drop 0 swap v>operand LI ;
|
||||||
|
|
|
@ -101,6 +101,6 @@ M: x86-backend %box-alien ( dst src -- )
|
||||||
] %allot
|
] %allot
|
||||||
"end" get JMP
|
"end" get JMP
|
||||||
"f" resolve-label
|
"f" resolve-label
|
||||||
f [ v>operand ] 2apply MOV
|
f [ v>operand ] bi@ MOV
|
||||||
"end" resolve-label
|
"end" resolve-label
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
|
@ -109,9 +109,9 @@ M: x86-backend %dispatch-label ( word -- )
|
||||||
0 cell, rc-absolute-cell rel-word ;
|
0 cell, rc-absolute-cell rel-word ;
|
||||||
|
|
||||||
M: x86-backend %unbox-float ( dst src -- )
|
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 ;
|
M: x86-backend %replace swap %peek ;
|
||||||
|
|
||||||
|
@ -162,10 +162,10 @@ M: x86-backend %return ( -- ) 0 %unwind ;
|
||||||
|
|
||||||
! Alien intrinsics
|
! Alien intrinsics
|
||||||
M: x86-backend %unbox-byte-array ( dst src -- )
|
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 -- )
|
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 -- )
|
M: x86-backend %unbox-f ( dst src -- )
|
||||||
drop v>operand 0 MOV ;
|
drop v>operand 0 MOV ;
|
||||||
|
|
|
@ -82,7 +82,7 @@ ERROR: assert got expect ;
|
||||||
: depth ( -- n ) datastack length ;
|
: depth ( -- n ) datastack length ;
|
||||||
|
|
||||||
: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
|
: 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 ;
|
ERROR: relative-underflow stack ;
|
||||||
|
|
||||||
|
|
|
@ -63,7 +63,7 @@ IN: dlists.tests
|
||||||
[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test
|
[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test
|
||||||
|
|
||||||
: assert-same-elements
|
: assert-same-elements
|
||||||
[ prune natural-sort ] 2apply assert= ;
|
[ prune natural-sort ] bi@ assert= ;
|
||||||
|
|
||||||
: dlist-push-all [ push-front ] curry each ;
|
: dlist-push-all [ push-front ] curry each ;
|
||||||
|
|
||||||
|
|
|
@ -18,8 +18,8 @@ TUPLE: effect in out terminated? ;
|
||||||
{ [ dup not ] [ t ] }
|
{ [ dup not ] [ t ] }
|
||||||
{ [ over effect-terminated? ] [ t ] }
|
{ [ over effect-terminated? ] [ t ] }
|
||||||
{ [ dup effect-terminated? ] [ f ] }
|
{ [ dup effect-terminated? ] [ f ] }
|
||||||
{ [ 2dup [ effect-in length ] 2apply > ] [ f ] }
|
{ [ 2dup [ effect-in length ] bi@ > ] [ f ] }
|
||||||
{ [ 2dup [ effect-height ] 2apply = not ] [ f ] }
|
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
|
||||||
{ [ t ] [ t ] }
|
{ [ t ] [ t ] }
|
||||||
} cond 2nip ;
|
} cond 2nip ;
|
||||||
|
|
||||||
|
|
|
@ -79,7 +79,7 @@ M: ds-loc minimal-ds-loc* ds-loc-n min ;
|
||||||
M: ds-loc operand-class* ds-loc-class ;
|
M: ds-loc operand-class* ds-loc-class ;
|
||||||
M: ds-loc set-operand-class set-ds-loc-class ;
|
M: ds-loc set-operand-class set-ds-loc-class ;
|
||||||
M: ds-loc live-loc?
|
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.
|
! A retain stack location.
|
||||||
TUPLE: rs-loc n class ;
|
TUPLE: rs-loc n class ;
|
||||||
|
@ -89,7 +89,7 @@ TUPLE: rs-loc n class ;
|
||||||
M: rs-loc operand-class* rs-loc-class ;
|
M: rs-loc operand-class* rs-loc-class ;
|
||||||
M: rs-loc set-operand-class set-rs-loc-class ;
|
M: rs-loc set-operand-class set-rs-loc-class ;
|
||||||
M: rs-loc live-loc?
|
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 ;
|
UNION: loc ds-loc rs-loc ;
|
||||||
|
|
||||||
|
@ -206,7 +206,7 @@ INSTANCE: constant value
|
||||||
%move ;
|
%move ;
|
||||||
|
|
||||||
: %move ( dst src -- )
|
: %move ( dst src -- )
|
||||||
2dup [ move-spec ] 2apply 2array {
|
2dup [ move-spec ] bi@ 2array {
|
||||||
{ { f f } [ %move-bug ] }
|
{ { f f } [ %move-bug ] }
|
||||||
{ { f unboxed-c-ptr } [ %move-bug ] }
|
{ { f unboxed-c-ptr } [ %move-bug ] }
|
||||||
{ { f unboxed-byte-array } [ %move-bug ] }
|
{ { f unboxed-byte-array } [ %move-bug ] }
|
||||||
|
@ -318,7 +318,7 @@ M: phantom-stack cut-phantom
|
||||||
|
|
||||||
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
|
: 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 ;
|
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
|
||||||
|
|
||||||
|
@ -442,7 +442,7 @@ M: loc lazy-store
|
||||||
: fast-shuffle? ( live-locs -- ? )
|
: fast-shuffle? ( live-locs -- ? )
|
||||||
#! Test if we have enough free registers to load all
|
#! Test if we have enough free registers to load all
|
||||||
#! shuffle inputs at once.
|
#! shuffle inputs at once.
|
||||||
T{ int-regs } free-vregs [ length ] 2apply <= ;
|
T{ int-regs } free-vregs [ length ] bi@ <= ;
|
||||||
|
|
||||||
: finalize-locs ( -- )
|
: finalize-locs ( -- )
|
||||||
#! Perform any deferred stack shuffling.
|
#! Perform any deferred stack shuffling.
|
||||||
|
@ -488,7 +488,7 @@ M: loc lazy-store
|
||||||
|
|
||||||
: phantom&spec ( phantom spec -- phantom' spec' )
|
: phantom&spec ( phantom spec -- phantom' spec' )
|
||||||
[ length f pad-left ] keep
|
[ length f pad-left ] keep
|
||||||
[ <reversed> ] 2apply ; inline
|
[ <reversed> ] bi@ ; inline
|
||||||
|
|
||||||
: phantom&spec-agree? ( phantom spec quot -- ? )
|
: phantom&spec-agree? ( phantom spec quot -- ? )
|
||||||
>r phantom&spec r> 2all? ; inline
|
>r phantom&spec r> 2all? ; inline
|
||||||
|
@ -520,7 +520,7 @@ M: loc lazy-store
|
||||||
swap lazy-load ;
|
swap lazy-load ;
|
||||||
|
|
||||||
: output-vregs ( -- seq seq )
|
: output-vregs ( -- seq seq )
|
||||||
+output+ +clobber+ [ get [ get ] map ] 2apply ;
|
+output+ +clobber+ [ get [ get ] map ] bi@ ;
|
||||||
|
|
||||||
: clash? ( seq -- ? )
|
: clash? ( seq -- ? )
|
||||||
phantoms append [
|
phantoms append [
|
||||||
|
|
|
@ -156,7 +156,7 @@ M: hashtable clone
|
||||||
|
|
||||||
M: hashtable equal?
|
M: hashtable equal?
|
||||||
over hashtable? [
|
over hashtable? [
|
||||||
2dup [ assoc-size ] 2apply number=
|
2dup [ assoc-size ] bi@ number=
|
||||||
[ assoc= ] [ 2drop f ] if
|
[ assoc= ] [ 2drop f ] if
|
||||||
] [ 2drop f ] if ;
|
] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
|
|
@ -66,8 +66,8 @@ IN: heaps.tests
|
||||||
dup heap-data clone swap
|
dup heap-data clone swap
|
||||||
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
|
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
|
||||||
heap-data
|
heap-data
|
||||||
[ [ entry-key ] map ] 2apply
|
[ [ entry-key ] map ] bi@
|
||||||
[ natural-sort ] 2apply ;
|
[ natural-sort ] bi@ ;
|
||||||
|
|
||||||
11 [
|
11 [
|
||||||
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test
|
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test
|
||||||
|
|
|
@ -26,8 +26,8 @@ C: <literal-constraint> literal-constraint
|
||||||
M: literal-constraint equal?
|
M: literal-constraint equal?
|
||||||
over literal-constraint? [
|
over literal-constraint? [
|
||||||
2dup
|
2dup
|
||||||
[ literal-constraint-literal ] 2apply eql? >r
|
[ literal-constraint-literal ] bi@ eql? >r
|
||||||
[ literal-constraint-value ] 2apply = r> and
|
[ literal-constraint-value ] bi@ = r> and
|
||||||
] [
|
] [
|
||||||
2drop f
|
2drop f
|
||||||
] if ;
|
] if ;
|
||||||
|
|
|
@ -224,7 +224,7 @@ DEFER: do-crap*
|
||||||
MATH: xyz
|
MATH: xyz
|
||||||
M: fixnum xyz 2array ;
|
M: fixnum xyz 2array ;
|
||||||
M: float xyz
|
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
|
[ [ xyz ] infer ] [ inference-error? ] must-fail-with
|
||||||
|
|
||||||
|
|
|
@ -117,7 +117,7 @@ io.encodings.utf8 ;
|
||||||
|
|
||||||
[ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
|
[ ] [ "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
|
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
|
||||||
|
|
||||||
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
|
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
|
||||||
|
|
|
@ -60,8 +60,8 @@ $nl
|
||||||
{ $subsection keep }
|
{ $subsection keep }
|
||||||
{ $subsection 2keep }
|
{ $subsection 2keep }
|
||||||
{ $subsection 3keep }
|
{ $subsection 3keep }
|
||||||
{ $subsection 2apply }
|
{ $subsection bi@ }
|
||||||
"A pair of utility words built from " { $link 2apply } ":"
|
"A pair of utility words built from " { $link bi@ } ":"
|
||||||
{ $subsection both? }
|
{ $subsection both? }
|
||||||
{ $subsection either? }
|
{ $subsection either? }
|
||||||
"A looping combinator:"
|
"A looping combinator:"
|
||||||
|
@ -376,7 +376,7 @@ HELP: 3keep
|
||||||
{ $values { "quot" "a quotation with stack effect " { $snippet "( x y z -- )" } } { "x" object } { "y" object } { "z" object } }
|
{ $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." } ;
|
{ $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 } }
|
{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } { "x" object } { "y" object } }
|
||||||
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." } ;
|
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." } ;
|
||||||
|
|
||||||
|
|
|
@ -199,6 +199,3 @@ GENERIC: construct-boa ( ... class -- tuple )
|
||||||
: do-primitive ( number -- ) "Improper primitive call" throw ;
|
: do-primitive ( number -- ) "Improper primitive call" throw ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
! Deprecated
|
|
||||||
: 2apply bi@ ; inline
|
|
||||||
|
|
|
@ -169,7 +169,7 @@ IN: math.intervals.tests
|
||||||
|
|
||||||
: random-interval ( -- interval )
|
: random-interval ( -- interval )
|
||||||
1000 random dup 2 1000 random + +
|
1000 random dup 2 1000 random + +
|
||||||
1 random zero? [ [ neg ] 2apply swap ] when
|
1 random zero? [ [ neg ] bi@ swap ] when
|
||||||
4 random {
|
4 random {
|
||||||
{ 0 [ [a,b] ] }
|
{ 0 [ [a,b] ] }
|
||||||
{ 1 [ [a,b) ] }
|
{ 1 [ [a,b) ] }
|
||||||
|
@ -197,7 +197,7 @@ IN: math.intervals.tests
|
||||||
0 pick interval-contains? over first { / /i } member? and [
|
0 pick interval-contains? over first { / /i } member? and [
|
||||||
3drop t
|
3drop t
|
||||||
] [
|
] [
|
||||||
[ >r [ random-element ] 2apply ! 2dup . .
|
[ >r [ random-element ] bi@ ! 2dup . .
|
||||||
r> first execute ] 3keep
|
r> first execute ] 3keep
|
||||||
second execute interval-contains?
|
second execute interval-contains?
|
||||||
] if ;
|
] if ;
|
||||||
|
@ -214,7 +214,7 @@ IN: math.intervals.tests
|
||||||
|
|
||||||
: comparison-test
|
: comparison-test
|
||||||
random-interval random-interval random-comparison
|
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? [
|
second execute dup incomparable eq? [
|
||||||
2drop t
|
2drop t
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -67,7 +67,7 @@ C: <interval> interval
|
||||||
|
|
||||||
: (interval-op) ( p1 p2 quot -- p3 )
|
: (interval-op) ( p1 p2 quot -- p3 )
|
||||||
2over >r >r
|
2over >r >r
|
||||||
>r [ first ] 2apply r> call
|
>r [ first ] bi@ r> call
|
||||||
r> r> [ second ] both? 2array ; inline
|
r> r> [ second ] both? 2array ; inline
|
||||||
|
|
||||||
: interval-op ( i1 i2 quot -- i3 )
|
: interval-op ( i1 i2 quot -- i3 )
|
||||||
|
@ -108,7 +108,7 @@ C: <interval> interval
|
||||||
|
|
||||||
: interval-intersect ( i1 i2 -- i3 )
|
: interval-intersect ( i1 i2 -- i3 )
|
||||||
2dup and [
|
2dup and [
|
||||||
[ interval>points ] 2apply swapd
|
[ interval>points ] bi@ swapd
|
||||||
[ swap endpoint> ] most
|
[ swap endpoint> ] most
|
||||||
>r [ swap endpoint< ] most r>
|
>r [ swap endpoint< ] most r>
|
||||||
make-interval
|
make-interval
|
||||||
|
@ -118,7 +118,7 @@ C: <interval> interval
|
||||||
|
|
||||||
: interval-union ( i1 i2 -- i3 )
|
: interval-union ( i1 i2 -- i3 )
|
||||||
2dup and [
|
2dup and [
|
||||||
[ interval>points 2array ] 2apply append points>interval
|
[ interval>points 2array ] bi@ append points>interval
|
||||||
] [
|
] [
|
||||||
2drop f
|
2drop f
|
||||||
] if ;
|
] if ;
|
||||||
|
@ -131,17 +131,17 @@ C: <interval> interval
|
||||||
|
|
||||||
: interval-singleton? ( int -- ? )
|
: interval-singleton? ( int -- ? )
|
||||||
interval>points
|
interval>points
|
||||||
2dup [ second ] 2apply and
|
2dup [ second ] bi@ and
|
||||||
[ [ first ] 2apply = ]
|
[ [ first ] bi@ = ]
|
||||||
[ 2drop f ] if ;
|
[ 2drop f ] if ;
|
||||||
|
|
||||||
: interval-length ( int -- n )
|
: interval-length ( int -- n )
|
||||||
dup
|
dup
|
||||||
[ interval>points [ first ] 2apply swap - ]
|
[ interval>points [ first ] bi@ swap - ]
|
||||||
[ drop 0 ] if ;
|
[ drop 0 ] if ;
|
||||||
|
|
||||||
: interval-closure ( i1 -- i2 )
|
: 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 )
|
: interval-shift ( i1 i2 -- i3 )
|
||||||
#! Inaccurate; could be tighter
|
#! Inaccurate; could be tighter
|
||||||
|
@ -163,7 +163,7 @@ C: <interval> interval
|
||||||
[ min ] interval-op interval-closure ;
|
[ min ] interval-op interval-closure ;
|
||||||
|
|
||||||
: interval-interior ( i1 -- i2 )
|
: interval-interior ( i1 -- i2 )
|
||||||
interval>points [ first ] 2apply (a,b) ;
|
interval>points [ first ] bi@ (a,b) ;
|
||||||
|
|
||||||
: interval-division-op ( i1 i2 quot -- i3 )
|
: interval-division-op ( i1 i2 quot -- i3 )
|
||||||
>r 0 over interval-closure interval-contains?
|
>r 0 over interval-closure interval-contains?
|
||||||
|
@ -186,13 +186,13 @@ SYMBOL: incomparable
|
||||||
: left-endpoint-< ( i1 i2 -- ? )
|
: left-endpoint-< ( i1 i2 -- ? )
|
||||||
[ swap interval-subset? ] 2keep
|
[ swap interval-subset? ] 2keep
|
||||||
[ nip interval-singleton? ] 2keep
|
[ nip interval-singleton? ] 2keep
|
||||||
[ interval-from ] 2apply =
|
[ interval-from ] bi@ =
|
||||||
and and ;
|
and and ;
|
||||||
|
|
||||||
: right-endpoint-< ( i1 i2 -- ? )
|
: right-endpoint-< ( i1 i2 -- ? )
|
||||||
[ interval-subset? ] 2keep
|
[ interval-subset? ] 2keep
|
||||||
[ drop interval-singleton? ] 2keep
|
[ drop interval-singleton? ] 2keep
|
||||||
[ interval-to ] 2apply =
|
[ interval-to ] bi@ =
|
||||||
and and ;
|
and and ;
|
||||||
|
|
||||||
: (interval<) over interval-from over interval-from endpoint< ;
|
: (interval<) over interval-from over interval-from endpoint< ;
|
||||||
|
|
|
@ -99,7 +99,7 @@ namespaces assocs kernel sequences math tools.test words ;
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
: regression-2 ( x y -- x.y )
|
: regression-2 ( x y -- x.y )
|
||||||
[ p1 ] 2apply [
|
[ p1 ] bi@ [
|
||||||
[
|
[
|
||||||
rot
|
rot
|
||||||
[ 2swap [ swapd * -rot p2 +@ ] 2keep ]
|
[ 2swap [ swapd * -rot p2 +@ ] 2keep ]
|
||||||
|
|
|
@ -113,7 +113,7 @@ generic.standard system ;
|
||||||
: post-process ( class interval node -- classes intervals )
|
: post-process ( class interval node -- classes intervals )
|
||||||
dupd won't-overflow?
|
dupd won't-overflow?
|
||||||
[ >r dup { f integer } member? [ drop fixnum ] when r> ] when
|
[ >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 )
|
: math-output-interval-1 ( node word -- interval )
|
||||||
dup [
|
dup [
|
||||||
|
@ -147,7 +147,7 @@ generic.standard system ;
|
||||||
] each
|
] each
|
||||||
|
|
||||||
: intervals ( node -- i1 i2 )
|
: 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 )
|
: math-output-interval-2 ( node word -- interval )
|
||||||
dup [
|
dup [
|
||||||
|
|
|
@ -475,7 +475,7 @@ SYMBOL: interactive-vocabs
|
||||||
|
|
||||||
: removed-definitions ( -- definitions )
|
: removed-definitions ( -- definitions )
|
||||||
new-definitions old-definitions
|
new-definitions old-definitions
|
||||||
[ get first2 union ] 2apply diff ;
|
[ get first2 union ] bi@ diff ;
|
||||||
|
|
||||||
: smudged-usage ( -- usages referenced removed )
|
: smudged-usage ( -- usages referenced removed )
|
||||||
removed-definitions filter-moved keys [
|
removed-definitions filter-moved keys [
|
||||||
|
|
|
@ -114,7 +114,7 @@ SYMBOL: ->
|
||||||
|
|
||||||
: remove-breakpoints ( quot pos -- quot' )
|
: remove-breakpoints ( quot pos -- quot' )
|
||||||
over quotation? [
|
over quotation? [
|
||||||
1+ cut [ (remove-breakpoints) ] 2apply
|
1+ cut [ (remove-breakpoints) ] bi@
|
||||||
[ -> ] swap 3append
|
[ -> ] swap 3append
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
|
|
|
@ -12,7 +12,7 @@ M: curry call dup 3 slot swap 4 slot call ;
|
||||||
M: compose call dup 3 slot swap 4 slot slip call ;
|
M: compose call dup 3 slot swap 4 slot slip call ;
|
||||||
|
|
||||||
M: wrapper equal?
|
M: wrapper equal?
|
||||||
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;
|
over wrapper? [ [ wrapped ] bi@ = ] [ 2drop f ] if ;
|
||||||
|
|
||||||
UNION: callable quotation curry compose ;
|
UNION: callable quotation curry compose ;
|
||||||
|
|
||||||
|
|
|
@ -169,13 +169,13 @@ unit-test
|
||||||
|
|
||||||
[ f ] [ { "a" "b" "c" } { "a" "b" "c" } mismatch ] unit-test
|
[ 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
|
[ -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 ] [ "ab" "abc" <=> ] unit-test
|
||||||
[ 1 ] [ "abc" "ab" <=> ] unit-test
|
[ 1 ] [ "abc" "ab" <=> ] unit-test
|
||||||
|
|
|
@ -300,9 +300,9 @@ M: immutable-sequence clone-like like ;
|
||||||
: change-nth ( i seq quot -- )
|
: change-nth ( i seq quot -- )
|
||||||
[ >r nth r> call ] 3keep drop set-nth ; inline
|
[ >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
|
<PRIVATE
|
||||||
|
|
||||||
|
@ -369,7 +369,7 @@ PRIVATE>
|
||||||
(2each) each-integer ; inline
|
(2each) each-integer ; inline
|
||||||
|
|
||||||
: 2reverse-each ( seq1 seq2 quot -- )
|
: 2reverse-each ( seq1 seq2 quot -- )
|
||||||
>r [ <reversed> ] 2apply r> 2each ; inline
|
>r [ <reversed> ] bi@ r> 2each ; inline
|
||||||
|
|
||||||
: 2reduce ( seq1 seq2 identity quot -- result )
|
: 2reduce ( seq1 seq2 identity quot -- result )
|
||||||
>r -rot r> 2each ; inline
|
>r -rot r> 2each ; inline
|
||||||
|
@ -460,7 +460,7 @@ M: sequence <=>
|
||||||
[ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
|
[ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
|
||||||
|
|
||||||
: sequence= ( seq1 seq2 -- ? )
|
: sequence= ( seq1 seq2 -- ? )
|
||||||
2dup [ length ] 2apply number=
|
2dup [ length ] bi@ number=
|
||||||
[ mismatch not ] [ 2drop f ] if ; inline
|
[ mismatch not ] [ 2drop f ] if ; inline
|
||||||
|
|
||||||
: move ( to from seq -- )
|
: move ( to from seq -- )
|
||||||
|
@ -620,12 +620,12 @@ M: sequence <=>
|
||||||
[ drop nip ]
|
[ drop nip ]
|
||||||
[ 2drop first ]
|
[ 2drop first ]
|
||||||
[ >r drop first2 r> call ]
|
[ >r drop first2 r> call ]
|
||||||
[ >r drop first3 r> 2apply ]
|
[ >r drop first3 r> bi@ ]
|
||||||
} dispatch
|
} dispatch
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
>r >r halves r> r>
|
>r >r halves r> r>
|
||||||
[ [ binary-reduce ] 2curry 2apply ] keep
|
[ [ binary-reduce ] 2curry bi@ ] keep
|
||||||
call
|
call
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
|
|
|
@ -32,7 +32,7 @@ DEFER: sort
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
: merge ( sorted1 sorted2 quot -- result )
|
: merge ( sorted1 sorted2 quot -- result )
|
||||||
>r [ [ <iterator> ] 2apply ] 2keep r>
|
>r [ [ <iterator> ] bi@ ] 2keep r>
|
||||||
rot length rot length + <vector>
|
rot length rot length + <vector>
|
||||||
[ (merge) ] keep underlying ; inline
|
[ (merge) ] keep underlying ; inline
|
||||||
|
|
||||||
|
|
|
@ -56,7 +56,7 @@ INSTANCE: groups sequence
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: last-split1 ( seq subseq -- before after )
|
: last-split1 ( seq subseq -- before after )
|
||||||
[ <reversed> ] 2apply split1 [ reverse ] 2apply
|
[ <reversed> ] bi@ split1 [ reverse ] bi@
|
||||||
dup [ swap ] when ;
|
dup [ swap ] when ;
|
||||||
|
|
||||||
: (split) ( separators n seq -- )
|
: (split) ( separators n seq -- )
|
||||||
|
|
|
@ -77,7 +77,7 @@ IN: vectors.tests
|
||||||
|
|
||||||
[ f ] [
|
[ f ] [
|
||||||
V{ 1 2 3 4 } dup clone
|
V{ 1 2 3 4 } dup clone
|
||||||
[ underlying ] 2apply eq?
|
[ underlying ] bi@ eq?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 0 ] [
|
[ 0 ] [
|
||||||
|
|
|
@ -94,7 +94,7 @@ TUPLE: vocab-link name ;
|
||||||
|
|
||||||
M: vocab-link equal?
|
M: vocab-link equal?
|
||||||
over vocab-link?
|
over vocab-link?
|
||||||
[ [ vocab-link-name ] 2apply = ] [ 2drop f ] if ;
|
[ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ;
|
||||||
|
|
||||||
M: vocab-link hashcode*
|
M: vocab-link hashcode*
|
||||||
vocab-link-name hashcode* ;
|
vocab-link-name hashcode* ;
|
||||||
|
|
|
@ -133,7 +133,7 @@ DEFER: create ( level c r -- scene )
|
||||||
pick 1 = [ <sphere> nip ] [ create-group ] if ;
|
pick 1 = [ <sphere> nip ] [ create-group ] if ;
|
||||||
|
|
||||||
: ss-point ( dx dy -- point )
|
: ss-point ( dx dy -- point )
|
||||||
[ oversampling /f ] 2apply 0.0 3float-array ;
|
[ oversampling /f ] bi@ 0.0 3float-array ;
|
||||||
|
|
||||||
: ss-grid ( -- ss-grid )
|
: ss-grid ( -- ss-grid )
|
||||||
oversampling [ oversampling [ ss-point ] with map ] map ;
|
oversampling [ oversampling [ ss-point ] with map ] map ;
|
||||||
|
@ -150,7 +150,7 @@ DEFER: create ( level c r -- scene )
|
||||||
: pixel-grid ( -- grid )
|
: pixel-grid ( -- grid )
|
||||||
size reverse [
|
size reverse [
|
||||||
size [
|
size [
|
||||||
[ size 0.5 * - ] 2apply swap size
|
[ size 0.5 * - ] bi@ swap size
|
||||||
3float-array
|
3float-array
|
||||||
] with map
|
] with map
|
||||||
] map ;
|
] map ;
|
||||||
|
|
|
@ -5,7 +5,7 @@ io.files kernel ;
|
||||||
[ "c071aa7e007a9770b2fb4304f55a17e5" ] [
|
[ "c071aa7e007a9770b2fb4304f55a17e5" ] [
|
||||||
"extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
|
"extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
|
||||||
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
|
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
|
||||||
[ resource-path ] 2apply
|
[ resource-path ] bi@
|
||||||
reverse-complement
|
reverse-complement
|
||||||
|
|
||||||
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
|
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
|
||||||
|
|
|
@ -7,7 +7,7 @@ IN: benchmark.spectral-norm
|
||||||
: fast-truncate >fixnum >float ; inline
|
: fast-truncate >fixnum >float ; inline
|
||||||
|
|
||||||
: eval-A ( i j -- n )
|
: eval-A ( i j -- n )
|
||||||
[ >float ] 2apply
|
[ >float ] bi@
|
||||||
dupd + dup 1+ * 2 /f fast-truncate + 1+
|
dupd + dup 1+ * 2 /f fast-truncate + 1+
|
||||||
recip ; inline
|
recip ; inline
|
||||||
|
|
||||||
|
|
|
@ -63,7 +63,7 @@ M: check< summary drop "Number exceeds upper bound" ;
|
||||||
[ range>accessor ] map ;
|
[ range>accessor ] map ;
|
||||||
|
|
||||||
: clear-range ( range -- num )
|
: clear-range ( range -- num )
|
||||||
first2 dupd + [ 2^ 1- ] 2apply bitnot bitor ;
|
first2 dupd + [ 2^ 1- ] bi@ bitnot bitor ;
|
||||||
|
|
||||||
: range>setter ( range -- quot )
|
: range>setter ( range -- quot )
|
||||||
[
|
[
|
||||||
|
|
|
@ -80,7 +80,7 @@ VAR: separation-radius
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: 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 )
|
: relative-angle ( self other -- angle )
|
||||||
over boid-vel -rot relative-position angle-between ;
|
over boid-vel -rot relative-position angle-between ;
|
||||||
|
|
|
@ -19,11 +19,11 @@ IN: builder.benchmark
|
||||||
2array ;
|
2array ;
|
||||||
|
|
||||||
: compare-tables ( old new -- table )
|
: compare-tables ( old new -- table )
|
||||||
[ passing-benchmarks ] 2apply
|
[ passing-benchmarks ] bi@
|
||||||
[ benchmark-difference ] with map ;
|
[ benchmark-difference ] with map ;
|
||||||
|
|
||||||
: benchmark-deltas ( -- table )
|
: benchmark-deltas ( -- table )
|
||||||
"../benchmarks" "benchmarks" [ eval-file ] 2apply
|
"../benchmarks" "benchmarks" [ eval-file ] bi@
|
||||||
compare-tables
|
compare-tables
|
||||||
sort-values ;
|
sort-values ;
|
||||||
|
|
||||||
|
|
|
@ -88,7 +88,7 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: longer? ( seq seq -- ? ) [ length ] 2apply > ;
|
: longer? ( seq seq -- ? ) [ length ] bi@ > ;
|
||||||
|
|
||||||
: maybe-tail* ( seq n -- seq )
|
: maybe-tail* ( seq n -- seq )
|
||||||
2dup longer?
|
2dup longer?
|
||||||
|
|
|
@ -185,7 +185,7 @@ M: number +second ( timestamp n -- timestamp )
|
||||||
[ month>> +month ] keep
|
[ month>> +month ] keep
|
||||||
[ year>> +year ] keep ; inline
|
[ year>> +year ] keep ; inline
|
||||||
|
|
||||||
: +slots [ 2apply + ] curry 2keep ; inline
|
: +slots [ bi@ + ] curry 2keep ; inline
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
@ -244,9 +244,9 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
||||||
[ >gmt tuple-slots ] compare ;
|
[ >gmt tuple-slots ] compare ;
|
||||||
|
|
||||||
: (time-) ( timestamp timestamp -- n )
|
: (time-) ( timestamp timestamp -- n )
|
||||||
[ >gmt ] 2apply
|
[ >gmt ] bi@
|
||||||
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
|
[ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
|
||||||
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
|
[ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ;
|
||||||
|
|
||||||
M: timestamp time-
|
M: timestamp time-
|
||||||
#! Exact calendar-time difference
|
#! Exact calendar-time difference
|
||||||
|
|
|
@ -182,7 +182,7 @@ M: timestamp year. ( timestamp -- )
|
||||||
[
|
[
|
||||||
[ month>> month-abbreviations nth write ] keep bl
|
[ month>> month-abbreviations nth write ] keep bl
|
||||||
[ day>> number>string 2 32 pad-left write ] keep bl
|
[ day>> number>string 2 32 pad-left write ] keep bl
|
||||||
dup now [ year>> ] 2apply = [
|
dup now [ year>> ] bi@ = [
|
||||||
[ hour>> write-00 ] keep ":" write
|
[ hour>> write-00 ] keep ":" write
|
||||||
minute>> write-00
|
minute>> write-00
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -26,7 +26,7 @@ IN: cocoa.dialogs
|
||||||
[ -> filenames CF>string-array ] [ drop f ] if ;
|
[ -> filenames CF>string-array ] [ drop f ] if ;
|
||||||
|
|
||||||
: split-path ( path -- dir file )
|
: split-path ( path -- dir file )
|
||||||
"/" last-split1 [ <NSString> ] 2apply ;
|
"/" last-split1 [ <NSString> ] bi@ ;
|
||||||
|
|
||||||
: save-panel ( path -- paths )
|
: save-panel ( path -- paths )
|
||||||
<NSSavePanel> dup
|
<NSSavePanel> dup
|
||||||
|
|
|
@ -24,7 +24,7 @@ C: <rsa> rsa
|
||||||
: modulus-phi ( numbits -- n phi )
|
: modulus-phi ( numbits -- n phi )
|
||||||
#! Loop until phi is not divisible by the public key.
|
#! Loop until phi is not divisible by the public key.
|
||||||
dup rsa-primes [ * ] 2keep
|
dup rsa-primes [ * ] 2keep
|
||||||
[ 1- ] 2apply *
|
[ 1- ] bi@ *
|
||||||
dup public-key gcd nip 1 = [
|
dup public-key gcd nip 1 = [
|
||||||
rot drop
|
rot drop
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -124,5 +124,5 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
|
||||||
: byte-array>sha1-interleave ( string -- seq )
|
: byte-array>sha1-interleave ( string -- seq )
|
||||||
[ zero? ] left-trim
|
[ zero? ] left-trim
|
||||||
dup length odd? [ 1 tail ] when
|
dup length odd? [ 1 tail ] when
|
||||||
seq>2seq [ byte-array>sha1 ] 2apply
|
seq>2seq [ byte-array>sha1 ] bi@
|
||||||
swap 2seq>seq ;
|
swap 2seq>seq ;
|
||||||
|
|
|
@ -12,7 +12,7 @@ IN: documents
|
||||||
|
|
||||||
: =line ( n loc -- newloc ) second 2array ;
|
: =line ( n loc -- newloc ) second 2array ;
|
||||||
|
|
||||||
: lines-equal? ( loc1 loc2 -- ? ) [ first ] 2apply number= ;
|
: lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ;
|
||||||
|
|
||||||
TUPLE: document locs ;
|
TUPLE: document locs ;
|
||||||
|
|
||||||
|
@ -46,7 +46,7 @@ TUPLE: document locs ;
|
||||||
2over = [
|
2over = [
|
||||||
3drop
|
3drop
|
||||||
] [
|
] [
|
||||||
>r [ first ] 2apply 1+ dup <slice> r> each
|
>r [ first ] bi@ 1+ dup <slice> r> each
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
: start/end-on-line ( from to line# -- n1 n2 )
|
: start/end-on-line ( from to line# -- n1 n2 )
|
||||||
|
@ -85,7 +85,7 @@ TUPLE: document locs ;
|
||||||
|
|
||||||
: (set-doc-range) ( newlines from to lines -- )
|
: (set-doc-range) ( newlines from to lines -- )
|
||||||
[ prepare-insert ] 3keep
|
[ prepare-insert ] 3keep
|
||||||
>r [ first ] 2apply 1+ r>
|
>r [ first ] bi@ 1+ r>
|
||||||
replace-slice ;
|
replace-slice ;
|
||||||
|
|
||||||
: set-doc-range ( string from to document -- )
|
: set-doc-range ( string from to document -- )
|
||||||
|
|
|
@ -91,7 +91,7 @@ C: <faq> faq
|
||||||
: faq-sections, ( question-lists -- )
|
: faq-sections, ( question-lists -- )
|
||||||
unclip question-list-seq length 1+ dupd
|
unclip question-list-seq length 1+ dupd
|
||||||
[ question-list-seq length + ] accumulate nip
|
[ 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 )
|
: faq>html ( faq -- div )
|
||||||
"div" [
|
"div" [
|
||||||
|
|
|
@ -69,7 +69,7 @@ $nl
|
||||||
{ { $link curry } { $snippet ": curry '[ , @ ] ;" } }
|
{ { $link curry } { $snippet ": curry '[ , @ ] ;" } }
|
||||||
{ { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } }
|
{ { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } }
|
||||||
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
|
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
|
||||||
{ { $link 2apply } { $snippet ": 2apply tuck '[ , @ , @ ] call ;" } }
|
{ { $link bi@ } { $snippet ": bi@ tuck '[ , @ , @ ] call ;" } }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
ARTICLE: "fry.philosophy" "Fried quotation philosophy"
|
ARTICLE: "fry.philosophy" "Fried quotation philosophy"
|
||||||
|
|
|
@ -59,7 +59,7 @@ IN: help.lint
|
||||||
|
|
||||||
: check-see-also ( word element -- )
|
: check-see-also ( word element -- )
|
||||||
nip \ $see-also swap elements [
|
nip \ $see-also swap elements [
|
||||||
1 tail dup prune [ length ] 2apply assert=
|
1 tail dup prune [ length ] bi@ assert=
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
: vocab-exists? ( name -- ? )
|
: vocab-exists? ( name -- ? )
|
||||||
|
|
|
@ -106,7 +106,7 @@ IN: http
|
||||||
: query>assoc ( query -- assoc )
|
: query>assoc ( query -- assoc )
|
||||||
dup [
|
dup [
|
||||||
"&" split [
|
"&" split [
|
||||||
"=" split1 [ dup [ url-decode ] when ] 2apply
|
"=" split1 [ dup [ url-decode ] when ] bi@
|
||||||
] H{ } map>assoc
|
] H{ } map>assoc
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
|
|
|
@ -51,14 +51,14 @@ SYMBOL: open-arrays
|
||||||
|
|
||||||
: binary-op ( quot -- ? )
|
: binary-op ( quot -- ? )
|
||||||
>r get-cba r>
|
>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
|
set-reg f ; inline
|
||||||
|
|
||||||
: op1 ( opcode -- ? )
|
: op1 ( opcode -- ? )
|
||||||
[ swap arr-val ] binary-op ;
|
[ swap arr-val ] binary-op ;
|
||||||
|
|
||||||
: op2 ( opcode -- ? )
|
: 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 -- ? )
|
: op3 ( opcode -- ? )
|
||||||
[ + >32bit ] binary-op ;
|
[ + >32bit ] binary-op ;
|
||||||
|
|
|
@ -151,10 +151,10 @@ MACRO: undo ( quot -- ) [undo] ;
|
||||||
\ - [ + ] [ - ] define-math-inverse
|
\ - [ + ] [ - ] define-math-inverse
|
||||||
\ * [ / ] [ / ] define-math-inverse
|
\ * [ / ] [ / ] define-math-inverse
|
||||||
\ / [ * ] [ / ] define-math-inverse
|
\ / [ * ] [ / ] define-math-inverse
|
||||||
\ ^ [ recip ^ ] [ [ log ] 2apply / ] define-math-inverse
|
\ ^ [ recip ^ ] [ [ log ] bi@ / ] define-math-inverse
|
||||||
|
|
||||||
\ ? 2 [
|
\ ? 2 [
|
||||||
[ assert-literal ] 2apply
|
[ assert-literal ] bi@
|
||||||
[ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
|
[ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
|
||||||
2curry
|
2curry
|
||||||
] define-pop-inverse
|
] define-pop-inverse
|
||||||
|
|
|
@ -78,7 +78,7 @@ M: utf16le decode-char
|
||||||
swap BIN: 11111111 bitand ;
|
swap BIN: 11111111 bitand ;
|
||||||
|
|
||||||
: stream-write2 ( stream char1 char2 -- )
|
: stream-write2 ( stream char1 char2 -- )
|
||||||
rot [ stream-write1 ] curry 2apply ;
|
rot [ stream-write1 ] curry bi@ ;
|
||||||
|
|
||||||
: char>utf16be ( stream char -- )
|
: char>utf16be ( stream char -- )
|
||||||
dup HEX: FFFF > [
|
dup HEX: FFFF > [
|
||||||
|
|
|
@ -161,5 +161,5 @@ TUPLE: datagram-port addr packet packet-addr ;
|
||||||
|
|
||||||
: check-datagram-send ( packet addrspec port -- )
|
: check-datagram-send ( packet addrspec port -- )
|
||||||
dup check-datagram-port
|
dup check-datagram-port
|
||||||
datagram-port-addr [ class ] 2apply assert=
|
datagram-port-addr [ class ] bi@ assert=
|
||||||
class byte-array assert= ;
|
class byte-array assert= ;
|
||||||
|
|
|
@ -64,8 +64,8 @@ M: inet6 inet-ntop ( data addrspec -- str )
|
||||||
|
|
||||||
M: inet6 inet-pton ( str addrspec -- data )
|
M: inet6 inet-pton ( str addrspec -- data )
|
||||||
drop "::" split1
|
drop "::" split1
|
||||||
[ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] 2apply
|
[ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] bi@
|
||||||
2dup [ length ] 2apply + 8 swap - 0 <array> swap 3append
|
2dup [ length ] bi@ + 8 swap - 0 <array> swap 3append
|
||||||
[ 2 >be ] map concat >byte-array ;
|
[ 2 >be ] map concat >byte-array ;
|
||||||
|
|
||||||
M: inet6 address-size drop 16 ;
|
M: inet6 address-size drop 16 ;
|
||||||
|
|
|
@ -49,7 +49,7 @@ M: unix-io touch-file ( path -- )
|
||||||
close ;
|
close ;
|
||||||
|
|
||||||
M: unix-io move-file ( from to -- )
|
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 -- )
|
M: unix-io delete-file ( path -- )
|
||||||
normalize-pathname unlink io-error ;
|
normalize-pathname unlink io-error ;
|
||||||
|
@ -69,7 +69,7 @@ M: unix-io delete-directory ( path -- )
|
||||||
] with-disposal ;
|
] with-disposal ;
|
||||||
|
|
||||||
M: unix-io copy-file ( from to -- )
|
M: unix-io copy-file ( from to -- )
|
||||||
[ normalize-pathname ] 2apply
|
[ normalize-pathname ] bi@
|
||||||
[ (copy-file) ]
|
[ (copy-file) ]
|
||||||
[ swap file-info file-info-permissions chmod io-error ]
|
[ swap file-info file-info-permissions chmod io-error ]
|
||||||
2bi ;
|
2bi ;
|
||||||
|
|
|
@ -46,5 +46,5 @@ M: windows-ce-io (init-stdio) ( -- )
|
||||||
1 _getstdfilex _fileno
|
1 _getstdfilex _fileno
|
||||||
2 _getstdfilex _fileno
|
2 _getstdfilex _fileno
|
||||||
] if [ f <win32-file> ] 3apply
|
] if [ f <win32-file> ] 3apply
|
||||||
rot <reader> -rot [ <writer> ] 2apply
|
rot <reader> -rot [ <writer> ] bi@
|
||||||
] with-variable ;
|
] with-variable ;
|
||||||
|
|
|
@ -135,14 +135,14 @@ M: windows-io (file-appender) ( path -- stream )
|
||||||
open-append <win32-file> <writer> ;
|
open-append <win32-file> <writer> ;
|
||||||
|
|
||||||
M: windows-io move-file ( from to -- )
|
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 -- )
|
M: windows-io delete-file ( path -- )
|
||||||
normalize-pathname DeleteFile win32-error=0/f ;
|
normalize-pathname DeleteFile win32-error=0/f ;
|
||||||
|
|
||||||
M: windows-io copy-file ( from to -- )
|
M: windows-io copy-file ( from to -- )
|
||||||
dup parent-directory make-directories
|
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 -- )
|
M: windows-io make-directory ( path -- )
|
||||||
normalize-pathname
|
normalize-pathname
|
||||||
|
|
|
@ -72,7 +72,7 @@ TUPLE: segment number color radius ;
|
||||||
: sub-tunnel ( from to sements -- segments )
|
: sub-tunnel ( from to sements -- segments )
|
||||||
#! return segments between from and to, after clamping from and to to
|
#! return segments between from and to, after clamping from and to to
|
||||||
#! valid values
|
#! 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 )
|
: nearer-segment ( segment segment oint -- segment )
|
||||||
#! return whichever of the two segments is nearer to the oint
|
#! return whichever of the two segments is nearer to the oint
|
||||||
|
|
|
@ -57,7 +57,7 @@ SYMBOL: terms
|
||||||
terms get [ [ swap +@ ] assoc-each ] bind ;
|
terms get [ [ swap +@ ] assoc-each ] bind ;
|
||||||
|
|
||||||
: alt+ ( x y -- x+y )
|
: alt+ ( x y -- x+y )
|
||||||
[ >alt ] 2apply [ (alt+) (alt+) ] with-terms ;
|
[ >alt ] bi@ [ (alt+) (alt+) ] with-terms ;
|
||||||
|
|
||||||
! Multiplication
|
! Multiplication
|
||||||
: alt*n ( vec n -- vec )
|
: alt*n ( vec n -- vec )
|
||||||
|
@ -79,7 +79,7 @@ SYMBOL: terms
|
||||||
] curry each ;
|
] curry each ;
|
||||||
|
|
||||||
: duplicates? ( seq -- ? )
|
: duplicates? ( seq -- ? )
|
||||||
dup prune [ length ] 2apply > ;
|
dup prune [ length ] bi@ > ;
|
||||||
|
|
||||||
: (wedge) ( n basis1 basis2 -- n basis )
|
: (wedge) ( n basis1 basis2 -- n basis )
|
||||||
append dup duplicates? [
|
append dup duplicates? [
|
||||||
|
@ -90,7 +90,7 @@ SYMBOL: terms
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: wedge ( x y -- x.y )
|
: wedge ( x y -- x.y )
|
||||||
[ >alt ] 2apply [
|
[ >alt ] bi@ [
|
||||||
swap [
|
swap [
|
||||||
[
|
[
|
||||||
2swap [
|
2swap [
|
||||||
|
@ -200,7 +200,7 @@ DEFER: (d)
|
||||||
] with map ;
|
] with map ;
|
||||||
|
|
||||||
: bigraded-betti ( u-generators z-generators -- seq )
|
: 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
|
[ [ [ first ] map ] map ] keep
|
||||||
[ [ second ] map 2 head* { 0 0 } prepend ] map
|
[ [ second ] map 2 head* { 0 0 } prepend ] map
|
||||||
1 tail dup first length 0 <array> add
|
1 tail dup first length 0 <array> add
|
||||||
|
@ -278,7 +278,7 @@ DEFER: (d)
|
||||||
] with map ;
|
] with map ;
|
||||||
|
|
||||||
: bigraded-laplacian ( u-generators z-generators quot -- seq )
|
: 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
|
[ [ first3 ] swap compose map ] curry map ; inline
|
||||||
|
|
||||||
: bigraded-laplacian-betti ( u-generators z-generators -- seq )
|
: bigraded-laplacian-betti ( u-generators z-generators -- seq )
|
||||||
|
|
|
@ -52,7 +52,7 @@ M: cons nil? ( cons -- bool )
|
||||||
TUPLE: lazy-cons car cdr ;
|
TUPLE: lazy-cons car cdr ;
|
||||||
|
|
||||||
: lazy-cons ( car cdr -- promise )
|
: lazy-cons ( car cdr -- promise )
|
||||||
[ promise ] 2apply \ lazy-cons construct-boa
|
[ promise ] bi@ \ lazy-cons construct-boa
|
||||||
T{ promise f f t f } clone
|
T{ promise f f t f } clone
|
||||||
[ set-promise-value ] keep ;
|
[ set-promise-value ] keep ;
|
||||||
|
|
||||||
|
|
|
@ -17,7 +17,7 @@ SYMBOL: d
|
||||||
SYMBOL: costs
|
SYMBOL: costs
|
||||||
|
|
||||||
: init-d ( str1 str2 -- )
|
: init-d ( str1 str2 -- )
|
||||||
[ length 1+ ] 2apply 2dup <matrix> d set
|
[ length 1+ ] bi@ 2dup <matrix> d set
|
||||||
[ 0 over ->d ] each
|
[ 0 over ->d ] each
|
||||||
[ dup 0 ->d ] each ; inline
|
[ dup 0 ->d ] each ; inline
|
||||||
|
|
||||||
|
@ -39,7 +39,7 @@ SYMBOL: costs
|
||||||
[
|
[
|
||||||
2dup init-d
|
2dup init-d
|
||||||
2dup compute-costs
|
2dup compute-costs
|
||||||
[ length ] 2apply [
|
[ length ] bi@ [
|
||||||
[ levenshtein-step ] curry each
|
[ levenshtein-step ] curry each
|
||||||
] with each
|
] with each
|
||||||
levenshtein-result
|
levenshtein-result
|
||||||
|
|
|
@ -71,7 +71,7 @@ def-hash get-global [
|
||||||
|
|
||||||
! Remove set-alien-cell, etc.
|
! 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
|
] assoc-subset
|
||||||
|
|
||||||
! Remove trivial defs
|
! Remove trivial defs
|
||||||
|
@ -148,7 +148,7 @@ GENERIC: run-lint ( obj -- obj )
|
||||||
: filter-symbols ( alist -- alist )
|
: filter-symbols ( alist -- alist )
|
||||||
[
|
[
|
||||||
nip first dup def-hash get at
|
nip first dup def-hash get at
|
||||||
[ first ] 2apply literalize = not
|
[ first ] bi@ literalize = not
|
||||||
] assoc-subset ;
|
] assoc-subset ;
|
||||||
|
|
||||||
M: sequence run-lint ( seq -- seq )
|
M: sequence run-lint ( seq -- seq )
|
||||||
|
|
|
@ -32,10 +32,10 @@ SYMBOL: _
|
||||||
{ [ 2dup = ] [ 2drop t ] }
|
{ [ 2dup = ] [ 2drop t ] }
|
||||||
{ [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
|
{ [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
|
||||||
{ [ 2dup [ sequence? ] both? ] [
|
{ [ 2dup [ sequence? ] both? ] [
|
||||||
2dup [ length ] 2apply =
|
2dup [ length ] bi@ =
|
||||||
[ [ (match) ] 2all? ] [ 2drop f ] if ] }
|
[ [ (match) ] 2all? ] [ 2drop f ] if ] }
|
||||||
{ [ 2dup [ tuple? ] both? ]
|
{ [ 2dup [ tuple? ] both? ]
|
||||||
[ [ tuple>array ] 2apply [ (match) ] 2all? ] }
|
[ [ tuple>array ] bi@ [ (match) ] 2all? ] }
|
||||||
{ [ t ] [ 2drop f ] }
|
{ [ t ] [ 2drop f ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
|
|
|
@ -8,11 +8,11 @@ math.functions.private sequences parser ;
|
||||||
M: real real-part ;
|
M: real real-part ;
|
||||||
M: real imaginary-part drop 0 ;
|
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 )
|
: 2>rect ( x y -- xr yr xi yi )
|
||||||
[ [ real-part ] 2apply ] 2keep
|
[ [ real-part ] bi@ ] 2keep
|
||||||
[ imaginary-part ] 2apply ; inline
|
[ imaginary-part ] bi@ ; inline
|
||||||
|
|
||||||
M: complex number=
|
M: complex number=
|
||||||
2>rect number= [ number= ] [ 2drop f ] if ;
|
2>rect number= [ number= ] [ 2drop f ] if ;
|
||||||
|
|
|
@ -101,7 +101,7 @@ M: real absq sq ;
|
||||||
>r - abs r> < ;
|
>r - abs r> < ;
|
||||||
|
|
||||||
: ~rel ( x y epsilon -- ? )
|
: ~rel ( x y epsilon -- ? )
|
||||||
>r [ - abs ] 2keep [ abs ] 2apply + r> * < ;
|
>r [ - abs ] 2keep [ abs ] bi@ + r> * < ;
|
||||||
|
|
||||||
: ~ ( x y epsilon -- ? )
|
: ~ ( x y epsilon -- ? )
|
||||||
{
|
{
|
||||||
|
@ -124,7 +124,7 @@ M: real absq sq ;
|
||||||
: arg ( z -- arg ) >float-rect swap fatan2 ; inline
|
: arg ( z -- arg ) >float-rect swap fatan2 ; inline
|
||||||
|
|
||||||
: >polar ( z -- abs arg )
|
: >polar ( z -- abs arg )
|
||||||
>float-rect [ [ sq ] 2apply + fsqrt ] 2keep swap fatan2 ;
|
>float-rect [ [ sq ] bi@ + fsqrt ] 2keep swap fatan2 ;
|
||||||
inline
|
inline
|
||||||
|
|
||||||
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
|
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
|
||||||
|
|
|
@ -13,10 +13,10 @@ IN: math.polynomials
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
: 2pad-left ( p p n -- p p ) 0 [ pad-left swap ] 2keep pad-left swap ;
|
: 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 ;
|
: 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 ( p p -- p p ) 2dup [ length ] bi@ max 2pad-right ;
|
||||||
: pextend-left ( p p -- p p ) 2dup [ length ] 2apply max 2pad-left ;
|
: pextend-left ( p p -- p p ) 2dup [ length ] bi@ max 2pad-left ;
|
||||||
: unempty ( seq -- seq ) dup empty? [ drop { 0 } ] when ;
|
: unempty ( seq -- seq ) dup empty? [ drop { 0 } ] when ;
|
||||||
: 2unempty ( seq seq -- seq seq ) [ unempty ] 2apply ;
|
: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
: p= ( p p -- ? ) pextend = ;
|
: p= ( p p -- ? ) pextend = ;
|
||||||
|
@ -24,7 +24,7 @@ PRIVATE>
|
||||||
: ptrim ( p -- p )
|
: ptrim ( p -- p )
|
||||||
dup singleton? [ [ zero? ] right-trim ] unless ;
|
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+ ;
|
||||||
: p- ( p p -- p ) pextend v- ;
|
: p- ( p p -- p ) pextend v- ;
|
||||||
: n*p ( n p -- n*p ) n*v ;
|
: n*p ( n p -- n*p ) n*v ;
|
||||||
|
@ -32,7 +32,7 @@ PRIVATE>
|
||||||
! convolution
|
! convolution
|
||||||
: pextend-conv ( p p -- p p )
|
: pextend-conv ( p p -- p p )
|
||||||
#! extend to: p_m + p_n - 1
|
#! 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 )
|
: p* ( p p -- p )
|
||||||
#! Multiply two polynomials.
|
#! Multiply two polynomials.
|
||||||
|
@ -46,13 +46,13 @@ PRIVATE>
|
||||||
|
|
||||||
: p/mod-setup ( p p -- p p n )
|
: p/mod-setup ( p p -- p p n )
|
||||||
2ptrim
|
2ptrim
|
||||||
2dup [ length ] 2apply -
|
2dup [ length ] bi@ -
|
||||||
dup 1 < [ drop 1 ] when
|
dup 1 < [ drop 1 ] when
|
||||||
[ over length + 0 pad-left pextend ] keep 1+ ;
|
[ over length + 0 pad-left pextend ] keep 1+ ;
|
||||||
|
|
||||||
: /-last ( seq seq -- a )
|
: /-last ( seq seq -- a )
|
||||||
#! divide the last two numbers in the sequences
|
#! divide the last two numbers in the sequences
|
||||||
[ peek ] 2apply / ;
|
[ peek ] bi@ / ;
|
||||||
|
|
||||||
: (p/mod)
|
: (p/mod)
|
||||||
2dup /-last
|
2dup /-last
|
||||||
|
@ -74,7 +74,7 @@ PRIVATE>
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: pgcd ( p p -- p q )
|
: 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' )
|
: pdiff ( p -- p' )
|
||||||
#! Polynomial derivative.
|
#! Polynomial derivative.
|
||||||
|
|
|
@ -14,7 +14,7 @@ IN: math.quaternions
|
||||||
|
|
||||||
: ** conjugate * ; inline
|
: ** 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
|
: q*a ( u v -- a ) 2q swapd ** >r * r> - ; inline
|
||||||
|
|
||||||
|
|
|
@ -7,7 +7,7 @@ USING: kernel kernel.private math math.functions math.private ;
|
||||||
dup numerator swap denominator ; inline
|
dup numerator swap denominator ; inline
|
||||||
|
|
||||||
: 2>fraction ( a/b c/d -- a c b d )
|
: 2>fraction ( a/b c/d -- a c b d )
|
||||||
[ >fraction ] 2apply swapd ; inline
|
[ >fraction ] bi@ swapd ; inline
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
@ -26,7 +26,7 @@ M: integer /
|
||||||
dup zero? [
|
dup zero? [
|
||||||
"Division by zero" throw
|
"Division by zero" throw
|
||||||
] [
|
] [
|
||||||
dup 0 < [ [ neg ] 2apply ] when
|
dup 0 < [ [ neg ] bi@ ] when
|
||||||
2dup gcd nip tuck /i >r /i r> fraction>
|
2dup gcd nip tuck /i >r /i r> fraction>
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
|
|
@ -46,13 +46,13 @@ IN: math.statistics
|
||||||
|
|
||||||
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
|
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
|
||||||
! finds sigma((xi-mean(x))(yi-mean(y))
|
! 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 )
|
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
|
||||||
* recip >r [ ((r)) ] keep length 1- / r> * ;
|
* recip >r [ ((r)) ] keep length 1- / r> * ;
|
||||||
|
|
||||||
: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
|
: [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 ( {{x,y}...} -- r )
|
||||||
[r] (r) ;
|
[r] (r) ;
|
||||||
|
|
|
@ -22,7 +22,7 @@ SYMBOL: visited
|
||||||
: random-neighbour ( cell -- newcell ) choices random ;
|
: random-neighbour ( cell -- newcell ) choices random ;
|
||||||
|
|
||||||
: vertex ( pair -- )
|
: vertex ( pair -- )
|
||||||
first2 [ 0.5 + line-width * ] 2apply glVertex2d ;
|
first2 [ 0.5 + line-width * ] bi@ glVertex2d ;
|
||||||
|
|
||||||
: (draw-maze) ( cell -- )
|
: (draw-maze) ( cell -- )
|
||||||
dup vertex
|
dup vertex
|
||||||
|
|
|
@ -23,9 +23,9 @@ TUPLE: not-a-decimal ;
|
||||||
: parse-decimal ( str -- ratio )
|
: parse-decimal ( str -- ratio )
|
||||||
"." split1
|
"." split1
|
||||||
>r dup "-" head? [ drop t "0" ] [ f swap ] if r>
|
>r dup "-" head? [ drop t "0" ] [ f swap ] if r>
|
||||||
[ dup empty? [ drop "0" ] when ] 2apply
|
[ dup empty? [ drop "0" ] when ] bi@
|
||||||
dup length
|
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 ;
|
10 swap ^ / + swap [ neg ] when ;
|
||||||
|
|
||||||
: DECIMAL:
|
: DECIMAL:
|
||||||
|
|
|
@ -113,7 +113,7 @@ TUPLE: no-method arguments generic ;
|
||||||
] curry assoc-map ;
|
] curry assoc-map ;
|
||||||
|
|
||||||
: sorted-methods ( alist -- alist' )
|
: sorted-methods ( alist -- alist' )
|
||||||
[ [ first ] 2apply classes< ] topological-sort ;
|
[ [ first ] bi@ classes< ] topological-sort ;
|
||||||
|
|
||||||
: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
|
: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
|
||||||
|
|
||||||
|
|
|
@ -38,7 +38,7 @@ M: demo-gadget pref-dim* ( gadget -- dim )
|
||||||
|
|
||||||
: demo-gadget-frustum ( -- -x x -y y near far )
|
: demo-gadget-frustum ( -- -x x -y y near far )
|
||||||
FOV-RATIO NEAR-PLANE FOV / v*n
|
FOV-RATIO NEAR-PLANE FOV / v*n
|
||||||
first2 [ -+ ] 2apply NEAR-PLANE FAR-PLANE ;
|
first2 [ -+ ] bi@ NEAR-PLANE FAR-PLANE ;
|
||||||
|
|
||||||
: demo-gadget-set-matrices ( gadget -- )
|
: demo-gadget-set-matrices ( gadget -- )
|
||||||
GL_PROJECTION glMatrixMode
|
GL_PROJECTION glMatrixMode
|
||||||
|
|
|
@ -8,9 +8,9 @@ math.parser opengl.gl opengl.glu combinators arrays sequences
|
||||||
splitting words byte-arrays assocs combinators.lib ;
|
splitting words byte-arrays assocs combinators.lib ;
|
||||||
IN: opengl
|
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
|
: gl-color ( color -- ) first4 glColor4d ; inline
|
||||||
|
|
||||||
|
@ -85,7 +85,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
||||||
|
|
||||||
: unit-circle dup [ sin ] map swap [ cos ] map ;
|
: 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 ;
|
: scale-points 2array flip [ v* ] with map [ v+ ] with map ;
|
||||||
|
|
||||||
|
|
|
@ -35,7 +35,7 @@ C: <parse-result> parse-result
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: string= ( str1 str2 ignore-case -- ? )
|
: string= ( str1 str2 ignore-case -- ? )
|
||||||
[ [ >upper ] 2apply ] when sequence= ;
|
[ [ >upper ] bi@ ] when sequence= ;
|
||||||
|
|
||||||
: string-head? ( str head ignore-case -- ? )
|
: string-head? ( str head ignore-case -- ? )
|
||||||
2over shorter? [
|
2over shorter? [
|
||||||
|
@ -327,7 +327,7 @@ LAZY: <(+)> ( parser -- parser )
|
||||||
nonempty-list-of { } succeed <|> ;
|
nonempty-list-of { } succeed <|> ;
|
||||||
|
|
||||||
LAZY: surrounded-by ( parser start end -- parser' )
|
LAZY: surrounded-by ( parser start end -- parser' )
|
||||||
[ token ] 2apply swapd pack ;
|
[ token ] bi@ swapd pack ;
|
||||||
|
|
||||||
: exactly-n ( parser n -- parser' )
|
: exactly-n ( parser n -- parser' )
|
||||||
swap <repetition> <and-parser> [ flatten ] <@ ;
|
swap <repetition> <and-parser> [ flatten ] <@ ;
|
||||||
|
|
|
@ -70,7 +70,7 @@ MEMO: pack ( begin body end -- parser )
|
||||||
>r >r hide r> r> hide 3seq [ first ] action ;
|
>r >r hide r> r> hide 3seq [ first ] action ;
|
||||||
|
|
||||||
: surrounded-by ( parser begin end -- parser' )
|
: surrounded-by ( parser begin end -- parser' )
|
||||||
[ token ] 2apply swapd pack ;
|
[ token ] bi@ swapd pack ;
|
||||||
|
|
||||||
: 'digit' ( -- parser )
|
: 'digit' ( -- parser )
|
||||||
[ digit? ] satisfy [ digit> ] action ;
|
[ digit? ] satisfy [ digit> ] action ;
|
||||||
|
|
|
@ -11,7 +11,7 @@ USE: prettyprint
|
||||||
TUPLE: parse-result remaining ast ;
|
TUPLE: parse-result remaining ast ;
|
||||||
|
|
||||||
TUPLE: parser id compiled ;
|
TUPLE: parser id compiled ;
|
||||||
M: parser equal? [ id>> ] 2apply = ;
|
M: parser equal? [ id>> ] bi@ = ;
|
||||||
C: <parser> parser
|
C: <parser> parser
|
||||||
|
|
||||||
SYMBOL: ignore
|
SYMBOL: ignore
|
||||||
|
|
|
@ -31,7 +31,7 @@ IN: project-euler.009
|
||||||
: abc ( p q -- triplet )
|
: abc ( p q -- triplet )
|
||||||
[
|
[
|
||||||
2dup * , ! a = p * q
|
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
|
+ 2 / , ! c = (p² + q²) / 2
|
||||||
] { } make natural-sort ;
|
] { } make natural-sort ;
|
||||||
|
|
||||||
|
|
|
@ -39,7 +39,7 @@ IN: project-euler.014
|
||||||
dup even? [ 2 / ] [ 3 * 1+ ] if ;
|
dup even? [ 2 / ] [ 3 * 1+ ] if ;
|
||||||
|
|
||||||
: longest ( seq seq -- seq )
|
: longest ( seq seq -- seq )
|
||||||
2dup [ length ] 2apply > [ drop ] [ nip ] if ;
|
2dup [ length ] bi@ > [ drop ] [ nip ] if ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -58,7 +58,7 @@ PRIVATE>
|
||||||
|
|
||||||
: max-period ( seq -- elt n )
|
: max-period ( seq -- elt n )
|
||||||
dup [ period-length ] map dup supremum
|
dup [ period-length ] map dup supremum
|
||||||
over index [ swap nth ] curry 2apply ;
|
over index [ swap nth ] curry bi@ ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -60,7 +60,7 @@ IN: project-euler.027
|
||||||
|
|
||||||
: max-consecutive ( seq -- elt n )
|
: max-consecutive ( seq -- elt n )
|
||||||
dup [ first2 consecutive-primes ] map dup supremum
|
dup [ first2 consecutive-primes ] map dup supremum
|
||||||
over index [ swap nth ] curry 2apply ;
|
over index [ swap nth ] curry bi@ ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -33,10 +33,10 @@ IN: project-euler.033
|
||||||
10 99 [a,b] dup cartesian-product [ first2 < ] subset ;
|
10 99 [a,b] dup cartesian-product [ first2 < ] subset ;
|
||||||
|
|
||||||
: safe? ( ax xb -- ? )
|
: 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 )
|
: 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 -- ? )
|
: curious? ( m n -- ? )
|
||||||
2dup / [ ax/xb ] dip = ;
|
2dup / [ ax/xb ] dip = ;
|
||||||
|
|
|
@ -31,7 +31,7 @@ IN: project-euler.044
|
||||||
dup 3 * 1- * 2 / ;
|
dup 3 * 1- * 2 / ;
|
||||||
|
|
||||||
: sum-and-diff? ( m n -- ? )
|
: sum-and-diff? ( m n -- ? )
|
||||||
2dup + -rot - [ pentagonal? ] 2apply and ;
|
2dup + -rot - [ pentagonal? ] bi@ and ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -35,7 +35,7 @@ IN: project-euler.079
|
||||||
] { } make ;
|
] { } make ;
|
||||||
|
|
||||||
: find-source ( seq -- elt )
|
: 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 ;
|
dup empty? [ "Topological sort failed" throw ] [ first ] if ;
|
||||||
|
|
||||||
: remove-source ( seq elt -- seq )
|
: remove-source ( seq elt -- seq )
|
||||||
|
|
|
@ -54,7 +54,7 @@ IN: random-tester
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: random-ratio ( -- ratio )
|
: 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 )
|
: random-float ( -- float )
|
||||||
50% [ random-ratio ] [ special-floats get random ] if
|
50% [ random-ratio ] [ special-floats get random ] if
|
||||||
|
|
|
@ -16,7 +16,7 @@ SYMBOL: ignore-case?
|
||||||
|
|
||||||
: char-between?-quot ( ch1 ch2 -- quot )
|
: char-between?-quot ( ch1 ch2 -- quot )
|
||||||
ignore-case? get
|
ignore-case? get
|
||||||
[ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ]
|
[ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ]
|
||||||
[ [ between? ] ]
|
[ [ between? ] ]
|
||||||
if 2curry ;
|
if 2curry ;
|
||||||
|
|
||||||
|
|
|
@ -16,7 +16,7 @@ SYMBOL: ignore-case?
|
||||||
|
|
||||||
: char-between?-quot ( ch1 ch2 -- quot )
|
: char-between?-quot ( ch1 ch2 -- quot )
|
||||||
ignore-case? get
|
ignore-case? get
|
||||||
[ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ]
|
[ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ]
|
||||||
[ [ between? ] ]
|
[ [ between? ] ]
|
||||||
if 2curry ;
|
if 2curry ;
|
||||||
|
|
||||||
|
|
|
@ -9,7 +9,7 @@ IN: reports.noise
|
||||||
{ -nrot 5 }
|
{ -nrot 5 }
|
||||||
{ -roll 4 }
|
{ -roll 4 }
|
||||||
{ -rot 3 }
|
{ -rot 3 }
|
||||||
{ 2apply 1 }
|
{ bi@ 1 }
|
||||||
{ 2curry 1 }
|
{ 2curry 1 }
|
||||||
{ 2drop 1 }
|
{ 2drop 1 }
|
||||||
{ 2dup 1 }
|
{ 2dup 1 }
|
||||||
|
|
|
@ -23,7 +23,7 @@ TUPLE: roman-range-error n ;
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: roman<= ( ch1 ch2 -- ? )
|
: roman<= ( ch1 ch2 -- ? )
|
||||||
[ 1string roman-digits index ] 2apply >= ;
|
[ 1string roman-digits index ] bi@ >= ;
|
||||||
|
|
||||||
: roman>n ( ch -- n )
|
: roman>n ( ch -- n )
|
||||||
1string roman-digits index roman-values nth ;
|
1string roman-digits index roman-values nth ;
|
||||||
|
@ -57,7 +57,7 @@ PRIVATE>
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: 2roman> ( str1 str2 -- m n )
|
: 2roman> ( str1 str2 -- m n )
|
||||||
[ roman> ] 2apply ;
|
[ roman> ] bi@ ;
|
||||||
|
|
||||||
: binary-roman-op ( str1 str2 quot -- str3 )
|
: binary-roman-op ( str1 str2 quot -- str3 )
|
||||||
>r 2roman> r> call >roman ; inline
|
>r 2roman> r> call >roman ; inline
|
||||||
|
|
|
@ -60,7 +60,7 @@ test-db [
|
||||||
"charlie" create-node* "charlie" set
|
"charlie" create-node* "charlie" set
|
||||||
"gertrude" create-node* "gertrude" set
|
"gertrude" create-node* "gertrude" set
|
||||||
[ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test
|
[ 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
|
[ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test
|
||||||
[ { "adam" "eve" } ] [ "bob" get parents [ 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
|
[ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test
|
||||||
|
|
|
@ -24,7 +24,7 @@ C: <id> id
|
||||||
|
|
||||||
M: id hashcode* obj>> hashcode* ;
|
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-object ( obj -- )
|
||||||
#! Add an object to the sequence of already serialized
|
#! Add an object to the sequence of already serialized
|
||||||
|
|
|
@ -20,7 +20,7 @@ IN: shufflers
|
||||||
|
|
||||||
: put-effect ( word -- )
|
: put-effect ( word -- )
|
||||||
dup word-name "-" split1
|
dup word-name "-" split1
|
||||||
[ >array [ 1string ] map ] 2apply
|
[ >array [ 1string ] map ] bi@
|
||||||
<effect> "declared-effect" set-word-prop ;
|
<effect> "declared-effect" set-word-prop ;
|
||||||
|
|
||||||
: in-shuffle ( -- ) in get ".shuffle" append set-in ;
|
: in-shuffle ( -- ) in get ".shuffle" append set-in ;
|
||||||
|
|
|
@ -18,7 +18,7 @@ SYMBOL: board
|
||||||
: cell-contains? ( n x y i -- ? ) 3 /mod pair+ board> = ;
|
: cell-contains? ( n x y i -- ? ) 3 /mod pair+ board> = ;
|
||||||
|
|
||||||
: box-contains? ( n x y -- ? )
|
: box-contains? ( n x y -- ? )
|
||||||
[ 3 /i 3 * ] 2apply
|
[ 3 /i 3 * ] bi@
|
||||||
9 [ >r 3dup r> cell-contains? ] contains?
|
9 [ >r 3dup r> cell-contains? ] contains?
|
||||||
>r 3drop r> ;
|
>r 3drop r> ;
|
||||||
|
|
||||||
|
|
|
@ -35,7 +35,7 @@ linkname magic version uname gname devmajor devminor prefix ;
|
||||||
|
|
||||||
: header-checksum ( seq -- x )
|
: header-checksum ( seq -- x )
|
||||||
148 cut-slice 8 tail-slice
|
148 cut-slice 8 tail-slice
|
||||||
[ sum ] 2apply + 256 + ;
|
[ sum ] bi@ + 256 + ;
|
||||||
|
|
||||||
TUPLE: checksum-error ;
|
TUPLE: checksum-error ;
|
||||||
TUPLE: malformed-block-error ;
|
TUPLE: malformed-block-error ;
|
||||||
|
|
|
@ -40,7 +40,7 @@ unicode.categories ;
|
||||||
|
|
||||||
: score ( full fuzzy -- n )
|
: score ( full fuzzy -- n )
|
||||||
dup [
|
dup [
|
||||||
[ [ length ] 2apply - 15 swap [-] 3 /f ] 2keep
|
[ [ length ] bi@ - 15 swap [-] 3 /f ] 2keep
|
||||||
runs [
|
runs [
|
||||||
[ 0 [ pick score-1 max ] reduce nip ] keep
|
[ 0 [ pick score-1 max ] reduce nip ] keep
|
||||||
length * +
|
length * +
|
||||||
|
@ -57,7 +57,7 @@ unicode.categories ;
|
||||||
|
|
||||||
: complete ( full short -- score )
|
: complete ( full short -- score )
|
||||||
[ dupd fuzzy score ] 2keep
|
[ dupd fuzzy score ] 2keep
|
||||||
[ <reversed> ] 2apply
|
[ <reversed> ] bi@
|
||||||
dupd fuzzy score max ;
|
dupd fuzzy score max ;
|
||||||
|
|
||||||
: completion ( short candidate -- result )
|
: completion ( short candidate -- result )
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue