| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | ! Copyright (C) 2006, 2007 Slava Pestov. | 
					
						
							|  |  |  | ! See http://factorcode.org/license.txt for BSD license. | 
					
						
							| 
									
										
										
										
											2013-03-05 13:34:47 -05:00
										 |  |  | USING: assocs kernel sequences sets ;
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | IN: graphs | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2012-08-30 14:31:52 -04:00
										 |  |  | <PRIVATE
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | : if-graph ( vertex edges graph quot -- )
 | 
					
						
							| 
									
										
										
										
											2012-07-17 14:00:38 -04:00
										 |  |  |     dupd [ 3drop ] if ; inline
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2012-07-17 14:00:38 -04:00
										 |  |  | : nest ( key graph -- hash )
 | 
					
						
							|  |  |  |     [ drop H{ } clone ] cache ; inline
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2012-08-30 14:31:52 -04:00
										 |  |  | PRIVATE>
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | : add-vertex ( vertex edges graph -- )
 | 
					
						
							| 
									
										
										
										
											2012-07-17 14:00:38 -04:00
										 |  |  |     [ [ nest dupd set-at ] curry with each ] if-graph ; inline
 | 
					
						
							| 
									
										
										
										
											2008-01-12 04:25:16 -05:00
										 |  |  | 
 | 
					
						
							|  |  |  | : add-vertex* ( vertex edges graph -- )
 | 
					
						
							|  |  |  |     [ | 
					
						
							| 
									
										
										
										
											2012-07-17 14:00:38 -04:00
										 |  |  |         swapd [ [ rot ] dip nest set-at ] 2curry assoc-each
 | 
					
						
							| 
									
										
										
										
											2008-01-12 04:25:16 -05:00
										 |  |  |     ] if-graph ; inline
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | : remove-vertex ( vertex edges graph -- )
 | 
					
						
							| 
									
										
										
										
											2012-07-17 14:00:38 -04:00
										 |  |  |     [ [ at delete-at ] curry with each ] if-graph ; inline
 | 
					
						
							| 
									
										
										
										
											2008-01-12 04:25:16 -05:00
										 |  |  | 
 | 
					
						
							|  |  |  | : remove-vertex* ( vertex edges graph -- )
 | 
					
						
							|  |  |  |     [ | 
					
						
							| 
									
										
										
										
											2012-07-17 14:00:38 -04:00
										 |  |  |         swapd [ [ rot ] dip at delete-at drop ] 2curry assoc-each
 | 
					
						
							| 
									
										
										
										
											2008-01-12 04:25:16 -05:00
										 |  |  |     ] if-graph ; inline
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2012-08-30 14:31:52 -04:00
										 |  |  | <PRIVATE
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2013-03-24 12:34:05 -04:00
										 |  |  | : (closure) ( vertex assoc quot: ( vertex -- assoc ) -- )
 | 
					
						
							| 
									
										
										
										
											2013-03-08 21:08:09 -05:00
										 |  |  |     2over key? [ | 
					
						
							|  |  |  |         3drop
 | 
					
						
							|  |  |  |     ] [ | 
					
						
							|  |  |  |         2over conjoin [ dip ] keep
 | 
					
						
							|  |  |  |         [ [ drop ] 3dip (closure) ] 2curry assoc-each
 | 
					
						
							|  |  |  |     ] if ; inline recursive
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2012-08-30 14:31:52 -04:00
										 |  |  | PRIVATE>
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2013-03-24 12:34:05 -04:00
										 |  |  | : closure ( vertex quot: ( vertex -- assoc ) -- assoc )
 | 
					
						
							| 
									
										
										
										
											2013-03-08 21:08:09 -05:00
										 |  |  |     H{ } clone [ swap (closure) ] keep ; inline
 |