1 ! Copyright (C) 2012 John Benediktsson, Doug Coleman
2 ! See http://factorcode.org/license.txt for BSD license
3 USING: arrays assocs assocs.private fry generalizations kernel
4 math math.statistics sequences sequences.extras sets ;
7 : deep-at ( assoc seq -- value/f )
10 : substitute! ( seq assoc -- seq )
13 : assoc-reduce ( ... assoc identity quot: ( ... prev key value -- next ) -- ... result )
14 [ >alist ] 2dip [ first2 ] prepose reduce ; inline
16 : reduce-keys ( ... assoc identity quot: ( ... prev elt -- ... next ) -- ... result )
17 [ drop ] prepose assoc-reduce ; inline
19 : reduce-values ( ... assoc identity quot: ( ... prev elt -- ... next ) -- ... result )
20 [ nip ] prepose assoc-reduce ; inline
22 : sum-keys ( assoc -- n ) 0 [ + ] reduce-keys ; inline
24 : sum-values ( assoc -- n ) 0 [ + ] reduce-values ; inline
26 : map-keys ( assoc quot: ( key -- key' ) -- assoc )
27 '[ _ dip ] assoc-map ; inline
29 : map-values ( assoc quot: ( value -- value' ) -- assoc )
30 '[ swap _ dip swap ] assoc-map ; inline
32 : filter-keys ( assoc quot: ( key -- key' ) -- assoc' )
33 '[ drop @ ] assoc-filter ; inline
35 : filter-values ( assoc quot: ( value -- value' ) -- assoc' )
36 '[ nip @ ] assoc-filter ; inline
38 : reject-keys ( assoc quot: ( key -- key' ) -- assoc' )
39 '[ drop @ ] assoc-reject ; inline
41 : reject-values ( assoc quot: ( value -- value' ) -- assoc' )
42 '[ nip @ ] assoc-reject ; inline
44 : rekey-new-assoc ( assoc keys -- newassoc )
45 [ tuck of ] with H{ } map>assoc ; inline
47 : rekey-assoc ( assoc keys -- assoc )
48 [ dup keys ] dip diff over [ delete-at ] curry each ; inline
50 : if-assoc-empty ( ..a assoc quot1: ( ..a -- ..b ) quot2: ( ..a assoc -- ..b ) -- ..b )
51 [ dup assoc-empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
53 : assoc-invert-as ( assoc exemplar -- newassoc )
54 [ swap ] swap assoc-map-as ;
56 : assoc-invert ( assoc -- newassoc )
59 : assoc-merge! ( assoc1 assoc2 -- assoc1 )
60 over [ push-at ] with-assoc assoc-each ;
62 : assoc-merge ( assoc1 assoc2 -- newassoc )
63 [ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
64 [ assoc-merge! ] bi@ ;
66 GENERIC: delete-value-at ( value assoc -- )
68 M: assoc delete-value-at
69 [ value-at* ] keep swap [ delete-at ] [ 2drop ] if ;
71 ERROR: key-exists value key assoc ;
72 : set-once-at ( value key assoc -- )
79 : kv-with ( obj assoc quot -- assoc curried )
80 swapd [ -rotd call ] 2curry ; inline
84 : (sequence>assoc) ( seq map-quot insert-quot assoc -- assoc )
85 [ swap curry compose each ] keep ; inline
87 : (sequence-index>assoc) ( seq map-quot insert-quot assoc -- assoc )
88 [ swap curry compose each-index ] keep ; inline
92 : sequence>assoc! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- assoc )
93 roll (sequence>assoc) ; inline
95 : assoc>object ( assoc map-quot insert-quot exemplar -- object )
96 clone [ swap curry compose assoc-each ] keep ; inline
98 : assoc>object! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- object )
99 roll assoc>object ; inline
101 : sequence>assoc ( seq map-quot insert-quot exemplar -- assoc )
102 clone (sequence>assoc) ; inline
104 : sequence-index>assoc ( seq map-quot insert-quot exemplar -- assoc )
105 clone (sequence-index>assoc) ; inline
107 : sequence-index>hashtable ( seq map-quot insert-quot -- hashtable )
108 H{ } sequence-index>assoc ; inline
110 : sequence>hashtable ( seq map-quot insert-quot -- hashtable )
111 H{ } sequence>assoc ; inline
113 : expand-keys-set-at-as ( assoc exemplar -- hashtable' )
115 [ swap dup sequence? [ 1array ] unless ]
116 [ '[ _ set-at ] with each ]
119 : expand-keys-set-at ( assoc -- hashtable' )
120 H{ } expand-keys-set-at-as ;
122 : expand-keys-push-at-as ( assoc exemplar -- hashtable' )
124 [ swap dup sequence? [ 1array ] unless ]
125 [ '[ _ push-at ] with each ]
128 : expand-keys-push-at ( assoc -- hashtable' )
129 H{ } expand-keys-push-at-as ; inline
131 : expand-keys-push-as ( assoc exemplar -- hashtable' )
133 [ [ dup sequence? [ 1array ] unless ] dip ]
134 [ '[ _ 2array _ push ] each ]
137 : expand-keys-push ( assoc -- hashtable' )
138 V{ } expand-keys-push-as ; inline
140 : expand-values-set-at-as ( assoc exemplar -- hashtable' )
142 [ dup sequence? [ 1array ] unless swap ]
143 [ '[ _ _ set-at ] each ]
146 : expand-values-set-at ( assoc -- hashtable' )
147 H{ } expand-values-set-at-as ; inline
149 : expand-values-push-at-as ( assoc exemplar -- hashtable' )
151 [ dup sequence? [ 1array ] unless swap ]
152 [ '[ _ _ push-at ] each ]
155 : expand-values-push-at ( assoc -- assoc )
156 H{ } expand-values-push-at-as ; inline
158 : expand-values-push-as ( assoc exemplar -- assoc )
160 [ dup sequence? [ 1array ] unless ]
161 [ '[ 2array _ push ] with each ]
164 : expand-values-push ( assoc -- sequence )
165 V{ } expand-values-push-as ; inline
167 : assoc-any-key? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
168 [ drop ] prepose assoc-find 2nip ; inline
170 : assoc-any-value? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
171 [ nip ] prepose assoc-find 2nip ; inline
173 : assoc-all-key? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
174 [ not ] compose assoc-any-key? not ; inline
176 : assoc-all-value? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
177 [ not ] compose assoc-any-value? not ; inline
179 : any-multi-key? ( assoc -- ? )
180 [ sequence? ] assoc-any-key? ;
182 : any-multi-value? ( assoc -- ? )
183 [ sequence? ] assoc-any-value? ;
185 : flatten-keys ( assoc -- assoc' )
186 dup any-multi-key? [ expand-keys-set-at flatten-keys ] when ;
188 : flatten-values ( assoc -- assoc' )
189 dup any-multi-value? [ expand-values-set-at flatten-values ] when ;
191 : intersect-keys ( assoc seq -- elts )
192 [ of ] with zip-with sift-values ; inline
194 : values-of ( assoc seq -- elts )
195 [ of ] with map sift ; inline
197 : counts ( seq elts -- counts )
198 [ histogram ] dip intersect-keys ;