extra/game/loop/loop.factor

   1 ! Copyright (C) 2009 Joe Groff.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors calendar continuations destructors kernel
   4 math math.order system timers ui ui.gadgets.worlds vocabs.loader ;
   5 IN: game.loop
   6
   7 TUPLE: game-loop
   8     { tick-interval-nanos integer read-only }
   9     tick-delegate
  10     draw-delegate
  11     { running? boolean }
  12     { tick# integer }
  13     { frame# integer }
  14     tick-timer
  15     draw-timer
  16     benchmark-data ;
  17
  18 GENERIC: tick* ( delegate -- )
  19 GENERIC: draw* ( tick-slice delegate -- )
  20
  21 DEFER: stop-loop
  22
  23 TUPLE: game-loop-error-state error game-loop ;
  24
  25 : ?ui-error ( error -- )
  26     ui-running? [ ui-error ] [ rethrow ] if ;
  27
  28 : game-loop-error ( error game-loop -- )
  29     [ nip stop-loop ] [ \ game-loop-error-state boa ?ui-error ] 2bi ;
  30
  31 : fps ( fps -- nanos )
  32     [ 1,000,000,000 ] dip /i ; inline
  33
  34 <PRIVATE
  35
  36 : last-tick-percent-offset ( loop -- float )
  37     [ draw-timer>> next-nanos>> nano-count - ]
  38     [ tick-interval-nanos>> ] bi /f 1.0 swap -
  39     0.0 1.0 clamp ;
  40
  41 GENERIC#: record-benchmarking 1 ( loop quot -- )
  42
  43 M: object record-benchmarking
  44     call( loop -- ) ;
  45
  46 : redraw ( loop -- )
  47     [ 1 + ] change-frame#
  48     [
  49         [ last-tick-percent-offset ] [ draw-delegate>> ] bi
  50         draw*
  51     ] record-benchmarking ;
  52
  53 : tick ( loop -- )
  54     [ tick-delegate>> tick* ] record-benchmarking ;
  55
  56 : increment-tick ( loop -- )
  57     [ 1 + ] change-tick#
  58     drop ;
  59
  60 PRIVATE>
  61
  62 :: when-running ( loop quot -- )
  63     [
  64         loop
  65         dup running?>> quot [ drop ] if
  66     ] [
  67         loop game-loop-error
  68     ] recover ; inline
  69
  70 : tick-iteration ( loop -- )
  71     [ [ tick ] [ increment-tick ] bi ] when-running ;
  72
  73 : frame-iteration ( loop -- )
  74     [ redraw ] when-running ;
  75
  76 : start-loop ( loop -- )
  77     t >>running?
  78
  79     dup
  80     [ '[ _ tick-iteration ] f ]
  81     [ tick-interval-nanos>> nanoseconds ] bi <timer> >>tick-timer
  82
  83     dup '[ _ frame-iteration ] f 1 milliseconds <timer> >>draw-timer
  84
  85     [ tick-timer>> ] [ draw-timer>> ] bi [ start-timer ] bi@ ;
  86
  87 : stop-loop ( loop -- )
  88     f >>running?
  89     [ tick-timer>> ] [ draw-timer>> ] bi [ stop-timer ] bi@ ;
  90
  91 : <game-loop*> ( tick-interval-nanos tick-delegate draw-delegate -- loop )
  92     f 0 0 f f f game-loop boa ;
  93
  94 : <game-loop> ( tick-interval-nanos delegate -- loop )
  95     dup <game-loop*> ; inline
  96
  97 M: game-loop dispose
  98     stop-loop ;
  99
 100 { "game.loop" "prettyprint" } "game.loop.prettyprint" require-when
 101 { "game.loop" "tools.memory" } "game.loop.benchmark" require-when