1 ! Copyright (C) 2007, 2008 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: set-at ( value key assoc -- )
11 GENERIC: new-assoc ( capacity exemplar -- newassoc )
12 GENERIC: delete-at ( key assoc -- )
13 GENERIC: clear-assoc ( assoc -- )
14 GENERIC: assoc-size ( assoc -- n )
15 GENERIC: assoc-like ( assoc exemplar -- newassoc )
17 M: assoc assoc-like drop ;
19 GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
21 GENERIC: >alist ( assoc -- newassoc )
23 : (assoc-each) ( assoc quot -- seq quot' )
24 [ >alist ] dip [ first2 ] prepose ; inline
26 : assoc-find ( assoc quot -- key value ? )
27 (assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
29 : key? ( key assoc -- ? ) at* nip ; inline
31 : assoc-each ( assoc quot -- )
32 (assoc-each) each ; inline
34 : assoc>map ( assoc quot exemplar -- seq )
35 [ accumulator [ assoc-each ] dip ] dip like ; inline
37 : assoc-map-as ( assoc quot exemplar -- newassoc )
38 [ [ 2array ] compose V{ } assoc>map ] dip assoc-like ; inline
40 : assoc-map ( assoc quot -- newassoc )
41 over assoc-map-as ; inline
43 : assoc-push-if ( key value quot accum -- )
44 [ 2keep rot ] dip swap
45 [ [ 2array ] dip push ] [ 3drop ] if ; inline
47 : assoc-pusher ( quot -- quot' accum )
48 V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
50 : assoc-filter-as ( assoc quot exemplar -- subassoc )
51 [ assoc-pusher [ assoc-each ] dip ] dip assoc-like ; inline
53 : assoc-filter ( assoc quot -- subassoc )
54 over assoc-filter-as ; inline
56 : assoc-contains? ( assoc quot -- ? )
57 assoc-find 2nip ; inline
59 : assoc-all? ( assoc quot -- ? )
60 [ not ] compose assoc-contains? not ; inline
62 : at ( key assoc -- value/f )
65 M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
66 over assoc-size swap new-assoc
67 swap [ swap pick set-at ] assoc-each ;
69 : keys ( assoc -- keys )
70 [ drop ] { } assoc>map ;
72 : values ( assoc -- values )
73 [ nip ] { } assoc>map ;
75 : delete-at* ( key assoc -- old ? )
76 [ at* ] 2keep delete-at ;
78 : rename-at ( newkey key assoc -- )
79 tuck delete-at* [ -rot set-at ] [ 3drop ] if ;
81 : assoc-empty? ( assoc -- ? )
84 : (assoc-stack) ( key i seq -- value )
89 [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if
90 ] if ; inline recursive
92 : assoc-stack ( key seq -- value )
93 dup length 1- swap (assoc-stack) ;
95 : assoc-subset? ( assoc1 assoc2 -- ? )
96 [ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
98 : assoc= ( assoc1 assoc2 -- ? )
99 [ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
101 : assoc-hashcode ( n assoc -- code )
103 [ over ] dip hashcode* 2/ [ dupd hashcode* ] dip bitxor
104 ] { } assoc>map hashcode* ;
106 : assoc-intersect ( assoc1 assoc2 -- intersection )
107 swap [ nip key? ] curry assoc-filter ;
109 : update ( assoc1 assoc2 -- )
110 swap [ swapd set-at ] curry assoc-each ;
112 : assoc-union ( assoc1 assoc2 -- union )
113 2dup [ assoc-size ] bi@ + pick new-assoc
114 [ rot update ] keep [ swap update ] keep ;
116 : assoc-combine ( seq -- union )
117 H{ } clone [ dupd update ] reduce ;
119 : assoc-diff ( assoc1 assoc2 -- diff )
120 [ nip key? not ] curry assoc-filter ;
122 : remove-all ( assoc seq -- subseq )
123 swap [ key? not ] curry filter ;
126 [ dupd at* [ nip ] [ drop ] if ] curry ; inline
128 : substitute-here ( seq assoc -- )
129 (substitute) change-each ;
131 : substitute ( seq assoc -- newseq )
134 : cache ( key assoc quot -- value )
138 drop pick rot [ call dup ] 2dip set-at
141 : change-at ( key assoc quot -- )
142 [ [ at ] dip call ] 3keep drop set-at ; inline
144 : at+ ( n key assoc -- )
145 [ 0 or + ] change-at ;
147 : map>assoc ( seq quot exemplar -- assoc )
148 [ [ 2array ] compose { } map-as ] dip assoc-like ; inline
150 : extract-keys ( seq assoc -- subassoc )
151 [ [ dupd at ] curry ] keep map>assoc ;
153 GENERIC: value-at* ( value assoc -- key/f ? )
155 M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
157 : value-at ( value assoc -- key/f ) value-at* drop ;
159 : value? ( value assoc -- ? ) value-at* nip ;
161 : push-at ( value key assoc -- )
162 [ ?push ] change-at ;
164 : zip ( keys values -- alist )
167 : unzip ( assoc -- keys values )
168 dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
170 : search-alist ( key alist -- pair/f i/f )
171 [ first = ] with find swap ; inline
174 search-alist [ second t ] [ f ] if ;
179 [ drop [ swap 2array ] dip push ] if ;
181 M: sequence new-assoc drop <vector> ;
183 M: sequence clear-assoc delete-all ;
185 M: sequence delete-at
186 tuck search-alist nip
187 [ swap delete-nth ] [ drop ] if* ;
189 M: sequence assoc-size length ;
191 M: sequence assoc-clone-like
192 [ >alist ] dip clone-like ;
194 M: sequence assoc-like
195 [ >alist ] dip like ;
199 ! Override sequence => assoc instance for f
200 M: f clear-assoc drop ;
202 M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
204 INSTANCE: sequence assoc
211 seq>> 2dup bounds-check?
212 [ nth t ] [ 2drop f f ] if ;
214 M: enum set-at seq>> set-nth ;
216 M: enum delete-at seq>> delete-nth ;
218 M: enum >alist ( enum -- alist )
219 seq>> [ length ] keep zip ;
221 M: enum assoc-size seq>> length ;
223 M: enum clear-assoc seq>> delete-all ;