Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-10-30 00:42:37 -05:00
commit 1cf45abf06
33 changed files with 43 additions and 43 deletions

View File

@ -162,7 +162,7 @@ IN: compiler.cfg.builder.tests
: count-insns ( quot insn-check -- ? )
[ test-mr [ instructions>> ] map ] dip
'[ _ count ] sigma ; inline
'[ _ count ] map-sum ; inline
: contains-insn? ( quot insn-check -- ? )
count-insns 0 > ; inline

View File

@ -26,7 +26,7 @@ M: ##box-alien allocation-size* drop 4 cells ;
M: ##box-displaced-alien allocation-size* drop 4 cells ;
: allocation-size ( bb -- n )
instructions>> [ ##allocation? ] filter [ allocation-size* ] sigma ;
instructions>> [ ##allocation? ] filter [ allocation-size* ] map-sum ;
: insert-gc-check ( bb -- )
dup dup '[
@ -44,4 +44,4 @@ M: ##box-displaced-alien allocation-size* drop 4 cells ;
dup blocks-with-gc [
over compute-uninitialized-sets
[ insert-gc-check ] each
] unless-empty ;
] unless-empty ;

View File

@ -32,7 +32,7 @@ PREDICATE: fry-specifier < word { _ @ } member-eq? ;
GENERIC: count-inputs ( quot -- n )
M: callable count-inputs [ count-inputs ] sigma ;
M: callable count-inputs [ count-inputs ] map-sum ;
M: fry-specifier count-inputs drop 1 ;
M: object count-inputs drop 0 ;

View File

@ -7,4 +7,4 @@ USING: byte-arrays math math.bitwise math.primes.erato sequences tools.test ;
[ t ] [ 113 100 sieve marked-prime? ] unit-test
! There are 25997 primes below 300000. 1 must be removed and 3 5 7 added.
[ 25997 ] [ 299999 sieve [ bit-count ] sigma 2 + ] unit-test
[ 25997 ] [ 299999 sieve [ bit-count ] map-sum 2 + ] unit-test

View File

@ -12,7 +12,7 @@ IN: math.statistics
[ length ] [ product ] bi nth-root ;
: harmonic-mean ( seq -- x )
[ recip ] sigma recip ;
[ recip ] map-sum recip ;
:: kth-smallest ( seq k -- elt )
#! Wirth's method, Algorithm's + Data structues = Programs p. 84
@ -75,7 +75,7 @@ IN: math.statistics
dup length 1 <= [
drop 0
] [
[ [ mean ] keep [ - sq ] with sigma ]
[ [ mean ] keep [ - sq ] with map-sum ]
[ length 1 - ] bi /
] if ;

View File

@ -97,7 +97,7 @@ MACRO: pack ( str -- quot )
packed-length-table at ; inline
: packed-length ( str -- n )
[ ch>packed-length ] sigma ;
[ ch>packed-length ] map-sum ;
: pack-native ( seq str -- seq )
'[ _ _ pack ] with-native-endian ; inline

View File

@ -43,7 +43,7 @@ PRIVATE>
: >ROMAN ( n -- str ) >roman >upper ;
: roman> ( str -- n )
>lower [ roman>= ] monotonic-split [ (roman>) ] sigma ;
>lower [ roman>= ] monotonic-split [ (roman>) ] map-sum ;
<PRIVATE

View File

@ -19,7 +19,7 @@ IN: tools.profiler
[ dup counter>> ] map-counters ;
: cumulative-counters ( obj quot -- alist )
'[ dup @ [ counter>> ] sigma ] map-counters ; inline
'[ dup @ [ counter>> ] map-sum ] map-counters ; inline
: vocab-counters ( -- alist )
vocabs [ words [ predicate? not ] filter ] cumulative-counters ;

View File

@ -40,13 +40,13 @@ TUPLE: line words height ;
dup wrap-words [ <line> ] map ;
: line-width ( wrapped-line -- n )
[ break?>> ] trim-tail-slice [ width>> ] sigma ;
[ break?>> ] trim-tail-slice [ width>> ] map-sum ;
: max-line-width ( wrapped-paragraph -- x )
[ words>> line-width ] [ max ] map-reduce ;
: sum-line-heights ( wrapped-paragraph -- y )
[ height>> ] sigma ;
[ height>> ] map-sum ;
M: paragraph pref-dim*
wrap-paragraph [ max-line-width ] [ sum-line-heights ] bi 2array ;
@ -82,4 +82,4 @@ M: paragraph baseline
M: paragraph cap-height pack-cap-height ;
PRIVATE>
PRIVATE>

View File

@ -118,7 +118,7 @@ ERROR: bad-superclass class ;
} case define-predicate ;
: class-size ( class -- n )
superclasses [ "slots" word-prop length ] sigma ;
superclasses [ "slots" word-prop length ] map-sum ;
: (instance-check-quot) ( class -- quot )
[

View File

@ -975,12 +975,12 @@ HELP: produce-as
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence of type " { $snippet "exemplar" } " at the end." }
{ $examples "See " { $link produce } " for examples." } ;
HELP: sigma
HELP: map-sum
{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
{ $description "Like map sum, but without creating an intermediate sequence." }
{ $example
"USING: math math.ranges sequences prettyprint ;"
"100 [1,b] [ sq ] sigma ."
"100 [1,b] [ sq ] map-sum ."
"338350"
} ;

View File

@ -243,7 +243,7 @@ unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-head ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-tail ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
[ 328350 ] [ 100 [ sq ] map-sum ] unit-test
[ 50 ] [ 100 [ even? ] count ] unit-test
[ 50 ] [ 100 [ odd? ] count ] unit-test

View File

@ -932,10 +932,10 @@ PRIVATE>
: supremum ( seq -- n ) [ ] [ max ] map-reduce ;
: sigma ( seq quot -- n )
: map-sum ( seq quot -- n )
[ 0 ] 2dip [ dip + ] curry [ swap ] prepose each ; inline
: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
: count ( seq quot -- n ) [ 1 0 ? ] compose map-sum ; inline
! We hand-optimize flip to such a degree because type hints
! cannot express that an array is an array of arrays yet, and

View File

@ -38,9 +38,9 @@ MEMO: 24-from-4 ( a b c d -- ? )
1 10 [a,b] [| d |
a b c d 24-from-4
] count
] sigma
] sigma
] sigma ;
] map-sum
] map-sum
] map-sum ;
CONSTANT: words { 24-from-1 24-from-2 24-from-3 24-from-4 }

View File

@ -4,7 +4,7 @@ USING: kernel math math.combinatorics math.ranges sequences ;
IN: benchmark.e-ratios
: calculate-e-ratios ( n -- e )
iota [ factorial recip ] sigma ;
iota [ factorial recip ] map-sum ;
: calculate-e-ratios-benchmark ( -- )
5 [ 300 calculate-e-ratios drop ] times ;

View File

@ -14,7 +14,7 @@ TUPLE-ARRAY: point
[ 1 + ] change-x
[ 1 - ] change-y
[ 1 + 2 / ] change-z
] map [ z>> ] sigma
] sigma . ;
] map [ z>> ] map-sum
] map-sum . ;
MAIN: tuple-array-benchmark

View File

@ -18,7 +18,7 @@ PRIVATE>
:: passwd-md5 ( magic salt password -- bytes )
password magic salt 3append
salt password tuck 3append md5 checksum-bytes
salt password dup surround md5 checksum-bytes
password length
[ 16 / ceiling swap <repetition> concat ] keep
head-slice append
@ -42,7 +42,7 @@ PRIVATE>
11 final nth 2 to64 3append ;
: parse-shadow-password ( string -- magic salt password )
"$" split harvest first3 [ "$" tuck 3append ] 2dip ;
"$" split harvest first3 [ "$" dup surround ] 2dip ;
: authenticate-password ( shadow password -- ? )
'[ parse-shadow-password drop _ passwd-md5 ] keep = ;

View File

@ -30,7 +30,7 @@ IN: project-euler.021
{ [ = not ] [ sum-proper-divisors = ] } 2&& ;
: euler021 ( -- answer )
10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ;
10000 [1,b] [ dup amicable? [ drop 0 ] unless ] map-sum ;
! [ euler021 ] 100 ave-time
! 335 ms ave run time - 18.63 SD (100 trials)

View File

@ -33,7 +33,7 @@ IN: project-euler.028
dup 1 = [ [ sq 4 * ] [ 6 * ] bi - 6 + ] unless ;
: sum-diags ( n -- sum )
1 swap 2 <range> [ sum-corners ] sigma ;
1 swap 2 <range> [ sum-corners ] map-sum ;
PRIVATE>

View File

@ -33,7 +33,7 @@ IN: project-euler.030
<PRIVATE
: sum-fifth-powers ( n -- sum )
number>digits [ 5 ^ ] sigma ;
number>digits [ 5 ^ ] map-sum ;
PRIVATE>

View File

@ -34,7 +34,7 @@ IN: project-euler.034
{ 1 1 2 6 24 120 720 5040 40320 362880 } nth ;
: factorion? ( n -- ? )
dup number>digits [ digit-factorial ] sigma = ;
dup number>digits [ digit-factorial ] map-sum = ;
PRIVATE>

View File

@ -92,7 +92,7 @@ PRIVATE>
PRIVATE>
: euler043a ( -- answer )
interesting-pandigitals [ 10 digits>integer ] sigma ;
interesting-pandigitals [ 10 digits>integer ] map-sum ;
! [ euler043a ] 100 ave-time
! 10 ms ave run time - 1.37 SD (100 trials)

View File

@ -18,7 +18,7 @@ IN: project-euler.048
! --------
: euler048 ( -- answer )
1000 [1,b] [ dup ^ ] sigma 10 10^ mod ;
1000 [1,b] [ dup ^ ] map-sum 10 10^ mod ;
! [ euler048 ] 100 ave-time
! 276 ms run / 1 ms GC ave time - 100 trials

View File

@ -27,7 +27,7 @@ IN: project-euler.053
! --------
: euler053 ( -- answer )
23 100 [a,b] [ dup [ nCk 1000000 > ] with count ] sigma ;
23 100 [a,b] [ dup [ nCk 1000000 > ] with count ] map-sum ;
! [ euler053 ] 100 ave-time
! 52 ms ave run time - 4.44 SD (100 trials)

View File

@ -29,7 +29,7 @@ IN: project-euler.063
! Round down since we already know that particular value of n is no good.
: euler063 ( -- answer )
9 [1,b] [ log [ 10 log dup ] dip - /i ] sigma ;
9 [1,b] [ log [ 10 log dup ] dip - /i ] map-sum ;
! [ euler063 ] 100 ave-time
! 0 ms ave run time - 0.0 SD (100 trials)

View File

@ -30,7 +30,7 @@ IN: project-euler.072
! The answer can be found by adding totient(n) for 2 ≤ n ≤ 1e6
: euler072 ( -- answer )
2 1000000 [a,b] [ totient ] sigma ;
2 1000000 [a,b] [ totient ] map-sum ;
! [ euler072 ] 100 ave-time
! 5274 ms ave run time - 102.7 SD (100 trials)

View File

@ -48,7 +48,7 @@ IN: project-euler.074
{ 1 1 2 6 24 120 720 5040 40320 362880 } nth ;
: digits-factorial-sum ( n -- n )
number>digits [ digit-factorial ] sigma ;
number>digits [ digit-factorial ] map-sum ;
: chain-length ( n -- n )
61 <hashtable>

View File

@ -29,7 +29,7 @@ IN: project-euler.092
<PRIVATE
: next-link ( n -- m )
number>digits [ sq ] sigma ;
number>digits [ sq ] map-sum ;
: chain-ending ( n -- m )
dup [ 1 = ] [ 89 = ] bi or [ next-link chain-ending ] unless ;

View File

@ -47,7 +47,7 @@ IN: project-euler.116
V{ 1 } clone [ [ next ] 2curry times ] keep last 1 - ;
: (euler116) ( length -- permutations )
3 [1,b] [ ways ] with sigma ;
3 [1,b] [ ways ] with map-sum ;
PRIVATE>

View File

@ -46,7 +46,7 @@ PRIVATE>
m [1,b] [| i | 2 i * m 1 + / i ^ ] PI ;
: euler190 ( -- answer )
2 15 [a,b] [ P_m truncate ] sigma ;
2 15 [a,b] [ P_m truncate ] map-sum ;
! [ euler150 ] 100 ave-time
! 5 ms ave run time - 1.01 SD (100 trials)

View File

@ -57,7 +57,7 @@ IN: project-euler.common
PRIVATE>
: alpha-value ( str -- n )
>lower [ CHAR: a - 1 + ] sigma ;
>lower [ CHAR: a - 1 + ] map-sum ;
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
[ [ 2array ] with map ] curry map concat ;

View File

@ -53,7 +53,7 @@ syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* c
syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect assoc-refine update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* assoc-map-as >alist assoc-filter-as clear-assoc assoc-stack maybe-set-at substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip
syn keyword factorKeyword case execute-effect no-cond no-case? 3cleave>quot 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case case>quot 3cleave wrong-values to-fixed-point alist>quot case-find cond cleave call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot
syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex <fp-nan> < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f
syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter! last-index-from reversed index-from cut* pad-tail (indices) concat-as remove-eq but-last snip trim-tail nths nth 2pusher sequence slice? <slice> partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length remove-eq! drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift delete sigma new-sequence follow like remove-nth! first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse! sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head last replicate set-fourth shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode member-eq? pop set-nth ?nth <flat-slice> second map! join when-empty accumulator immutable-sequence? <reversed> all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? <repetition> trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim
syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter! last-index-from reversed index-from cut* pad-tail (indices) concat-as remove-eq but-last snip trim-tail nths nth 2pusher sequence slice? <slice> partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length remove-eq! drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift remove! map-sum new-sequence follow like remove-nth! first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse! sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head last replicate set-fourth shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode member-eq? pop set-nth ?nth <flat-slice> second map! join when-empty accumulator immutable-sequence? <reversed> all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? <repetition> trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim
syn keyword factorKeyword global +@ change set-namestack change-global init-namespaces on off set-global namespace set with-scope bind with-variable inc dec counter initialize namestack get get-global make-assoc
syn keyword factorKeyword <array> 2array 3array pair >array 1array 4array pair? array resize-array array?
syn keyword factorKeyword +character+ bad-seek-type? readln stream-seek read print with-output-stream contents write1 stream-write1 stream-copy stream-element-type with-input-stream stream-print stream-read stream-contents bl seek-output bad-seek-type nl stream-nl write flush stream-lines +byte+ stream-flush read1 seek-absolute? stream-read1 lines stream-readln stream-read-until each-line seek-end with-output-stream* seek-absolute with-streams seek-input seek-relative? input-stream stream-write read-partial seek-end? seek-relative error-stream read-until with-input-stream* with-streams* each-block output-stream stream-read-partial

View File

@ -34,7 +34,7 @@ M: graph num-vertices
vertices length ;
M: graph num-edges
[ vertices ] [ '[ _ adjlist length ] sigma ] bi ;
[ vertices ] [ '[ _ adjlist length ] map-sum ] bi ;
M: graph adjlist
[ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;