extra/slides/lib.factor

   1 USING: arrays assocs kernel vectors sequences namespaces
   2        random math.parser math fry ;
   3
   4 IN: assocs.lib
   5
   6 : set-assoc-stack ( value key seq -- )
   7     dupd [ key? ] with find-last nip set-at ;
   8
   9 : at-default ( key assoc -- value/key )
  10     dupd at [ nip ] when* ;
  11
  12 : replace-at ( assoc value key -- assoc )
  13     >r >r dup r> 1vector r> rot set-at ;
  14
  15 : peek-at* ( assoc key -- obj ? )
  16     swap at* dup [ >r peek r> ] when ;
  17
  18 : peek-at ( assoc key -- obj )
  19     peek-at* drop ;
  20
  21 : >multi-assoc ( assoc -- new-assoc )
  22     [ 1vector ] assoc-map ;
  23
  24 : multi-assoc-each ( assoc quot -- )
  25     [ with each ] curry assoc-each ; inline
  26
  27 : insert ( value variable -- ) namespace push-at ;
  28
  29 : generate-key ( assoc -- str )
  30     >r 32 random-bits >hex r>
  31     2dup key? [ nip generate-key ] [ drop ] if ;
  32
  33 : set-at-unique ( value assoc -- key )
  34     dup generate-key [ swap set-at ] keep ;
  35
  36 : histogram ( assoc quot -- assoc' )
  37     H{ } clone [
  38         swap [ change-at ] 2curry assoc-each
  39     ] keep ; inline
  40
  41 : inc-at ( key assoc -- )
  42     [ 0 or 1 + ] change-at ;
  43
  44 : ?at ( obj assoc -- value/obj ? )
  45     dupd at* [ [ nip ] [ drop ] if ] keep ;
  46
  47 : if-at ( obj assoc quot1 quot2 -- )
  48     [ ?at ] 2dip if ; inline
  49
  50 : when-at ( obj assoc quot -- ) [ ] if-at ; inline
  51
  52 : unless-at ( obj assoc quot -- ) [ ] swap if-at ; inline