2008-08-06 02:06:14 -04:00
|
|
|
! Based on Clojure's PersistentHashMap by Rich Hickey.
|
|
|
|
|
|
|
|
USING: kernel math accessors assocs fry combinators parser
|
2009-11-05 15:05:06 -05:00
|
|
|
prettyprint.custom locals make
|
2008-08-06 02:06:14 -04:00
|
|
|
persistent.assocs
|
|
|
|
persistent.hashtables.nodes
|
|
|
|
persistent.hashtables.nodes.empty
|
|
|
|
persistent.hashtables.nodes.leaf
|
|
|
|
persistent.hashtables.nodes.full
|
|
|
|
persistent.hashtables.nodes.bitmap
|
|
|
|
persistent.hashtables.nodes.collision ;
|
|
|
|
IN: persistent.hashtables
|
|
|
|
|
|
|
|
TUPLE: persistent-hash
|
|
|
|
{ root read-only initial: empty-node }
|
|
|
|
{ count fixnum read-only } ;
|
|
|
|
|
|
|
|
M: persistent-hash assoc-size count>> ;
|
|
|
|
|
|
|
|
M: persistent-hash at*
|
|
|
|
[ dup hashcode >fixnum ] [ root>> ] bi* (entry-at)
|
|
|
|
dup [ value>> t ] [ f ] if ;
|
|
|
|
|
|
|
|
M: persistent-hash new-at ( value key assoc -- assoc' )
|
|
|
|
[
|
|
|
|
{ [ 0 ] [ ] [ dup hashcode >fixnum ] [ root>> ] } spread
|
|
|
|
(new-at) 1 0 ?
|
|
|
|
] [ count>> ] bi +
|
|
|
|
persistent-hash boa ;
|
|
|
|
|
|
|
|
M: persistent-hash pluck-at
|
|
|
|
[ [ dup hashcode >fixnum ] [ root>> ] bi* (pluck-at) ] keep
|
|
|
|
{
|
|
|
|
{ [ 2dup root>> eq? ] [ nip ] }
|
|
|
|
{ [ over not ] [ 2drop T{ persistent-hash } ] }
|
2009-08-13 20:21:44 -04:00
|
|
|
[ count>> 1 - persistent-hash boa ]
|
2008-08-06 02:06:14 -04:00
|
|
|
} cond ;
|
|
|
|
|
|
|
|
M: persistent-hash >alist [ root>> >alist% ] { } make ;
|
|
|
|
|
2009-11-05 15:05:06 -05:00
|
|
|
:: >persistent-hash ( assoc -- phash )
|
|
|
|
T{ persistent-hash } assoc [| ph k v | v k ph new-at ] assoc-each ;
|
2008-08-06 02:06:14 -04:00
|
|
|
|
2008-08-06 20:01:17 -04:00
|
|
|
M: persistent-hash equal?
|
|
|
|
over persistent-hash? [ assoc= ] [ 2drop f ] if ;
|
|
|
|
|
|
|
|
M: persistent-hash hashcode* nip assoc-size ;
|
|
|
|
|
|
|
|
M: persistent-hash clone ;
|
|
|
|
|
2009-03-21 02:27:50 -04:00
|
|
|
SYNTAX: PH{ \ } [ >persistent-hash ] parse-literal ;
|
2008-08-06 02:06:14 -04:00
|
|
|
|
|
|
|
M: persistent-hash pprint-delims drop \ PH{ \ } ;
|
|
|
|
M: persistent-hash >pprint-sequence >alist ;
|
2008-09-06 04:23:54 -04:00
|
|
|
M: persistent-hash pprint* pprint-object ;
|
2008-11-13 01:10:37 -05:00
|
|
|
|
|
|
|
: passociate ( value key -- phash )
|
|
|
|
T{ persistent-hash } new-at ; inline
|