| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | ! Copyright (C) 2006, 2007 Slava Pestov. | 
					
						
							|  |  |  | ! See http://factorcode.org/license.txt for BSD license. | 
					
						
							| 
									
										
										
										
											2008-06-11 03:58:38 -04:00
										 |  |  | USING: assocs kernel namespaces sequences sets ;
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | IN: graphs | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | SYMBOL: graph | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : if-graph ( vertex edges graph quot -- )
 | 
					
						
							|  |  |  |     over
 | 
					
						
							|  |  |  |     [ graph swap with-variable ] | 
					
						
							|  |  |  |     [ 2drop 2drop ] if ; inline
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : nest ( key -- hash )
 | 
					
						
							|  |  |  |     graph get [ drop H{ } clone ] cache ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : add-vertex ( vertex edges graph -- )
 | 
					
						
							| 
									
										
										
										
											2008-01-09 17:36:30 -05:00
										 |  |  |     [ [ dupd nest set-at ] with each ] if-graph ; inline
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-01-12 04:25:16 -05:00
										 |  |  | : (add-vertex) ( key value vertex -- )
 | 
					
						
							|  |  |  |     rot nest set-at ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : add-vertex* ( vertex edges graph -- )
 | 
					
						
							|  |  |  |     [ | 
					
						
							|  |  |  |         swap [ (add-vertex) ] curry assoc-each
 | 
					
						
							|  |  |  |     ] if-graph ; inline
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | : remove-vertex ( vertex edges graph -- )
 | 
					
						
							| 
									
										
										
										
											2008-01-09 17:36:30 -05:00
										 |  |  |     [ [ graph get at delete-at ] with each ] if-graph ; inline
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-01-12 04:25:16 -05:00
										 |  |  | : (remove-vertex) ( key value vertex -- )
 | 
					
						
							|  |  |  |     rot graph get at delete-at drop ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : remove-vertex* ( vertex edges graph -- )
 | 
					
						
							|  |  |  |     [ | 
					
						
							|  |  |  |         swap [ (remove-vertex) ] curry assoc-each
 | 
					
						
							|  |  |  |     ] if-graph ; inline
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | SYMBOL: previous | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-07-18 20:22:59 -04:00
										 |  |  | : (closure) ( obj quot: ( elt -- assoc ) -- )
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  |     over previous get key? [ | 
					
						
							|  |  |  |         2drop
 | 
					
						
							|  |  |  |     ] [ | 
					
						
							| 
									
										
										
										
											2008-06-11 03:58:38 -04:00
										 |  |  |         over previous get conjoin | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  |         dup slip | 
					
						
							|  |  |  |         [ nip (closure) ] curry assoc-each
 | 
					
						
							| 
									
										
										
										
											2008-07-18 20:22:59 -04:00
										 |  |  |     ] if ; inline recursive
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | : closure ( obj quot -- assoc )
 | 
					
						
							|  |  |  |     H{ } clone [ | 
					
						
							|  |  |  |         previous [ (closure) ] with-variable
 | 
					
						
							|  |  |  |     ] keep ; inline
 |