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 ;
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 : if-assoc-empty ( ..a assoc quot1: ( ..a -- ..b ) quot2: ( ..a assoc -- ..b ) -- ..b )
45 [ dup assoc-empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
47 : assoc-invert-as ( assoc exemplar -- newassoc )
48 [ swap ] swap assoc-map-as ;
50 : assoc-invert ( assoc -- newassoc )
53 : assoc-merge! ( assoc1 assoc2 -- assoc1 )
54 over [ push-at ] with-assoc assoc-each ;
56 : assoc-merge ( assoc1 assoc2 -- newassoc )
57 [ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
58 [ assoc-merge! ] bi@ ;
60 GENERIC: delete-value-at ( value assoc -- )
62 M: assoc delete-value-at
63 [ value-at* ] keep swap [ delete-at ] [ 2drop ] if ;
65 ERROR: key-exists value key assoc ;
66 : set-once-at ( value key assoc -- )
73 : kv-with ( obj assoc quot -- assoc curried )
74 swapd [ -rotd call ] 2curry ; inline
78 : (sequence>assoc) ( seq map-quot insert-quot assoc -- assoc )
79 [ swap curry compose each ] keep ; inline
81 : (sequence-index>assoc) ( seq map-quot insert-quot assoc -- assoc )
82 [ swap curry compose each-index ] keep ; inline
86 : sequence>assoc! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- assoc )
87 roll (sequence>assoc) ; inline
89 : assoc>object ( assoc map-quot insert-quot exemplar -- object )
90 clone [ swap curry compose assoc-each ] keep ; inline
92 : assoc>object! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- object )
93 roll assoc>object ; inline
95 : sequence>assoc ( seq map-quot insert-quot exemplar -- assoc )
96 clone (sequence>assoc) ; inline
98 : sequence-index>assoc ( seq map-quot insert-quot exemplar -- assoc )
99 clone (sequence-index>assoc) ; inline
101 : sequence-index>hashtable ( seq map-quot insert-quot -- hashtable )
102 H{ } sequence-index>assoc ; inline
104 : sequence>hashtable ( seq map-quot insert-quot -- hashtable )
105 H{ } sequence>assoc ; inline
107 : expand-keys-set-at-as ( assoc exemplar -- hashtable' )
109 [ swap dup sequence? [ 1array ] unless ]
110 [ '[ _ set-at ] with each ]
113 : expand-keys-set-at ( assoc -- hashtable' )
114 H{ } expand-keys-set-at-as ;
116 : expand-keys-push-at-as ( assoc exemplar -- hashtable' )
118 [ swap dup sequence? [ 1array ] unless ]
119 [ '[ _ push-at ] with each ]
122 : expand-keys-push-at ( assoc -- hashtable' )
123 H{ } expand-keys-push-at-as ; inline
125 : expand-keys-push-as ( assoc exemplar -- hashtable' )
127 [ [ dup sequence? [ 1array ] unless ] dip ]
128 [ '[ _ 2array _ push ] each ]
131 : expand-keys-push ( assoc -- hashtable' )
132 V{ } expand-keys-push-as ; inline
134 : expand-values-set-at-as ( assoc exemplar -- hashtable' )
136 [ dup sequence? [ 1array ] unless swap ]
137 [ '[ _ _ set-at ] each ]
140 : expand-values-set-at ( assoc -- hashtable' )
141 H{ } expand-values-set-at-as ; inline
143 : expand-values-push-at-as ( assoc exemplar -- hashtable' )
145 [ dup sequence? [ 1array ] unless swap ]
146 [ '[ _ _ push-at ] each ]
149 : expand-values-push-at ( assoc -- assoc )
150 H{ } expand-values-push-at-as ; inline
152 : expand-values-push-as ( assoc exemplar -- assoc )
154 [ dup sequence? [ 1array ] unless ]
155 [ '[ 2array _ push ] with each ]
158 : expand-values-push ( assoc -- sequence )
159 V{ } expand-values-push-as ; inline
161 : assoc-any-key? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
162 [ drop ] prepose assoc-find 2nip ; inline
164 : assoc-any-value? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
165 [ nip ] prepose assoc-find 2nip ; inline
167 : assoc-all-key? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
168 [ not ] compose assoc-any-key? not ; inline
170 : assoc-all-value? ( ... assoc quot: ( ... key -- ... ? ) -- ... ? )
171 [ not ] compose assoc-any-value? not ; inline
173 : any-multi-key? ( assoc -- ? )
174 [ sequence? ] assoc-any-key? ;
176 : any-multi-value? ( assoc -- ? )
177 [ sequence? ] assoc-any-value? ;
179 : flatten-keys ( assoc -- assoc' )
180 dup any-multi-key? [ expand-keys-set-at flatten-keys ] when ;
182 : flatten-values ( assoc -- assoc' )
183 dup any-multi-value? [ expand-values-set-at flatten-values ] when ;
185 : intersect-keys ( assoc seq -- elts )
186 [ of ] with map-zip sift-values ; inline
188 : values-of ( assoc seq -- elts )
189 [ of ] with map sift ; inline
191 : counts ( seq elts -- counts )
192 [ histogram ] dip intersect-keys ;