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