basis/hashtables/identity/identity.factor

   1 ! (c)2010 Joe Groff bsd license\r
   2 USING: accessors assocs hashtables hashtables.wrapped kernel\r
   3 parser vocabs.loader ;\r
   4 IN: hashtables.identity\r
   5 \r
   6 TUPLE: identity-wrapper < wrapped-key identity-hashcode ;\r
   7 \r
   8 : <identity-wrapper> ( wrapped-key -- identity-wrapper )\r
   9     dup identity-hashcode identity-wrapper boa ; inline\r
  10 \r
  11 M: identity-wrapper equal?\r
  12     over identity-wrapper?\r
  13     [ [ underlying>> ] bi@ eq? ]\r
  14     [ 2drop f ] if ; inline\r
  15 \r
  16 M: identity-wrapper hashcode* nip identity-hashcode>> ; inline\r
  17 \r
  18 TUPLE: identity-hashtable < wrapped-hashtable ;\r
  19 \r
  20 : <identity-hashtable> ( n -- ihashtable )\r
  21     <hashtable> identity-hashtable boa ; inline\r
  22 \r
  23 M: identity-hashtable wrap-key drop <identity-wrapper> ;\r
  24 \r
  25 M: identity-hashtable clone\r
  26     underlying>> clone identity-hashtable boa ; inline\r
  27 \r
  28 : identity-associate ( value key -- ihashtable )\r
  29     2 <identity-hashtable> [ set-at ] keep ; inline\r
  30 \r
  31 : >identity-hashtable ( assoc -- ihashtable )\r
  32     [ assoc-size <identity-hashtable> ] keep assoc-union! ;\r
  33 \r
  34 M: identity-hashtable assoc-like\r
  35     drop dup identity-hashtable? [ >identity-hashtable ] unless ; inline\r
  36 \r
  37 M: identity-hashtable new-assoc drop <identity-hashtable> ;\r
  38 \r
  39 SYNTAX: IH{ \ } [ >identity-hashtable ] parse-literal ;\r
  40 \r
  41 { "hashtables.identity" "prettyprint" } "hashtables.identity.prettyprint" require-when\r
  42 { "hashtables.identity" "mirrors" } "hashtables.identity.mirrors" require-when\r