[ 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 )
[ [ ^^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 ]
[ 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
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 ;
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 ;
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
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> ;
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) ;
client-out addrspec secure-connection
socket FIONBIO 0 set-ioctl-socket ;
-M: windows non-ssl-socket? win32-socket? ;
\ No newline at end of file
+M: windows non-ssl-socket? win32-socket? ;
GENERIC: establish-connection ( client-out remote -- )
-GENERIC: ((client)) ( remote -- handle )
+GENERIC: remote>handle ( remote -- handle )
GENERIC: (client) ( remote -- client-in client-out local )
M: object (client) ( remote -- client-in client-out local )
[
- [ ((client)) ] keep
+ [ remote>handle ] keep
[
[ <ports> [ |dispose ] bi@ dup ] dip
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 ;
: 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
<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!
: (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
: 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
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>
: (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>> ;
: ?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 )
: 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) ;
<PRIVATE
-:: ((monotonic-split)) ( seq quot slice-quot n -- pieces )
+:: monotonic-split-impl ( seq quot slice-quot n -- pieces )
V{ 0 } clone :> accum
0 seq [ ] [
] { } 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>
[ 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 ;
[ [ 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 ]
: 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 ;
[ initial-selection-index ]
} 1||
] keep
- over [ ((select-row)) ] [
+ over [ select-table-row ] [
[ selection-index>> set-model ]
[ selection>> set-model ]
2bi
: (select-row) ( table n -- )
[ scroll-to-row ]
- [ swap ((select-row)) ]
+ [ swap select-table-row ]
[ drop relayout-1 ]
2tri ;
[ 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 ;
: 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)
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
<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
<PRIVATE
: (2each-index) ( seq1 seq2 quot -- n quot' )
- [ ((2each)) [ keep ] curry ] dip compose ; inline
+ [ setup-2each [ keep ] curry ] dip compose ; inline
PRIVATE>
[ 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
: (which) ( command path -- file/f )
split-path os windows? [
[ path-extensions ] [ "." prefix ] bi*
- ] [ [ 1array ] dip ] if ((which)) ;
+ ] [ [ 1array ] dip ] if find-which ;
PRIVATE>