: count-words ( pred -- )
all-words swap count number>string write ; inline
-: print-time ( ms -- )
- 1000 /i
+: print-time ( us -- )
+ 1000000 /i
60 /mod swap
number>string write
" minutes and " write number>string write " seconds." print ;
[
! We time bootstrap
- system-millis
+ system-micros
default-image-name "output-image" set-global
load-components
- system-millis over - core-bootstrap-time set-global
+ system-micros over - core-bootstrap-time set-global
run-bootstrap-init
f error set-global
f error-continuation set-global
- system-millis swap - bootstrap-time set-global
+ system-micros swap - bootstrap-time set-global
print-report
"deploy-vocab" get [
: expire-state ( class -- )
new
- -1/0. system-millis [a,b] >>expires
+ -1/0. system-micros [a,b] >>expires
delete-tuples ;
TUPLE: server-state-manager < filter-responder timeout ;
20 minutes >>timeout ; inline
: touch-state ( state manager -- )
- timeout>> hence timestamp>millis >>expires drop ;
+ timeout>> hence timestamp>micros >>expires drop ;
{ $values { "quot" quotation } }
{ $description "Runs a quotation, gathering statistics about method dispatch and garbage collection, and then prints the total run time." } ;
-{ benchmark system-micros system-millis time } related-words
+{ benchmark system-micros time } related-words
HELP: collect-gc-events
{ $values { "quot" quotation } }
"Getting the current time:"
{ $subsections
system-micros
- system-millis
}
"Getting a monotonically increasing nanosecond count:"
{ $subsections nano-count }
{ $description "Outputs the number of microseconds elapsed since midnight January 1, 1970." }
{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting. For timing code, use " { $link nano-count } "." } ;
-HELP: system-millis ( -- ms )
-{ $values { "ms" integer } }
-{ $description "Outputs the number of milliseconds elapsed since midnight January 1, 1970." }
-{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ;
-
HELP: nano-count ( -- ns )
{ $values { "ns" integer } }
{ $description "Outputs a monotonically increasing count of nanoseconds elapsed since an arbitrary starting time. The difference of two calls to this word allows timing. This word is unaffected by system clock changes." }
: embedded? ( -- ? ) 15 getenv ;
-: system-millis ( -- ms ) system-micros 1000 /i ;
-
: exit ( n -- ) do-shutdown-hooks (exit) ;
SYMBOL: game-loop
-: since-last-tick ( loop -- milliseconds )
- last-tick>> system-millis swap - ;
+: since-last-tick ( loop -- microseconds )
+ last-tick>> system-micros swap - ;
: tick-slice ( loop -- slice )
[ since-last-tick ] [ tick-length>> ] bi /f 1.0 min ;
drop ;
: ?tick ( loop count -- )
- [ system-millis >>last-tick drop ] [
+ [ system-micros >>last-tick drop ] [
over [ since-last-tick ] [ tick-length>> ] bi >=
[ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ]
[ 2drop ] if
[ [ (run-loop) ] [ game-loop-error ] recover ]
with-variable ;
-: benchmark-millis ( loop -- millis )
- system-millis swap benchmark-time>> - ;
+: benchmark-micros ( loop -- micros )
+ system-micros swap benchmark-time>> - ;
PRIVATE>
: reset-loop-benchmark ( loop -- )
- system-millis >>benchmark-time
+ system-micros >>benchmark-time
dup tick-number>> >>benchmark-tick-number
dup frame-number>> >>benchmark-frame-number
drop ;
: benchmark-ticks-per-second ( loop -- n )
- [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-millis ] tri /f ;
+ [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-micros ] tri /f ;
: benchmark-frames-per-second ( loop -- n )
- [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-millis ] tri /f ;
+ [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-micros ] tri /f ;
: start-loop ( loop -- )
- system-millis >>last-tick
+ system-micros >>last-tick
t >>running?
[ reset-loop-benchmark ]
[ [ run-loop ] curry "game loop" spawn ]
drop ;
: <game-loop> ( tick-length delegate -- loop )
- system-millis f f 0 0 system-millis 0 0
+ system-micros f f 0 0 system-micros 0 0
game-loop boa ;
M: game-loop dispose
game-loop
{ tick-slice float initial: 0.0 } ;
-GENERIC: tick-length ( world -- millis )
+GENERIC: tick-length ( world -- micros )
M: game-world draw*
swap >>tick-slice relayout-1 yield ;
[ sobel>> framebuffer>> ] [ dim>> ] bi resize-framebuffer ;
M: bunny-world pref-dim* drop { 1024 768 } ;
-M: bunny-world tick-length drop 1000 30 /i ;
+M: bunny-world tick-length drop 1000000 30 /i ;
M: bunny-world wasd-movement-speed drop 1/160. ;
M: bunny-world wasd-near-plane drop 1/32. ;
M: bunny-world wasd-far-plane drop 256.0 ;
} <render-set> render ;
M: raytrace-world pref-dim* drop { 1024 768 } ;
-M: raytrace-world tick-length drop 1000 30 /i ;
+M: raytrace-world tick-length drop 1000000 30 /i ;
M: raytrace-world wasd-movement-speed drop 1/4. ;
: raytrace-window ( -- )
>>tunnel to-tunnel-start ;
: update-time ( player -- seconds-passed )
- system-millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
+ system-micros swap [ last-move>> - 1000000 / ] [ (>>last-move) ] 2bi ;
-: moved ( player -- ) system-millis swap (>>last-move) ;
+: moved ( player -- ) system-micros swap (>>last-move) ;
: speed-range ( -- range )
max-speed [0,b] ;
: init-sounds ( cpu -- )
init-openal
[ 9 gen-sources swap (>>sounds) ] keep
- [ SOUND-SHOT "resource:extra/space-invaders/resources/Shot.wav" init-sound ] keep
- [ SOUND-UFO "resource:extra/space-invaders/resources/Ufo.wav" init-sound ] keep
+ [ SOUND-SHOT "vocab:space-invaders/resources/Shot.wav" init-sound ] keep
+ [ SOUND-UFO "vocab:space-invaders/resources/Ufo.wav" init-sound ] keep
[ sounds>> SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ] keep
- [ SOUND-BASE-HIT "resource:extra/space-invaders/resources/BaseHit.wav" init-sound ] keep
- [ SOUND-INVADER-HIT "resource:extra/space-invaders/resources/InvHit.Wav" init-sound ] keep
- [ SOUND-WALK1 "resource:extra/space-invaders/resources/Walk1.wav" init-sound ] keep
- [ SOUND-WALK2 "resource:extra/space-invaders/resources/Walk2.wav" init-sound ] keep
- [ SOUND-WALK3 "resource:extra/space-invaders/resources/Walk3.wav" init-sound ] keep
- [ SOUND-WALK4 "resource:extra/space-invaders/resources/Walk4.wav" init-sound ] keep
- [ SOUND-UFO-HIT "resource:extra/space-invaders/resources/UfoHit.wav" init-sound ] keep
+ [ SOUND-BASE-HIT "vocab:space-invaders/resources/BaseHit.wav" init-sound ] keep
+ [ SOUND-INVADER-HIT "vocab:space-invaders/resources/InvHit.Wav" init-sound ] keep
+ [ SOUND-WALK1 "vocab:space-invaders/resources/Walk1.wav" init-sound ] keep
+ [ SOUND-WALK2 "vocab:space-invaders/resources/Walk2.wav" init-sound ] keep
+ [ SOUND-WALK3 "vocab:space-invaders/resources/Walk3.wav" init-sound ] keep
+ [ SOUND-WALK4 "vocab:space-invaders/resources/Walk4.wav" init-sound ] keep
+ [ SOUND-UFO-HIT "vocab:space-invaders/resources/UfoHit.wav" init-sound ] keep
f swap (>>looping?) ;
: cpu-init ( cpu -- cpu )
3drop
] if ;
-: sync-frame ( millis -- millis )
+: sync-frame ( micros -- micros )
#! Sleep until the time for the next frame arrives.
- 1000 60 / >fixnum + system:system-millis - dup 0 >
- [ milliseconds threads:sleep ] [ drop threads:yield ] if system:system-millis ;
+ 1000 60 / >fixnum + system:system-micros - dup 0 >
+ [ milliseconds threads:sleep ] [ drop threads:yield ] if system:system-micros ;
-: invaders-process ( millis gadget -- )
+: invaders-process ( micros gadget -- )
#! Run a space invaders gadget inside a
#! concurrent process. Messages can be sent to
#! signal key presses, etc.
M: invaders-gadget graft* ( gadget -- )
dup cpu>> init-sounds
f over (>>quit?)
- [ system:system-millis swap invaders-process ] curry
+ [ system:system-micros swap invaders-process ] curry
"Space invaders" threads:spawn drop ;
M: invaders-gadget ungraft* ( gadget -- )
VELOCITY-MODIFIER-NORMAL >>velocity-modifier ;
M: terrain-world tick-length
- drop 1000 30 /i ;
+ drop 1000000 30 /i ;
: frustum ( dim -- -x x -y y near far )
dup first2 min v/n
rows>> 1 + 10 / ceiling ;
: update-interval ( tetris -- interval )
- level>> 1 - 60 * 1000 swap - ;
+ level>> 1 - 60 * 1000000 swap - ;
: add-block ( tetris block -- )
over [ board>> ] 2dip current-piece tetromino>> colour>> set-block ;
dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
: update ( tetris -- )
- system-millis over last-update>> -
+ system-micros over last-update>> -
over update-interval > [
dup move-down
- system-millis >>last-update
+ system-micros >>last-update
] when drop ;
: ?update ( tetris -- )