1 ! Copyright (C) 2007, 2010 Daniel Ehrenberg, Slava Pestov
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays kernel math sequences sequences.private
9 GENERIC: at* ( key assoc -- value/f ? )
10 GENERIC: value-at* ( value assoc -- key/f ? )
11 GENERIC: set-at ( value key assoc -- )
12 GENERIC: new-assoc ( capacity exemplar -- newassoc )
13 GENERIC: delete-at ( key assoc -- )
14 GENERIC: clear-assoc ( assoc -- )
15 GENERIC: assoc-size ( assoc -- n )
16 GENERIC: assoc-like ( assoc exemplar -- newassoc )
17 GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
18 GENERIC: >alist ( assoc -- newassoc )
19 GENERIC: keys ( assoc -- keys )
20 GENERIC: values ( assoc -- values )
21 GENERIC: unzip ( assoc -- keys values )
23 M: assoc assoc-like drop ; inline
25 : ?at ( key assoc -- value/key ? )
26 2dup at* [ 2nip t ] [ 2drop f ] if ; inline
28 : ?of ( assoc key -- value/key ? )
31 : maybe-set-at ( value key assoc -- changed? )
32 3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ;
34 : set-of ( assoc key value -- assoc )
35 swap pick set-at ; inline
37 : maybe-set-of ( assoc key value -- assoc changed? )
39 [ dupd = [ 2drop f ] [ set-of t ] if ] [ nip set-of t ] if ;
43 : assoc-operator ( assoc quot -- alist quot' )
44 [ >alist ] dip [ first2 ] prepose ; inline
46 : assoc-stack-from ( key i seq -- value/f )
51 [ 3nip ] [ drop [ 1 - ] dip assoc-stack-from ] if
52 ] if ; inline recursive
54 : search-alist ( key alist -- pair/f i/f )
55 [ first = ] with find swap ; inline
57 : substituter ( assoc -- quot )
58 [ ?at drop ] curry ; inline
62 : assoc-find ( ... assoc quot: ( ... key value -- ... ? ) -- ... key value ? )
63 assoc-operator find swap [ first2-unsafe t ] [ drop f f f ] if ; inline
65 : key? ( key assoc -- ? ) at* nip ; inline
67 : assoc-each ( ... assoc quot: ( ... key value -- ... ) -- ... )
68 assoc-operator each ; inline
70 : assoc>map ( ... assoc quot: ( ... key value -- ... elt ) exemplar -- ... seq )
71 [ assoc-operator ] dip map-as ; inline
73 : assoc-map-as ( ... assoc quot: ( ... key value -- ... newkey newvalue ) exemplar -- ... newassoc )
74 [ [ 2array ] compose { } assoc>map ] dip assoc-like ; inline
76 : assoc-map ( ... assoc quot: ( ... key value -- ... newkey newvalue ) -- ... newassoc )
77 over assoc-map-as ; inline
79 : assoc-filter-as ( ... assoc quot: ( ... key value -- ... ? ) exemplar -- ... subassoc )
80 [ assoc-operator filter ] dip assoc-like ; inline
82 : assoc-filter ( ... assoc quot: ( ... key value -- ... ? ) -- ... subassoc )
83 over assoc-filter-as ; inline
85 : assoc-reject-as ( ... assoc quot: ( ... key value -- ... ? ) exemplar -- ... subassoc )
86 [ [ not ] compose ] [ assoc-filter-as ] bi* ; inline
88 : assoc-reject ( ... assoc quot: ( ... key value -- ... ? ) -- ... subassoc )
89 over assoc-reject-as ; inline
91 : assoc-filter! ( ... assoc quot: ( ... key value -- ... ? ) -- ... assoc )
93 over [ [ [ drop ] 2bi ] dip [ delete-at ] 2curry unless ] 2curry
95 ] [ drop ] 2bi ; inline
97 : assoc-reject! ( ... assoc quot: ( ... key value -- ... ? ) -- ... assoc )
98 [ not ] compose assoc-filter! ; inline
100 : sift-keys ( assoc -- assoc' )
101 [ drop ] assoc-filter ; inline
103 : sift-values ( assoc -- assoc' )
104 [ nip ] assoc-filter ; inline
106 : harvest-keys ( assoc -- assoc' )
107 [ drop empty? ] assoc-reject ; inline
109 : harvest-values ( assoc -- assoc' )
110 [ nip empty? ] assoc-reject ; inline
112 : assoc-partition ( ... assoc quot: ( ... key value -- ... ? ) -- ... true-assoc false-assoc )
113 [ assoc-operator partition ] [ drop ] 2bi
114 [ assoc-like ] curry bi@ ; inline
116 : assoc-any? ( ... assoc quot: ( ... key value -- ... ? ) -- ... ? )
117 assoc-find 2nip ; inline
119 : assoc-all? ( ... assoc quot: ( ... key value -- ... ? ) -- ... ? )
120 [ not ] compose assoc-any? not ; inline
122 : at ( key assoc -- value/f )
125 : of ( assoc key -- value/f )
128 M: assoc assoc-clone-like
129 [ dup assoc-size ] dip new-assoc
130 [ [ set-at ] with-assoc assoc-each ] keep ; inline
132 M: assoc keys [ drop ] { } assoc>map ;
134 M: assoc values [ nip ] { } assoc>map ;
136 : delete-at* ( key assoc -- value/f ? )
137 [ at* ] 2keep delete-at ;
139 : ?delete-at ( key assoc -- value/key ? )
140 [ ?at ] 2keep delete-at ;
142 : rename-at ( newkey key assoc -- )
143 [ delete-at* ] keep [ set-at ] with-assoc [ 2drop ] if ;
145 : assoc-empty? ( assoc -- ? )
146 assoc-size 0 = ; inline
148 : assoc-stack ( key seq -- value )
149 index-of-last assoc-stack-from ; flushable
151 : assoc-subset? ( assoc1 assoc2 -- ? )
152 [ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ;
154 : assoc= ( assoc1 assoc2 -- ? )
155 2dup [ assoc-size ] bi@ = [ assoc-subset? ] [ 2drop f ] if ;
157 : assoc-hashcode ( n assoc -- code )
160 : assoc-intersect ( assoc1 assoc2 -- intersection )
161 swap [ nip key? ] curry assoc-filter ;
163 : assoc-union! ( assoc1 assoc2 -- assoc1 )
164 [ set-of ] assoc-each ; inline
166 : assoc-union-as ( assoc1 assoc2 exemplar -- union )
167 [ [ [ assoc-size ] bi@ + ] dip new-assoc ] 2keepd
168 [ assoc-union! ] bi@ ;
170 : assoc-union ( assoc1 assoc2 -- union )
171 over assoc-union-as ;
173 : assoc-union-all ( seq -- union )
174 H{ } clone [ assoc-union! ] reduce ;
176 : assoc-intersect-all ( seq -- assoc )
177 [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
179 : assoc-differ ( key -- quot )
180 [ nip key? not ] curry ; inline
182 : assoc-diff ( assoc1 assoc2 -- diff )
183 assoc-differ assoc-filter ;
185 : assoc-diff! ( assoc1 assoc2 -- assoc1 )
186 assoc-differ assoc-filter! ;
188 : substitute ( seq assoc -- newseq )
191 : cache ( ... key assoc quot: ( ... key -- ... value ) -- ... value )
192 [ [ at* ] 2keep ] dip
193 [ [ nip call dup ] [ drop ] 3bi set-at ] 3curry
197 : 2cache ( ... key1 key2 assoc quot: ( ... key1 key2 -- ... value ) -- ... value )
198 [ 2array ] 2dip [ first2-unsafe ] prepose cache ; inline
200 : change-at ( ..a key assoc quot: ( ..a value -- ..b newvalue ) -- ..b )
201 [ [ at ] dip call ] [ drop ] 3bi set-at ; inline
203 : ?change-at ( ..a key assoc quot: ( ..a value -- ..b newvalue ) -- ..b )
204 2over [ set-at ] 2curry compose [ at* ] dip [ drop ] if ; inline
206 : change-of ( ..a assoc key quot: ( ..a value -- ..b newvalue ) -- ..b assoc )
207 [ [ of ] dip call ] 2keepd rot set-of ; inline
209 : ?change-of ( ..a assoc key quot: ( ..a value -- ..b newvalue ) -- ..b assoc )
210 [ set-of ] compose [ 2dup ?of ] dip [ 2drop ] if ; inline
212 : at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline
214 : at+* ( n key assoc -- old ) [ 0 or [ + ] keep swap ] change-at ; inline
216 : inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline
218 : of+ ( assoc key n -- assoc ) '[ 0 or _ + ] change-of ; inline
220 : inc-of ( assoc key -- assoc ) 1 of+ ; inline
222 : inc-at* ( key assoc -- old ) [ 1 ] 2dip at+* ; inline
224 : map>assoc ( ... seq quot: ( ... elt -- ... key value ) exemplar -- ... assoc )
226 [ [ 2array ] compose ] dip map-as
228 [ over assoc-size ] dip new-assoc
229 [ [ swapd set-at ] curry compose each ] keep
232 : map>alist ( ... seq quot: ( ... elt -- ... key value ) -- ... alist )
233 { } map>assoc ; inline
235 : extract-keys ( seq assoc -- subassoc )
236 [ [ dupd at ] curry ] keep map>assoc ;
238 M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
240 : value-at ( value assoc -- key/f ) value-at* drop ;
242 : ?value-at ( value assoc -- key/value ? )
243 2dup value-at* [ 2nip t ] [ 2drop f ] if ; inline
245 : value? ( value assoc -- ? ) value-at* nip ;
247 : push-at ( value key assoc -- )
248 [ ?push ] change-at ;
250 : push-of ( assoc key value -- assoc )
251 swap pick push-at ; inline
253 : zip-as ( keys values exemplar -- assoc )
255 [ 2array ] swap 2map-as
257 [ 2dup min-length ] dip new-assoc
258 [ [ set-at ] with-assoc 2each ] keep
261 : zip ( keys values -- alist )
264 : zip-index-as ( values exemplar -- assoc )
265 [ dup length <iota> ] dip zip-as ; inline
267 : zip-index ( values -- alist )
268 { } zip-index-as ; inline
271 dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
273 : zip-with-as ( ... seq quot: ( ... key -- ... value ) exemplar -- ... assoc )
274 [ [ keep swap ] curry ] dip map>assoc ; inline
276 : zip-with ( ... seq quot: ( ... key -- ... value ) -- ... alist )
277 { } zip-with-as ; inline
279 : collect-by! ( ... assoc seq quot: ( ... obj -- ... key ) -- ... assoc )
280 [ keep swap ] curry rot [
281 [ push-at ] curry compose each
284 : collect-by ( ... seq quot: ( ... obj -- ... key ) -- ... assoc )
285 [ H{ } clone ] 2dip collect-by! ; inline
288 search-alist [ second t ] [ f ] if ;
293 [ drop [ swap 2array ] dip push ] if ;
295 M: sequence new-assoc drop <vector> ; inline
297 M: sequence clear-assoc delete-all ; inline
299 M: sequence delete-at
300 [ nip ] [ search-alist nip ] 2bi
301 [ swap remove-nth! drop ] [ drop ] if* ;
303 M: sequence assoc-size length ; inline
305 M: sequence assoc-clone-like
306 [ >alist ] dip clone-like ; inline
308 M: sequence assoc-like
309 [ >alist ] dip like ; inline
311 M: sequence >alist ; inline
313 ! Override sequence => assoc instance for f
314 M: f at* 2drop f f ; inline
316 M: f assoc-size drop 0 ; inline
318 M: f clear-assoc drop ; inline
320 M: f assoc-like drop dup assoc-empty? [ drop f ] when ; inline
322 INSTANCE: sequence assoc
324 TUPLE: enumerated { seq read-only } ;
326 C: <enumerated> enumerated
329 seq>> 2dup bounds-check?
330 [ nth-unsafe t ] [ 2drop f f ] if ; inline
332 M: enumerated set-at seq>> set-nth ; inline
334 M: enumerated delete-at seq>> remove-nth! drop ; inline
336 M: enumerated >alist ; inline
338 M: enumerated keys seq>> length <iota> >array ; inline
340 M: enumerated values seq>> >array ; inline
342 M: enumerated unzip seq>> [ length <iota> ] keep [ >array ] bi@ ;
344 M: enumerated assoc-size seq>> length ; inline
346 M: enumerated clear-assoc seq>> delete-all ; inline
348 INSTANCE: enumerated assoc
350 M: enumerated length seq>> length ; inline
352 M: enumerated nth-unsafe dupd seq>> nth-unsafe 2array ; inline
354 INSTANCE: enumerated immutable-sequence