diff --git a/extra/pairs/authors.txt b/extra/pairs/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/pairs/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/pairs/pairs-tests.factor b/extra/pairs/pairs-tests.factor new file mode 100644 index 0000000000..524f7680ed --- /dev/null +++ b/extra/pairs/pairs-tests.factor @@ -0,0 +1,23 @@ +IN: pairs.tests +USING: namespaces assocs tools.test pairs ; + +SYMBOL: blah + +"blah" blah "b" set + +[ "blah" t ] [ blah "b" get at* ] unit-test +[ f f ] [ "fdaf" "b" get at* ] unit-test +[ 1 ] [ "b" get assoc-size ] unit-test +[ { { blah "blah" } } ] [ "b" get >alist ] unit-test +[ ] [ "bleah" blah "b" get set-at ] unit-test +[ 1 ] [ "b" get assoc-size ] unit-test +[ { { blah "bleah" } } ] [ "b" get >alist ] unit-test +[ "bleah" t ] [ blah "b" get at* ] unit-test +[ f f ] [ "fdaf" "b" get at* ] unit-test +[ blah "b" get delete-at ] must-fail +[ ] [ 1 2 "b" get set-at ] unit-test +[ "bleah" t ] [ blah "b" get at* ] unit-test +[ 1 t ] [ 2 "b" get at* ] unit-test +[ f f ] [ "fdaf" "b" get at* ] unit-test +[ 2 ] [ "b" get assoc-size ] unit-test +[ { { 2 1 } { blah "bleah" } } ] [ "b" get >alist ] unit-test diff --git a/extra/pairs/pairs.factor b/extra/pairs/pairs.factor new file mode 100644 index 0000000000..2b19d95833 --- /dev/null +++ b/extra/pairs/pairs.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: hashtables kernel assocs accessors math arrays sequences ; +IN: pairs + +TUPLE: pair value key hash ; + +: ( value key -- assoc ) + f pair boa ; inline + +: if-hash ( pair true-quot false-quot -- ) + [ dup hash>> ] 2dip ?if ; inline + +M: pair assoc-size + [ assoc-size 1 + ] [ drop 1 ] if-hash ; inline + +: if-key ( key pair true-quot false-quot -- ) + [ [ 2dup key>> eq? ] dip [ nip ] prepose ] dip if ; inline + +M: pair at* + [ value>> t ] [ + [ at* ] [ 2drop f f ] if-hash + ] if-key ; inline + +M: pair set-at + [ (>>value) ] [ + [ set-at ] + [ [ associate ] dip swap >>hash drop ] if-hash + ] if-key ; inline + +ERROR: cannot-delete-key pair ; + +M: pair delete-at + [ cannot-delete-key ] [ + [ delete-at ] [ 2drop ] if-hash + ] if-key ; inline + +M: pair >alist + [ hash>> >alist ] [ [ key>> ] [ value>> ] bi 2array ] bi suffix ; inline + +INSTANCE: pair assoc diff --git a/extra/pairs/summary.txt b/extra/pairs/summary.txt new file mode 100644 index 0000000000..1a9e959a9f --- /dev/null +++ b/extra/pairs/summary.txt @@ -0,0 +1 @@ +Assoc implementation optimized for a single key/value pair