new vocab hashtables.identity: cheesy identity hashtables

db4
Joe Groff 2010-06-17 21:41:56 -07:00
parent 28a56df0da
commit c186b54449
6 changed files with 111 additions and 0 deletions

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -0,0 +1,31 @@
! (c)2010 Joe Groff bsd license
USING: assocs hashtables.identity kernel literals tools.test ;
IN: hashtables.identity.tests
CONSTANT: the-real-slim-shady "marshall mathers"
CONSTANT: will
IH{
{ $ the-real-slim-shady t }
{ "marshall mathers" f }
}
: please-stand-up ( assoc key -- value )
swap at ;
[ t ] [ will the-real-slim-shady please-stand-up ] unit-test
[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test
[ 2 ] [ will assoc-size ] unit-test
[ { { "marshall mathers" f } } ] [
the-real-slim-shady will clone
[ delete-at ] [ >alist ] bi
] unit-test
[ t ] [
t the-real-slim-shady identity-associate
t the-real-slim-shady identity-associate =
] unit-test
[ f ] [
t the-real-slim-shady identity-associate
t "marshall mathers" identity-associate =
] unit-test

View File

@ -0,0 +1,62 @@
! (c)2010 Joe Groff bsd license
USING: accessors arrays assocs fry hashtables kernel parser
sequences vocabs.loader ;
IN: hashtables.identity
TUPLE: identity-wrapper
{ underlying read-only } ;
C: <identity-wrapper> identity-wrapper
M: identity-wrapper equal?
over identity-wrapper?
[ [ underlying>> ] bi@ eq? ]
[ 2drop f ] if ; inline
M: identity-wrapper hashcode*
nip underlying>> identity-hashcode ; inline
TUPLE: identity-hashtable
{ underlying hashtable read-only } ;
: <identity-hashtable> ( n -- ihash )
<hashtable> identity-hashtable boa ; inline
<PRIVATE
: identity@ ( key ihash -- ikey hash )
[ <identity-wrapper> ] [ underlying>> ] bi* ; inline
PRIVATE>
M: identity-hashtable at*
identity@ at* ; inline
M: identity-hashtable clear-assoc
underlying>> clear-assoc ; inline
M: identity-hashtable delete-at
identity@ delete-at ; inline
M: identity-hashtable assoc-size
underlying>> assoc-size ; inline
M: identity-hashtable set-at
identity@ set-at ; inline
: identity-associate ( value key -- hash )
2 <identity-hashtable> [ set-at ] keep ; inline
M: identity-hashtable >alist
underlying>> >alist [ [ first underlying>> ] [ second ] bi 2array ] map ;
M: identity-hashtable clone
underlying>> clone identity-hashtable boa ; inline
M: identity-hashtable equal?
over identity-hashtable? [ [ underlying>> ] bi@ = ] [ 2drop f ] if ;
: >identity-hashtable ( assoc -- ihashtable )
dup assoc-size <identity-hashtable> [ '[ swap _ set-at ] assoc-each ] keep ;
SYNTAX: IH{ \ } [ >identity-hashtable ] parse-literal ;
{ "hashtables.identity" "prettyprint" } "hashtables.identity.prettyprint" require-when
{ "hashtables.identity" "mirrors" } "hashtables.identity.mirrors" require-when

View File

@ -0,0 +1,4 @@
USING: hashtables.identity mirrors ;
IN: hashtables.identity.mirrors
M: identity-hashtable make-mirror ;

View File

@ -0,0 +1,12 @@
! (c)2010 Joe Groff bsd license
USING: assocs continuations hashtables.identity kernel
namespaces prettyprint.backend prettyprint.config
prettyprint.custom ;
IN: hashtables.identity.prettyprint
M: identity-hashtable >pprint-sequence >alist ;
M: identity-hashtable pprint-delims drop \ IH{ \ } ;
M: identity-hashtable pprint*
nesting-limit inc
[ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;

View File

@ -0,0 +1 @@
Hashtables keyed by object identity (eq?) rather than by logical value (=)