Merge branch 'master' of git://projects.elasticdog.com/git/factor

db4
Slava Pestov 2008-12-04 00:28:29 -06:00
commit 993d8de372
100 changed files with 274 additions and 125 deletions

View File

@ -29,7 +29,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
writer>> swap "writing" set-word-prop ; writer>> swap "writing" set-word-prop ;
: reader-word ( class name vocab -- word ) : reader-word ( class name vocab -- word )
[ "-" swap 3append ] dip create ; [ "-" glue ] dip create ;
: writer-word ( class name vocab -- word ) : writer-word ( class name vocab -- word )
[ [ swap "set-" % % "-" % % ] "" make ] dip create ; [ [ swap "set-" % % "-" % % ] "" make ] dip create ;

View File

@ -162,22 +162,19 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
where-clause where-clause
] query-make ; ] query-make ;
: splice ( string1 string2 string3 -- string )
swap 3append ;
: do-group ( tuple groups -- ) : do-group ( tuple groups -- )
dup string? [ 1array ] when dup string? [ 1array ] when
[ ", " join " group by " splice ] curry change-sql drop ; [ ", " join " group by " glue ] curry change-sql drop ;
: do-order ( tuple order -- ) : do-order ( tuple order -- )
dup string? [ 1array ] when dup string? [ 1array ] when
[ ", " join " order by " splice ] curry change-sql drop ; [ ", " join " order by " glue ] curry change-sql drop ;
: do-offset ( tuple n -- ) : do-offset ( tuple n -- )
[ number>string " offset " splice ] curry change-sql drop ; [ number>string " offset " glue ] curry change-sql drop ;
: do-limit ( tuple n -- ) : do-limit ( tuple n -- )
[ number>string " limit " splice ] curry change-sql drop ; [ number>string " limit " glue ] curry change-sql drop ;
: make-query* ( tuple query -- tuple' ) : make-query* ( tuple query -- tuple' )
dupd dupd

View File

@ -147,12 +147,6 @@ HELP: get-slot-named
{ "value" "the value stored in the slot" } } { "value" "the value stored in the slot" } }
{ $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ; { $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ;
HELP: join-space
{ $values
{ "string1" string } { "string2" string }
{ "new-string" null } }
{ $description "" } ;
HELP: literal-bind HELP: literal-bind
{ $description "" } ; { $description "" } ;

View File

@ -158,12 +158,6 @@ ERROR: no-sql-type type ;
modifiers>> [ lookup-modifier ] map " " join modifiers>> [ lookup-modifier ] map " " join
[ "" ] [ " " prepend ] if-empty ; [ "" ] [ " " prepend ] if-empty ;
: join-space ( string1 string2 -- new-string )
" " swap 3append ;
: paren ( string -- new-string )
"(" swap ")" 3append ;
HOOK: bind% db ( spec -- ) HOOK: bind% db ( spec -- )
HOOK: bind# db ( spec obj -- ) HOOK: bind# db ( spec obj -- )
@ -171,7 +165,7 @@ ERROR: no-column column ;
: >reference-string ( string pair -- string ) : >reference-string ( string pair -- string )
first2 first2
[ [ unparse join-space ] [ db-columns ] bi ] dip [ [ unparse " " glue ] [ db-columns ] bi ] dip
swap [ column-name>> = ] with find nip swap [ column-name>> = ] with find nip
[ no-column ] unless* [ no-column ] unless*
column-name>> paren append ; column-name>> "(" ")" surround append ;

View File

@ -18,7 +18,7 @@ HOOK: (set-os-envs) os ( seq -- )
(os-envs) [ "=" split1 ] H{ } map>assoc ; (os-envs) [ "=" split1 ] H{ } map>assoc ;
: set-os-envs ( assoc -- ) : set-os-envs ( assoc -- )
[ "=" swap 3append ] { } assoc>map (set-os-envs) ; [ "=" glue ] { } assoc>map (set-os-envs) ;
{ {
{ [ os unix? ] [ "environment.unix" require ] } { [ os unix? ] [ "environment.unix" require ] }

View File

@ -7,8 +7,7 @@ namespaces make sequences ftp io.unix.launcher.parser
unicode.case splitting assocs classes io.servers.connection unicode.case splitting assocs classes io.servers.connection
destructors calendar io.timeouts io.streams.duplex threads destructors calendar io.timeouts io.streams.duplex threads
continuations math concurrency.promises byte-arrays continuations math concurrency.promises byte-arrays
io.backend sequences.lib tools.hexdump tools.files io.backend tools.hexdump tools.files io.streams.string ;
io.streams.string ;
IN: ftp.server IN: ftp.server
TUPLE: ftp-client url mode state command-promise user password ; TUPLE: ftp-client url mode state command-promise user password ;
@ -231,7 +230,7 @@ M: ftp-put service-command ( stream obj -- )
expect-connection expect-connection
[ [
"Entering Passive Mode (127,0,0,1," % "Entering Passive Mode (127,0,0,1," %
port>bytes [ number>string ] bi@ "," splice % port>bytes [ number>string ] bi@ "," glue %
")" % ")" %
] "" make 227 swap server-response ; ] "" make 227 swap server-response ;

View File

@ -7,7 +7,7 @@ http.server.redirection http.server.remapping ;
IN: furnace.utilities IN: furnace.utilities
: word>string ( word -- string ) : word>string ( word -- string )
[ vocabulary>> ] [ name>> ] bi ":" swap 3append ; [ vocabulary>> ] [ name>> ] bi ":" glue ;
: words>strings ( seq -- seq' ) : words>strings ( seq -- seq' )
[ word>string ] map ; [ word>string ] map ;

View File

@ -111,7 +111,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
{ [ dup real? ] [ number>string ] } { [ dup real? ] [ number>string ] }
[ ] [ ]
} cond } cond
[ check-cookie-string ] bi@ "=" swap 3append , [ check-cookie-string ] bi@ "=" glue ,
] ]
} case ; } case ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.bitwise combinators.lib math.parser USING: kernel math math.bitwise math.parser
random sequences sequences.lib continuations namespaces random sequences continuations namespaces
io.files io arrays io.files.unique.backend system io.files io arrays io.files.unique.backend system
combinators vocabs.loader fry ; combinators vocabs.loader fry ;
IN: io.files.unique IN: io.files.unique
@ -29,7 +29,7 @@ PRIVATE>
: make-unique-file ( prefix suffix -- path ) : make-unique-file ( prefix suffix -- path )
temporary-path -rot temporary-path -rot
[ [
unique-length get random-name swap 3append append-path unique-length get random-name glue append-path
dup (make-unique-file) dup (make-unique-file)
] 3curry unique-retries get retry ; ] 3curry unique-retries get retry ;

View File

@ -79,7 +79,7 @@ M: threaded-server handle-client* handler>> call ;
\ handle-client ERROR add-error-logging \ handle-client ERROR add-error-logging
: thread-name ( server-name addrspec -- string ) : thread-name ( server-name addrspec -- string )
unparse-short " connection from " swap 3append ; unparse-short " connection from " glue ;
: accept-connection ( threaded-server -- ) : accept-connection ( threaded-server -- )
[ accept ] [ addr>> ] bi [ accept ] [ addr>> ] bi

View File

@ -115,7 +115,7 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ;
: pad-inet6 ( string1 string2 -- seq ) : pad-inet6 ( string1 string2 -- seq )
2dup [ length ] bi@ + 8 swap - 2dup [ length ] bi@ + 8 swap -
dup 0 < [ "More than 8 components" throw ] when dup 0 < [ "More than 8 components" throw ] when
<byte-array> swap 3append ; <byte-array> glue ;
: inet6-bytes ( seq -- bytes ) : inet6-bytes ( seq -- bytes )
[ 2 >be ] { } map-as concat >byte-array ; [ 2 >be ] { } map-as concat >byte-array ;

View File

@ -4,7 +4,7 @@ USING: alien.syntax kernel unix.stat math unix
combinators system io.backend accessors alien.c-types combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types io.unix.files io.encodings.utf8 alien.strings unix.types io.unix.files
io.files unix.statvfs.netbsd unix.getfsstat.netbsd io.files unix.statvfs.netbsd unix.getfsstat.netbsd
grouping sequences ; grouping sequences io.encodings.utf8 ;
IN: io.unix.files.netbsd IN: io.unix.files.netbsd
TUPLE: netbsd-file-system-info < unix-file-system-info TUPLE: netbsd-file-system-info < unix-file-system-info
@ -40,13 +40,13 @@ M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-inf
[ statvfs-f_namemax >>name-max ] [ statvfs-f_namemax >>name-max ]
[ statvfs-f_owner >>owner ] [ statvfs-f_owner >>owner ]
! [ statvfs-f_spare >>spare ] ! [ statvfs-f_spare >>spare ]
[ statvfs-f_fstypename alien>native-string >>type ] [ statvfs-f_fstypename utf8 alien>string >>type ]
[ statvfs-f_mntonname alien>native-string >>mount-point ] [ statvfs-f_mntonname utf8 alien>string >>mount-point ]
[ statvfs-f_mntfromname alien>native-string >>device-name ] [ statvfs-f_mntfromname utf8 alien>string >>device-name ]
} cleave ; } cleave ;
M: netbsd file-systems ( -- array ) M: netbsd file-systems ( -- array )
f 0 0 getvfsstat dup io-error f 0 0 getvfsstat dup io-error
"statvfs" <c-array> dup dup length 0 getvfsstat io-error "statvfs" <c-array> dup dup length 0 getvfsstat io-error
"statvfs" heap-size group "statvfs" heap-size group
[ statvfs-f_mntonname alien>native-string file-system-info ] map ; [ statvfs-f_mntonname utf8 alien>string file-system-info ] map ;

View File

@ -16,7 +16,7 @@ USE: unix
command>> dup string? [ tokenize-command ] when ; command>> dup string? [ tokenize-command ] when ;
: assoc>env ( assoc -- env ) : assoc>env ( assoc -- env )
[ "=" swap 3append ] { } assoc>map ; [ "=" glue ] { } assoc>map ;
: setup-priority ( process -- process ) : setup-priority ( process -- process )
dup priority>> [ dup priority>> [

View File

@ -3,13 +3,14 @@ IN: math.statistics
HELP: geometric-mean HELP: geometric-mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." } { $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." }
{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
{ $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ; { $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ;
HELP: harmonic-mean HELP: harmonic-mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." } { $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
{ $notes "Positive reals only." }
{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
@ -36,21 +37,21 @@ HELP: range
HELP: std HELP: std
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the standard deviation of " { $snippet "seq" } " by squaring the variance of the sequence. It measures how widely spread the values in a sequence are about the mean." } { $description "Computes the standard deviation of " { $snippet "seq" } ", which is the square root of the variance. It measures how widely spread the values in a sequence are about the mean." }
{ $examples { $examples
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" } { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" }
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ; { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ;
HELP: ste HELP: ste
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." } { $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." }
{ $examples { $examples
{ $example "USING: math.statistics prettyprint ;" "{ -2 2 } ste ." "2.0" } { $example "USING: math.statistics prettyprint ;" "{ -2 2 } ste ." "2.0" }
{ $example "USING: math.statistics prettyprint ;" "{ -2 2 2 } ste ." "1.333333333333333" } } ; { $example "USING: math.statistics prettyprint ;" "{ -2 2 2 } ste ." "1.333333333333333" } } ;
HELP: var HELP: var
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." } { $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." }
{ $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." } { $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." }
{ $examples { $examples
{ $example "USING: math.statistics prettyprint ;" "{ 1 } var ." "0" } { $example "USING: math.statistics prettyprint ;" "{ 1 } var ." "0" }

View File

@ -5,20 +5,15 @@ USING: arrays combinators kernel math math.analysis math.functions sequences
IN: math.statistics IN: math.statistics
: mean ( seq -- n ) : mean ( seq -- n )
#! arithmetic mean, sum divided by length
[ sum ] [ length ] bi / ; [ sum ] [ length ] bi / ;
: geometric-mean ( seq -- n ) : geometric-mean ( seq -- n )
#! geometric mean, nth root of product
[ length ] [ product ] bi nth-root ; [ length ] [ product ] bi nth-root ;
: harmonic-mean ( seq -- n ) : harmonic-mean ( seq -- n )
#! harmonic mean, reciprocal of sum of reciprocals.
#! positive reals only
[ recip ] sigma recip ; [ recip ] sigma recip ;
: median ( seq -- n ) : median ( seq -- n )
#! middle number if odd, avg of two middle numbers if even
natural-sort dup length even? [ natural-sort dup length even? [
[ midpoint@ dup 1- 2array ] keep nths mean [ midpoint@ dup 1- 2array ] keep nths mean
] [ ] [
@ -26,11 +21,10 @@ IN: math.statistics
] if ; ] if ;
: range ( seq -- n ) : range ( seq -- n )
#! max - min
minmax swap - ; minmax swap - ;
: var ( seq -- x ) : var ( seq -- x )
#! variance, normalize by N-1 #! normalize by N-1
dup length 1 <= [ dup length 1 <= [
drop 0 drop 0
] [ ] [
@ -39,11 +33,9 @@ IN: math.statistics
] if ; ] if ;
: std ( seq -- x ) : std ( seq -- x )
#! standard deviation, sqrt of variance
var sqrt ; var sqrt ;
: ste ( seq -- x ) : ste ( seq -- x )
#! standard error, standard deviation / sqrt ( length of sequence )
[ std ] [ length ] bi sqrt / ; [ std ] [ length ] bi sqrt / ;
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) ) : ((r)) ( mean(x) mean(y) {x} {y} -- (r) )

View File

@ -129,7 +129,7 @@ SYMBOL: ->
: remove-breakpoints ( quot pos -- quot' ) : remove-breakpoints ( quot pos -- quot' )
over quotation? [ over quotation? [
1+ cut [ (remove-breakpoints) ] bi@ 1+ cut [ (remove-breakpoints) ] bi@
[ -> ] swap 3append [ -> ] glue
] [ ] [
drop drop
] if ; ] if ;

View File

@ -15,11 +15,14 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
: mt-m 397 ; inline : mt-m 397 ; inline
: mt-a HEX: 9908b0df ; inline : mt-a HEX: 9908b0df ; inline
: mersenne-wrap ( n -- n' )
dup mt-n > [ mt-n - ] when ; inline
: wrap-nth ( n seq -- obj ) : wrap-nth ( n seq -- obj )
[ length mod ] keep nth-unsafe ; inline [ mersenne-wrap ] dip nth-unsafe ; inline
: set-wrap-nth ( obj n seq -- ) : set-wrap-nth ( obj n seq -- )
[ length mod ] keep set-nth-unsafe ; inline [ mersenne-wrap ] dip set-nth-unsafe ; inline
: calculate-y ( n seq -- y ) : calculate-y ( n seq -- y )
[ wrap-nth 31 mask-bit ] [ wrap-nth 31 mask-bit ]
@ -50,7 +53,7 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
: init-mt-seq ( seed -- seq ) : init-mt-seq ( seed -- seq )
32 bits mt-n <uint-array> 32 bits mt-n <uint-array>
[ set-first ] [ init-mt-rest ] [ ] tri ; [ set-first ] [ init-mt-rest ] [ ] tri ; inline
: mt-temper ( y -- yt ) : mt-temper ( y -- yt )
dup -11 shift bitxor dup -11 shift bitxor

View File

@ -10,7 +10,7 @@ IN: tools.memory
: write-size ( n -- ) : write-size ( n -- )
number>string number>string
dup length 4 > [ 3 cut* "," swap 3append ] when dup length 4 > [ 3 cut* "," glue ] when
" KB" append write-cell ; " KB" append write-cell ;
: write-total/used/free ( free total str -- ) : write-total/used/free ( free total str -- )

View File

@ -238,7 +238,7 @@ M: vocab-link summary vocab-summary ;
vocab-dir append-path dup exists? vocab-dir append-path dup exists?
[ subdirs ] [ drop { } ] if [ subdirs ] [ drop { } ] if
] keep [ ] keep [
swap [ "." swap 3append ] with map swap [ "." glue ] with map
] unless-empty ; ] unless-empty ;
: vocabs-in-dir ( root name -- ) : vocabs-in-dir ( root name -- )

View File

@ -126,7 +126,7 @@ SYMBOL: +stopped+
[ [
2dup length = [ nip [ break ] append ] [ 2dup length = [ nip [ break ] append ] [
2dup nth \ break = [ nip ] [ 2dup nth \ break = [ nip ] [
swap 1+ cut [ break ] swap 3append swap 1+ cut [ break ] glue
] if ] if
] if ] if
] change-frame ; ] change-frame ;

View File

@ -91,6 +91,6 @@ PRIVATE>
[ [
[ [
[ url-encode ] dip [ url-encode ] dip
[ url-encode "=" swap 3append , ] with each [ url-encode "=" glue , ] with each
] assoc-each ] assoc-each
] { } make "&" join ; ] { } make "&" join ;

View File

@ -79,6 +79,7 @@ $nl
{ $subsection continue-with } { $subsection continue-with }
"Continuations as control-flow:" "Continuations as control-flow:"
{ $subsection attempt-all } { $subsection attempt-all }
{ $subsection retry }
{ $subsection with-return } { $subsection with-return }
"Reflecting the datastack:" "Reflecting the datastack:"
{ $subsection with-datastack } { $subsection with-datastack }
@ -237,6 +238,20 @@ HELP: attempt-all
} }
} ; } ;
HELP: retry
{ $values
{ "quot" quotation } { "n" null }
}
{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." }
{ $examples
{ $unchecked-example "USING: continuations math prettyprint ;"
"[ 5 random 0 = ] retry t"
"t"
}
} ;
{ attempt-all retry } related-words
HELP: return HELP: return
{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ; { $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;

View File

@ -154,6 +154,8 @@ ERROR: attempt-all-error ;
] { } make peek swap [ rethrow ] when ] { } make peek swap [ rethrow ] when
] if ; inline ] if ; inline
: retry ( quot: ( -- ? ) n -- ) swap [ drop ] prepose attempt-all ; inline
TUPLE: condition error restarts continuation ; TUPLE: condition error restarts continuation ;
C: <condition> condition ( error restarts cc -- condition ) C: <condition> condition ( error restarts cc -- condition )

View File

@ -26,7 +26,7 @@ GENERIC: effect>string ( obj -- str )
M: string effect>string ; M: string effect>string ;
M: word effect>string name>> ; M: word effect>string name>> ;
M: integer effect>string number>string ; M: integer effect>string number>string ;
M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ; M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
: stack-picture ( seq -- string ) : stack-picture ( seq -- string )
dup integer? [ "object" <repetition> ] when dup integer? [ "object" <repetition> ] when

View File

@ -77,7 +77,7 @@ TUPLE: check-method class generic ;
3tri ; inline 3tri ; inline
: method-word-name ( class word -- string ) : method-word-name ( class word -- string )
[ name>> ] bi@ "=>" swap 3append ; [ name>> ] bi@ "=>" glue ;
PREDICATE: method-body < word PREDICATE: method-body < word
"method-generic" word-prop >boolean ; "method-generic" word-prop >boolean ;

View File

@ -6,7 +6,7 @@ ARTICLE: "floats" "Floats"
"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximation" } ". While rationals can grow to any required precision, floating point numbers are fixed-width, and manipulating them is usually faster than manipulating ratios or bignums (but slower than manipulating fixnums). Floating point numbers are often used to represent irrational numbers, which have no exact representation as a ratio of two integers." "Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximation" } ". While rationals can grow to any required precision, floating point numbers are fixed-width, and manipulating them is usually faster than manipulating ratios or bignums (but slower than manipulating fixnums). Floating point numbers are often used to represent irrational numbers, which have no exact representation as a ratio of two integers."
$nl $nl
"Introducing a floating point number in a computation forces the result to be expressed in floating point." "Introducing a floating point number in a computation forces the result to be expressed in floating point."
{ $example "5/4 1/2 + ." "7/4" } { $example "5/4 1/2 + ." "1+3/4" }
{ $example "5/4 0.5 + ." "1.75" } { $example "5/4 0.5 + ." "1.75" }
"Integers and rationals can be converted to floats:" "Integers and rationals can be converted to floats:"
{ $subsection >float } { $subsection >float }

View File

@ -128,7 +128,7 @@ M: ratio >base
[ [
[ numerator (>base) ] [ numerator (>base) ]
[ denominator (>base) ] bi [ denominator (>base) ] bi
"/" swap 3append "/" glue
] bi* append ] bi* append
negative? get [ CHAR: - prefix ] when negative? get [ CHAR: - prefix ] when
] with-radix ; ] with-radix ;

View File

@ -714,6 +714,26 @@ HELP: 3append
} }
} ; } ;
HELP: surround
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } }
{ $description "Outputs a new sequence with " { $snippet "seq1" } " inserted between " { $snippet "seq2" } " and " { $snippet "seq3" } "." }
{ $examples
{ $example "USING: sequences prettyprint ;"
"\"sssssh\" \"(\" \")\" surround ."
"\"(sssssh)\""
}
} ;
HELP: glue
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } }
{ $description "Outputs a new sequence with " { $snippet "seq3" } " inserted between " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
{ $examples
{ $example "USING: sequences prettyprint ;"
"\"a\" \"b\" \",\" glue ."
"\"a,b\""
}
} ;
HELP: subseq HELP: subseq
{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "subseq" "a new sequence" } } { $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "subseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of all elements starting from and including " { $snippet "from" } ", and up to but not including " { $snippet "to" } "." } { $description "Outputs a new sequence consisting of all elements starting from and including " { $snippet "from" } ", and up to but not including " { $snippet "to" } "." }
@ -1348,6 +1368,8 @@ ARTICLE: "sequences-appending" "Appending sequences"
{ $subsection append } { $subsection append }
{ $subsection prepend } { $subsection prepend }
{ $subsection 3append } { $subsection 3append }
{ $subsection surround }
{ $subsection glue }
{ $subsection concat } { $subsection concat }
{ $subsection join } { $subsection join }
"A pair of words useful for aligning strings:" "A pair of words useful for aligning strings:"

View File

@ -268,3 +268,6 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
[ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] unit-test [ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] unit-test
[ V{ 0 2 } ] [ "a" { "a" "b" "a" } indices ] unit-test [ V{ 0 2 } ] [ "a" { "a" "b" "a" } indices ] unit-test
[ "a,b" ] [ "a" "b" "," glue ] unit-test
[ "(abc)" ] [ "abc" "(" ")" surround ] unit-test

View File

@ -317,6 +317,10 @@ PRIVATE>
: 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ; : 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ;
: surround ( seq1 seq2 seq3 -- newseq ) swapd 3append ; inline
: glue ( seq1 seq2 seq3 -- newseq ) swap 3append ; inline
: change-nth ( i seq quot -- ) : change-nth ( i seq quot -- )
[ [ nth ] dip call ] 3keep drop set-nth ; inline [ [ nth ] dip call ] 3keep drop set-nth ; inline

View File

@ -9,7 +9,7 @@ IN: benchmark.knucleotide
"." split1 rot "." split1 rot
over length over < over length over <
[ CHAR: 0 pad-right ] [ CHAR: 0 pad-right ]
[ head ] if "." swap 3append ; [ head ] if "." glue ;
: discard-lines ( -- ) : discard-lines ( -- )
readln readln

View File

@ -80,7 +80,7 @@ M: check< summary drop "Number exceeds upper bound" ;
[ ":" split1 string>number [ dup length ] unless* ] { } map>assoc ; [ ":" split1 string>number [ dup length ] unless* ] { } map>assoc ;
: define-slots ( prefix names quots -- ) : define-slots ( prefix names quots -- )
>r [ "-" swap 3append create-in ] with map r> >r [ "-" glue create-in ] with map r>
[ define ] 2each ; [ define ] 2each ;
: define-accessors ( classname slots -- ) : define-accessors ( classname slots -- )

View File

@ -135,9 +135,6 @@ MACRO: multikeep ( word out-indexes -- ... )
r> [ drop \ r> , ] each r> [ drop \ r> , ] each
] [ ] make ; ] [ ] make ;
: retry ( quot n -- )
[ drop ] rot compose attempt-all ; inline
: do-while ( pred body tail -- ) : do-while ( pred body tail -- )
[ tuck 2slip ] dip while ; inline [ tuck 2slip ] dip while ; inline

View File

@ -285,7 +285,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
[ get-label ] [ get-label ]
[ skip-label get-name ] [ skip-label get-name ]
2bi 2bi
"." swap 3append "." glue
] ]
} }
} }

View File

@ -5,7 +5,7 @@ IN: hardware-info.windows.ce
: memory-status ( -- MEMORYSTATUS ) : memory-status ( -- MEMORYSTATUS )
"MEMORYSTATUS" <c-object> "MEMORYSTATUS" <c-object>
"MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
[ GlobalMemoryStatus ] keep ; dup GlobalMemoryStatus ;
M: wince cpus ( -- n ) 1 ; M: wince cpus ( -- n ) 1 ;

View File

@ -3,16 +3,13 @@ kernel libc math namespaces hardware-info.backend
windows windows.advapi32 windows.kernel32 system ; windows windows.advapi32 windows.kernel32 system ;
IN: hardware-info.windows.nt IN: hardware-info.windows.nt
: system-info ( -- SYSTEM_INFO )
"SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
M: winnt cpus ( -- n ) M: winnt cpus ( -- n )
system-info SYSTEM_INFO-dwNumberOfProcessors ; system-info SYSTEM_INFO-dwNumberOfProcessors ;
: memory-status ( -- MEMORYSTATUSEX ) : memory-status ( -- MEMORYSTATUSEX )
"MEMORYSTATUSEX" <c-object> "MEMORYSTATUSEX" <c-object>
"MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
[ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ; dup GlobalMemoryStatusEx win32-error=0/f ;
M: winnt memory-load ( -- n ) M: winnt memory-load ( -- n )
memory-status MEMORYSTATUSEX-dwMemoryLoad ; memory-status MEMORYSTATUSEX-dwMemoryLoad ;
@ -35,21 +32,12 @@ M: winnt total-virtual-mem ( -- n )
M: winnt available-virtual-mem ( -- n ) M: winnt available-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailVirtual ; memory-status MEMORYSTATUSEX-ullAvailVirtual ;
: pull-win32-string ( alien -- string )
[ utf16n alien>string ] keep free ;
: computer-name ( -- string ) : computer-name ( -- string )
MAX_COMPUTERNAME_LENGTH 1+ [ malloc ] keep MAX_COMPUTERNAME_LENGTH 1+
<int> dupd GetComputerName zero? [ [ <byte-array> dup ] keep <uint>
free win32-error f GetComputerName win32-error=0/f alien>native-string ;
] [
pull-win32-string
] if ;
: username ( -- string ) : username ( -- string )
UNLEN 1+ [ malloc ] keep UNLEN 1+
<int> dupd GetUserName zero? [ [ <byte-array> dup ] keep <uint>
free win32-error f GetUserName win32-error=0/f alien>native-string ;
] [
pull-win32-string
] if ;

View File

@ -21,7 +21,7 @@ IN: hardware-info.windows
: os-version ( -- os-version ) : os-version ( -- os-version )
"OSVERSIONINFO" <c-object> "OSVERSIONINFO" <c-object>
"OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize "OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize
[ GetVersionEx ] keep swap zero? [ win32-error ] when ; dup GetVersionEx win32-error=0/f ;
: windows-major ( -- n ) : windows-major ( -- n )
os-version OSVERSIONINFO-dwMajorVersion ; os-version OSVERSIONINFO-dwMajorVersion ;
@ -36,7 +36,7 @@ IN: hardware-info.windows
os-version OSVERSIONINFO-dwPlatformId ; os-version OSVERSIONINFO-dwPlatformId ;
: windows-service-pack ( -- string ) : windows-service-pack ( -- string )
os-version OSVERSIONINFO-szCSDVersion utf16n alien>string ; os-version OSVERSIONINFO-szCSDVersion alien>native-string ;
: feature-present? ( n -- ? ) : feature-present? ( n -- ? )
IsProcessorFeaturePresent zero? not ; IsProcessorFeaturePresent zero? not ;
@ -51,8 +51,8 @@ IN: hardware-info.windows
"ushort" <c-array> ; "ushort" <c-array> ;
: get-directory ( word -- str ) : get-directory ( word -- str )
>r MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd r> [ MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd ] dip
execute win32-error=0/f utf16n alien>string ; inline execute win32-error=0/f alien>native-string ; inline
: windows-directory ( -- str ) : windows-directory ( -- str )
\ GetWindowsDirectory get-directory ; \ GetWindowsDirectory get-directory ;

View File

@ -31,7 +31,7 @@ M: object handle-message drop ;
"git-log" , "git-log" ,
"--no-merges" , "--no-merges" ,
"--pretty=format:%h %an: %s" , "--pretty=format:%h %an: %s" ,
".." swap 3append , ".." glue ,
] { } make ] { } make
latin1 [ input-stream get lines ] with-process-reader ; latin1 [ input-stream get lines ] with-process-reader ;

View File

@ -1,7 +1,15 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: tools.test math.floating-point math.constants kernel ; USING: tools.test math.floating-point math.constants kernel
math.constants fry sequences kernel math ;
IN: math.floating-point.tests IN: math.floating-point.tests
[ t ] [ pi >double< >double pi = ] unit-test [ t ] [ pi >double< >double pi = ] unit-test
[ t ] [ -1.0 >double< >double -1.0 = ] unit-test [ t ] [ -1.0 >double< >double -1.0 = ] unit-test
[ t ] [ 1/0. infinity? ] unit-test
[ t ] [ -1/0. infinity? ] unit-test
[ f ] [ 0/0. infinity? ] unit-test
[ f ] [ 10. infinity? ] unit-test
[ f ] [ -10. infinity? ] unit-test
[ f ] [ 0. infinity? ] unit-test

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences prettyprint math.parser io USING: kernel math sequences prettyprint math.parser io
math.functions math.bitwise ; math.functions math.bitwise combinators.short-circuit ;
IN: math.floating-point IN: math.floating-point
: (double-sign) ( bits -- n ) -63 shift ; inline : (double-sign) ( bits -- n ) -63 shift ; inline
@ -37,3 +37,10 @@ IN: math.floating-point
(double-mantissa-bits) >bin 52 CHAR: 0 pad-left (double-mantissa-bits) >bin 52 CHAR: 0 pad-left
11 [ bl ] times print 11 [ bl ] times print
] tri ; ] tri ;
: infinity? ( double -- ? )
double>bits
{
[ (double-exponent-bits) 11 on-bits = ]
[ (double-mantissa-bits) 0 = ]
} 1&& ;

View File

@ -56,7 +56,7 @@ SYMBOL: and-needed?
: text-with-scale ( index seq -- str ) : text-with-scale ( index seq -- str )
[ nth 3digits>text ] [ drop scale-numbers ] 2bi [ nth 3digits>text ] [ drop scale-numbers ] 2bi
[ " " swap 3append ] unless-empty ; [ " " glue ] unless-empty ;
: append-with-conjunction ( str1 str2 -- newstr ) : append-with-conjunction ( str1 str2 -- newstr )
over length zero? [ over length zero? [

View File

@ -12,7 +12,7 @@ CHAR: $ \ currency-token set-global
: (money>string) ( dollars cents -- string ) : (money>string) ( dollars cents -- string )
[ number>string ] bi@ [ number>string ] bi@
[ <reversed> 3 group "," join <reversed> ] [ <reversed> 3 group "," join <reversed> ]
[ 2 CHAR: 0 pad-left ] bi* "." swap 3append ; [ 2 CHAR: 0 pad-left ] bi* "." glue ;
: money>string ( object -- string ) : money>string ( object -- string )
dollars/cents (money>string) currency-token get prefix ; dollars/cents (money>string) currency-token get prefix ;

View File

@ -28,7 +28,7 @@ IN: printf
[ 0 ] [ string>number ] if-empty ; [ 0 ] [ string>number ] if-empty ;
: pad-digits ( string digits -- string' ) : pad-digits ( string digits -- string' )
[ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." swap 3append ; [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ;
: max-digits ( n digits -- n' ) : max-digits ( n digits -- n' )
10 swap ^ [ * round ] keep / ; 10 swap ^ [ * round ] keep / ;

View File

@ -3,3 +3,4 @@ IN: project-euler.002.tests
[ 4613732 ] [ euler002 ] unit-test [ 4613732 ] [ euler002 ] unit-test
[ 4613732 ] [ euler002a ] unit-test [ 4613732 ] [ euler002a ] unit-test
[ 4613732 ] [ euler002b ] unit-test

View File

@ -1,4 +1,4 @@
! Copyright (c) 2007 Aaron Schaefer, Alexander Solovyov. ! Copyright (c) 2007, 2008 Aaron Schaefer, Alexander Solovyov, Vishal Talwar.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences shuffle ; USING: kernel math sequences shuffle ;
IN: project-euler.002 IN: project-euler.002
@ -50,4 +50,31 @@ PRIVATE>
! [ euler002a ] 100 ave-time ! [ euler002a ] 100 ave-time
! 0 ms ave run time - 0.2 SD (100 trials) ! 0 ms ave run time - 0.2 SD (100 trials)
MAIN: euler002a
<PRIVATE
: next-fibs ( x y -- y x+y )
tuck + ;
: ?retotal ( total fib- fib+ -- retotal fib- fib+ )
dup even? [ [ nip + ] 2keep ] when ;
: (sum-even-fibs-below) ( partial fib- fib+ max -- total )
2dup > [
3drop
] [
[ ?retotal next-fibs ] dip (sum-even-fibs-below)
] if ;
PRIVATE>
: sum-even-fibs-below ( max -- sum )
[ 0 0 1 ] dip (sum-even-fibs-below) ;
: euler002b ( -- answer )
4000000 sum-even-fibs-below ;
! [ euler002b ] 100 ave-time
! 0 ms ave run time - 0.0 SD (100 trials)
MAIN: euler002b

View File

@ -0,0 +1,6 @@
USING: project-euler.050 project-euler.050.private tools.test ;
IN: project-euler.050.tests
[ 41 ] [ 100 solve ] unit-test
[ 953 ] [ 1000 solve ] unit-test
[ 997651 ] [ euler050 ] unit-test

View File

@ -0,0 +1,90 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel locals math math.primes sequences ;
IN: project-euler.050
! http://projecteuler.net/index.php?section=problems&id=50
! DESCRIPTION
! -----------
! The prime 41, can be written as the sum of six consecutive primes:
! 41 = 2 + 3 + 5 + 7 + 11 + 13
! This is the longest sum of consecutive primes that adds to a prime below
! one-hundred.
! The longest sum of consecutive primes below one-thousand that adds to a
! prime, contains 21 terms, and is equal to 953.
! Which prime, below one-million, can be written as the sum of the most
! consecutive primes?
! SOLUTION
! --------
! 1) Create an sequence of all primes under 1000000.
! 2) Start summing elements in the sequence until the next number would put you
! over 1000000.
! 3) Check if that sum is prime, if not, subtract the last number added.
! 4) Repeat step 3 until you get a prime number, and store it along with the
! how many consecutive numbers from the original sequence it took to get there.
! 5) Drop the first number from the sequence of primes, and do steps 2-4 again
! 6) Compare the longest chain from the first run with the second run, and store
! the longer of the two.
! 7) If the sequence of primes is still longer than the longest chain, then
! repeat steps 5-7...otherwise, you've found the longest sum of consecutive
! primes!
<PRIVATE
:: sum-upto ( seq limit -- length sum )
0 seq [ + dup limit > ] find
[ swapd - ] [ drop seq length swap ] if* ;
: pop-until-prime ( seq sum -- seq prime )
over length 0 > [
[ unclip-last-slice ] dip swap -
dup prime? [ pop-until-prime ] unless
] [
2drop { } 0
] if ;
! a pair is { length of chain, prime the chain sums to }
: longest-prime ( seq limit -- pair )
dupd sum-upto dup prime? [
2array nip
] [
[ head-slice ] dip pop-until-prime
[ length ] dip 2array
] if ;
: longest ( pair pair -- longest )
2dup [ first ] bi@ > [ drop ] [ nip ] if ;
: continue? ( pair seq -- ? )
[ first ] [ length 1- ] bi* < ;
: (find-longest) ( best seq limit -- best )
[ longest-prime longest ] 2keep 2over continue? [
[ rest-slice ] dip (find-longest)
] [ 2drop ] if ;
: find-longest ( seq limit -- best )
{ 1 2 } -rot (find-longest) ;
: solve ( n -- answer )
[ primes-upto ] keep find-longest second ;
PRIVATE>
: euler050 ( -- answer )
1000000 solve ;
! [ euler050 ] 100 ave-time
! 291 ms run / 20.6 ms GC ave time - 100 trials
MAIN: euler050

View File

@ -1,21 +1,24 @@
! Copyright (c) 2007 Aaron Schaefer. ! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: continuations fry io kernel make math math.functions math.parser USING: continuations fry io kernel make math math.functions math.parser
math.statistics memory tools.time ; math.statistics memory tools.time ;
IN: project-euler.ave-time IN: project-euler.ave-time
: nth-place ( x n -- y )
10 swap ^ [ * round >integer ] keep /f ;
: collect-benchmarks ( quot n -- seq ) : collect-benchmarks ( quot n -- seq )
[ [
[ datastack ] [ datastack ]
[ '[ _ gc benchmark , ] tuck '[ _ _ with-datastack drop ] ] [
'[ _ gc benchmark 1000 / , ] tuck
'[ _ _ with-datastack drop ]
]
[ 1- ] tri* swap times call [ 1- ] tri* swap times call
] { } make ; inline ] { } make ; inline
: nth-place ( x n -- y )
10 swap ^ [ * round ] keep / ;
: ave-time ( quot n -- ) : ave-time ( quot n -- )
[ collect-benchmarks ] keep swap [ collect-benchmarks ] keep swap
[ std 2 nth-place ] [ mean round ] bi [ [ std 2 nth-place ] [ mean round >integer ] bi [
# " ms ave run time - " % # " SD (" % # " trials)" % # " ms ave run time - " % # " SD (" % # " trials)" %
] "" make print flush ; inline ] "" make print flush ; inline

View File

@ -23,11 +23,11 @@ IN: sequences.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: each-percent ( seq quot -- ) : each-percent ( seq quot -- )
>r [
dup length dup length
dup [ / ] curry dup [ / ] curry
[ 1+ ] prepose [ 1+ ] prepose
r> compose ] dip compose
2each ; inline 2each ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -68,7 +68,7 @@ IN: sequences.lib
: minmax ( seq -- min max ) : minmax ( seq -- min max )
#! find the min and max of a seq in one pass #! find the min and max of a seq in one pass
1/0. -1/0. rot [ tuck max >r min r> ] each ; 1/0. -1/0. rot [ tuck max [ min ] dip ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -78,7 +78,7 @@ IN: sequences.lib
: (monotonic-split) ( seq quot -- newseq ) : (monotonic-split) ( seq quot -- newseq )
[ [
>r dup unclip suffix r> [ dup unclip suffix ] dip
v, [ pick ,, call [ v, ] unless ] curry 2each ,v v, [ pick ,, call [ v, ] unless ] curry 2each ,v
] { } make ; ] { } make ;
@ -88,7 +88,7 @@ IN: sequences.lib
ERROR: element-not-found ; ERROR: element-not-found ;
: split-around ( seq quot -- before elem after ) : split-around ( seq quot -- before elem after )
dupd find over [ element-not-found ] unless dupd find over [ element-not-found ] unless
>r cut rest r> swap ; inline [ cut rest ] dip swap ; inline
: map-until ( seq quot pred -- newseq ) : map-until ( seq quot pred -- newseq )
'[ [ @ dup @ [ drop t ] [ , f ] if ] find 2drop ] { } make ; '[ [ @ dup @ [ drop t ] [ , f ] if ] find 2drop ] { } make ;
@ -115,14 +115,14 @@ ERROR: element-not-found ;
PRIVATE> PRIVATE>
: exact-strings ( alphabet length -- seqs ) : exact-strings ( alphabet length -- seqs )
>r dup length r> exact-number-strings map-alphabet ; [ dup length ] dip exact-number-strings map-alphabet ;
: strings ( alphabet length -- seqs ) : strings ( alphabet length -- seqs )
>r dup length r> number-strings map-alphabet ; [ dup length ] dip number-strings map-alphabet ;
: switches ( seq1 seq -- subseq ) : switches ( seq1 seq -- subseq )
! seq1 is a sequence of ones and zeroes ! seq1 is a sequence of ones and zeroes
>r [ length ] keep [ nth 1 = ] curry filter r> [ [ length ] keep [ nth 1 = ] curry filter ] dip
[ nth ] curry { } map-as ; [ nth ] curry { } map-as ;
: power-set ( seq -- subsets ) : power-set ( seq -- subsets )
@ -147,7 +147,3 @@ PRIVATE>
dup length 1 (a,b] [ dup random pick exchange ] each ; dup length 1 (a,b] [ dup random pick exchange ] each ;
: enumerate ( seq -- seq' ) <enum> >alist ; : enumerate ( seq -- seq' ) <enum> >alist ;
: splice ( left-seq right-seq seq -- newseq ) swap 3append ;
: surround ( seq left-seq right-seq -- newseq ) swapd 3append ;

View File

@ -50,7 +50,7 @@ M: entity feed-entry-date date>> ;
TUPLE: post < entity title comments ; TUPLE: post < entity title comments ;
M: post feed-entry-title M: post feed-entry-title
[ author>> ] [ title>> ] bi ": " swap 3append ; [ author>> ] [ title>> ] bi ": " glue ;
M: post entity-url M: post entity-url
id>> view-post-url ; id>> view-post-url ;