From fd879b16c7daffb2d772fc0145209a8214eff4a4 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Sat, 6 Apr 2013 14:12:47 -0700
Subject: [PATCH] hash-sets.identity: adding identity hashsets.
---
basis/hash-sets/identity/authors.txt | 1 +
.../hash-sets/identity/identity-tests.factor | 27 ++++++++++++++
basis/hash-sets/identity/identity.factor | 37 +++++++++++++++++++
.../identity/prettyprint/prettyprint.factor | 8 ++++
4 files changed, 73 insertions(+)
create mode 100644 basis/hash-sets/identity/authors.txt
create mode 100644 basis/hash-sets/identity/identity-tests.factor
create mode 100644 basis/hash-sets/identity/identity.factor
create mode 100644 basis/hash-sets/identity/prettyprint/prettyprint.factor
diff --git a/basis/hash-sets/identity/authors.txt b/basis/hash-sets/identity/authors.txt
new file mode 100644
index 0000000000..e091bb8164
--- /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
index 0000000000..a9752b53bd
--- /dev/null
+++ b/basis/hash-sets/identity/identity-tests.factor
@@ -0,0 +1,27 @@
+USING: hash-sets.identity kernel literals sets tools.test ;
+IN: hash-sets.identity.tests
+
+CONSTANT: the-real-slim-shady "marshall mathers"
+
+CONSTANT: will
+ IHS{
+ $ the-real-slim-shady
+ "marshall mathers"
+ }
+
+: please-stand-up ( set obj -- ? )
+ swap in? ;
+
+[ 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 cardinality ] unit-test
+[ { "marshall mathers" } ] [
+ the-real-slim-shady will clone
+ [ delete ] [ members ] bi
+] unit-test
+
+CONSTANT: same-as-it-ever-was "same as it ever was"
+
+{ IHS{ $ same-as-it-ever-was } }
+[ HS{ $ same-as-it-ever-was } IHS{ } set-like ] unit-test
diff --git a/basis/hash-sets/identity/identity.factor b/basis/hash-sets/identity/identity.factor
new file mode 100644
index 0000000000..dad416c19d
--- /dev/null
+++ b/basis/hash-sets/identity/identity.factor
@@ -0,0 +1,37 @@
+! Copyright (C) 2013 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors hash-sets hash-sets.wrapped kernel parser
+sequences sets sets.private vocabs.loader ;
+IN: hash-sets.identity
+
+TUPLE: identity-wrapper < wrapped-key identity-hashcode ;
+
+: <identity-wrapper> ( wrapped-key -- identity-wrapper )
+ dup identity-hashcode identity-wrapper boa ; inline
+
+M: identity-wrapper equal?
+ over identity-wrapper?
+ [ [ underlying>> ] bi@ eq? ]
+ [ 2drop f ] if ; inline
+
+M: identity-wrapper hashcode* nip identity-hashcode>> ; inline
+
+TUPLE: identity-hash-set < wrapped-hash-set ;
+
+: <identity-hash-set> ( n -- ihash-set )
+ <hash-set> identity-hash-set boa ; inline
+
+M: identity-hash-set wrap-key drop <identity-wrapper> ;
+
+M: identity-hash-set clone
+ underlying>> clone identity-hash-set boa ; inline
+
+: >identity-hash-set ( members -- ihash-set )
+ [ <identity-wrapper> ] map >hash-set identity-hash-set boa ; inline
+
+M: identity-hash-set set-like
+ drop dup identity-hash-set? [ ?members >identity-hash-set ] unless ; inline
+
+SYNTAX: IHS{ \ } [ >identity-hash-set ] parse-literal ;
+
+{ "hash-sets.identity" "prettyprint" } "hash-sets.identity.prettyprint" require-when
diff --git a/basis/hash-sets/identity/prettyprint/prettyprint.factor b/basis/hash-sets/identity/prettyprint/prettyprint.factor
new file mode 100644
index 0000000000..d45ac1a623
--- /dev/null
+++ b/basis/hash-sets/identity/prettyprint/prettyprint.factor
@@ -0,0 +1,8 @@
+! Copyright (C) 2013 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license
+
+USING: hash-sets.identity kernel prettyprint.custom ;
+
+IN: hash-sets.identity.prettyprint
+
+M: identity-hash-set pprint-delims drop \ IHS{ \ } ;