+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: kernel tools.test sequences vectors assocs.lib ;
-IN: assocs.lib.tests
-
-{ 1 1 } [ [ ?push ] histogram ] must-infer-as
-
-! substitute
-[ { 2 } ] [ { 1 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test
-[ { 3 } ] [ { 3 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test
-
-[ 2 ] [ 1 H{ { 1 2 } } [ ] [ ] if-at ] unit-test
-[ 3 ] [ 3 H{ { 1 2 } } [ ] [ ] if-at ] unit-test
-
-[ "hi" ] [ 1 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test
-[ 3 ] [ 3 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test
-[ 2 ] [ 1 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test
-[ "hi" ] [ 3 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test
-
+++ /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 )
- [ dupd 1vector ] dip rot set-at ;
-
-: peek-at* ( assoc key -- obj ? )
- swap at* dup [ [ peek ] dip ] 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 )
- [ 32 random-bits >hex ] dip
- 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
-
-: ?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
+++ /dev/null
-Non-core assoc words
+++ /dev/null
-collections
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: help.syntax help.markup kernel prettyprint sequences
-quotations math ;
-IN: combinators.lib
-
-HELP: generate
-{ $values { "generator" quotation } { "predicate" quotation } { "obj" object } }
-{ $description "Loop until the generator quotation generates an object that satisfies predicate quotation." }
-{ $unchecked-example
- "! Generate a random 20-bit prime number congruent to 3 (mod 4)"
- "USING: combinators.lib math math.miller-rabin prettyprint ;"
- "[ 20 random-prime ] [ 4 mod 3 = ] generate ."
- "526367"
-} ;
-
-HELP: %chance
-{ $values { "quot" quotation } { "n" integer } }
-{ $description "Calls the quotation " { $snippet "n" } " percent of the time." }
-{ $unchecked-example
- "USING: io ;"
- "[ \"hello, world! maybe.\" print ] 50 %chance"
- ""
-} ;
+++ /dev/null
-USING: combinators.lib kernel math random sequences tools.test continuations
- arrays vectors ;
-IN: combinators.lib.tests
-
-[ 6 -1 ] [ 5 0 1 [ + ] [ - ] bi, bi* ] unit-test
-[ 6 -1 1 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri, tri* ] unit-test
-
-[ 5 4 ] [ 5 0 1 [ + ] [ - ] bi*, bi ] unit-test
-[ 5 4 5 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri*, tri ] unit-test
-
-[ 5 6 ] [ 5 0 1 [ + ] bi@, bi ] unit-test
-[ 5 6 7 ] [ 5 0 1 2 [ + ] tri@, tri ] unit-test
-
-[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
-[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
-
-[ { "foo" "xbarx" } ]
-[
- { "oof" "bar" } { [ reverse ] [ "x" dup surround ] } parallel-call
-] unit-test
-
-{ 1 1 } [
- [ even? ] [ drop 1 ] [ drop 2 ] ifte
-] must-infer-as
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov, Chris Double,
-! Doug Coleman, Eduardo Cavazos,
-! Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel combinators fry namespaces make quotations hashtables
-sequences assocs arrays stack-checker effects math math.ranges
-generalizations macros continuations random locals accessors ;
-
-IN: combinators.lib
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Currying cleave combinators
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bi, ( obj quot quot -- quot' quot' )
- [ [ curry ] curry ] bi@ bi ; inline
-: tri, ( obj quot quot quot -- quot' quot' quot' )
- [ [ curry ] curry ] tri@ tri ; inline
-
-: bi*, ( obj obj quot quot -- quot' quot' )
- [ [ curry ] curry ] bi@ bi* ; inline
-: tri*, ( obj obj obj quot quot quot -- quot' quot' quot' )
- [ [ curry ] curry ] tri@ tri* ; inline
-
-: bi@, ( obj obj quot -- quot' quot' )
- [ curry ] curry bi@ ; inline
-: tri@, ( obj obj obj quot -- quot' quot' quot' )
- [ curry ] curry tri@ ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Generalized versions of core combinators
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: quad ( x p q r s -- ) [ keep ] 3dip [ keep ] 2dip [ keep ] dip call ; inline
-
-: 4slip ( quot a b c d -- a b c d ) 4 nslip ; inline
-
-: 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline
-
-: 2with ( param1 param2 obj quot -- obj curry )
- with with ; inline
-
-: 3with ( param1 param2 param3 obj quot -- obj curry )
- with with with ; inline
-
-: with* ( obj assoc quot -- assoc curry )
- swapd [ [ -rot ] dip call ] 2curry ; inline
-
-: 2with* ( obj1 obj2 assoc quot -- assoc curry )
- with* with* ; inline
-
-: 3with* ( obj1 obj2 obj3 assoc quot -- assoc curry )
- with* with* with* ; inline
-
-: assoc-each-with ( obj assoc quot -- )
- with* assoc-each ; inline
-
-: assoc-map-with ( obj assoc quot -- assoc )
- with* assoc-map ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! ifte
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: preserving ( predicate -- quot )
- dup infer in>>
- dup 1+
- '[ _ _ nkeep _ nrot ] ;
-
-MACRO: ifte ( quot quot quot -- )
- '[ _ preserving _ _ if ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! switch
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: switch ( quot -- )
- [ [ [ preserving ] curry ] dip ] assoc-map
- [ cond ] curry ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Conceptual implementation:
-
-! : pcall ( seq quots -- seq ) [ call ] 2map ;
-
-MACRO: parallel-call ( quots -- )
- [ '[ [ unclip @ ] dip [ push ] keep ] ] map concat
- '[ V{ } clone @ nip >array ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! map-call and friends
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (make-call-with) ( quots -- quot )
- [ [ keep ] curry ] map concat [ drop ] append ;
-
-MACRO: map-call-with ( quots -- )
- [ (make-call-with) ] keep length [ narray ] curry compose ;
-
-: (make-call-with2) ( quots -- quot )
- [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
- [ 2drop ] append ;
-
-MACRO: map-call-with2 ( quots -- )
- [
- [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
- [ 2drop ] append
- ] keep length [ narray ] curry append ;
-
-MACRO: map-exec-with ( words -- )
- [ 1quotation ] map [ map-call-with ] curry ;
-
-MACRO: construct-slots ( assoc tuple-class -- tuple )
- [ new ] curry swap [
- [ dip ] curry swap 1quotation [ keep ] curry compose
- ] { } assoc>map concat compose ;
-
-: 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 )
- >r pick >r with r> r> swapd with ;
-
-MACRO: multikeep ( word out-indexes -- ... )
- [
- dup >r [ \ npick \ >r 3array % ] each
- %
- r> [ drop \ r> , ] each
- ] [ ] make ;
-
-: do-while ( pred body tail -- )
- [ tuck 2slip ] dip while ; inline
-
-: generate ( generator predicate -- obj )
- '[ dup @ dup [ nip ] unless not ]
- swap [ ] do-while ;
-
-MACRO: predicates ( seq -- quot/f )
- dup [ 1quotation [ drop ] prepend ] map
- [ [ [ dup ] prepend ] map ] dip zip [ drop f ] suffix
- [ cond ] curry ;
-
-: %chance ( quot n -- ) 100 random > swap when ; inline
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: kernel namespaces namespaces.private quotations sequences
- assocs.lib math.parser math generalizations locals mirrors
- macros ;
-
-IN: namespaces.lib
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: save-namestack ( quot -- ) namestack slip set-namestack ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set* ( val var -- ) namestack* set-assoc-stack ;
-
-: make-object ( quot class -- object )
- new [ <mirror> swap bind ] keep ; inline
-
-: with-object ( object quot -- )
- [ <mirror> ] dip bind ; inline
+++ /dev/null
-Non-core namespace words
+++ /dev/null
-collections
+++ /dev/null
-Eduardo Cavazos
-Doug Coleman
+++ /dev/null
-USING: help.syntax help.markup kernel prettyprint sequences\r
-quotations math ;\r
-IN: sequences.lib\r
-\r
-HELP: map-withn\r
-{ $values { "seq" sequence } { "quot" quotation } { "n" number } { "newseq" sequence } }\r
-{ $description "A generalisation of " { $link map } ". The first " { $snippet "n" } " items after the quotation will be "\r
-"passed to the quotation given to map-withn for each element in the sequence."\r
-} \r
-{ $examples\r
- { $example "USING: math sequences.lib prettyprint ;" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" }\r
-}\r
-{ $see-also each-withn } ;\r
-\r
-HELP: each-withn\r
-{ $values { "seq" sequence } { "quot" quotation } { "n" number } }\r
-{ $description "A generalisation of " { $link each } ". The first " { $snippet "n" } " items after the quotation will be "\r
-"passed to the quotation given to each-withn for each element in the sequence."\r
-} \r
-{ $see-also map-withn } ;\r
-\r
-HELP: randomize\r
-{ $values { "seq" sequence } { "seq'" sequence } }\r
-{ $description "Shuffle the elements in the sequence randomly, returning the new sequence." } ;\r
-\r
-HELP: enumerate\r
-{ $values { "seq" sequence } { "seq'" sequence } }\r
-{ $description "Returns a new sequence where each element is an array of { index, value }" } ;\r
-\r
+++ /dev/null
-USING: arrays kernel sequences sequences.lib math math.functions math.ranges
- tools.test strings ;
-IN: sequences.lib.tests
-
-[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
-{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
-
-[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
-{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
-{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
-[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
-
-[ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test
-[ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test
-
-[ -4 ] [ 1 -4 [ abs ] higher ] unit-test
-[ 1 ] [ 1 -4 [ abs ] lower ] unit-test
-
-[ { 1 2 3 4 } ] [ { { 1 2 3 4 } { 1 2 3 } } longest ] unit-test
-[ { 1 2 3 4 } ] [ { { 1 2 3 } { 1 2 3 4 } } longest ] unit-test
-
-[ { 1 2 3 } ] [ { { 1 2 3 4 } { 1 2 3 } } shortest ] unit-test
-[ { 1 2 3 } ] [ { { 1 2 3 } { 1 2 3 4 } } shortest ] unit-test
-
-[ 3 ] [ 1 3 bigger ] unit-test
-[ 1 ] [ 1 3 smaller ] unit-test
-
-[ "abd" ] [ "abc" "abd" bigger ] unit-test
-[ "abc" ] [ "abc" "abd" smaller ] unit-test
-
-[ "abe" ] [ { "abc" "abd" "abe" } biggest ] unit-test
-[ "abc" ] [ { "abc" "abd" "abe" } smallest ] unit-test
-
-[ 1 3 ] [ { 1 2 3 } minmax ] unit-test
-[ -11 -9 ] [ { -11 -10 -9 } minmax ] unit-test
-[ -1/0. 1/0. ] [ { -1/0. 1/0. -11 -10 -9 } minmax ] unit-test
-
-[ { { 1 } { -1 5 } { 2 4 } } ]
-[ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test
-[ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
-[ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test
-
-[ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test
-[ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test
-
-[ { { 0 0 } { 1 0 } { 0 1 } { 1 1 } } ] [ 2 2 exact-strings ] unit-test
-[ t ] [ "ab" 4 strings [ >string ] map "abab" swap member? ] unit-test
-[ { { } { 1 } { 2 } { 1 2 } } ] [ { 1 2 } power-set ] unit-test
-
-[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
-{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
-{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
-[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
-{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
-[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
-
-[ { { 0 1 } { 1 2 } { 2 3 } } ] [ { 1 2 3 } enumerate ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
-! Eduardo Cavazos, Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib kernel sequences math namespaces make
-assocs random sequences.private shuffle math.functions arrays
-math.parser math.private sorting strings ascii macros assocs.lib
-quotations hashtables math.order locals generalizations
-math.ranges random fry ;
-IN: sequences.lib
-
-: each-withn ( seq quot n -- ) nwith each ; inline
-
-: each-with ( seq quot -- ) with each ; inline
-
-: each-with2 ( obj obj list quot -- ) 2 each-withn ; inline
-
-: map-withn ( seq quot n -- newseq ) nwith map ; inline
-
-: map-with ( seq quot -- ) with map ; inline
-
-: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: each-percent ( seq quot -- )
- [
- dup length
- dup [ / ] curry
- [ 1+ ] prepose
- ] dip compose
- 2each ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: reduce* ( seq quot -- result ) [ ] swap map-reduce ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: higher ( a b quot -- c ) [ compare +gt+ eq? ] curry most ; inline
-
-: lower ( a b quot -- c ) [ compare +lt+ eq? ] curry most ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: longer ( a b -- c ) [ length ] higher ;
-
-: shorter ( a b -- c ) [ length ] lower ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: longest ( seq -- item ) [ longer ] reduce* ;
-
-: shortest ( seq -- item ) [ shorter ] reduce* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bigger ( a b -- c ) [ ] higher ;
-
-: smaller ( a b -- c ) [ ] lower ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: biggest ( seq -- item ) [ bigger ] reduce* ;
-
-: smallest ( seq -- item ) [ smaller ] reduce* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: minmax ( seq -- min max )
- #! find the min and max of a seq in one pass
- 1/0. -1/0. rot [ tuck max [ min ] dip ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ,, ( obj -- ) building get peek push ;
-: v, ( -- ) V{ } clone , ;
-: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
-
-: (monotonic-split) ( seq quot -- newseq )
- [
- [ dup unclip suffix ] dip
- v, [ pick ,, call [ v, ] unless ] curry 2each ,v
- ] { } make ;
-
-: monotonic-split ( seq quot -- newseq )
- over empty? [ 2drop { } ] [ (monotonic-split) ] if ;
-
-ERROR: element-not-found ;
-: split-around ( seq quot -- before elem after )
- dupd find over [ element-not-found ] unless
- [ cut rest ] dip swap ; inline
-
-: map-until ( seq quot pred -- newseq )
- '[ [ @ dup @ [ drop t ] [ , f ] if ] find 2drop ] { } make ;
-
-: take-while ( seq quot -- newseq )
- [ not ] compose
- [ find drop [ head-slice ] when* ] curry
- [ dup ] prepose keep like ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<PRIVATE
-: translate-string ( n alphabet out-len -- seq )
- [ drop /mod ] with map nip ;
-
-: map-alphabet ( alphabet seq[seq] -- seq[seq] )
- [ [ swap nth ] with map ] with map ;
-
-: exact-number-strings ( n out-len -- seqs )
- [ ^ ] 2keep [ translate-string ] 2curry map ;
-
-: number-strings ( n max-length -- seqs )
- 1+ [ exact-number-strings ] with map concat ;
-PRIVATE>
-
-: exact-strings ( alphabet length -- seqs )
- [ dup length ] dip exact-number-strings map-alphabet ;
-
-: strings ( alphabet length -- seqs )
- [ dup length ] dip number-strings map-alphabet ;
-
-: switches ( seq1 seq -- subseq )
- ! seq1 is a sequence of ones and zeroes
- [ [ length ] keep [ nth 1 = ] curry filter ] dip
- [ nth ] curry { } map-as ;
-
-: power-set ( seq -- subsets )
- 2 over length exact-number-strings swap [ switches ] curry map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<PRIVATE
-: (attempt-each-integer) ( i n quot -- result )
- [
- iterate-step roll
- [ 3nip ] [ iterate-next (attempt-each-integer) ] if*
- ] [ 3drop f ] if-iterate? ; inline recursive
-PRIVATE>
-
-: attempt-each ( seq quot -- result )
- (each) iterate-prep (attempt-each-integer) ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: randomize ( seq -- seq' )
- dup length 1 (a,b] [ dup random pick exchange ] each ;
-
-: enumerate ( seq -- seq' ) <enum> >alist ;
+++ /dev/null
-Non-core sequence words
+++ /dev/null
-collections
+++ /dev/null
-USING: kernel sequences strings.lib tools.test ;
-IN: temporary
-
-[ "abcdefghijklmnopqrstuvwxyz" ] [ lower-alpha-chars "" like ] unit-test
-[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
-[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
-[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test
-[ t ] [ 100 [ random-alphanumeric-char ] replicate alphanumeric-chars [ member? ] curry all? ] unit-test
+++ /dev/null
-USING: math math.ranges arrays sequences kernel random splitting
-strings unicode.case ;
-IN: strings.lib
-
-: >Upper ( str -- str )
- dup empty? [ unclip ch>upper prefix ] unless ;
-
-: >Upper-dashes ( str -- str )
- "-" split [ >Upper ] map "-" join ;
-
-: lower-alpha-chars ( -- seq )
- CHAR: a CHAR: z [a,b] ;
-
-: upper-alpha-chars ( -- seq )
- CHAR: A CHAR: Z [a,b] ;
-
-: numeric-chars ( -- seq )
- CHAR: 0 CHAR: 9 [a,b] ;
-
-: alpha-chars ( -- seq )
- lower-alpha-chars upper-alpha-chars append ;
-
-: alphanumeric-chars ( -- seq )
- alpha-chars numeric-chars append ;
-
-: random-alpha-char ( -- ch )
- alpha-chars random ;
-
-: random-alphanumeric-char ( -- ch )
- alphanumeric-chars random ;
-
-: random-alphanumeric-string ( length -- str )
- [ random-alphanumeric-char ] "" replicate-as ;
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+USING: kernel tools.test sequences vectors assocs.lib ;
+IN: assocs.lib.tests
+
+{ 1 1 } [ [ ?push ] histogram ] must-infer-as
+
+! substitute
+[ { 2 } ] [ { 1 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test
+[ { 3 } ] [ { 3 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test
+
+[ 2 ] [ 1 H{ { 1 2 } } [ ] [ ] if-at ] unit-test
+[ 3 ] [ 3 H{ { 1 2 } } [ ] [ ] if-at ] unit-test
+
+[ "hi" ] [ 1 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test
+[ 3 ] [ 3 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test
+[ 2 ] [ 1 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test
+[ "hi" ] [ 3 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test
+
--- /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 )
+ [ dupd 1vector ] dip rot set-at ;
+
+: peek-at* ( assoc key -- obj ? )
+ swap at* dup [ [ peek ] dip ] 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 )
+ [ 32 random-bits >hex ] dip
+ 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
+
+: ?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
--- /dev/null
+Non-core assoc words
--- /dev/null
+collections
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+USING: help.syntax help.markup kernel prettyprint sequences
+quotations math ;
+IN: combinators.lib
+
+HELP: generate
+{ $values { "generator" quotation } { "predicate" quotation } { "obj" object } }
+{ $description "Loop until the generator quotation generates an object that satisfies predicate quotation." }
+{ $unchecked-example
+ "! Generate a random 20-bit prime number congruent to 3 (mod 4)"
+ "USING: combinators.lib math math.miller-rabin prettyprint ;"
+ "[ 20 random-prime ] [ 4 mod 3 = ] generate ."
+ "526367"
+} ;
+
+HELP: %chance
+{ $values { "quot" quotation } { "n" integer } }
+{ $description "Calls the quotation " { $snippet "n" } " percent of the time." }
+{ $unchecked-example
+ "USING: io ;"
+ "[ \"hello, world! maybe.\" print ] 50 %chance"
+ ""
+} ;
--- /dev/null
+USING: combinators.lib kernel math random sequences tools.test continuations
+ arrays vectors ;
+IN: combinators.lib.tests
+
+[ 6 -1 ] [ 5 0 1 [ + ] [ - ] bi, bi* ] unit-test
+[ 6 -1 1 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri, tri* ] unit-test
+
+[ 5 4 ] [ 5 0 1 [ + ] [ - ] bi*, bi ] unit-test
+[ 5 4 5 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri*, tri ] unit-test
+
+[ 5 6 ] [ 5 0 1 [ + ] bi@, bi ] unit-test
+[ 5 6 7 ] [ 5 0 1 2 [ + ] tri@, tri ] unit-test
+
+[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
+[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
+
+[ { "foo" "xbarx" } ]
+[
+ { "oof" "bar" } { [ reverse ] [ "x" dup surround ] } parallel-call
+] unit-test
+
+{ 1 1 } [
+ [ even? ] [ drop 1 ] [ drop 2 ] ifte
+] must-infer-as
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Chris Double,
+! Doug Coleman, Eduardo Cavazos,
+! Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel combinators fry namespaces make quotations hashtables
+sequences assocs arrays stack-checker effects math math.ranges
+generalizations macros continuations random locals accessors ;
+
+IN: combinators.lib
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Currying cleave combinators
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bi, ( obj quot quot -- quot' quot' )
+ [ [ curry ] curry ] bi@ bi ; inline
+: tri, ( obj quot quot quot -- quot' quot' quot' )
+ [ [ curry ] curry ] tri@ tri ; inline
+
+: bi*, ( obj obj quot quot -- quot' quot' )
+ [ [ curry ] curry ] bi@ bi* ; inline
+: tri*, ( obj obj obj quot quot quot -- quot' quot' quot' )
+ [ [ curry ] curry ] tri@ tri* ; inline
+
+: bi@, ( obj obj quot -- quot' quot' )
+ [ curry ] curry bi@ ; inline
+: tri@, ( obj obj obj quot -- quot' quot' quot' )
+ [ curry ] curry tri@ ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Generalized versions of core combinators
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: quad ( x p q r s -- ) [ keep ] 3dip [ keep ] 2dip [ keep ] dip call ; inline
+
+: 4slip ( quot a b c d -- a b c d ) 4 nslip ; inline
+
+: 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline
+
+: 2with ( param1 param2 obj quot -- obj curry )
+ with with ; inline
+
+: 3with ( param1 param2 param3 obj quot -- obj curry )
+ with with with ; inline
+
+: with* ( obj assoc quot -- assoc curry )
+ swapd [ [ -rot ] dip call ] 2curry ; inline
+
+: 2with* ( obj1 obj2 assoc quot -- assoc curry )
+ with* with* ; inline
+
+: 3with* ( obj1 obj2 obj3 assoc quot -- assoc curry )
+ with* with* with* ; inline
+
+: assoc-each-with ( obj assoc quot -- )
+ with* assoc-each ; inline
+
+: assoc-map-with ( obj assoc quot -- assoc )
+ with* assoc-map ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! ifte
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: preserving ( predicate -- quot )
+ dup infer in>>
+ dup 1+
+ '[ _ _ nkeep _ nrot ] ;
+
+MACRO: ifte ( quot quot quot -- )
+ '[ _ preserving _ _ if ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! switch
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: switch ( quot -- )
+ [ [ [ preserving ] curry ] dip ] assoc-map
+ [ cond ] curry ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Conceptual implementation:
+
+! : pcall ( seq quots -- seq ) [ call ] 2map ;
+
+MACRO: parallel-call ( quots -- )
+ [ '[ [ unclip @ ] dip [ push ] keep ] ] map concat
+ '[ V{ } clone @ nip >array ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! map-call and friends
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (make-call-with) ( quots -- quot )
+ [ [ keep ] curry ] map concat [ drop ] append ;
+
+MACRO: map-call-with ( quots -- )
+ [ (make-call-with) ] keep length [ narray ] curry compose ;
+
+: (make-call-with2) ( quots -- quot )
+ [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
+ [ 2drop ] append ;
+
+MACRO: map-call-with2 ( quots -- )
+ [
+ [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
+ [ 2drop ] append
+ ] keep length [ narray ] curry append ;
+
+MACRO: map-exec-with ( words -- )
+ [ 1quotation ] map [ map-call-with ] curry ;
+
+MACRO: construct-slots ( assoc tuple-class -- tuple )
+ [ new ] curry swap [
+ [ dip ] curry swap 1quotation [ keep ] curry compose
+ ] { } assoc>map concat compose ;
+
+: 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 )
+ >r pick >r with r> r> swapd with ;
+
+MACRO: multikeep ( word out-indexes -- ... )
+ [
+ dup >r [ \ npick \ >r 3array % ] each
+ %
+ r> [ drop \ r> , ] each
+ ] [ ] make ;
+
+: do-while ( pred body tail -- )
+ [ tuck 2slip ] dip while ; inline
+
+: generate ( generator predicate -- obj )
+ '[ dup @ dup [ nip ] unless not ]
+ swap [ ] do-while ;
+
+MACRO: predicates ( seq -- quot/f )
+ dup [ 1quotation [ drop ] prepend ] map
+ [ [ [ dup ] prepend ] map ] dip zip [ drop f ] suffix
+ [ cond ] curry ;
+
+: %chance ( quot n -- ) 100 random > swap when ; inline
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+USING: kernel namespaces namespaces.private quotations sequences
+ assocs.lib math.parser math generalizations locals mirrors
+ macros ;
+
+IN: namespaces.lib
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: save-namestack ( quot -- ) namestack slip set-namestack ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: set* ( val var -- ) namestack* set-assoc-stack ;
+
+: make-object ( quot class -- object )
+ new [ <mirror> swap bind ] keep ; inline
+
+: with-object ( object quot -- )
+ [ <mirror> ] dip bind ; inline
--- /dev/null
+Non-core namespace words
--- /dev/null
+collections
--- /dev/null
+Eduardo Cavazos
+Doug Coleman
--- /dev/null
+USING: help.syntax help.markup kernel prettyprint sequences\r
+quotations math ;\r
+IN: sequences.lib\r
+\r
+HELP: map-withn\r
+{ $values { "seq" sequence } { "quot" quotation } { "n" number } { "newseq" sequence } }\r
+{ $description "A generalisation of " { $link map } ". The first " { $snippet "n" } " items after the quotation will be "\r
+"passed to the quotation given to map-withn for each element in the sequence."\r
+} \r
+{ $examples\r
+ { $example "USING: math sequences.lib prettyprint ;" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" }\r
+}\r
+{ $see-also each-withn } ;\r
+\r
+HELP: each-withn\r
+{ $values { "seq" sequence } { "quot" quotation } { "n" number } }\r
+{ $description "A generalisation of " { $link each } ". The first " { $snippet "n" } " items after the quotation will be "\r
+"passed to the quotation given to each-withn for each element in the sequence."\r
+} \r
+{ $see-also map-withn } ;\r
+\r
+HELP: randomize\r
+{ $values { "seq" sequence } { "seq'" sequence } }\r
+{ $description "Shuffle the elements in the sequence randomly, returning the new sequence." } ;\r
+\r
+HELP: enumerate\r
+{ $values { "seq" sequence } { "seq'" sequence } }\r
+{ $description "Returns a new sequence where each element is an array of { index, value }" } ;\r
+\r
--- /dev/null
+USING: arrays kernel sequences sequences.lib math math.functions math.ranges
+ tools.test strings ;
+IN: sequences.lib.tests
+
+[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
+{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
+
+[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
+{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
+{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
+[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
+
+[ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test
+[ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test
+
+[ -4 ] [ 1 -4 [ abs ] higher ] unit-test
+[ 1 ] [ 1 -4 [ abs ] lower ] unit-test
+
+[ { 1 2 3 4 } ] [ { { 1 2 3 4 } { 1 2 3 } } longest ] unit-test
+[ { 1 2 3 4 } ] [ { { 1 2 3 } { 1 2 3 4 } } longest ] unit-test
+
+[ { 1 2 3 } ] [ { { 1 2 3 4 } { 1 2 3 } } shortest ] unit-test
+[ { 1 2 3 } ] [ { { 1 2 3 } { 1 2 3 4 } } shortest ] unit-test
+
+[ 3 ] [ 1 3 bigger ] unit-test
+[ 1 ] [ 1 3 smaller ] unit-test
+
+[ "abd" ] [ "abc" "abd" bigger ] unit-test
+[ "abc" ] [ "abc" "abd" smaller ] unit-test
+
+[ "abe" ] [ { "abc" "abd" "abe" } biggest ] unit-test
+[ "abc" ] [ { "abc" "abd" "abe" } smallest ] unit-test
+
+[ 1 3 ] [ { 1 2 3 } minmax ] unit-test
+[ -11 -9 ] [ { -11 -10 -9 } minmax ] unit-test
+[ -1/0. 1/0. ] [ { -1/0. 1/0. -11 -10 -9 } minmax ] unit-test
+
+[ { { 1 } { -1 5 } { 2 4 } } ]
+[ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test
+[ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
+[ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test
+
+[ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test
+[ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test
+
+[ { { 0 0 } { 1 0 } { 0 1 } { 1 1 } } ] [ 2 2 exact-strings ] unit-test
+[ t ] [ "ab" 4 strings [ >string ] map "abab" swap member? ] unit-test
+[ { { } { 1 } { 2 } { 1 2 } } ] [ { 1 2 } power-set ] unit-test
+
+[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
+{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
+{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
+[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
+{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
+[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
+
+[ { { 0 1 } { 1 2 } { 2 3 } } ] [ { 1 2 3 } enumerate ] unit-test
+
--- /dev/null
+! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
+! Eduardo Cavazos, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.lib kernel sequences math namespaces make
+assocs random sequences.private shuffle math.functions arrays
+math.parser math.private sorting strings ascii macros assocs.lib
+quotations hashtables math.order locals generalizations
+math.ranges random fry ;
+IN: sequences.lib
+
+: each-withn ( seq quot n -- ) nwith each ; inline
+
+: each-with ( seq quot -- ) with each ; inline
+
+: each-with2 ( obj obj list quot -- ) 2 each-withn ; inline
+
+: map-withn ( seq quot n -- newseq ) nwith map ; inline
+
+: map-with ( seq quot -- ) with map ; inline
+
+: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: each-percent ( seq quot -- )
+ [
+ dup length
+ dup [ / ] curry
+ [ 1+ ] prepose
+ ] dip compose
+ 2each ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: reduce* ( seq quot -- result ) [ ] swap map-reduce ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: higher ( a b quot -- c ) [ compare +gt+ eq? ] curry most ; inline
+
+: lower ( a b quot -- c ) [ compare +lt+ eq? ] curry most ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: longer ( a b -- c ) [ length ] higher ;
+
+: shorter ( a b -- c ) [ length ] lower ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: longest ( seq -- item ) [ longer ] reduce* ;
+
+: shortest ( seq -- item ) [ shorter ] reduce* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bigger ( a b -- c ) [ ] higher ;
+
+: smaller ( a b -- c ) [ ] lower ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: biggest ( seq -- item ) [ bigger ] reduce* ;
+
+: smallest ( seq -- item ) [ smaller ] reduce* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: minmax ( seq -- min max )
+ #! find the min and max of a seq in one pass
+ 1/0. -1/0. rot [ tuck max [ min ] dip ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ,, ( obj -- ) building get peek push ;
+: v, ( -- ) V{ } clone , ;
+: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
+
+: (monotonic-split) ( seq quot -- newseq )
+ [
+ [ dup unclip suffix ] dip
+ v, [ pick ,, call [ v, ] unless ] curry 2each ,v
+ ] { } make ;
+
+: monotonic-split ( seq quot -- newseq )
+ over empty? [ 2drop { } ] [ (monotonic-split) ] if ;
+
+ERROR: element-not-found ;
+: split-around ( seq quot -- before elem after )
+ dupd find over [ element-not-found ] unless
+ [ cut rest ] dip swap ; inline
+
+: map-until ( seq quot pred -- newseq )
+ '[ [ @ dup @ [ drop t ] [ , f ] if ] find 2drop ] { } make ;
+
+: take-while ( seq quot -- newseq )
+ [ not ] compose
+ [ find drop [ head-slice ] when* ] curry
+ [ dup ] prepose keep like ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<PRIVATE
+: translate-string ( n alphabet out-len -- seq )
+ [ drop /mod ] with map nip ;
+
+: map-alphabet ( alphabet seq[seq] -- seq[seq] )
+ [ [ swap nth ] with map ] with map ;
+
+: exact-number-strings ( n out-len -- seqs )
+ [ ^ ] 2keep [ translate-string ] 2curry map ;
+
+: number-strings ( n max-length -- seqs )
+ 1+ [ exact-number-strings ] with map concat ;
+PRIVATE>
+
+: exact-strings ( alphabet length -- seqs )
+ [ dup length ] dip exact-number-strings map-alphabet ;
+
+: strings ( alphabet length -- seqs )
+ [ dup length ] dip number-strings map-alphabet ;
+
+: switches ( seq1 seq -- subseq )
+ ! seq1 is a sequence of ones and zeroes
+ [ [ length ] keep [ nth 1 = ] curry filter ] dip
+ [ nth ] curry { } map-as ;
+
+: power-set ( seq -- subsets )
+ 2 over length exact-number-strings swap [ switches ] curry map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<PRIVATE
+: (attempt-each-integer) ( i n quot -- result )
+ [
+ iterate-step roll
+ [ 3nip ] [ iterate-next (attempt-each-integer) ] if*
+ ] [ 3drop f ] if-iterate? ; inline recursive
+PRIVATE>
+
+: attempt-each ( seq quot -- result )
+ (each) iterate-prep (attempt-each-integer) ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: randomize ( seq -- seq' )
+ dup length 1 (a,b] [ dup random pick exchange ] each ;
+
+: enumerate ( seq -- seq' ) <enum> >alist ;
--- /dev/null
+Non-core sequence words
--- /dev/null
+collections
--- /dev/null
+USING: kernel sequences strings.lib tools.test ;
+IN: temporary
+
+[ "abcdefghijklmnopqrstuvwxyz" ] [ lower-alpha-chars "" like ] unit-test
+[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
+[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
+[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test
+[ t ] [ 100 [ random-alphanumeric-char ] replicate alphanumeric-chars [ member? ] curry all? ] unit-test
--- /dev/null
+USING: math math.ranges arrays sequences kernel random splitting
+strings unicode.case ;
+IN: strings.lib
+
+: >Upper ( str -- str )
+ dup empty? [ unclip ch>upper prefix ] unless ;
+
+: >Upper-dashes ( str -- str )
+ "-" split [ >Upper ] map "-" join ;
+
+: lower-alpha-chars ( -- seq )
+ CHAR: a CHAR: z [a,b] ;
+
+: upper-alpha-chars ( -- seq )
+ CHAR: A CHAR: Z [a,b] ;
+
+: numeric-chars ( -- seq )
+ CHAR: 0 CHAR: 9 [a,b] ;
+
+: alpha-chars ( -- seq )
+ lower-alpha-chars upper-alpha-chars append ;
+
+: alphanumeric-chars ( -- seq )
+ alpha-chars numeric-chars append ;
+
+: random-alpha-char ( -- ch )
+ alpha-chars random ;
+
+: random-alphanumeric-char ( -- ch )
+ alphanumeric-chars random ;
+
+: random-alphanumeric-string ( length -- str )
+ [ random-alphanumeric-char ] "" replicate-as ;
projects / factor.git / commitdiff