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