--- /dev/null
+Jon Harper
--- /dev/null
+! Copyright (C) 2010 Jon Harper.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax kernel quotations
+combinators.random.private sequences ;
+IN: combinators.random
+
+HELP: call-random
+{ $values { "seq" "a sequence of quotations" } }
+{ $description "Calls a random quotation from the given sequence of quotations." } ;
+
+HELP: execute-random
+{ $values { "seq" "a sequence of words" } }
+{ $description "Executes a random word from the given sequence of quotations." } ;
+
+HELP: ifp
+{ $values
+ { "p" "a number between 0 and 1" } { "true" quotation } { "false" quotation }
+}
+{ $description "Calls the " { $snippet "true" } " quotation with probability " { $snippet "p" }
+" and the " { $snippet "false" } " quotation with probability (1-" { $snippet "p" } ")." } ;
+
+HELP: casep
+{ $values
+ { "assoc" "a sequence of probability/quotations pairs with an optional quotation at the end" }
+}
+{ $description "Calls the different quotations randomly with the given probability. The optional quotation at the end "
+"will be given a probability so that the sum of the probabilities is one. Therefore, the sum of the probabilities "
+"must be exactly one when no default quotation is given, or between zero and one when it is given. "
+"Additionally, all probabilities must be numbers between 0 and 1. "
+"These rules are enforced during the macro expansion by throwing " { $link bad-probabilities } " "
+"if they are not respected." }
+{ $examples
+ "The following two forms will output 1 with 0.2 probability, 2 with 0.3 probability and 3 with 0.5 probability"
+ { $code
+ "USING: combinators.random ;"
+ "{ { 0.2 [ 1 ] }"
+ " { 0.3 [ 2 ] }"
+ " { 0.5 [ 3 ] } } casep ."
+ }
+ $nl
+ { $code
+ "USING: combinators.random ;"
+ "{ { 0.2 [ 1 ] }"
+ " { 0.3 [ 2 ] }"
+ " { [ 3 ] } } casep ."
+ }
+
+}
+
+{ $see-also casep* } ;
+
+HELP: casep*
+{ $values
+ { "assoc" "a sequence of probability/word pairs with an optional quotation at the end" }
+}
+{ $description "Calls the different quotations randomly with the given probability. Unlike " { $link casep } ", "
+"the probabilities are interpreted as conditional probabilities. "
+"All probabilities must be numbers between 0 and 1. "
+"The sequence must end with a pair whose probability is one, or a quotation."
+"These rules are enforced during the macro expansion by throwing " { $link bad-probabilities } " "
+"if they are not respected." }
+{ $examples
+ "The following two forms will output 1 with 0.5 probability, 2 with 0.25 probability and 3 with 0.25 probability"
+ { $code
+ "USING: combinators.random ;"
+ "{ { 0.5 [ 1 ] }"
+ " { 0.5 [ 2 ] }"
+ " { 1 [ 3 ] } } casep* ."
+ }
+ $nl
+ { $code
+ "USING: combinators.random ;"
+ "{ { 0.5 [ 1 ] }"
+ " { 0.5 [ 2 ] }"
+ " { [ 3 ] } } casep* ."
+ }
+
+}
+{ $see-also casep } ;
+
+HELP: unlessp
+{ $values
+ { "p" "a number between 0 and 1" } { "false" quotation }
+}
+{ $description "Variant of " { $link ifp } " with no " { $snippet "true" } " quotation." } ;
+
+HELP: whenp
+{ $values
+ { "p" "a number between 0 and 1" } { "true" quotation }
+}
+{ $description "Variant of " { $link ifp } " with no " { $snippet "false" } " quotation." } ;
+
+ARTICLE: "combinators.random" "Random combinators"
+"The " { $vocab-link "combinators.random" } " vocabulary implements simple combinators to easily express random choices"
+" between multiple code paths."
+$nl
+"For all these combinators, the stack effect of the different given quotations or words must be the same."
+$nl
+"Variants of if, when and unless:"
+{ $subsections
+ ifp
+ whenp
+ unlessp }
+"Variants of case:"
+{ $subsections
+ casep
+ casep*
+ call-random
+ execute-random
+} ;
+
+ABOUT: "combinators.random"
--- /dev/null
+! Copyright (C) 2010 Jon Harper.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test combinators.random combinators.random.private ;
+IN: combinators.random.tests
+
+[ 1 ] [ 1 [ 1 ] [ 2 ] ifp ] unit-test
+[ 2 ] [ 0 [ 1 ] [ 2 ] ifp ] unit-test
+
+[ 3 ]
+[ { { 0 [ 1 ] }
+ { 0 [ 2 ] }
+ { 1 [ 3 ] }
+ [ 4 ]
+ } casep ] unit-test
+
+[ 4 ]
+[ { { 0 [ 1 ] }
+ { 0 [ 2 ] }
+ { 0 [ 3 ] }
+ [ 4 ]
+ } casep ] unit-test
+
+[ 1 1 ] [ 1 {
+ { 1 [ 1 ] }
+ { 0 [ 2 ] }
+ { 0 [ 3 ] }
+ [ 4 ]
+ } casep ] unit-test
+
+[ 1 4 ] [ 1 {
+ { 0 [ 1 ] }
+ { 0 [ 2 ] }
+ { 0 [ 3 ] }
+ [ 4 ]
+ } casep ] unit-test
+
+[ 2 ] [ 0.7 {
+ { 0.3 [ 1 ] }
+ { 0.5 [ 2 ] }
+ [ 2 ] } (casep) ] unit-test
+
+[ { { 1/3 [ 1 ] }
+ { 1/3 [ 2 ] }
+ { 1/3 [ 3 ] } } ]
+[ { [ 1 ] [ 2 ] [ 3 ] } call-random>casep ] unit-test
+
+[ { { 1/2 [ 1 ] }
+ { 1/4 [ 2 ] }
+ { 1/4 [ 3 ] } } ]
+[ { { 1/2 [ 1 ] }
+ { 1/2 [ 2 ] }
+ { 1 [ 3 ] } } direct>conditional ] unit-test
+
+[ { { 1/2 [ 1 ] }
+ { 1/4 [ 2 ] }
+ { [ 3 ] } } ]
+[ { { 1/2 [ 1 ] }
+ { 1/2 [ 2 ] }
+ { [ 3 ] } } direct>conditional ] unit-test
+
+[ f ] [ { { 0.6 [ 1 ] }
+ { 0.6 [ 2 ] } } good-probabilities? ] unit-test
+[ f ] [ { { 0.3 [ 1 ] }
+ { 0.6 [ 2 ] } } good-probabilities? ] unit-test
+[ f ] [ { { -0.6 [ 1 ] }
+ { 1.4 [ 2 ] } } good-probabilities? ] unit-test
+[ f ] [ { { -0.6 [ 1 ] }
+ [ 2 ] } good-probabilities? ] unit-test
+[ t ] [ { { 0.6 [ 1 ] }
+ [ 2 ] } good-probabilities? ] unit-test
+[ t ] [ { { 0.6 [ 1 ] }
+ { 0.4 [ 2 ] } } good-probabilities? ] unit-test
--- /dev/null
+! Copyright (C) 2010 Jon Harper.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators combinators.short-circuit
+kernel macros math math.order quotations random sequences
+summary ;
+IN: combinators.random
+
+: ifp ( p true false -- ) [ 0 1 uniform-random-float > ] 2dip if ; inline
+: whenp ( p true -- ) [ ] ifp ; inline
+: unlessp ( p false -- ) [ [ ] ] dip ifp ; inline
+
+<PRIVATE
+
+: with-drop ( quot -- quot' ) [ drop ] prepend ; inline
+
+: prepare-pair ( pair -- pair' )
+ first2 [ [ [ - ] [ < ] 2bi ] curry ] [ with-drop ] bi* 2array ;
+
+ERROR: bad-probabilities assoc ;
+
+M: bad-probabilities summary
+ drop "The probabilities do not satisfy the rules stated in the docs." ;
+
+: good-probabilities? ( assoc -- ? )
+ dup last pair? [
+ keys { [ sum 1 number= ] [ [ 0 1 between? ] all? ] } 1&&
+ ] [
+ but-last keys { [ sum 0 1 between? ] [ [ 0 1 between? ] all? ] } 1&&
+ ] if ;
+
+! Useful for unit-tests (no random part)
+: (casep>quot) ( assoc -- quot )
+ dup good-probabilities? [
+ [ dup pair? [ prepare-pair ] [ with-drop ] if ] map
+ cond>quot
+ ] [ bad-probabilities ] if ;
+
+MACRO: (casep) ( assoc -- ) (casep>quot) ;
+
+: casep>quot ( assoc -- quot )
+ (casep>quot) [ 0 1 uniform-random-float ] prepend ;
+
+: (conditional-probabilities) ( seq i -- p )
+ [ dup 0 > [ head [ 1 swap - ] [ * ] map-reduce ] [ 2drop 1 ] if ] [ swap nth ] 2bi * ;
+
+: conditional-probabilities ( seq -- seq' )
+ dup length iota [ (conditional-probabilities) ] with map ;
+
+: (direct>conditional) ( assoc -- assoc' )
+ [ keys conditional-probabilities ] [ values ] bi zip ;
+
+: direct>conditional ( assoc -- assoc' )
+ dup last pair? [ (direct>conditional) ] [
+ unclip-last [ (direct>conditional) ] [ suffix ] bi*
+ ] if ;
+
+: call-random>casep ( seq -- assoc )
+ [ length recip ] keep [ 2array ] with map ;
+
+PRIVATE>
+
+MACRO: casep ( assoc -- ) casep>quot ;
+
+MACRO: casep* ( assoc -- ) direct>conditional casep>quot ;
+
+MACRO: call-random ( seq -- ) call-random>casep casep>quot ;
+
+MACRO: execute-random ( seq -- )
+ [ 1quotation ] map call-random>casep casep>quot ;
\ No newline at end of file
USING: arrays combinators continuations fry io io.backend
io.directories io.directories.hierarchy io.files io.pathnames
kernel locals math math.bitwise math.parser namespaces random
-sequences system vocabs.loader ;
+sequences system vocabs.loader random.data ;
IN: io.files.unique
HOOK: (touch-unique-file) io-backend ( path -- )
<PRIVATE
-: random-letter ( -- ch )
- 26 random { CHAR: a CHAR: A } random + ;
-
-: random-ch ( -- ch )
- { t f } random
- [ 10 random CHAR: 0 + ] [ random-letter ] if ;
-
-: random-name ( -- string )
- unique-length get [ random-ch ] "" replicate-as ;
+: random-file-name ( -- string )
+ unique-length get random-string ;
: retry ( quot: ( -- ? ) n -- )
iota swap [ drop ] prepose attempt-all ; inline
: (make-unique-file) ( path prefix suffix -- path )
'[
- _ _ _ random-name glue append-path
+ _ _ _ random-file-name glue append-path
dup touch-unique-file
] unique-retries get retry ;
: unique-directory ( -- path )
[
current-temporary-directory get
- random-name append-path
+ random-file-name append-path
dup make-directory
] unique-retries get retry ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators effects.parser kernel math random
+combinators.random sequences ;
+IN: random.data
+
+: random-digit ( -- ch )
+ 10 random CHAR: 0 + ;
+
+: random-LETTER ( -- ch ) 26 random CHAR: A + ;
+
+: random-letter ( -- ch ) 26 random CHAR: a + ;
+
+: random-Letter ( -- ch )
+ { random-LETTER random-letter } execute-random ;
+
+: random-ch ( -- ch )
+ { random-digit random-Letter } execute-random ;
+
+: random-string ( n -- string ) [ random-ch ] "" replicate-as ;
projects / factor.git / commitdiff