extra/game/loop/loop.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors calendar continuations destructors kernel math
   3 math.order namespaces system threads ui ui.gadgets.worlds
   4 sequences ;
   5 IN: game.loop
   6
   7 TUPLE: game-loop
   8     { tick-interval-micros integer read-only }
   9     tick-delegate
  10     draw-delegate
  11     { last-tick integer }
  12     thread
  13     { running? boolean }
  14     { tick-number integer }
  15     { frame-number integer }
  16     { benchmark-time integer }
  17     { benchmark-tick-number integer }
  18     { benchmark-frame-number integer } ;
  19
  20 GENERIC: tick* ( delegate -- )
  21 GENERIC: draw* ( tick-slice delegate -- )
  22
  23 SYMBOL: game-loop
  24
  25 : since-last-tick ( loop -- microseconds )
  26     last-tick>> system-micros swap - ;
  27
  28 : tick-slice ( loop -- slice )
  29     [ since-last-tick ] [ tick-interval-micros>> ] bi /f 1.0 min ;
  30
  31 CONSTANT: MAX-FRAMES-TO-SKIP 5
  32
  33 DEFER: stop-loop
  34
  35 TUPLE: game-loop-error game-loop error ;
  36
  37 : ?ui-error ( error -- )
  38     ui-running? [ ui-error ] [ rethrow ] if ;
  39
  40 : game-loop-error ( game-loop error -- )
  41     [ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
  42
  43 : fps ( fps -- micros )
  44     1,000,000 swap /i ; inline
  45
  46 <PRIVATE
  47
  48 : redraw ( loop -- )
  49     [ 1 + ] change-frame-number
  50     [ tick-slice ] [ draw-delegate>> ] bi draw* ;
  51
  52 : tick ( loop -- )
  53     tick-delegate>> tick* ;
  54
  55 : increment-tick ( loop -- )
  56     [ 1 + ] change-tick-number
  57     dup tick-interval-micros>> [ + ] curry change-last-tick
  58     drop ;
  59
  60 : ?tick ( loop count -- )
  61     [ system-micros >>last-tick drop ] [
  62         over [ since-last-tick ] [ tick-interval-micros>> ] bi >=
  63         [ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ]
  64         [ 2drop ] if
  65     ] if-zero ;
  66
  67 : (run-loop) ( loop -- )
  68     dup running?>>
  69     [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ]
  70     [ drop ] if ;
  71
  72 : run-loop ( loop -- )
  73     dup game-loop
  74     [ [ (run-loop) ] [ game-loop-error ] recover ]
  75     with-variable ;
  76
  77 : benchmark-micros ( loop -- micros )
  78     system-micros swap benchmark-time>> - ;
  79
  80 PRIVATE>
  81
  82 : reset-loop-benchmark ( loop -- )
  83     system-micros >>benchmark-time
  84     dup tick-number>> >>benchmark-tick-number
  85     dup frame-number>> >>benchmark-frame-number
  86     drop ;
  87
  88 : benchmark-ticks-per-second ( loop -- n )
  89     [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-micros ] tri /f ;
  90 : benchmark-frames-per-second ( loop -- n )
  91     [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-micros ] tri /f ;
  92
  93 : start-loop ( loop -- )
  94     system-micros >>last-tick
  95     t >>running?
  96     [ reset-loop-benchmark ]
  97     [ [ run-loop ] curry "game loop" spawn ]
  98     [ (>>thread) ] tri ;
  99
 100 : stop-loop ( loop -- )
 101     f >>running?
 102     f >>thread
 103     drop ;
 104
 105 : <game-loop*> ( tick-interval-micros tick-delegate draw-delegate -- loop )
 106     system-micros f f 0 0 system-micros 0 0
 107     game-loop boa ;
 108
 109 : <game-loop> ( tick-interval-micros delegate -- loop )
 110     dup <game-loop*> ; inline
 111
 112 M: game-loop dispose
 113     stop-loop ;
 114
 115 USE: vocabs.loader
 116
 117 { "game.loop" "prettyprint" } "game.loop.prettyprint" require-when