1 ! Copyright (C) 2007, 2010 Daniel Ehrenberg, Slava Pestov
2 ! See http://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 )
22 M: assoc assoc-like drop ; inline
24 : ?at ( key assoc -- value/key ? )
25 2dup at* [ 2nip t ] [ 2drop f ] if ; inline
27 : maybe-set-at ( value key assoc -- changed? )
28 3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ;
32 : (assoc-each) ( assoc quot -- seq quot' )
33 [ >alist ] dip [ first2 ] prepose ; inline
35 : (assoc-stack) ( key i seq -- value )
40 [ [ 3drop ] dip ] [ drop [ 1 - ] dip (assoc-stack) ] if
41 ] if ; inline recursive
43 : search-alist ( key alist -- pair/f i/f )
44 [ first = ] with find swap ; inline
46 : substituter ( assoc -- quot )
47 [ ?at drop ] curry ; inline
49 : with-assoc ( assoc quot: ( ..a value key assoc -- ..b ) -- quot: ( ..a key value -- ..b ) )
50 curry [ swap ] prepose ; inline
54 : assoc-find ( ... assoc quot: ( ... key value -- ... ? ) -- ... key value ? )
55 (assoc-each) find swap [ first2-unsafe t ] [ drop f f f ] if ; inline
57 : key? ( key assoc -- ? ) at* nip ; inline
59 : assoc-each ( ... assoc quot: ( ... key value -- ... ) -- ... )
60 (assoc-each) each ; inline
62 : assoc>map ( ... assoc quot: ( ... key value -- ... elt ) exemplar -- ... seq )
63 [ (assoc-each) ] dip map-as ; inline
65 : assoc-map-as ( ... assoc quot: ( ... key value -- ... newkey newvalue ) exemplar -- ... newassoc )
66 [ [ 2array ] compose { } assoc>map ] dip assoc-like ; inline
68 : assoc-map ( ... assoc quot: ( ... key value -- ... newkey newvalue ) -- ... newassoc )
69 over assoc-map-as ; inline
71 : assoc-filter-as ( ... assoc quot: ( ... key value -- ... ? ) exemplar -- ... subassoc )
72 [ (assoc-each) filter ] dip assoc-like ; inline
74 : assoc-filter ( ... assoc quot: ( ... key value -- ... ? ) -- ... subassoc )
75 over assoc-filter-as ; inline
77 : assoc-filter! ( ... assoc quot: ( ... key value -- ... ? ) -- ... assoc )
79 over [ [ [ drop ] 2bi ] dip [ delete-at ] 2curry unless ] 2curry
81 ] [ drop ] 2bi ; inline
83 : sift-keys ( assoc -- assoc' )
84 [ drop ] assoc-filter ; inline
86 : sift-values ( assoc -- assoc' )
87 [ nip ] assoc-filter ; inline
89 : assoc-partition ( ... assoc quot: ( ... key value -- ... ? ) -- ... true-assoc false-assoc )
90 [ (assoc-each) partition ] [ drop ] 2bi
91 [ assoc-like ] curry bi@ ; inline
93 : assoc-any? ( ... assoc quot: ( ... key value -- ... ? ) -- ... ? )
94 assoc-find 2nip ; inline
96 : assoc-all? ( ... assoc quot: ( ... key value -- ... ? ) -- ... ? )
97 [ not ] compose assoc-any? not ; inline
99 : at ( key assoc -- value/f )
102 : ?of ( assoc key -- value/key ? )
105 : of ( assoc key -- value/f )
108 M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
109 [ dup assoc-size ] dip new-assoc
110 [ [ set-at ] with-assoc assoc-each ] keep ; inline
112 M: assoc keys [ drop ] { } assoc>map ;
114 M: assoc values [ nip ] { } assoc>map ;
116 : delete-at* ( key assoc -- old ? )
117 [ at* ] 2keep delete-at ;
119 : rename-at ( newkey key assoc -- )
120 [ delete-at* ] keep [ set-at ] with-assoc [ 2drop ] if ;
122 : assoc-empty? ( assoc -- ? )
123 assoc-size 0 = ; inline
125 : assoc-stack ( key seq -- value )
126 [ length 1 - ] keep (assoc-stack) ; flushable
128 : assoc-subset? ( assoc1 assoc2 -- ? )
129 [ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ;
131 : assoc= ( assoc1 assoc2 -- ? )
132 2dup [ assoc-size ] bi@ eq? [ assoc-subset? ] [ 2drop f ] if ;
134 : assoc-hashcode ( n assoc -- code )
137 : assoc-intersect ( assoc1 assoc2 -- intersection )
138 swap [ nip key? ] curry assoc-filter ;
140 : assoc-union! ( assoc1 assoc2 -- assoc1 )
141 over [ set-at ] with-assoc assoc-each ;
143 : assoc-union ( assoc1 assoc2 -- union )
144 [ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
145 [ assoc-union! ] bi@ ;
147 : assoc-combine ( seq -- union )
148 H{ } clone [ assoc-union! ] reduce ;
150 : assoc-refine ( seq -- assoc )
151 [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
153 : assoc-differ ( key -- quot )
154 [ nip key? not ] curry ; inline
156 : assoc-diff ( assoc1 assoc2 -- diff )
157 assoc-differ assoc-filter ;
159 : assoc-diff! ( assoc1 assoc2 -- assoc1 )
160 assoc-differ assoc-filter! ;
162 : substitute ( seq assoc -- newseq )
165 : cache ( ... key assoc quot: ( ... key -- ... value ) -- ... value )
166 [ [ at* ] 2keep ] dip
167 [ [ nip call dup ] [ drop ] 3bi set-at ] 3curry
171 : 2cache ( ... key1 key2 assoc quot: ( ... key1 key2 -- ... value ) -- ... value )
172 [ 2array ] 2dip [ first2-unsafe ] prepose cache ; inline
174 : change-at ( ..a key assoc quot: ( ..a value -- ..b newvalue ) -- ..b )
175 [ [ at ] dip call ] [ drop ] 3bi set-at ; inline
177 : at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline
179 : inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline
181 : map>assoc ( ... seq quot: ( ... elt -- ... key value ) exemplar -- ... assoc )
183 [ [ 2array ] compose ] dip map-as
185 [ over assoc-size ] dip new-assoc
186 [ [ swapd set-at ] curry compose each ] keep
189 : extract-keys ( seq assoc -- subassoc )
190 [ [ dupd at ] curry ] keep map>assoc ;
192 M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
194 : value-at ( value assoc -- key/f ) value-at* drop ;
196 : value? ( value assoc -- ? ) value-at* nip ;
198 : push-at ( value key assoc -- )
199 [ ?push ] change-at ;
201 : zip-as ( keys values exemplar -- assoc )
203 [ 2array ] swap 2map-as
205 [ 2dup min-length ] dip new-assoc
206 [ [ set-at ] with-assoc 2each ] keep
209 : zip ( keys values -- assoc )
212 : map-index-as ( ... seq quot: ( ... elt index -- ... newelt ) exemplar -- ... obj )
214 [ dup length iota ] 2dip 2map-as
216 [ dup length iota ] 2dip [ over length ] dip new-assoc
217 ! Need to do 2array/first2 here because of quot's stack effect
218 [ [ [ first2 swap ] dip set-at ] curry compose 2each ] keep
221 : map-index ( ... seq quot: ( ... elt index -- ... newelt ) -- ... newseq )
222 over map-index-as ; inline
224 : zip-index-as ( values exemplar -- assoc )
225 [ [ 2array ] ] dip map-index-as ; inline
227 : zip-index ( values -- assoc )
228 dup zip-index-as ; inline
230 : unzip ( assoc -- keys values )
231 dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
234 search-alist [ second t ] [ f ] if ;
239 [ drop [ swap 2array ] dip push ] if ;
241 M: sequence new-assoc drop <vector> ; inline
243 M: sequence clear-assoc delete-all ; inline
245 M: sequence delete-at
246 [ nip ] [ search-alist nip ] 2bi
247 [ swap remove-nth! drop ] [ drop ] if* ;
249 M: sequence assoc-size length ; inline
251 M: sequence assoc-clone-like
252 [ >alist ] dip clone-like ; inline
254 M: sequence assoc-like
255 [ >alist ] dip like ; inline
257 M: sequence >alist ; inline
259 ! Override sequence => assoc instance for f
260 M: f at* 2drop f f ; inline
262 M: f assoc-size drop 0 ; inline
264 M: f clear-assoc drop ; inline
266 M: f assoc-like drop dup assoc-empty? [ drop f ] when ; inline
268 INSTANCE: sequence assoc
270 TUPLE: enum { seq read-only } ;
275 seq>> 2dup bounds-check?
276 [ nth-unsafe t ] [ 2drop f f ] if ; inline
278 M: enum set-at seq>> set-nth ; inline
280 M: enum delete-at seq>> remove-nth! drop ; inline
282 M: enum >alist ( enum -- alist )
283 seq>> [ length iota ] keep zip ; inline
285 M: enum keys seq>> length iota >array ; inline
287 M: enum values seq>> >array ; inline
289 M: enum assoc-size seq>> length ; inline
291 M: enum clear-assoc seq>> delete-all ; inline
295 M: enum length seq>> length ; inline
297 M: enum nth-unsafe dupd seq>> nth-unsafe 2array ; inline
299 INSTANCE: enum immutable-sequence