new vocab hashtables.identity: cheesy identity hashtables

diff --git a/extra/hashtables/identity/authors.txt b/extra/hashtables/identity/authors.txt
new file mode 100644 (file)
index 0000000..6a1b3e7
--- /dev/null
+++ b/extra/hashtables/identity/authors.txt
@@ -0,0 +1 @@
+Joe Groff\r

diff --git a/extra/hashtables/identity/identity-tests.factor b/extra/hashtables/identity/identity-tests.factor
new file mode 100644 (file)
index 0000000..871d8e3
--- /dev/null
+++ b/extra/hashtables/identity/identity-tests.factor
@@ -0,0 +1,31 @@
+! (c)2010 Joe Groff bsd license\r
+USING: assocs hashtables.identity kernel literals tools.test ;\r
+IN: hashtables.identity.tests\r
+\r
+CONSTANT: the-real-slim-shady "marshall mathers"\r
+\r
+CONSTANT: will\r
+    IH{\r
+        { $ the-real-slim-shady t }\r
+        { "marshall mathers"    f }\r
+    }\r
+\r
+: please-stand-up ( assoc key -- value )\r
+    swap at ;\r
+\r
+[ t ] [ will the-real-slim-shady please-stand-up ] unit-test\r
+[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test\r
+\r
+[ 2 ] [ will assoc-size ] unit-test\r
+[ { { "marshall mathers" f } } ] [\r
+    the-real-slim-shady will clone\r
+    [ delete-at ] [ >alist ] bi\r
+] unit-test\r
+[ t ] [\r
+    t the-real-slim-shady identity-associate\r
+    t the-real-slim-shady identity-associate =\r
+] unit-test\r
+[ f ] [\r
+    t the-real-slim-shady identity-associate\r
+    t "marshall mathers"  identity-associate =\r
+] unit-test\r

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

diff --git a/extra/hashtables/identity/mirrors/mirrors.factor b/extra/hashtables/identity/mirrors/mirrors.factor
new file mode 100644 (file)
index 0000000..1ba891c
--- /dev/null
+++ b/extra/hashtables/identity/mirrors/mirrors.factor
@@ -0,0 +1,4 @@
+USING: hashtables.identity mirrors ;\r
+IN: hashtables.identity.mirrors\r
+\r
+M: identity-hashtable make-mirror ;\r

diff --git a/extra/hashtables/identity/prettyprint/prettyprint.factor b/extra/hashtables/identity/prettyprint/prettyprint.factor
new file mode 100644 (file)
index 0000000..15a4849
--- /dev/null
+++ b/extra/hashtables/identity/prettyprint/prettyprint.factor
@@ -0,0 +1,12 @@
+! (c)2010 Joe Groff bsd license\r
+USING: assocs continuations hashtables.identity kernel\r
+namespaces prettyprint.backend prettyprint.config\r
+prettyprint.custom ;\r
+IN: hashtables.identity.prettyprint\r
+\r
+M: identity-hashtable >pprint-sequence >alist ;\r
+M: identity-hashtable pprint-delims drop \ IH{ \ } ;\r
+\r
+M: identity-hashtable pprint*\r
+    nesting-limit inc\r
+    [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;\r

diff --git a/extra/hashtables/identity/summary.txt b/extra/hashtables/identity/summary.txt
new file mode 100644 (file)
index 0000000..6c6ec09
--- /dev/null
+++ b/extra/hashtables/identity/summary.txt
@@ -0,0 +1 @@
+Hashtables keyed by object identity (eq?) rather than by logical value (=)\r