Update code base for new alarms api
							parent
							
								
									09d2a7dbc7
								
							
						
					
					
						commit
						e75b85de30
					
				| 
						 | 
				
			
			@ -28,7 +28,7 @@ ERROR: wait-timeout ;
 | 
			
		|||
: wait ( queue timeout status -- )
 | 
			
		||||
    over [
 | 
			
		||||
        [ queue-timeout ] dip suspend
 | 
			
		||||
        [ wait-timeout ] [ cancel-alarm ] if
 | 
			
		||||
        [ wait-timeout ] [ stop-alarm ] if
 | 
			
		||||
    ] [
 | 
			
		||||
        [ drop queue ] dip suspend drop
 | 
			
		||||
    ] if ; inline
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -17,7 +17,7 @@ GENERIC: cancel-operation ( obj -- )
 | 
			
		|||
    [ '[ _ cancel-operation ] ] dip later ;
 | 
			
		||||
 | 
			
		||||
: with-timeout* ( obj timeout quot -- )
 | 
			
		||||
    3dup drop queue-timeout [ nip call ] dip cancel-alarm ;
 | 
			
		||||
    3dup drop queue-timeout [ nip call ] dip stop-alarm ;
 | 
			
		||||
    inline
 | 
			
		||||
 | 
			
		||||
: with-timeout ( obj quot -- )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -14,14 +14,14 @@ TUPLE: delay < model model timeout alarm ;
 | 
			
		|||
        over >>model
 | 
			
		||||
        [ add-dependency ] keep ;
 | 
			
		||||
 | 
			
		||||
: cancel-delay ( delay -- )
 | 
			
		||||
    alarm>> [ cancel-alarm ] when* ;
 | 
			
		||||
: stop-delay ( delay -- )
 | 
			
		||||
    alarm>> [ stop-alarm ] when* ;
 | 
			
		||||
 | 
			
		||||
: start-delay ( delay -- )
 | 
			
		||||
    dup
 | 
			
		||||
    [ [ f >>alarm update-delay-model ] curry ] [ timeout>> ] bi later
 | 
			
		||||
    >>alarm drop ;
 | 
			
		||||
 | 
			
		||||
M: delay model-changed nip dup cancel-delay start-delay ;
 | 
			
		||||
M: delay model-changed nip dup stop-delay start-delay ;
 | 
			
		||||
 | 
			
		||||
M: delay model-activated update-delay-model ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -60,7 +60,7 @@ SYMBOL: blink-interval
 | 
			
		|||
750 milliseconds blink-interval set-global
 | 
			
		||||
 | 
			
		||||
: stop-blinking ( editor -- )
 | 
			
		||||
    [ [ cancel-alarm ] when* f ] change-blink-alarm drop ;
 | 
			
		||||
    [ [ stop-alarm ] when* f ] change-blink-alarm drop ;
 | 
			
		||||
 | 
			
		||||
: start-blinking ( editor -- )
 | 
			
		||||
    [ stop-blinking ] [
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -188,13 +188,15 @@ SYMBOL: drag-timer
 | 
			
		|||
        [ drag-gesture ]
 | 
			
		||||
        300 milliseconds
 | 
			
		||||
        100 milliseconds
 | 
			
		||||
        add-alarm drag-timer get-global >box
 | 
			
		||||
        <alarm>
 | 
			
		||||
        [ drag-timer get-global >box ]
 | 
			
		||||
        [ start-alarm ] bi
 | 
			
		||||
    ] when ;
 | 
			
		||||
 | 
			
		||||
: stop-drag-timer ( -- )
 | 
			
		||||
    hand-buttons get-global empty? [
 | 
			
		||||
        drag-timer get-global ?box
 | 
			
		||||
        [ cancel-alarm ] [ drop ] if
 | 
			
		||||
        [ stop-alarm ] [ drop ] if
 | 
			
		||||
    ] when ;
 | 
			
		||||
 | 
			
		||||
: fire-motion ( -- )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -233,7 +233,7 @@ DEFER: update-audio
 | 
			
		|||
    dup al-sources>> [
 | 
			
		||||
        {
 | 
			
		||||
            [ make-engine-current ]
 | 
			
		||||
            [ update-alarm>> [ cancel-alarm ] when* ]
 | 
			
		||||
            [ update-alarm>> [ stop-alarm ] when* ]
 | 
			
		||||
            [ clips>> clone [ dispose ] each ]
 | 
			
		||||
            [ al-sources>> free-sources ]
 | 
			
		||||
            [
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -44,7 +44,7 @@ M: noise-generator dispose
 | 
			
		|||
    ] 20 milliseconds every :> alarm
 | 
			
		||||
    "Press Enter to stop the test." print
 | 
			
		||||
    readln drop
 | 
			
		||||
    alarm cancel-alarm
 | 
			
		||||
    alarm stop-alarm
 | 
			
		||||
    engine dispose ;
 | 
			
		||||
 | 
			
		||||
MAIN: audio-engine-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -4,11 +4,10 @@ kernel math math.order namespaces system ui ui.gadgets.worlds ;
 | 
			
		|||
IN: game.loop
 | 
			
		||||
 | 
			
		||||
TUPLE: game-loop
 | 
			
		||||
    { tick-interval-micros integer read-only }
 | 
			
		||||
    { tick-interval-nanos integer read-only }
 | 
			
		||||
    tick-delegate
 | 
			
		||||
    draw-delegate
 | 
			
		||||
    { last-tick integer }
 | 
			
		||||
    thread 
 | 
			
		||||
    { running? boolean }
 | 
			
		||||
    { tick-number integer }
 | 
			
		||||
    { frame-number integer }
 | 
			
		||||
| 
						 | 
				
			
			@ -22,11 +21,11 @@ GENERIC: draw* ( tick-slice delegate -- )
 | 
			
		|||
 | 
			
		||||
SYMBOL: game-loop
 | 
			
		||||
 | 
			
		||||
: since-last-tick ( loop -- microseconds )
 | 
			
		||||
    last-tick>> system-micros swap - ;
 | 
			
		||||
: since-last-tick ( loop -- nanos )
 | 
			
		||||
    last-tick>> nano-count swap - ;
 | 
			
		||||
 | 
			
		||||
: tick-slice ( loop -- slice )
 | 
			
		||||
    [ since-last-tick ] [ tick-interval-micros>> ] bi /f 1.0 min ;
 | 
			
		||||
    [ since-last-tick ] [ tick-interval-nanos>> ] bi /f 1.0 min ;
 | 
			
		||||
 | 
			
		||||
CONSTANT: MAX-FRAMES-TO-SKIP 5
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -40,8 +39,8 @@ TUPLE: game-loop-error game-loop error ;
 | 
			
		|||
: game-loop-error ( game-loop error -- )
 | 
			
		||||
    [ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
 | 
			
		||||
 | 
			
		||||
: fps ( fps -- micros )
 | 
			
		||||
    1,000,000 swap /i ; inline
 | 
			
		||||
: fps ( fps -- nanos )
 | 
			
		||||
    1,000,000,000 swap /i ; inline
 | 
			
		||||
 | 
			
		||||
<PRIVATE
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -54,60 +53,60 @@ TUPLE: game-loop-error game-loop error ;
 | 
			
		|||
 | 
			
		||||
: increment-tick ( loop -- )
 | 
			
		||||
    [ 1 + ] change-tick-number
 | 
			
		||||
    dup tick-interval-micros>> [ + ] curry change-last-tick
 | 
			
		||||
    dup tick-interval-nanos>> [ + ] curry change-last-tick
 | 
			
		||||
    drop ;
 | 
			
		||||
 | 
			
		||||
: ?tick ( loop count -- )
 | 
			
		||||
    [ system-micros >>last-tick drop ] [
 | 
			
		||||
        over [ since-last-tick ] [ tick-interval-micros>> ] bi >=
 | 
			
		||||
    [ nano-count >>last-tick drop ] [
 | 
			
		||||
        over [ since-last-tick ] [ tick-interval-nanos>> ] bi >=
 | 
			
		||||
        [ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ]
 | 
			
		||||
        [ 2drop ] if
 | 
			
		||||
    ] if-zero ;
 | 
			
		||||
 | 
			
		||||
: benchmark-micros ( loop -- micros )
 | 
			
		||||
    system-micros swap benchmark-time>> - ;
 | 
			
		||||
: benchmark-nanos ( loop -- nanos )
 | 
			
		||||
    nano-count swap benchmark-time>> - ;
 | 
			
		||||
 | 
			
		||||
PRIVATE>
 | 
			
		||||
 | 
			
		||||
: reset-loop-benchmark ( loop -- )
 | 
			
		||||
    system-micros >>benchmark-time
 | 
			
		||||
: reset-loop-benchmark ( loop -- loop )
 | 
			
		||||
    nano-count >>benchmark-time
 | 
			
		||||
    dup tick-number>> >>benchmark-tick-number
 | 
			
		||||
    dup frame-number>> >>benchmark-frame-number
 | 
			
		||||
    drop ;
 | 
			
		||||
    dup frame-number>> >>benchmark-frame-number ;
 | 
			
		||||
 | 
			
		||||
: benchmark-ticks-per-second ( loop -- n )
 | 
			
		||||
    [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-micros ] tri /f ;
 | 
			
		||||
    [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-nanos ] tri /f ;
 | 
			
		||||
: benchmark-frames-per-second ( loop -- n )
 | 
			
		||||
    [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-micros ] tri /f ;
 | 
			
		||||
    [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-nanos ] tri /f ;
 | 
			
		||||
 | 
			
		||||
: (game-tick) ( loop -- )
 | 
			
		||||
    dup running?>>
 | 
			
		||||
    [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] bi ]
 | 
			
		||||
    [ drop ] if ;
 | 
			
		||||
    
 | 
			
		||||
: game-tick ( alarm loop -- )
 | 
			
		||||
    [ alarm<< ] keep
 | 
			
		||||
: game-tick ( loop -- )
 | 
			
		||||
    dup game-loop [
 | 
			
		||||
        [ (game-tick) ] [ game-loop-error ] recover
 | 
			
		||||
    ] with-variable ;
 | 
			
		||||
 | 
			
		||||
: start-loop ( loop -- )
 | 
			
		||||
    system-micros >>last-tick
 | 
			
		||||
    nano-count >>last-tick
 | 
			
		||||
    t >>running?
 | 
			
		||||
    [ reset-loop-benchmark ]
 | 
			
		||||
    [ [ '[ _ game-tick ] ] keep tick-interval-micros>> microseconds every* ]
 | 
			
		||||
    [ thread<< ] tri ;
 | 
			
		||||
    reset-loop-benchmark
 | 
			
		||||
    [
 | 
			
		||||
        [ '[ _ game-tick ] f ]
 | 
			
		||||
        [ tick-interval-nanos>> nanoseconds ] bi
 | 
			
		||||
        <alarm>
 | 
			
		||||
    ] keep [ alarm<< ] [ drop start-alarm ] 2bi ;
 | 
			
		||||
 | 
			
		||||
: stop-loop ( loop -- )
 | 
			
		||||
    f >>running?
 | 
			
		||||
    f >>thread
 | 
			
		||||
    drop ;
 | 
			
		||||
    alarm>> stop-alarm ;
 | 
			
		||||
 | 
			
		||||
: <game-loop*> ( tick-interval-micros tick-delegate draw-delegate -- loop )
 | 
			
		||||
    system-micros f f 0 0 system-micros 0 0 f
 | 
			
		||||
: <game-loop*> ( tick-interval-nanos tick-delegate draw-delegate -- loop )
 | 
			
		||||
    nano-count f 0 0 nano-count 0 0 f
 | 
			
		||||
    game-loop boa ;
 | 
			
		||||
 | 
			
		||||
: <game-loop> ( tick-interval-micros delegate -- loop )
 | 
			
		||||
: <game-loop> ( tick-interval-nanos delegate -- loop )
 | 
			
		||||
    dup <game-loop*> ; inline
 | 
			
		||||
 | 
			
		||||
M: game-loop dispose
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -108,7 +108,7 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
 | 
			
		|||
 | 
			
		||||
: kill-update-axes ( gadget -- )
 | 
			
		||||
    COLOR: gray <solid> >>interior
 | 
			
		||||
    [ [ cancel-alarm ] when* f ] change-alarm
 | 
			
		||||
    [ [ stop-alarm ] when* f ] change-alarm
 | 
			
		||||
    relayout-1 ;
 | 
			
		||||
 | 
			
		||||
: (update-axes) ( gadget controller-state -- )
 | 
			
		||||
| 
						 | 
				
			
			@ -129,7 +129,7 @@ M: joystick-demo-gadget graft*
 | 
			
		|||
    drop ;
 | 
			
		||||
 | 
			
		||||
M: joystick-demo-gadget ungraft*
 | 
			
		||||
    alarm>> [ cancel-alarm ] when* ;
 | 
			
		||||
    alarm>> [ stop-alarm ] when* ;
 | 
			
		||||
 | 
			
		||||
: joystick-window ( controller -- )
 | 
			
		||||
    [ <joystick-demo-gadget> ] [ product-string ] bi
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -167,7 +167,7 @@ M: key-caps-gadget graft*
 | 
			
		|||
    drop ;
 | 
			
		||||
 | 
			
		||||
M: key-caps-gadget ungraft*
 | 
			
		||||
    alarm>> [ cancel-alarm ] when*
 | 
			
		||||
    alarm>> [ stop-alarm ] when*
 | 
			
		||||
    close-game-input ;
 | 
			
		||||
 | 
			
		||||
M: key-caps-gadget handle-gesture
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -48,4 +48,4 @@ PRIVATE>
 | 
			
		|||
    ] unless ;
 | 
			
		||||
 | 
			
		||||
: stop-site-watcher ( -- )
 | 
			
		||||
    running-site-watcher get [ cancel-alarm ] when* ;
 | 
			
		||||
    running-site-watcher get [ stop-alarm ] when* ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -55,7 +55,7 @@ M: tetris-gadget graft* ( gadget -- )
 | 
			
		|||
    [ [ tick ] curry 100 milliseconds every ] keep alarm<< ;
 | 
			
		||||
 | 
			
		||||
M: tetris-gadget ungraft* ( gadget -- )
 | 
			
		||||
    [ cancel-alarm f ] change-alarm drop ;
 | 
			
		||||
    [ stop-alarm f ] change-alarm drop ;
 | 
			
		||||
 | 
			
		||||
: tetris-window ( -- ) 
 | 
			
		||||
    [
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue