core/assocs/assocs.factor

   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
   4 accessors ;
   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
  20 M: assoc assoc-like drop ; inline
  21
  22 : ?at ( key assoc -- value/key ? )
  23     2dup at* [ 2nip t ] [ 2drop f ] if ; inline
  24
  25 : maybe-set-at ( value key assoc -- changed? )
  26     3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ;
  27
  28 <PRIVATE
  29
  30 : (assoc-each) ( assoc quot -- seq quot' )
  31     [ >alist ] dip [ first2 ] prepose ; inline
  32
  33 : (assoc-stack) ( key i seq -- value )
  34     over 0 < [
  35         3drop f
  36     ] [
  37         3dup nth-unsafe at*
  38         [ [ 3drop ] dip ] [ drop [ 1 - ] dip (assoc-stack) ] if
  39     ] if ; inline recursive
  40
  41 : search-alist ( key alist -- pair/f i/f )
  42     [ first = ] with find swap ; inline
  43
  44 : substituter ( assoc -- quot )
  45     [ ?at drop ] curry ; inline
  46
  47 : with-assoc ( assoc quot: ( value key assoc -- ) -- quot: ( key value -- ) )
  48     curry [ swap ] prepose ; inline
  49
  50 PRIVATE>
  51
  52 : assoc-find ( assoc quot -- key value ? )
  53     (assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
  54
  55 : key? ( key assoc -- ? ) at* nip ; inline
  56
  57 : assoc-each ( assoc quot -- )
  58     (assoc-each) each ; inline
  59
  60 : assoc>map ( assoc quot exemplar -- seq )
  61     [ accumulator [ assoc-each ] dip ] dip like ; inline
  62
  63 : assoc-map-as ( assoc quot exemplar -- newassoc )
  64     [ [ 2array ] compose V{ } assoc>map ] dip assoc-like ; inline
  65
  66 : assoc-map ( assoc quot -- newassoc )
  67     over assoc-map-as ; inline
  68
  69 : assoc-filter-as ( assoc quot exemplar -- subassoc )
  70     [ (assoc-each) filter ] dip assoc-like ; inline
  71
  72 : assoc-filter ( assoc quot -- subassoc )
  73     over assoc-filter-as ; inline
  74
  75 : assoc-partition ( assoc quot -- true-assoc false-assoc )
  76     [ (assoc-each) partition ] [ drop ] 2bi
  77     [ assoc-like ] curry bi@ ; inline
  78
  79 : assoc-any? ( assoc quot -- ? )
  80     assoc-find 2nip ; inline
  81
  82 : assoc-all? ( assoc quot -- ? )
  83     [ not ] compose assoc-any? not ; inline
  84
  85 : at ( key assoc -- value/f )
  86     at* drop ; inline
  87
  88 M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
  89     [ dup assoc-size ] dip new-assoc
  90     [ [ set-at ] with-assoc assoc-each ] keep ; inline
  91
  92 : keys ( assoc -- keys )
  93     [ drop ] { } assoc>map ;
  94
  95 : values ( assoc -- values )
  96     [ nip ] { } assoc>map ;
  97
  98 : delete-at* ( key assoc -- old ? )
  99     [ at* ] 2keep delete-at ;
 100
 101 : rename-at ( newkey key assoc -- )
 102     [ delete-at* ] keep [ set-at ] with-assoc [ 2drop ] if ;
 103
 104 : assoc-empty? ( assoc -- ? )
 105     assoc-size 0 = ;
 106
 107 : assoc-stack ( key seq -- value )
 108     [ length 1 - ] keep (assoc-stack) ; flushable
 109
 110 : assoc-subset? ( assoc1 assoc2 -- ? )
 111     [ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ;
 112
 113 : assoc= ( assoc1 assoc2 -- ? )
 114     [ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
 115
 116 : assoc-hashcode ( n assoc -- code )
 117     >alist hashcode* ;
 118
 119 : assoc-intersect ( assoc1 assoc2 -- intersection )
 120     swap [ nip key? ] curry assoc-filter ;
 121
 122 : update ( assoc1 assoc2 -- )
 123     swap [ set-at ] with-assoc assoc-each ;
 124
 125 : assoc-union ( assoc1 assoc2 -- union )
 126     [ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
 127     [ dupd update ] bi@ ;
 128
 129 : assoc-combine ( seq -- union )
 130     H{ } clone [ dupd update ] reduce ;
 131
 132 : assoc-refine ( seq -- assoc )
 133     [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
 134
 135 : assoc-diff ( assoc1 assoc2 -- diff )
 136     [ nip key? not ] curry assoc-filter ;
 137
 138 : substitute ( seq assoc -- newseq )
 139     substituter map ;
 140
 141 : cache ( key assoc quot -- value )
 142     [ [ at* ] 2keep ] dip
 143     [ [ nip call dup ] [ drop ] 3bi set-at ] 3curry
 144     [ drop ] prepose
 145     unless ; inline
 146
 147 : 2cache ( key1 key2 assoc quot -- value )
 148     [ 2array ] 2dip [ first2 ] prepose cache ; inline
 149
 150 : change-at ( key assoc quot -- )
 151     [ [ at ] dip call ] [ drop ] 3bi set-at ; inline
 152
 153 : at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline
 154
 155 : inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline
 156
 157 : map>assoc ( seq quot exemplar -- assoc )
 158     [ [ 2array ] compose { } map-as ] dip assoc-like ; inline
 159
 160 : extract-keys ( seq assoc -- subassoc )
 161     [ [ dupd at ] curry ] keep map>assoc ;
 162
 163 M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
 164
 165 : value-at ( value assoc -- key/f ) value-at* drop ;
 166
 167 : value? ( value assoc -- ? ) value-at* nip ;
 168
 169 : push-at ( value key assoc -- )
 170     [ ?push ] change-at ;
 171
 172 : zip ( keys values -- alist )
 173     2array flip ; inline
 174
 175 : unzip ( assoc -- keys values )
 176     dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
 177
 178 M: sequence at*
 179     search-alist [ second t ] [ f ] if ;
 180
 181 M: sequence set-at
 182     2dup search-alist
 183     [ 2nip set-second ]
 184     [ drop [ swap 2array ] dip push ] if ;
 185
 186 M: sequence new-assoc drop <vector> ; inline
 187
 188 M: sequence clear-assoc delete-all ; inline
 189
 190 M: sequence delete-at
 191     [ nip ] [ search-alist nip ] 2bi
 192     [ swap remove-nth! drop ] [ drop ] if* ;
 193
 194 M: sequence assoc-size length ; inline
 195
 196 M: sequence assoc-clone-like
 197     [ >alist ] dip clone-like ; inline
 198
 199 M: sequence assoc-like
 200     [ >alist ] dip like ; inline
 201
 202 M: sequence >alist ; inline
 203
 204 ! Override sequence => assoc instance for f
 205 M: f at* 2drop f f ; inline
 206
 207 M: f assoc-size drop 0 ; inline
 208
 209 M: f clear-assoc drop ; inline
 210
 211 M: f assoc-like drop dup assoc-empty? [ drop f ] when ; inline
 212
 213 INSTANCE: sequence assoc
 214
 215 TUPLE: enum { seq read-only } ;
 216
 217 C: <enum> enum
 218
 219 M: enum at*
 220     seq>> 2dup bounds-check?
 221     [ nth t ] [ 2drop f f ] if ; inline
 222
 223 M: enum set-at seq>> set-nth ; inline
 224
 225 M: enum delete-at seq>> remove-nth! drop ; inline
 226
 227 M: enum >alist ( enum -- alist )
 228     seq>> [ length ] keep zip ; inline
 229
 230 M: enum assoc-size seq>> length ; inline
 231
 232 M: enum clear-assoc seq>> delete-all ; inline
 233
 234 INSTANCE: enum assoc