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