| 
									
										
										
										
											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
 |