core/assocs/assocs.factor

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