Update code base for new alarms api

db4
Doug Coleman 2010-05-21 20:42:12 -05:00
parent 09d2a7dbc7
commit e75b85de30
12 changed files with 45 additions and 44 deletions

View File

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

View File

@ -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 -- )

View File

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

View File

@ -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 ] [

View File

@ -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 ( -- )

View File

@ -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 ]
[

View File

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

View File

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

View File

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

View File

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

View File

@ -48,4 +48,4 @@ PRIVATE>
] unless ;
: stop-site-watcher ( -- )
running-site-watcher get [ cancel-alarm ] when* ;
running-site-watcher get [ stop-alarm ] when* ;

View File

@ -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 ( -- )
[