2008-07-11 01:47:16 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! Copyright (C) 2008 Slava Pestov.
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! See http://factorcode.org/license.txt for BSD license.
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								USING: accessors kernel models alarms ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-04 18:58:37 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								IN: models.delay
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-11 01:47:16 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								TUPLE: delay < model model timeout alarm ;
							 | 
						
					
						
							
								
									
										
										
										
											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
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: cancel-delay ( delay -- )
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-31 03:51:09 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    alarm>> [ cancel-alarm ] when* ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-04 18:58:37 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: start-delay ( delay -- )
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-11 01:47:16 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    dup
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [ [ f >>alarm update-delay-model ] curry ] [ timeout>> ] bi later
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    >>alarm drop ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-04 18:58:37 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								M: delay model-changed nip dup cancel-delay start-delay ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								M: delay model-activated update-delay-model ;
							 |