: sqlite-row ( handle -- seq )
dup sqlite-#columns [ sqlite-column ] with map ;
-: sqlite-step-has-more-rows? ( prepared -- bool )
+: sqlite-step-has-more-rows? ( prepared -- ? )
{
{ SQLITE_ROW [ t ] }
{ SQLITE_DONE [ f ] }
Daniel Ehrenberg
+Doug Coleman
[ "foo" ] [ "foo" [ string? ] deep-find ] unit-test
[ { { 1 2 } 1 2 } ] [ [ { 1 2 } [ , ] deep-each ] { } make ] unit-test
+
+[ t ]
+[ { { 1 2 3 } 4 } { { { 1 { { 1 2 3 } 4 } } } 2 } deep-member? ] unit-test
+
+[ t ]
+[ { { 1 2 3 } 4 } { { { 1 2 3 } 4 } 2 } deep-member? ] unit-test
+
+[ f ]
+[ { 1 2 3 4 } { 1 2 3 { 4 } } deep-subseq? ] unit-test
+
+[ t ]
+[ { 1 2 3 4 } { 1 2 3 4 } deep-subseq? ] unit-test
+
+[ t ]
+[ { 1 2 3 4 } { { 1 2 3 4 } } deep-subseq? ] unit-test
-! Copyright (C) 2007 Daniel Ehrenberg
+! Copyright (C) 2007, 2008 Daniel Ehrenberg, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel strings math ;
+USING: sequences kernel strings math fry ;
IN: sequences.deep
! All traversal goes in postorder
: deep-all? ( obj quot -- ? )
[ not ] compose deep-contains? not ; inline
+: deep-member? ( obj seq -- ? )
+ swap '[
+ _ swap dup branch? [ member? ] [ 2drop f ] if
+ ] deep-find >boolean ;
+
+: deep-subseq? ( subseq seq -- ? )
+ swap '[
+ _ swap dup branch? [ subseq? ] [ 2drop f ] if
+ ] deep-find >boolean ;
+
: deep-change-each ( obj quot: ( elt -- elt' ) -- )
over branch? [
[ [ call ] keep over [ deep-change-each ] dip ] curry change-each
LOG: smtp-response DEBUG
-: multiline? ( response -- boolean )
+: multiline? ( response -- ? )
3 swap ?nth CHAR: - = ;
: (receive-response) ( -- )
{ 27 "ESC" }
} ;
-: exclude-key-wm-keydown? ( n -- bool )
+: exclude-key-wm-keydown? ( n -- ? )
exclude-keys-wm-keydown key? ;
-: exclude-key-wm-char? ( n -- bool )
+: exclude-key-wm-char? ( n -- ? )
exclude-keys-wm-char key? ;
: keystroke>gesture ( n -- mods sym )
: (make-callbacks) ( implementations -- sequence )
dup [ first ] map (make-iunknown-methods)
- [ >r >r first2 r> r> swap (make-interface-callbacks) ]
+ [ [ first2 ] 2dip swap (make-interface-callbacks) ]
curry map-index ;
: (malloc-wrapped-object) ( wrapper -- wrapped-object )
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types kernel math windows windows.kernel32
-namespaces calendar ;
+namespaces calendar math.bitwise ;
IN: windows.time
: >64bit ( lo hi -- n )
: windows-time>FILETIME ( n -- FILETIME )
"FILETIME" <c-object>
[
- [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep
- >r -32 shift r> set-FILETIME-dwHighDateTime
+ [ 32 bits set-FILETIME-dwLowDateTime ] 2keep
+ [ -32 shift ] dip set-FILETIME-dwHighDateTime
] keep ;
: timestamp>FILETIME ( timestamp -- FILETIME/f )
: balance>> ( account -- balance ) transactions>> total ;
: open-account ( name interest-rate interest-payment-day opening-date opening-balance -- account )
- >r [ <account> ] keep r> "Account Opened" <transaction> >>transaction ;
+ [ [ <account> ] keep ] dip "Account Opened" <transaction> >>transaction ;
: daily-rate ( yearly-rate day -- daily-rate )
days-in-year / ;
: each-day ( quot start end -- )
2dup before? [
- >r dup >r over >r swap call r> r> 1 days time+ r> each-day
+ [ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
] [
3drop
] if ;
initialize-sha1 process-sha1-block
stream>sha1 get-sha1
initialize-sha1
- >r process-sha1-block r>
- process-sha1-block get-sha1 ;
+ [ process-sha1-block ]
+ [ process-sha1-block ] bi* get-sha1 ;
: md5-hmac ( Ko Ki -- hmac )
initialize-md5 process-md5-block
stream>md5 get-md5
initialize-md5
- >r process-md5-block r>
- process-md5-block get-md5 ;
+ [ process-md5-block ]
+ [ process-md5-block ] bi* get-md5 ;
: seq-bitxor ( seq seq -- seq )
[ bitxor ] 2map ;
: find-forms ( vector -- vector' )
"form" over find-opening-tags-by-name
- swap [ >r first2 r> find-between* ] curry map
+ swap [ [ first2 ] dip find-between* ] curry map
[ [ name>> { "form" "input" } member? ] filter ] map ;
: find-html-objects ( vector string -- vector' )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: save-namestack ( quot -- ) namestack >r call r> set-namestack ;
+: save-namestack ( quot -- ) namestack slip set-namestack ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (>roman) ( n -- )
roman-values roman-digits [
- >r /mod swap r> <repetition> concat %
+ [ /mod swap ] dip <repetition> concat %
] 2each drop ;
: (roman>) ( seq -- n )
[ roman> ] bi@ ;
: binary-roman-op ( str1 str2 quot -- str3 )
- >r 2roman> r> call >roman ; inline
+ [ 2roman> ] dip call >roman ; inline
PRIVATE>
[ /i ] binary-roman-op ;
: roman/mod ( str1 str2 -- str3 str4 )
- [ /mod ] binary-roman-op >r >roman r> ;
+ [ /mod ] binary-roman-op [ >roman ] dip ;
: ROMAN: scan roman> parsed ; parsing
+++ /dev/null
-USING: arrays assocs kernel vectors sequences namespaces
- random math.parser math fry ;
-
-IN: assocs.lib
-
-: set-assoc-stack ( value key seq -- )
- dupd [ key? ] with find-last nip set-at ;
-
-: at-default ( key assoc -- value/key )
- dupd at [ nip ] when* ;
-
-: replace-at ( assoc value key -- assoc )
- >r >r dup r> 1vector r> rot set-at ;
-
-: peek-at* ( assoc key -- obj ? )
- swap at* dup [ >r peek r> ] when ;
-
-: peek-at ( assoc key -- obj )
- peek-at* drop ;
-
-: >multi-assoc ( assoc -- new-assoc )
- [ 1vector ] assoc-map ;
-
-: multi-assoc-each ( assoc quot -- )
- [ with each ] curry assoc-each ; inline
-
-: insert ( value variable -- ) namespace push-at ;
-
-: generate-key ( assoc -- str )
- >r 32 random-bits >hex r>
- 2dup key? [ nip generate-key ] [ drop ] if ;
-
-: set-at-unique ( value assoc -- key )
- dup generate-key [ swap set-at ] keep ;
-
-: histogram ( assoc quot -- assoc' )
- H{ } clone [
- swap [ change-at ] 2curry assoc-each
- ] keep ; inline
-
-: inc-at ( key assoc -- )
- [ 0 or 1 + ] change-at ;
-
-: ?at ( obj assoc -- value/obj ? )
- dupd at* [ [ nip ] [ drop ] if ] keep ;
-
-: if-at ( obj assoc quot1 quot2 -- )
- [ ?at ] 2dip if ; inline
-
-: when-at ( obj assoc quot -- ) [ ] if-at ; inline
-
-: unless-at ( obj assoc quot -- ) [ ] swap if-at ; inline
! quot is ( state string -- output-string )
[ missing-state ] <array> dup
[
- [ >r dup [ data>> ] [ place>> ] bi r> ] %
+ [ [ dup [ data>> ] [ place>> ] bi ] dip ] %
[ swapd bounds-check dispatch ] curry ,
[ each pick (>>place) swap (>>date) ] %
] [ ] make [ over make ] curry ;
: define-machine ( word state-class -- )
execute make-machine
- >r over r> define
+ [ over ] dip define
"state-table" set-word-prop ;
: MACHINE:
] if ;
: net ( salary w4 collector -- x )
- >r dupd r> total-withholding - ;
+ [ dupd ] dip total-withholding - ;
: d= ( d d -- ? ) comparison-op number= ;
-: d~ ( d d delta -- ? ) >r comparison-op r> ~ ;
+: d~ ( d d delta -- ? ) [ comparison-op ] dip ~ ;
: d-min ( d d -- d ) [ d< ] most ;