From c186b54449f8048dc45761ff5d9781c373aba22b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 17 Jun 2010 21:41:56 -0700
Subject: [PATCH] new vocab hashtables.identity: cheesy identity hashtables

---
 extra/hashtables/identity/authors.txt         |  1 +
 .../hashtables/identity/identity-tests.factor | 31 ++++++++++
 extra/hashtables/identity/identity.factor     | 62 +++++++++++++++++++
 .../identity/mirrors/mirrors.factor           |  4 ++
 .../identity/prettyprint/prettyprint.factor   | 12 ++++
 extra/hashtables/identity/summary.txt         |  1 +
 6 files changed, 111 insertions(+)
 create mode 100644 extra/hashtables/identity/authors.txt
 create mode 100644 extra/hashtables/identity/identity-tests.factor
 create mode 100644 extra/hashtables/identity/identity.factor
 create mode 100644 extra/hashtables/identity/mirrors/mirrors.factor
 create mode 100644 extra/hashtables/identity/prettyprint/prettyprint.factor
 create mode 100644 extra/hashtables/identity/summary.txt

diff --git a/extra/hashtables/identity/authors.txt b/extra/hashtables/identity/authors.txt
new file mode 100644
index 0000000000..6a1b3e726a
--- /dev/null
+++ b/extra/hashtables/identity/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/hashtables/identity/identity-tests.factor b/extra/hashtables/identity/identity-tests.factor
new file mode 100644
index 0000000000..871d8e3d32
--- /dev/null
+++ b/extra/hashtables/identity/identity-tests.factor
@@ -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
diff --git a/extra/hashtables/identity/identity.factor b/extra/hashtables/identity/identity.factor
new file mode 100644
index 0000000000..5f1aeca636
--- /dev/null
+++ b/extra/hashtables/identity/identity.factor
@@ -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
diff --git a/extra/hashtables/identity/mirrors/mirrors.factor b/extra/hashtables/identity/mirrors/mirrors.factor
new file mode 100644
index 0000000000..1ba891cd85
--- /dev/null
+++ b/extra/hashtables/identity/mirrors/mirrors.factor
@@ -0,0 +1,4 @@
+USING: hashtables.identity mirrors ;
+IN: hashtables.identity.mirrors
+
+M: identity-hashtable make-mirror ;
diff --git a/extra/hashtables/identity/prettyprint/prettyprint.factor b/extra/hashtables/identity/prettyprint/prettyprint.factor
new file mode 100644
index 0000000000..15a4849257
--- /dev/null
+++ b/extra/hashtables/identity/prettyprint/prettyprint.factor
@@ -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 ;
diff --git a/extra/hashtables/identity/summary.txt b/extra/hashtables/identity/summary.txt
new file mode 100644
index 0000000000..6c6ec09e85
--- /dev/null
+++ b/extra/hashtables/identity/summary.txt
@@ -0,0 +1 @@
+Hashtables keyed by object identity (eq?) rather than by logical value (=)