factor: remove rest of double paren words.
parent
20aadd5688
commit
d3bc2035a2
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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> ;
|
||||
|
||||
|
|
|
@ -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) ;
|
||||
|
@ -72,4 +72,4 @@ M:: secure establish-connection ( client-out addrspec -- )
|
|||
client-out addrspec secure-connection
|
||||
socket FIONBIO 0 set-ioctl-socket ;
|
||||
|
||||
M: windows non-ssl-socket? win32-socket? ;
|
||||
M: windows non-ssl-socket? win32-socket? ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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>> ;
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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) ;
|
||||
|
|
|
@ -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>
|
||||
|
||||
|
|
|
@ -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 ]
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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>
|
||||
|
||||
|
|
|
@ -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>
|
||||
|
||||
|
|
Loading…
Reference in New Issue