Bi-assocs: fast at and value-at

core/assocs/assocs.factor

@@ -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 )
+M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
-    swap [ = nip ] curry assoc-find 2drop ;
+
+: value-at ( value assoc -- key/f ) value-at* drop ;
+
+: value? ( value assoc -- ? ) value-at* nip ;
 
 : push-at ( value key assoc -- )
     [ ?push ] change-at ;

extra/biassocs/biassocs-tests.factor

@@ -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

extra/biassocs/biassocs.factor

@@ -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