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 ; + +: ( 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 ; + +: ( n -- ihash-set ) + identity-hash-set boa ; inline + +M: identity-hash-set wrap-key drop ; + +M: identity-hash-set clone + underlying>> clone identity-hash-set boa ; inline + +: >identity-hash-set ( members -- ihash-set ) + [ ] 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{ \ } ;