basis/linked-assocs/linked-assocs.factor

   1 ! Copyright (C) 2008 Slava Pestov, James Cash.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes deques dlists hashtables
   4 kernel parser sequences.private vocabs.loader ;
   5 IN: linked-assocs
   6
   7 TUPLE: linked-assoc { assoc read-only } { dlist dlist read-only } ;
   8
   9 : <linked-assoc> ( exemplar -- assoc )
  10     0 swap new-assoc <dlist> linked-assoc boa ;
  11
  12 : <linked-hash> ( -- assoc )
  13     H{ } <linked-assoc> ;
  14
  15 M: linked-assoc assoc-size assoc>> assoc-size ;
  16
  17 M: linked-assoc at*
  18     assoc>> at* [ [ obj>> second-unsafe ] when ] keep ;
  19
  20 <PRIVATE
  21
  22 : (delete-at) ( key assoc dlist -- )
  23     '[ at [ _ delete-node ] when* ] [ delete-at ] 2bi ; inline
  24
  25 PRIVATE>
  26
  27 M: linked-assoc delete-at
  28     [ assoc>> ] [ dlist>> ] bi (delete-at) ;
  29
  30 <PRIVATE
  31
  32 : add-to-dlist ( value key dlist -- node )
  33     [ swap 2array ] dip push-back* ; inline
  34
  35 PRIVATE>
  36
  37 M: linked-assoc set-at
  38     [ assoc>> ] [ dlist>> ] bi
  39     '[ _ 2over key? [ 3dup (delete-at) ] when nip add-to-dlist ]
  40     [ set-at ] 2bi ;
  41
  42 M: linked-assoc >alist
  43     dlist>> dlist>sequence ;
  44
  45 M: linked-assoc clear-assoc
  46     [ assoc>> clear-assoc ] [ dlist>> clear-deque ] bi ;
  47
  48 M: linked-assoc clone
  49     [ assoc>> clone ] [ dlist>> clone ] bi linked-assoc boa ;
  50
  51 INSTANCE: linked-assoc assoc
  52
  53 : >linked-hash ( assoc -- assoc' )
  54     [ <linked-hash> ] dip assoc-union! ;
  55
  56 M: linked-assoc assoc-like
  57     over linked-assoc?
  58     [ 2dup [ assoc>> ] bi@ class-of instance? ] [ f ] if
  59     [ drop ] [ assoc>> <linked-assoc> swap assoc-union! ] if ;
  60
  61 M: linked-assoc equal?
  62     over linked-assoc? [ [ dlist>> ] bi@ = ] [ 2drop f ] if ;
  63
  64 SYNTAX: LH{ \ } [ check-hashtable >linked-hash ] parse-literal ;
  65
  66 { "linked-assocs" "prettyprint" } "linked-assocs.prettyprint" require-when