steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

assocs.extras: move assocs extras words here.

db4
John Benediktsson 2012-09-26 15:33:40 -07:00
parent 1fe94e4184
commit c1fe403b98
2 changed files with 16 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
extra/assocs/extras/extras.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2012 John Benediktsson ! Copyright (C) 2012 John Benediktsson, Doug Coleman
! See http://factorcode.org/license.txt for BSD license ! See http://factorcode.org/license.txt for BSD license
USING: arrays assocs assocs.private kernel sequences ; USING: arrays assocs assocs.private kernel sequences ;
@ -21,3 +21,18 @@ IN: assocs.extras
: substitute! ( seq assoc -- seq ) : substitute! ( seq assoc -- seq )
substituter map! ; substituter map! ;
: assoc-reduce ( ... assoc identity quot: ( ... prev key value -- next ) -- ... result )
[ >alist ] 2dip [ first2 ] prepose reduce ; inline
: reduce-keys ( ... assoc identity quot: ( ... prev elt -- ... next ) -- ... result )
[ drop ] prepose assoc-reduce ; inline
: reduce-values ( ... assoc identity quot: ( ... prev elt -- ... next ) -- ... result )
[ nip ] prepose assoc-reduce ; inline
: sum-keys ( assoc -- n ) 0 [ + ] reduce-keys ; inline
: sum-values ( assoc -- n ) 0 [ + ] reduce-values ; inline

13
extra/sequences/extras/extras.factor
View File

@ -337,18 +337,5 @@ PRIVATE>
: reverse-as ( seq exemplar -- newseq ) : reverse-as ( seq exemplar -- newseq )
[ (reverse) ] [ like ] bi* ; [ (reverse) ] [ like ] bi* ;
: assoc-reduce ( ... assoc identity quot: ( ... prev key value -- next ) -- ... result )
[ >alist ] 2dip [ first2 ] prepose reduce ; inline
: reduce-keys ( ... assoc identity quot: ( ... prev elt -- ... next ) -- ... result )
[ drop ] prepose assoc-reduce ; inline
: reduce-values ( ... assoc identity quot: ( ... prev elt -- ... next ) -- ... result )
[ nip ] prepose assoc-reduce ; inline
: sum-keys ( assoc -- n ) 0 [ + ] reduce-keys ; inline
: sum-values ( assoc -- n ) 0 [ + ] reduce-values ; inline
: map-product ( ... seq quot: ( ... elt -- ... n ) -- ... n ) : map-product ( ... seq quot: ( ... elt -- ... n ) -- ... n )
[ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline [ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline