| 
									
										
										
										
											2008-07-11 01:47:16 -04:00
										 |  |  | ! Copyright (C) 2008 Slava Pestov. | 
					
						
							|  |  |  | ! See http://factorcode.org/license.txt for BSD license. | 
					
						
							| 
									
										
										
										
											2010-06-10 17:39:13 -04:00
										 |  |  | USING: accessors timers fry kernel models ;
 | 
					
						
							| 
									
										
										
										
											2008-07-04 18:58:37 -04:00
										 |  |  | IN: models.delay | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2010-06-10 17:39:13 -04:00
										 |  |  | TUPLE: delay < model model timeout timer ;
 | 
					
						
							| 
									
										
										
										
											2008-07-04 18:58:37 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | : update-delay-model ( delay -- )
 | 
					
						
							| 
									
										
										
										
											2008-08-31 03:51:09 -04:00
										 |  |  |     [ model>> value>> ] keep set-model ;
 | 
					
						
							| 
									
										
										
										
											2008-07-04 18:58:37 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | : <delay> ( model timeout -- delay )
 | 
					
						
							| 
									
										
										
										
											2008-07-11 01:47:16 -04:00
										 |  |  |     f delay new-model | 
					
						
							|  |  |  |         swap >>timeout | 
					
						
							|  |  |  |         over >>model | 
					
						
							|  |  |  |         [ add-dependency ] keep ;
 | 
					
						
							| 
									
										
										
										
											2008-07-04 18:58:37 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2010-05-21 21:42:12 -04:00
										 |  |  | : stop-delay ( delay -- )
 | 
					
						
							| 
									
										
										
										
											2010-06-10 17:39:13 -04:00
										 |  |  |     timer>> [ stop-timer ] when* ;
 | 
					
						
							| 
									
										
										
										
											2008-07-04 18:58:37 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | : start-delay ( delay -- )
 | 
					
						
							| 
									
										
										
										
											2008-07-11 01:47:16 -04:00
										 |  |  |     dup
 | 
					
						
							| 
									
										
										
										
											2010-06-10 17:39:13 -04:00
										 |  |  |     [ '[ _ f >>timer update-delay-model ] ] [ timeout>> ] bi
 | 
					
						
							| 
									
										
										
										
											2010-05-21 21:48:33 -04:00
										 |  |  |     later | 
					
						
							| 
									
										
										
										
											2010-06-10 17:39:13 -04:00
										 |  |  |     >>timer drop ;
 | 
					
						
							| 
									
										
										
										
											2008-07-04 18:58:37 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2010-05-21 21:42:12 -04:00
										 |  |  | M: delay model-changed nip dup stop-delay start-delay ;
 | 
					
						
							| 
									
										
										
										
											2008-07-04 18:58:37 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | M: delay model-activated update-delay-model ;
 |