1 ! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel sequences arrays math sequences.private vectors
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 )
20 M: assoc assoc-like drop ;
22 : ?at ( key assoc -- value/key ? )
23 2dup at* [ 2nip t ] [ 2drop f ] if ; inline
25 : maybe-set-at ( value key assoc -- changed? )
26 3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ;
30 : (assoc-each) ( assoc quot -- seq quot' )
31 [ >alist ] dip [ first2 ] prepose ; inline
33 : (assoc-stack) ( key i seq -- value )
38 [ [ 3drop ] dip ] [ drop [ 1 - ] dip (assoc-stack) ] if
39 ] if ; inline recursive
41 : search-alist ( key alist -- pair/f i/f )
42 [ first = ] with find swap ; inline
44 : substituter ( assoc -- quot )
45 [ ?at drop ] curry ; inline
47 : with-assoc ( assoc quot: ( value key assoc -- ) -- quot: ( key value -- ) )
48 curry [ swap ] prepose ; inline
52 : assoc-find ( assoc quot -- key value ? )
53 (assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
55 : key? ( key assoc -- ? ) at* nip ; inline
57 : assoc-each ( assoc quot -- )
58 (assoc-each) each ; inline
60 : assoc>map ( assoc quot exemplar -- seq )
61 [ accumulator [ assoc-each ] dip ] dip like ; inline
63 : assoc-map-as ( assoc quot exemplar -- newassoc )
64 [ [ 2array ] compose V{ } assoc>map ] dip assoc-like ; inline
66 : assoc-map ( assoc quot -- newassoc )
67 over assoc-map-as ; inline
69 : assoc-filter-as ( assoc quot exemplar -- subassoc )
70 [ (assoc-each) filter ] dip assoc-like ; inline
72 : assoc-filter ( assoc quot -- subassoc )
73 over assoc-filter-as ; inline
75 : assoc-partition ( assoc quot -- true-assoc false-assoc )
76 [ (assoc-each) partition ] [ drop ] 2bi
77 [ assoc-like ] curry bi@ ; inline
79 : assoc-any? ( assoc quot -- ? )
80 assoc-find 2nip ; inline
82 : assoc-all? ( assoc quot -- ? )
83 [ not ] compose assoc-any? not ; inline
85 : at ( key assoc -- value/f )
88 : at-default ( key assoc -- value/key )
91 M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
92 [ dup assoc-size ] dip new-assoc
93 [ [ set-at ] with-assoc assoc-each ] keep ;
95 : keys ( assoc -- keys )
96 [ drop ] { } assoc>map ;
98 : values ( assoc -- values )
99 [ nip ] { } assoc>map ;
101 : delete-at* ( key assoc -- old ? )
102 [ at* ] 2keep delete-at ;
104 : rename-at ( newkey key assoc -- )
105 [ delete-at* ] keep [ set-at ] with-assoc [ 2drop ] if ;
107 : assoc-empty? ( assoc -- ? )
110 : assoc-stack ( key seq -- value )
111 [ length 1 - ] keep (assoc-stack) ; flushable
113 : assoc-subset? ( assoc1 assoc2 -- ? )
114 [ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ;
116 : assoc= ( assoc1 assoc2 -- ? )
117 [ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
119 : assoc-hashcode ( n assoc -- code )
122 : assoc-intersect ( assoc1 assoc2 -- intersection )
123 swap [ nip key? ] curry assoc-filter ;
125 : update ( assoc1 assoc2 -- )
126 swap [ set-at ] with-assoc assoc-each ;
128 : assoc-union ( assoc1 assoc2 -- union )
129 [ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
130 [ dupd update ] bi@ ;
132 : assoc-combine ( seq -- union )
133 H{ } clone [ dupd update ] reduce ;
135 : assoc-diff ( assoc1 assoc2 -- diff )
136 [ nip key? not ] curry assoc-filter ;
138 : remove-all ( assoc seq -- subseq )
139 swap [ key? not ] curry filter ;
141 : substitute-here ( seq assoc -- )
142 substituter change-each ;
144 : substitute ( seq assoc -- newseq )
147 : cache ( key assoc quot -- value )
148 [ [ at* ] 2keep ] dip
149 [ [ nip call dup ] [ drop ] 3bi set-at ] 3curry
153 : 2cache ( key1 key2 assoc quot -- value )
154 [ 2array ] 2dip [ first2 ] prepose cache ; inline
156 : change-at ( key assoc quot -- )
157 [ [ at ] dip call ] [ drop ] 3bi set-at ; inline
159 : at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline
161 : inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline
163 : map>assoc ( seq quot exemplar -- assoc )
164 [ [ 2array ] compose { } map-as ] dip assoc-like ; inline
166 : extract-keys ( seq assoc -- subassoc )
167 [ [ dupd at ] curry ] keep map>assoc ;
169 M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
171 : value-at ( value assoc -- key/f ) value-at* drop ;
173 : value? ( value assoc -- ? ) value-at* nip ;
175 : push-at ( value key assoc -- )
176 [ ?push ] change-at ;
178 : zip ( keys values -- alist )
181 : unzip ( assoc -- keys values )
182 dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
185 search-alist [ second t ] [ f ] if ;
190 [ drop [ swap 2array ] dip push ] if ;
192 M: sequence new-assoc drop <vector> ;
194 M: sequence clear-assoc delete-all ;
196 M: sequence delete-at
197 [ nip ] [ search-alist nip ] 2bi
198 [ swap delete-nth ] [ drop ] if* ;
200 M: sequence assoc-size length ;
202 M: sequence assoc-clone-like
203 [ >alist ] dip clone-like ;
205 M: sequence assoc-like
206 [ >alist ] dip like ;
210 ! Override sequence => assoc instance for f
211 M: f clear-assoc drop ;
213 M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
215 INSTANCE: sequence assoc
222 seq>> 2dup bounds-check?
223 [ nth t ] [ 2drop f f ] if ;
225 M: enum set-at seq>> set-nth ;
227 M: enum delete-at seq>> delete-nth ;
229 M: enum >alist ( enum -- alist )
230 seq>> [ length ] keep zip ;
232 M: enum assoc-size seq>> length ;
234 M: enum clear-assoc seq>> delete-all ;