factor: remove rest of double paren words.

locals-and-roots
Doug Coleman 2016-03-25 03:10:47 -07:00
parent 20aadd5688
commit d3bc2035a2
20 changed files with 53 additions and 55 deletions

View File

@ -146,7 +146,7 @@ MACRO: smart-map-reduce ( map-reduce-quots -- quot )
[ keys ] [ [ [ ] concat-as ] [ ] map-as ] bi dup length dup '[
[ first _ cleave ] keep
[ @ _ cleave-curry _ spread* ]
[ 1 ] 2dip (each) (each-integer)
[ 1 ] 2dip setup-each (each-integer)
] ;
MACRO: smart-2reduce ( 2reduce-quots -- quot )

View File

@ -93,7 +93,7 @@ CONSTANT: rep>half {
[ [ ^^fill-vector ] [ ^^xor-vector ] bi ]
} v-vector-op ;
:: ^((compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
:: ^swap-compare-vector ( src1 src2 rep {cc,swap} -- dst )
{cc,swap} first2 :> ( cc swap? )
swap?
[ src2 src1 rep cc ^^compare-vector ]
@ -106,10 +106,10 @@ CONSTANT: rep>half {
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
[
ccs unclip :> ( rest-ccs first-cc )
src1 src2 rep first-cc ^((compare-vector)) :> first-dst
src1 src2 rep first-cc ^swap-compare-vector :> first-dst
rest-ccs first-dst
[ [ src1 src2 rep ] dip ^((compare-vector)) rep ^^or-vector ]
[ [ src1 src2 rep ] dip ^swap-compare-vector rep ^^or-vector ]
reduce
not? [ rep ^not-vector ] when

View File

@ -107,7 +107,7 @@ TUPLE: couchdb-auth-provider
over [ change-at ] dip ; inline
! Should be given a view URL.
: ((get-user)) ( couchdb-url -- user/f )
: url>user ( couchdb-url -- user/f )
couch-get
"rows" of dup empty? [ drop f ] [ first "value" of ] if ;
@ -115,7 +115,7 @@ TUPLE: couchdb-auth-provider
couchdb-auth-provider get
username-view>> get-url
swap >json "key" set-query-param
((get-user)) ;
url>user ;
: strip-hash ( hash1 -- hash2 )
[ drop first CHAR: _ = ] assoc-reject ;

View File

@ -76,7 +76,7 @@ PRIVATE>
2 = [
[ first2-unsafe ] dip call
] [
[ [ first-unsafe 1 ] [ ((each)) ] bi ] dip
[ [ first-unsafe 1 ] [ (setup-each) ] bi ] dip
'[ @ _ keep swap ] (all-integers?) nip
] if
] if ; inline

View File

@ -14,8 +14,8 @@ M: ssl-handle handle-fd file>> handle-fd ;
M: unix socket-handle fd>> ;
M: secure ((client)) ( secure -- handle )
[ addrspec>> ((client)) ] [ hostname>> ] bi <ssl-socket> ;
M: secure remote>handle ( secure -- handle )
[ addrspec>> remote>handle ] [ hostname>> ] bi <ssl-socket> ;
M: secure parse-sockaddr addrspec>> parse-sockaddr f <secure> ;

View File

@ -57,8 +57,8 @@ M: openssl ssl-certificate-verification-supported? f ;
M: windows socket-handle handle>> alien-address ;
M: secure ((client)) ( addrspec -- handle )
[ addrspec>> ((client)) ] [ hostname>> ] bi <ssl-socket> ;
M: secure remote>handle ( addrspec -- handle )
[ addrspec>> remote>handle ] [ hostname>> ] bi <ssl-socket> ;
M: secure (get-local-address) ( handle remote -- sockaddr )
[ file>> ] [ addrspec>> ] bi* (get-local-address) ;

View File

@ -241,7 +241,7 @@ SYMBOL: bind-local-address
GENERIC: establish-connection ( client-out remote -- )
GENERIC: ((client)) ( remote -- handle )
GENERIC: remote>handle ( remote -- handle )
GENERIC: (client) ( remote -- client-in client-out local )
@ -249,7 +249,7 @@ M: array (client) [ (client) 3array ] attempt-all first3 ;
M: object (client) ( remote -- client-in client-out local )
[
[ ((client)) ] keep
[ remote>handle ] keep
[
[ <ports> [ |dispose ] bi@ dup ] dip
establish-connection

View File

@ -74,7 +74,7 @@ M: object establish-connection
drop
] if* ; inline
M: object ((client))
M: object remote>handle
[ protocol-family SOCK_STREAM ] [ protocol ] bi socket-fd
[ init-client-socket ] [ ?bind-client ] [ ] tri ;

View File

@ -67,7 +67,7 @@ M: object (get-remote-address) ( socket addrspec -- sockaddr )
: bind-socket ( win32-socket sockaddr len -- )
[ handle>> ] 2dip bind socket-error ;
M: object ((client)) ( addrspec -- handle )
M: object remote>handle ( addrspec -- handle )
[ SOCK_STREAM open-socket ] keep
[
bind-local-address get

View File

@ -60,7 +60,7 @@ PRIVATE>
<PRIVATE
:: ((kth-object)) ( seq k nth-quot exchange-quot quot: ( x y -- ? ) -- elt )
:: kth-object-impl ( seq k nth-quot exchange-quot quot: ( x y -- ? ) -- elt )
! Wirth's method, Algorithm's + Data structues = Programs p. 84
k seq bounds-check 2drop
0 :> i!
@ -91,7 +91,7 @@ PRIVATE>
: (kth-object) ( seq k nth-quot exchange-quot quot: ( x y -- ? ) -- elt )
! The algorithm modifiers seq, so we clone it
[ >array ] 4dip ((kth-object)) ; inline
[ >array ] 4dip kth-object-impl ; inline
: kth-object-unsafe ( seq k quot: ( x y -- ? ) -- elt )
[ [ nth-unsafe ] [ exchange-unsafe ] ] dip (kth-object) ; inline
@ -302,24 +302,22 @@ ALIAS: std sample-std
: sample-ste ( seq -- x ) 1 ste-ddof ;
: ((r)) ( x-mean y-mean x-seq y-seq -- (r) )
<PRIVATE
: r-sum-diffs ( x-mean y-mean x-seq y-seq -- (r) )
! finds sigma((xi-mean(x))(yi-mean(y))
0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
: (r) ( x-mean y-mean x-seq y-seq x-std y-std -- r )
* recip [ [ ((r)) ] keep length 1 - / ] dip * ;
* recip [ [ r-sum-diffs ] keep length 1 - / ] dip * ;
: [r] ( xy-pairs -- x-mean y-mean x-seq y-seq x-std y-std )
: r-stats ( xy-pairs -- x-mean y-mean x-seq y-seq x-std y-std )
first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ population-std ] bi@ ;
PRIVATE>
: r ( xy-pairs -- r )
[r] (r) ;
: r^2 ( xy-pairs -- r )
r sq ;
: pearson-r ( xy-pairs -- r ) r-stats (r) ;
: least-squares ( xy-pairs -- alpha beta )
[r] { [ 2dup ] [ ] [ ] [ ] [ ] } spread
r-stats [ 2dup ] 4 ndip
! stack is x-mean y-mean x-mean y-mean x-seq y-seq x-std y-std
[ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy
swap / * ! stack is mean(x) mean(y) beta

View File

@ -136,7 +136,7 @@ GENERIC: native/ ( x y -- x/y )
M: integer native/ /i ; inline
M: float native/ /f ; inline
: ((vgetmask)) ( a rep -- b )
: (vgetmask) ( a rep -- b )
0 [ [ 1 shift ] [ zero? 0 1 ? ] bi* bitor ] bitwise-components-reduce* ; inline
PRIVATE>
@ -245,7 +245,7 @@ PRIVATE>
: (simd-vnone?) ( a rep -- ? ) [ bitor ] bitwise-components-reduce zero? ;
: (simd-vgetmask) ( a rep -- n )
{ float-4-rep double-2-rep } member?
[ uint-4-rep ((vgetmask)) ] [ uchar-16-rep ((vgetmask)) ] if ;
[ uint-4-rep (vgetmask) ] [ uchar-16-rep (vgetmask) ] if ;
: (simd-v>float) ( a rep -- c )
[ [ byte>rep-array ] [ rep-length ] bi [ >float ] ]
[ >float-vector-rep <rep-array> ] bi unrolled-map-as-unsafe underlying>> ;

View File

@ -90,14 +90,14 @@ M: model update-model drop ;
: ?set-model ( value model -- )
2dup value>> = [ 2drop ] [ set-model ] if ;
: ((change-model)) ( model quot -- newvalue model )
: call-change-model ( model quot -- newvalue model )
over [ [ value>> ] dip call ] dip ; inline
: change-model ( ..a model quot: ( ..a obj -- ..b newobj ) -- ..b )
((change-model)) set-model ; inline
call-change-model set-model ; inline
: (change-model) ( ..a model quot: ( ..a obj -- ..b newobj ) -- ..b )
((change-model)) value<< ; inline
call-change-model value<< ; inline
GENERIC: range-value ( model -- value )
GENERIC: range-page-value ( model -- value )

View File

@ -71,14 +71,14 @@ PRIVATE>
: next-power-of-2-bits ( m -- numbits )
dup 2 <= [ drop 1 ] [ 1 - log2 1 + ] if ; inline
:: ((random-integer)) ( m obj -- n )
:: random-integer-loop ( m obj -- n )
obj random-32* 32 m next-power-of-2-bits 32 - [ dup 0 > ] [
[ 32 shift obj random-32* + ] [ 32 + ] [ 32 - ] tri*
] while drop [ m * ] [ neg shift ] bi* ; inline
GENERIC# (random-integer) 1 ( m obj -- n )
M: fixnum (random-integer) ( m obj -- n ) ((random-integer)) ;
M: bignum (random-integer) ( m obj -- n ) ((random-integer)) ;
M: fixnum (random-integer) ( m obj -- n ) random-integer-loop ;
M: bignum (random-integer) ( m obj -- n ) random-integer-loop ;
: random-integer ( m -- n )
random-generator get (random-integer) ;

View File

@ -6,7 +6,7 @@ IN: splitting.monotonic
<PRIVATE
:: ((monotonic-split)) ( seq quot slice-quot n -- pieces )
:: monotonic-split-impl ( seq quot slice-quot n -- pieces )
V{ 0 } clone :> accum
0 seq [ ] [
@ -22,7 +22,7 @@ IN: splitting.monotonic
] { } 2map-as ; inline
: (monotonic-split) ( seq quot slice-quot -- pieces )
pick length [ 3drop { } ] [ ((monotonic-split)) ] if-zero ; inline
pick length [ 3drop { } ] [ monotonic-split-impl ] if-zero ; inline
PRIVATE>

View File

@ -13,7 +13,7 @@ IN: stack-checker.transforms
[ error-continuation get current-word get transform-expansion-error ]
recover ;
:: ((apply-transform)) ( quot values stack rstate -- )
:: apply-literal-values-transform ( quot values stack rstate -- )
rstate recursive-state [ stack quot call-transformer ] with-variable
values [ length shorten-d ] [ #drop, ] bi
rstate infer-quot ;
@ -31,7 +31,7 @@ IN: stack-checker.transforms
[ [ literal value>> ] map ]
[ first literal recursion>> ] tri
] if
((apply-transform))
apply-literal-values-transform
] }
{ [ dup input-values? ] [ drop current-word get unknown-macro-input ] }
[ drop current-word get bad-macro-input ]

View File

@ -247,7 +247,7 @@ PRIVATE>
: hide-mouse-help ( table -- )
f >>mouse-index [ update-status ] [ relayout-1 ] bi ;
: ((select-row)) ( n table -- )
: select-table-row ( n table -- )
[ selection-index>> set-model ]
[ [ selected-row drop ] keep selection>> set-model ]
bi ;
@ -282,7 +282,7 @@ PRIVATE>
[ initial-selection-index ]
} 1||
] keep
over [ ((select-row)) ] [
over [ select-table-row ] [
[ selection-index>> set-model ]
[ selection>> set-model ]
2bi
@ -303,7 +303,7 @@ M: table model-changed
: (select-row) ( table n -- )
[ scroll-to-row ]
[ swap ((select-row)) ]
[ swap select-table-row ]
[ drop relayout-1 ]
2tri ;

View File

@ -46,13 +46,13 @@ ERROR: vocab-root-required root ;
[ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map! ]
2tri ;
: ((disk-vocabs-recursive)) ( root prefix -- )
: disk-vocabs-recursive% ( root prefix -- )
dupd vocab-name (disk-vocab-children) [ % ] keep
[ ((disk-vocabs-recursive)) ] with each ;
[ disk-vocabs-recursive% ] with each ;
: (disk-vocabs-recursive) ( root prefix -- seq )
[ ensure-vocab-root ] dip
[ ((disk-vocabs-recursive)) ] { } make ;
[ disk-vocabs-recursive% ] { } make ;
: no-rooted ( seq -- seq' ) [ find-vocab-root ] reject ;

View File

@ -103,9 +103,9 @@ SYMBOL: boundaries
: d= ( value basis -- )
boundaries [ ?set-at ] change ;
: ((d)) ( basis -- value ) boundaries get at ;
: get-boundary ( basis -- value ) boundaries get at ;
: dx.y ( x y -- vec ) [ ((d)) ] dip wedge ;
: dx.y ( x y -- vec ) [ get-boundary ] dip wedge ;
DEFER: (d)

View File

@ -189,7 +189,7 @@ PRIVATE>
over empty? [ 2drop { } ] [
[ [ first ] dip call ] 2keep rot dup [
>resizable [ [ push-all ] curry compose ] keep
[ 1 ] 3dip [ (each) (each-integer) ] dip
[ 1 ] 3dip [ setup-each (each-integer) ] dip
] curry dip like
] if ; inline
@ -208,16 +208,16 @@ PRIVATE>
<PRIVATE
: ((each-from)) ( i seq -- n quot )
: (each-from) ( i seq -- n quot )
[ length over [-] swap ] keep '[ _ + _ nth-unsafe ] ; inline
: (each-from) ( i seq quot -- n quot' )
[ ((each-from)) ] dip compose ; inline
: each-from ( i seq quot -- n quot' )
[ (each-from) ] dip compose ; inline
PRIVATE>
: map-from-as ( ... seq quot: ( ... elt -- ... newelt ) i exemplar -- ... newseq )
[ -rot (each-from) ] dip map-integers ; inline
[ -rot each-from ] dip map-integers ; inline
: map-from ( ... seq quot: ( ... elt -- ... newelt ) i -- ... newseq )
pick map-from-as ; inline
@ -319,7 +319,7 @@ PRIVATE>
<PRIVATE
: (2each-index) ( seq1 seq2 quot -- n quot' )
[ ((2each)) [ keep ] curry ] dip compose ; inline
[ setup-2each [ keep ] curry ] dip compose ; inline
PRIVATE>

View File

@ -25,7 +25,7 @@ IN: tools.which
[ drop 1array ] [ [ append ] with map ] if
] [ 1array ] if* ;
: ((which)) ( commands paths -- file/f )
: find-which ( commands paths -- file/f )
[ normalize-path ] map members
cartesian-product flip concat
[ prepend-path ] { } assoc>map
@ -34,7 +34,7 @@ IN: tools.which
: (which) ( command path -- file/f )
split-path os windows? [
[ path-extensions ] [ "." prefix ] bi*
] [ [ 1array ] dip ] if ((which)) ;
] [ [ 1array ] dip ] if find-which ;
PRIVATE>