Bi-assocs: fast at and value-at
parent
50ac09aa9e
commit
0770d50d7b
|
@ -144,10 +144,13 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
: extract-keys ( seq assoc -- subassoc )
|
||||
[ [ dupd at ] curry ] keep map>assoc ;
|
||||
|
||||
! M: assoc >alist [ 2array ] { } assoc>map ;
|
||||
GENERIC: value-at* ( value assoc -- key/f ? )
|
||||
|
||||
: value-at ( value assoc -- key/f )
|
||||
swap [ = nip ] curry assoc-find 2drop ;
|
||||
M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
|
||||
|
||||
: value-at ( value assoc -- key/f ) value-at* drop ;
|
||||
|
||||
: value? ( value assoc -- ? ) value-at* nip ;
|
||||
|
||||
: push-at ( value key assoc -- )
|
||||
[ ?push ] change-at ;
|
||||
|
|
|
@ -0,0 +1,22 @@
|
|||
IN: biassocs.tests
|
||||
USING: biassocs assocs namespaces tools.test ;
|
||||
|
||||
<bihash> "h" set
|
||||
|
||||
[ 0 ] [ "h" get assoc-size ] unit-test
|
||||
|
||||
[ ] [ 1 2 "h" get set-at ] unit-test
|
||||
|
||||
[ 1 ] [ 2 "h" get at ] unit-test
|
||||
|
||||
[ 2 ] [ 1 "h" get value-at ] unit-test
|
||||
|
||||
[ 1 ] [ "h" get assoc-size ] unit-test
|
||||
|
||||
[ ] [ 1 3 "h" get set-at ] unit-test
|
||||
|
||||
[ 1 ] [ 3 "h" get at ] unit-test
|
||||
|
||||
[ 2 ] [ 1 "h" get value-at ] unit-test
|
||||
|
||||
[ 2 ] [ "h" get assoc-size ] unit-test
|
|
@ -0,0 +1,35 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs accessors ;
|
||||
IN: biassocs
|
||||
|
||||
TUPLE: biassoc from to ;
|
||||
|
||||
: <biassoc> ( exemplar -- biassoc )
|
||||
[ clone ] [ clone ] bi biassoc boa ;
|
||||
|
||||
: <bihash> ( -- bihashtable )
|
||||
H{ } <biassoc> ;
|
||||
|
||||
M: biassoc assoc-size from>> assoc-size ;
|
||||
|
||||
M: biassoc at* from>> at* ;
|
||||
|
||||
M: biassoc value-at* to>> at* ;
|
||||
|
||||
: once-at ( value key assoc -- )
|
||||
2dup key? [ 3drop ] [ set-at ] if ;
|
||||
|
||||
M: biassoc set-at
|
||||
[ from>> set-at ] [ swapd to>> once-at ] 3bi ;
|
||||
|
||||
M: biassoc delete-at
|
||||
"biassocs do not support deletion" throw ;
|
||||
|
||||
M: biassoc >alist
|
||||
from>> >alist ;
|
||||
|
||||
M: biassoc clear-assoc
|
||||
[ from>> clear-assoc ] [ to>> clear-assoc ] bi ;
|
||||
|
||||
INSTANCE: biassoc assoc
|
Loading…
Reference in New Issue