core/assocs/assocs.factor

   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
   4 vectors ;
   5 IN: assocs
   6
   7 MIXIN: assoc
   8
   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 )
  22
  23 M: assoc assoc-like drop ; inline
  24
  25 : ?at ( key assoc -- value/key ? )
  26     2dup at* [ 2nip t ] [ 2drop f ] if ; inline
  27
  28 : ?of ( assoc key -- value/key ? )
  29     swap ?at ; inline
  30
  31 : maybe-set-at ( value key assoc -- changed? )
  32     3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ;
  33
  34 : set-of ( assoc key value -- assoc )
  35     swap pick set-at ; inline
  36
  37 : maybe-set-of ( assoc key value -- assoc changed? )
  38     [ 2dup ?of ] dip swap
  39     [ dupd = [ 2drop f ] [ set-of t ] if ] [ nip set-of t ] if ;
  40
  41 <PRIVATE
  42
  43 : assoc-operator ( assoc quot -- alist quot' )
  44     [ >alist ] dip [ first2 ] prepose ; inline
  45
  46 : assoc-stack-from ( key i seq -- value/f )
  47     over 0 < [
  48         3drop f
  49     ] [
  50         3dup nth-unsafe at*
  51         [ 3nip ] [ drop [ 1 - ] dip assoc-stack-from ] if
  52     ] if ; inline recursive
  53
  54 : search-alist ( key alist -- pair/f i/f )
  55     [ first = ] with find swap ; inline
  56
  57 : substituter ( assoc -- quot )
  58     [ ?at drop ] curry ; inline
  59
  60 PRIVATE>
  61
  62 : assoc-find ( ... assoc quot: ( ... key value -- ... ? ) -- ... key value ? )
  63     assoc-operator find swap [ first2-unsafe t ] [ drop f f f ] if ; inline
  64
  65 : key? ( key assoc -- ? ) at* nip ; inline
  66
  67 : assoc-each ( ... assoc quot: ( ... key value -- ... ) -- ... )
  68     assoc-operator each ; inline
  69
  70 : assoc>map ( ... assoc quot: ( ... key value -- ... elt ) exemplar -- ... seq )
  71     [ assoc-operator ] dip map-as ; inline
  72
  73 : assoc-map-as ( ... assoc quot: ( ... key value -- ... newkey newvalue ) exemplar -- ... newassoc )
  74     [ [ 2array ] compose { } assoc>map ] dip assoc-like ; inline
  75
  76 : assoc-map ( ... assoc quot: ( ... key value -- ... newkey newvalue ) -- ... newassoc )
  77     over assoc-map-as ; inline
  78
  79 : assoc-filter-as ( ... assoc quot: ( ... key value -- ... ? ) exemplar -- ... subassoc )
  80     [ assoc-operator filter ] dip assoc-like ; inline
  81
  82 : assoc-filter ( ... assoc quot: ( ... key value -- ... ? ) -- ... subassoc )
  83     over assoc-filter-as ; inline
  84
  85 : assoc-reject-as ( ... assoc quot: ( ... key value -- ... ? ) exemplar -- ... subassoc )
  86     [ [ not ] compose ] [ assoc-filter-as ] bi* ; inline
  87
  88 : assoc-reject ( ... assoc quot: ( ... key value -- ... ? ) -- ... subassoc )
  89     over assoc-reject-as ; inline
  90
  91 : assoc-filter! ( ... assoc quot: ( ... key value -- ... ? ) -- ... assoc )
  92     [
  93         over [ [ [ drop ] 2bi ] dip [ delete-at ] 2curry unless ] 2curry
  94         assoc-each
  95     ] [ drop ] 2bi ; inline
  96
  97 : assoc-reject! ( ... assoc quot: ( ... key value -- ... ? ) -- ... assoc )
  98     [ not ] compose assoc-filter! ; inline
  99
 100 : sift-keys ( assoc -- assoc' )
 101     [ drop ] assoc-filter ; inline
 102
 103 : sift-values ( assoc -- assoc' )
 104     [ nip ] assoc-filter ; inline
 105
 106 : harvest-keys ( assoc -- assoc' )
 107     [ drop empty? ] assoc-reject ; inline
 108
 109 : harvest-values ( assoc -- assoc' )
 110     [ nip empty? ] assoc-reject ; inline
 111
 112 : assoc-partition ( ... assoc quot: ( ... key value -- ... ? ) -- ... true-assoc false-assoc )
 113     [ assoc-operator partition ] [ drop ] 2bi
 114     [ assoc-like ] curry bi@ ; inline
 115
 116 : assoc-any? ( ... assoc quot: ( ... key value -- ... ? ) -- ... ? )
 117     assoc-find 2nip ; inline
 118
 119 : assoc-all? ( ... assoc quot: ( ... key value -- ... ? ) -- ... ? )
 120     [ not ] compose assoc-any? not ; inline
 121
 122 : at ( key assoc -- value/f )
 123     at* drop ; inline
 124
 125 : of ( assoc key -- value/f )
 126     swap at ; inline
 127
 128 M: assoc assoc-clone-like
 129     [ dup assoc-size ] dip new-assoc
 130     [ [ set-at ] with-assoc assoc-each ] keep ; inline
 131
 132 M: assoc keys [ drop ] { } assoc>map ;
 133
 134 M: assoc values [ nip ] { } assoc>map ;
 135
 136 : delete-at* ( key assoc -- value/f ? )
 137     [ at* ] 2keep delete-at ;
 138
 139 : ?delete-at ( key assoc -- value/key ? )
 140     [ ?at ] 2keep delete-at ;
 141
 142 : rename-at ( newkey key assoc -- )
 143     [ delete-at* ] keep [ set-at ] with-assoc [ 2drop ] if ;
 144
 145 : assoc-empty? ( assoc -- ? )
 146     assoc-size 0 = ; inline
 147
 148 : assoc-stack ( key seq -- value )
 149     index-of-last assoc-stack-from ; flushable
 150
 151 : assoc-subset? ( assoc1 assoc2 -- ? )
 152     [ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ;
 153
 154 : assoc= ( assoc1 assoc2 -- ? )
 155     2dup [ assoc-size ] bi@ = [ assoc-subset? ] [ 2drop f ] if ;
 156
 157 : assoc-hashcode ( n assoc -- code )
 158     >alist hashcode* ;
 159
 160 : assoc-intersect ( assoc1 assoc2 -- intersection )
 161     swap [ nip key? ] curry assoc-filter ;
 162
 163 : assoc-union! ( assoc1 assoc2 -- assoc1 )
 164     [ set-of ] assoc-each ; inline
 165
 166 : assoc-union-as ( assoc1 assoc2 exemplar -- union )
 167     [ [ [ assoc-size ] bi@ + ] dip new-assoc ] 2keepd
 168     [ assoc-union! ] bi@ ;
 169
 170 : assoc-union ( assoc1 assoc2 -- union )
 171     over assoc-union-as ;
 172
 173 : assoc-union-all ( seq -- union )
 174     H{ } clone [ assoc-union! ] reduce ;
 175
 176 : assoc-intersect-all ( seq -- assoc )
 177     [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
 178
 179 : assoc-differ ( key -- quot )
 180     [ nip key? not ] curry ; inline
 181
 182 : assoc-diff ( assoc1 assoc2 -- diff )
 183     assoc-differ assoc-filter ;
 184
 185 : assoc-diff! ( assoc1 assoc2 -- assoc1 )
 186     assoc-differ assoc-filter! ;
 187
 188 : substitute ( seq assoc -- newseq )
 189     substituter map ;
 190
 191 : cache ( ... key assoc quot: ( ... key -- ... value ) -- ... value )
 192     [ [ at* ] 2keep ] dip
 193     [ [ nip call dup ] [ drop ] 3bi set-at ] 3curry
 194     [ drop ] prepose
 195     unless ; inline
 196
 197 : 2cache ( ... key1 key2 assoc quot: ( ... key1 key2 -- ... value ) -- ... value )
 198     [ 2array ] 2dip [ first2-unsafe ] prepose cache ; inline
 199
 200 : change-at ( ..a key assoc quot: ( ..a value -- ..b newvalue ) -- ..b )
 201     [ [ at ] dip call ] [ drop ] 3bi set-at ; inline
 202
 203 : ?change-at ( ..a key assoc quot: ( ..a value -- ..b newvalue ) -- ..b )
 204     2over [ set-at ] 2curry compose [ at* ] dip [ drop ] if ; inline
 205
 206 : change-of ( ..a assoc key quot: ( ..a value -- ..b newvalue ) -- ..b )
 207     [ [ of ] dip call ] 2keepd rot set-of drop ; inline
 208
 209 : ?change-of ( ..a assoc key quot: ( ..a value -- ..b newvalue ) -- ..b )
 210     [ set-of drop ] compose [ 2dup ?of ] dip [ 3drop ] if ; inline
 211
 212 : at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline
 213
 214 : at+* ( n key assoc -- old new ) [ 0 or [ + ] keep swap dup ] change-at ; inline
 215
 216 : inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline
 217
 218 : inc-at* ( key assoc -- old new ) [ 1 ] 2dip at+* ; inline
 219
 220 : of+ ( assoc key n -- ) '[ 0 or _ + ] change-of ; inline
 221
 222 : of+* ( assoc key n -- old new ) '[ [ 0 or _ + ] keep swap dup ] change-of ; inline
 223
 224 : inc-of ( assoc key -- ) 1 of+ ; inline
 225
 226 : inc-of* ( assoc key -- old new ) 1 of+* ; inline
 227
 228 : map>assoc ( ... seq quot: ( ... elt -- ... key value ) exemplar -- ... assoc )
 229     dup sequence? [
 230         [ [ 2array ] compose ] dip map-as
 231     ] [
 232         [ over assoc-size ] dip new-assoc
 233         [ [ swapd set-at ] curry compose each ] keep
 234     ] if ; inline
 235
 236 : map>alist ( ... seq quot: ( ... elt -- ... key value ) -- ... alist )
 237     { } map>assoc ; inline
 238
 239 : extract-keys ( seq assoc -- subassoc )
 240     [ [ dupd at ] curry ] keep map>assoc ;
 241
 242 M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
 243
 244 : value-at ( value assoc -- key/f ) value-at* drop ;
 245
 246 : ?value-at ( value assoc -- key/value ? )
 247     2dup value-at* [ 2nip t ] [ 2drop f ] if ; inline
 248
 249 : value? ( value assoc -- ? ) value-at* nip ;
 250
 251 : push-at ( value key assoc -- )
 252     [ ?push ] change-at ;
 253
 254 : push-of ( assoc key value -- assoc )
 255     swap pick push-at ; inline
 256
 257 : zip-as ( keys values exemplar -- assoc )
 258     dup sequence? [
 259         [ 2array ] swap 2map-as
 260     ] [
 261         [ 2dup min-length ] dip new-assoc
 262         [ [ set-at ] with-assoc 2each ] keep
 263     ] if ; inline
 264
 265 : zip ( keys values -- alist )
 266     { } zip-as ; inline
 267
 268 : zip-index-as ( values exemplar -- assoc )
 269     [ dup length <iota> ] dip zip-as ; inline
 270
 271 : zip-index ( values -- alist )
 272     { } zip-index-as ; inline
 273
 274 M: assoc unzip
 275     dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
 276
 277 : zip-with-as ( ... seq quot: ( ... key -- ... value ) exemplar -- ... assoc )
 278     [ [ keep swap ] curry ] dip map>assoc ; inline
 279
 280 : zip-with ( ... seq quot: ( ... key -- ... value ) -- ... alist )
 281     { } zip-with-as ; inline
 282
 283 : collect-by! ( ... assoc seq quot: ( ... obj -- ... key ) -- ... assoc )
 284     [ keep swap ] curry rot [
 285         [ push-at ] curry compose each
 286     ] keep ; inline
 287
 288 : collect-by ( ... seq quot: ( ... obj -- ... key ) -- ... assoc )
 289     [ H{ } clone ] 2dip collect-by! ; inline
 290
 291 M: sequence at*
 292     search-alist [ second t ] [ f ] if ;
 293
 294 M: sequence set-at
 295     2dup search-alist
 296     [ 2nip set-second ]
 297     [ drop [ swap 2array ] dip push ] if ;
 298
 299 M: sequence new-assoc drop <vector> ; inline
 300
 301 M: sequence clear-assoc delete-all ; inline
 302
 303 M: sequence delete-at
 304     [ nip ] [ search-alist nip ] 2bi
 305     [ swap remove-nth! drop ] [ drop ] if* ;
 306
 307 M: sequence assoc-size length ; inline
 308
 309 M: sequence assoc-clone-like
 310     [ >alist ] dip clone-like ; inline
 311
 312 M: sequence assoc-like
 313     [ >alist ] dip like ; inline
 314
 315 M: sequence >alist ; inline
 316
 317 ! Override sequence => assoc instance for f
 318 M: f at* 2drop f f ; inline
 319
 320 M: f assoc-size drop 0 ; inline
 321
 322 M: f clear-assoc drop ; inline
 323
 324 M: f assoc-like drop dup assoc-empty? [ drop f ] when ; inline
 325
 326 INSTANCE: sequence assoc
 327
 328 TUPLE: enumerated { seq read-only } ;
 329
 330 C: <enumerated> enumerated
 331
 332 M: enumerated at*
 333     seq>> 2dup bounds-check?
 334     [ nth-unsafe t ] [ 2drop f f ] if ; inline
 335
 336 M: enumerated set-at seq>> set-nth ; inline
 337
 338 M: enumerated delete-at seq>> remove-nth! drop ; inline
 339
 340 M: enumerated >alist ; inline
 341
 342 M: enumerated keys seq>> length <iota> >array ; inline
 343
 344 M: enumerated values seq>> >array ; inline
 345
 346 M: enumerated unzip seq>> [ length <iota> ] keep [ >array ] bi@ ;
 347
 348 M: enumerated assoc-size seq>> length ; inline
 349
 350 M: enumerated clear-assoc seq>> delete-all ; inline
 351
 352 INSTANCE: enumerated assoc
 353
 354 M: enumerated length seq>> length ; inline
 355
 356 M: enumerated nth-unsafe dupd seq>> nth-unsafe 2array ; inline
 357
 358 INSTANCE: enumerated immutable-sequence