hash-sets.identity: adding identity hashsets.

diff --git a/basis/hash-sets/identity/authors.txt b/basis/hash-sets/identity/authors.txt
new file mode 100644 (file)
index 0000000..e091bb8
--- /dev/null
+++ b/basis/hash-sets/identity/authors.txt
@@ -0,0 +1 @@
+John Benediktsson

diff --git a/basis/hash-sets/identity/identity-tests.factor b/basis/hash-sets/identity/identity-tests.factor
new file mode 100644 (file)
index 0000000..a9752b5
--- /dev/null
+++ b/basis/hash-sets/identity/identity-tests.factor
@@ -0,0 +1,27 @@
+USING: hash-sets.identity kernel literals sets tools.test ;\r
+IN: hash-sets.identity.tests\r
+\r
+CONSTANT: the-real-slim-shady "marshall mathers"\r
+\r
+CONSTANT: will\r
+    IHS{\r
+        $ the-real-slim-shady\r
+        "marshall mathers"\r
+    }\r
+\r
+: please-stand-up ( set obj -- ? )\r
+    swap in? ;\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 cardinality ] unit-test\r
+[ { "marshall mathers" } ] [\r
+    the-real-slim-shady will clone\r
+    [ delete ] [ members ] bi\r
+] unit-test\r
+\r
+CONSTANT: same-as-it-ever-was "same as it ever was"\r
+\r
+{ IHS{ $ same-as-it-ever-was } }\r
+[ HS{ $ same-as-it-ever-was } IHS{ } set-like ] unit-test\r

diff --git a/basis/hash-sets/identity/identity.factor b/basis/hash-sets/identity/identity.factor
new file mode 100644 (file)
index 0000000..dad416c
--- /dev/null
+++ b/basis/hash-sets/identity/identity.factor
@@ -0,0 +1,37 @@
+! Copyright (C) 2013 John Benediktsson.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors hash-sets hash-sets.wrapped kernel parser\r
+sequences sets sets.private vocabs.loader ;\r
+IN: hash-sets.identity\r
+\r
+TUPLE: identity-wrapper < wrapped-key identity-hashcode ;\r
+\r
+: <identity-wrapper> ( wrapped-key -- identity-wrapper )\r
+    dup identity-hashcode identity-wrapper boa ; inline\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* nip identity-hashcode>> ; inline\r
+\r
+TUPLE: identity-hash-set < wrapped-hash-set ;\r
+\r
+: <identity-hash-set> ( n -- ihash-set )\r
+    <hash-set> identity-hash-set boa ; inline\r
+\r
+M: identity-hash-set wrap-key drop <identity-wrapper> ;\r
+\r
+M: identity-hash-set clone\r
+    underlying>> clone identity-hash-set boa ; inline\r
+\r
+: >identity-hash-set ( members -- ihash-set )\r
+    [ <identity-wrapper> ] map >hash-set identity-hash-set boa ; inline\r
+\r
+M: identity-hash-set set-like\r
+    drop dup identity-hash-set? [ ?members >identity-hash-set ] unless ; inline\r
+\r
+SYNTAX: IHS{ \ } [ >identity-hash-set ] parse-literal ;\r
+\r
+{ "hash-sets.identity" "prettyprint" } "hash-sets.identity.prettyprint" require-when\r

diff --git a/basis/hash-sets/identity/prettyprint/prettyprint.factor b/basis/hash-sets/identity/prettyprint/prettyprint.factor
new file mode 100644 (file)
index 0000000..d45ac1a
--- /dev/null
+++ b/basis/hash-sets/identity/prettyprint/prettyprint.factor
@@ -0,0 +1,8 @@
+! Copyright (C) 2013 John Benediktsson.\r
+! See http://factorcode.org/license.txt for BSD license\r
+\r
+USING: hash-sets.identity kernel prettyprint.custom ;\r
+\r
+IN: hash-sets.identity.prettyprint\r
+\r
+M: identity-hash-set pprint-delims drop \ IHS{ \ } ;\r