new vocab hashtables.identity: cheesy identity hashtables
parent
28a56df0da
commit
c186b54449
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
|
@ -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
|
|
@ -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
|
|
@ -0,0 +1,4 @@
|
|||
USING: hashtables.identity mirrors ;
|
||||
IN: hashtables.identity.mirrors
|
||||
|
||||
M: identity-hashtable make-mirror ;
|
|
@ -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 ;
|
|
@ -0,0 +1 @@
|
|||
Hashtables keyed by object identity (eq?) rather than by logical value (=)
|
Loading…
Reference in New Issue