: 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
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 '[
dup blocks-with-gc [
over compute-uninitialized-sets
[ insert-gc-check ] each
- ] unless-empty ;
\ No newline at end of file
+ ] unless-empty ;
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 ;
[ 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
\ No newline at end of file
+[ 25997 ] [ 299999 sieve [ bit-count ] map-sum 2 + ] unit-test
[ 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
dup length 1 <= [
drop 0
] [
- [ [ mean ] keep [ - sq ] with sigma ]
+ [ [ mean ] keep [ - sq ] with map-sum ]
[ length 1 - ] bi /
] if ;
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
: >ROMAN ( n -- str ) >roman >upper ;
: roman> ( str -- n )
- >lower [ roman>= ] monotonic-split [ (roman>) ] sigma ;
+ >lower [ roman>= ] monotonic-split [ (roman>) ] map-sum ;
<PRIVATE
[ 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 ;
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 ;
M: paragraph cap-height pack-cap-height ;
-PRIVATE>
\ No newline at end of file
+PRIVATE>
} 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 )
[
{ $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
- "! Find the sum of the squares [0,99]"
"USING: math math.ranges sequences prettyprint ;"
- "100 [1,b] [ sq ] sigma ."
+ "100 [1,b] [ sq ] map-sum ."
"338350"
} ;
[ "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
: 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
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 }
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 ;
[ 1 + ] change-x
[ 1 - ] change-y
[ 1 + 2 / ] change-z
- ] map [ z>> ] sigma
- ] sigma . ;
+ ] map [ z>> ] map-sum
+ ] map-sum . ;
MAIN: tuple-array-benchmark
{ [ = 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)
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>
<PRIVATE
: sum-fifth-powers ( n -- sum )
- number>digits [ 5 ^ ] sigma ;
+ number>digits [ 5 ^ ] map-sum ;
PRIVATE>
{ 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>
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)
! --------
: 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
! --------
: 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)
! 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)
! 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)
{ 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>
<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 ;
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>
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)
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 ;
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
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 ;
projects / factor.git / commitdiff