extra/game-loop/game-loop.factor

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